| 1 | ; Initialization file for TinySCHEME 1.41 |
1 | ; Initialization file for TinySCHEME 1.41 |
| 2 | |
2 | |
| 3 | ; Per R5RS, up to four deep compositions should be defined |
3 | (gc-verbose #t) |
| 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 | |
4 | |
| 33 | ;;;; Utility to ease macro creation |
5 | ;;;; Utility to ease macro creation |
| 34 | (define (macro-expand form) |
6 | (define (macro-expand form) |
| 35 | ((eval (get-closure-code (eval (car form)))) form)) |
7 | ((eval (get-closure-code (eval (car form)))) form)) |
| 36 | |
8 | |
| … | |
… | |
| 57 | (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form)))))) |
29 | (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form)))))) |
| 58 | |
30 | |
| 59 | ; Utilities for math. Notice that inexact->exact is primitive, |
31 | ; Utilities for math. Notice that inexact->exact is primitive, |
| 60 | ; but exact->inexact is not. |
32 | ; but exact->inexact is not. |
| 61 | (define exact? integer?) |
33 | (define exact? integer?) |
|
|
34 | (define exact-integer? integer?) |
| 62 | (define (inexact? x) (and (real? x) (not (integer? x)))) |
35 | (define (inexact? x) (and (real? x) (not (integer? x)))) |
|
|
36 | (define (exact->inexact n) (* n 1.0)) |
|
|
37 | (define exact inexact->exact) |
|
|
38 | (define inexact exact->inexact) |
| 63 | (define (even? n) (= (remainder n 2) 0)) |
39 | (define (even? n) (= (remainder n 2) 0)) |
| 64 | (define (odd? n) (not (= (remainder n 2) 0))) |
40 | (define (odd? n) (not (= (remainder n 2) 0))) |
| 65 | (define (zero? n) (= n 0)) |
41 | (define (zero? n) (= n 0)) |
| 66 | (define (positive? n) (> n 0)) |
42 | (define (positive? n) (> n 0)) |
| 67 | (define (negative? n) (< n 0)) |
43 | (define (negative? n) (< n 0)) |
| 68 | (define complex? number?) |
44 | (define complex? number?) |
| 69 | (define rational? real?) |
45 | (define rational? real?) |
| 70 | (define (abs n) (if (>= n 0) n (- n))) |
46 | (define (abs n) (if (>= n 0) n (- n))) |
| 71 | (define (exact->inexact n) (* n 1.0)) |
|
|
| 72 | (define (<> n1 n2) (not (= n1 n2))) |
47 | (define (<> n1 n2) (not (= n1 n2))) |
|
|
48 | (define (square n) (* n n)) |
|
|
49 | ;; missing: numerator denominator rationalize exact-integer-sqrt |
| 73 | |
50 | |
| 74 | ; min and max must return inexact if any arg is inexact; use (+ n 0.0) |
51 | ; min and max must return inexact if any arg is inexact |
| 75 | (define (max . lst) |
52 | (define (max . lst) |
| 76 | (foldr (lambda (a b) |
53 | (foldr (lambda (a b) |
| 77 | (if (> a b) |
54 | (if (> a b) |
| 78 | (if (exact? b) a (+ a 0.0)) |
55 | (if (exact? b) a (exact->inexact a)) |
| 79 | (if (exact? a) b (+ b 0.0)))) |
56 | (if (exact? a) b (exact->inexact b)))) |
| 80 | (car lst) (cdr lst))) |
57 | (car lst) (cdr lst))) |
| 81 | (define (min . lst) |
58 | (define (min . lst) |
| 82 | (foldr (lambda (a b) |
59 | (foldr (lambda (a b) |
| 83 | (if (< a b) |
60 | (if (< a b) |
| 84 | (if (exact? b) a (+ a 0.0)) |
61 | (if (exact? b) a (exact->inexact a)) |
| 85 | (if (exact? a) b (+ b 0.0)))) |
62 | (if (exact? a) b (exact->inexact b)))) |
| 86 | (car lst) (cdr lst))) |
63 | (car lst) (cdr lst))) |
| 87 | |
64 | |
| 88 | (define (succ x) (+ x 1)) |
65 | (define (succ x) (+ x 1)) |
| 89 | (define (pred x) (- x 1)) |
66 | (define (pred x) (- x 1)) |
| 90 | (define gcd |
67 | (define gcd |
| … | |
… | |
| 132 | (let loop ((n (pred (string-length s))) (l '())) |
109 | (let loop ((n (pred (string-length s))) (l '())) |
| 133 | (if (= n -1) |
110 | (if (= n -1) |
| 134 | l |
111 | l |
| 135 | (loop (pred n) (cons (string-ref s n) l))))) |
112 | (loop (pred n) (cons (string-ref s n) l))))) |
| 136 | |
113 | |
| 137 | (define (string-copy str) |
114 | ;TODO string-upcase |
| 138 | (string-append str)) |
115 | ;TODO string-downcase |
|
|
116 | ;TODO string-foldcase |
|
|
117 | ;TODO string-copy! |
|
|
118 | ;TODO string-fill! |
|
|
119 | |
|
|
120 | (define substring string-copy) |
| 139 | |
121 | |
| 140 | (define (string->anyatom str pred) |
122 | (define (string->anyatom str pred) |
| 141 | (let* ((a (string->atom str))) |
123 | (let* ((a (string->atom str))) |
| 142 | (if (pred a) a |
124 | (if (pred a) a |
| 143 | (error "string->xxx: not a xxx" a)))) |
125 | (error "string->xxx: not a xxx" a)))) |
| … | |
… | |
| 169 | (define (char-ci=? a b) (char-ci-cmp? = a b)) |
151 | (define (char-ci=? a b) (char-ci-cmp? = a b)) |
| 170 | (define (char-ci<? a b) (char-ci-cmp? < a b)) |
152 | (define (char-ci<? a b) (char-ci-cmp? < a b)) |
| 171 | (define (char-ci>? a b) (char-ci-cmp? > a b)) |
153 | (define (char-ci>? a b) (char-ci-cmp? > a b)) |
| 172 | (define (char-ci<=? a b) (char-ci-cmp? <= a b)) |
154 | (define (char-ci<=? a b) (char-ci-cmp? <= a b)) |
| 173 | (define (char-ci>=? a b) (char-ci-cmp? >= a b)) |
155 | (define (char-ci>=? a b) (char-ci-cmp? >= a b)) |
|
|
156 | |
|
|
157 | (define (digit-value ch) |
|
|
158 | (if (and (char<=? #\0 ch) (char<=? ch #\9)) |
|
|
159 | (- (char->integer ch) (char->integer #\0)) |
|
|
160 | #f)) |
|
|
161 | |
|
|
162 | (define char-foldcase char-downcase) |
| 174 | |
163 | |
| 175 | ; Note the trick of returning (cmp x y) |
164 | ; Note the trick of returning (cmp x y) |
| 176 | (define (string-cmp? chcmp cmp a b) |
165 | (define (string-cmp? chcmp cmp a b) |
| 177 | (let ((na (string-length a)) (nb (string-length b))) |
166 | (let ((na (string-length a)) (nb (string-length b))) |
| 178 | (let loop ((i 0)) |
167 | (let loop ((i 0)) |
| … | |
… | |
| 237 | (let* ((unz (apply unzip1-with-cdr lists)) |
226 | (let* ((unz (apply unzip1-with-cdr lists)) |
| 238 | (cars (car unz)) |
227 | (cars (car unz)) |
| 239 | (cdrs (cdr unz))) |
228 | (cdrs (cdr unz))) |
| 240 | (apply proc cars) (apply map (cons proc cdrs)))))) |
229 | (apply proc cars) (apply map (cons proc cdrs)))))) |
| 241 | |
230 | |
|
|
231 | (define (make-list k . fill) (vector->list (vector k (car fill)))) |
|
|
232 | |
|
|
233 | (define (list-copy l) (vector->list (list->vector l))) |
|
|
234 | |
| 242 | (define (list-tail x k) |
235 | (define (list-tail x k) |
| 243 | (if (zero? k) |
236 | (if (zero? k) |
| 244 | x |
237 | x |
| 245 | (list-tail (cdr x) (- k 1)))) |
238 | (list-tail (cdr x) (- k 1)))) |
| 246 | |
239 | |
| … | |
… | |
| 266 | (loop (succ i)))))))) |
259 | (loop (succ i)))))))) |
| 267 | |
260 | |
| 268 | (define (list->vector x) |
261 | (define (list->vector x) |
| 269 | (apply vector x)) |
262 | (apply vector x)) |
| 270 | |
263 | |
|
|
264 | ;TODO vector-fill! v e start end |
| 271 | (define (vector-fill! v e) |
265 | (define (vector-fill! v e) |
| 272 | (let ((n (vector-length v))) |
266 | (let ((n (vector-length v))) |
| 273 | (let loop ((i 0)) |
267 | (let loop ((i 0)) |
| 274 | (if (= i n) |
268 | (if (= i n) |
| 275 | v |
269 | v |
| … | |
… | |
| 278 | (define (vector->list v) |
272 | (define (vector->list v) |
| 279 | (let loop ((n (pred (vector-length v))) (l '())) |
273 | (let loop ((n (pred (vector-length v))) (l '())) |
| 280 | (if (= n -1) |
274 | (if (= n -1) |
| 281 | l |
275 | l |
| 282 | (loop (pred n) (cons (vector-ref v n) l))))) |
276 | (loop (pred n) (cons (vector-ref v n) l))))) |
|
|
277 | |
|
|
278 | ;TODO vector->string vector start end |
|
|
279 | |
|
|
280 | (define (string->vector . args) |
|
|
281 | (list->vector (string->list (apply string-copy args)))) |
|
|
282 | |
|
|
283 | ;TODO vector-copy v s e |
|
|
284 | ;TODO vector-copy! to at v s e |
|
|
285 | |
|
|
286 | (define (vector-append hd . tl) |
|
|
287 | (if (null? tl) |
|
|
288 | hd |
|
|
289 | (list->vector (append (hd (vector->list (vector-append tl))))))) |
| 283 | |
290 | |
| 284 | ;; The following quasiquote macro is due to Eric S. Tiedemann. |
291 | ;; The following quasiquote macro is due to Eric S. Tiedemann. |
| 285 | ;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. |
292 | ;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. |
| 286 | ;; |
293 | ;; |
| 287 | ;; Subsequently modified to handle vectors: D. Souflis |
294 | ;; Subsequently modified to handle vectors: D. Souflis |
| … | |
… | |
| 447 | result))) |
454 | result))) |
| 448 | outer-env))) |
455 | outer-env))) |
| 449 | |
456 | |
| 450 | (define call/cc call-with-current-continuation) |
457 | (define call/cc call-with-current-continuation) |
| 451 | |
458 | |
|
|
459 | (define (symbol=? hd . tl) |
|
|
460 | (if (null? tl) |
|
|
461 | #t |
|
|
462 | (and (symbol? hd) (eq? hd (car tl)) (symbol=? (cdr tl))))) |
|
|
463 | |
|
|
464 | (define (boolean=? hd . tl) |
|
|
465 | (if (null? tl) |
|
|
466 | #t |
|
|
467 | (and (boolean? hd) (eq? hd (car tl)) (boolean=? (cdr tl))))) |
| 452 | |
468 | |
| 453 | ;;;;; atom? and equal? written by a.k |
469 | ;;;;; atom? and equal? written by a.k |
| 454 | |
470 | |
| 455 | ;;;; atom? |
471 | ;;;; atom? |
| 456 | (define (atom? x) |
472 | (define (atom? x) |
| … | |
… | |
| 567 | (define (throw . x) |
583 | (define (throw . x) |
| 568 | (if (more-handlers?) |
584 | (if (more-handlers?) |
| 569 | (apply (pop-handler)) |
585 | (apply (pop-handler)) |
| 570 | (apply error x))) |
586 | (apply error x))) |
| 571 | |
587 | |
|
|
588 | ; catch handler thunk |
| 572 | (macro (catch form) |
589 | (macro (catch form) |
| 573 | (let ((label (gensym))) |
590 | (let ((label (gensym))) |
| 574 | `(call/cc (lambda (exit) |
591 | `(call/cc (lambda (exit) |
| 575 | (push-handler (lambda () (exit ,(cadr form)))) |
592 | (push-handler (lambda () (exit ,(cadr form)))) |
| 576 | (let ((,label (begin ,@(cddr form)))) |
593 | (let ((,label (begin ,@(cddr form)))) |
| 577 | (pop-handler) |
594 | (pop-handler) |
| 578 | ,label))))) |
595 | ,label))))) |
| 579 | |
596 | |
| 580 | (define *error-hook* throw) |
597 | (define *error-hook* throw) |
| 581 | |
598 | |
|
|
599 | ; same as above, r7rs |
|
|
600 | (define (with-exception-handler handler thunk) |
|
|
601 | (catch (handler) (thunk))) |
|
|
602 | |
|
|
603 | (define (raise-continuable x) |
|
|
604 | (if (more-handlers?) |
|
|
605 | ((pop-handler) x) |
|
|
606 | (error x))) |
|
|
607 | |
|
|
608 | (define (raise x) |
|
|
609 | (raise-continuable x) |
|
|
610 | (error "raise: exception handler returned")) |
|
|
611 | |
|
|
612 | ;(with-exception-handler |
|
|
613 | ; (lambda () (display (list "xerror"))) |
|
|
614 | ; (lambda () (begin (display ("aaa") (raise 5))))) |
|
|
615 | |
|
|
616 | ;TODO: a lot more is missing, and it doesn't work |
| 582 | |
617 | |
| 583 | ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL |
618 | ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL |
| 584 | |
619 | |
| 585 | (macro (make-environment form) |
620 | (macro (make-environment form) |
| 586 | `(apply (lambda () |
621 | `(apply (lambda () |
| … | |
… | |
| 712 | ((not) (if (not (null? (cddr condition))) |
747 | ((not) (if (not (null? (cddr condition))) |
| 713 | (error "cond-expand : 'not' takes 1 argument") |
748 | (error "cond-expand : 'not' takes 1 argument") |
| 714 | (not (cond-eval (cadr condition))))) |
749 | (not (cond-eval (cadr condition))))) |
| 715 | (else (error "cond-expand : unknown operator" (car condition))))))) |
750 | (else (error "cond-expand : unknown operator" (car condition))))))) |
| 716 | |
751 | |
| 717 | (gc-verbose #f) |
|
|
| 718 | |
|
|
| 719 | ; compatibility functions added by schmorp@schmorp.de |
752 | ; compatibility functions added by schmorp@schmorp.de |
| 720 | (macro (defmacro dform) |
753 | (macro (defmacro dform) |
| 721 | (let ((name (cadr dform)) (formals (caddr dform)) (body (cdddr dform))) |
754 | (let ((name (cadr dform)) (formals (caddr dform)) (body (cdddr dform))) |
| 722 | `(define-macro (,name . ,formals) ,@body))) |
755 | `(define-macro (,name . ,formals) ,@body))) |
| 723 | |
756 | |
|
|
757 | ;; r7rs |
|
|
758 | ; sring-map, vector-map, string-for-each, vector-for-each |
|
|
759 | ; bytevectors |
|
|
760 | |
| 724 | ;; srfi-1 |
761 | ;; srfi-1 |
| 725 | |
762 | |
| 726 | (define (check-arg pred val caller) |
763 | (define (check-arg pred val caller) |
| 727 | (let lp ((val val)) |
764 | (let lp ((val val)) |
| 728 | (if (pred val) val (lp (error "Bad argument" val pred caller))))) |
765 | (if (pred val) val (lp (error "Bad argument" val pred caller))))) |
| 729 | |
766 | |
|
|
767 | ; Some macros and functions that the SRFI 1 reference implementation |
|
|
768 | ; requires that it does not define and are not part of R5RS. |
|
|
769 | |
|
|
770 | (define-macro let-optionals |
|
|
771 | (lambda (input names . code) |
|
|
772 | (let ((input-left (gensym))) |
|
|
773 | `(let ((,input-left ,input)) |
|
|
774 | ,(let next ((names names)) |
|
|
775 | (if (null? names) |
|
|
776 | `(begin ,@code) |
|
|
777 | `(let ((,input-left (if (null? ,input-left) |
|
|
778 | '() |
|
|
779 | (cdr ,input-left))) |
|
|
780 | (,(caar names) (if (null? ,input-left) |
|
|
781 | ,(cadar names) |
|
|
782 | (car ,input-left)))) |
|
|
783 | ,(next (cdr names))))))))) |
|
|
784 | |
|
|
785 | (define-macro receive |
|
|
786 | (lambda (names values . code) |
|
|
787 | `(call-with-values (lambda () ,values) |
|
|
788 | (lambda ,names ,@code)))) |
|
|
789 | |
|
|
790 | |
|
|
791 | (define (:optional data default) |
|
|
792 | (if (null? data) |
|
|
793 | default |
|
|
794 | (car data))) |
|
|
795 | |
| 730 | (load "srfi-1-reference.scm") |
796 | (load "srfi-1.scm") |
|
|
797 | |
|
|
798 | ;(load "srfi-55.scm") |
|
|
799 | |
|
|
800 | ;(register-extension '(srfi 1) (lamba () (load "srfi-1.scm"))) |
|
|
801 | ;(register-extension '(srfi 23) (lamba () ())) ; error builtin |
|
|
802 | ;(register-extension '(srfi 55) (lamba () ())) ; always available |
| 731 | |
803 | |
| 732 | ;; end of init |
804 | ;; end of init |
| 733 | |
805 | |
| 734 | ;(do ((j 0 (+ j 1))) ((> j 100000)) ()) |
806 | ;(load "test.scm") |
| 735 | |
807 | |
| 736 | ;(define call/cc call-with-current-continuation) |
808 | ;; macros-by-example |
| 737 | |
809 | |
| 738 | (define (coroutine routine) |
810 | (define append! |
| 739 | (let ((current routine) |
|
|
| 740 | (status 'suspended)) |
|
|
| 741 | (lambda args |
811 | (lambda args |
| 742 | (cond ((null? args) |
812 | (cond ((null? args) '()) |
| 743 | (if (eq? status 'dead) |
813 | ((null? (cdr args)) (car args)) |
| 744 | (error 'dead-coroutine) |
814 | ((null? (car args)) (apply comlist:nconc (cdr args))) |
| 745 | (let ((continuation-and-value |
|
|
| 746 | (call/cc (lambda (return) |
|
|
| 747 | (let ((returner |
|
|
| 748 | (lambda (value) |
|
|
| 749 | (call/cc (lambda (next) |
|
|
| 750 | (return (cons next value))))))) |
|
|
| 751 | (current returner) |
|
|
| 752 | (set! status 'dead)))))) |
|
|
| 753 | (if (pair? continuation-and-value) |
|
|
| 754 | (begin (set! current (car continuation-and-value)) |
|
|
| 755 | (cdr continuation-and-value)) |
|
|
| 756 | continuation-and-value)))) |
|
|
| 757 | ((eq? (car args) 'status?) status) |
|
|
| 758 | ((eq? (car args) 'dead?) (eq? status 'dead)) |
|
|
| 759 | ((eq? (car args) 'alive?) (not (eq? status 'dead))) |
|
|
| 760 | ((eq? (car args) 'kill!) (set! status 'dead)) |
|
|
| 761 | (true nil))))) |
|
|
| 762 | |
|
|
| 763 | (define test-coroutine-1 |
|
|
| 764 | (coroutine (lambda (yield) |
|
|
| 765 | (display "HELLO!") |
|
|
| 766 | (yield 1) |
815 | (else |
| 767 | (display "WORLD!") |
816 | (set-cdr! (last-pair (car args)) |
| 768 | (yield 2) |
817 | (apply comlist:nconc (cdr args))) |
| 769 | (display "SORRY, I'M OUT")))) |
818 | (car args))))) |
| 770 | (test-coroutine-1 'status?) |
819 | |
| 771 | (test-coroutine-1 'dead?) |
820 | (define (some pred lst . rest) |
| 772 | (test-coroutine-1 'alive?) |
821 | (cond ((null? rest) |
| 773 | (test-coroutine-1) |
822 | (let mapf ((lst lst)) |
| 774 | (test-coroutine-1) |
823 | (and (not (null? lst)) |
| 775 | (test-coroutine-1) |
824 | (or (pred (car lst)) (mapf (cdr lst)))))) |
| 776 | (test-coroutine-1 'status?) |
825 | (else (let mapf ((lst lst) (rest rest)) |
| 777 | (test-coroutine-1 'dead?) |
826 | (and (not (null? lst)) |
| 778 | (test-coroutine-1) |
827 | (or (apply pred (car lst) (map car rest)) |
|
|
828 | (mapf (cdr lst) (map cdr rest)))))))) |
|
|
829 | |
|
|
830 | (define (every pred lst . rest) |
|
|
831 | (cond ((null? rest) |
|
|
832 | (let mapf ((lst lst)) |
|
|
833 | (or (null? lst) |
|
|
834 | (and (pred (car lst)) (mapf (cdr lst)))))) |
|
|
835 | (else (let mapf ((lst lst) (rest rest)) |
|
|
836 | (or (null? lst) |
|
|
837 | (and (apply pred (car lst) (map car rest)) |
|
|
838 | (mapf (cdr lst) (map cdr rest)))))))) |
|
|
839 | |
|
|
840 | (load "mbe.scm") |
|
|
841 | |
|
|
842 | (load "test.scm") |
|
|
843 | |
|
|
844 | (gc-verbose #f) |
