diff options
Diffstat (limited to 'Macro.scm')
| -rw-r--r-- | Macro.scm | 155 |
1 files changed, 93 insertions, 62 deletions
@@ -1,4 +1,4 @@ -;; Copyright (C) 1997, 1998 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1998, 1999 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -12,7 +12,7 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. ;; ;; As a special exception, the Free Software Foundation gives permission ;; for additional uses of the text contained in its release of GUILE. @@ -41,20 +41,20 @@ ;;;; "Macro.scm", Support for syntax-rules macros. ;;; Author: Radey Shouman ;; -;; As in SYNTAX-CASE, the identifier ... may be quoted in a +;; 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 +;; 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 + ;; 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)) @@ -63,8 +63,9 @@ (and (the-macro and)) (or (the-macro or))) (let ((var-rtd (make-record-type '? '(name rank))) - (e-pat-rtd (make-record-type '... '(pattern vars)))) - + (e-pat-rtd (make-record-type '... '(pattern vars))) + (rule-rtd (make-record-type 'rule '(pattern inserted template)))) + (define pattern-variable (record-constructor var-rtd '(name rank))) (define pattern-variable? (record-predicate var-rtd)) (define pattern-variable->name @@ -82,10 +83,15 @@ (define ellipsis-pattern->pattern (record-accessor e-pat-rtd 'pattern)) (define ellipsis-pattern->vars (record-accessor e-pat-rtd 'vars)) + (define rule (record-constructor rule-rtd '(pattern inserted template))) + (define rule->pattern (record-accessor rule-rtd 'pattern)) + (define rule->inserted (record-accessor rule-rtd 'inserted)) + (define rule->template (record-accessor rule-rtd 'template)) + (define (append2 x y) (if (null? y) x (append x y))) - + (define ellipsis? (let (($... (renamed-identifier '... #f))) (lambda (x env) @@ -101,25 +107,26 @@ (car vars) (duplicates? (cdr vars))))) - (define (compile-pattern literals rule env-def) - (let recur ((pat (cdar rule)) + (define (compile-pattern literals rule-exp env-def) + (let recur ((pat (cdar rule-exp)) (vars '()) (rank 0) (k (lambda (compiled vars) (let ((dup (duplicates? (map car vars)))) (if dup - (error + (error "syntax-rules: duplicate pattern variable:" - dup " in rule " rule))) - (cons compiled - (rewrite-template - (cadr rule) vars env-def))))) + dup " in rule " rule-exp))) + (apply rule + compiled + (rewrite-template + (cadr rule-exp) vars env-def))))) (cond ((null? pat) (k pat vars)) ((identifier? pat) (let ((lit (memq pat literals))) (if lit - (k pat vars) + (k (renamed-identifier pat env-def) vars) (let ((var (pattern-variable pat rank))) (k var (cons (cons pat var) vars)))))) ((pair? pat) @@ -146,7 +153,7 @@ (k (list->vector comp) vars)))) (else (k pat vars))))) - + (define (rewrite-template template vars env-def) (let recur ((tmpl template) (rank 0) @@ -173,7 +180,7 @@ (or (null? (cddr tmpl)) (error "bad ellipsis:" tmpl))) ;; (... ...) escape - (k (car tmpl) (list (car tmpl)) '()) + (k (car tmpl) (list (car tmpl)) '()) (recur (car tmpl) (+ rank 1) '() (lambda (comp1 ins1 op1) (if (null? op1) @@ -203,14 +210,14 @@ ;;; Match EXP to RULE, returning alist of variable bindings or #f. - (define (match literals rule exp env-def env-use) - (let recur ((r rule) + (define (match rule exp env-use) + (let recur ((r (rule->pattern rule)) (x (cdr exp))) (cond ((null? r) (and (null? x) '())) ((pair? r) (if (ellipsis-pattern? (car r)) - (and + (and (list? x) (let ((pat (ellipsis-pattern->pattern (car r)))) (let match1 ((x x) @@ -233,9 +240,7 @@ (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) - '())) + (and (identifier? x) (identifier-equal? r x env-use) '())) ((pattern-variable? r) (list (cons r x))) ((vector? r) @@ -244,30 +249,35 @@ (else (and (equal? r x) '()))))) - (define (substitute-in-template inserted template vars env-def) + (define (substitute-in-template rule vars env-def) (let ((ins (map (lambda (id) (cons id (renamed-identifier id env-def))) - inserted))) - (let recur ((tmpl template) + (rule->inserted rule)))) + (let recur ((tmpl (rule->template rule)) (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)))) + (let* ((enames (ellipsis-pattern->vars (car tmpl))) + (etmpl (ellipsis-pattern->pattern (car tmpl))) + (evals (map (lambda (nam) + (cdr (assq nam vars))) + enames)) + (n (length (car evals)))) + (let check ((es (cdr evals))) + (if (pair? es) + (if (= n (length (car es))) + (check (cdr es)) + (error "syntax-rules: pattern variable length mismatch:")))) + (append! + (map (lambda (eval) + (recur etmpl + (append! + (map cons enames eval) + vars))) + (apply map list evals)) + (recur (cdr tmpl) vars))) (cons (recur (car tmpl) vars) (recur (cdr tmpl) vars)))) ((identifier? tmpl) @@ -291,33 +301,22 @@ (or (identifier? x) (error "Bad literals list:" x-def))) literals) + (let ((rules (map (lambda (rule-expr) + (or (and (list? rule-expr) + (= 2 (length rule-expr)) + (pair? (car rule-expr))) + (error "Bad rule:" rule-expr)) + (compile-pattern literals rule-expr env-def)) + (cddr x-def)))) - ;;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) + ((match (car rules) x-use env-use) => (lambda (vars) - (let ((r (car rules))) - (substitute-in-template (cadr r) - (caddr r) - vars - env-def)))) + (substitute-in-template (car rules) vars env-def))) (else (loop (cdr rules)))))))))))) @@ -327,6 +326,38 @@ (procedure->memoizing-macro (macro:compile-syntax-rules expr env-def))))) +;; Explicit renaming macro facility, as in +;; W. Clinger, "Hygienic Macros Through Explicit Renaming" +(define (macro:renaming-transformer-procedure proc env-def) + (procedure->memoizing-macro + (lambda (expr env-use) + (proc (@copy-tree expr) + (let ((al '())) + (lambda (id) + (cond ((not (identifier? id)) + (error id "non-identifier passed to rename procedure" + expr)) + ((assq id al) => cdr) + (else + (let ((r-id (renamed-identifier id env-def))) + (set! al (cons id r-id)) + r-id))))) + (lambda (id1 id2) + (or (and (identifier? id1) + (identifier? id2) + (error (if (identifier? id1) id2 id1) + "non-identifier passed to compare procedure" + expr))) + (identifier-equal? id1 id2 env-use)))))) + +(define renaming-transformer + (let ((?transformer + (renamed-identifier 'macro:renaming-transformer-procedure #f)) + (?syntax-quote (renamed-identifier 'syntax-quote #f))) + (procedure->memoizing-macro + (lambda (exp env-def) + `(,?transformer ,(cadr exp) (,?syntax-quote ,env-def)))))) + (define define-syntax (syntax-rules () ((define-syntax ?name ?val) |