summaryrefslogtreecommitdiffstats
path: root/Macro.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit3278b75942bdbe706f7a0fba87729bb1e935b68b (patch)
treedcad4048dfc0b38367047426b2b14501bf5ff257 /Macro.scm
parentdb04688faa20f3576257c0fe41752ec435beab9a (diff)
downloadscm-3278b75942bdbe706f7a0fba87729bb1e935b68b.tar.gz
scm-3278b75942bdbe706f7a0fba87729bb1e935b68b.zip
Import Upstream version 5d2upstream/5d2
Diffstat (limited to 'Macro.scm')
-rw-r--r--Macro.scm155
1 files changed, 93 insertions, 62 deletions
diff --git a/Macro.scm b/Macro.scm
index 76fc495..0ddccc1 100644
--- a/Macro.scm
+++ b/Macro.scm
@@ -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)