Changeset 29432 in project


Ignore:
Timestamp:
07/28/13 21:00:40 (6 years ago)
Author:
sjamaan
Message:

r7rs: mem*, ass*, list-copy; this completes 6.4: pairs and lists

Location:
release/4/r7rs/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/r7rs/trunk/scheme.base-interface.scm

    r29431 r29432  
    99  #|
    1010  apply
     11  |#
    1112  assoc assq assv
     13  #|
    1214  begin
    1315  binary-port?
     
    107109  library                    ; for "cond-expand"
    108110  |#
    109   list
    110   #|
    111   list-copy
    112   |#
    113   list-ref list-set! list-tail list?
     111  list list-copy list-ref list-set! list-tail list?
    114112  #|
    115113  make-bytevector
     
    122120  map
    123121  max min
     122  |#
    124123  member memq memv
     124  #|
    125125  modulo remainder
    126126  negative? positive?
  • release/4/r7rs/trunk/scheme.base.scm

    r29431 r29432  
    11(module scheme.base ()
    22
    3 (import (except scheme syntax-rules cond-expand))
     3(import (except scheme syntax-rules cond-expand member))
    44(import (except chicken with-exception-handler raise))
    55
     
    166166      (error 'list-set! "out of range"))))
    167167
     168(: member (forall (a b) (a (list-of b) #!optional (procedure (b a) *) ; sic
     169                         -> (or boolean (list-of b)))))
     170
     171;; XXX These aren't exported to the types file!?
     172(define-specialization (member (x (or symbol procedure immediate)) (lst list))
     173  (##core#inline "C_u_i_memq" x lst))
     174(define-specialization (member x (lst (list-of (or symbol procedure immediate))))
     175  (##core#inline "C_u_i_memq" x lst))
     176(define-specialization (member x lst)
     177  (##core#inline "C_i_member" x lst))
     178
     179(define member
     180  (case-lambda
     181   ((x lst) (##core#inline "C_i_member" x lst))
     182   ((x lst eq?)
     183    (let lp ((lst lst))
     184      (cond ((null? lst) #f)
     185            ((eq? (car lst) x) lst)
     186            (else (lp (cdr lst))))))))
     187
     188
     189(: assoc (forall (a b c) (a (list-of (pair b c)) #!optional (procedure (b a) *) ; sic
     190                            -> (or boolean (list-of (pair b c))))))
     191
     192;; XXX These aren't exported to the types file!?
     193(define-specialization (assoc (x (or symbol procedure immediate)) (lst (list-of pair)))
     194  (##core#inline "C_u_i_assq" x lst))
     195(define-specialization (assoc x (lst (list-of (pair (or symbol procedure immediate) *))))
     196  (##core#inline "C_u_i_assq" x lst))
     197(define-specialization (assoc x lst)
     198  (##core#inline "C_i_assoc" x lst))
     199
     200(define assoc
     201  (case-lambda
     202   ((x lst) (##core#inline "C_i_assoc" x lst))
     203   ((x lst eq?)
     204    (let lp ((lst lst))
     205      (cond ((null? lst) #f)
     206            ((not (pair? (car lst)))
     207             (error 'assoc "unexpected non-pair in list" (car lst)))
     208            ((eq? (caar lst) x) (car lst))
     209            (else (lp (cdr lst))))))))
     210
     211
     212(: list-copy (forall (a) ((list-of a) -> (list-of a))))
     213
     214;; TODO: Test if this is the quickest way to do this, or whether we
     215;; should just cons recursively like our SRFI-1 implementation does.
     216(define (list-copy lst)
     217  (let lp ((res '())
     218           (lst lst))
     219    (if (null? lst)
     220        (##sys#fast-reverse res)
     221        (lp (cons (car lst) res) (cdr lst)))))
     222
    168223;;;
    169224;;; 6.11. Exceptions
  • release/4/r7rs/trunk/tests/run.scm

    r29431 r29432  
    198198    ;; Should be an error?
    199199    #;(list-set! '(0 1 2) 1 "oops")
    200     ))
     200    (test-error (list-set! (list 1 2 3) 3 'foo)))
     201
     202  (test-group "mem*"
     203    (test '(a b c) (memq 'a '(a b c)))
     204    (test '(b c) (memq 'b '(a b c)))
     205    (test #f (memq 'a '(b c d)))
     206    (test #f (memq (list 'a) '(b (a) c)))
     207    (test '((a) c) (member (list 'a) '(b (a) c)))
     208    (test '("b" "c") (member "B" '("a" "b" "c") string-ci=?))
     209    (test '(101 102) (memq 101 '(100 101 102))) ; unspecified in R7RS
     210    (test '(101 102) (memv 101 '(100 101 102))))
     211
     212  (test-group "ass*"
     213    (define e '((a 1) (b 2) (c 3)))
     214    (test '(a 1) (assq 'a e))
     215    (test '(b 2) (assq 'b e))
     216    (test #f (assq 'd e))
     217    (test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
     218    (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
     219    (test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =))
     220    (test '(5 7) (assq 5 '((2 3) (5 7) (11 13)))) ; unspecified in R7RS
     221    (test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
     222    (test-error (assq 5 '(5 6 7)))
     223    (test-error (assv 5 '(5 6 7)))
     224    (test-error (assoc 5 '(5 6 7))))
     225
     226  (test-group "list-copy"
     227   (define a '(1 8 2 8)) ; a may be immutable
     228   (define b (list-copy a))
     229   (set-car! b 3)        ; b is mutable
     230   (test '((3 8 2 8)) (list b))
     231   (test '((1 8 2 8)) (list a))))
    201232
    202233(define-syntax catch
Note: See TracChangeset for help on using the changeset viewer.