From b8df35753623937a007b4626da512a7833a0c750 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 12 Feb 2018 20:50:20 -0800 Subject: [PATCH] Bind classifiers directly into global environment. Eliminates kludge of syntax-definitions. --- src/runtime/ed-ffi.scm | 1 - src/runtime/make.scm | 1 - src/runtime/mit-syntax.scm | 262 ++++++++++++++++------------- src/runtime/runtime.pkg | 41 ++--- src/runtime/syntax-definitions.scm | 56 ------ 5 files changed, 167 insertions(+), 194 deletions(-) delete mode 100644 src/runtime/syntax-definitions.scm diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm index 0006b5660..e18c6ab48 100644 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@ -161,7 +161,6 @@ USA. ("syntax" (runtime syntax top-level)) ("syntax-check" (runtime syntax check)) ("syntax-declaration" (runtime syntax declaration)) - ("syntax-definitions" (runtime syntax definitions)) ("syntax-environment" (runtime syntax environment)) ("syntax-items" (runtime syntax items)) ("syntax-output" (runtime syntax output)) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index ab1cb70d0..e04c35a50 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -531,7 +531,6 @@ USA. (RUNTIME PRETTY-PRINTER) (RUNTIME EXTENDED-SCODE-EVAL) (runtime syntax top-level) - (RUNTIME SYNTAX DEFINITIONS) (runtime syntax rename) ;; REP Loops (RUNTIME INTERRUPT-HANDLER) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index aed5ff544..14757f77d 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -42,34 +42,44 @@ USA. (output/top-level-syntax-expander procedure-name transformer))))))) -(define classifier:sc-macro-transformer +(define (classifier->runtime classifier) + (make-unmapped-macro-reference-trap (classifier-item classifier))) + +(define :sc-macro-transformer ;; "Syntactic Closures" transformer - (transformer-keyword 'sc-macro-transformer->expander - sc-macro-transformer->expander)) + (classifier->runtime + (transformer-keyword 'sc-macro-transformer->expander + sc-macro-transformer->expander))) -(define classifier:rsc-macro-transformer +(define :rsc-macro-transformer ;; "Reversed Syntactic Closures" transformer - (transformer-keyword 'rsc-macro-transformer->expander - rsc-macro-transformer->expander)) + (classifier->runtime + (transformer-keyword 'rsc-macro-transformer->expander + rsc-macro-transformer->expander))) -(define classifier:er-macro-transformer +(define :er-macro-transformer ;; "Explicit Renaming" transformer - (transformer-keyword 'er-macro-transformer->expander - er-macro-transformer->expander)) + (classifier->runtime + (transformer-keyword 'er-macro-transformer->expander + er-macro-transformer->expander))) ;;;; Core primitives -(define (classifier:lambda form senv hist) - (syntax-check '(_ mit-bvl + form) form) - (classify-lambda scode-lambda-name:unnamed - (cadr form) - form senv hist)) +(define :lambda + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ mit-bvl + form) form) + (classify-lambda scode-lambda-name:unnamed + (cadr form) + form senv hist)))) -(define (classifier:named-lambda form senv hist) - (syntax-check '(_ (identifier . mit-bvl) + form) form) - (classify-lambda (identifier->symbol (caadr form)) - (cdadr form) - form senv hist)) +(define :named-lambda + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ (identifier . mit-bvl) + form) form) + (classify-lambda (identifier->symbol (caadr form)) + (cdadr form) + form senv hist)))) (define (classify-lambda name bvl form senv hist) (let ((senv (make-internal-senv senv))) @@ -84,51 +94,74 @@ USA. (body-item (classify-forms-in-order-cddr form senv hist))))))) -(define (classifier:begin form senv hist) - (syntax-check '(_ * form) form) - (seq-item (classify-forms-in-order-cdr form senv hist))) - -(define (classifier:if form senv hist) - (syntax-check '(_ expression expression ? expression) form) - (if-item (classify-form-cadr form senv hist) - (classify-form-caddr form senv hist) - (if (pair? (cdddr form)) - (classify-form-cadddr form senv hist) - (unspecific-item)))) - -(define (classifier:quote form senv hist) - (declare (ignore senv hist)) - (syntax-check '(_ datum) form) - (constant-item (strip-syntactic-closures (cadr form)))) - -(define (classifier:quote-identifier form senv hist) - (declare (ignore hist)) - (syntax-check '(_ identifier) form) - (let ((item (lookup-identifier (cadr form) senv))) - (if (not (var-item? item)) - (syntax-error "Can't quote a keyword identifier:" form)) - (quoted-id-item item))) - -(define (classifier:set! form senv hist) - (syntax-check '(_ form ? expression) form) - (let ((lhs-item (classify-form-cadr form senv hist)) - (rhs-item - (if (pair? (cddr form)) - (classify-form-caddr form senv hist) - (unassigned-item)))) - (cond ((var-item? lhs-item) - (assignment-item (var-item-id lhs-item) rhs-item)) - ((access-item? lhs-item) - (access-assignment-item (access-item-name lhs-item) - (access-item-env lhs-item) - rhs-item)) - (else - (syntax-error "Variable required in this context:" (cadr form)))))) - -(define (classifier:delay form senv hist) - (syntax-check '(_ expression) form) - (delay-item (lambda () (classify-form-cadr form senv hist)))) +(define :delay + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ expression) form) + (delay-item (lambda () (classify-form-cadr form senv hist)))))) + +(define :begin + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ * form) form) + (seq-item (classify-forms-in-order-cdr form senv hist))))) + +(define :if + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ expression expression ? expression) form) + (if-item (classify-form-cadr form senv hist) + (classify-form-caddr form senv hist) + (if (pair? (cdddr form)) + (classify-form-cadddr form senv hist) + (unspecific-item)))))) + +(define :quote + (classifier->runtime + (lambda (form senv hist) + (declare (ignore senv hist)) + (syntax-check '(_ datum) form) + (constant-item (strip-syntactic-closures (cadr form)))))) + +(define :quote-identifier + (classifier->runtime + (lambda (form senv hist) + (declare (ignore hist)) + (syntax-check '(_ identifier) form) + (let ((item (lookup-identifier (cadr form) senv))) + (if (not (var-item? item)) + (syntax-error "Can't quote a keyword identifier:" form)) + (quoted-id-item item))))) +(define :set! + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ form ? expression) form) + (let ((lhs-item (classify-form-cadr form senv hist)) + (rhs-item + (if (pair? (cddr form)) + (classify-form-caddr form senv hist) + (unassigned-item)))) + (cond ((var-item? lhs-item) + (assignment-item (var-item-id lhs-item) rhs-item)) + ((access-item? lhs-item) + (access-assignment-item (access-item-name lhs-item) + (access-item-env lhs-item) + rhs-item)) + (else + (syntax-error "Variable required in this context:" + (cadr form)))))))) + +;; TODO: this is a classifier rather than a macro because it uses the +;; special OUTPUT/DISJUNCTION. Unfortunately something downstream in +;; the compiler wants this, but it would be nice to eliminate this +;; hack. +(define :or + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ * expression) form) + (or-item (classify-forms-cdr form senv hist))))) + ;;;; Definitions (define keyword:define @@ -137,16 +170,18 @@ USA. (let ((id (bind-variable (cadr form) senv))) (defn-item id (classify-form-caddr form senv hist)))))) -(define (classifier:define-syntax form senv hist) - (syntax-check '(_ identifier expression) form) - (let ((name (cadr form)) - (item (classify-form-caddr form senv hist))) - (keyword-binder senv name item) - ;; User-defined macros at top level are preserved in the output. - (if (and (senv-top-level? senv) - (expander-item? item)) - (syntax-defn-item name (expander-item-expr item)) - (seq-item '())))) +(define :define-syntax + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ identifier expression) form) + (let ((name (cadr form)) + (item (classify-form-caddr form senv hist))) + (keyword-binder senv name item) + ;; User-defined macros at top level are preserved in the output. + (if (and (senv-top-level? senv) + (expander-item? item)) + (syntax-defn-item name (expander-item-expr item)) + (seq-item '())))))) (define (keyword-binder senv name item) (if (not (keyword-item? item)) @@ -184,37 +219,34 @@ USA. (seq-item (classify-forms-in-order-cddr form body-senv hist)))) +(define :let-syntax + (classifier->runtime classifier:let-syntax)) + (define keyword:let-syntax (classifier->keyword classifier:let-syntax)) -(define (classifier:letrec-syntax form senv hist) - (syntax-check '(_ (* (identifier expression)) + form) form) - (let ((binding-senv (make-internal-senv senv))) - (let ((bindings (cadr form))) - (for-each (lambda (binding) - (reserve-identifier (car binding) binding-senv)) - bindings) - ;; Classify right-hand sides first, in order to catch references to - ;; reserved names. Then bind names prior to classifying body. - (for-each (lambda (binding item) - (keyword-binder binding-senv (car binding) item)) - bindings - (map (lambda (binding hist) - (classify-form-cadr binding binding-senv hist)) - bindings - (subform-hists bindings (hist-cadr hist))))) - (seq-item - (classify-forms-in-order-cddr form - (make-internal-senv binding-senv) - hist)))) - -;; TODO: this is a classifier rather than a macro because it uses the -;; special OUTPUT/DISJUNCTION. Unfortunately something downstream in -;; the compiler wants this, but it would be nice to eliminate this -;; hack. -(define (classifier:or form senv hist) - (syntax-check '(_ * expression) form) - (or-item (classify-forms-cdr form senv hist))) +(define :letrec-syntax + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ (* (identifier expression)) + form) form) + (let ((binding-senv (make-internal-senv senv))) + (let ((bindings (cadr form))) + (for-each (lambda (binding) + (reserve-identifier (car binding) binding-senv)) + bindings) + ;; Classify right-hand sides first, in order to catch references to + ;; reserved names. Then bind names prior to classifying body. + (for-each (lambda (binding item) + (keyword-binder binding-senv (car binding) item)) + bindings + (map (lambda (binding hist) + (classify-form-cadr binding binding-senv hist)) + bindings + (subform-hists bindings (hist-cadr hist))))) + (seq-item + (classify-forms-in-order-cddr form + (make-internal-senv binding-senv) + hist)))))) ;;;; MIT-specific syntax @@ -235,12 +267,14 @@ USA. (output/access-reference (access-item-name item) (compile-expr-item (access-item-env item))))) -(define (classifier:the-environment form senv hist) - (declare (ignore hist)) - (syntax-check '(_) form) - (if (not (senv-top-level? senv)) - (syntax-error "This form allowed only at top level:" form)) - (the-environment-item)) +(define :the-environment + (classifier->runtime + (lambda (form senv hist) + (declare (ignore hist)) + (syntax-check '(_) form) + (if (not (senv-top-level? senv)) + (syntax-error "This form allowed only at top level:" form)) + (the-environment-item)))) (define keyword:unspecific (classifier->keyword @@ -253,14 +287,16 @@ USA. (lambda (form senv hist) (declare (ignore form senv hist)) (unassigned-item)))) - + ;;;; Declarations -(define (classifier:declare form senv hist) - (syntax-check '(_ * (identifier * datum)) form) - (decl-item - (lambda () - (classify-decls (cdr form) senv (hist-cdr hist))))) +(define :declare + (classifier->runtime + (lambda (form senv hist) + (syntax-check '(_ * (identifier * datum)) form) + (decl-item + (lambda () + (classify-decls (cdr form) senv (hist-cdr hist))))))) (define (classify-decls decls senv hist) (map (lambda (decl hist) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 6a6c8c80f..3be7548c5 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4569,24 +4569,24 @@ USA. (define-package (runtime syntax mit) (files "mit-syntax") (parent (runtime syntax)) - (export (runtime syntax definitions) - classifier:begin - classifier:declare - classifier:define-syntax - classifier:delay - classifier:er-macro-transformer - classifier:if - classifier:lambda - classifier:let-syntax - classifier:letrec-syntax - classifier:named-lambda - classifier:or - classifier:quote - classifier:quote-identifier - classifier:rsc-macro-transformer - classifier:sc-macro-transformer - classifier:set! - classifier:the-environment) + (export () + (begin :begin) + (declare :declare) + (define-syntax :define-syntax) + (delay :delay) + (er-macro-transformer :er-macro-transformer) + (if :if) + (lambda :lambda) + (let-syntax :let-syntax) + (letrec-syntax :letrec-syntax) + (named-lambda :named-lambda) + (or :or) + (quote :quote) + (quote-identifier :quote-identifier) + (rsc-macro-transformer :rsc-macro-transformer) + (sc-macro-transformer :sc-macro-transformer) + (set! :set!) + (the-environment :the-environment)) (export (runtime mit-macros) keyword:access keyword:define @@ -4643,11 +4643,6 @@ USA. (export () define-structure)) -(define-package (runtime syntax definitions) - (files "syntax-definitions") - (parent (runtime syntax)) - (initialization (initialize-package!))) - (define-package (runtime system-macros) (files "sysmac") (parent (runtime)) diff --git a/src/runtime/syntax-definitions.scm b/src/runtime/syntax-definitions.scm deleted file mode 100644 index 55053e8e1..000000000 --- a/src/runtime/syntax-definitions.scm +++ /dev/null @@ -1,56 +0,0 @@ -#| -*-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. - -|# - -;;;; Code to install syntax keywords in global environment -;;; package: (runtime syntax definitions) - -(declare (usual-integrations)) - -(add-boot-init! - (lambda () - - (define (define-classifier name classifier) - (environment-define-macro system-global-environment - name - (classifier-item classifier))) - - (define-classifier 'begin classifier:begin) - (define-classifier 'declare classifier:declare) - (define-classifier 'define-syntax classifier:define-syntax) - (define-classifier 'delay classifier:delay) - (define-classifier 'er-macro-transformer classifier:er-macro-transformer) - (define-classifier 'if classifier:if) - (define-classifier 'lambda classifier:lambda) - (define-classifier 'let-syntax classifier:let-syntax) - (define-classifier 'letrec-syntax classifier:letrec-syntax) - (define-classifier 'named-lambda classifier:named-lambda) - (define-classifier 'or classifier:or) - (define-classifier 'quote classifier:quote) - (define-classifier 'quote-identifier classifier:quote-identifier) - (define-classifier 'rsc-macro-transformer classifier:rsc-macro-transformer) - (define-classifier 'sc-macro-transformer classifier:sc-macro-transformer) - (define-classifier 'set! classifier:set!) - (define-classifier 'the-environment classifier:the-environment))) \ No newline at end of file -- 2.25.1