Implement syntax-constructor ("scons") mechanism.

This eliminates a potential problem with RSC and ER macros, which typically
construct ordinary list structure using quasiquote and renaming the keywords.
Unfortunately this will fail if the use environment has redefined the quasiquote
and/or quote keywords.  These constructors are careful not to use any keywords
except renamed ones; they also hide most of the renaming while providing a
simple procedural interface.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 97a6f450b5290b47f72b272387631f9508600b06..bc211ab9adc315ce5ab6601b591623b1563e15d9 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -148,11 +148,10 @@ USA.
   (spar-transformer->runtime
    (delay
      (spar-top-level '(r4rs-bvl expr (list (+ form)))
-       (lambda (close bvl expr body-forms)
-        (let ((r-cwv (close 'call-with-values))
-              (r-lambda (close 'lambda)))
-          `(,r-cwv (,r-lambda () ,expr)
-                   (,r-lambda ,bvl ,@body-forms))))))
+       (lambda (bvl expr body-forms)
+        (scons-call 'call-with-values
+                    (scons-lambda '() expr)
+                    (apply scons-lambda bvl body-forms)))))
    system-global-environment))
 
 (define :define-record-type
@@ -167,41 +166,40 @@ USA.
           (or (seq '#f (push #f))
               id)
           (list (* (list (elt symbol id (or id (push #f)))))))
-       (lambda (close type-name parent maker-name maker-args pred-name
-                     field-specs)
-        (let ((beg (close 'begin))
-              (de (close 'define))
-              (mrt (close 'new-make-record-type))
-              (rc (close 'record-constructor))
-              (rp (close 'record-predicate))
-              (ra (close 'record-accessor))
-              (rm (close 'record-modifier)))
-          `(,beg
-            (,de ,type-name
-                 (,mrt ',type-name
-                       ',(map car field-specs)
-                       ,@(if parent
-                             (list parent)
-                             '())))
-            ,@(if maker-name
-                  `((,de ,maker-name
-                         (,rc ,type-name
-                              ,@(if maker-args
-                                    (list `',maker-args)
-                                    '()))))
-                  '())
-            ,@(if pred-name
-                  `((,de ,pred-name (,rp ,type-name)))
-                  '())
-            ,@(append-map (lambda (field)
-                            (let ((field-name (car field)))
-                              `((,de ,(cadr field)
-                                     (,ra ,type-name ',field-name))
-                                ,@(if (caddr field)
-                                      `((,de ,(caddr field)
-                                             (,rm ,type-name ',field-name)))
-                                      '()))))
-                          field-specs))))))
+       (lambda (type-name parent maker-name maker-args pred-name field-specs)
+        (apply scons-begin
+               (scons-define type-name
+                 (scons-call 'new-make-record-type
+                             (scons-quote type-name)
+                             (scons-quote (map car field-specs))
+                             (or parent (default-object))))
+               (if maker-name
+                   (scons-define maker-name
+                     (scons-call 'record-constructor
+                                 type-name
+                                 (if maker-args
+                                     (scons-quote maker-args)
+                                     (default-object))))
+                   (default-object))
+               (if pred-name
+                   (scons-define pred-name
+                     (scons-call 'record-predicate type-name))
+                   (default-object))
+               (append-map (lambda (field-spec)
+                             (let ((name (car field-spec))
+                                   (accessor (cadr field-spec))
+                                   (modifier (caddr field-spec)))
+                               (list (scons-define accessor
+                                       (scons-call 'record-accessor
+                                                   type-name
+                                                   (scons-quote name)))
+                                     (if modifier
+                                         (scons-define modifier
+                                           (scons-call 'record-modifier
+                                                       type-name
+                                                       (scons-quote name)))
+                                         (default-object)))))
+                           field-specs)))))
    system-global-environment))
 \f
 (define-syntax :define
@@ -240,45 +238,50 @@ USA.
                     (or expr
                         (push-value ,unassigned-expression)))))))
           (list (+ form)))
-       (lambda (close name bindings body-forms)
+       (lambda (name bindings body-forms)
         (let ((ids (map car bindings))
               (vals (map cdr bindings)))
           (if name
-              (generate-named-let close name ids vals body-forms)
-              `((,(close 'named-lambda)
-                 (,scode-lambda-name:let ,@ids)
-                 ,@body-forms)
-                ,@vals))))))
+              (generate-named-let name ids vals body-forms)
+              (apply scons-call
+                     (apply scons-named-lambda
+                            (cons scode-lambda-name:let ids)
+                            body-forms)
+                     vals))))))
    system-global-environment))
 
 (define named-let-strategy 'internal-definition)
 
-(define (generate-named-let close name ids vals body-forms)
-  (let ((proc `(,(close 'named-lambda) (,name ,@ids) ,@body-forms)))
+(define (generate-named-let name ids vals body-forms)
+  (let ((proc (apply scons-named-lambda (cons name ids) body-forms)))
     (case named-let-strategy
       ((internal-definition)
-       `((,(close 'let) ()
-         (,(close 'define) ,name ,proc)
-         ,name)
-        ,@vals))
-      ((letrec letrec*)
-       `((,(close named-let-strategy) ((,name ,proc)) ,name)
-        ,@vals))
+       (apply scons-call
+             (scons-let '() (scons-define name proc) name)
+             vals))
+      ((letrec)
+       (apply scons-call
+             (scons-letrec (list (list name proc)) name)
+             vals))
+      ((letrec*)
+       (apply scons-call
+             (scons-letrec* (list (list name proc)) name)
+             vals))
       ((fixed-point)
        (let ((iter (new-identifier 'iter))
             (kernel (new-identifier 'kernel))
-            (temps (map new-identifier ids))
-            (r-lambda (close 'lambda))
-            (r-declare (close 'declare)))
-        `((,r-lambda (,kernel)
-                     (,kernel ,kernel ,@vals))
-          (,r-lambda (,iter ,@ids)
-                     ((,r-lambda (,name)
-                                 (,r-declare (integrate-operator ,name))
-                                 ,@body-forms)
-                      (,r-lambda ,temps
-                                 (,r-declare (integrate ,@temps))
-                                 (,iter ,iter ,@temps)))))))
+            (temps (map new-identifier ids)))
+        (scons-call (scons-lambda (list kernel)
+                      (apply scons-call kernel kernel vals))
+                    (scons-lambda (cons iter ids)
+                      (scons-call (apply scons-lambda
+                                         (list name)
+                                         (scons-declare
+                                          (list 'integrate-operator name))
+                                         body-forms)
+                                  (scons-lambda temps
+                                    (scons-declare (cons 'integrate temps))
+                                    (apply scons-call iter iter temps)))))))
       (else
        (error "Unrecognized strategy:" named-let-strategy)))))
 \f

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 00e1dce0bb0100ceb87e01c6cb086d8cedf81cde..7e4550e9a8bbf8a1be711df0c7a64e79bd327df8 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4583,7 +4583,6 @@ USA.
          spar-repeat
          spar-seq
          spar-succeed
-         spar-top-level
          spar-transform-values
          spar-with-mapped-senv)
   (export (runtime syntax)
@@ -4592,6 +4591,29 @@ USA.
          spar-push-deferred-classified
          spar-push-open-classified))
 
+(define-package (runtime syntax constructor)
+  (files "syntax-constructor")
+  (parent (runtime syntax))
+  (export ()
+         scons-and
+         scons-begin
+         scons-call
+         scons-declare
+         scons-define
+         scons-delay
+         scons-if
+         scons-lambda
+         scons-let
+         scons-letrec
+         scons-letrec*
+         scons-named-lambda
+         scons-named-let
+         scons-or
+         scons-quote
+         scons-quote-identifier
+         scons-set!
+         spar-top-level))
+
 (define-package (runtime syntax rename)
   (files "syntax-rename")
   (parent (runtime syntax))

diff --git a/src/runtime/syntax-constructor.scm b/src/runtime/syntax-constructor.scm
new file mode 100644 (file)
index 0000000..5859ad1
--- /dev/null
+++ b/src/runtime/syntax-constructor.scm
@@ -0,0 +1,141 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Syntax constructors
+;;; package: (runtime syntax constructor)
+
+(declare (usual-integrations))
+\f
+(define (spar-top-level pattern procedure)
+  (spar-call-with-values
+      (lambda (close . args)
+       (close-part close (apply procedure args)))
+    (spar-elt)
+    (spar-push spar-arg:close)
+    (pattern->spar pattern)))
+
+(define (close-part close part)
+  (if (procedure? part)
+      (part close)
+      part))
+
+(define (close-parts close parts)
+  (map (lambda (part) (close-part close part))
+       parts))
+
+(define (scons-and . exprs)
+  (lambda (close)
+    (cons (close 'and)
+         (close-parts close exprs))))
+
+(define (scons-begin . exprs)
+  (lambda (close)
+    (cons (close 'begin)
+         (close-parts close (remove default-object? exprs)))))
+
+(define (scons-call operator . operands)
+  (lambda (close)
+    (cons (if (identifier? operator)
+             (close operator)
+             (close-part close operator))
+         (close-parts close operands))))
+
+(define (scons-declare . decls)
+  (lambda (close)
+    (cons (close 'declare)
+         decls)))
+
+(define (scons-define name value)
+  (lambda (close)
+    (list (close 'define)
+         name
+         (close-part close value))))
+
+(define (scons-delay expr)
+  (lambda (close)
+    (list (close 'delay)
+         (close-part close expr))))
+
+(define (scons-if predicate consequent alternative)
+  (lambda (close)
+    (list (close 'if)
+         (close-part close predicate)
+         (close-part close consequent)
+         (close-part close alternative))))
+\f
+(define (scons-lambda bvl . body-forms)
+  (lambda (close)
+    (cons* (close 'lambda)
+          bvl
+          (close-parts close body-forms))))
+
+(define (scons-named-lambda bvl . body-forms)
+  (lambda (close)
+    (cons* (close 'named-lambda)
+          bvl
+          (close-parts close body-forms))))
+
+(define (scons-or . exprs)
+  (lambda (close)
+    (cons (close 'or)
+         (close-parts close exprs))))
+
+(define (scons-quote datum)
+  (lambda (close)
+    (list (close 'quote) datum)))
+
+(define (scons-quote-identifier id)
+  (lambda (close)
+    (list (close 'quote-identifier) id)))
+
+(define (scons-set! name value)
+  (lambda (close)
+    (list (close 'set!)
+         name
+         (close-part close value))))
+
+(define (let-like keyword)
+  (lambda (bindings . body-forms)
+    (lambda (close)
+      (cons* (close keyword)
+            (close-bindings close bindings)
+            (close-parts close body-forms)))))
+
+(define (close-bindings close bindings)
+  (map (lambda (b)
+        (list (car b) (close-part close (cadr b))))
+       bindings))
+
+(define scons-let (let-like 'let))
+(define scons-letrec (let-like 'letrec))
+(define scons-letrec* (let-like 'letrec*))
+
+(define (scons-named-let name bindings . body-forms)
+  (lambda (close)
+    (cons* (close 'let)
+          name
+          (close-bindings close bindings)
+          (close-parts close body-forms))))
\ No newline at end of file

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index d3bdca6facdcf244833426070cec294f042bf464..2b4c38d5c05f72785f872c3d6644b20204bcb306 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -441,12 +441,6 @@ USA.
 \f
 ;;;; Shorthand
 
-(define (spar-top-level pattern procedure)
-  (spar-call-with-values procedure
-    (spar-elt)
-    (spar-push spar-arg:close)
-    (pattern->spar pattern)))
-
 (define (make-pattern-compiler expr? caller)
   (call-with-constructors expr?
     (lambda (:* :+ :call :close :cons :elt :eqv? :form :hist :identifier? :list