diff options
Diffstat (limited to 'Macro.scm')
| -rw-r--r-- | Macro.scm | 292 |
1 files changed, 292 insertions, 0 deletions
diff --git a/Macro.scm b/Macro.scm new file mode 100644 index 0000000..f053b9c --- /dev/null +++ b/Macro.scm @@ -0,0 +1,292 @@ +;; Support for R4RS macros. +;; +;; As in SYNTAX-CASE, the identifier ... may be quoted in a +;; SYNTAX-RULES pattern or template as (... ...). +;; +;; THE-MACRO may be used to define macros, eg +;; (define-syntax foo (the-macro and)) +;; defines the syntactic keyword FOO to have the same transformer +;; as the macro AND. + +(require 'rev2-procedures) ;append! +(require 'record) + +(define macro:compile-syntax-rules + ;; We keep local copies of these standard special forms, otherwise, + ;; redefining them before they are memoized below can lead to + ;; infinite recursion. + (@let-syntax ((lambda (the-macro lambda)) + (let (the-macro let)) + (cond (the-macro cond)) + (if (the-macro if)) + (and (the-macro and)) + (or (the-macro or))) + (let ((var-rtd (make-record-type '? '(name rank))) + (e-pat-rtd (make-record-type '... '(pattern vars)))) + + (define pattern-variable (record-constructor var-rtd '(name rank))) + (define pattern-variable? (record-predicate var-rtd)) + (define pattern-variable->name + (let ((acc (record-accessor var-rtd 'name))) + (lambda (x) (identifier->symbol (acc x))))) + (define pattern-variable->rank (record-accessor var-rtd 'rank)) + + ;; An ellipsis-pattern is used both for ellipses in patterns and + ;; ellipses in templates. In a pattern, VARS is the list of variables + ;; bound by the ellipsis pattern. In a template, VARS is the list of + ;; variables opened by the ellipsis template. + + (define ellipsis-pattern (record-constructor e-pat-rtd '(pattern vars))) + (define ellipsis-pattern? (record-predicate e-pat-rtd)) + (define ellipsis-pattern->pattern (record-accessor e-pat-rtd 'pattern)) + (define ellipsis-pattern->vars (record-accessor e-pat-rtd 'vars)) + + (define (append2 x y) + (if (null? y) x + (append x y))) + + (define ellipsis? + (let (($... (renamed-identifier '... #f))) + (lambda (x env) + (and + (identifier? x) + (identifier-equal? x $... env))))) + + ;; Yeah, it's quadratically slow. + (define (duplicates? vars) + (if (null? vars) + #f + (if (memq (car vars) (cdr vars)) + (car vars) + (duplicates? (cdr vars))))) + + (define (compile-pattern literals rule env-def) + (let recur ((pat (cdar rule)) + (vars '()) + (rank 0) + (k (lambda (compiled vars) + (let ((dup (duplicates? (map car vars)))) + (if dup + (error + "syntax-rules: duplicate pattern variable:" + dup " in rule " rule))) + (cons compiled + (rewrite-template + (cadr rule) vars env-def))))) + (cond ((null? pat) + (k pat vars)) + ((identifier? pat) + (let ((lit (memq pat literals))) + (if lit + (k pat vars) + (let ((var (pattern-variable pat rank))) + (k var (cons (cons pat var) vars)))))) + ((pair? pat) + (if (and (pair? (cdr pat)) + (ellipsis? (cadr pat) env-def) + (or (null? (cddr pat)) + (error "bad ellipsis:" pat))) + (if (ellipsis? (car pat) env-def) + (recur (car pat) vars rank k) + (recur (car pat) '() (+ rank 1) + (lambda (comp1 vars1) + (k (list + (ellipsis-pattern comp1 (map cdr vars1))) + (append2 vars1 vars))))) + (recur (car pat) '() rank + (lambda (comp1 vars1) + (recur (cdr pat) vars rank + (lambda (comp2 vars2) + (k (cons comp1 comp2) + (append2 vars1 vars2))))))))))) + + (define (rewrite-template template vars env-def) + (let recur ((tmpl template) + (rank 0) + (inserted '()) + (k (lambda (compiled inserted opened) + (list inserted compiled)))) + (cond ((null? tmpl) + (k tmpl '() '())) + ((identifier? tmpl) + (let ((v (assq tmpl vars))) + (if v + (cond ((= rank (pattern-variable->rank (cdr v))) + (k (cdr v) '() (list (cdr v)))) + ((> rank (pattern-variable->rank (cdr v))) + (k (cdr v) '() '())) + (else + (error "pattern variable rank mismatch:" tmpl + " in " template))) + (k tmpl (list tmpl) '())))) + ((pair? tmpl) + (if (and (pair? (cdr tmpl)) + (ellipsis? (cadr tmpl) env-def)) + (if (and (ellipsis? (car tmpl) env-def) + (or (null? (cddr tmpl)) + (error "bad ellipsis:" tmpl))) + ;; (... ...) escape + (k (car tmpl) (list (car tmpl)) '()) + (recur (car tmpl) (+ rank 1) '() + (lambda (comp1 ins1 op1) + (if (null? op1) + (error "Bad ellipsis:" + tmpl " in template " template)) + (recur (cddr tmpl) rank inserted + (lambda (comp2 ins2 op2) + (k (cons + (ellipsis-pattern comp1 op1) + comp2) + (append2 ins1 ins2) + (append2 op1 op2))))))) + (recur (car tmpl) rank '() + (lambda (comp1 ins1 op1) + (recur (cdr tmpl) rank inserted + (lambda (comp2 ins2 op2) + (k (cons comp1 comp2) + (append2 ins1 ins2) + (append2 op1 op2)))))))) + (else + (k tmpl '() '()))))) + + +;;; Match EXP to RULE, returning alist of variable bindings or #f. + + (define (match literals rule exp env-def env-use) + (let recur ((r rule) + (x (cdr exp))) + (cond ((null? r) + (and (null? x) '())) + ((pair? r) + (if (ellipsis-pattern? (car r)) + (and + (list? x) + (let ((pat (ellipsis-pattern->pattern (car r)))) + (let match1 ((x x) + (vals '())) + (if (null? x) + (if (null? vals) + (map list (ellipsis-pattern->vars (car r))) + (let ((vars (map car (car vals)))) + (apply map list vars + (map (lambda (al) + (map cdr al)) + (reverse vals))))) + (let ((val (recur pat (car x)))) + (and val + (match1 (cdr x) (cons val vals)))))))) + (and + (pair? x) + (let ((v1 (recur (car r) (car x)))) + (and v1 + (let ((v2 (recur (cdr r) (cdr x)))) + (and v2 (append2 v1 v2)))))))) + ((identifier? r) ;literal + (and (identifier? x) + (identifier-equal? (cdr (assq r literals)) x env-use) + '())) + ((pattern-variable? r) + (list (cons r x))) + (else + (and (equal? r x) '()))))) + + (define (substitute-in-template inserted template vars env-def) + (let ((ins (map (lambda (id) + (cons id (renamed-identifier id env-def))) + inserted))) + (let recur ((tmpl template) + (vars vars)) + (cond ((null? tmpl) + tmpl) + ((pair? tmpl) + (if (ellipsis-pattern? (car tmpl)) + (let ((enames (ellipsis-pattern->vars (car tmpl))) + (etmpl (ellipsis-pattern->pattern (car tmpl)))) + (let ((evals (apply map list + (map (lambda (nam) + (cdr (assq nam vars))) + enames)))) + (append! + (map (lambda (eval) + (recur etmpl + (append! + (map cons enames eval) + vars))) + evals) + (recur (cdr tmpl) vars)))) + (cons (recur (car tmpl) vars) + (recur (cdr tmpl) vars)))) + ((identifier? tmpl) + (let ((a (assq tmpl ins))) + (if a (cdr a) tmpl))) + ((pattern-variable? tmpl) + (@copy-tree (cdr (assq tmpl vars)))) + (else + tmpl))))) + + ;; MACRO:COMPILE-SYNTAX-RULES + (lambda (x-def env-def) + (or (and (list? x-def) + (< 2 (length x-def)) + (list? (cadr x-def))) + (error "Malformed syntax-rules:" x-def)) + (let ((literals (cadr x-def))) + (for-each (lambda (x) + (or (identifier? x) + (error "Bad literals list:" x-def))) + literals) + + ;;Rules have the form: (<pattern> <inserted-identifiers> <template>). + (let ((rules + (map + (lambda (rule) + (or (and (list? rule) + (= 2 (length rule))) + (error "Bad rule:" rule)) + (compile-pattern literals rule env-def)) + (cddr x-def))) + (re-lits + (map (lambda (sym) + (cons sym (renamed-identifier sym env-def))) + literals))) + + (lambda (x-use env-use) + (let loop ((rules rules)) + (cond ((null? rules) + (error "macro use does not match definition:" + x-use)) + ((match re-lits (caar rules) x-use env-def env-use) + => (lambda (vars) + (let ((r (car rules))) + (substitute-in-template (cadr r) + (caddr r) + vars + env-def)))) + (else + (loop (cdr rules)))))))))))) + +(define syntax-rules + (procedure->syntax + (lambda (expr env-def) + (procedure->memoizing-macro + (macro:compile-syntax-rules expr env-def))))) + +(define define-syntax + (syntax-rules () + ((define-syntax ?name ?val) + (define ?name (the-macro ?val))))) + +(define-syntax let-syntax + (syntax-rules () ((let-syntax ((?name ?val) ...) . ?body) + (@let-syntax + ((?name (the-macro ?val)) ...) . ?body)))) + +(define-syntax letrec-syntax + (syntax-rules () ((letrec-syntax ((?name ?val) ...) . ?body) + (@letrec-syntax + ((?name (the-macro ?val)) ...) . ?body)))) + +;; MACRO:EXPAND would require substantial work. +(define macro:load load) +(define macro:eval eval) +(provide 'macro) |