From 740ed5cd79ee6db163068597a78ec0c9d2845c56 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 21 Mar 2018 21:16:07 -0700 Subject: [PATCH] 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. --- src/runtime/mit-macros.scm | 137 ++++++++++++++-------------- src/runtime/runtime.pkg | 24 ++++- src/runtime/syntax-constructor.scm | 141 +++++++++++++++++++++++++++++ src/runtime/syntax-parser.scm | 6 -- 4 files changed, 234 insertions(+), 74 deletions(-) create mode 100644 src/runtime/syntax-constructor.scm diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 97a6f450b..bc211ab9a 100644 --- 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)) (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))))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 00e1dce0b..7e4550e9a 100644 --- 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 index 000000000..5859ad150 --- /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)) + +(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)))) + +(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 d3bdca6fa..2b4c38d5c 100644 --- a/src/runtime/syntax-parser.scm +++ b/src/runtime/syntax-parser.scm @@ -441,12 +441,6 @@ USA. ;;;; 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 -- 2.25.1