| … | |
… | |
| 607 | |
607 | |
| 608 | (define (raise x) |
608 | (define (raise x) |
| 609 | (raise-continuable x) |
609 | (raise-continuable x) |
| 610 | (error "raise: exception handler returned")) |
610 | (error "raise: exception handler returned")) |
| 611 | |
611 | |
| 612 | (with-exception-handler |
612 | ;(with-exception-handler |
| 613 | (lambda () (display (list "xerror"))) |
613 | ; (lambda () (display (list "xerror"))) |
| 614 | (lambda () (begin (display ("aaa") (raise 5))))) |
614 | ; (lambda () (begin (display ("aaa") (raise 5))))) |
| 615 | |
615 | |
| 616 | ;TODO: a lot more is missing, and it doesn't work |
616 | ;TODO: a lot more is missing, and it doesn't work |
| 617 | |
617 | |
| 618 | ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL |
618 | ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL |
| 619 | |
619 | |
| … | |
… | |
| 752 | ; compatibility functions added by schmorp@schmorp.de |
752 | ; compatibility functions added by schmorp@schmorp.de |
| 753 | (macro (defmacro dform) |
753 | (macro (defmacro dform) |
| 754 | (let ((name (cadr dform)) (formals (caddr dform)) (body (cdddr dform))) |
754 | (let ((name (cadr dform)) (formals (caddr dform)) (body (cdddr dform))) |
| 755 | `(define-macro (,name . ,formals) ,@body))) |
755 | `(define-macro (,name . ,formals) ,@body))) |
| 756 | |
756 | |
| 757 | ;; simple syntax-rules |
|
|
| 758 | |
|
|
| 759 | ;; values/call-with-values |
|
|
| 760 | (load "simple-syntax-rules/values.scm") |
|
|
| 761 | ;; (hash-)table |
|
|
| 762 | ;(load "simple-syntax-rules/table.scm") |
|
|
| 763 | ;; "the real stuff" |
|
|
| 764 | ;(load "simple-syntax-rules/usual.scm") |
|
|
| 765 | ;(load "simple-syntax-rules/rules.scm") |
|
|
| 766 | ;(load "simple-syntax-rules/memo.scm") |
|
|
| 767 | ;(load "simple-syntax-rules/syntax.scm") |
|
|
| 768 | ;(load "simple-syntax-rules/ev.scm") |
|
|
| 769 | ;(load "simple-syntax-rules/ex.scm") |
|
|
| 770 | ;(macro (define-syntax form) (expand form top-level-env)) |
|
|
| 771 | |
|
|
| 772 | ;(load "macros/expand.scm") |
|
|
| 773 | ;(load "macros/misc.scm") |
|
|
| 774 | ;(load "macros/prefs.scm") |
|
|
| 775 | ;(load "macros/syntaxenv.scm") |
|
|
| 776 | ;(load "macros/syntaxrules.scm") |
|
|
| 777 | ;(load "macros/usual.scm") |
|
|
| 778 | |
|
|
| 779 | ;; r7rs |
757 | ;; r7rs |
| 780 | ; sring-map, vector-map, string-for-each, vector-for-each |
758 | ; sring-map, vector-map, string-for-each, vector-for-each |
| 781 | ; bytevectors |
759 | ; bytevectors |
| 782 | |
760 | |
| 783 | ;; srfi-1 |
761 | ;; srfi-1 |
| … | |
… | |
| 825 | |
803 | |
| 826 | ;; end of init |
804 | ;; end of init |
| 827 | |
805 | |
| 828 | ;(load "test.scm") |
806 | ;(load "test.scm") |
| 829 | |
807 | |
| 830 | (define $sc-put-cte #f) |
808 | ;; macros-by-example |
| 831 | (define sc-expand #f) |
|
|
| 832 | (define $make-environment #f) |
|
|
| 833 | ;(define environment? #f) |
|
|
| 834 | ;(define interaction-environment #f) |
|
|
| 835 | (define identifier? #f) |
|
|
| 836 | (define syntax->list #f) |
|
|
| 837 | (define syntax->vector #f) |
|
|
| 838 | (define syntax-object->datum #f) |
|
|
| 839 | (define datum->syntax-object #f) |
|
|
| 840 | (define generate-temporaries #f) |
|
|
| 841 | (define free-identifier=? #f) |
|
|
| 842 | (define bound-identifier=? #f) |
|
|
| 843 | (define literal-identifier=? #f) |
|
|
| 844 | (define syntax-error #f) |
|
|
| 845 | (define $syntax-dispatch #f) |
|
|
| 846 | |
809 | |
| 847 | (define void (lambda () (if #f #f))) |
|
|
| 848 | |
|
|
| 849 | (define andmap |
810 | (define append! |
| 850 | (lambda (f first . rest) |
811 | (lambda args |
| 851 | (or (null? first) |
812 | (cond ((null? args) '()) |
|
|
813 | ((null? (cdr args)) (car args)) |
|
|
814 | ((null? (car args)) (apply comlist:nconc (cdr args))) |
|
|
815 | (else |
|
|
816 | (set-cdr! (last-pair (car args)) |
|
|
817 | (apply comlist:nconc (cdr args))) |
|
|
818 | (car args))))) |
|
|
819 | |
|
|
820 | (define (some pred lst . rest) |
|
|
821 | (cond ((null? rest) |
|
|
822 | (let mapf ((lst lst)) |
|
|
823 | (and (not (null? lst)) |
|
|
824 | (or (pred (car lst)) (mapf (cdr lst)))))) |
|
|
825 | (else (let mapf ((lst lst) (rest rest)) |
|
|
826 | (and (not (null? lst)) |
|
|
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)) |
| 852 | (if (null? rest) |
833 | (or (null? lst) |
| 853 | (let andmap ((first first)) |
834 | (and (pred (car lst)) (mapf (cdr lst)))))) |
| 854 | (let ((x (car first)) (first (cdr first))) |
835 | (else (let mapf ((lst lst) (rest rest)) |
| 855 | (if (null? first) |
836 | (or (null? lst) |
| 856 | (f x) |
|
|
| 857 | (and (f x) (andmap first))))) |
|
|
| 858 | (let andmap ((first first) (rest rest)) |
|
|
| 859 | (let ((x (car first)) |
|
|
| 860 | (xr (map car rest)) |
|
|
| 861 | (first (cdr first)) |
|
|
| 862 | (rest (map cdr rest))) |
837 | (and (apply pred (car lst) (map car rest)) |
| 863 | (if (null? first) |
838 | (mapf (cdr lst) (map cdr rest)))))))) |
| 864 | (apply f (cons x xr)) |
|
|
| 865 | (and (apply f (cons x xr)) (andmap first rest))))))))) |
|
|
| 866 | |
839 | |
| 867 | (define ormap |
840 | (load "mbe.scm") |
| 868 | (lambda (proc list1) |
|
|
| 869 | (and (not (null? list1)) |
|
|
| 870 | (or (proc (car list1)) (ormap proc (cdr list1)))))) |
|
|
| 871 | |
|
|
| 872 | (define *properties* '()) |
|
|
| 873 | |
|
|
| 874 | (define (putprop sym k v) |
|
|
| 875 | (set! *properties* (acons (list sym k) v *properties*))) |
|
|
| 876 | |
|
|
| 877 | (define (remprop sym k) |
|
|
| 878 | (putprop sym k #f)) |
|
|
| 879 | |
|
|
| 880 | (define (getprop sym k) |
|
|
| 881 | (assoc (list sym k) *properties*)) |
|
|
| 882 | |
|
|
| 883 | (load "psyntax.pp") |
|
|
| 884 | |
|
|
| 885 | ;(define *compile-hook* sc-expand) |
|
|
| 886 | |
841 | |
| 887 | (load "test.scm") |
842 | (load "test.scm") |
| 888 | |
843 | |
| 889 | (gc-verbose #f) |
844 | (gc-verbose #f) |
