87d3c88703c1be9ccfa8af2886881679ee0f554b
[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 ;; Print the given history.
538 (define (vm-history-print history)
539   (let loop ((n 0) (skip 0) (frames history))
540     (cond
541      ((null? frames)
542       #t)
543      ((> skip 0)
544       (loop 0 (- skip 1) (cdr frames)))
545      (else
546       (let ((f (car frames)))
547         (display n)
548         (display ": ")
549         (let ((tag (get-tag f)))
550           (when (and (pair? tag) (string? (car tag)) (number? (cdr tag)))
551                 (display (basename (car tag)))
552                 (display ":")
553                 (display (+ 1 (cdr tag)))
554                 (display ": ")))
555         (write f))
556         (newline)
557         (loop (+ n 1) skip (cdr frames))))))
558
559 ;;;; Simple exception handling
560 ;
561 ;    Exceptions are caught as follows:
562 ;
563 ;         (catch (do-something to-recover and-return meaningful-value)
564 ;              (if-something goes-wrong)
565 ;              (with-these calls))
566 ;
567 ;    "Catch" establishes a scope spanning multiple call-frames until
568 ;    another "catch" is encountered.  Within the recovery expression
569 ;    the thrown exception is bound to *error*.  Errors can be rethrown
570 ;    using (rethrow *error*).
571 ;
572 ;    Finalization can be expressed using "finally":
573 ;
574 ;         (finally (finalize-something called-purely-for side-effects)
575 ;              (whether-or-not something goes-wrong)
576 ;              (with-these calls))
577 ;
578 ;    The final expression is executed purely for its side-effects,
579 ;    both when the function exits successfully, and when an exception
580 ;    is thrown.
581 ;
582 ;    Exceptions are thrown with:
583 ;
584 ;         (throw "message")
585 ;
586 ;    If used outside a (catch ...), reverts to (error "message")
587
588 (define *handlers* (list))
589
590 (define (push-handler proc)
591      (set! *handlers* (cons proc *handlers*)))
592
593 (define (pop-handler)
594      (let ((h (car *handlers*)))
595           (set! *handlers* (cdr *handlers*))
596           h))
597
598 (define (more-handlers?)
599      (pair? *handlers*))
600
601 ;; This throws an exception.
602 (define (throw message . args)
603   (throw' message args (cdr (*vm-history*))))
604
605 ;; This is used by the vm to throw exceptions.
606 (define (throw' message args history)
607   (cond
608    ((more-handlers?)
609     ((pop-handler) message args history))
610    ((and args (list? args) (= 2 (length args))
611          (equal? *interpreter-exit* (car args)))
612     (*run-atexit-handlers*)
613     (quit (cadr args)))
614    (else
615     (display message)
616     (if args (begin
617               (display ": ")
618               (write args)))
619     (newline)
620     (vm-history-print history)
621     (quit 1))))
622
623 ;; Convenience function to rethrow the error.
624 (define (rethrow e)
625   (apply throw' e))
626
627 (macro (catch form)
628      (let ((label (gensym)))
629           `(call/cc (lambda (**exit**)
630                (push-handler (lambda *error* (**exit** ,(cadr form))))
631                (let ((,label (begin ,@(cddr form))))
632                     (pop-handler)
633                     ,label)))))
634
635 (define-macro (finally final-expression . expressions)
636   (let ((result (gensym)))
637     `(let ((,result (catch (begin ,final-expression (rethrow *error*))
638                            ,@expressions)))
639        ,final-expression
640        ,result)))
641
642 ;; Make the vm use throw'.
643 (define *error-hook* throw')
644
645 \f
646
647 ;; High-level mechanism to terminate the process is to throw an error
648 ;; of the form (*interpreter-exit* status).  This gives automatic
649 ;; resource management a chance to clean up.
650 (define *interpreter-exit* (gensym))
651
652 ;; Terminate the process returning STATUS to the parent.
653 (define (exit status)
654   (throw "interpreter exit" *interpreter-exit* status))
655
656 ;; A list of functions run at interpreter shutdown.
657 (define *atexit-handlers* (list))
658
659 ;; Execute all these functions.
660 (define (*run-atexit-handlers*)
661   (unless (null? *atexit-handlers*)
662           (let ((proc (car *atexit-handlers*)))
663             ;; Drop proc from the list so that it will not get
664             ;; executed again even if it raises an exception.
665             (set! *atexit-handlers* (cdr *atexit-handlers*))
666             (proc)
667             (*run-atexit-handlers*))))
668
669 ;; Register a function to be run at interpreter shutdown.
670 (define (atexit proc)
671   (set! *atexit-handlers* (cons proc *atexit-handlers*)))
672
673 \f
674
675 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
676
677 (macro (make-environment form)
678      `(apply (lambda ()
679                ,@(cdr form)
680                (current-environment))))
681
682 (define-macro (eval-polymorphic x . envl)
683   (display envl)
684   (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
685          (xval (eval x env)))
686     (if (closure? xval)
687       (make-closure (get-closure-code xval) env)
688       xval)))
689
690 ; Redefine this if you install another package infrastructure
691 ; Also redefine 'package'
692 (define *colon-hook* eval)
693
694 (macro (package form)
695   `(apply (lambda ()
696             ,@(cdr form)
697             (current-environment))))
698
699 ;;;;; I/O
700
701 (define (input-output-port? p)
702      (and (input-port? p) (output-port? p)))
703
704 (define (close-port p)
705      (cond
706           ((input-output-port? p) (close-input-port p) (close-output-port p))
707           ((input-port? p) (close-input-port p))
708           ((output-port? p) (close-output-port p))
709           (else (throw "Not a port" p))))
710
711 (define (call-with-input-file s p)
712      (let ((inport (open-input-file s)))
713           (if (eq? inport #f)
714                #f
715                (let ((res (p inport)))
716                     (close-input-port inport)
717                     res))))
718
719 (define (call-with-output-file s p)
720      (let ((outport (open-output-file s)))
721           (if (eq? outport #f)
722                #f
723                (let ((res (p outport)))
724                     (close-output-port outport)
725                     res))))
726
727 (define (with-input-from-file s p)
728      (let ((inport (open-input-file s)))
729           (if (eq? inport #f)
730                #f
731                (let ((prev-inport (current-input-port)))
732                     (set-input-port inport)
733                     (let ((res (p)))
734                          (close-input-port inport)
735                          (set-input-port prev-inport)
736                          res)))))
737
738 (define (with-output-to-file s p)
739      (let ((outport (open-output-file s)))
740           (if (eq? outport #f)
741                #f
742                (let ((prev-outport (current-output-port)))
743                     (set-output-port outport)
744                     (let ((res (p)))
745                          (close-output-port outport)
746                          (set-output-port prev-outport)
747                          res)))))
748
749 (define (with-input-output-from-to-files si so p)
750      (let ((inport (open-input-file si))
751            (outport (open-input-file so)))
752           (if (not (and inport outport))
753                (begin
754                     (close-input-port inport)
755                     (close-output-port outport)
756                     #f)
757                (let ((prev-inport (current-input-port))
758                      (prev-outport (current-output-port)))
759                     (set-input-port inport)
760                     (set-output-port outport)
761                     (let ((res (p)))
762                          (close-input-port inport)
763                          (close-output-port outport)
764                          (set-input-port prev-inport)
765                          (set-output-port prev-outport)
766                          res)))))
767
768 ; Random number generator (maximum cycle)
769 (define *seed* 1)
770 (define (random-next)
771      (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
772           (set! *seed*
773                (-   (* a (- *seed*
774                          (* (quotient *seed* q) q)))
775                     (* (quotient *seed* q) r)))
776           (if (< *seed* 0) (set! *seed* (+ *seed* m)))
777           *seed*))
778 ;; SRFI-0
779 ;; COND-EXPAND
780 ;; Implemented as a macro
781 (define *features* '(srfi-0 tinyscheme))
782
783 (define-macro (cond-expand . cond-action-list)
784   (cond-expand-runtime cond-action-list))
785
786 (define (cond-expand-runtime cond-action-list)
787   (if (null? cond-action-list)
788       #t
789       (if (cond-eval (caar cond-action-list))
790           `(begin ,@(cdar cond-action-list))
791           (cond-expand-runtime (cdr cond-action-list)))))
792
793 (define (cond-eval-and cond-list)
794   (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
795
796 (define (cond-eval-or cond-list)
797   (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
798
799 (define (cond-eval condition)
800   (cond
801     ((symbol? condition)
802        (if (member condition *features*) #t #f))
803     ((eq? condition #t) #t)
804     ((eq? condition #f) #f)
805     (else (case (car condition)
806             ((and) (cond-eval-and (cdr condition)))
807             ((or) (cond-eval-or (cdr condition)))
808             ((not) (if (not (null? (cddr condition)))
809                      (error "cond-expand : 'not' takes 1 argument")
810                      (not (cond-eval (cadr condition)))))
811             (else (error "cond-expand : unknown operator" (car condition)))))))
812
813 (gc-verbose #f)