~ chicken-core (chicken-5) /tests/functor-tests.scm

  1;;;; functor-tests.scm
  2
  3
  4(import chicken.fixnum chicken.port chicken.pretty-print)
  5
  6
  7(include "test.scm")
  8(test-begin "functor tests")
  9
 10;;
 11
 12
 13(include "test-queue")
 14(include "breadth-first")
 15
 16(define (take lst n)
 17  (if (fx<= n 0)
 18      '()
 19      (cons (car lst) (take (cdr lst) (fx- n 1)))))
 20
 21
 22(module queue1 QUEUE
 23  (import (rename scheme
 24		  (null? empty?)
 25		  (car head)
 26		  (cdr dequeue)))
 27  (define empty-queue '())
 28  (define (enqueue q x) (append q (list x)))
 29  ;(define empty? null?)
 30  ;(define head car)
 31  ;(define dequeue cdr) 
 32  )
 33
 34
 35(module queue2 QUEUE
 36  (import (rename scheme (not empty?)) chicken.base)
 37  (define-record entry q x)
 38  (define empty-queue #f)
 39  (define enqueue make-entry)
 40  ;(define empty? not)
 41  (define (head q)
 42    (let ((q2 (entry-q q)))
 43      (if (empty? q2) (entry-x q) (head q2))))
 44  (define (dequeue q) 
 45    (let ((q2 (entry-q q)))
 46      (if (empty? q2) 
 47	  empty-queue 
 48	  (make-entry (dequeue q2) (entry-x q)))) ))
 49
 50
 51(module queue3 QUEUE
 52  (import scheme chicken.base)
 53  (define-record queue heads tails)
 54  (define empty-queue (make-queue '() '()))
 55  (define (norm q)
 56    (if (null? (queue-heads q))
 57	(make-queue (reverse (queue-tails q)) '())
 58	q))
 59  (define (enqueue q x)
 60    (norm (make-queue (queue-heads q) (cons x (queue-tails q)))))
 61  (define (empty? q)
 62    (and (null? (queue-heads q)) (null? (queue-tails q))))
 63  (define (head q) (car (queue-heads q)))
 64  (define (dequeue q)
 65    (norm (make-queue (cdr (queue-heads q)) (queue-tails q)))) )
 66
 67
 68(module test-q1 = (test-queue queue1))
 69(module test-q2 = (test-queue queue2))
 70(module test-q3 = (test-queue queue3))
 71
 72(import (rename test-q1 (list->queue l2q1) (queue->list q2l1)))
 73(import (rename test-q2 (list->queue l2q2) (queue->list q2l2)))
 74(import (rename test-q3 (list->queue l2q3) (queue->list q2l3)))
 75
 76(define (list-tabulate n proc)
 77  (let loop ((i 0))
 78    (if (fx>= i n)
 79	'()
 80	(cons (proc i) (loop (fx+ i 1))))))
 81
 82(define long-list (list-tabulate (cond-expand (csi 500) (else 1000)) identity))
 83
 84(print "Queue representation #1:")
 85(time (q2l1 (l2q1 long-list)))
 86(print "Queue representation #2:")
 87(time (q2l2 (l2q2 long-list)))
 88(print "Queue representation #3:")
 89(time (q2l3 (l2q3 long-list)))
 90
 91(module breadth = (breadth-first queue3))
 92(import breadth)
 93
 94(define (next-char lst) 
 95  (list (cons #\A lst) (cons #\B lst) (cons #\C lst)))
 96
 97(define (show n csq) 
 98  (map list->string (take csq 1)))
 99
100;;XXX shows (""), which looks wrong:
101(pp (show 8 (search next-char '())))	;XXX assert
102
103;; list-style library names
104
105(functor ((double printer) ((P (chicken base)) (print))) (print-twice)
106  (import (scheme) P)
107  (define (print-twice x) (print x) (print x)))
108
109(module (noop printer) *
110  (import (only (scheme) define) (only (chicken base) void))
111  (define print void))
112
113(module (2x print) = ((double printer)))
114
115(module (2x noop) = ((double printer) (noop printer)))
116
117(module (2x write) = (double printer)
118  (import (chicken module))
119  (reexport (rename (scheme) (write print))))
120
121(define output
122  (with-output-to-string
123   (lambda ()
124     (import (2x print))
125     (print-twice #\a)
126     (import (2x noop))
127     (print-twice #\a)
128     (import (2x write))
129     (print-twice #\a))))
130
131(test-equal "double printer" output "a\na\n#\\a#\\a")
132
133;; Test for errors
134
135#+csi
136(begin
137
138(module m1 ())
139
140(test-error 
141 "argument mismatch"
142 (eval '(module m2 = (breadth-first m1))))
143
144(test-error
145 "undefined module"
146 (eval '(module m2 = (breadth-first hunoz))))
147
148(test-error
149 "undefined interface"
150 (eval '(module m2 HUNOZ)))
151
152(test-error
153 "undefined interface in functor"
154 (eval '(functor (f1 (X HUNOZ)) ())))
155
156(test-error
157 "undefined interface in functor result"
158 (eval '(functor (f1 (X ())) HUNOZ)))
159
160)
161
162
163;; Test alternative instantiation syntax:
164
165(functor (frob (X (yibble))) *
166  (import chicken.base X)
167  yibble)
168
169;; XXX This is somewhat iffy: functor instantiation results in a
170;; value!
171(test-equal
172 "alternative functor instantiation syntax"
173 (module yabble = frob (import scheme) (define yibble 99))
174 99)
175
176
177;; Test optional functor arguments
178
179(functor (greet ((X default-writer) (write-greeting))) *
180  (import scheme X)
181  (define (greetings) (write-greeting 'Hello!)))
182
183(module default-writer (write-greeting)
184  (import scheme)
185  (define write-greeting list))
186
187(module writer (write-greeting)
188  (import scheme)
189  (define write-greeting vector))
190
191(module greet1 = (greet writer))
192(module greet2 = (greet))
193
194(test-equal
195 "optional functor argument #1"
196 (module m2 ()
197	 (import greet1)
198	 (greetings))
199 '#(Hello!))
200
201(test-equal
202 "optional functor argument #2"
203 (module m3 ()
204	 (import greet2)
205	 (greetings))
206 '(Hello!))
207
208
209;; Optional functor syntax with builtin ("primitive") modules:
210
211(functor (wrapper ((X scheme) (vector))) *
212  (import (except scheme vector) X)
213  (define (wrap x) (vector x)))
214
215(module default-wrapper (vector)
216  (import scheme))
217
218(module list-wrapper (vector)
219  (import (rename (only scheme list) (list vector))))
220
221(module lwrap = (wrapper list-wrapper))
222(module vwrap = (wrapper))
223
224(test-equal
225 "primitive optional functor argument #1"
226 (module m4 ()
227	 (import lwrap)
228	 (wrap 99))
229 '(99))
230
231(test-equal
232 "primitive optional functor argument #2"
233 (module m5 ()
234	 (import vwrap)
235	 (wrap 99))
236 '#(99))
237
238
239;; Module implementing functor plus more exports did not expose the
240;; additional exports (pointed out by Martin Schneeweis, patch
241;; suggested by megane)
242
243(define-interface iface-a (some-a))
244
245(module iface-a-plus-extra ((interface: iface-a) extra-a)
246  (import scheme (chicken base))
247  (define extra-a 'extra-a)
248  (define some-a 'some-a))
249
250(test-equal
251 "Functor with extra exports"
252 (module m6 ()
253   (import iface-a-plus-extra scheme)
254   (list extra-a some-a))
255 '(extra-a some-a))
256
257
258;;
259
260(test-end)
261
262(test-exit)