Changeset 29431 in project


Ignore:
Timestamp:
07/28/13 19:10:28 (6 years ago)
Author:
sjamaan
Message:

r7rs: reverse, list-tail, list-ref and list-set!

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

Legend:

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

    r29429 r29431  
    103103  let-values let*-values
    104104  |#
    105   let-syntax
    106   letrec-syntax
     105  let-syntax letrec-syntax
    107106  #|
    108107  library                    ; for "cond-expand"
     
    111110  #|
    112111  list-copy
    113   list-ref list-set!
    114   list-tail
    115   |#
    116   list?
     112  |#
     113  list-ref list-set! list-tail list?
    117114  #|
    118115  make-bytevector
     
    162159  read-u8
    163160  real?
     161  |#
    164162  reverse
     163  #|
    165164  round
    166165  set!
  • release/4/r7rs/trunk/scheme.base.scm

    r29429 r29431  
    135135    (##sys#check-integer n 'make-list)
    136136    (unless (fx>= n 0)
    137       (error 'make-list "Not a positive integer" n))
     137      (error 'make-list "not a positive integer" n))
    138138    (do ((i n (fx- i 1))
    139139         (result '() (cons fill result)))
    140         ((fx<= i 0) result)))))
     140        ((fx= i 0) result)))))
     141
     142
     143(: list-tail (forall (x) ((list-of x) fixnum -> (list-of x))))
     144
     145(define (list-tail l n)
     146  (##sys#check-integer n 'list-tail)
     147  (unless (fx>= n 0)
     148    (error 'list-tail "not a positive integer" n))
     149  (do ((i n (fx- i 1))
     150       (result l (cdr result)))
     151      ((fx= i 0) result)
     152    (when (null? result)
     153      (error 'list-tail "out of range"))))
     154
     155
     156(: list-set! (list fixnum -> undefined))
     157
     158(define (list-set! l n obj)
     159  (##sys#check-integer n 'list-set!)
     160  (unless (fx>= n 0)
     161    (error 'list-set! "not a positive integer" n))
     162  (do ((i n (fx- i 1))
     163       (l l (cdr l)))
     164      ((fx= i 0) (set-car! l obj))
     165    (when (null? l)
     166      (error 'list-set! "out of range"))))
    141167
    142168;;;
  • release/4/r7rs/trunk/tests/run.scm

    r29429 r29431  
    163163    (test '(a b . c) (append '(a b) 'c))
    164164    (test-error (append 'x '()))
    165     (test-error (append '(x) 'y '()))))
     165    (test-error (append '(x) 'y '())))
     166
     167  (test-group "reverse"
     168    (test '(c b a) (reverse '(a b c)))
     169    (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
     170    (test '() (reverse '()))
     171    (test-error (reverse '(a . b)))
     172    (test-error (reverse '(a b) '(c d)))
     173    (test-error (reverse 'a))
     174    (test-error (reverse '#(a b c)))
     175    (test-error (reverse "foo")))
     176
     177  (test-group "list-tail"
     178    (test '(a b c d e f) (list-tail '(a b c d e f) 0))
     179    (test '(d e f) (list-tail '(a b c d e f) 3))
     180    (test '() (list-tail '(a b c d e f) 6))
     181    (test '() (list-tail '() 0))
     182    (test-error (list-tail '(a b c d e f) -1))
     183    (test-error (list-tail '(a b c d e f) 7))
     184    (test-error (list-tail '(a b c d e . f) 6)))
     185
     186  (test-group "list-ref"
     187    (test 'a (list-ref '(a b c d) 0))
     188    (test 'b (list-ref '(a b c d) 1))
     189    (test 'c (list-ref '(a b c d) 2))
     190    (test 'd (list-ref '(a b c d) 3))
     191    (test-error (list-ref '(a b c d) 4))
     192    (test-error (list-ref '(a b c d) -1)))
     193
     194  (test-group "list-set!"
     195    (let ((ls (list 'one 'two 'five!)))
     196      (list-set! ls 2 'three)
     197      (test '(two three) (cdr ls)))
     198    ;; Should be an error?
     199    #;(list-set! '(0 1 2) 1 "oops")
     200    ))
    166201
    167202(define-syntax catch
Note: See TracChangeset for help on using the changeset viewer.