diff options
Diffstat (limited to 'csc/macros.csc')
| -rw-r--r-- | csc/macros.csc | 452 |
1 files changed, 348 insertions, 104 deletions
diff --git a/csc/macros.csc b/csc/macros.csc index a41a4a7..d8903eb 100644 --- a/csc/macros.csc +++ b/csc/macros.csc @@ -3,20 +3,31 @@ expand test-environment) (import (scheme base) - (only (csc gensym) gensym) + (only (csc format) sprintf) + (only (csc gensym) + gensym + gensym=?) (only (csc hash-map) alist->map hash-bytevector insert key-not-found-error? - lookup) + lookup + merge) (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-lambda-case + make-library-ref) (only (csc list) revappend) - (only (csc match) match)) + (only (csc match) match) + (only (csc strings) join)) (begin @@ -37,9 +48,9 @@ (raise (make-macro-syntax-error message irritants))) - ; symbols is a map with symbols as keys, and the values can be one of: + ; symbols is a map with identifiers as keys, and the values can be one of: ; - <lexical-ref>, - ; - <module-ref>, + ; - <library-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 @@ -50,135 +61,368 @@ (define-record-type <environment> (make-environment symbols library) environment? - (symbols environment-symbols) + (symbols environment-substitutions) (library environment-library)) - (define (with-binding environment symbol binding) - (make-environment (insert (environment-symbols environment) symbol binding) (environment-library environment))) + (define (with-binding environment identifier binding) + (make-environment (insert (environment-substitutions environment) identifier binding) (environment-library environment))) - (define (expand-procedure-call procedure arguments environment) - (let*-values (((expanded-procedure environment) (expand procedure environment)) - ((expanded-arguments environment) + (define-record-type <syntax-object> + (make-syntax-object expression environment marks) + syntax-object? + (expression syntax-object-expression) + (environment syntax-object-environment) + (marks syntax-object-marks)) + + + (define (wrap-syntax expression environment) + (if (syntax-object? expression) + expression + (make-syntax-object expression environment '()))) + + + (define (identifier? s) + (or (symbol? s) + (and (syntax-object? s) + (symbol? (syntax-object-expression s))))) + + + (define (marks s) + (if (syntax-object? s) + (syntax-object-marks s) + '())) + + + (define (marks=? m1 m2) + (and + (= (length m1) (length m2)) + (let loop ((m1 m1) + (m2 m2)) + (if (null? m1) + #t + (and (= (car m1) (car m2)) (loop (cdr m1) (cdr m2))))))) + + + (define (identifier-name s) + (if (syntax-object? s) + (syntax-object-expression s) + s)) + + + (define (bound-identifier=? s1 s2) + (and (symbol=? (identifier-name s1) (identifier-name s2)) + (marks=? (marks s1) (marks s2)))) + + + (define (binding=? b1 b2) + (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 (macro-transformer? b1) + (macro-transformer? b2) + (eq? (transformer-function b1) (transformer-function b2))))) + + + ; free-identifier=? only works on wrapped syntax objects. + (define (free-identifier=? s1 s2) + (let ((s1-binding (guard (e ((key-not-found-error? e) #f)) + (lookup (environment-substitutions (syntax-object-environment s1)) s1))) + (s2-binding (guard (e ((key-not-found-error? e) #f)) + (lookup (environment-substitutions (syntax-object-environment s2)) s2)))) + (or (and (not s1-binding) (not s2-binding)) + (binding=? s1-binding s2-binding)))) + + + (define *next-mark* 0) + + + (define (new-mark) + (let ((m *next-mark*)) + (set! *next-mark* (+ 1 *next-mark*)) + m)) + + + (define (add-mark mark expression) + (make-syntax-object + (syntax-object-expression expression) + (syntax-object-environment expression) + (if (and (pair? (syntax-object-marks expression)) + (not (car (syntax-object-marks expression)))) ; Anti-mark. + (cdr (syntax-object-marks expression)) + (cons mark (syntax-object-marks expression))))) + + + (define (add-marks marks expression) + (let loop ((marks marks) + (expression expression)) + (match marks + ('() expression) + ((mark . marks) + (loop marks (add-mark mark expression)))))) + + + (define (anti-mark expression) + (add-mark #f expression)) + + + (define (decorate marks expression environment) + (add-marks marks (wrap-syntax expression environment))) + + + (define (with-wrap expression parent) + (decorate (marks parent) expression (syntax-object-environment parent))) + + + (define (syntax-map f expr) + (with-wrap (f (syntax->expression expr)) expr)) + + + (define-record-type <syntax-case-no-match> + (make-syntax-case-no-match) + syntax-case-no-match?) + + + (define-syntax syntax-case-match-pattern + (syntax-rules (_ when) + ((syntax-case-match-pattern x pattern (when condition) result result* ...) + (syntax-case-match-pattern x pattern + (if condition + (begin result result* ...) + (raise (make-syntax-case-no-match))))) + ((syntax-case-match-pattern x _ result result* ...) + (begin result result* ...)) + ((syntax-case-match-pattern x '() result result* ...) + (if (null? (syntax->expression x)) + (begin result result* ...) + (raise (make-syntax-case-no-match)))) + ((syntax-case-match-pattern x (pattern) result result* ...) + (if (= 1 (length (syntax->expression x))) + (syntax-case-match-pattern (syntax-map car x) pattern result result* ...) + (raise (make-syntax-case-no-match)))) + ((syntax-case-match-pattern x (pattern . rest) result result* ...) + (let ((y x)) + (if (pair? (syntax->expression y)) + (syntax-case-match-pattern (syntax-map car y) pattern + (syntax-case-match-pattern (syntax-map cdr y) rest result result* ...))))) + ((syntax-case-match-pattern x ident result result* ...) + (let ((ident x)) result result* ...)))) + + + ; Yes, I just defined syntax-case in terms of syntax-rules. + ; Are we sure this won't create a black hole? + (define-syntax syntax-case + (syntax-rules () + ((syntax-case x (arm ...)) + (guard (e ((syntax-case-no-match? e) (if #f #f))) + (syntax-case-match-pattern x arm ...))) + ((syntax-case x (arm ...) clause clause* ...) + (let ((y x)) + (guard (e ((syntax-case-no-match? e) + (syntax-case y clause clause* ...))) + (syntax-case-match-pattern y arm ...)))))) + + + (define (expand-procedure-call procedure arguments) + (let-values (((expanded-procedure environment) (expand-syntax-object procedure)) + ((expanded-arguments) (let loop ((arguments arguments) - (environment environment) (expanded-arguments '())) - (match arguments - ('() (values (reverse expanded-arguments) environment)) + (syntax-case arguments + ('() (reverse expanded-arguments)) ((argument . rest) - (let-values (((expanded-argument environment) (expand argument environment))) - (loop - rest - environment - (cons expanded-argument expanded-arguments)))) + (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)))))) (make-call expanded-procedure expanded-arguments))) + ; From R6RS: + ; Each time the expander encounters a macro use, it applies an antimark to + ; the input form, invokes the associated transformer, then applies a fresh + ; mark to the output. + ; + ; In cute scheme, macros compile themselves, and syntax-rules is therefore + ; responsible for applying a mark to an expanded expression before + ; expanding it with expand-syntax-object. + (define (expand-macro-use transformer syntax) + ((transformer-function transformer) (anti-mark syntax))) + + + (define (expand-syntax-object syntax) + (syntax-case syntax + ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" syntax)) + ((macro-name . tail) (when (identifier? macro-name)) + (let ((macro-body + (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name))) + (lookup (environment-substitutions (syntax-object-environment macro-name)) macro-name)))) + (if (macro-transformer? macro-body) + (expand-macro-use macro-body syntax) + (values (expand-procedure-call macro-name tail) (syntax-object-environment syntax))))) + ((procedure . arguments) + (values (expand-procedure-call procedure arguments) (syntax-object-environment syntax))) + (_ (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))))) + (_ (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))) + (_ (raise-syntax-error "unexpected expression type" syntax)))) + + ; expand can be thought of as a compiler from Scheme to IR1. Macros ; included in the environment can be used to extend the syntax. Returns an ; IR1 expression and an environment which has been modified with any new ; bindings introduced by the expression. (define (expand expression environment) - (cond - ((null? expression) (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" expression)) - ((and (pair? expression) - (symbol? (car expression))) - (let* ((macro-name (car expression)) - (macro-body - (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name))) - (lookup (environment-symbols environment) macro-name)))) - (if (macro-transformer? macro-body) - ((transformer-function macro-body) expression environment) - (expand-procedure-call macro-name (cdr expression) environment)))) - ((pair? expression) - (let ((procedure (car expression)) - (arguments (cdr expression))) - (expand-procedure-call procedure arguments environment))) - ((symbol? expression) - (let ((binding - (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" expression))) - (lookup (environment-symbols environment) expression)))) - (if (macro-transformer? binding) - (raise-syntax-error "macro is not allowed in this context" expression) - (values binding environment)))) - ((or (boolean? expression) - (bytevector? expression) - (char? expression) - (number? expression) - (string? expression) - (vector? expression)) - (values (make-constant expression) environment)) - (else (raise-syntax-error "unexpected expression type" expression)))) + (expand-syntax-object (wrap-syntax expression environment))) (define builtin-quote (make-macro-transformer - (lambda (expression environment) - (match expression - ((_ datum) (values (make-constant datum) environment)) - (_ (raise-syntax-error "invalid form for quote" expression)))))) + (lambda (syntax) + (syntax-case syntax + ((_ datum) (values (make-constant (syntax->expression datum)) (syntax-object-environment syntax))) + (_ (raise-syntax-error "invalid form for quote" syntax)))))) - (define builtin-lambda - (make-macro-transformer - (lambda (expression environment) - (match expression - ((_ formals body) - (let loop ((formals formals) - (environment environment) - (argument-names '()) - (gensyms '())) - (match formals - ('() - (make-lambda - (make-lambda-case - (reverse argument-names) - #f - (reverse gensyms) - (expand body environment) - #f))) - ((variable . variables) (when (symbol? variable)) - (let ((sym (gensym))) - (loop - variables - (with-binding environment variable sym) - (cons variable argument-names) - (cons sym gensyms)))) - (variable (when (symbol? variable)) - (let ((sym (gensym))) - (make-lambda - (make-lambda-case - (reverse argument-names) - variable - (revappend gensyms (list sym)) - (expand body (with-binding environment variable sym)) - #f)))) - (_ (raise-syntax-error "invalid form for lambda arguments" expression))))) - (_ (raise-syntax-error "invalid form for lambda" expression)))))) + (define (syntax->expression s) + (if (syntax-object? s) + (syntax-object-expression s) + s)) - #;(define builtin-syntax-rules - (make-macro-transformer - (lambda (expression environment) - (match expression)))) + (define (matches-literals literals object) + (unless (list? (syntax->expression literals)) + (raise-syntax-error "invalid form in literals, expecting list" literals)) + (let ((literal-identifiers + (map + (lambda (lit) (with-wrap lit literals)) + (syntax->expression literals)))) + (let loop ((literal-identifiers literal-identifiers)) + (match literal-identifiers + ('() #f) + ((lit . literals) + (or (free-identifier=? lit object) + (loop literals))))))) - (define (hash-symbol s) - (hash-bytevector (string->utf8 (symbol->string s)))) + (define (identifier-uuid i) + ; Join marks by ( because symbols aren't allowed to have ( in the name. + (sprintf "{}({}" (apply join "(" (map number->string (marks i))) (identifier-name i))) - (define (symbol<? s1 s2) - (string<? (symbol->string s1) (symbol->string s2))) + (define (hash-identifier i) + (hash-bytevector (string->utf8 (identifier-uuid i)))) + + + (define (cmp-identifier i1 i2) + (cond + ((string<? (identifier-uuid i1) (identifier-uuid i2)) -1) + ((string=? (identifier-uuid i1) (identifier-uuid i2)) 0) + (else 1))) + + + (define (alist->substitutions l) + (alist->map hash-identifier cmp-identifier l)) + + + (define (is-underscore expression) + (free-identifier=? + expression + (wrap-syntax '_ (make-environment (alist->substitutions (list (cons '_ (make-library-ref '(csc builtins) '_ #t)))) '())))) + + + (define (pattern-bindings pattern literals object) + (syntax-case pattern + (lit (when (and (free-identifier=? object lit) + (matches-literals literals object))) + (alist->substitutions '())) + (underscore (when (is-underscore underscore)) + (alist->substitutions '())) + (ident (when (identifier? ident)) + (alist->substitutions (list (cons ident object)))) + ('() + (syntax-case object + ('() (alist->substitutions '())) + (_ #f))) + ((p . p*) + (syntax-case object + ((e . e*) + (merge (pattern-bindings p literals e) + (pattern-bindings p* literals e*))) + (_ #f))) + (constant + (if (equal? constant (syntax->expression object)) + (alist->substitutions '()) + #f)))) + + + (define (expand-template substitutions template) + (syntax-case template + ('() (with-wrap '() template)) + ((head . tail) + (with-wrap + (cons (expand-template substitutions head) + (expand-template substitutions tail)) + template)) + (ident (when (identifier? ident)) + (guard (e ((key-not-found-error? e) template)) + (lookup substitutions template))) + (_ template))) + + + (define (syntax-match literals all-rules object) + (let loop ((rules all-rules)) + (syntax-case rules + ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object (map car all-rules))) + ((((_ . pattern) template) . tail) + (let ((bindings (pattern-bindings pattern literals (with-wrap (cdr (syntax->expression object)) object)))) + (if bindings + ; Each time the expander encounters a macro use, + ; it applies an antimark to the input form, + ; invokes the associated transformer, + ; then applies a fresh mark to the output. + ; + ; We also call expand-syntax-object immediately, + ; since macros are allowed to be recursive -- rose + (expand-syntax-object (add-mark (new-mark) (expand-template bindings template))) + (loop tail)))) + (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules))))) + + + (define builtin-syntax-rules + (make-macro-transformer + (lambda (syntax-rules-form) + (syntax-case syntax-rules-form + ((_ literals . rules) + (values + (make-macro-transformer + (lambda (input-form) + (syntax-match literals rules input-form))) + (syntax-object-environment syntax-rules-form))) + (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form)))))) (define test-environment (make-environment - (alist->map - hash-symbol - symbol<? - (list - (cons 'quote builtin-quote) - (cons 'lambda builtin-lambda))) + (alist->substitutions + (list (cons 'syntax-rules builtin-syntax-rules) + (cons 'quote builtin-quote) + (cons '_ (make-library-ref '(csc builtins) '_ #t)))) '())))) |