gpgscm: Fix string.
[gnupg.git] / tests / gpgscm / init.scm
1 ;    Initialization file for TinySCHEME 1.41
2
3 ; Per R5RS, up to four deep compositions should be defined
4 (define (caar x) (car (car x)))
5 (define (cadr x) (car (cdr x)))
6 (define (cdar x) (cdr (car x)))
7 (define (cddr x) (cdr (cdr x)))
8 (define (caaar x) (car (car (car x))))
9 (define (caadr x) (car (car (cdr x))))
10 (define (cadar x) (car (cdr (car x))))
11 (define (caddr x) (car (cdr (cdr x))))
12 (define (cdaar x) (cdr (car (car x))))
13 (define (cdadr x) (cdr (car (cdr x))))
14 (define (cddar x) (cdr (cdr (car x))))
15 (define (cdddr x) (cdr (cdr (cdr x))))
16 (define (caaaar x) (car (car (car (car x)))))
17 (define (caaadr x) (car (car (car (cdr x)))))
18 (define (caadar x) (car (car (cdr (car x)))))
19 (define (caaddr x) (car (car (cdr (cdr x)))))
20 (define (cadaar x) (car (cdr (car (car x)))))
21 (define (cadadr x) (car (cdr (car (cdr x)))))
22 (define (caddar x) (car (cdr (cdr (car x)))))
23 (define (cadddr x) (car (cdr (cdr (cdr x)))))
24 (define (cdaaar x) (cdr (car (car (car x)))))
25 (define (cdaadr x) (cdr (car (car (cdr x)))))
26 (define (cdadar x) (cdr (car (cdr (car x)))))
27 (define (cdaddr x) (cdr (car (cdr (cdr x)))))
28 (define (cddaar x) (cdr (cdr (car (car x)))))
29 (define (cddadr x) (cdr (cdr (car (cdr x)))))
30 (define (cdddar x) (cdr (cdr (cdr (car x)))))
31 (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
32
33 ;;;; Utility to ease macro creation
34 (define (macro-expand form)
35      ((eval (get-closure-code (eval (car form)))) form))
36
37 (define (macro-expand-all form)
38    (if (macro? form)
39       (macro-expand-all (macro-expand form))
40       form))
41
42 (define *compile-hook* macro-expand-all)
43
44
45 (macro (unless form)
46      `(if (not ,(cadr form)) (begin ,@(cddr form))))
47
48 (macro (when form)
49      `(if ,(cadr form) (begin ,@(cddr form))))
50
51 ; DEFINE-MACRO Contributed by Andy Gaynor
52 (macro (define-macro dform)
53   (if (symbol? (cadr dform))
54     `(macro ,@(cdr dform))
55     (let ((form (gensym)))
56       `(macro (,(caadr dform) ,form)
57          (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
58
59 ; Utilities for math. Notice that inexact->exact is primitive,
60 ; but exact->inexact is not.
61 (define exact? integer?)
62 (define (inexact? x) (and (real? x) (not (integer? x))))
63 (define (even? n) (= (remainder n 2) 0))
64 (define (odd? n) (not (= (remainder n 2) 0)))
65 (define (zero? n) (= n 0))
66 (define (positive? n) (> n 0))
67 (define (negative? n) (< n 0))
68 (define complex? number?)
69 (define rational? real?)
70 (define (abs n) (if (>= n 0) n (- n)))
71 (define (exact->inexact n) (* n 1.0))
72 (define (<> n1 n2) (not (= n1 n2)))
73
74 ; min and max must return inexact if any arg is inexact; use (+ n 0.0)
75 (define (max . lst)
76   (foldr (lambda (a b)
77            (if (> a b)
78              (if (exact? b) a (+ a 0.0))
79              (if (exact? a) b (+ b 0.0))))
80          (car lst) (cdr lst)))
81 (define (min . lst)
82   (foldr (lambda (a b)
83            (if (< a b)
84              (if (exact? b) a (+ a 0.0))
85              (if (exact? a) b (+ b 0.0))))
86          (car lst) (cdr lst)))
87
88 (define (succ x) (+ x 1))
89 (define (pred x) (- x 1))
90 (define gcd
91   (lambda a
92     (if (null? a)
93       0
94       (let ((aa (abs (car a)))
95             (bb (abs (cadr a))))
96          (if (= bb 0)
97               aa
98               (gcd bb (remainder aa bb)))))))
99 (define lcm
100   (lambda a
101     (if (null? a)
102       1
103       (let ((aa (abs (car a)))
104             (bb (abs (cadr a))))
105          (if (or (= aa 0) (= bb 0))
106              0
107              (abs (* (quotient aa (gcd aa bb)) bb)))))))
108
109
110 (define (string . charlist)
111      (list->string charlist))
112
113 (define (list->string charlist)
114      (let* ((len (length charlist))
115             (newstr (make-string len))
116             (fill-string!
117                (lambda (str i len charlist)
118                     (if (= i len)
119                          str
120                          (begin (string-set! str i (car charlist))
121                          (fill-string! str (+ i 1) len (cdr charlist)))))))
122           (fill-string! newstr 0 len charlist)))
123
124 (define (string-fill! s e)
125      (let ((n (string-length s)))
126           (let loop ((i 0))
127                (if (= i n)
128                     s
129                     (begin (string-set! s i e) (loop (succ i)))))))
130
131 (define (string->list s)
132      (let loop ((n (pred (string-length s))) (l '()))
133           (if (= n -1)
134                l
135                (loop (pred n) (cons (string-ref s n) l)))))
136
137 (define (string-copy str)
138      (string-append str))
139
140 (define (string->anyatom str pred)
141      (let* ((a (string->atom str)))
142        (if (pred a) a
143          (error "string->xxx: not a xxx" a))))
144
145 (define (string->number str . base)
146     (let ((n (string->atom str (if (null? base) 10 (car base)))))
147         (if (number? n) n #f)))
148
149 (define (anyatom->string n pred)
150   (if (pred n)
151       (atom->string n)
152       (error "xxx->string: not a xxx" n)))
153
154 (define (number->string n . base)
155     (atom->string n (if (null? base) 10 (car base))))
156
157
158 (define (char-cmp? cmp a b)
159      (cmp (char->integer a) (char->integer b)))
160 (define (char-ci-cmp? cmp a b)
161      (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
162
163 (define (char=? a b) (char-cmp? = a b))
164 (define (char<? a b) (char-cmp? < a b))
165 (define (char>? a b) (char-cmp? > a b))
166 (define (char<=? a b) (char-cmp? <= a b))
167 (define (char>=? a b) (char-cmp? >= a b))
168
169 (define (char-ci=? a b) (char-ci-cmp? = a b))
170 (define (char-ci<? a b) (char-ci-cmp? < a b))
171 (define (char-ci>? a b) (char-ci-cmp? > a b))
172 (define (char-ci<=? a b) (char-ci-cmp? <= a b))
173 (define (char-ci>=? a b) (char-ci-cmp? >= a b))
174
175 ; Note the trick of returning (cmp x y)
176 (define (string-cmp? chcmp cmp a b)
177      (let ((na (string-length a)) (nb (string-length b)))
178           (let loop ((i 0))
179                (cond
180                     ((= i na)
181                          (if (= i nb) (cmp 0 0) (cmp 0 1)))
182                     ((= i nb)
183                          (cmp 1 0))
184                     ((chcmp = (string-ref a i) (string-ref b i))
185                          (loop (succ i)))
186                     (else
187                          (chcmp cmp (string-ref a i) (string-ref b i)))))))
188
189
190 (define (string=? a b) (string-cmp? char-cmp? = a b))
191 (define (string<? a b) (string-cmp? char-cmp? < a b))
192 (define (string>? a b) (string-cmp? char-cmp? > a b))
193 (define (string<=? a b) (string-cmp? char-cmp? <= a b))
194 (define (string>=? a b) (string-cmp? char-cmp? >= a b))
195
196 (define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
197 (define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
198 (define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
199 (define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
200 (define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
201
202 (define (list . x) x)
203
204 (define (foldr f x lst)
205      (if (null? lst)
206           x
207           (foldr f (f x (car lst)) (cdr lst))))
208
209 (define (unzip1-with-cdr . lists)
210   (unzip1-with-cdr-iterative lists '() '()))
211
212 (define (unzip1-with-cdr-iterative lists cars cdrs)
213   (if (null? lists)
214       (cons cars cdrs)
215       (let ((car1 (caar lists))
216             (cdr1 (cdar lists)))
217         (unzip1-with-cdr-iterative
218           (cdr lists)
219           (append cars (list car1))
220           (append cdrs (list cdr1))))))
221
222 (define (map proc . lists)
223   (if (null? lists)
224       (apply proc)
225       (if (null? (car lists))
226         '()
227         (let* ((unz (apply unzip1-with-cdr lists))
228                (cars (car unz))
229                (cdrs (cdr unz)))
230           (cons (apply proc cars) (apply map (cons proc cdrs)))))))
231
232 (define (for-each proc . lists)
233   (if (null? lists)
234       (apply proc)
235       (if (null? (car lists))
236         #t
237         (let* ((unz (apply unzip1-with-cdr lists))
238                (cars (car unz))
239                (cdrs (cdr unz)))
240           (apply proc cars) (apply map (cons proc cdrs))))))
241
242 (define (list-tail x k)
243     (if (zero? k)
244         x
245         (list-tail (cdr x) (- k 1))))
246
247 (define (list-ref x k)
248     (car (list-tail x k)))
249
250 (define (last-pair x)
251     (if (pair? (cdr x))
252         (last-pair (cdr x))
253         x))
254
255 (define (head stream) (car stream))
256
257 (define (tail stream) (force (cdr stream)))
258
259 (define (vector-equal? x y)
260      (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
261           (let ((n (vector-length x)))
262                (let loop ((i 0))
263                     (if (= i n)
264                          #t
265                          (and (equal? (vector-ref x i) (vector-ref y i))
266                               (loop (succ i))))))))
267
268 (define (list->vector x)
269      (apply vector x))
270
271 (define (vector-fill! v e)
272      (let ((n (vector-length v)))
273           (let loop ((i 0))
274                (if (= i n)
275                     v
276                     (begin (vector-set! v i e) (loop (succ i)))))))
277
278 (define (vector->list v)
279      (let loop ((n (pred (vector-length v))) (l '()))
280           (if (= n -1)
281                l
282                (loop (pred n) (cons (vector-ref v n) l)))))
283
284 ;; The following quasiquote macro is due to Eric S. Tiedemann.
285 ;;   Copyright 1988 by Eric S. Tiedemann; all rights reserved.
286 ;;
287 ;; Subsequently modified to handle vectors: D. Souflis
288
289 (macro
290  quasiquote
291  (lambda (l)
292    (define (mcons f l r)
293      (if (and (pair? r)
294               (eq? (car r) 'quote)
295               (eq? (car (cdr r)) (cdr f))
296               (pair? l)
297               (eq? (car l) 'quote)
298               (eq? (car (cdr l)) (car f)))
299          (if (or (procedure? f) (number? f) (string? f))
300                f
301                (list 'quote f))
302          (if (eqv? l vector)
303                (apply l (eval r))
304                (list 'cons l r)
305                )))
306    (define (mappend f l r)
307      (if (or (null? (cdr f))
308              (and (pair? r)
309                   (eq? (car r) 'quote)
310                   (eq? (car (cdr r)) '())))
311          l
312          (list 'append l r)))
313    (define (foo level form)
314      (cond ((not (pair? form))
315                (if (or (procedure? form) (number? form) (string? form))
316                     form
317                     (list 'quote form))
318                )
319            ((eq? 'quasiquote (car form))
320             (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
321            (#t (if (zero? level)
322                    (cond ((eq? (car form) 'unquote) (car (cdr form)))
323                          ((eq? (car form) 'unquote-splicing)
324                           (error "Unquote-splicing wasn't in a list:"
325                                  form))
326                          ((and (pair? (car form))
327                                (eq? (car (car form)) 'unquote-splicing))
328                           (mappend form (car (cdr (car form)))
329                                    (foo level (cdr form))))
330                          (#t (mcons form (foo level (car form))
331                                          (foo level (cdr form)))))
332                    (cond ((eq? (car form) 'unquote)
333                           (mcons form ''unquote (foo (- level 1)
334                                                      (cdr form))))
335                          ((eq? (car form) 'unquote-splicing)
336                           (mcons form ''unquote-splicing
337                                       (foo (- level 1) (cdr form))))
338                          (#t (mcons form (foo level (car form))
339                                          (foo level (cdr form)))))))))
340    (foo 0 (car (cdr l)))))
341
342 ;;;;;Helper for the dynamic-wind definition.  By Tom Breton (Tehom)
343 (define (shared-tail x y)
344    (let ((len-x (length x))
345          (len-y (length y)))
346       (define (shared-tail-helper x y)
347          (if
348             (eq? x y)
349             x
350             (shared-tail-helper (cdr x) (cdr y))))
351
352       (cond
353          ((> len-x len-y)
354             (shared-tail-helper
355                (list-tail x (- len-x len-y))
356                y))
357          ((< len-x len-y)
358             (shared-tail-helper
359                x
360                (list-tail y (- len-y len-x))))
361          (#t (shared-tail-helper x y)))))
362
363 ;;;;;Dynamic-wind by Tom Breton (Tehom)
364
365 ;;Guarded because we must only eval this once, because doing so
366 ;;redefines call/cc in terms of old call/cc
367 (unless (defined? 'dynamic-wind)
368    (let
369       ;;These functions are defined in the context of a private list of
370       ;;pairs of before/after procs.
371       (  (*active-windings* '())
372          ;;We'll define some functions into the larger environment, so
373          ;;we need to know it.
374          (outer-env (current-environment)))
375
376       ;;Poor-man's structure operations
377       (define before-func car)
378       (define after-func  cdr)
379       (define make-winding cons)
380
381       ;;Manage active windings
382       (define (activate-winding! new)
383          ((before-func new))
384          (set! *active-windings* (cons new *active-windings*)))
385       (define (deactivate-top-winding!)
386          (let ((old-top (car *active-windings*)))
387             ;;Remove it from the list first so it's not active during its
388             ;;own exit.
389             (set! *active-windings* (cdr *active-windings*))
390             ((after-func old-top))))
391
392       (define (set-active-windings! new-ws)
393          (unless (eq? new-ws *active-windings*)
394             (let ((shared (shared-tail new-ws *active-windings*)))
395
396                ;;Define the looping functions.
397                ;;Exit the old list.  Do deeper ones last.  Don't do
398                ;;any shared ones.
399                (define (pop-many)
400                   (unless (eq? *active-windings* shared)
401                      (deactivate-top-winding!)
402                      (pop-many)))
403                ;;Enter the new list.  Do deeper ones first so that the
404                ;;deeper windings will already be active.  Don't do any
405                ;;shared ones.
406                (define (push-many new-ws)
407                   (unless (eq? new-ws shared)
408                      (push-many (cdr new-ws))
409                      (activate-winding! (car new-ws))))
410
411                ;;Do it.
412                (pop-many)
413                (push-many new-ws))))
414
415       ;;The definitions themselves.
416       (eval
417          `(define call-with-current-continuation
418              ;;It internally uses the built-in call/cc, so capture it.
419              ,(let ((old-c/cc call-with-current-continuation))
420                  (lambda (func)
421                     ;;Use old call/cc to get the continuation.
422                     (old-c/cc
423                        (lambda (continuation)
424                           ;;Call func with not the continuation itself
425                           ;;but a procedure that adjusts the active
426                           ;;windings to what they were when we made
427                           ;;this, and only then calls the
428                           ;;continuation.
429                           (func
430                              (let ((current-ws *active-windings*))
431                                 (lambda (x)
432                                    (set-active-windings! current-ws)
433                                    (continuation x)))))))))
434          outer-env)
435       ;;We can't just say "define (dynamic-wind before thunk after)"
436       ;;because the lambda it's defined to lives in this environment,
437       ;;not in the global environment.
438       (eval
439          `(define dynamic-wind
440              ,(lambda (before thunk after)
441                  ;;Make a new winding
442                  (activate-winding! (make-winding before after))
443                  (let ((result (thunk)))
444                     ;;Get rid of the new winding.
445                     (deactivate-top-winding!)
446                     ;;The return value is that of thunk.
447                     result)))
448          outer-env)))
449
450 (define call/cc call-with-current-continuation)
451
452
453 ;;;;; atom? and equal? written by a.k
454
455 ;;;; atom?
456 (define (atom? x)
457   (not (pair? x)))
458
459 ;;;;    equal?
460 (define (equal? x y)
461      (cond
462           ((pair? x)
463                (and (pair? y)
464                     (equal? (car x) (car y))
465                     (equal? (cdr x) (cdr y))))
466           ((vector? x)
467                (and (vector? y) (vector-equal? x y)))
468           ((string? x)
469                (and (string? y) (string=? x y)))
470           (else (eqv? x y))))
471
472 ;;;; (do ((var init inc) ...) (endtest result ...) body ...)
473 ;;
474 (macro do
475   (lambda (do-macro)
476     (apply (lambda (do vars endtest . body)
477              (let ((do-loop (gensym)))
478                `(letrec ((,do-loop
479                            (lambda ,(map (lambda (x)
480                                            (if (pair? x) (car x) x))
481                                       `,vars)
482                              (if ,(car endtest)
483                                (begin ,@(cdr endtest))
484                                (begin
485                                  ,@body
486                                  (,do-loop
487                                    ,@(map (lambda (x)
488                                             (cond
489                                               ((not (pair? x)) x)
490                                               ((< (length x) 3) (car x))
491                                               (else (car (cdr (cdr x))))))
492                                        `,vars)))))))
493                   (,do-loop
494                     ,@(map (lambda (x)
495                              (if (and (pair? x) (cdr x))
496                                (car (cdr x))
497                                '()))
498                         `,vars)))))
499       do-macro)))
500
501 ;;;; generic-member
502 (define (generic-member cmp obj lst)
503   (cond
504     ((null? lst) #f)
505     ((cmp obj (car lst)) lst)
506     (else (generic-member cmp obj (cdr lst)))))
507
508 (define (memq obj lst)
509      (generic-member eq? obj lst))
510 (define (memv obj lst)
511      (generic-member eqv? obj lst))
512 (define (member obj lst)
513      (generic-member equal? obj lst))
514
515 ;;;; generic-assoc
516 (define (generic-assoc cmp obj alst)
517      (cond
518           ((null? alst) #f)
519           ((cmp obj (caar alst)) (car alst))
520           (else (generic-assoc cmp obj (cdr alst)))))
521
522 (define (assq obj alst)
523      (generic-assoc eq? obj alst))
524 (define (assv obj alst)
525      (generic-assoc eqv? obj alst))
526 (define (assoc obj alst)
527      (generic-assoc equal? obj alst))
528
529 (define (acons x y z) (cons (cons x y) z))
530
531 ;;;; Handy for imperative programs
532 ;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
533 (macro (define-with-return form)
534      `(define ,(cadr form)
535           (call/cc (lambda (return) ,@(cddr form)))))
536
537 ;;;; Simple exception handling
538 ;
539 ;    Exceptions are caught as follows:
540 ;
541 ;         (catch (do-something to-recover and-return meaningful-value)
542 ;              (if-something goes-wrong)
543 ;              (with-these calls))
544 ;
545 ;    "Catch" establishes a scope spanning multiple call-frames until
546 ;    another "catch" is encountered.  Within the recovery expression
547 ;    the thrown exception is bound to *error*.  Errors can be rethrown
548 ;    using (apply throw *error*).
549 ;
550 ;    Exceptions are thrown with:
551 ;
552 ;         (throw "message")
553 ;
554 ;    If used outside a (catch ...), reverts to (error "message")
555
556 (define *handlers* (list))
557
558 (define (push-handler proc)
559      (set! *handlers* (cons proc *handlers*)))
560
561 (define (pop-handler)
562      (let ((h (car *handlers*)))
563           (set! *handlers* (cdr *handlers*))
564           h))
565
566 (define (more-handlers?)
567      (pair? *handlers*))
568
569 (define (throw . x)
570      (if (more-handlers?)
571           (apply (pop-handler) x)
572           (apply error x)))
573
574 (macro (catch form)
575      (let ((label (gensym)))
576           `(call/cc (lambda (**exit**)
577                (push-handler (lambda *error* (**exit** ,(cadr form))))
578                (let ((,label (begin ,@(cddr form))))
579                     (pop-handler)
580                     ,label)))))
581
582 (define *error-hook* throw)
583
584
585 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
586
587 (macro (make-environment form)
588      `(apply (lambda ()
589                ,@(cdr form)
590                (current-environment))))
591
592 (define-macro (eval-polymorphic x . envl)
593   (display envl)
594   (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
595          (xval (eval x env)))
596     (if (closure? xval)
597       (make-closure (get-closure-code xval) env)
598       xval)))
599
600 ; Redefine this if you install another package infrastructure
601 ; Also redefine 'package'
602 (define *colon-hook* eval)
603
604 (macro (package form)
605   `(apply (lambda ()
606             ,@(cdr form)
607             (current-environment))))
608
609 ;;;;; I/O
610
611 (define (input-output-port? p)
612      (and (input-port? p) (output-port? p)))
613
614 (define (close-port p)
615      (cond
616           ((input-output-port? p) (close-input-port p) (close-output-port p))
617           ((input-port? p) (close-input-port p))
618           ((output-port? p) (close-output-port p))
619           (else (throw "Not a port" p))))
620
621 (define (call-with-input-file s p)
622      (let ((inport (open-input-file s)))
623           (if (eq? inport #f)
624                #f
625                (let ((res (p inport)))
626                     (close-input-port inport)
627                     res))))
628
629 (define (call-with-output-file s p)
630      (let ((outport (open-output-file s)))
631           (if (eq? outport #f)
632                #f
633                (let ((res (p outport)))
634                     (close-output-port outport)
635                     res))))
636
637 (define (with-input-from-file s p)
638      (let ((inport (open-input-file s)))
639           (if (eq? inport #f)
640                #f
641                (let ((prev-inport (current-input-port)))
642                     (set-input-port inport)
643                     (let ((res (p)))
644                          (close-input-port inport)
645                          (set-input-port prev-inport)
646                          res)))))
647
648 (define (with-output-to-file s p)
649      (let ((outport (open-output-file s)))
650           (if (eq? outport #f)
651                #f
652                (let ((prev-outport (current-output-port)))
653                     (set-output-port outport)
654                     (let ((res (p)))
655                          (close-output-port outport)
656                          (set-output-port prev-outport)
657                          res)))))
658
659 (define (with-input-output-from-to-files si so p)
660      (let ((inport (open-input-file si))
661            (outport (open-input-file so)))
662           (if (not (and inport outport))
663                (begin
664                     (close-input-port inport)
665                     (close-output-port outport)
666                     #f)
667                (let ((prev-inport (current-input-port))
668                      (prev-outport (current-output-port)))
669                     (set-input-port inport)
670                     (set-output-port outport)
671                     (let ((res (p)))
672                          (close-input-port inport)
673                          (close-output-port outport)
674                          (set-input-port prev-inport)
675                          (set-output-port prev-outport)
676                          res)))))
677
678 ; Random number generator (maximum cycle)
679 (define *seed* 1)
680 (define (random-next)
681      (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
682           (set! *seed*
683                (-   (* a (- *seed*
684                          (* (quotient *seed* q) q)))
685                     (* (quotient *seed* q) r)))
686           (if (< *seed* 0) (set! *seed* (+ *seed* m)))
687           *seed*))
688 ;; SRFI-0
689 ;; COND-EXPAND
690 ;; Implemented as a macro
691 (define *features* '(srfi-0 tinyscheme))
692
693 (define-macro (cond-expand . cond-action-list)
694   (cond-expand-runtime cond-action-list))
695
696 (define (cond-expand-runtime cond-action-list)
697   (if (null? cond-action-list)
698       #t
699       (if (cond-eval (caar cond-action-list))
700           `(begin ,@(cdar cond-action-list))
701           (cond-expand-runtime (cdr cond-action-list)))))
702
703 (define (cond-eval-and cond-list)
704   (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
705
706 (define (cond-eval-or cond-list)
707   (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
708
709 (define (cond-eval condition)
710   (cond
711     ((symbol? condition)
712        (if (member condition *features*) #t #f))
713     ((eq? condition #t) #t)
714     ((eq? condition #f) #f)
715     (else (case (car condition)
716             ((and) (cond-eval-and (cdr condition)))
717             ((or) (cond-eval-or (cdr condition)))
718             ((not) (if (not (null? (cddr condition)))
719                      (error "cond-expand : 'not' takes 1 argument")
720                      (not (cond-eval (cadr condition)))))
721             (else (error "cond-expand : unknown operator" (car condition)))))))
722
723 (gc-verbose #f)