ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/microscheme/init.scm
Revision: 1.19
Committed: Tue Dec 1 03:44:32 2015 UTC (8 years, 6 months ago) by root
Branch: MAIN
Changes since 1.18: +6 -2 lines
Log Message:
more r7rs

File Contents

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