From: Chris Hanson Date: Sat, 22 Dec 2001 03:19:19 +0000 (+0000) Subject: Fix problem: DEFINE-SYNTAX was expanding into a fixed reference trap X-Git-Tag: 20090517-FFI~2315 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6620847c0a04e74bae3227640626e5bb4de68341;p=mit-scheme.git Fix problem: DEFINE-SYNTAX was expanding into a fixed reference trap in which the SCode lambda was inserted; it must instead expand into an expression that evaluates the lambda and wraps it in a reference trap. --- diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 79566fd25..2a23aaa02 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.401 2001/12/21 18:37:35 cph Exp $ +$Id: runtime.pkg,v 14.402 2001/12/22 03:19:19 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -2695,7 +2695,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA unmap-reference-trap unmapped-macro-reference-trap? unmapped-unassigned-reference-trap? - unmapped-unbound-reference-trap?)) + unmapped-unbound-reference-trap?) + (export (runtime syntaxer) + make-macro-reference-trap-expression) + (export (runtime unsyntaxer) + macro-reference-trap-expression-transformer + macro-reference-trap-expression?)) (define-package (runtime rep) (files "rep") @@ -3758,6 +3763,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA syntax-table/define) (export (runtime syntaxer) guarantee-syntax-table + make-syntax-table syntax-table/environment syntax-table/extend syntax-table/ref)) diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index ef9516f77..564d16fd5 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: syntax.scm,v 14.48 2001/12/21 18:22:41 cph Exp $ +$Id: syntax.scm,v 14.49 2001/12/22 03:17:19 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -86,11 +86,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (syntax-top-level name syntaxer expression table) (let ((scode (fluid-let ((*syntax-table* - (if (eq? table 'DEFAULT) - (if (unassigned? *syntax-table*) - (nearest-repl/environment) - *syntax-table*) - (guarantee-syntax-table table name))) + (make-syntax-table + (if (eq? table 'DEFAULT) + (if (unassigned? *syntax-table*) + (nearest-repl/environment) + *syntax-table*) + (guarantee-syntax-table table name)))) (*current-keyword* #f)) (syntaxer #t expression)))) (if *disallow-illegal-definitions?* @@ -436,7 +437,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let ((value (syntax-subexpression value))) (syntax-table/define *syntax-table* name (syntax-eval value)) (if top-level? - (make-definition name (make-macro-reference-trap value)) + (make-definition name (make-macro-reference-trap-expression value)) name))) (define (syntax-eval scode) diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index 2899be465..ce7ed3887 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: unsyn.scm,v 14.25 2001/12/21 18:22:53 cph Exp $ +$Id: unsyn.scm,v 14.26 2001/12/22 03:17:22 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -163,9 +163,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA `(SET! ,name ,@(unexpand-binding-value value))))) (define (unexpand-definition name value) - (cond ((macro-reference-trap? value) + (cond ((macro-reference-trap-expression? value) `(DEFINE-SYNTAX ,name - ,(macro-reference-trap-transformer value))) + ,(macro-reference-trap-expression-transformer value))) ((and (eq? #t unsyntaxer:macroize?) (lambda? value) (not (has-substitution? value))) diff --git a/v7/src/runtime/urtrap.scm b/v7/src/runtime/urtrap.scm index 6c0d6cb32..72ca5085e 100644 --- a/v7/src/runtime/urtrap.scm +++ b/v7/src/runtime/urtrap.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: urtrap.scm,v 14.9 2001/12/21 18:22:57 cph Exp $ +$Id: urtrap.scm,v 14.10 2001/12/22 03:17:25 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -119,7 +119,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (if (cached-reference-trap? value) (cached-reference-trap-value value) value))) - + (define (make-macro-reference-trap transformer) (make-reference-trap 15 transformer)) @@ -141,4 +141,29 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (and (primitive-object-type? (ucode-type reference-trap) (getter)) (let ((index (object-datum (getter)))) (and (> index trap-max-immediate) - (fix:= 15 (primitive-object-ref (getter) 0)))))) \ No newline at end of file + (fix:= 15 (primitive-object-ref (getter) 0)))))) + +(define (make-macro-reference-trap-expression transformer) + (make-combination primitive-object-set-type + (list (ucode-type reference-trap) + (make-combination cons (list 15 transformer))))) + +(define (macro-reference-trap-expression? expression) + (and (combination? expression) + (eq? (combination-operator expression) primitive-object-set-type) + (let ((operands (combination-operands expression))) + (and (pair? operands) + (eqv? (car operands) (ucode-type reference-trap)) + (pair? (cdr operands)) + (let ((expression (cadr operands))) + (and (combination? expression) + (eq? (combination-operator expression) cons) + (let ((operands (combination-operands expression))) + (and (pair? operands) + (eqv? (car operands) 15) + (pair? (cdr operands)) + (null? (cddr operands)))))) + (null? (cddr operands)))))) + +(define (macro-reference-trap-expression-transformer expression) + (cadr (combination-operands (cadr (combination-operands expression))))) \ No newline at end of file