scm.mes: add list-ref.
[mes.git] / test.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; test.mes: This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;; The Maxwell Equations of Software -- John McCarthy page 13
22 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
23
24 (define result
25   (let ((pass 0)
26         (fail 0))
27     (lambda (. t)
28       (cond ((null? t) (list pass fail))
29             ((car t) (display ": pass") (newline) (set! pass (+ pass 1)))
30             (#t (display ": fail") (newline) (set! fail (+ fail 1)))))))
31
32
33 (define guile? (defined? 'gc))
34 (when guile?
35   (module-define! (current-module) 'builtin? (lambda (. x) #t))
36   (use-modules (srfi srfi-1)))
37
38 (define (seq? a b)
39   (or (eq? a b)
40       (begin
41         (display ": fail")
42         (newline)
43         (display "expected: ")
44         (display b) (newline)
45         (display "actual: ")
46         (display a)
47         (newline)
48         #f)))
49
50 (define (sequal? a b)
51   (or (equal? a b)
52       (begin
53         (display ": fail")
54         (newline)
55         (display "expected: ")
56         (display b) (newline)
57         (display "actual: ")
58         (display a)
59         (newline)
60         #f)))
61
62
63 (define-macro (pass-if name t)
64   `(let ()
65      (display "test: ") (display ,name)
66      (result ,t)))
67
68 (define-macro (pass-if-not name f)
69   `(let ()
70      (display "test: ") (display ,name)
71      (result (not ,f))))
72
73 (pass-if "first dummy" #t)
74 (pass-if-not "second dummy" #f)
75
76 (pass-if "and" (seq? (and 1) 1))
77 (pass-if "and 2" (seq? (and 1 (= 0 1) #f) #f))
78 (pass-if "or" (seq? (or) #f))
79 (pass-if "or 2" (seq? (or 1) 1))
80 (pass-if "or 3" (seq? (or #f (= 0 1) 3) 3))
81 (pass-if "let" (seq? (let ((p 5) (q 6)) (+ p q)) 11))
82 (pass-if "let loop" (sequal? (let loop ((lst '(3 2 1)))
83                               (if (null? lst) '()
84                                   (cons (car lst)
85                                         (loop (cdr lst))))) '(3 2 1)))
86 (pass-if "quasiquote" (let ((cc 'bb)) (sequal? `(aa bb ,cc) '(aa bb bb))))
87 (pass-if "let* comments" (seq? (let* ((aa 2)
88                                      (bb (+ aa 3))
89                                      #! boo !#
90                                      ;;(bb 4)
91                                      )
92                                 bb)
93                               5))
94
95 (pass-if "map" (sequal? (map identity '(1 2 3 4)) '(1 2 3 4)))
96 (pass-if "map 2 " (sequal? (map (lambda (i a) (cons i a)) '(1 2 3 4) '(a b c d))
97                            '((1 . a) (2 . b) (3 . c) (4 . d))))
98 (pass-if "for-each" (sequal? (let ((acc '())) (for-each (lambda (x) (set! acc (cons x acc))) '(1 2 3 4)) acc) '(4 3 2 1)))
99 (define xxxa 0)
100 (pass-if "set! " (seq? (begin (set! xxxa 1) xxxa) 1))
101 (pass-if "set! 2" (seq? (let ((a 0)) (set! a 1) a) 1))
102 (pass-if "+" (seq? (+ 1 2 3) 6))
103 (pass-if "*" (seq? (* 3 3 3) 27))
104 (pass-if "/" (seq? (/ 9 3) 3))
105 (pass-if "remainder" (seq? (remainder 11 3) 2))
106 (pass-if "modulo" (seq? (modulo 11 3) 2))
107 (pass-if "expt" (seq? (expt 2 3) 8))
108 (pass-if "logior" (seq? (logior 0 1 2 4) 7))
109
110 (pass-if "=" (seq? 3 '3))
111 (pass-if "= 2" (not (= 3 '4)))
112 (pass-if "if" (seq? (if #t 'true) 'true))
113 (pass-if "if 2" (seq? (if (seq? 0 '0) 'true 'false) 'true))
114 (pass-if "if 3" (seq? (if (= 1 2) 'true 'false) 'false))
115 (pass-if "letrec" (seq? (letrec ((factorial (lambda (n)
116                                            (if (= n 1) 1
117                                                (* n (factorial (- n 1)))))))
118                        (factorial 4))
119                      24))
120 (pass-if "begin" (seq? (begin 'a 'b (+ 1 2)) 3))
121 (pass-if "string-append" (sequal? (string-append "a" "b" "c") "abc"))
122 (pass-if "eq?" (not (eq? (string-append "a" "b" "c") "abc")))
123 (pass-if "string-length" (seq? (string-length (string-append "a" "b" "c")) 3))
124 (pass-if "char" (seq? (char->integer #\A) 65))
125 (pass-if "char 2" (seq? (char->integer #\101) (char->integer #\A)))
126 (pass-if "char 3" (seq? (integer->char 10) #\newline))
127 (pass-if "char 4" (seq? (integer->char 32) #\space))
128 (pass-if "string " (sequal? (string #\a #\space #\s #\t #\r #\i #\n #\g) "a string"))
129 (pass-if "length" (seq? (length '()) 0))
130 (pass-if "length 2" (seq? (length '(a b c)) 3))
131 (pass-if "vector?" (vector? #(1 2 c)))
132 (pass-if "vector-length" (seq? (vector-length #(1)) 1))
133 (pass-if "list->vector" (sequal? (list->vector '(a b c)) #(a b c)))
134 (pass-if "vector" (sequal? #(vector 0 1 2) #(vector 0 1 2)))
135 (when (not guile?)
136   (pass-if "make-vector" (sequal? (make-vector 3) #(*unspecified* *unspecified* *unspecified*))))
137 (pass-if "make-vector 2" (sequal? (make-vector 3 0) #(0 0 0)))
138 (pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1))
139 (when (not guile?) ;; hmm guile segfaults
140   (pass-if "vector-set" (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #(0 q)))
141   (pass-if "vector-set 2" (not (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #()))))
142 (pass-if "equal?" (sequal? #(1) #(1)))
143 (pass-if "equal?" (not (equal? #() #(1))))
144 (pass-if "memq" (sequal? (memq 'a '(a b c)) '(a b c)))
145 (pass-if "memq" (sequal? (memq 'b '(a b c)) '(b c)))
146 (pass-if "memq" (seq? (memq 'd '(a b c)) #f))
147 (pass-if "member" (sequal? (member '(a) '((a) b c)) '((a) b c)))
148 (pass-if "assq-ref" (seq? (assq-ref '((b . 1) (c . 2)) 'c) 2))
149 (pass-if "assq-ref 2" (seq? (assq-ref '((b . 1) (c . 2)) 'a) #f))
150 (pass-if "assq-set!" (sequal? (assq-set! '((b . 1)) 'a 0) '((a . 0) (b . 1))))
151 (pass-if "assq-set! 2" (sequal? (assq-set! '((a . 0)) 'a 1) '((a . 1))))
152 (pass-if "assoc" (sequal? (assoc '(a . 0) '((a . 0) (b . 1) ((a . 0) aa))) '((a . 0) aa)))
153
154 ;; works, but debugging is foo
155 ;; (cond ((defined? 'loop2)
156 ;;        (display "mes:values broken after loop2")
157 ;;        (newline))
158 ;;       (#t
159 ;;        (values 0 1)
160 ;;        (display "(values 0 1): ")
161 ;;        (display (values 0 1))
162 ;;        (newline)
163
164 ;;        (display "call-with-values ==> 6: ")
165 ;;        (display
166 ;;         (call-with-values (lambda () (values 1 2 3))
167 ;;           (lambda (a b c) (+ a b c))))
168 ;;        (newline)
169 ;;        (display "call-with-values ==> 1: ")
170 ;;        (display ((lambda (x) x) (values 1 2 3)))
171 ;;        (newline)))
172
173 (pass-if "builtin?" (builtin? eval))
174 ;;(pass-if "builtin?" (builtin? cond))
175 (pass-if "procedure?" (procedure? builtin?))
176 (pass-if "procedure?" (procedure? procedure?))
177 (when (not guile?)
178   (pass-if "gensym" (seq? (gensym) 'g0))
179   (pass-if "gensym" (seq? (gensym) 'g1))
180   (pass-if "gensym" (seq? (gensym) 'g2)))
181 (pass-if "unquote" (sequal? `,(list 1 2 3 4) '(1 2 3 4)))
182 (pass-if "splice" (sequal? `('boo ,@'(bah baz) 1 2) '((quote boo) bah baz 1 2)))
183 (pass-if "splice" (sequal? `(1 ,@(list 2 3) 4) '(1 2 3 4)))
184 (pass-if "splice" (sequal? (let ((s-r '(2 3))) `(1 ,@s-r 4)) '(1 2 3 4)))
185 (pass-if "unquote" (sequal? `(1 2 '(,(+ 1 2))) '(1 2 '(3))))
186 (pass-if "when" (seq? (when #t 'true) 'true))
187 (pass-if "when 2" (seq? (when #f 'true) *unspecified*))
188
189 (define b 0)
190 (define x (lambda () b))
191 (define (x) b)
192 (pass-if "closure" (seq? (x) 0))
193 (define (c b)
194   (x))
195 (pass-if "closure 2" (seq? (c 1) 0))
196
197 (define (x)
198   (define b 1)
199   (define (y) b)
200   (set! b 0)
201   (list b
202         (let ((b 2))
203           (y))))
204
205 (pass-if "closure 3" (sequal? (x) '(0 0)))
206
207 (pass-if "closure 4 "
208   (seq? (let ()
209           (let ((count (let ((counter 0))
210                          (lambda ()
211                            counter))))
212             (count)))
213         0))
214
215 (pass-if "closure 5 "
216          (seq?
217           (let ()
218             (define name? 2)
219             (define (foo)
220               (define name? 0)
221               (lambda () name?))
222             ((foo)))
223           0))
224
225 (pass-if "closure 6 "
226          (seq?
227           (let ()
228             (define foo
229               (lambda ()
230                 (define name? symbol?)
231                 (lambda ()
232                   (name? 'boo))))
233             ((foo)))
234                #t))
235
236 (pass-if "last-pair " (sequal? (last-pair '(1 2 3 4)) '(4)))
237 (pass-if "last-pair 2" (seq? (last-pair '()) '()))
238 ;; (pass-if "circular-list? "
239 ;;   (seq?
240 ;;    (let ((x (list 1 2 3 4)))
241 ;;      (set-cdr! (last-pair x) (cddr x))
242 ;;      (circular-list? x))
243 ;;    #t))
244
245 (pass-if "reverse" (sequal? (reverse '(1 2 3)) '(3 2 1)))
246
247 (pass-if "cond-expand" (sequal? (cond-expand (foobar #f) (mes (display ": pass: *YAY*") 'mes) (guile (display ": pass: *GUILE*") 'mes)) 'mes))
248
249 (begin (define *top-begin-a* '*top-begin-a*))
250 (pass-if "top begin " (seq? (and (defined? '*top-begin-a*) *top-begin-a*) '*top-begin-a*))
251
252 (let () (define *top-let-a* '*top-let-a*) #f)
253 (pass-if "top let " (seq? (and (defined? '*top-let-a*) *top-let-a*) #f))
254
255 (pass-if "apply identity" (seq? (apply identity '(0)) 0))
256 (pass-if "apply identity 2" (sequal? (apply identity '((0 1))) '(0 1)))
257 (pass-if "apply append" (sequal? (apply append '((1 2) (3 4))) '(1 2 3 4)))
258
259 (pass-if "=" (seq? (=) #t))
260 (pass-if "= 1" (seq? (= 0) #t))
261 (pass-if "= 2" (seq? (= 0 0) #t))
262 (pass-if "= 3" (seq? (= 0 0) #t))
263 (pass-if "= 4" (seq? (= 0 1 0) #f))
264
265 (pass-if "<" (seq? (<) #t))
266 (pass-if "< 1" (seq? (< 0) #t))
267 (pass-if "< 2" (seq? (< 0 1) #t))
268 (pass-if "< 3" (seq? (< 1 0) #f))
269 (pass-if "< 4" (seq? (< 0 1 2) #t))
270 (pass-if "< 5" (seq? (< 0 2 1) #f))
271
272 (pass-if ">" (seq? (>) #t))
273 (pass-if "> 1" (seq? (> 0) #t))
274 (pass-if "> 2" (seq? (> 1 0) #t))
275 (pass-if "> 3" (seq? (> 0 1) #f))
276 (pass-if "> 4" (seq? (> 2 1 0) #t))
277 (pass-if "> 5" (seq? (> 1 2 0) #f))
278
279 (pass-if ">=" (seq? (>= 3 2 1) #t))
280 (pass-if ">= 2" (seq? (>= 1 2 3) #f))
281
282 (pass-if "<=" (seq? (<= 3 2 1) #f))
283 (pass-if "<= 2" (seq? (<= 1 2 3) #t))
284
285 (pass-if "max" (seq? (max 0) 0))
286 (pass-if "max 1" (seq? (max 0 1) 1))
287 (pass-if "max 2" (seq? (max 1 0 2) 2))
288
289 (pass-if "min" (seq? (min 0) 0))
290 (pass-if "min 1" (seq? (min 0 1) 0))
291 (pass-if "min 2" (seq? (min 1 0 2) 0))
292
293 (pass-if "list-ref" (seq? (list-ref '(0 1 2) 1) 1))
294
295 (pass-if "do" (sequal? (let ((acc '())) (do ((i 0 (+ i 1))) ((>= i 3)) (set! acc (cons i acc))) acc) '(2 1 0)))
296
297 (newline)
298 (display "passed: ") (display (car (result))) (newline)
299 (display "failed: ") (display (cadr (result))) (newline)
300 (display "total: ") (display (apply + (result))) (newline)
301
302 (exit (cadr (result)))