diff options
Diffstat (limited to 'lib/csc/macros.csc')
| -rw-r--r-- | lib/csc/macros.csc | 801 |
1 files changed, 801 insertions, 0 deletions
diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc new file mode 100644 index 0000000..4559991 --- /dev/null +++ b/lib/csc/macros.csc @@ -0,0 +1,801 @@ +(define-library (csc macros) + (export + builtins-environment + expand-body + macro-syntax-error? + macro-transformer?) + (import (scheme base) + (only (csc assert) assert) + (only (csc format) sprintf) + (only (csc gensym) + gensym + gensym=?) + (only (csc hash-map) + alist->map + hash-bytevector + insert + key-not-found-error? + lookup + make-comparer + make-map + map-for-each + merge) + (only (csc ir1) + define-syntax-name + define-syntax-transformer + define-syntax? + lexical-ref-gensym + lexical-ref? + library-define-expression + library-define-ref + library-define? + library-ref-name + library-ref? + make-call + make-call-builtin + make-constant + make-define-syntax + make-lambda + make-letrec + make-lexical-ref + make-library-define + make-library-ref + make-sequence + sequence-head + sequence-tail + sequence?) + (only (csc list) + revappend + unzip) + (only (csc loop) + loop + return) + (only (csc match) match) + (only (csc vec) + vec + vec-append + vec-length + vec-ref)) + (begin + + + (define-record-type <macro-transformer> + (make-macro-transformer transformer) + macro-transformer? + (transformer transformer-function)) + + + (define-record-type <macro-syntax-error> + (make-macro-syntax-error message irritants) + macro-syntax-error? + (message syntax-error-object-message) + (irritants syntax-error-object-irritants)) + + + (define (raise-syntax-error message . irritants) + (raise (make-macro-syntax-error message irritants))) + + + ; symbols is a map with identifiers as keys, and the values can be one of: + ; - <lexical-ref>, + ; - <library-ref>, + ; - or <macro-transformer>. + ; The first two correspond to variables bound lexically or from a library, + ; and the third represents a macro transformer bound in the + ; current context. + (define-record-type <environment> + (make-environment symbols library) + environment? + (symbols environment-substitutions) + (library environment-library)) + + + (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 (syntax->expression s) + (if (syntax-object? s) + (syntax-object-expression s) + s)) + + + (define (marks s) + (if (syntax-object? s) + (syntax-object-marks s) + '())) + + + (define (add-binding identifier binding environment) + (make-environment + (insert (environment-substitutions environment) identifier binding) + (environment-library environment))) + + + (define (with-binding identifier binding syntax) + (make-syntax-object + (syntax->expression syntax) + (add-binding identifier binding (syntax-object-environment syntax)) + (marks syntax))) + + + (define (identifier? s) + (or (symbol? s) + (and (syntax-object? s) + (symbol? (syntax-object-expression 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) + (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) + (symbol=? (identifier-name s1) (identifier-name s2))) + (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 + (let () result result* ...) + (raise (make-syntax-case-no-match))))) + ((syntax-case-match-pattern x _ result result* ...) + (let () result result* ...)) + ((syntax-case-match-pattern x '() result result* ...) + (if (null? (syntax->expression x)) + (let () result result* ...) + (raise (make-syntax-case-no-match)))) + ((syntax-case-match-pattern x (pattern) 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) '() 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* ...)) + (raise (make-syntax-case-no-match))))) + ((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) (error "no match in syntax case"))) + (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 ((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))) + + + (define (resolve-identifier ident) + (let* ((environment (syntax-object-environment ident)) + (substitutions (environment-substitutions environment))) + (or + ; Check whether the variable is lexically bound to a marked identifier. + (guard (e ((key-not-found-error? e) #f)) + (lookup substitutions ident)) + ; Check whether the variable is bound to an unmarked identifier. + (guard (e ((key-not-found-error? e) #f)) + (lookup substitutions (identifier-name ident))) + ; Otherwise insert a library-ref + (make-library-ref (identifier-name ident) (environment-library environment))))) + + + (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 (resolve-identifier macro-name))) + (if (macro-transformer? macro-body) + ((transformer-function macro-body) syntax) + (expand-procedure-call macro-name tail)))) + ((procedure . arguments) + (expand-procedure-call procedure arguments)) + (_ when (identifier? syntax) + (let ((binding (resolve-identifier syntax))) + (if (macro-transformer? binding) + (raise-syntax-error "macro is not allowed in this context" syntax) + binding))) + (_ when (let ((expr (syntax->expression syntax))) + (or (boolean? expr) + (char? expr) + (number? expr) + (string? expr) + (vector? expr))) + (make-constant (syntax->expression syntax))) + (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax))))) + + + (define (expand expression environment) + (expand-syntax-object (wrap-syntax expression environment))) + + + (define (clean-syntax s) + (cond + ((pair? s) (cons (clean-syntax (car s)) (clean-syntax (cdr s)))) + ((syntax-object? s) (clean-syntax (syntax->expression s))) + (else s))) + + + (define builtin-quote + (make-macro-transformer + (lambda (syntax) + (syntax-case syntax + ((_ datum) (make-constant (clean-syntax datum))) + (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax))))))) + + + (define (matches-literals literals object) + (unless (list? (syntax->expression literals)) + (raise-syntax-error "invalid form in literals, expecting list" literals)) + (if (not (identifier? object)) + #f + (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 (identifier-uuid i) + (sprintf "{}" (list (identifier-name i) (marks i)))) + + + (define (hash-identifier i) + (hash-bytevector (string->utf8 (identifier-uuid i)))) + + + (define (marks<? m1 m2) + (loop for m1* in m1 + for m2* in m2 + if (< m1* m2*) + return #t + else if (> m1* m2*) + return #f + finally (return (< (length m1) (length m2))))) + + + (define compare-identifiers + (make-comparer + hash-identifier + (lambda (i1 i2) + (cond + ((bound-identifier=? i1 i2) 0) + ((or (string<? (symbol->string (identifier-name i1)) (symbol->string (identifier-name i2))) + (marks<? (marks i1) (marks i2))) + -1) + (else 1))))) + + + (define (alist->substitutions l) + (alist->map compare-identifiers l)) + + + (define (is-underscore expression) + (and + (identifier? expression) + (free-identifier=? + expression + (wrap-syntax + '_ + (make-environment + (alist->substitutions + (list (cons '_ (make-library-ref '_ '(scheme base))))) + '(scheme base)))))) + + + (define (syntax-improper-list-length l) + (let loop ((l l) + (n 0)) + (syntax-case l + ('() n) + ((_ . rest) (loop rest (+ 1 n))) + (_ (+ 1 n))))) + + + ; objects is an n-dimensional vec, where n is nesting-level. + (define-record-type <ellipsis-binding> + (make-ellipsis-binding objects nesting-level) + ellipsis-binding? + (objects ellipsis-binding-objects) + (nesting-level ellipsis-binding-nesting-level)) + + + (define (merge-bindings x y) + (assert (= (ellipsis-binding-nesting-level x) (ellipsis-binding-nesting-level y))) + (make-ellipsis-binding + (vec-append (ellipsis-binding-objects x) (ellipsis-binding-objects y)) + (ellipsis-binding-nesting-level x))) + + + (define (ellipsis-substitutions-merge s1 s2) + (map-for-each + (lambda (k v) + (let-values (((s1-binding ok) + (guard (e ((key-not-found-error? e) (values #f #f))) + (values (lookup s1 k) #t)))) + (if ok + (set! s1 (insert s1 k (merge-bindings s1-binding v))) + (set! s1 (insert s1 k v))))) + s2) + s1) + + + (define (map-ellipsis-binding substitutions) + (let ((res (alist->substitutions '()))) + (map-for-each + (lambda (k v) + (if (ellipsis-binding? v) + (set! res + (insert + res + k + (make-ellipsis-binding + (vec (ellipsis-binding-objects v)) + (+ 1 (ellipsis-binding-nesting-level v))))) + (set! res + (insert + res + k + (make-ellipsis-binding + (vec v) + 1))))) + substitutions) + res)) + + + (define (pattern-bindings ellipsis literals pattern object) + (syntax-case pattern + (lit when (matches-literals literals lit) + (if (and (identifier? object) (free-identifier=? object lit)) + (alist->substitutions '()) + #f)) + ((p ellip . p*) when (and (identifier? ellip) (not (matches-literals literals ellip)) (free-identifier=? ellipsis ellip)) + (let* ((n (syntax-improper-list-length object)) + (m (syntax-improper-list-length p*)) + (n-m (- n m))) + (if (>= n m) + (let loop ((i 0) + (object object) + (bindings (alist->substitutions '()))) + (if (< i n-m) + (let ((binding (pattern-bindings ellipsis literals p (syntax-map car object)))) + (and binding + (loop + (+ 1 i) + (syntax-map cdr object) + (ellipsis-substitutions-merge bindings (map-ellipsis-binding binding))))) + (let ((bindings* (pattern-bindings ellipsis literals p* object))) + (and bindings* (merge bindings bindings*))))) + #f))) + (underscore when (is-underscore underscore) + (alist->substitutions '())) + (ident when (identifier? ident) + ; Each time the expander encounters a macro use, it applies an + ; antimark to the input form. + ; + ; We would apply it earlier, but the antimark breaks + ; free-identifier=? to check for literals. -- rose + (alist->substitutions (list (cons ident (anti-mark object))))) + ('() + (syntax-case object + ('() (alist->substitutions '())) + (_ #f))) + ((p . p*) + (syntax-case object + ((e . e*) + (define pbindings (pattern-bindings ellipsis literals p e)) + (define p*bindings (pattern-bindings ellipsis literals p* e*)) + (and pbindings p*bindings (merge pbindings p*bindings))) + (_ #f))) + (constant + (if (equal? (syntax->expression constant) (syntax->expression object)) + (alist->substitutions '()) + #f)))) + + + (define-record-type <ellipsis-out-of-bounds> + (make-ellipsis-out-of-bounds) + ellipsis-out-of-bounds?) + + + (define (ellipsis-ref v i) + (if (< i (vec-length v)) + (vec-ref v i) + (raise (make-ellipsis-out-of-bounds)))) + + + ; Can raise key-not-found-error? or ellipsis-out-of-bounds?. + (define (ellipsis-lookup substitutions ellipsis-nesting key) + (let ((n-d-vector (lookup substitutions key))) + (if (ellipsis-binding? n-d-vector) + (if (= (ellipsis-binding-nesting-level n-d-vector) (vec-length ellipsis-nesting)) + (let loop ((i 0) + (value (ellipsis-binding-objects n-d-vector))) + (if (< i (vec-length ellipsis-nesting)) + (loop + (+ 1 i) + (ellipsis-ref value (vec-ref ellipsis-nesting i))) + value)) + (raise-syntax-error "reference to pattern variable at incorrect ellipsis nesting level" (clean-syntax key) (vec-length ellipsis-nesting))) + n-d-vector))) + + + (define (syntax-append s1 s2) + (syntax-case s1 + ('() (with-wrap s2 s1)) + ((head . tail) + (with-wrap + (cons head + (syntax-append tail s2)) + s1)))) + + + (define (expand-template ellipsis ellipsis-nesting substitutions template) + (syntax-case template + ('() (with-wrap '() template)) + ((head ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis)) + (let-values (((extra-ellipses tail) + (let loop ((tail tail) + (extra-ellipses '())) + (syntax-case tail + ((ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis)) + (loop tail (cons ellip extra-ellipses))) + (_ (values extra-ellipses tail)))))) + (let loop ((i 0) + (expansion (with-wrap '() template))) + (guard (e ((ellipsis-out-of-bounds? e) + (if (= 0 i) + ; Failure was at a higher level. + (raise e) + (syntax-append expansion (expand-template ellipsis ellipsis-nesting substitutions tail))))) + (loop + (+ 1 i) + (syntax-append + expansion + (expand-template + ellipsis + (vec-append ellipsis-nesting i) + substitutions + (with-wrap + (cons + head + extra-ellipses) + template)))))))) + ((head . tail) + (with-wrap + (cons (expand-template ellipsis ellipsis-nesting substitutions head) + (expand-template ellipsis ellipsis-nesting substitutions tail)) + template)) + (ident when (identifier? ident) + (guard (e ((key-not-found-error? e) template)) + (ellipsis-lookup substitutions ellipsis-nesting template))) + (_ template))) + + + (define (syntax-match ellipsis 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 all-rules)) + ((((_ . pattern) template) . tail) + (define bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object))) + (if bindings + ; We call expand-syntax-object immediately, since macros are + ; allowed to be recursive. + (expand-syntax-object + ; 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. + (add-mark (new-mark) (expand-template ellipsis (vec) bindings template))) + (loop tail))) + (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules))))) + + + (define default-ellipsis + (wrap-syntax + '... + (make-environment + (alist->substitutions + (list (cons '... + (make-library-ref '... '(scheme base))))) + '(scheme base)))) + + + (define builtin-syntax-rules + (make-macro-transformer + (lambda (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 + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ (ident transformer-form) body-form) when (identifier? ident) + (let* ((transformer (expand-syntax-object transformer-form)) + (body (expand-syntax-object (with-binding ident transformer body-form)))) + body)) + (_ (raise-syntax-error "unexpected form in let-syntax")))))) + + + (define (split-args-rest formals) + (syntax-case formals + ('() + (values '() #f)) + ((var . vars) when (identifier? var) + (let-values (((args rest) (split-args-rest vars))) + (values (cons (identifier-name var) args) rest))) + (var when (identifier? var) + (values '() (identifier-name var))) + (_ (raise-syntax-error "unexpected form in split-args-rest" formals)))) + + + (define (expand-lambda-body-rest body) + (let loop ((body body) + (expanded-body (make-constant #f))) + (syntax-case body + ('() + expanded-body) + ((expr . expr*) + (define expanded-expr (expand-syntax-object expr)) + (when (or (library-define? expanded-expr) + (define-syntax? expanded-expr)) + (raise-syntax-error "define not allowed here" body)) + (loop (syntax-map cdr body) + (make-sequence expanded-body expanded-expr)))))) + + + (define (expand-lambda-body body) + (let loop ((body body) + (names '()) + (gensyms '()) + (expressions '())) + (syntax-case body + ('() + (if (null? names) + (make-constant #f) + (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (make-constant #f)))) + ((expr . expr*) + (define expanded-expr (expand-syntax-object expr)) + (cond + ((library-define? expanded-expr) + (let ((name (library-ref-name (library-define-ref expanded-expr))) + (g (gensym))) + (loop (with-binding name (make-lexical-ref name g) (syntax-map cdr body)) + (cons name names) + (cons g gensyms) + (cons (library-define-expression expanded-expr) expressions)))) + ((define-syntax? expanded-expr) + (loop (with-binding (define-syntax-name expanded-expr) (define-syntax-transformer expanded-expr) (syntax-map cdr body)) + names + gensyms + expressions)) + (else + (if (null? names) + (expand-lambda-body-rest body) + (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body))))))))) + + + (define builtin-lambda + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ formals . body) + (let-values (((args rest) (split-args-rest formals))) + (make-lambda + (map (lambda (name) + (make-lexical-ref name (gensym))) + args) + (if rest + (make-lexical-ref rest (gensym)) + #f) + (expand-lambda-body body)))) + (_ (raise-syntax-error "unexpected form in lambda" x)))))) + + + (define builtin-define + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ symbol expression) + (make-library-define + (make-library-ref + (identifier-name symbol) + (environment-library (syntax-object-environment x))) + (expand-syntax-object expression))) + (_ (raise-syntax-error "unexpected form in builtin-define" x)))))) + + + (define builtin-define-syntax + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ ident transformer-form) when (identifier? ident) + (make-define-syntax (identifier-name ident) + (expand-syntax-object transformer-form))) + (_ (raise-syntax-error "unexpected form in builtin-define-syntax" x)))))) + + + (define builtin-call-builtin + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ op . args) when (identifier? op) + (make-call-builtin (identifier-name op) + (let loop ((args args) + (expanded-args '())) + (syntax-case args + ('() (reverse expanded-args)) + ((head . tail) + (loop tail + (cons (expand-syntax-object head) + expanded-args))) + (_ (raise-syntax-error "unexpected form in call-builtin")))))) + (_ (raise-syntax-error "unexpected form in call-builtin" x)))))) + + + (define builtins-environment + (alist->substitutions + (list (cons 'syntax-rules builtin-syntax-rules) + (cons '_ (make-library-ref '_ '(scheme base))) + (cons '... (make-library-ref '... '(scheme base))) + (cons 'let-syntax builtin-let-syntax) + (cons 'quote builtin-quote) + (cons 'lambda builtin-lambda) + (cons 'builtin-define builtin-define) + (cons 'define-syntax builtin-define-syntax) + (cons 'call-builtin builtin-call-builtin)))) + + + ; Expands the body of a library, or top level. expand-body 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. + (define (expand-body name body env) + (define ident-map (make-map compare-identifiers)) + (map-for-each (lambda (k v) + (set! ident-map (insert ident-map k v))) + env) + (define environment (make-environment ident-map name)) + (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 (define-syntax? expanded-expr) + do (set! environment + (add-binding + (define-syntax-name expanded-expr) + (define-syntax-transformer expanded-expr) + environment)))))) |