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 79566fd25cb7af4aa4a97beb415669cc296a51f4..2a23aaa02b8abb024bc30cdfb291ffe1d4ecbfb6 100644 (file)
--- 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 ef9516f77c98b6461f360f3b4f4c794e68967e3b..564d16fd5fcadf88d0aa07b32033f9bbee964631 100644 (file)
--- 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 2899be465b9acbcb7f5735805f92cf5ed4d7b182..ce7ed3887585463be2638dd8823746ae3fa03281 100644 (file)
--- 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 6c0d6cb3280dfe920fc8eca80fbc99ebb51c5cd2..72ca5085ea7867be9e9b89bd99d7855f8d30e728 100644 (file)
--- 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)))
-
+\f
 (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