1;    Initialization file for TinySCHEME 1.31 onwards
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(macro (unless form)
34     `(if (not ,(cadr form)) (begin ,@(cddr form))))
35
36(macro (when form)
37     `(if ,(cadr form) (begin ,@(cddr form))))
38
39; DEFINE-MACRO Contributed by Andy Gaynor
40(macro (define-macro dform)
41  (if (symbol? (cadr dform))
42    `(macro ,@(cdr dform))
43    (let ((form (gensym)))
44      `(macro (,(caadr dform) ,form)
45         (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
46
47; Utilities for math. Notice that inexact->exact is primitive,
48; but exact->inexact is not.
49(define exact? integer?)
50(define (inexact? x) (and (real? x) (not (integer? x))))
51(define (even? n) (= (remainder n 2) 0))
52(define (odd? n) (not (= (remainder n 2) 0)))
53(define (zero? n) (= n 0))
54(define (positive? n) (> n 0))
55(define (negative? n) (< n 0))
56(define complex? number?)
57(define rational? real?)
58(define (abs n) (if (>= n 0) n (- n)))
59(define (exact->inexact n) (* n 1.0))
60(define (<> n1 n2) (not (= n1 n2)))
61(define (max . lst)
62     (foldr (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst)))
63(define (min . lst)
64     (foldr (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst)))
65(define (succ x) (+ x 1))
66(define (pred x) (- x 1))
67(define (gcd a b)
68  (let ((aa (abs a))
69	(bb (abs b)))
70     (if (= bb 0)
71          aa
72          (gcd bb (remainder aa bb)))))
73(define (lcm a b)
74     (if (or (= a 0) (= b 0))
75          0
76          (abs (* (quotient a (gcd a b)) b))))
77
78(define call/cc call-with-current-continuation)
79
80(define (string . charlist)
81     (list->string charlist))
82
83(define (list->string charlist)
84     (let* ((len (length charlist))
85            (newstr (make-string len))
86            (fill-string!
87               (lambda (str i len charlist)
88                    (if (= i len)
89                         str
90                         (begin (string-set! str i (car charlist))
91                         (fill-string! str (+ i 1) len (cdr charlist)))))))
92          (fill-string! newstr 0 len charlist)))
93
94(define (string-fill! s e)
95     (let ((n (string-length s)))
96          (let loop ((i 0))
97               (if (= i n)
98                    s
99                    (begin (string-set! s i e) (loop (succ i)))))))
100
101(define (string->list s)
102     (let loop ((n (pred (string-length s))) (l '()))
103          (if (= n -1)
104               l
105               (loop (pred n) (cons (string-ref s n) l)))))
106
107(define (string-copy str)
108     (string-append str))
109
110(define (string->anyatom str pred)
111     (let* ((a (string->atom str)))
112       (if (pred a) a
113	   (error "string->xxx: not a xxx" a))))
114
115(define (string->number str) (string->anyatom str number?))
116
117(define (anyatom->string n pred)
118  (if (pred n)
119      (atom->string n)
120      (error "xxx->string: not a xxx" n)))
121
122
123(define (number->string n) (anyatom->string n number?))
124
125(define (char-cmp? cmp a b)
126     (cmp (char->integer a) (char->integer b)))
127(define (char-ci-cmp? cmp a b)
128     (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
129
130(define (char=? a b) (char-cmp? = a b))
131(define (char<? a b) (char-cmp? < a b))
132(define (char>? a b) (char-cmp? > a b))
133(define (char<=? a b) (char-cmp? <= a b))
134(define (char>=? a b) (char-cmp? >= a b))
135
136(define (char-ci=? a b) (char-ci-cmp? = a b))
137(define (char-ci<? a b) (char-ci-cmp? < a b))
138(define (char-ci>? a b) (char-ci-cmp? > a b))
139(define (char-ci<=? a b) (char-ci-cmp? <= a b))
140(define (char-ci>=? a b) (char-ci-cmp? >= a b))
141
142; Note the trick of returning (cmp x y)
143(define (string-cmp? chcmp cmp a b)
144     (let ((na (string-length a)) (nb (string-length b)))
145          (if (<> na nb)
146               (cmp na nb)
147               (let loop ((i 0))
148                    (if (= i na)
149                         (if (= na 0) (cmp 0 0) #t)
150                         (and (chcmp cmp (string-ref a i) (string-ref b i))
151                              (loop (succ i))))))))
152
153(define (string=? a b) (string-cmp? char-cmp? = a b))
154(define (string<? a b) (string-cmp? char-cmp? < a b))
155(define (string>? a b) (string-cmp? char-cmp? > a b))
156(define (string<=? a b) (string-cmp? char-cmp? <= a b))
157(define (string>=? a b) (string-cmp? char-cmp? >= a b))
158
159(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
160(define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
161(define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
162(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
163(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
164
165(define (list . x) x)
166
167(define (foldr f x lst)
168     (if (null? lst)
169          x
170          (foldr f (f x (car lst)) (cdr lst))))
171
172(define (unzip1-with-cdr . lists)
173  (unzip1-with-cdr-iterative lists '() '()))
174
175(define (unzip1-with-cdr-iterative lists cars cdrs)
176  (if (null? lists)
177      (cons cars cdrs)
178      (let ((car1 (caar lists))
179	    (cdr1 (cdar lists)))
180	(unzip1-with-cdr-iterative
181	 (cdr lists)
182	 (append cars (list car1))
183	 (append cdrs (list cdr1))))))
184
185(define (map proc . lists)
186  (if (null? lists)
187      (apply proc)
188      (if (null? (car lists))
189	  '()
190	  (let* ((unz (apply unzip1-with-cdr lists))
191		 (cars (car unz))
192		 (cdrs (cdr unz)))
193	    (cons (apply proc cars) (apply map (cons proc cdrs)))))))
194
195(define (for-each proc . lists)
196  (if (null? lists)
197      (apply proc)
198      (if (null? (car lists))
199	  #t
200	  (let* ((unz (apply unzip1-with-cdr lists))
201		 (cars (car unz))
202		 (cdrs (cdr unz)))
203	    (apply proc cars) (apply map (cons proc cdrs))))))
204
205(define (list-tail x k)
206    (if (zero? k)
207        x
208        (list-tail (cdr x) (- k 1))))
209
210(define (list-ref x k)
211    (car (list-tail x k)))
212
213(define (last-pair x)
214    (if (pair? (cdr x))
215        (last-pair (cdr x))
216        x))
217
218(define (head stream) (car stream))
219
220(define (tail stream) (force (cdr stream)))
221
222(define (vector-equal? x y)
223     (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
224          (let ((n (vector-length x)))
225               (let loop ((i 0))
226                    (if (= i n)
227                         #t
228                         (and (equal? (vector-ref x i) (vector-ref y i))
229                              (loop (succ i))))))))
230
231(define (list->vector x)
232     (apply vector x))
233
234(define (vector-fill! v e)
235     (let ((n (vector-length v)))
236          (let loop ((i 0))
237               (if (= i n)
238                    v
239                    (begin (vector-set! v i e) (loop (succ i)))))))
240
241(define (vector->list v)
242     (let loop ((n (pred (vector-length v))) (l '()))
243          (if (= n -1)
244               l
245               (loop (pred n) (cons (vector-ref v n) l)))))
246
247;; The following quasiquote macro is due to Eric S. Tiedemann.
248;;   Copyright 1988 by Eric S. Tiedemann; all rights reserved.
249;;
250;; Subsequently modified to handle vectors: D. Souflis
251
252(macro
253 quasiquote
254 (lambda (l)
255   (define (mcons f l r)
256     (if (and (pair? r)
257              (eq? (car r) 'quote)
258              (eq? (car (cdr r)) (cdr f))
259              (pair? l)
260              (eq? (car l) 'quote)
261              (eq? (car (cdr l)) (car f)))
262         (if (or (procedure? f) (number? f) (string? f))
263               f
264               (list 'quote f))
265         (if (eqv? l vector)
266               (apply l (eval r))
267               (list 'cons l r)
268               )))
269   (define (mappend f l r)
270     (if (or (null? (cdr f))
271             (and (pair? r)
272                  (eq? (car r) 'quote)
273                  (eq? (car (cdr r)) '())))
274         l
275         (list 'append l r)))
276   (define (foo level form)
277     (cond ((not (pair? form))
278               (if (or (procedure? form) (number? form) (string? form))
279                    form
280                    (list 'quote form))
281               )
282           ((eq? 'quasiquote (car form))
283            (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
284           (#t (if (zero? level)
285                   (cond ((eq? (car form) 'unquote) (car (cdr form)))
286                         ((eq? (car form) 'unquote-splicing)
287                          (error "Unquote-splicing wasn't in a list:"
288                                 form))
289                         ((and (pair? (car form))
290                               (eq? (car (car form)) 'unquote-splicing))
291                          (mappend form (car (cdr (car form)))
292                                   (foo level (cdr form))))
293                         (#t (mcons form (foo level (car form))
294                                         (foo level (cdr form)))))
295                   (cond ((eq? (car form) 'unquote)
296                          (mcons form ''unquote (foo (- level 1)
297                                                     (cdr form))))
298                         ((eq? (car form) 'unquote-splicing)
299                          (mcons form ''unquote-splicing
300                                      (foo (- level 1) (cdr form))))
301                         (#t (mcons form (foo level (car form))
302                                         (foo level (cdr form)))))))))
303   (foo 0 (car (cdr l)))))
304
305
306;;;;; atom? and equal? written by a.k
307
308;;;; atom?
309(define (atom? x)
310  (not (pair? x)))
311
312;;;;    equal?
313(define (equal? x y)
314     (cond
315          ((pair? x)
316               (and (pair? y)
317                    (equal? (car x) (car y))
318                    (equal? (cdr x) (cdr y))))
319          ((vector? x)
320               (and (vector? y) (vector-equal? x y)))
321          ((string? x)
322               (and (string? y) (string=? x y)))
323          (else (eqv? x y))))
324
325;;;; (do ((var init inc) ...) (endtest result ...) body ...)
326;;
327(macro do
328  (lambda (do-macro)
329    (apply (lambda (do vars endtest . body)
330             (let ((do-loop (gensym)))
331               `(letrec ((,do-loop
332                           (lambda ,(map (lambda (x)
333                                           (if (pair? x) (car x) x))
334                                      `,vars)
335                             (if ,(car endtest)
336                               (begin ,@(cdr endtest))
337                               (begin
338                                 ,@body
339                                 (,do-loop
340                                   ,@(map (lambda (x)
341                                            (cond
342                                              ((not (pair? x)) x)
343                                              ((< (length x) 3) (car x))
344                                              (else (car (cdr (cdr x))))))
345                                       `,vars)))))))
346                  (,do-loop
347                    ,@(map (lambda (x)
348                             (if (and (pair? x) (cdr x))
349                               (car (cdr x))
350                               '()))
351                        `,vars)))))
352      do-macro)))
353
354;;;; generic-member
355(define (generic-member cmp obj lst)
356  (cond
357    ((null? lst) #f)
358    ((cmp obj (car lst)) lst)
359    (else (generic-member cmp obj (cdr lst)))))
360
361(define (memq obj lst)
362     (generic-member eq? obj lst))
363(define (memv obj lst)
364     (generic-member eqv? obj lst))
365(define (member obj lst)
366     (generic-member equal? obj lst))
367
368;;;; generic-assoc
369(define (generic-assoc cmp obj alst)
370     (cond
371          ((null? alst) #f)
372          ((cmp obj (caar alst)) (car alst))
373          (else (generic-assoc cmp obj (cdr alst)))))
374
375(define (assq obj alst)
376     (generic-assoc eq? obj alst))
377(define (assv obj alst)
378     (generic-assoc eqv? obj alst))
379(define (assoc obj alst)
380     (generic-assoc equal? obj alst))
381
382(define (acons x y z) (cons (cons x y) z))
383
384;;;; Utility to ease macro creation
385(define (macro-expand form)
386     ((eval (get-closure-code (eval (car form)))) form))
387
388;;;; Handy for imperative programs
389;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
390(macro (define-with-return form)
391     `(define ,(cadr form)
392          (call/cc (lambda (return) ,@(cddr form)))))
393
394;;;; Simple exception handling
395;
396;    Exceptions are caught as follows:
397;
398;         (catch (do-something to-recover and-return meaningful-value)
399;              (if-something goes-wrong)
400;              (with-these calls))
401;
402;    "Catch" establishes a scope spanning multiple call-frames
403;    until another "catch" is encountered.
404;
405;    Exceptions are thrown with:
406;
407;         (throw "message")
408;
409;    If used outside a (catch ...), reverts to (error "message)
410
411(define *handlers* (list))
412
413(define (push-handler proc)
414     (set! *handlers* (cons proc *handlers*)))
415
416(define (pop-handler)
417     (let ((h (car *handlers*)))
418          (set! *handlers* (cdr *handlers*))
419          h))
420
421(define (more-handlers?)
422     (pair? *handlers*))
423
424(define (throw . x)
425     (if (more-handlers?)
426          (apply (pop-handler))
427          (apply error x)))
428
429(macro (catch form)
430     (let ((label (gensym)))
431          `(call/cc (lambda (exit)
432               (push-handler (lambda () (exit ,(cadr form))))
433               (let ((,label (begin ,@(cddr form))))
434                    (pop-handler)
435                    ,label)))))
436
437(define *error-hook* throw)
438
439
440;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
441
442(macro (make-environment form)
443     `(apply (lambda ()
444               ,@(cdr form)
445               (current-environment))))
446
447(define-macro (eval-polymorphic x . envl)
448  (display envl)
449  (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
450         (xval (eval x env)))
451    (if (closure? xval)
452	(make-closure (get-closure-code xval) env)
453	xval)))
454
455; Redefine this if you install another package infrastructure
456; Also redefine 'package'
457(define *colon-hook* eval)
458
459;;;;; I/O
460
461(define (input-output-port? p)
462     (and (input-port? p) (output-port? p)))
463
464(define (close-port p)
465     (cond
466          ((input-output-port? p) (close-input-port (close-output-port p)))
467          ((input-port? p) (close-input-port p))
468          ((output-port? p) (close-output-port p))
469          (else (throw "Not a port" p))))
470
471(define (call-with-input-file s p)
472     (let ((inport (open-input-file s)))
473          (if (eq? inport #f)
474               #f
475               (let ((res (p inport)))
476                    (close-input-port inport)
477                    res))))
478
479(define (call-with-output-file s p)
480     (let ((outport (open-output-file s)))
481          (if (eq? outport #f)
482               #f
483               (let ((res (p outport)))
484                    (close-output-port outport)
485                    res))))
486
487(define (with-input-from-file s p)
488     (let ((inport (open-input-file s)))
489          (if (eq? inport #f)
490               #f
491               (let ((prev-inport (current-input-port)))
492                    (set-input-port inport)
493                    (let ((res (p)))
494                         (close-input-port inport)
495                         (set-input-port prev-inport)
496                         res)))))
497
498(define (with-output-to-file s p)
499     (let ((outport (open-output-file s)))
500          (if (eq? outport #f)
501               #f
502               (let ((prev-outport (current-output-port)))
503                    (set-output-port outport)
504                    (let ((res (p)))
505                         (close-output-port outport)
506                         (set-output-port prev-outport)
507                         res)))))
508
509(define (with-input-output-from-to-files si so p)
510     (let ((inport (open-input-file si))
511           (outport (open-input-file so)))
512          (if (not (and inport outport))
513               (begin
514                    (close-input-port inport)
515                    (close-output-port outport)
516                    #f)
517               (let ((prev-inport (current-input-port))
518                     (prev-outport (current-output-port)))
519                    (set-input-port inport)
520                    (set-output-port outport)
521                    (let ((res (p)))
522                         (close-input-port inport)
523                         (close-output-port outport)
524                         (set-input-port prev-inport)
525                         (set-output-port prev-outport)
526                         res)))))
527
528; Random number generator (maximum cycle)
529(define *seed* 1)
530(define (random-next)
531     (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
532          (set! *seed*
533               (-   (* a (- *seed*
534                         (* (quotient *seed* q) q)))
535                    (* (quotient *seed* q) r)))
536          (if (< *seed* 0) (set! *seed* (+ *seed* m)))
537          *seed*))
538;; SRFI-0
539;; COND-EXPAND
540;; Implemented as a macro
541(define *features* '(srfi-0))
542
543(define-macro (cond-expand . cond-action-list)
544  (cond-expand-runtime cond-action-list))
545
546(define (cond-expand-runtime cond-action-list)
547  (if (null? cond-action-list)
548      #t
549      (if (cond-eval (caar cond-action-list))
550          `(begin ,@(cdar cond-action-list))
551          (cond-expand-runtime (cdr cond-action-list)))))
552
553(define (cond-eval-and cond-list)
554  (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
555
556(define (cond-eval-or cond-list)
557  (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
558
559(define (cond-eval condition)
560  (cond ((symbol? condition)
561	 (if (member condition *features*) #t #f))
562	((eq? condition #t) #t)
563	((eq? condition #f) #f)
564	(else (case (car condition)
565		((and) (cond-eval-and (cdr condition)))
566		((or) (cond-eval-or (cdr condition)))
567		((not) (if (not (null? (cddr condition)))
568			   (error "cond-expand : 'not' takes 1 argument")
569			   (not (cond-eval (cadr condition)))))
570		(else (error "cond-expand : unknown operator" (car condition)))))))
571
572(gc-verbose #f)
573