From 6a2ab0c1b52034f762c9b7eb8485643caac196c9 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 12 Feb 2002 00:26:34 +0000 Subject: [PATCH] Eliminate non-hygienic macros. --- v7/src/compiler/back/asmmac.scm | 17 ++- v7/src/compiler/base/macros.scm | 12 +- v7/src/compiler/base/pmpars.scm | 150 +++++++++++------------ v7/src/compiler/machines/i386/assmd.scm | 10 +- v7/src/compiler/machines/i386/dassm1.scm | 10 +- 5 files changed, 102 insertions(+), 97 deletions(-) diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm index 9a5e068ca..7287b3b25 100644 --- a/v7/src/compiler/back/asmmac.scm +++ b/v7/src/compiler/back/asmmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: asmmac.scm,v 1.13 2002/02/08 03:54:10 cph Exp $ +$Id: asmmac.scm,v 1.14 2002/02/12 00:25:08 cph Exp $ Copyright (c) 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology @@ -27,11 +27,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-syntax define-instruction (sc-macro-transformer (lambda (form environment) - environment (if (syntax-match? '(SYMBOL * (DATUM + DATUM)) (cdr form)) `(ADD-INSTRUCTION! ',(cadr form) - ,(compile-database (cddr form) + ,(compile-database (cddr form) environment (lambda (pattern actions) pattern (if (not (pair? actions)) @@ -39,16 +38,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (parse-instruction (car actions) (cdr actions) #f)))) (ill-formed-syntax form))))) -(define (compile-database cases procedure) +(define (compile-database cases environment procedure) `(LIST ,@(map (lambda (rule) - (parse-rule (car rule) (cdr rule) - (lambda (pattern variables qualifier actions) + (call-with-values (lambda () (parse-rule (car rule) (cdr rule))) + (lambda (pattern variables qualifiers actions) `(CONS ',pattern ,(rule-result-expression variables - qualifier - (procedure pattern - actions)))))) + qualifiers + (procedure pattern actions) + environment))))) cases))) (define optimize-group-syntax diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index cb24f62c6..90f5b737c 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: macros.scm,v 4.26 2002/02/09 05:43:15 cph Exp $ +$Id: macros.scm,v 4.27 2002/02/12 00:25:26 cph Exp $ Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology @@ -312,16 +312,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let ((type (cadr form)) (pattern (caddr form)) (body (cdddr form))) - (parse-rule pattern body - (lambda (pattern variables qualifier actions) + (call-with-values (lambda () (parse-rule pattern body)) + (lambda (pattern variables qualifiers actions) `(,(case type ((STATEMENT) 'ADD-STATEMENT-RULE!) ((PREDICATE) 'ADD-STATEMENT-RULE!) ((REWRITING) 'ADD-REWRITING-RULE!) (else (close-syntax type environment))) ',pattern - ,(rule-result-expression variables qualifier - `(BEGIN ,@actions)))))) + ,(rule-result-expression variables + qualifiers + `(BEGIN ,@actions) + environment))))) (ill-formed-syntax form))))) (define-syntax lap diff --git a/v7/src/compiler/base/pmpars.scm b/v7/src/compiler/base/pmpars.scm index d19b51724..526351fa3 100644 --- a/v7/src/compiler/base/pmpars.scm +++ b/v7/src/compiler/base/pmpars.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: pmpars.scm,v 1.4 1999/01/02 06:06:43 cph Exp $ +$Id: pmpars.scm,v 1.5 2002/02/12 00:25:30 cph Exp $ Copyright (c) 1988, 1999 Massachusetts Institute of Technology @@ -38,36 +38,34 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; arguments, will return either false, indicating that the ;;; qualifications failed, or the result of the body. -(define (parse-rule pattern body receiver) - (extract-variables - pattern - (lambda (pattern variables) - (extract-qualifier - body - (lambda (qualifiers actions) - (let ((names (pattern-variables pattern))) - (receiver pattern +(define (parse-rule pattern body) + (call-with-values (lambda () (extract-variables pattern)) + (lambda (pattern variables) + (call-with-values (lambda () (extract-qualifiers body)) + (lambda (qualifiers actions) + (let ((names (pattern-variables pattern))) + (values pattern (reorder-variables variables names) qualifiers actions))))))) -(define (extract-variables pattern receiver) +(define (extract-variables pattern) (if (pair? pattern) (if (memq (car pattern) '(? ?@)) - (receiver (make-pattern-variable (cadr pattern)) - (list (cons (cadr pattern) - (if (null? (cddr pattern)) - '() - (list (cons (car pattern) - (cddr pattern))))))) - (extract-variables (car pattern) + (values (make-pattern-variable (cadr pattern)) + (list (cons (cadr pattern) + (if (null? (cddr pattern)) + '() + (list (cons (car pattern) + (cddr pattern))))))) + (call-with-values (lambda () (extract-variables (car pattern))) (lambda (car-pattern car-variables) - (extract-variables (cdr pattern) + (call-with-values (lambda () (extract-variables (cdr pattern))) (lambda (cdr-pattern cdr-variables) - (receiver (cons car-pattern cdr-pattern) - (merge-variables-lists car-variables - cdr-variables))))))) - (receiver pattern '()))) + (values (cons car-pattern cdr-pattern) + (merge-variables-lists car-variables + cdr-variables))))))) + (values pattern '()))) (define (merge-variables-lists x y) (cond ((null? x) y) @@ -81,62 +79,64 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (cons (car x) (merge-variables-lists (cdr x) y))))))) - -(define (extract-qualifier body receiver) + +(define (extract-qualifiers body) (if (and (pair? (car body)) (eq? (caar body) 'QUALIFIER)) - (receiver (cdar body) (cdr body)) - (receiver '() body))) + (values (cdar body) (cdr body)) + (values '() body))) (define (reorder-variables variables names) (map (lambda (name) (assq name variables)) names)) + +(define (rule-result-expression variables qualifiers body environment) + (reverse-syntactic-environments environment + (lambda (environment) + (call-with-values + (lambda () (process-transformations variables environment)) + (lambda (outer-vars inner-vars xforms xqualifiers) + (let ((r-lambda (close-syntax 'LAMBDA environment)) + (r-let (close-syntax 'LET environment)) + (r-and (close-syntax 'AND environment))) + `(,r-lambda ,outer-vars + (,r-let ,(map list inner-vars xforms) + (,r-and ,@xqualifiers + ,@qualifiers + (,r-lambda () ,body)))))))))) -(define (rule-result-expression variables qualifiers body) - (let ((body `(lambda () ,body))) - (process-transformations variables - (lambda (outer-vars inner-vars xforms xqualifiers) - (if (null? inner-vars) - `(lambda ,outer-vars - ,(if (null? qualifiers) - body - `(and ,@qualifiers ,body))) - `(lambda ,outer-vars - (let ,(map list inner-vars xforms) - (and ,@xqualifiers - ,@qualifiers - ,body)))))))) - -(define (process-transformations variables receiver) - (if (null? variables) - (receiver '() '() '() '()) - (process-transformations (cdr variables) - (lambda (outer inner xform qual) - (let ((name (caar variables)) - (variable (cdar variables))) - (cond ((null? variable) - (receiver (cons name outer) - inner - xform - qual)) - ((not (null? (cdr variable))) - (error "process-trasformations: Multiple qualifiers" - (car variables))) - (else - (let ((var (car variable))) - (define (handle-xform rename) - (if (eq? (car var) '?) - (receiver (cons rename outer) - (cons name inner) - (cons `(,(cadr var) ,rename) - xform) - (cons name qual)) - (receiver (cons rename outer) - (cons name inner) - (cons `(MAP ,(cadr var) ,rename) - xform) - (cons `(APPLY BOOLEAN/AND ,name) qual)))) - (handle-xform - (if (null? (cddr var)) - name - (caddr var))))))))))) \ No newline at end of file +(define (process-transformations variables environment) + (let ((r-map (close-syntax 'MAP environment)) + (r-apply (close-syntax 'APPLY environment)) + (r-boolean/and (close-syntax 'BOOLEAN/AND environment))) + (let loop ((variables variables)) + (if (pair? variables) + (call-with-values (lambda () (loop (cdr variables))) + (lambda (outer-vars inner-vars xforms qualifiers) + (let ((name (caar variables)) + (variable (cdar variables))) + (if (pair? variable) + (let ((var (car variable))) + (if (not (null? (cdr variable))) + (error "Multiple variable qualifiers:" + (car variables))) + (let ((xform (cadr var)) + (outer-var + (if (pair? (cddr var)) + (caddr var) + name))) + (if (eq? (car var) '?) + (values (cons outer-var outer-vars) + (cons name inner-vars) + (cons `(,xform ,outer-var) xforms) + (cons name qualifiers)) + (values (cons outer-var outer-vars) + (cons name inner-vars) + (cons `(,r-map ,xform ,outer-var) xforms) + (cons `(,r-apply ,r-boolean/and ,name) + qualifiers))))) + (values (cons name outer-vars) + inner-vars + xforms + qualifiers))))) + (values '() '() '() '()))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/i386/assmd.scm b/v7/src/compiler/machines/i386/assmd.scm index e974f1d43..2dbf7b7bd 100644 --- a/v7/src/compiler/machines/i386/assmd.scm +++ b/v7/src/compiler/machines/i386/assmd.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: assmd.scm,v 1.5 2001/12/23 17:20:57 cph Exp $ +$Id: assmd.scm,v 1.6 2002/02/12 00:26:30 cph Exp $ -Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1992, 1999, 2001, 2002 Massachusetts Institute of Technology 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 @@ -26,8 +26,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((ucode-type - (non-hygienic-macro-transformer - (lambda (name) `',(microcode-type name))))) + (sc-macro-transformer + (lambda (form environment) + environment + (apply microcode-type (cdr form)))))) (define-integrable maximum-padding-length ;; Instructions can be any number of bytes long. diff --git a/v7/src/compiler/machines/i386/dassm1.scm b/v7/src/compiler/machines/i386/dassm1.scm index ddc110f23..cc79d3bbd 100644 --- a/v7/src/compiler/machines/i386/dassm1.scm +++ b/v7/src/compiler/machines/i386/dassm1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dassm1.scm,v 1.12 2001/12/23 17:20:57 cph Exp $ +$Id: dassm1.scm,v 1.13 2002/02/12 00:26:34 cph Exp $ -Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology 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 @@ -145,8 +145,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (cond ((not (< index end)) 'DONE) ((object-type? (let-syntax ((ucode-type - (non-hygienic-macro-transformer - (lambda (name) (microcode-type name))))) + (sc-macro-transformer + (lambda (form environment) + environment + (apply microcode-type (cdr form)))))) (ucode-type linkage-section)) (system-vector-ref block index)) (loop (disassembler/write-linkage-section block -- 2.25.1