gpgscm: Improve error reporting.
[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     (when (and args (not (null? args)))
617           (display ": ")
618           (if (and (pair? args) (string? (car args)))
619               (begin (display (car args))
620                      (unless (null? (cdr args))
621                              (newline)
622                              (write (cdr args))))
623               (write args)))
624     (newline)
625     (vm-history-print history)
626     (quit 1))))
627
628 ;; Convenience function to rethrow the error.
629 (define (rethrow e)
630   (apply throw' e))
631
632 (macro (catch form)
633      (let ((label (gensym)))
634           `(call/cc (lambda (**exit**)
635                (push-handler (lambda *error* (**exit** ,(cadr form))))
636                (let ((,label (begin ,@(cddr form))))
637                     (pop-handler)
638                     ,label)))))
639
640 (define-macro (finally final-expression . expressions)
641   (let ((result (gensym)))
642     `(let ((,result (catch (begin ,final-expression (rethrow *error*))
643                            ,@expressions)))
644        ,final-expression
645        ,result)))
646
647 ;; Make the vm use throw'.
648 (define *error-hook* throw')
649
650 \f
651
652 ;; High-level mechanism to terminate the process is to throw an error
653 ;; of the form (*interpreter-exit* status).  This gives automatic
654 ;; resource management a chance to clean up.
655 (define *interpreter-exit* (gensym))
656
657 ;; Terminate the process returning STATUS to the parent.
658 (define (exit status)
659   (throw "interpreter exit" *interpreter-exit* status))
660
661 ;; A list of functions run at interpreter shutdown.
662 (define *atexit-handlers* (list))
663
664 ;; Execute all these functions.
665 (define (*run-atexit-handlers*)
666   (unless (null? *atexit-handlers*)
667           (let ((proc (car *atexit-handlers*)))
668             ;; Drop proc from the list so that it will not get
669             ;; executed again even if it raises an exception.
670             (set! *atexit-handlers* (cdr *atexit-handlers*))
671             (proc)
672             (*run-atexit-handlers*))))
673
674 ;; Register a function to be run at interpreter shutdown.
675 (define (atexit proc)
676   (set! *atexit-handlers* (cons proc *atexit-handlers*)))
677
678 \f
679
680 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
681
682 (macro (make-environment form)
683      `(apply (lambda ()
684                ,@(cdr form)
685                (current-environment))))
686
687 (define-macro (eval-polymorphic x . envl)
688   (display envl)
689   (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
690          (xval (eval x env)))
691     (if (closure? xval)
692       (make-closure (get-closure-code xval) env)
693       xval)))
694
695 ; Redefine this if you install another package infrastructure
696 ; Also redefine 'package'
697 (define *colon-hook* eval)
698
699 (macro (package form)
700   `(apply (lambda ()
701             ,@(cdr form)
702             (current-environment))))
703
704 (define-macro (export name . expressions)
705   `(define ,name
706      (begin
707        ,@expressions)))
708
709 ;;;;; I/O
710
711 (define (input-output-port? p)
712      (and (input-port? p) (output-port? p)))
713
714 (define (close-port p)
715      (cond
716           ((input-output-port? p) (close-input-port p) (close-output-port p))
717           ((input-port? p) (close-input-port p))
718           ((output-port? p) (close-output-port p))
719           (else (throw "Not a port" p))))
720
721 (define (call-with-input-file s p)
722      (let ((inport (open-input-file s)))
723           (if (eq? inport #f)
724                #f
725                (let ((res (p inport)))
726                     (close-input-port inport)
727                     res))))
728
729 (define (call-with-output-file s p)
730      (let ((outport (open-output-file s)))
731           (if (eq? outport #f)
732                #f
733                (let ((res (p outport)))
734                     (close-output-port outport)
735                     res))))
736
737 (define (with-input-from-file s p)
738      (let ((inport (open-input-file s)))
739           (if (eq? inport #f)
740                #f
741                (let ((prev-inport (current-input-port)))
742                     (set-input-port inport)
743                     (let ((res (p)))
744                          (close-input-port inport)
745                          (set-input-port prev-inport)
746                          res)))))
747
748 (define (with-output-to-file s p)
749      (let ((outport (open-output-file s)))
750           (if (eq? outport #f)
751                #f
752                (let ((prev-outport (current-output-port)))
753                     (set-output-port outport)
754                     (let ((res (p)))
755                          (close-output-port outport)
756                          (set-output-port prev-outport)
757                          res)))))
758
759 (define (with-input-output-from-to-files si so p)
760      (let ((inport (open-input-file si))
761            (outport (open-input-file so)))
762           (if (not (and inport outport))
763                (begin
764                     (close-input-port inport)
765                     (close-output-port outport)
766                     #f)
767                (let ((prev-inport (current-input-port))
768                      (prev-outport (current-output-port)))
769                     (set-input-port inport)
770                     (set-output-port outport)
771                     (let ((res (p)))
772                          (close-input-port inport)
773                          (close-output-port outport)
774                          (set-input-port prev-inport)
775                          (set-output-port prev-outport)
776                          res)))))
777
778 ; Random number generator (maximum cycle)
779 (define *seed* 1)
780 (define (random-next)
781      (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
782           (set! *seed*
783                (-   (* a (- *seed*
784                          (* (quotient *seed* q) q)))
785                     (* (quotient *seed* q) r)))
786           (if (< *seed* 0) (set! *seed* (+ *seed* m)))
787           *seed*))
788 ;; SRFI-0
789 ;; COND-EXPAND
790 ;; Implemented as a macro
791 (define *features* '(srfi-0 tinyscheme))
792
793 (define-macro (cond-expand . cond-action-list)
794   (cond-expand-runtime cond-action-list))
795
796 (define (cond-expand-runtime cond-action-list)
797   (if (null? cond-action-list)
798       #t
799       (if (cond-eval (caar cond-action-list))
800           `(begin ,@(cdar cond-action-list))
801           (cond-expand-runtime (cdr cond-action-list)))))
802
803 (define (cond-eval-and cond-list)
804   (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
805
806 (define (cond-eval-or cond-list)
807   (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
808
809 (define (cond-eval condition)
810   (cond
811     ((symbol? condition)
812        (if (member condition *features*) #t #f))
813     ((eq? condition #t) #t)
814     ((eq? condition #f) #f)
815     (else (case (car condition)
816             ((and) (cond-eval-and (cdr condition)))
817             ((or) (cond-eval-or (cdr condition)))
818             ((not) (if (not (null? (cddr condition)))
819                      (error "cond-expand : 'not' takes 1 argument")
820                      (not (cond-eval (cadr condition)))))
821             (else (error "cond-expand : unknown operator" (car condition)))))))
822
823 (gc-verbose #f)