aboutsummaryrefslogtreecommitdiffstats
path: root/Macro.scm
diff options
context:
space:
mode:
Diffstat (limited to 'Macro.scm')
-rw-r--r--Macro.scm292
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)