git.gag.com Git - fw/altos/blob - src/scheme/test/ao_scheme_test.scheme

   1                                         ; Basic syntax tests
   2
   3 (define _assert-eq_
   4   (macro (a b)
   5            (list cond
   6                  (list (list eq? a b)
   7                        )
   8                  (list 'else
   9                        (list display "failed: ")
  10                        (list write (list quote a))
  11                        (list newline)
  12                        (list exit 1)
  13                        )
  14                  )
  15            )
  16   )
  17
  18 (define _assert-equal_
  19   (macro (a b)
  20     (list cond
  21           (list (list equal? a b)
  22                 )
  23           (list 'else
  24                 (list display "failed: ")
  25                 (list write (list quote a))
  26                 (list newline)
  27                 (list exit 1)
  28                 )
  29           )
  30     )
  31   )
  32
  33 (_assert-eq_ (or #f #t) #t)
  34 (_assert-eq_ (and #t #f) #f)
  35 (_assert-eq_ (if (> 3 2) 'yes) 'yes)
  36 (_assert-eq_ (if (> 3 2) 'yes 'no) 'yes)
  37 (_assert-eq_ (if (> 2 3) 'no 'yes) 'yes)
  38 (_assert-eq_ (if (> 2 3) 'no) #f)
  39
  40 (_assert-eq_ (letrec ((a 1) (b a)) (+ a b)) 2)
  41
  42 (_assert-eq_ (equal? '(a b c) '(a b c)) #t)
  43 (_assert-eq_ (equal? '(a b c) '(a b b)) #f)
  44
  45 (_assert-equal_ (cdar '((1 2) (3 4))) '(2))
  46
  47 (_assert-equal_ (cddr '(1 2 3)) '(3))
  48
  49 (_assert-equal_ (caddr '(1 2 3 4)) 3)
  50
  51 (_assert-equal_ (member '(2) '((1) (2) (3)))  '((2) (3)))
  52 (_assert-equal_ (member '(4) '((1) (2) (3))) #f)
  53
  54 (_assert-equal_ (memq 2 '(1 2 3)) '(2 3))
  55 (_assert-equal_ (memq 4 '(1 2 3)) #f)
  56 (_assert-equal_ (memq '(2) '((1) (2) (3))) #f)
  57
  58 (_assert-equal_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1))
  59 (_assert-equal_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2))
  60 (_assert-equal_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3))
  61
  62 (_assert-equal_ (map cadr '((a b) (d e) (g h))) '(b e h))
  63
  64 (_assert-equal_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo)))
  65
  66                                         ; Advanced syntax tests
  67
  68 (_assert-eq_ (equal? '(a b c) '(a b c)) #t)
  69 (_assert-eq_ (equal? '(a b c) '(a b b)) #f)
  70 (_assert-eq_ (equal? #(1 2 3) #(1 2 3)) #t)
  71 (_assert-eq_ (equal? #(1 2 3) #(4 5 6)) #f)
  72 (_assert-equal_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo)))
  73 (_assert-equal_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3)
  74 (_assert-equal_ (when #t (+ 1 2)) 3)
  75 (_assert-equal_ (when #f (+ 1 2)) #f)
  76 (_assert-equal_ (unless #f (+ 2 3)) 5)
  77 (_assert-equal_ (unless #t (+ 2 3)) #f)
  78 (_assert-equal_ (cdar '((1 2) (3 4))) '(2))
  79 (_assert-equal_ (cddr '(1 2 3)) '(3))
  80 (_assert-equal_ (caddr '(1 2 3 4)) 3)
  81 (_assert-equal_ (reverse '(1 2 3)) '(3 2 1))
  82 (_assert-equal_ (make-list 10 'a) '(a a a a a a a a a a))
  83 (_assert-equal_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f))
  84 (_assert-equal_ (let ((a 0))
  85                   (for-each (lambda (b) (set! a (+ a b))) '(1 2 3))
  86                   a
  87                   )
  88                 6)
  89 (_assert-equal_ (call-with-current-continuation
  90                  (lambda (exit)
  91                    (for-each (lambda (x)
  92                                (if (negative? x)
  93                                    (exit x)))
  94                              '(54 0 37 -3 245 19))
  95                    )
  96                  )
  97                 -3)
  98 (_assert-equal_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "one")
  99 (_assert-equal_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "two")
 100 (_assert-equal_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "three")
 101 (_assert-equal_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "else")
 102 (_assert-equal_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) "three")) (12 "twelve") (else "else")) "twelve")
 103 (_assert-equal_ (do ((x 1 (+ x 1))
 104            (y 0)
 105            )
 106           ((= x 10) y)
 107         (set! y (+ y x))
 108         )
 109       45)
 110
 111 (_assert-equal_ (do ((vec (make-vector 5))
 112                      (i 0 (+ i 1)))
 113                     ((= i 5) vec)
 114                   (vector-set! vec i i))
 115                 #(0 1 2 3 4))
 116
 117                                         ; vector tests
 118
 119 (_assert-equal_ (vector->string #(#\a #\b #\c) 0 2) "ab")
 120 (_assert-equal_ (string->vector "hello" 0 2) #(#\h #\e))
 121 (_assert-equal_ (vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) #("f" "f" "f" "f" "f" "t" "t" "t" "t" "t"))
 122 (_assert-equal_ (vector-copy #(1 2 3) 0 3) #(1 2 3))
 123 (_assert-equal_ (vector-append #(1 2 3) #(4 5 6) #(7 8 9)) #(1 2 3 4 5 6 7 8 9))
 124 (_assert-equal_ (vector-fill! (make-vector 3) #t 1 2) #(#f #t #f))
 125 (_assert-equal_ (vector-map + #(1 2 3) #(4 5 6)) #(5 7 9))
 126
 127                                         ; string tests
 128
 129 (_assert-equal_ (string #\a #\b #\c) "abc")
 130 (_assert-equal_ (string-map (lambda (x) (+ 1 x)) "HAL") "IBM")
 131 (_assert-equal_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello     ")
 132 (_assert-equal_ (string-copy! (make-string 10) 1 "hello" 0 5) " hello    ")
 133 (_assert-equal_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello     ")
 134 (_assert-equal_ (string-copy "hello" 0 1) "h")
 135 (_assert-equal_ (string-copy "hello" 1) "ello")
 136 (_assert-equal_ (string-copy "hello") "hello")
 137 (_assert-equal_ (string-fill! (make-string 10) #\a) "aaaaaaaaaa")
 138 (_assert-equal_ (string-fill! (make-string 10) #\a 1 2) " a        ")
 139 ;(_assert-equal_ (string-for-each write-char "IBM\n") #t)
 140
 141                                         ; char tests
 142
 143 (_assert-equal_ (char? #\q) #t)
 144 (_assert-equal_ (char? "h") #f)
 145 (_assert-equal_ (char-upper-case? #\a) #f)
 146 (_assert-equal_ (char-upper-case? #\B) #t)
 147 (_assert-equal_ (char-upper-case? #\0) #f)
 148 (_assert-equal_ (char-upper-case? #\space) #f)
 149 (_assert-equal_ (char-lower-case? #\a) #t)
 150 (_assert-equal_ (char-lower-case? #\B) #f)
 151 (_assert-equal_ (char-lower-case? #\0) #f)
 152 (_assert-equal_ (char-lower-case? #\space) #f)
 153 (_assert-equal_ (char-alphabetic? #\a) #t)
 154 (_assert-equal_ (char-alphabetic? #\B) #t)
 155 (_assert-equal_ (char-alphabetic? #\0) #f)
 156 (_assert-equal_ (char-alphabetic? #\space) #f)
 157 (_assert-equal_ (char-numeric? #\a) #f)
 158 (_assert-equal_ (char-numeric? #\B) #f)
 159 (_assert-equal_ (char-numeric? #\0) #t)
 160 (_assert-equal_ (char-numeric? #\space) #f)
 161 (_assert-equal_ (char-whitespace? #\a) #f)
 162 (_assert-equal_ (char-whitespace? #\B) #f)
 163 (_assert-equal_ (char-whitespace? #\0) #f)
 164 (_assert-equal_ (char-whitespace? #\space) #t)
 165 (_assert-equal_ (char-upcase #\a) #\A)
 166 (_assert-equal_ (char-upcase #\B) #\B)
 167 (_assert-equal_ (char-upcase #\0) #\0)
 168 (_assert-equal_ (char-upcase #\space) #\space)
 169 (_assert-equal_ (char-downcase #\a) #\a)
 170 (_assert-equal_ (char-downcase #\B) #\b)
 171 (_assert-equal_ (char-downcase #\0) #\0)
 172 (_assert-equal_ (char-downcase #\space) #\space)
 173 (_assert-equal_ (digit-value #\1) 1)
 174 (_assert-equal_ (digit-value #\a) #f)
 175