| … | |
… | |
| 712 | ((not) (if (not (null? (cddr condition))) |
712 | ((not) (if (not (null? (cddr condition))) |
| 713 | (error "cond-expand : 'not' takes 1 argument") |
713 | (error "cond-expand : 'not' takes 1 argument") |
| 714 | (not (cond-eval (cadr condition))))) |
714 | (not (cond-eval (cadr condition))))) |
| 715 | (else (error "cond-expand : unknown operator" (car condition))))))) |
715 | (else (error "cond-expand : unknown operator" (car condition))))))) |
| 716 | |
716 | |
| 717 | (gc-verbose #f) |
717 | (gc-verbose #t) |
| 718 | |
718 | |
| 719 | ; compatibility functions added by schmorp@schmorp.de |
719 | ; compatibility functions added by schmorp@schmorp.de |
| 720 | (macro (defmacro dform) |
720 | (macro (defmacro dform) |
| 721 | (let ((name (cadr dform)) (formals (caddr dform)) (body (cdddr dform))) |
721 | (let ((name (cadr dform)) (formals (caddr dform)) (body (cdddr dform))) |
| 722 | `(define-macro (,name . ,formals) ,@body))) |
722 | `(define-macro (,name . ,formals) ,@body))) |
| 723 | |
723 | |
| 724 | ;; simple syntax-rules |
724 | ;; simple syntax-rules |
| 725 | |
725 | |
| 726 | ;; values/call-with-values |
726 | ;; values/call-with-values |
| 727 | ;(load "simple-syntax-rules/values.scm") |
727 | (load "simple-syntax-rules/values.scm") |
| 728 | ;; (hash-)table |
728 | ;; (hash-)table |
| 729 | ;(load "simple-syntax-rules/table.scm") |
729 | ;(load "simple-syntax-rules/table.scm") |
| 730 | ;; "the real stuff" |
730 | ;; "the real stuff" |
| 731 | ;(load "simple-syntax-rules/usual.scm") |
731 | ;(load "simple-syntax-rules/usual.scm") |
| 732 | ;(load "simple-syntax-rules/rules.scm") |
732 | ;(load "simple-syntax-rules/rules.scm") |
| … | |
… | |
| 755 | |
755 | |
| 756 | (define (check-arg pred val caller) |
756 | (define (check-arg pred val caller) |
| 757 | (let lp ((val val)) |
757 | (let lp ((val val)) |
| 758 | (if (pred val) val (lp (error "Bad argument" val pred caller))))) |
758 | (if (pred val) val (lp (error "Bad argument" val pred caller))))) |
| 759 | |
759 | |
|
|
760 | ; Some macros and functions that the SRFI 1 reference implementation |
|
|
761 | ; requires that it does not define and are not part of R5RS. |
|
|
762 | |
|
|
763 | (define-macro let-optionals |
|
|
764 | (lambda (input names . code) |
|
|
765 | (let ((input-left (gensym))) |
|
|
766 | `(let ((,input-left ,input)) |
|
|
767 | ,(let next ((names names)) |
|
|
768 | (if (null? names) |
|
|
769 | `(begin ,@code) |
|
|
770 | `(let ((,input-left (if (null? ,input-left) |
|
|
771 | '() |
|
|
772 | (cdr ,input-left))) |
|
|
773 | (,(caar names) (if (null? ,input-left) |
|
|
774 | ,(cadar names) |
|
|
775 | (car ,input-left)))) |
|
|
776 | ,(next (cdr names))))))))) |
|
|
777 | |
|
|
778 | (define-macro receive |
|
|
779 | (lambda (names values . code) |
|
|
780 | `(call-with-values (lambda () ,values) |
|
|
781 | (lambda ,names ,@code)))) |
|
|
782 | |
|
|
783 | |
|
|
784 | (define (:optional data default) |
|
|
785 | (if (null? data) |
|
|
786 | default |
|
|
787 | (car data))) |
|
|
788 | |
|
|
789 | (load "srfi-1.scm") |
|
|
790 | |
| 760 | ;(load "srfi-55.scm") |
791 | ;(load "srfi-55.scm") |
| 761 | |
792 | |
| 762 | ;(register-extension '(srfi 1) (lamba () (load "srfi-1.scm"))) |
793 | ;(register-extension '(srfi 1) (lamba () (load "srfi-1.scm"))) |
| 763 | ;(register-extension '(srfi 23) (lamba () ())) ; error builtin |
794 | ;(register-extension '(srfi 23) (lamba () ())) ; error builtin |
| 764 | ;(register-extension '(srfi 55) (lamba () ())) ; always available |
795 | ;(register-extension '(srfi 55) (lamba () ())) ; always available |
| 765 | |
|
|
| 766 | (load "srfi-1.scm") |
|
|
| 767 | |
796 | |
| 768 | ;; end of init |
797 | ;; end of init |
| 769 | |
798 | |
| 770 | ;(load "test.scm") |
799 | ;(load "test.scm") |
| 771 | |
800 | |
| … | |
… | |
| 774 | (define $make-environment #f) |
803 | (define $make-environment #f) |
| 775 | ;(define environment? #f) |
804 | ;(define environment? #f) |
| 776 | ;(define interaction-environment #f) |
805 | ;(define interaction-environment #f) |
| 777 | (define identifier? #f) |
806 | (define identifier? #f) |
| 778 | (define syntax->list #f) |
807 | (define syntax->list #f) |
|
|
808 | (define syntax->vector #f) |
| 779 | (define syntax-object->datum #f) |
809 | (define syntax-object->datum #f) |
| 780 | (define datum->syntax-object #f) |
810 | (define datum->syntax-object #f) |
| 781 | (define generate-temporaries #f) |
811 | (define generate-temporaries #f) |
| 782 | (define free-identifier=? #f) |
812 | (define free-identifier=? #f) |
| 783 | (define bound-identifier=? #f) |
813 | (define bound-identifier=? #f) |
| … | |
… | |
| 808 | (define ormap |
838 | (define ormap |
| 809 | (lambda (proc list1) |
839 | (lambda (proc list1) |
| 810 | (and (not (null? list1)) |
840 | (and (not (null? list1)) |
| 811 | (or (proc (car list1)) (ormap proc (cdr list1)))))) |
841 | (or (proc (car list1)) (ormap proc (cdr list1)))))) |
| 812 | |
842 | |
|
|
843 | (define *properties* '()) |
|
|
844 | |
|
|
845 | (define (putprop sym k v) |
|
|
846 | (set! *properties* (acons (list sym k) v *properties*))) |
|
|
847 | |
|
|
848 | (define (remprop sym k) |
|
|
849 | (putprop sym k #f)) |
|
|
850 | |
|
|
851 | (define (getprop sym k) |
|
|
852 | (assoc (list sym k) *properties*)) |
|
|
853 | |
| 813 | (load "psyntax.pp") |
854 | (load "psyntax.pp") |
