From 3278b75942bdbe706f7a0fba87729bb1e935b68b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 5d2 --- Macro.scm | 155 +++++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 93 insertions(+), 62 deletions(-) (limited to 'Macro.scm') 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: (