diff options
Diffstat (limited to 'csc/macros.csc')
| -rw-r--r-- | csc/macros.csc | 148 |
1 files changed, 72 insertions, 76 deletions
diff --git a/csc/macros.csc b/csc/macros.csc index e59973b..08c5fd2 100644 --- a/csc/macros.csc +++ b/csc/macros.csc @@ -1,6 +1,7 @@ (define-library (csc macros) (export expand + program->ir1 macro-syntax-error? builtins-environment) (import (scheme base) @@ -20,14 +21,13 @@ (only (csc ir1) lexical-ref-gensym lexical-ref? - library-ref-library - library-ref-name - library-ref? make-call make-constant make-lambda make-lambda-case - make-library-ref + make-letrec + make-sequence + make-toplevel-ref make-void sequence-head sequence-tail @@ -35,6 +35,8 @@ toplevel-define-expression toplevel-define-name toplevel-define? + toplevel-ref-name + toplevel-ref? void?) (only (csc list) revappend @@ -71,20 +73,15 @@ ; symbols is a map with identifiers as keys, and the values can be one of: ; - <lexical-ref>, - ; - <library-ref>, + ; - <toplevel-ref>, ; - or <macro-transformer>. ; The first two correspond to variables bound lexically or from a module, ; and the third represents a macro transformer bound in the ; current context. - ; - ; library holds information about what library toplevel defines will define - ; into. A value of nil means the main program. The special value 'lambda - ; means define should emit a <lambda-define> object. (define-record-type <environment> - (make-environment symbols library) + (make-environment symbols) environment? - (symbols environment-substitutions) - (library environment-library)) + (symbols environment-substitutions)) (define-record-type <syntax-object> @@ -117,7 +114,7 @@ (let ((environment (syntax-object-environment syntax))) (make-syntax-object (syntax->expression syntax) - (make-environment (insert (environment-substitutions environment) identifier binding) (environment-library environment)) + (make-environment (insert (environment-substitutions environment) identifier binding)) (marks syntax)))) @@ -152,10 +149,9 @@ (or (and (lexical-ref? b1) (lexical-ref? b2) (gensym=? (lexical-ref-gensym b1) (lexical-ref-gensym b2))) - (and (library-ref? b1) - (library-ref? b2) - (equal? (library-ref-library b1) (library-ref-library b2)) - (symbol=? (library-ref-name b1) (library-ref-name b2))) + (and (toplevel-ref? b1) + (toplevel-ref? b2) + (symbol=? (toplevel-ref-name b1) (toplevel-ref-name b2))) (and (macro-transformer? b1) (macro-transformer? b2) (eq? (transformer-function b1) (transformer-function b2))))) @@ -266,18 +262,18 @@ (define (expand-procedure-call procedure arguments) - (let-values (((expanded-procedure environment) (expand-syntax-object procedure)) - ((expanded-arguments) - (let loop ((arguments arguments) - (expanded-arguments '())) - (syntax-case arguments - ('() (reverse expanded-arguments)) - ((argument . rest) - (let-values (((expanded-argument environment) (expand-syntax-object argument))) - (loop - rest - (cons expanded-argument expanded-arguments)))) - (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments)))))) + (let ((expanded-procedure (expand-syntax-object procedure)) + (expanded-arguments + (let loop ((arguments arguments) + (expanded-arguments '())) + (syntax-case arguments + ('() (reverse expanded-arguments)) + ((argument . rest) + (let ((expanded-argument (expand-syntax-object argument))) + (loop + rest + (cons expanded-argument expanded-arguments)))) + (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments)))))) (make-call expanded-procedure expanded-arguments))) @@ -299,23 +295,23 @@ (let ((macro-body (resolve-identifier macro-name))) (if (macro-transformer? macro-body) ((transformer-function macro-body) syntax) - (values (expand-procedure-call macro-name tail) (syntax-object-environment syntax))))) + (expand-procedure-call macro-name tail)))) ((procedure . arguments) - (values (expand-procedure-call procedure arguments) (syntax-object-environment syntax))) + (expand-procedure-call procedure arguments)) (_ (when (identifier? syntax)) (let ((binding (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" syntax))) (lookup (environment-substitutions (syntax-object-environment syntax)) syntax)))) (if (macro-transformer? binding) (raise-syntax-error "macro is not allowed in this context" syntax) - (values binding (syntax-object-environment syntax))))) + binding))) (_ (when (let ((expr (syntax->expression syntax))) (or (boolean? expr) (char? expr) (number? expr) (string? expr) (vector? expr)))) - (values (make-constant (syntax->expression syntax)) (syntax-object-environment syntax))) + (make-constant (syntax->expression syntax))) (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax))))) @@ -337,7 +333,7 @@ (make-macro-transformer (lambda (syntax) (syntax-case syntax - ((_ datum) (values (make-constant (clean-syntax datum)) (syntax-object-environment syntax))) + ((_ datum) (make-constant (clean-syntax datum))) (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax))))))) @@ -387,8 +383,7 @@ '_ (make-environment (alist->substitutions - (list (cons '_ (make-library-ref '(csc builtins) '_ #t)))) - '()))))) + (list (cons '_ (make-toplevel-ref '_))))))))) (define (syntax-improper-list-length l) @@ -604,23 +599,20 @@ (make-environment (alist->substitutions (list (cons '_ - (make-library-ref '(csc builtins) '_ #t)))) - '()))) + (make-toplevel-ref '_))))))) (define builtin-syntax-rules (make-macro-transformer (lambda (syntax-rules-form) - (values - (make-macro-transformer - (lambda (input-form) - (syntax-case syntax-rules-form - ((_ ellipsis literals . rules) (when (identifier? ellipsis)) - (syntax-match ellipsis literals rules input-form)) - ((_ literals . rules) - (syntax-match default-ellipsis literals rules input-form)) - (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form))))) - (syntax-object-environment syntax-rules-form))))) + (make-macro-transformer + (lambda (input-form) + (syntax-case syntax-rules-form + ((_ ellipsis literals . rules) (when (identifier? ellipsis)) + (syntax-match ellipsis literals rules input-form)) + ((_ literals . rules) + (syntax-match default-ellipsis literals rules input-form)) + (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form)))))))) (define builtin-let-syntax @@ -628,11 +620,9 @@ (lambda (x) (syntax-case x ((_ (ident transformer-form) body-form) (when (identifier? ident)) - (let*-values (((transformer environment) (expand-syntax-object transformer-form)) - ((body environment) (expand-syntax-object (with-binding ident transformer body-form)))) - (values - body - (syntax-object-environment x)))) + (let* ((transformer (expand-syntax-object transformer-form)) + (body (expand-syntax-object (with-binding ident transformer body-form)))) + body)) (_ (raise-syntax-error "unexpected for in let-syntax")))))) @@ -648,17 +638,9 @@ (_ (raise-syntax-error "unexpected form in case-lambda" formals)))) - (define-record-type <lambda-define> - (make-lambda-define name gensym expression) - lambda-define? - (name lambda-define-name) - (gensym lambda-define-gensym) - (expression lambda-define-expression)) - - (define (collect-defines acc body) (cond - ((lambda-define? body) + ((toplevel-define? body) (values (cons body acc) (make-void))) @@ -678,9 +660,9 @@ (define (fix-lambda-body body) (define-values (defines rest) (collect-defines '() body)) (define-values (names gensyms vals) (loop for def in defines - collect (lambda-define-name def) into names - collect (lambda-define-gensym def) into gensyms - collect (lambda-define-expression def) into vals + collect (toplevel-define-name def) into names + collect (gensym) into gensyms + collect (toplevel-define-expression def) into vals finally (return (values names gensyms vals)))) (make-letrec #t @@ -690,13 +672,6 @@ rest)) - (define (with-library lib expr) - (make-syntax-object - (syntax->expression expr) - (make-environment (environment-symbols (syntax-object-environment expr)) lib) - (marks expr))) - - (define (case-lambda-helper form) (syntax-case form ('() '()) @@ -710,7 +685,7 @@ (if rest (cons rest args) args)) - (fix-lambda-body (expand-syntax-object (with-library 'lambda body))) + (fix-lambda-body (expand-syntax-object body)) (case-lambda-helper clauses)))) (_ (raise-syntax-error "unexpected form in case-lambda" form)))) @@ -728,7 +703,28 @@ (make-environment (alist->substitutions (list (cons 'syntax-rules builtin-syntax-rules) - (cons '_ (make-library-ref '(csc builtins) '_ #t)) + (cons '_ (make-toplevel-ref '_)) (cons 'quote builtin-quote) - (cons 'builtin-let-syntax builtin-let-syntax))) - '())))) + (cons 'case-lambda builtin-case-lambda) + (cons 'builtin-let-syntax builtin-let-syntax))))) + + + (define (expand-body environment body) + (loop for expr in body + for expanded-expr = (expand expr environment) + for res = expanded-expr then (make-sequence res expanded-expr) + finally (return res) + if (toplevel-define? expanded-expr) + do (set! environment (insert environment (toplevel-define-name expanded-expr) (toplevel-define-expression expanded-expr))))) + + + ; A Scheme program consists of one or more import declarations + ; followed by a sequence of expressions and definitions. + ; -- R7RS + (define (program->ir1 program) + (loop for expr in program + for body on program + do (match expr + ; Add this line to make yourself feel better. + ((! ('import ('csc 'builtins))) '()) + (_ (return (expand-body builtins-environment body)))))))) |