From 1e8fbaf61860f19be2396e00a3272f254e801e25 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 6 Feb 2018 20:48:53 -0800 Subject: [PATCH] Collapse syntax, syntax-classify, and syntax-compile into one file. --- src/runtime/ed-ffi.scm | 2 - src/runtime/make.scm | 2 +- src/runtime/runtime.pkg | 24 ++--- src/runtime/syntax-classify.scm | 99 --------------------- src/runtime/syntax-compile.scm | 105 ---------------------- src/runtime/syntax.scm | 150 ++++++++++++++++++++++++++++++++ 6 files changed, 158 insertions(+), 224 deletions(-) delete mode 100644 src/runtime/syntax-classify.scm delete mode 100644 src/runtime/syntax-compile.scm diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm index b5418fccf..0006b5660 100644 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@ -160,8 +160,6 @@ USA. ("syncproc" (runtime synchronous-subprocess)) ("syntax" (runtime syntax top-level)) ("syntax-check" (runtime syntax check)) - ("syntax-classify" (runtime syntax classify)) - ("syntax-compile" (runtime syntax compile)) ("syntax-declaration" (runtime syntax declaration)) ("syntax-definitions" (runtime syntax definitions)) ("syntax-environment" (runtime syntax environment)) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 00b04a266..538b424db 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -530,7 +530,7 @@ USA. (RUNTIME UNSYNTAXER) (RUNTIME PRETTY-PRINTER) (RUNTIME EXTENDED-SCODE-EVAL) - (runtime syntax compile) + (runtime syntax top-level) (RUNTIME SYNTAX DEFINITIONS) (runtime syntax rename) ;; REP Loops diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 39fddddd0..fded8384a 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4404,8 +4404,15 @@ USA. syntax-error) (export (runtime syntax) classifier->keyword + classify/body + classify/expression + classify/form + compile-body-item/top-level + compile-body-items + compile-item/expression compile/expression compiler->keyword + define-item-compiler raw-identifier?)) (define-package (runtime syntax items) @@ -4474,23 +4481,6 @@ USA. syntax-match? syntax-match?*)) -(define-package (runtime syntax classify) - (files "syntax-classify") - (parent (runtime syntax)) - (export (runtime syntax) - classify/body - classify/expression - classify/form)) - -(define-package (runtime syntax compile) - (files "syntax-compile") - (parent (runtime syntax)) - (export (runtime syntax) - compile-body-item/top-level - compile-body-items - compile-item/expression - define-item-compiler)) - (define-package (runtime syntax rename) (files "syntax-rename") (parent (runtime syntax)) diff --git a/src/runtime/syntax-classify.scm b/src/runtime/syntax-classify.scm deleted file mode 100644 index 047907b21..000000000 --- a/src/runtime/syntax-classify.scm +++ /dev/null @@ -1,99 +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. - -|# - -;;;; Syntax Classifier - -(declare (usual-integrations)) - -(define (classify/form form environment) - (cond ((identifier? form) - (let ((item (lookup-identifier form environment))) - (if (keyword-item? item) - (keyword-value-item - (strip-keyword-value-item item) - (expr-item - (let ((name (identifier->symbol form))) - (lambda () - (output/combination - (output/runtime-reference 'syntactic-keyword->item) - (list (output/constant name) - (output/the-environment))))))) - item))) - ((syntactic-closure? form) - (classify/form - (syntactic-closure-form form) - (make-partial-syntactic-environment (syntactic-closure-free form) - environment - (syntactic-closure-senv form)))) - ((pair? form) - (let ((item - (strip-keyword-value-item - (classify/expression (car form) environment)))) - (cond ((classifier-item? item) - ((classifier-item-impl item) form environment)) - ((compiler-item? item) - (expr-item - (let ((compiler (compiler-item-impl item))) - (lambda () - (compiler form environment))))) - ((expander-item? item) - (classify/form ((expander-item-impl item) form environment) - environment)) - (else - (if (not (list? (cdr form))) - (syntax-error "Combination must be a proper list:" form)) - (expr-item - (let ((items (classify/expressions (cdr form) environment))) - (lambda () - (output/combination - (compile-item/expression item) - (map compile-item/expression items))))))))) - (else - (expr-item (lambda () (output/constant form)))))) - -(define (strip-keyword-value-item item) - (if (keyword-value-item? item) - (keyword-value-item-keyword item) - item)) - -(define (classify/expression expression environment) - (classify/form expression environment)) - -(define (classify/expressions expressions environment) - (map (lambda (expression) - (classify/expression expression environment)) - expressions)) - -(define (classify/body forms environment) - ;; Syntactic definitions affect all forms that appear after them, so classify - ;; FORMS in order. - (seq-item - (let loop ((forms forms) (items '())) - (if (pair? forms) - (loop (cdr forms) - (reverse* (item->list (classify/form (car forms) environment)) - items)) - (reverse! items))))) \ No newline at end of file diff --git a/src/runtime/syntax-compile.scm b/src/runtime/syntax-compile.scm deleted file mode 100644 index 216c4a313..000000000 --- a/src/runtime/syntax-compile.scm +++ /dev/null @@ -1,105 +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. - -|# - -;;;; Syntax Compiler - -(declare (usual-integrations)) - -(define (compile-item/top-level item) - (if (defn-item? item) - (let ((name (identifier->symbol (defn-item-id item))) - (value (defn-item-value item))) - (if (keyword-value-item? value) - (output/top-level-syntax-definition - name - (compile-item/expression (keyword-value-item-expr value))) - (output/top-level-definition - name - (compile-item/expression value)))) - (compile-item/expression item))) - -(define (compile-body-item/top-level item) - (output/top-level-sequence (map compile-item/top-level (item->list item)))) - -(define (compile-body-items items) - (let ((items (flatten-items items))) - (if (not (pair? items)) - (syntax-error "Empty body")) - (output/sequence - (append-map - (lambda (item) - (if (defn-item? item) - (let ((value (defn-item-value item))) - (if (keyword-value-item? value) - '() - (list (output/definition (defn-item-id item) - (compile-item/expression value))))) - (list (compile-item/expression item)))) - items)))) - -(define compile-item/expression) -(add-boot-init! - (lambda () - (set! compile-item/expression - (standard-predicate-dispatcher 'compile-item/expression 1)) - (run-deferred-boot-actions 'define-item-compiler))) - -(define (define-item-compiler predicate compiler) - (defer-boot-action 'define-item-compiler - (lambda () - (define-predicate-dispatch-handler compile-item/expression - (list predicate) - compiler)))) - -(define-item-compiler var-item? - (lambda (item) - (output/variable (var-item-id item)))) - -(define-item-compiler expr-item? - (lambda (item) - ((expr-item-compiler item)))) - -(define-item-compiler seq-item? - (lambda (item) - (compile-body-items (seq-item-elements item)))) - -(define-item-compiler decl-item? - (lambda (item) - (output/declaration (decl-item-text item)))) - -(define (illegal-expression-compiler description) - (let ((message (string description " may not be used as an expression:"))) - (lambda (item) - (syntax-error message item)))) - -(define-item-compiler reserved-name-item? - (illegal-expression-compiler "Reserved name")) - -(define-item-compiler keyword-item? - (illegal-expression-compiler "Syntactic keyword")) - -(define-item-compiler defn-item? - (illegal-expression-compiler "Definition")) \ No newline at end of file diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index b73d294a5..c8c1d4f7a 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -66,6 +66,156 @@ USA. (compile/expression expression environment)) expressions)) +;;;; Classifier + +(define (classify/form form environment) + (cond ((identifier? form) + (let ((item (lookup-identifier form environment))) + (if (keyword-item? item) + (keyword-value-item + (strip-keyword-value-item item) + (expr-item + (let ((name (identifier->symbol form))) + (lambda () + (output/combination + (output/runtime-reference 'syntactic-keyword->item) + (list (output/constant name) + (output/the-environment))))))) + item))) + ((syntactic-closure? form) + (classify/form + (syntactic-closure-form form) + (make-partial-syntactic-environment (syntactic-closure-free form) + environment + (syntactic-closure-senv form)))) + ((pair? form) + (let ((item + (strip-keyword-value-item + (classify/expression (car form) environment)))) + (cond ((classifier-item? item) + ((classifier-item-impl item) form environment)) + ((compiler-item? item) + (expr-item + (let ((compiler (compiler-item-impl item))) + (lambda () + (compiler form environment))))) + ((expander-item? item) + (classify/form ((expander-item-impl item) form environment) + environment)) + (else + (if (not (list? (cdr form))) + (syntax-error "Combination must be a proper list:" form)) + (expr-item + (let ((items (classify/expressions (cdr form) environment))) + (lambda () + (output/combination + (compile-item/expression item) + (map compile-item/expression items))))))))) + (else + (expr-item (lambda () (output/constant form)))))) + +(define (strip-keyword-value-item item) + (if (keyword-value-item? item) + (keyword-value-item-keyword item) + item)) + +(define (classify/expression expression environment) + (classify/form expression environment)) + +(define (classify/expressions expressions environment) + (map (lambda (expression) + (classify/expression expression environment)) + expressions)) + +(define (classify/body forms environment) + ;; Syntactic definitions affect all forms that appear after them, so classify + ;; FORMS in order. + (seq-item + (let loop ((forms forms) (items '())) + (if (pair? forms) + (loop (cdr forms) + (reverse* (item->list (classify/form (car forms) environment)) + items)) + (reverse! items))))) + +;;;; Compiler + +(define (compile-item/top-level item) + (if (defn-item? item) + (let ((name (identifier->symbol (defn-item-id item))) + (value (defn-item-value item))) + (if (keyword-value-item? value) + (output/top-level-syntax-definition + name + (compile-item/expression (keyword-value-item-expr value))) + (output/top-level-definition + name + (compile-item/expression value)))) + (compile-item/expression item))) + +(define (compile-body-item/top-level item) + (output/top-level-sequence (map compile-item/top-level (item->list item)))) + +(define (compile-body-items items) + (let ((items (flatten-items items))) + (if (not (pair? items)) + (syntax-error "Empty body")) + (output/sequence + (append-map + (lambda (item) + (if (defn-item? item) + (let ((value (defn-item-value item))) + (if (keyword-value-item? value) + '() + (list (output/definition (defn-item-id item) + (compile-item/expression value))))) + (list (compile-item/expression item)))) + items)))) + +(define compile-item/expression) +(add-boot-init! + (lambda () + (set! compile-item/expression + (standard-predicate-dispatcher 'compile-item/expression 1)) + (run-deferred-boot-actions 'define-item-compiler))) + +(define (define-item-compiler predicate compiler) + (defer-boot-action 'define-item-compiler + (lambda () + (define-predicate-dispatch-handler compile-item/expression + (list predicate) + compiler)))) + +(define-item-compiler var-item? + (lambda (item) + (output/variable (var-item-id item)))) + +(define-item-compiler expr-item? + (lambda (item) + ((expr-item-compiler item)))) + +(define-item-compiler seq-item? + (lambda (item) + (compile-body-items (seq-item-elements item)))) + +(define-item-compiler decl-item? + (lambda (item) + (output/declaration (decl-item-text item)))) + +(define (illegal-expression-compiler description) + (let ((message (string description " may not be used as an expression:"))) + (lambda (item) + (syntax-error message item)))) + +(define-item-compiler reserved-name-item? + (illegal-expression-compiler "Reserved name")) + +(define-item-compiler keyword-item? + (illegal-expression-compiler "Syntactic keyword")) + +(define-item-compiler defn-item? + (illegal-expression-compiler "Definition")) + ;;;; Syntactic closures (define (close-syntax form senv) -- 2.25.1