diff options
Diffstat (limited to 'mitscheme.init')
| -rwxr-xr-x[-rw-r--r--] | mitscheme.init | 127 |
1 files changed, 69 insertions, 58 deletions
diff --git a/mitscheme.init b/mitscheme.init index fdf1c95..8e07241 100644..100755 --- a/mitscheme.init +++ b/mitscheme.init @@ -198,7 +198,7 @@ ;;; sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. - defmacro ;has Common Lisp DEFMACRO +;;; defmacro ;has Common Lisp DEFMACRO record ;has user defined data structures string-port ;has CALL-WITH-INPUT-STRING and ;CALL-WITH-OUTPUT-STRING @@ -222,13 +222,21 @@ Xwindows )) +(define system run-shell-command) +(define (print-call-stack port) #f) + ; **** MIT Scheme has SORT, but SORT! accepts only vectors. (define sort! sort) (define mit-scheme-has-r4rs-macros? (mit-scheme-release>= 7 7)) +(define mit-scheme-supports-defmacro? + (and mit-scheme-has-r4rs-macros? + (not (mit-scheme-release>= 9 0)))) (if mit-scheme-has-r4rs-macros? (set! slib:features (cons 'macro slib:features))) +(if mit-scheme-supports-defmacro? + (set! slib:features (cons 'defmacro slib:features))) (if (get-subsystem-version-string "6.001") ;; Runs code from "Structure and Interpretation of Computer @@ -336,78 +344,81 @@ (define *macros* '(defmacro)) (define (defmacro? m) (and (memq m *macros*) #t)) -(if mit-scheme-has-r4rs-macros? - (environment-define-macro user-initial-environment 'defmacro - (non-hygienic-macro-transformer->expander - (lambda arguments - (let ((name (car arguments))) - `(begin - (set! *macros* (cons ',name *macros*)) - (environment-define-macro user-initial-environment ',name - (non-hygienic-macro-transformer->expander - (lambda ,@(cdr arguments)) - user-initial-environment))))) - user-initial-environment)) - (syntax-table-define system-global-syntax-table 'defmacro - (macro defmacargs - (let ((macname (car defmacargs)) (macargs (cadr defmacargs)) - (macbdy (cddr defmacargs))) - `(begin - (set! *macros* (cons ',macname *macros*)) - (syntax-table-define system-global-syntax-table ',macname - (macro ,macargs ,@macbdy))))))) +(if mit-scheme-supports-defmacro? + (if mit-scheme-has-r4rs-macros? + (environment-define-macro + user-initial-environment 'defmacro + (non-hygienic-macro-transformer->expander + (lambda arguments + (let ((name (car arguments))) + `(begin + (set! *macros* (cons ',name *macros*)) + (environment-define-macro user-initial-environment ',name + (non-hygienic-macro-transformer->expander + (lambda ,@(cdr arguments)) + user-initial-environment))))) + user-initial-environment)) + (syntax-table-define system-global-syntax-table 'defmacro + (macro defmacargs + (let ((macname (car defmacargs)) (macargs (cadr defmacargs)) + (macbdy (cddr defmacargs))) + `(begin + (set! *macros* (cons ',macname *macros*)) + (syntax-table-define system-global-syntax-table ',macname + (macro ,macargs ,@macbdy)))))))) (define macroexpand-1) (define macroexpand) -(let ((finish - (lambda (get-transformer apply-transformer) - (set! macroexpand-1 +(if mit-scheme-supports-defmacro? + (let ((finish + (lambda (get-transformer apply-transformer) + (set! macroexpand-1 + (lambda (form) + (let ((transformer (get-transformer form))) + (if transformer + (apply-transformer transformer form) + form)))) + (set! macroexpand + (lambda (form) + (let ((transformer (get-transformer form))) + (if transformer + (macroexpand (apply-transformer transformer form)) + form))))))) + (if mit-scheme-has-r4rs-macros? + (let ((e (->environment '(runtime syntactic-closures)))) + (let ((strip-keyword-value-item (access strip-keyword-value-item e)) + (expander-item/expander (access expander-item/expander e)) + (expander-item/environment (access expander-item/environment e))) + (finish (lambda (form) - (let ((transformer (get-transformer form))) - (if transformer - (apply-transformer transformer form) - form)))) - (set! macroexpand - (lambda (form) - (let ((transformer (get-transformer form))) - (if transformer - (macroexpand (apply-transformer transformer form)) - form))))))) - (if mit-scheme-has-r4rs-macros? - (let ((e (->environment '(runtime syntactic-closures)))) - (let ((strip-keyword-value-item (access strip-keyword-value-item e)) - (expander-item/expander (access expander-item/expander e)) - (expander-item/environment (access expander-item/environment e))) + (and (pair? form) + (let ((a (car form))) + (and (symbol? a) + (defmacro? a) + (environment-lookup-macro user-initial-environment + a))))) + (lambda (item form) + (let ((item (strip-keyword-value-item item))) + ((expander-item/expander item) + form + user-initial-environment + (expander-item/environment item))))))) (finish (lambda (form) (and (pair? form) (let ((a (car form))) (and (symbol? a) (defmacro? a) - (environment-lookup-macro user-initial-environment - a))))) - (lambda (item form) - (let ((item (strip-keyword-value-item item))) - ((expander-item/expander item) - form - user-initial-environment - (expander-item/environment item))))))) - (finish - (lambda (form) - (and (pair? form) - (let ((a (car form))) - (and (symbol? a) - (defmacro? a) - (syntax-table-ref system-global-syntax-table a))))) - (apply-transformer - (lambda (transformer form) - (apply transformer (cdr form))))))) + (syntax-table-ref system-global-syntax-table a))))) + (apply-transformer + (lambda (transformer form) + (apply transformer (cdr form)))))))) (define gentemp generate-uninterned-symbol) (define defmacro:eval slib:eval) (define defmacro:load load) -(if mit-scheme-has-r4rs-macros? +(if mit-scheme-supports-defmacro? (begin (environment-define (the-environment) 'macro:eval slib:eval) (environment-define (the-environment) 'macro:load load))) |