Simplify where easy to do so.
make-rvalue
make-snode
package
- rule-matcher)
- (import (runtime syntactic-closures)
- syntax-match?))
+ rule-matcher))
(define-package (compiler declarations)
(files "machines/C/decls")
make-rvalue
make-snode
package
- rule-matcher)
- (import (runtime syntactic-closures)
- syntax-match?))
+ rule-matcher))
(define-package (compiler declarations)
(files "machines/i386/decls")
(define with-instance-variables
(make-unmapped-macro-reference-trap
(make-compiler-item
- (lambda (form environment history)
- (if (syntax-match? '(IDENTIFIER EXPRESSION (* IDENTIFIER) + EXPRESSION)
- (cdr form))
- (let ((class-name (cadr form))
- (self (caddr form))
- (free-names (cadddr form))
- (body (cddddr form)))
- (transform-instance-variables
- (class-instance-transforms
- (name->class (identifier->symbol class-name)))
- (compile/subexpression self environment history select-caddr)
- free-names
- (compile/subexpression
- `(,(close-syntax 'BEGIN system-global-environment) ,@body)
- environment
- history
- select-cddddr)))
- (ill-formed-syntax form))))))
+ (lambda (form environment)
+ (syntax-check '(KEYWORD IDENTIFIER EXPRESSION (* IDENTIFIER) + EXPRESSION)
+ form)
+ (let ((class-name (cadr form))
+ (self (caddr form))
+ (free-names (cadddr form))
+ (body (cddddr form)))
+ (transform-instance-variables
+ (class-instance-transforms
+ (name->class (identifier->symbol class-name)))
+ (compile/expression self environment)
+ free-names
+ (compile/expression
+ `(,(close-syntax 'BEGIN system-global-environment) ,@body)
+ environment)))))))
(define-syntax ==>
(syntax-rules ()
define-method
usual==>
with-instance-variables)
- (import (runtime syntactic-closures)
- compile/subexpression
- make-compiler-item
- select-caddr
- select-cddddr))
+ (import (runtime syntax)
+ compile/expression
+ make-compiler-item))
(define-package (edwin class-macros transform-instance-variables)
(files "xform")
|#
-(define-expander 'DEFINE-STRUCTURE system-global-environment
- (lambda (form environment closing-environment)
- (if (not (and (pair? (cdr form)) (list? (cddr form))))
- (error "Ill-formed special form:" form))
- (make-syntactic-closure closing-environment '()
- (let ((name-and-options (cadr form))
- (slot-descriptions (cddr form)))
+(define-syntax define-structure
+ (sc-macro-transformer
+ (lambda (form use-environment)
+ (syntax-check '(KEYWORD + DATUM) form)
+ (capture-syntactic-environment
+ (lambda (closing-environment)
(let ((structure
- (call-with-values
- (lambda ()
+ (receive (name options)
+ (let ((name-and-options (cadr form)))
(if (pair? name-and-options)
(values (car name-and-options) (cdr name-and-options))
(values name-and-options '())))
- (lambda (name options)
- (if (not (symbol? name))
- (error "Structure name must be a symbol:" name))
- (if (not (list? options))
- (error "Structure options must be a list:" options))
- (let ((context
- (make-parser-context name
- environment
- closing-environment)))
- (parse/options options
- (parse/slot-descriptions slot-descriptions)
- context))))))
+ (if (not (symbol? name))
+ (error "Structure name must be a symbol:" name))
+ (if (not (list? options))
+ (error "Structure options must be a list:" options))
+ (let ((context
+ (make-parser-context name
+ use-environment
+ closing-environment)))
+ (parse/options options
+ (parse/slot-descriptions (cddr form))
+ context)))))
`(BEGIN ,@(type-definitions structure)
,@(constructor-definitions structure)
,@(accessor-definitions structure)
,@(modifier-definitions structure)
,@(predicate-definitions structure)
- ,@(copier-definitions structure)))))))
+ ,@(copier-definitions structure))))))))
\f
;;;; Parse options
(and (identifier? object)
(there-exists? false-expression-names
(lambda (name)
- (identifier=? (parser-context/environment context)
+ (identifier=? (parser-context/use-environment context)
object
(parser-context/closing-environment context)
name))))))
(eq? (structure/physical-type structure) 'RECORD))
(define-record-type <parser-context>
- (make-parser-context name environment closing-environment)
+ (make-parser-context name use-environment closing-environment)
parser-context?
(name parser-context/name)
- (environment parser-context/environment)
+ (use-environment parser-context/use-environment)
(closing-environment parser-context/closing-environment))
(define-record-type <option>
(parser-context/closing-environment context)))
(define (close name context)
- (close-syntax name (parser-context/environment context)))
+ (close-syntax name (parser-context/use-environment context)))
(define (accessor-definitions structure)
(let ((context (structure/context structure)))
("dbgcmd" (runtime debugger-command-loop))
("dbgutl" (runtime debugger-utilities))
("debug" (runtime debugger))
- ("defstr" (runtime defstruct))
+ ("defstr" (runtime syntax defstruct))
("dospth" (runtime pathname dos))
("dragon4" (runtime number))
("emacs" (runtime emacs-interface))
("krypt" (runtime krypt))
("kryptdum" (runtime krypt))
("lambda" (runtime lambda-abstraction))
+ ("lambda-list" (runtime lambda-list))
("lambdx" (runtime alternative-lambda))
("list" (runtime list))
("load" (runtime load))
("mime-codec" (runtime mime-codec))
- ("mit-syntax" (runtime syntactic-closures))
+ ("mit-macros" (runtime mit-macros))
+ ("mit-syntax" (runtime syntax mit))
("msort" (runtime merge-sort))
("ntdir" (runtime directory))
("ntprm" (runtime os-primitives))
("structure-parser" (runtime structure-parser))
("symbol" (runtime symbol))
("syncproc" (runtime synchronous-subprocess))
- ("syntactic-closures" (runtime syntactic-closures))
- ("syntax-check" (runtime syntactic-closures))
- ("syntax-output" (runtime syntactic-closures))
- ("syntax-rules" (runtime syntactic-closures))
- ("syntax-transforms" (runtime syntactic-closures))
+ ("syntax" (runtime syntax top-level))
+ ("syntax-check" (runtime syntax check))
+ ("syntax-classify" (runtime syntax classify))
+ ("syntax-declaration" (runtime syntax declaration))
+ ("syntax-definitions" (runtime syntax definitions))
+ ("syntax-compile" (runtime syntax compile))
+ ("syntax-environment" (runtime syntax environment))
+ ("syntax-items" (runtime syntax items))
+ ("syntax-output" (runtime syntax output))
+ ("syntax-rules" (runtime syntax syntax-rules))
+ ("syntax-transforms" (runtime syntax transforms))
("sysclk" (runtime system-clock))
("sysmac" (runtime system-macros))
("system" (runtime system))
--- /dev/null
+#| -*-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 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.
+
+|#
+
+;;;; Lambda lists
+
+(declare (usual-integrations))
+\f
+(define (r4rs-lambda-list? object)
+ (let loop ((object object) (seen '()))
+ (or (null? object)
+ (if (identifier? object)
+ (not (memq object seen))
+ (and (pair? object)
+ (identifier? (car object))
+ (not (memq (car object) seen))
+ (loop (cdr object) (cons (car object) seen)))))))
+
+(define-guarantee r4rs-lambda-list "R4RS lambda list")
+
+(define (parse-r4rs-lambda-list bvl)
+ (let loop ((bvl* bvl) (required '()))
+ (cond ((and (pair? bvl*)
+ (identifier? (car bvl*)))
+ (loop (cdr bvl*)
+ (cons (car bvl*) required)))
+ ((null? bvl*)
+ (values (reverse! required) #f))
+ ((identifier? bvl*)
+ (values (reverse! required) bvl*))
+ (else
+ (error:not-r4rs-lambda-list bvl)))))
+
+(define (map-r4rs-lambda-list procedure bvl)
+ (let loop ((bvl* bvl))
+ (cond ((and (pair? bvl*)
+ (identifier? (car bvl*)))
+ (cons (procedure (car bvl*))
+ (loop (cdr bvl*))))
+ ((null? bvl*)
+ '())
+ ((identifier? bvl*)
+ (procedure bvl*))
+ (else
+ (error:not-r4rs-lambda-list bvl)))))
+\f
+(define (mit-lambda-list? object)
+ (letrec
+ ((parse-required
+ (lambda (object seen)
+ (or (null? object)
+ (if (identifier? object)
+ (not (memq object seen))
+ (and (pair? object)
+ (cond ((eq? (car object) lambda-tag:optional)
+ (and (pair? (cdr object))
+ (parse-parameter (cadr object) seen
+ (lambda (seen)
+ (parse-optional (cddr object) seen)))))
+ ((eq? (car object) lambda-tag:rest)
+ (parse-rest (cdr object) seen))
+ (else
+ (parse-parameter (car object) seen
+ (lambda (seen)
+ (parse-required (cdr object) seen))))))))))
+ (parse-optional
+ (lambda (object seen)
+ (or (null? object)
+ (if (identifier? object)
+ (not (memq object seen))
+ (and (pair? object)
+ (cond ((eq? (car object) lambda-tag:optional)
+ #f)
+ ((eq? (car object) lambda-tag:rest)
+ (parse-rest (cdr object) seen))
+ (else
+ (parse-parameter (car object) seen
+ (lambda (seen)
+ (parse-optional (cdr object) seen))))))))))
+ (parse-rest
+ (lambda (object seen)
+ (and (pair? object)
+ (parse-parameter (car object) seen
+ (lambda (seen)
+ seen
+ (null? (cdr object)))))))
+ (parse-parameter
+ (lambda (object seen k)
+ (if (identifier? object)
+ (and (not (memq object seen))
+ (k (cons object seen)))
+ (and (pair? object)
+ (identifier? (car object))
+ (list? (cdr object))
+ (not (memq (car object) seen))
+ (k (cons (car object) seen)))))))
+ (parse-required object '())))
+
+(define-guarantee mit-lambda-list "MIT/GNU Scheme lambda list")
+
+(define lambda-tag:optional (object-new-type (ucode-type constant) 3))
+(define lambda-tag:rest (object-new-type (ucode-type constant) 4))
+(define lambda-tag:key (object-new-type (ucode-type constant) 5))
+(define lambda-tag:aux (object-new-type (ucode-type constant) 8))
+\f
+(define (parse-mit-lambda-list lambda-list)
+ (let ((required (list '()))
+ (optional (list '())))
+ (define (parse-parameters cell pattern)
+ (let loop ((pattern pattern))
+ (cond ((null? pattern) (finish #f))
+ ((identifier? pattern) (finish pattern))
+ ((not (pair? pattern)) (bad-lambda-list pattern))
+ ((eq? (car pattern) lambda-tag:rest)
+ (if (and (pair? (cdr pattern)) (null? (cddr pattern)))
+ (cond ((identifier? (cadr pattern)) (finish (cadr pattern)))
+ ((and (pair? (cadr pattern))
+ (identifier? (caadr pattern)))
+ (finish (caadr pattern)))
+ (else (bad-lambda-list (cdr pattern))))
+ (bad-lambda-list (cdr pattern))))
+ ((eq? (car pattern) lambda-tag:optional)
+ (if (eq? cell required)
+ (parse-parameters optional (cdr pattern))
+ (bad-lambda-list pattern)))
+ ((identifier? (car pattern))
+ (set-car! cell (cons (car pattern) (car cell)))
+ (loop (cdr pattern)))
+ ((and (pair? (car pattern)) (identifier? (caar pattern)))
+ (set-car! cell (cons (caar pattern) (car cell)))
+ (loop (cdr pattern)))
+ (else (bad-lambda-list pattern)))))
+
+ (define (finish rest)
+ (let ((required (reverse! (car required)))
+ (optional (reverse! (car optional))))
+ (do ((parameters
+ (append required optional (if rest (list rest) '()))
+ (cdr parameters)))
+ ((null? parameters))
+ (if (memq (car parameters) (cdr parameters))
+ (error "lambda list has duplicate parameter:"
+ (car parameters)
+ (error-irritant/noise " in")
+ lambda-list)))
+ (values required optional rest)))
+
+ (define (bad-lambda-list pattern)
+ (error:not-mit-lambda-list pattern 'PARSE-MIT-LAMBDA-LIST))
+
+ (parse-parameters required lambda-list)))
+
+(define (map-mit-lambda-list procedure bvl)
+ (let loop ((bvl bvl))
+ (if (pair? bvl)
+ (cons (if (or (eq? (car bvl) lambda-tag:optional)
+ (eq? (car bvl) lambda-tag:rest))
+ (car bvl)
+ (procedure (car bvl)))
+ (loop (cdr bvl)))
+ (if (identifier? bvl)
+ (procedure bvl)
+ '()))))
\ No newline at end of file
("random" . (RUNTIME RANDOM-NUMBER))
("gentag" . (RUNTIME GENERIC-PROCEDURE))
("poplat" . (RUNTIME POPULATION))
- ("record" . (RUNTIME RECORD))
- ("syntax-transforms" . (RUNTIME SYNTACTIC-CLOSURES))))
+ ("record" . (RUNTIME RECORD))))
(files2
- '(("prop1d" . (RUNTIME 1D-PROPERTY))
+ '(("syntax-items" . (RUNTIME SYNTAX ITEMS))
+ ("syntax-transforms" . (RUNTIME SYNTAX TRANSFORMS))
+ ("prop1d" . (RUNTIME 1D-PROPERTY))
("events" . (RUNTIME EVENT-DISTRIBUTOR))
("gdatab" . (RUNTIME GLOBAL-DATABASE))
("gcfinal" . (RUNTIME GC-FINALIZER))
#t)
(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! #t)
(package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
- (package-initialize '(RUNTIME SYNTACTIC-CLOSURES)
- 'INITIALIZE-SYNTAX-TRANSFORMS!
- #t)
(load-files files2)
(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! #t)
(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! #t)
(RUNTIME UNSYNTAXER)
(RUNTIME PRETTY-PRINTER)
(RUNTIME EXTENDED-SCODE-EVAL)
+ (RUNTIME SYNTAX DEFINITIONS)
;; REP Loops
(RUNTIME INTERRUPT-HANDLER)
(RUNTIME GC-STATISTICS)
--- /dev/null
+#| -*-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 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.
+
+|#
+
+;;;; MIT/GNU Scheme macros
+
+(declare (usual-integrations))
+\f
+;;;; SRFI features
+
+(define-syntax :cond-expand
+ (er-macro-transformer
+ (lambda (form rename compare)
+ (let ((if-error (lambda () (ill-formed-syntax form))))
+ (if (syntax-match? '(+ (DATUM * FORM)) (cdr form))
+ (let loop ((clauses (cdr form)))
+ (let ((req (caar clauses))
+ (if-true (lambda () `(,(rename 'BEGIN) ,@(cdar clauses)))))
+ (if (and (identifier? req)
+ (compare (rename 'ELSE) req))
+ (if (null? (cdr clauses))
+ (if-true)
+ (if-error))
+ (let req-loop
+ ((req req)
+ (if-true if-true)
+ (if-false
+ (lambda ()
+ (if (null? (cdr clauses))
+ (if-error)
+ (loop (cdr clauses))))))
+ (cond ((identifier? req)
+ (if (any (lambda (feature)
+ (compare (rename feature) req))
+ supported-srfi-features)
+ (if-true)
+ (if-false)))
+ ((and (syntax-match? '(IDENTIFIER DATUM) req)
+ (compare (rename 'NOT) (car req)))
+ (req-loop (cadr req)
+ if-false
+ if-true))
+ ((and (syntax-match? '(IDENTIFIER * DATUM) req)
+ (compare (rename 'AND) (car req)))
+ (let and-loop ((reqs (cdr req)))
+ (if (pair? reqs)
+ (req-loop (car reqs)
+ (lambda () (and-loop (cdr reqs)))
+ if-false)
+ (if-true))))
+ ((and (syntax-match? '(IDENTIFIER * DATUM) req)
+ (compare (rename 'OR) (car req)))
+ (let or-loop ((reqs (cdr req)))
+ (if (pair? reqs)
+ (req-loop (car reqs)
+ if-true
+ (lambda () (or-loop (cdr reqs))))
+ (if-false))))
+ (else
+ (if-error)))))))
+ (if-error))))))
+
+(define supported-srfi-features
+ '(MIT
+ MIT/GNU
+ SRFI-0 ;COND-EXPAND
+ SRFI-1 ;List Library
+ SRFI-2 ;AND-LET*
+ SRFI-6 ;Basic String Ports
+ SRFI-8 ;RECEIVE
+ SRFI-9 ;DEFINE-RECORD-TYPE
+ SRFI-23 ;ERROR
+ SRFI-27 ;Sources of Random Bits
+ SRFI-30 ;Nested Multi-Line Comments (#| ... |#)
+ SRFI-62 ;S-expression comments
+ SRFI-69 ;Basic Hash Tables
+ ))
+\f
+(define-syntax :receive
+ (er-macro-transformer
+ (lambda (form rename compare)
+ compare ;ignore
+ (if (syntax-match? '(R4RS-BVL FORM + FORM) (cdr form))
+ `(,(rename 'CALL-WITH-VALUES)
+ (,(rename 'LAMBDA) () ,(caddr form))
+ (,(rename 'LAMBDA) ,(cadr form) ,@(cdddr form)))
+ (ill-formed-syntax form)))))
+
+(define-syntax :define-record-type
+ (er-macro-transformer
+ (lambda (form rename compare)
+ compare ;ignore
+ (if (syntax-match? '(IDENTIFIER
+ (IDENTIFIER * IDENTIFIER)
+ IDENTIFIER
+ * (IDENTIFIER IDENTIFIER ? IDENTIFIER))
+ (cdr form))
+ (let ((type (cadr form))
+ (constructor (car (caddr form)))
+ (c-tags (cdr (caddr form)))
+ (predicate (cadddr form))
+ (fields (cddddr form))
+ (de (rename 'DEFINE)))
+ `(,(rename 'BEGIN)
+ (,de ,type (,(rename 'MAKE-RECORD-TYPE) ',type ',(map car fields)))
+ (,de ,constructor (,(rename 'RECORD-CONSTRUCTOR) ,type ',c-tags))
+ (,de ,predicate (,(rename 'RECORD-PREDICATE) ,type))
+ ,@(append-map
+ (lambda (field)
+ (let ((name (car field)))
+ (cons `(,de ,(cadr field)
+ (,(rename 'RECORD-ACCESSOR) ,type ',name))
+ (if (pair? (cddr field))
+ `((,de ,(caddr field)
+ (,(rename 'RECORD-MODIFIER) ,type ',name)))
+ '()))))
+ fields)))
+ (ill-formed-syntax form)))))
+
+(define-syntax :define
+ (er-macro-transformer
+ (lambda (form rename compare)
+ compare ;ignore
+ (receive (name value) (parse-define-form form rename)
+ `(,keyword:define ,name ,value)))))
+
+(define (parse-define-form form rename)
+ (cond ((syntax-match? '((DATUM . MIT-BVL) + FORM) (cdr form))
+ (parse-define-form
+ `(,(car form) ,(caadr form)
+ ,(if (identifier? (caadr form))
+ `(,(rename 'NAMED-LAMBDA) ,@(cdr form))
+ `(,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form))))
+ rename))
+ ((syntax-match? '(IDENTIFIER ? EXPRESSION) (cdr form))
+ (values (cadr form)
+ (if (pair? (cddr form))
+ (caddr form)
+ (unassigned-expression))))
+ (else
+ (ill-formed-syntax form))))
+\f
+(define-syntax :let
+ (er-macro-transformer
+ (lambda (form rename compare)
+ compare ;ignore
+ (cond ((syntax-match? '(IDENTIFIER (* (IDENTIFIER ? EXPRESSION)) + FORM)
+ (cdr form))
+ (let ((name (cadr form))
+ (bindings (caddr form))
+ (body (cdddr form)))
+ `((,(rename 'LETREC)
+ ((,name (,(rename 'NAMED-LAMBDA) (,name ,@(map car bindings))
+ ,@body)))
+ ,name)
+ ,@(map (lambda (binding)
+ (if (pair? (cdr binding))
+ (cadr binding)
+ (unassigned-expression)))
+ bindings))))
+ ((syntax-match? '((* (IDENTIFIER ? EXPRESSION)) + FORM) (cdr form))
+ `(,keyword:let ,@(cdr (normalize-let-bindings form))))
+ (else
+ (ill-formed-syntax form))))))
+
+(define (normalize-let-bindings form)
+ `(,(car form) ,(map (lambda (binding)
+ (if (pair? (cdr binding))
+ binding
+ (list (car binding) (unassigned-expression))))
+ (cadr form))
+ ,@(cddr form)))
+
+(define-syntax :let*
+ (er-macro-transformer
+ (lambda (form rename compare)
+ rename compare ;ignore
+ (expand/let* form keyword:let))))
+
+(define-syntax :let*-syntax
+ (er-macro-transformer
+ (lambda (form rename compare)
+ rename compare ;ignore
+ (expand/let* form keyword:let-syntax))))
+
+(define (expand/let* form let-keyword)
+ (syntax-check '(KEYWORD (* DATUM) + FORM) form)
+ (let ((bindings (cadr form))
+ (body (cddr form)))
+ (if (pair? bindings)
+ (let loop ((bindings bindings))
+ (if (pair? (cdr bindings))
+ `(,let-keyword (,(car bindings)) ,(loop (cdr bindings)))
+ `(,let-keyword ,bindings ,@body)))
+ `(,let-keyword ,bindings ,@body))))
+
+(define-syntax :and
+ (er-macro-transformer
+ (lambda (form rename compare)
+ compare ;ignore
+ (syntax-check '(KEYWORD * EXPRESSION) form)
+ (let ((operands (cdr form)))
+ (if (pair? operands)
+ (let ((if-keyword (rename 'IF)))
+ (let loop ((operands operands))
+ (if (pair? (cdr operands))
+ `(,if-keyword ,(car operands)
+ ,(loop (cdr operands))
+ #F)
+ (car operands))))
+ `#T)))))
+\f
+(define-syntax :case
+ (er-macro-transformer
+ (lambda (form rename compare)
+ (syntax-check '(KEYWORD EXPRESSION + (DATUM * EXPRESSION)) form)
+ (letrec
+ ((process-clause
+ (lambda (clause rest)
+ (cond ((null? (car clause))
+ (process-rest rest))
+ ((and (identifier? (car clause))
+ (compare (rename 'ELSE) (car clause))
+ (null? rest))
+ `(,(rename 'BEGIN) ,@(cdr clause)))
+ ((list? (car clause))
+ `(,(rename 'IF) ,(process-predicate (car clause))
+ (,(rename 'BEGIN) ,@(cdr clause))
+ ,(process-rest rest)))
+ (else
+ (syntax-error "Ill-formed clause:" clause)))))
+ (process-rest
+ (lambda (rest)
+ (if (pair? rest)
+ (process-clause (car rest) (cdr rest))
+ (unspecific-expression))))
+ (process-predicate
+ (lambda (items)
+ ;; Optimize predicate for speed in compiled code.
+ (cond ((null? (cdr items))
+ (single-test (car items)))
+ ((null? (cddr items))
+ `(,(rename 'OR) ,(single-test (car items))
+ ,(single-test (cadr items))))
+ ((null? (cdddr items))
+ `(,(rename 'OR) ,(single-test (car items))
+ ,(single-test (cadr items))
+ ,(single-test (caddr items))))
+ ((null? (cddddr items))
+ `(,(rename 'OR) ,(single-test (car items))
+ ,(single-test (cadr items))
+ ,(single-test (caddr items))
+ ,(single-test (cadddr items))))
+ (else
+ `(,(rename
+ (if (for-all? items eq-testable?) 'MEMQ 'MEMV))
+ ,(rename 'TEMP)
+ ',items)))))
+ (single-test
+ (lambda (item)
+ `(,(rename (if (eq-testable? item) 'EQ? 'EQV?))
+ ,(rename 'TEMP)
+ ',item)))
+ (eq-testable?
+ (lambda (item)
+ (or (symbol? item)
+ (boolean? item)
+ ;; remainder are implementation dependent:
+ (char? item)
+ (fix:fixnum? item)))))
+ `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form)))
+ ,(process-clause (caddr form)
+ (cdddr form)))))))
+\f
+(define-syntax :cond
+ (er-macro-transformer
+ (lambda (form rename compare)
+ (let ((clauses (cdr form)))
+ (if (not (pair? clauses))
+ (syntax-error "Form must have at least one clause:" form))
+ (let loop ((clause (car clauses)) (rest (cdr clauses)))
+ (expand/cond-clause clause rename compare (null? rest)
+ (if (pair? rest)
+ (loop (car rest) (cdr rest))
+ (unspecific-expression))))))))
+
+(define-syntax :do
+ (er-macro-transformer
+ (lambda (form rename compare)
+ (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION ? EXPRESSION))
+ (+ FORM)
+ * FORM)
+ form)
+ (let ((bindings (cadr form))
+ (r-loop (rename 'DO-LOOP)))
+ `(,(rename 'LET)
+ ,r-loop
+ ,(map (lambda (binding)
+ (list (car binding) (cadr binding)))
+ bindings)
+ ,(expand/cond-clause (caddr form) rename compare #f
+ `(,(rename 'BEGIN)
+ ,@(cdddr form)
+ (,r-loop ,@(map (lambda (binding)
+ (if (pair? (cddr binding))
+ (caddr binding)
+ (car binding)))
+ bindings)))))))))
+
+(define (expand/cond-clause clause rename compare else-allowed? alternative)
+ (if (not (and (pair? clause) (list? (cdr clause))))
+ (syntax-error "Ill-formed clause:" clause))
+ (cond ((and (identifier? (car clause))
+ (compare (rename 'ELSE) (car clause)))
+ (if (not else-allowed?)
+ (syntax-error "Misplaced ELSE clause:" clause))
+ (if (or (not (pair? (cdr clause)))
+ (and (identifier? (cadr clause))
+ (compare (rename '=>) (cadr clause))))
+ (syntax-error "Ill-formed ELSE clause:" clause))
+ `(,(rename 'BEGIN) ,@(cdr clause)))
+ ((not (pair? (cdr clause)))
+ (let ((r-temp (rename 'TEMP)))
+ `(,(rename 'LET) ((,r-temp ,(car clause)))
+ (,(rename 'IF) ,r-temp ,r-temp ,alternative))))
+ ((and (identifier? (cadr clause))
+ (compare (rename '=>) (cadr clause)))
+ (if (not (and (pair? (cddr clause))
+ (null? (cdddr clause))))
+ (syntax-error "Ill-formed => clause:" clause))
+ (let ((r-temp (rename 'TEMP)))
+ `(,(rename 'LET) ((,r-temp ,(car clause)))
+ (,(rename 'IF) ,r-temp
+ (,(caddr clause) ,r-temp)
+ ,alternative))))
+ (else
+ `(,(rename 'IF) ,(car clause)
+ (,(rename 'BEGIN) ,@(cdr clause))
+ ,alternative))))
+\f
+(define-syntax :quasiquote
+ (er-macro-transformer
+ (lambda (form rename compare)
+
+ (define (descend-quasiquote x level return)
+ (cond ((pair? x) (descend-quasiquote-pair x level return))
+ ((vector? x) (descend-quasiquote-vector x level return))
+ (else (return 'QUOTE x))))
+
+ (define (descend-quasiquote-pair x level return)
+ (cond ((not (and (pair? x)
+ (identifier? (car x))
+ (pair? (cdr x))
+ (null? (cddr x))))
+ (descend-quasiquote-pair* x level return))
+ ((compare (rename 'QUASIQUOTE) (car x))
+ (descend-quasiquote-pair* x (+ level 1) return))
+ ((compare (rename 'UNQUOTE) (car x))
+ (if (zero? level)
+ (return 'UNQUOTE (cadr x))
+ (descend-quasiquote-pair* x (- level 1) return)))
+ ((compare (rename 'UNQUOTE-SPLICING) (car x))
+ (if (zero? level)
+ (return 'UNQUOTE-SPLICING (cadr x))
+ (descend-quasiquote-pair* x (- level 1) return)))
+ (else
+ (descend-quasiquote-pair* x level return))))
+
+ (define (descend-quasiquote-pair* x level return)
+ (descend-quasiquote (car x) level
+ (lambda (car-mode car-arg)
+ (descend-quasiquote (cdr x) level
+ (lambda (cdr-mode cdr-arg)
+ (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE))
+ (return 'QUOTE x))
+ ((eq? car-mode 'UNQUOTE-SPLICING)
+ (if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg))
+ (return 'UNQUOTE car-arg)
+ (return 'APPEND
+ (list car-arg
+ (finalize-quasiquote cdr-mode
+ cdr-arg)))))
+ ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg))
+ (return 'LIST
+ (cons (finalize-quasiquote car-mode car-arg)
+ (map (lambda (element)
+ (finalize-quasiquote 'QUOTE
+ element))
+ cdr-arg))))
+ ((eq? cdr-mode 'LIST)
+ (return 'LIST
+ (cons (finalize-quasiquote car-mode car-arg)
+ cdr-arg)))
+ (else
+ (return
+ 'CONS
+ (list (finalize-quasiquote car-mode car-arg)
+ (finalize-quasiquote cdr-mode cdr-arg))))))))))
+
+ (define (descend-quasiquote-vector x level return)
+ (descend-quasiquote (vector->list x) level
+ (lambda (mode arg)
+ (case mode
+ ((QUOTE) (return 'QUOTE x))
+ ((LIST) (return 'VECTOR arg))
+ (else
+ (return 'LIST->VECTOR
+ (list (finalize-quasiquote mode arg))))))))
+
+ (define (finalize-quasiquote mode arg)
+ (case mode
+ ((QUOTE) `(,(rename 'QUOTE) ,arg))
+ ((UNQUOTE) arg)
+ ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context:" arg))
+ (else `(,(rename mode) ,@arg))))
+
+ (syntax-check '(KEYWORD EXPRESSION) form)
+ (descend-quasiquote (cadr form) 0 finalize-quasiquote))))
+\f
+;;;; SRFI 2: AND-LET*
+
+;;; The SRFI document is a little unclear about the semantics, imposes
+;;; the weird restriction that variables may be duplicated (citing
+;;; LET*'s similar restriction, which doesn't actually exist), and the
+;;; reference implementation is highly non-standard and hard to
+;;; follow. This passes all of the tests except for the one that
+;;; detects duplicate bound variables, though.
+
+(define-syntax :and-let*
+ (er-macro-transformer
+ (lambda (form rename compare)
+ compare
+ (let ((%and (rename 'AND))
+ (%let (rename 'LET))
+ (%begin (rename 'BEGIN)))
+ (cond ((syntax-match? '(() * FORM) (cdr form))
+ `(,%begin #T ,@(cddr form)))
+ ((syntax-match? '((* DATUM) * FORM) (cdr form))
+ (let ((clauses (cadr form))
+ (body (cddr form)))
+ (define (expand clause recur)
+ (cond ((syntax-match? 'IDENTIFIER clause)
+ (recur clause))
+ ((syntax-match? '(EXPRESSION) clause)
+ (recur (car clause)))
+ ((syntax-match? '(IDENTIFIER EXPRESSION) clause)
+ (let ((tail (recur (car clause))))
+ (and tail `(,%let (,clause) ,tail))))
+ (else #f)))
+ (define (recur clauses make-body)
+ (expand (car clauses)
+ (let ((clauses (cdr clauses)))
+ (if (null? clauses)
+ make-body
+ (lambda (conjunct)
+ `(,%and ,conjunct
+ ,(recur clauses make-body)))))))
+ (or (recur clauses
+ (if (null? body)
+ (lambda (conjunct) conjunct)
+ (lambda (conjunct)
+ `(,%and ,conjunct (,%begin ,@body)))))
+ (ill-formed-syntax form))))
+ (else
+ (ill-formed-syntax form)))))))
+
+(define-syntax :access
+ (er-macro-transformer
+ (lambda (form rename compare)
+ rename compare ;ignore
+ (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
+ `(,keyword:access ,@(cdr form)))
+ ((syntax-match? '(IDENTIFIER IDENTIFIER + FORM) (cdr form))
+ `(,keyword:access ,(cadr form) (,(car form) ,@(cddr form))))
+ (else
+ (ill-formed-syntax form))))))
+
+(define-syntax :cons-stream
+ (er-macro-transformer
+ (lambda (form rename compare)
+ compare ;ignore
+ (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form)
+ `(,(rename 'CONS) ,(cadr form)
+ (,(rename 'DELAY) ,(caddr form))))))
+\f
+(define-syntax :define-integrable
+ (er-macro-transformer
+ (lambda (form rename compare)
+ compare ;ignore
+ (let ((r-begin (rename 'BEGIN))
+ (r-declare (rename 'DECLARE))
+ (r-define (rename 'DEFINE)))
+ (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
+ `(,r-begin
+ (,r-declare (INTEGRATE ,(cadr form)))
+ (,r-define ,@(cdr form))))
+ ((syntax-match? '((IDENTIFIER * IDENTIFIER) + FORM) (cdr form))
+ `(,r-begin
+ (,r-declare (INTEGRATE-OPERATOR ,(caadr form)))
+ (,r-define ,(cadr form)
+ (,r-declare (INTEGRATE ,@(cdadr form)))
+ ,@(cddr form))))
+ (else
+ (ill-formed-syntax form)))))))
+
+(define-syntax :fluid-let
+ (er-macro-transformer
+ (lambda (form rename compare)
+ compare
+ (syntax-check '(KEYWORD (* (FORM ? EXPRESSION)) + FORM) form)
+ (let ((names (map car (cadr form)))
+ (r-let (rename 'LET))
+ (r-lambda (rename 'LAMBDA))
+ (r-set! (rename 'SET!)))
+ (let ((out-temps
+ (map (lambda (name)
+ name
+ (make-synthetic-identifier 'OUT-TEMP))
+ names))
+ (in-temps
+ (map (lambda (name)
+ name
+ (make-synthetic-identifier 'IN-TEMP))
+ names))
+ (swap
+ (lambda (tos names froms)
+ `(,r-lambda ()
+ ,@(map (lambda (to name from)
+ `(,r-set! ,to
+ (,r-set! ,name
+ (,r-set! ,from))))
+ tos
+ names
+ froms)
+ ,(unspecific-expression)))))
+ `(,r-let (,@(map cons in-temps (map cdr (cadr form)))
+ ,@(map list out-temps))
+ (,(rename 'SHALLOW-FLUID-BIND)
+ ,(swap out-temps names in-temps)
+ (,r-lambda () ,@(cddr form))
+ ,(swap in-temps names out-temps))))))))
+
+(define (unspecific-expression)
+ `(,keyword:unspecific))
+
+(define (unassigned-expression)
+ `(,keyword:unassigned))
\ No newline at end of file
\f
;;;; Macro transformers
-(define (define-er-macro-transformer keyword environment transformer)
- (syntactic-environment/define environment keyword
- (er-macro-transformer->expander transformer environment)))
-
-(define (transformer-keyword transformer->expander-name transformer->expander)
- (lambda (form environment definition-environment history)
+(define (transformer-keyword name transformer->expander)
+ (lambda (form environment definition-environment)
definition-environment ;ignore
- (syntax-check '(KEYWORD EXPRESSION) form history)
- (expression->keyword-value-item (classify/subexpression (cadr form)
- environment
- history
- select-cadr)
- environment
- history
- transformer->expander-name
- transformer->expander)))
-
-(define (expression->keyword-value-item item environment history
- transformer->expander-name
- transformer->expander)
- (make-keyword-value-item
- history
- (transformer->expander
- (transformer-eval (compile-item/expression item)
- (syntactic-environment->environment environment))
- environment)
- (make-expression-item history
- (lambda ()
- (output/combination
- (output/access-reference transformer->expander-name
- system-global-environment)
- (list (compile-item/expression item)
- (output/the-environment)))))))
+ (syntax-check '(KEYWORD EXPRESSION) form)
+ (let ((item (classify/expression (cadr form) environment)))
+ (make-keyword-value-item
+ (transformer->expander (transformer-eval (compile-item/expression item)
+ environment)
+ environment)
+ (make-expression-item
+ (lambda ()
+ (output/combination (output/runtime-reference name)
+ (list (compile-item/expression item)
+ (output/the-environment)))))))))
-(define-classifier 'SC-MACRO-TRANSFORMER system-global-environment
+(define classifier:sc-macro-transformer
;; "Syntactic Closures" transformer
(transformer-keyword 'SC-MACRO-TRANSFORMER->EXPANDER
sc-macro-transformer->expander))
-(define-classifier 'RSC-MACRO-TRANSFORMER system-global-environment
+(define classifier:rsc-macro-transformer
;; "Reversed Syntactic Closures" transformer
(transformer-keyword 'RSC-MACRO-TRANSFORMER->EXPANDER
rsc-macro-transformer->expander))
-(define-classifier 'ER-MACRO-TRANSFORMER system-global-environment
+(define classifier:er-macro-transformer
;; "Explicit Renaming" transformer
(transformer-keyword 'ER-MACRO-TRANSFORMER->EXPANDER
er-macro-transformer->expander))
-(define-classifier 'NON-HYGIENIC-MACRO-TRANSFORMER system-global-environment
+(define classifier:non-hygienic-macro-transformer
(transformer-keyword 'NON-HYGIENIC-MACRO-TRANSFORMER->EXPANDER
non-hygienic-macro-transformer->expander))
\f
;;;; Core primitives
-(define-compiler 'LAMBDA system-global-environment
- (lambda (form environment history)
- (syntax-check '(KEYWORD MIT-BVL + FORM) form history)
- (call-with-values
- (lambda ()
- (compile/lambda (cadr form)
- (cddr form)
- select-cddr
- environment
- history))
- (lambda (bvl body)
- (output/lambda bvl body)))))
+(define (compiler:lambda form environment)
+ (syntax-check '(KEYWORD MIT-BVL + FORM) form)
+ (receive (bvl body)
+ (compile/lambda (cadr form) (cddr form) environment)
+ (output/lambda bvl body)))
-(define-compiler 'NAMED-LAMBDA system-global-environment
- (lambda (form environment history)
- (syntax-check '(KEYWORD (IDENTIFIER . MIT-BVL) + FORM) form history)
- (call-with-values
- (lambda ()
- (compile/lambda (cdadr form)
- (cddr form)
- select-cddr
- environment
- history))
- (lambda (bvl body)
- (output/named-lambda (identifier->symbol (caadr form)) bvl body)))))
+(define (compiler:named-lambda form environment)
+ (syntax-check '(KEYWORD (IDENTIFIER . MIT-BVL) + FORM) form)
+ (receive (bvl body)
+ (compile/lambda (cdadr form) (cddr form) environment)
+ (output/named-lambda (identifier->symbol (caadr form)) bvl body)))
-(define (compile/lambda bvl body select-body environment history)
+(define (compile/lambda bvl body environment)
(let ((environment (make-internal-syntactic-environment environment)))
;; Force order -- bind names before classifying body.
(let ((bvl
(compile-body-item
(classify/body body
environment
- environment
- history
- select-body))))))
-
-(define (map-mit-lambda-list procedure bvl)
- (let loop ((bvl bvl))
- (if (pair? bvl)
- (cons (if (or (eq? (car bvl) lambda-optional-tag)
- (eq? (car bvl) lambda-rest-tag))
- (car bvl)
- (procedure (car bvl)))
- (loop (cdr bvl)))
- (if (identifier? bvl)
- (procedure bvl)
- '()))))
-\f
-(define-classifier 'BEGIN system-global-environment
- (lambda (form environment definition-environment history)
- (syntax-check '(KEYWORD * FORM) form history)
- (make-body-item history
- (classify/subforms (cdr form)
- environment
- definition-environment
- history
- select-cdr))))
-
-(define-compiler 'IF system-global-environment
- (lambda (form environment history)
- (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION)
- form history)
- (output/conditional
- (compile/subexpression (cadr form) environment history select-cadr)
- (compile/subexpression (caddr form) environment history select-caddr)
- (if (pair? (cdddr form))
- (compile/subexpression (cadddr form)
- environment
- history
- select-cadddr)
- (output/unspecific)))))
-
-(define-compiler 'QUOTE system-global-environment
- (lambda (form environment history)
- environment ;ignore
- (syntax-check '(KEYWORD DATUM) form history)
- (output/constant (strip-syntactic-closures (cadr form)))))
-
-(define-compiler 'SET! system-global-environment
- (lambda (form environment history)
- (syntax-check '(KEYWORD FORM ? EXPRESSION) form history)
- (call-with-values
- (lambda ()
- (classify/sublocation (cadr form) environment history select-cadr))
- (lambda (name environment-item)
- (let ((value
- (if (pair? (cddr form))
- (compile/subexpression (caddr form)
- environment
- history
- select-caddr)
- (output/unassigned))))
- (if environment-item
- (output/access-assignment
- name
- (compile-item/expression environment-item)
- value)
- (output/assignment name value)))))))
-
-(define (classify/sublocation form environment history selector)
- (classify/location form
- environment
- (history/add-subproblem form
- environment
- history
- selector)))
-
-(define (classify/location form environment history)
- (let ((item (classify/expression form environment history)))
+ environment))))))
+
+(define (classifier:begin form environment definition-environment)
+ (syntax-check '(KEYWORD * FORM) form)
+ (classify/body (cdr form) environment definition-environment))
+
+(define (compiler:if form environment)
+ (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION) form)
+ (output/conditional
+ (compile/expression (cadr form) environment)
+ (compile/expression (caddr form) environment)
+ (if (pair? (cdddr form))
+ (compile/expression (cadddr form) environment)
+ (output/unspecific))))
+
+(define (compiler:quote form environment)
+ environment ;ignore
+ (syntax-check '(KEYWORD DATUM) form)
+ (output/constant (strip-syntactic-closures (cadr form))))
+
+(define (compiler:set! form environment)
+ (syntax-check '(KEYWORD FORM ? EXPRESSION) form)
+ (receive (name environment-item)
+ (classify/location (cadr form) environment)
+ (let ((value
+ (if (pair? (cddr form))
+ (compile/expression (caddr form) environment)
+ (output/unassigned))))
+ (if environment-item
+ (output/access-assignment
+ name
+ (compile-item/expression environment-item)
+ value)
+ (output/assignment name value)))))
+
+(define (classify/location form environment)
+ (let ((item (classify/expression form environment)))
(cond ((variable-item? item)
(values (variable-item/name item) #f))
((access-item? item)
(values (access-item/name item) (access-item/environment item)))
(else
- (syntax-error history "Variable required in this context:" form)))))
+ (syntax-error "Variable required in this context:" form)))))
-(define-compiler 'DELAY system-global-environment
- (lambda (form environment history)
- (syntax-check '(KEYWORD EXPRESSION) form history)
- (output/delay
- (compile/subexpression (cadr form)
- environment
- history
- select-cadr))))
+(define (compiler:delay form environment)
+ (syntax-check '(KEYWORD EXPRESSION) form)
+ (output/delay (compile/expression (cadr form) environment)))
\f
;;;; Definitions
-(define-er-macro-transformer 'DEFINE system-global-environment
- (let ((keyword
- (classifier->keyword
- (lambda (form environment definition-environment history)
- (classify/define form environment definition-environment history
- variable-binding-theory)))))
- (lambda (form rename compare)
- compare ;ignore
- (parse-define-form form rename
- (lambda (name value)
- `(,keyword ,name ,value))))))
-
-(define (parse-define-form form rename receiver)
- (cond ((syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
- (parse-define-form
- `(,(car form) ,(caadr form)
- (,(rename 'NAMED-LAMBDA) ,@(cdr form)))
- rename
- receiver))
- ((syntax-match? '((DATUM . MIT-BVL) + FORM) (cdr form))
- (parse-define-form
- `(,(car form) ,(caadr form)
- (,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form)))
- rename
- receiver))
- ((syntax-match? '(IDENTIFIER) (cdr form))
- (receiver (cadr form) (unassigned-expression)))
- ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
- (receiver (cadr form) (caddr form)))
- (else
- (ill-formed-syntax form))))
+(define keyword:define
+ (classifier->keyword
+ (lambda (form environment definition-environment)
+ (classify/define form environment definition-environment
+ variable-binding-theory))))
-(define-classifier 'DEFINE-SYNTAX system-global-environment
- (lambda (form environment definition-environment history)
- (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form history)
- (classify/define form environment definition-environment history
- syntactic-binding-theory)))
+(define (classifier:define-syntax form environment definition-environment)
+ (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form)
+ (classify/define form environment definition-environment
+ syntactic-binding-theory))
-(define (classify/define form environment definition-environment history
+(define (classify/define form environment definition-environment
binding-theory)
(if (not (syntactic-environment/top-level? definition-environment))
(syntactic-environment/define definition-environment
(cadr form)
- (make-reserved-name-item history)))
+ (make-reserved-name-item)))
(binding-theory definition-environment
(cadr form)
- (classify/subexpression (caddr form)
- environment
- history
- select-caddr)
- history))
+ (classify/expression (caddr form) environment)))
-(define (syntactic-binding-theory environment name item history)
+(define (syntactic-binding-theory environment name item)
(if (not (keyword-item? item))
- (let ((history (item/history item)))
- (syntax-error history "Syntactic binding value must be a keyword:"
- (history/original-form history))))
- (syntactic-environment/define environment
- name
- (item/new-history item #f))
+ (syntax-error "Syntactic binding value must be a keyword:" name))
+ (syntactic-environment/define environment name item)
;; User-defined macros at top level are preserved in the output.
(if (and (keyword-value-item? item)
(syntactic-environment/top-level? environment))
- (make-binding-item history
- (rename-top-level-identifier name)
- item)
- (make-null-binding-item history)))
+ (make-binding-item (rename-top-level-identifier name) item)
+ (make-null-binding-item)))
-(define (variable-binding-theory environment name item history)
+(define (variable-binding-theory environment name item)
(if (keyword-item? item)
- (let ((history (item/history item)))
- (syntax-error history "Binding value may not be a keyword:"
- (history/original-form history))))
- (make-binding-item history (bind-variable! environment name) item))
-\f
-;;;; SRFI features
-
-(define-er-macro-transformer 'COND-EXPAND system-global-environment
- (lambda (form rename compare)
- (let ((if-error (lambda () (ill-formed-syntax form))))
- (if (syntax-match? '(+ (DATUM * FORM)) (cdr form))
- (let loop ((clauses (cdr form)))
- (let ((req (caar clauses))
- (if-true (lambda () `(,(rename 'BEGIN) ,@(cdar clauses)))))
- (if (and (identifier? req)
- (compare (rename 'ELSE) req))
- (if (null? (cdr clauses))
- (if-true)
- (if-error))
- (let req-loop
- ((req req)
- (if-true if-true)
- (if-false
- (lambda ()
- (if (null? (cdr clauses))
- (if-error)
- (loop (cdr clauses))))))
- (cond ((identifier? req)
- (if (there-exists? supported-srfi-features
- (lambda (feature)
- (compare (rename feature) req)))
- (if-true)
- (if-false)))
- ((and (syntax-match? '(IDENTIFIER DATUM) req)
- (compare (rename 'NOT) (car req)))
- (req-loop (cadr req)
- if-false
- if-true))
- ((and (syntax-match? '(IDENTIFIER * DATUM) req)
- (compare (rename 'AND) (car req)))
- (let and-loop ((reqs (cdr req)))
- (if (pair? reqs)
- (req-loop (car reqs)
- (lambda () (and-loop (cdr reqs)))
- if-false)
- (if-true))))
- ((and (syntax-match? '(IDENTIFIER * DATUM) req)
- (compare (rename 'OR) (car req)))
- (let or-loop ((reqs (cdr req)))
- (if (pair? reqs)
- (req-loop (car reqs)
- if-true
- (lambda () (or-loop (cdr reqs))))
- (if-false))))
- (else
- (if-error)))))))
- (if-error)))))
-
-(define supported-srfi-features
- '(MIT
- MIT/GNU
- SRFI-0 ;COND-EXPAND
- SRFI-1 ;List Library
- SRFI-2 ;AND-LET*
- SRFI-6 ;Basic String Ports
- SRFI-8 ;RECEIVE
- SRFI-9 ;DEFINE-RECORD-TYPE
- SRFI-23 ;ERROR
- SRFI-27 ;Sources of Random Bits
- SRFI-30 ;Nested Multi-Line Comments (#| ... |#)
- SRFI-62 ;S-expression comments
- SRFI-69)) ;Basic Hash Tables
-\f
-(define-er-macro-transformer 'RECEIVE system-global-environment
- (lambda (form rename compare)
- compare ;ignore
- (if (syntax-match? '(R4RS-BVL FORM + FORM) (cdr form))
- `(,(rename 'CALL-WITH-VALUES)
- (,(rename 'LAMBDA) () ,(caddr form))
- (,(rename 'LAMBDA) ,(cadr form) ,@(cdddr form)))
- (ill-formed-syntax form))))
-
-(define-er-macro-transformer 'DEFINE-RECORD-TYPE system-global-environment
- (lambda (form rename compare)
- compare ;ignore
- (if (syntax-match? '(IDENTIFIER
- (IDENTIFIER * IDENTIFIER)
- IDENTIFIER
- * (IDENTIFIER IDENTIFIER ? IDENTIFIER))
- (cdr form))
- (let ((type (cadr form))
- (constructor (car (caddr form)))
- (c-tags (cdr (caddr form)))
- (predicate (cadddr form))
- (fields (cddddr form))
- (de (rename 'DEFINE)))
- `(,(rename 'BEGIN)
- (,de ,type (,(rename 'MAKE-RECORD-TYPE) ',type ',(map car fields)))
- (,de ,constructor (,(rename 'RECORD-CONSTRUCTOR) ,type ',c-tags))
- (,de ,predicate (,(rename 'RECORD-PREDICATE) ,type))
- ,@(append-map
- (lambda (field)
- (let ((name (car field)))
- (cons `(,de ,(cadr field)
- (,(rename 'RECORD-ACCESSOR) ,type ',name))
- (if (pair? (cddr field))
- `((,de ,(caddr field)
- (,(rename 'RECORD-MODIFIER) ,type ',name)))
- '()))))
- fields)))
- (ill-formed-syntax form))))
+ (syntax-error "Binding value may not be a keyword:" name))
+ (make-binding-item (bind-variable! environment name) item))
\f
;;;; LET-like
-(define-er-macro-transformer 'LET system-global-environment
- (let ((keyword
- (classifier->keyword
- (lambda (form environment definition-environment history)
- definition-environment
- (let* ((binding-environment
- (make-internal-syntactic-environment environment))
- (body-environment
- (make-internal-syntactic-environment binding-environment)))
- (classify/let-like form
- environment
- binding-environment
- body-environment
- history
- variable-binding-theory
- output/let))))))
- (lambda (form rename compare)
- compare ;ignore
- (cond ((syntax-match? '(IDENTIFIER (* (IDENTIFIER ? EXPRESSION)) + FORM)
- (cdr form))
- (let ((name (cadr form))
- (bindings (caddr form))
- (body (cdddr form)))
- `((,(rename 'LETREC)
- ((,name (,(rename 'NAMED-LAMBDA) (,name ,@(map car bindings))
- ,@body)))
- ,name)
- ,@(map (lambda (binding)
- (if (pair? (cdr binding))
- (cadr binding)
- (unassigned-expression)))
- bindings))))
- ((syntax-match? '((* (IDENTIFIER ? EXPRESSION)) + FORM) (cdr form))
- `(,keyword ,@(cdr (normalize-let-bindings form))))
- (else
- (ill-formed-syntax form))))))
-
-(define-er-macro-transformer 'LET* system-global-environment
- (lambda (form rename compare)
- compare ;ignore
- (expand/let* form rename 'LET)))
-
-(define-classifier 'LETREC system-global-environment
- (lambda (form environment definition-environment history)
- definition-environment
- (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form history)
- (let* ((binding-environment
- (make-internal-syntactic-environment environment))
- (body-environment
- (make-internal-syntactic-environment binding-environment)))
- (for-each (let ((item (make-reserved-name-item history)))
- (lambda (binding)
- (syntactic-environment/define binding-environment
- (car binding)
- item)))
- (cadr form))
- (classify/let-like form
- binding-environment
- binding-environment
- body-environment
- history
- variable-binding-theory
- output/letrec))))
-
-(define (normalize-let-bindings form)
- `(,(car form) ,(map (lambda (binding)
- (if (pair? (cdr binding))
- binding
- (list (car binding) (unassigned-expression))))
- (cadr form))
- ,@(cddr form)))
+(define keyword:let
+ (classifier->keyword
+ (lambda (form environment definition-environment)
+ definition-environment
+ (let* ((binding-environment
+ (make-internal-syntactic-environment environment))
+ (body-environment
+ (make-internal-syntactic-environment binding-environment)))
+ (classify/let-like form
+ environment
+ binding-environment
+ body-environment
+ variable-binding-theory
+ output/let)))))
+
+(define (classifier:letrec form environment definition-environment)
+ definition-environment
+ (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form)
+ (let* ((binding-environment
+ (make-internal-syntactic-environment environment))
+ (body-environment
+ (make-internal-syntactic-environment binding-environment)))
+ (for-each (let ((item (make-reserved-name-item)))
+ (lambda (binding)
+ (syntactic-environment/define binding-environment
+ (car binding)
+ item)))
+ (cadr form))
+ (classify/let-like form
+ binding-environment
+ binding-environment
+ body-environment
+ variable-binding-theory
+ output/letrec)))
\f
-(define-classifier 'LET-SYNTAX system-global-environment
- (lambda (form environment definition-environment history)
- definition-environment
- (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form history)
- (let* ((binding-environment
- (make-internal-syntactic-environment environment))
- (body-environment
- (make-internal-syntactic-environment binding-environment)))
- (classify/let-like form
- environment
- binding-environment
- body-environment
- history
- syntactic-binding-theory
- output/let))))
-
-(define-er-macro-transformer 'LET*-SYNTAX system-global-environment
- (lambda (form rename compare)
- compare ;ignore
- (expand/let* form rename 'LET-SYNTAX)))
+(define (classifier:let-syntax form environment definition-environment)
+ definition-environment
+ (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form)
+ (let* ((binding-environment
+ (make-internal-syntactic-environment environment))
+ (body-environment
+ (make-internal-syntactic-environment binding-environment)))
+ (classify/let-like form
+ environment
+ binding-environment
+ body-environment
+ syntactic-binding-theory
+ output/let)))
+
+(define keyword:let-syntax
+ (classifier->keyword classifier:let-syntax))
+
+(define (classifier:letrec-syntax form environment definition-environment)
+ definition-environment
+ (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form)
+ (let* ((binding-environment
+ (make-internal-syntactic-environment environment))
+ (body-environment
+ (make-internal-syntactic-environment binding-environment)))
+ (for-each (let ((item (make-reserved-name-item)))
+ (lambda (binding)
+ (syntactic-environment/define binding-environment
+ (car binding)
+ item)))
+ (cadr form))
+ (classify/let-like form
+ binding-environment
+ binding-environment
+ body-environment
+ syntactic-binding-theory
+ output/letrec)))
-(define-classifier 'LETREC-SYNTAX system-global-environment
- (lambda (form environment definition-environment history)
- definition-environment
- (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form history)
- (let* ((binding-environment
- (make-internal-syntactic-environment environment))
- (body-environment
- (make-internal-syntactic-environment binding-environment)))
- (for-each (let ((item (make-reserved-name-item history)))
- (lambda (binding)
- (syntactic-environment/define binding-environment
- (car binding)
- item)))
- (cadr form))
- (classify/let-like form
- binding-environment
- binding-environment
- body-environment
- history
- syntactic-binding-theory
- output/letrec))))
-\f
(define (classify/let-like form
value-environment
binding-environment
body-environment
- history
binding-theory
output/let)
;; Classify right-hand sides first, in order to catch references to
;; reserved names. Then bind names prior to classifying body.
(let* ((bindings
- (delete-matching-items!
- (map (lambda (binding item)
- (binding-theory binding-environment
- (car binding)
- item
- history))
- (cadr form)
- (select-map (lambda (binding selector)
- (classify/subexpression (cadr binding)
- value-environment
- history
- (selector/add-cadr
- selector)))
- (cadr form)
- select-cadr))
- null-binding-item?))
+ (remove! null-binding-item?
+ (map (lambda (binding item)
+ (binding-theory binding-environment
+ (car binding)
+ item))
+ (cadr form)
+ (map (lambda (binding)
+ (classify/expression (cadr binding)
+ value-environment))
+ (cadr form)))))
(body
(classify/body (cddr form)
body-environment
- body-environment
- history
- select-cddr)))
+ body-environment)))
(if (eq? binding-theory syntactic-binding-theory)
body
- (make-expression-item history
- (lambda ()
- (output/let (map binding-item/name bindings)
- (map (lambda (binding)
- (compile-item/expression
- (binding-item/value binding)))
- bindings)
- (compile-body-item body)))))))
-
-(define (expand/let* form rename let-keyword)
- (capture-expansion-history
- (lambda (history)
- (syntax-check '(KEYWORD (* DATUM) + FORM) form history)
- (let ((bindings (cadr form))
- (body (cddr form))
- (keyword (rename let-keyword)))
- (if (pair? bindings)
- (let loop ((bindings bindings))
- (if (pair? (cdr bindings))
- `(,keyword (,(car bindings)) ,(loop (cdr bindings)))
- `(,keyword ,bindings ,@body)))
- `(,keyword ,bindings ,@body))))))
-
-;;;; Bodies
-
-(define (compile-body-item item)
- (call-with-values
- (lambda ()
- (extract-declarations-from-body (body-item/components item)))
- (lambda (declaration-items items)
- (output/body (map declaration-item/text declaration-items)
- (compile-body-items item items)))))
-\f
-;;;; Derived syntax
-
-(define-er-macro-transformer 'AND system-global-environment
- (lambda (form rename compare)
- compare ;ignore
- (capture-expansion-history
- (lambda (history)
- (syntax-check '(KEYWORD * EXPRESSION) form history)
- (let ((operands (cdr form)))
- (if (pair? operands)
- (let ((if-keyword (rename 'IF)))
- (let loop ((operands operands))
- (if (pair? (cdr operands))
- `(,if-keyword ,(car operands)
- ,(loop (cdr operands))
- #F)
- (car operands))))
- `#T))))))
-
-(define-compiler 'OR system-global-environment
- (lambda (form environment history)
- (syntax-check '(KEYWORD * EXPRESSION) form history)
- (if (pair? (cdr form))
- (let loop ((expressions (cdr form)) (selector select-cdr))
- (let ((compiled
- (compile/subexpression (car expressions)
- environment
- history
- (selector/add-car selector))))
- (if (pair? (cdr expressions))
- (output/disjunction compiled
- (loop (cdr expressions)
- (selector/add-cdr selector)))
- compiled)))
- `#F)))
+ (make-expression-item
+ (let ((names (map binding-item/name bindings))
+ (values (map binding-item/value bindings)))
+ (lambda ()
+ (output/let names
+ (map compile-item/expression values)
+ (compile-body-item body))))))))
\f
-(define-er-macro-transformer 'CASE system-global-environment
- (lambda (form rename compare)
- (capture-expansion-history
- (lambda (history)
- (syntax-check '(KEYWORD EXPRESSION + (DATUM * EXPRESSION)) form history)
- (call-with-syntax-error-procedure
- (lambda (syntax-error)
- (letrec
- ((process-clause
- (lambda (clause rest)
- (cond ((null? (car clause))
- (process-rest rest))
- ((and (identifier? (car clause))
- (compare (rename 'ELSE) (car clause))
- (null? rest))
- `(,(rename 'BEGIN) ,@(cdr clause)))
- ((list? (car clause))
- `(,(rename 'IF) ,(process-predicate (car clause))
- (,(rename 'BEGIN) ,@(cdr clause))
- ,(process-rest rest)))
- (else
- (syntax-error "Ill-formed clause:" clause)))))
- (process-rest
- (lambda (rest)
- (if (pair? rest)
- (process-clause (car rest) (cdr rest))
- (unspecific-expression))))
- (process-predicate
- (lambda (items)
- ;; Optimize predicate for speed in compiled code.
- (cond ((null? (cdr items))
- (single-test (car items)))
- ((null? (cddr items))
- `(,(rename 'OR) ,(single-test (car items))
- ,(single-test (cadr items))))
- ((null? (cdddr items))
- `(,(rename 'OR) ,(single-test (car items))
- ,(single-test (cadr items))
- ,(single-test (caddr items))))
- ((null? (cddddr items))
- `(,(rename 'OR) ,(single-test (car items))
- ,(single-test (cadr items))
- ,(single-test (caddr items))
- ,(single-test (cadddr items))))
- (else
- `(,(rename
- (if (for-all? items eq-testable?) 'MEMQ 'MEMV))
- ,(rename 'TEMP)
- ',items)))))
- (single-test
- (lambda (item)
- `(,(rename (if (eq-testable? item) 'EQ? 'EQV?))
- ,(rename 'TEMP)
- ',item)))
- (eq-testable?
- (lambda (item)
- (or (symbol? item)
- (boolean? item)
- ;; remainder are implementation dependent:
- (char? item)
- (fix:fixnum? item)))))
- `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form)))
- ,(process-clause (caddr form)
- (cdddr form))))))))))
-\f
-(define-er-macro-transformer 'COND system-global-environment
- (lambda (form rename compare)
- (capture-expansion-history
- (lambda (history)
- (let ((clauses (cdr form)))
- (if (not (pair? clauses))
- (syntax-error history "Form must have at least one clause:" form))
- (let loop ((clause (car clauses)) (rest (cdr clauses)))
- (expand/cond-clause clause rename compare history (null? rest)
- (if (pair? rest)
- (loop (car rest) (cdr rest))
- (unspecific-expression)))))))))
-
-(define-er-macro-transformer 'DO system-global-environment
- (lambda (form rename compare)
- (capture-expansion-history
- (lambda (history)
- (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION ? EXPRESSION))
- (+ FORM)
- * FORM)
- form history)
- (let ((bindings (cadr form))
- (r-loop (rename 'DO-LOOP)))
- `(,(rename 'LET)
- ,r-loop
- ,(map (lambda (binding)
- (list (car binding) (cadr binding)))
- bindings)
- ,(expand/cond-clause (caddr form) rename compare history #f
- `(,(rename 'BEGIN)
- ,@(cdddr form)
- (,r-loop ,@(map (lambda (binding)
- (if (pair? (cddr binding))
- (caddr binding)
- (car binding)))
- bindings))))))))))
-
-(define (expand/cond-clause clause rename compare history else-allowed?
- alternative)
- (if (not (and (pair? clause) (list? (cdr clause))))
- (syntax-error history "Ill-formed clause:" clause))
- (cond ((and (identifier? (car clause))
- (compare (rename 'ELSE) (car clause)))
- (if (not else-allowed?)
- (syntax-error history "Misplaced ELSE clause:" clause))
- (if (or (not (pair? (cdr clause)))
- (and (identifier? (cadr clause))
- (compare (rename '=>) (cadr clause))))
- (syntax-error history "Ill-formed ELSE clause:" clause))
- `(,(rename 'BEGIN) ,@(cdr clause)))
- ((not (pair? (cdr clause)))
- (let ((r-temp (rename 'TEMP)))
- `(,(rename 'LET) ((,r-temp ,(car clause)))
- (,(rename 'IF) ,r-temp ,r-temp ,alternative))))
- ((and (identifier? (cadr clause))
- (compare (rename '=>) (cadr clause)))
- (if (not (and (pair? (cddr clause))
- (null? (cdddr clause))))
- (syntax-error history "Ill-formed => clause:" clause))
- (let ((r-temp (rename 'TEMP)))
- `(,(rename 'LET) ((,r-temp ,(car clause)))
- (,(rename 'IF) ,r-temp
- (,(caddr clause) ,r-temp)
- ,alternative))))
- (else
- `(,(rename 'IF) ,(car clause)
- (,(rename 'BEGIN) ,@(cdr clause))
- ,alternative))))
-\f
-(define-er-macro-transformer 'QUASIQUOTE system-global-environment
- (lambda (form rename compare)
- (call-with-syntax-error-procedure
- (lambda (syntax-error)
- (define (descend-quasiquote x level return)
- (cond ((pair? x) (descend-quasiquote-pair x level return))
- ((vector? x) (descend-quasiquote-vector x level return))
- (else (return 'QUOTE x))))
- (define (descend-quasiquote-pair x level return)
- (cond ((not (and (pair? x)
- (identifier? (car x))
- (pair? (cdr x))
- (null? (cddr x))))
- (descend-quasiquote-pair* x level return))
- ((compare (rename 'QUASIQUOTE) (car x))
- (descend-quasiquote-pair* x (+ level 1) return))
- ((compare (rename 'UNQUOTE) (car x))
- (if (zero? level)
- (return 'UNQUOTE (cadr x))
- (descend-quasiquote-pair* x (- level 1) return)))
- ((compare (rename 'UNQUOTE-SPLICING) (car x))
- (if (zero? level)
- (return 'UNQUOTE-SPLICING (cadr x))
- (descend-quasiquote-pair* x (- level 1) return)))
- (else
- (descend-quasiquote-pair* x level return))))
- (define (descend-quasiquote-pair* x level return)
- (descend-quasiquote (car x) level
- (lambda (car-mode car-arg)
- (descend-quasiquote (cdr x) level
- (lambda (cdr-mode cdr-arg)
- (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE))
- (return 'QUOTE x))
- ((eq? car-mode 'UNQUOTE-SPLICING)
- (if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg))
- (return 'UNQUOTE car-arg)
- (return 'APPEND
- (list car-arg
- (finalize-quasiquote cdr-mode
- cdr-arg)))))
- ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg))
- (return 'LIST
- (cons (finalize-quasiquote car-mode car-arg)
- (map (lambda (element)
- (finalize-quasiquote 'QUOTE
- element))
- cdr-arg))))
- ((eq? cdr-mode 'LIST)
- (return 'LIST
- (cons (finalize-quasiquote car-mode car-arg)
- cdr-arg)))
- (else
- (return
- 'CONS
- (list (finalize-quasiquote car-mode car-arg)
- (finalize-quasiquote cdr-mode cdr-arg))))))))))
- (define (descend-quasiquote-vector x level return)
- (descend-quasiquote (vector->list x) level
- (lambda (mode arg)
- (case mode
- ((QUOTE) (return 'QUOTE x))
- ((LIST) (return 'VECTOR arg))
- (else
- (return 'LIST->VECTOR
- (list (finalize-quasiquote mode arg))))))))
- (define (finalize-quasiquote mode arg)
- (case mode
- ((QUOTE) `(,(rename 'QUOTE) ,arg))
- ((UNQUOTE) arg)
- ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context:" arg))
- (else `(,(rename mode) ,@arg))))
- (capture-expansion-history
- (lambda (history)
- (syntax-check '(KEYWORD EXPRESSION) form history)
- (descend-quasiquote (cadr form) 0 finalize-quasiquote)))))))
-\f
-;;;; SRFI 2: AND-LET*
-
-;;; The SRFI document is a little unclear about the semantics, imposes
-;;; the weird restriction that variables may be duplicated (citing
-;;; LET*'s similar restriction, which doesn't actually exist), and the
-;;; reference implementation is highly non-standard and hard to
-;;; follow. This passes all of the tests except for the one that
-;;; detects duplicate bound variables, though.
-
-(define-er-macro-transformer 'AND-LET* system-global-environment
- (lambda (form rename compare)
- compare
- (let ((%and (rename 'AND))
- (%let (rename 'LET))
- (%begin (rename 'BEGIN)))
- (cond ((syntax-match? '(() * FORM) (cdr form))
- `(,%begin #T ,@(cddr form)))
- ((syntax-match? '((* DATUM) * FORM) (cdr form))
- (let ((clauses (cadr form))
- (body (cddr form)))
- (define (expand clause recur)
- (cond ((syntax-match? 'IDENTIFIER clause)
- (recur clause))
- ((syntax-match? '(EXPRESSION) clause)
- (recur (car clause)))
- ((syntax-match? '(IDENTIFIER EXPRESSION) clause)
- (let ((tail (recur (car clause))))
- (and tail `(,%let (,clause) ,tail))))
- (else #f)))
- (define (recur clauses make-body)
- (expand (car clauses)
- (let ((clauses (cdr clauses)))
- (if (null? clauses)
- make-body
- (lambda (conjunct)
- `(,%and ,conjunct
- ,(recur clauses make-body)))))))
- (or (recur clauses
- (if (null? body)
- (lambda (conjunct) conjunct)
- (lambda (conjunct)
- `(,%and ,conjunct (,%begin ,@body)))))
- (ill-formed-syntax form))))
- (else
- (ill-formed-syntax form))))))
+(define (compile-body-item item)
+ (receive (declaration-items items)
+ (extract-declarations-from-body (body-item/components item))
+ (output/body (map declaration-item/text declaration-items)
+ (compile-body-items items))))
+
+;; TODO: this is a compiler 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 (compiler:or form environment)
+ (syntax-check '(KEYWORD * EXPRESSION) form)
+ (if (pair? (cdr form))
+ (let loop ((expressions (cdr form)))
+ (let ((compiled (compile/expression (car expressions) environment)))
+ (if (pair? (cdr expressions))
+ (output/disjunction compiled (loop (cdr expressions)))
+ compiled)))
+ `#F))
\f
;;;; MIT-specific syntax
-(define-er-macro-transformer 'ACCESS system-global-environment
- (let ((keyword
- (classifier->keyword
- (lambda (form environment definition-environment history)
- definition-environment
- (make-access-item history
- (cadr form)
- (classify/subexpression (caddr form)
- environment
- history
- select-caddr))))))
- (lambda (form rename compare)
- rename compare ;ignore
- (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
- `(,keyword ,@(cdr form)))
- ((syntax-match? '(IDENTIFIER IDENTIFIER + FORM) (cdr form))
- `(,keyword ,(cadr form) (,(car form) ,@(cddr form))))
- (else
- (ill-formed-syntax form))))))
-
-(define <access-item>
- (make-item-type "access-item" '(NAME ENVIRONMENT)
- (lambda (item)
- (output/access-reference
- (access-item/name item)
- (compile-item/expression (access-item/environment item))))))
-
-(define make-access-item
- (item-constructor <access-item> '(NAME ENVIRONMENT)))
-
-(define access-item?
- (item-predicate <access-item>))
-
-(define access-item/name
- (item-accessor <access-item> 'NAME))
-
-(define access-item/environment
- (item-accessor <access-item> 'ENVIRONMENT))
-
-(define-er-macro-transformer 'CONS-STREAM system-global-environment
- (lambda (form rename compare)
- compare ;ignore
- (capture-expansion-history
- (lambda (history)
- (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form history)
- `(,(rename 'CONS) ,(cadr form)
- (,(rename 'DELAY) ,(caddr form)))))))
-\f
-(define-er-macro-transformer 'DEFINE-INTEGRABLE system-global-environment
- (lambda (form rename compare)
- compare ;ignore
- (let ((r-declare (rename 'DECLARE)))
- (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
- `(,(rename 'BEGIN)
- (,r-declare (INTEGRATE ,(cadr form)))
- (,(rename 'DEFINE) ,@(cdr form))))
- ((syntax-match? '((IDENTIFIER * IDENTIFIER) + FORM) (cdr form))
- `(,(rename 'BEGIN)
- (,r-declare (INTEGRATE-OPERATOR ,(caadr form)))
- (,(rename 'DEFINE) ,(cadr form)
- (,r-declare (INTEGRATE ,@(cdadr form)))
- ,@(cddr form))))
- (else
- (ill-formed-syntax form))))))
-
-(define-er-macro-transformer 'FLUID-LET system-global-environment
- (lambda (form rename compare)
- compare
- (capture-expansion-history
- (lambda (history)
- (syntax-check '(KEYWORD (* (FORM ? EXPRESSION)) + FORM)
- form history)
- (let ((names (map car (cadr form)))
- (r-let (rename 'LET))
- (r-lambda (rename 'LAMBDA))
- (r-set! (rename 'SET!)))
- (let ((out-temps
- (map (lambda (name)
- name
- (make-synthetic-identifier 'OUT-TEMP))
- names))
- (in-temps
- (map (lambda (name)
- name
- (make-synthetic-identifier 'IN-TEMP))
- names))
- (swap
- (lambda (tos names froms)
- `(,r-lambda ()
- ,@(map (lambda (to name from)
- `(,r-set! ,to
- (,r-set! ,name
- (,r-set! ,from))))
- tos
- names
- froms)
- ,(unspecific-expression)))))
- `(,r-let (,@(map cons in-temps (map cdr (cadr form)))
- ,@(map list out-temps))
- (,(rename 'SHALLOW-FLUID-BIND)
- ,(swap out-temps names in-temps)
- (,r-lambda () ,@(cddr form))
- ,(swap in-temps names out-temps)))))))))
-
-(define-compiler 'THE-ENVIRONMENT system-global-environment
- (lambda (form environment history)
- environment
- (syntax-check '(KEYWORD) form history)
- (if (not (syntactic-environment/top-level? environment))
- (syntax-error history "This form allowed only at top level:" form))
- (output/the-environment)))
-
-(define (unspecific-expression)
- (compiler->form
- (lambda (form environment history)
- form environment history ;ignore
+(define-record-type <access-item>
+ (make-access-item name environment)
+ access-item?
+ (name access-item/name)
+ (environment access-item/environment))
+
+(define keyword:access
+ (classifier->keyword
+ (lambda (form environment definition-environment)
+ definition-environment
+ (make-access-item (cadr form)
+ (classify/expression (caddr form) environment)))))
+
+(define-item-compiler <access-item>
+ (lambda (item)
+ (output/access-reference
+ (access-item/name item)
+ (compile-item/expression (access-item/environment item)))))
+
+(define (compiler:the-environment form environment)
+ environment
+ (syntax-check '(KEYWORD) form)
+ (if (not (syntactic-environment/top-level? environment))
+ (syntax-error "This form allowed only at top level:" form))
+ (output/the-environment))
+
+(define keyword:unspecific
+ (compiler->keyword
+ (lambda (form environment)
+ form environment ;ignore
(output/unspecific))))
-(define (unassigned-expression)
- (compiler->form
- (lambda (form environment history)
- form environment history ;ignore
+(define keyword:unassigned
+ (compiler->keyword
+ (lambda (form environment)
+ form environment ;ignore
(output/unassigned))))
\f
;;;; Declarations
-(define-classifier 'DECLARE system-global-environment
- (lambda (form environment definition-environment history)
- definition-environment
- (syntax-check '(KEYWORD * (SYMBOL * DATUM)) form history)
- (make-declaration-item history
- (lambda ()
- (map-declaration-references (cdr form)
- environment
- history
- select-cdr)))))
-
-(define-classifier 'LOCAL-DECLARE system-global-environment
- (lambda (form environment definition-environment history)
- (syntax-check '(KEYWORD (* (SYMBOL * DATUM)) + FORM) form history)
- (let ((body
- (classify/body (cddr form)
- environment
- definition-environment
- history
- select-cddr)))
- (make-expression-item history
- (lambda ()
- (output/local-declare (map-declaration-references (cadr form)
- environment
- history
- select-cadr)
- (compile-body-item body)))))))
-
-(define (map-declaration-references declarations environment history selector)
- (select-map (lambda (declaration selector)
- (process-declaration declaration selector
- (lambda (form selector)
- (classify/variable-subexpression form
- environment
- history
- selector))
- (lambda (declaration selector)
- (syntax-error (history/add-subproblem declaration
- environment
- history
- selector)
- "Ill-formed declaration:"
- declaration))))
- declarations
- selector))
-
-(define (classify/variable-subexpression form environment history selector)
- (let ((item (classify/subexpression form environment history selector)))
+(define (classifier:declare form environment definition-environment)
+ definition-environment
+ (syntax-check '(KEYWORD * (SYMBOL * DATUM)) form)
+ (make-declaration-item
+ (lambda ()
+ (classify/declarations (cdr form) environment))))
+
+(define (classifier:local-declare form environment definition-environment)
+ (syntax-check '(KEYWORD (* (SYMBOL * DATUM)) + FORM) form)
+ (let ((body
+ (classify/body (cddr form)
+ environment
+ definition-environment)))
+ (make-expression-item
+ (lambda ()
+ (output/local-declare (classify/declarations (cadr form) environment)
+ (compile-body-item body))))))
+
+(define (classify/declarations declarations environment)
+ (map (lambda (declaration)
+ (classify/declaration declaration environment))
+ declarations))
+
+(define (classify/declaration declaration environment)
+ (map-declaration-identifiers (lambda (identifier)
+ (variable-item/name
+ (classify/variable-reference identifier
+ environment)))
+ declaration))
+
+(define (classify/variable-reference identifier environment)
+ (let ((item (classify/expression identifier environment)))
(if (not (variable-item? item))
- (syntax-error history "Variable required in this context:" form))
- (variable-item/name item)))
\ No newline at end of file
+ (syntax-error "Variable required in this context:" identifier))
+ item))
\ No newline at end of file
(cond ((string-ci=? name "null") '())
((string-ci=? name "false") #f)
((string-ci=? name "true") #t)
- ((string-ci=? name "optional") lambda-optional-tag)
- ((string-ci=? name "rest") lambda-rest-tag)
- ((string-ci=? name "key") lambda-key-tag)
- ((string-ci=? name "aux") lambda-aux-tag)
+ ((string-ci=? name "optional") lambda-tag:optional)
+ ((string-ci=? name "rest") lambda-tag:rest)
+ ((string-ci=? name "key") lambda-tag:key)
+ ((string-ci=? name "aux") lambda-tag:aux)
((string-ci=? name "eof") (eof-object))
((string-ci=? name "default") (default-object))
((string-ci=? name "unspecific") unspecific)
(else (error:illegal-named-constant name)))))
-(define lambda-optional-tag (object-new-type (ucode-type constant) 3))
-(define lambda-rest-tag (object-new-type (ucode-type constant) 4))
-(define lambda-aux-tag (object-new-type (ucode-type constant) 8))
-(define lambda-key-tag (object-new-type (ucode-type constant) 5))
-
(define (handler:special-arg port db ctx char1 char2)
ctx char1
(let loop ((n (char->digit char2 10)))
error?))))))
(define (->type-name object)
- (let* ((string
- (cond ((string? object) object)
- ((symbol? object) (symbol-name object))
- (else (error:wrong-type-argument object "type name" #f))))
- (n (string-length string)))
- (if (and (fix:> n 2)
- (char=? (string-ref string 0) #\<)
- (char=? (string-ref string (fix:- n 1)) #\>))
- (substring string 1 (fix:- n 1))
- string)))
+ (cond ((string? object) object)
+ ((symbol? object) (symbol-name object))
+ (else (error:wrong-type-argument object "type name" #f))))
(define (list-of-unique-symbols? object)
(and (list-of-type? object symbol?)
weak-set-cdr!
xcons))
+(define-package (runtime lambda-list)
+ (files "lambda-list")
+ (parent (runtime))
+ (export ()
+ lambda-tag:aux
+ lambda-tag:key
+ lambda-tag:optional
+ lambda-tag:rest
+ map-mit-lambda-list
+ map-r4rs-lambda-list
+ mit-lambda-list?
+ parse-mit-lambda-list
+ parse-r4rs-lambda-list
+ r4rs-lambda-list?))
+
(define-package (runtime srfi-1)
(files "srfi-1")
(parent (runtime))
(*parser-table* runtime-parser-table))
(export (runtime character)
char-set/atom-delimiters)
- (export (runtime syntactic-closures)
- lambda-optional-tag
- lambda-rest-tag)
(export (runtime unparser)
char-set/atom-delimiters
char-set/number-leaders
- char-set/symbol-quotes
- lambda-aux-tag
- lambda-key-tag
- lambda-optional-tag
- lambda-rest-tag)
- (export (runtime unsyntaxer)
- lambda-aux-tag
- lambda-optional-tag
- lambda-rest-tag)
+ char-set/symbol-quotes)
(initialization (initialize-package!)))
(define-package (runtime parser-table)
unmapped-macro-reference-trap?
unmapped-unassigned-reference-trap?
unmapped-unbound-reference-trap?)
- (export (runtime syntactic-closures)
+ (export (runtime syntax)
make-macro-reference-trap-expression)
(export (runtime unsyntaxer)
macro-reference-trap-expression-transformer
with-output-to-truncated-string)
(initialization (initialize-package!)))
-(define-package (runtime syntactic-closures)
- (files "syntactic-closures"
- "syntax-output"
- "syntax-transforms"
- "mit-syntax"
- "syntax-rules"
- "syntax-check")
- (parent (runtime))
+(define-package (runtime syntax)
+ (files)
+ (parent (runtime)))
+
+(define-package (runtime syntax top-level)
+ (files "syntax")
+ (parent (runtime syntax))
(export ()
<syntactic-closure>
- call-with-syntax-error-procedure
capture-syntactic-environment
close-syntax
- er-macro-transformer->expander
- guarantee-syntactic-environment
+ error:not-identifier
+ error:not-syntactic-closure
+ error:not-synthetic-identifier
+ guarantee-identifier
+ guarantee-syntactic-closure
+ guarantee-synthetic-identifier
identifier->symbol
identifier=?
identifier?
- ill-formed-syntax
- lambda-tag:fluid-let
- lambda-tag:let
- lambda-tag:unnamed
make-syntactic-closure
make-synthetic-identifier
- mit-lambda-list?
- non-hygienic-macro-transformer->expander
- parse-mit-lambda-list
- r4rs-lambda-list?
reverse-syntactic-environments
- rsc-macro-transformer->expander
- sc-macro-transformer->expander
strip-syntactic-closures
- supported-srfi-features
syntactic-closure/environment
syntactic-closure/form
syntactic-closure/free-names
syntactic-closure?
+ syntax
+ syntax*
+ syntax-error
+ synthetic-identifier?)
+ (export (runtime syntax)
+ classifier->keyword
+ compile/expression
+ compiler->keyword
+ lookup-identifier))
+
+(define-package (runtime syntax items)
+ (files "syntax-items")
+ (parent (runtime syntax))
+ (export (runtime syntax)
+ <binding-item>
+ <body-item>
+ <classifier-item>
+ <compiler-item>
+ <declaration-item>
+ <expander-item>
+ <expression-item>
+ <keyword-value-item>
+ <null-binding-item>
+ <reserved-name-item>
+ <variable-item>
+ binding-item/name
+ binding-item/value
+ binding-item?
+ body-item/components
+ classifier-item/classifier
+ classifier-item?
+ compiler-item/compiler
+ compiler-item?
+ declaration-item/text
+ declaration-item?
+ expander-item/expander
+ expander-item?
+ expression-item/compiler
+ flatten-body-items
+ item->list
+ keyword-item?
+ keyword-value-item/expression
+ keyword-value-item/item
+ keyword-value-item?
+ make-binding-item
+ make-body-item
+ make-classifier-item
+ make-compiler-item
+ make-declaration-item
+ make-expander-item
+ make-expression-item
+ make-keyword-value-item
+ make-null-binding-item
+ make-reserved-name-item
+ make-variable-item
+ null-binding-item?
+ reserved-name-item?
+ variable-item/name
+ variable-item?))
+
+(define-package (runtime syntax environment)
+ (files "syntax-environment")
+ (parent (runtime syntax))
+ (export ()
+ error:not-syntactic-environment
+ guarantee-syntactic-environment
+ syntactic-environment?)
+ (export (runtime syntax)
+ bind-variable!
+ make-internal-syntactic-environment
+ make-partial-syntactic-environment
+ make-top-level-syntactic-environment
+ null-syntactic-environment
syntactic-environment->environment
+ syntactic-environment/define
syntactic-environment/lookup
syntactic-environment/top-level?
- syntactic-environment?
- syntactic-keyword->item
- syntax
- syntax*
+ syntactic-environment?))
+
+(define-package (runtime syntax check)
+ (files "syntax-check")
+ (parent (runtime syntax))
+ (export ()
+ ill-formed-syntax
+ syntax-check
syntax-match?
- synthetic-identifier?
- )
+ syntax-match?*))
+
+(define-package (runtime syntax classify)
+ (files "syntax-classify")
+ (parent (runtime syntax))
+ (export (runtime syntax)
+ classify/body
+ classify/expression
+ classify/form
+ extract-declarations-from-body))
+
+(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
+ compile-item/expression
+ define-item-compiler))
+
+(define-package (runtime syntax output)
+ (files "syntax-output")
+ (parent (runtime syntax))
+ (export ()
+ lambda-tag:fluid-let
+ lambda-tag:let
+ lambda-tag:unnamed)
+ (export (runtime syntax)
+ *rename-database*
+ initial-rename-database
+ make-name-generator
+ make-rename-id
+ output/access-assignment
+ output/access-reference
+ output/assignment
+ output/body
+ output/combination
+ output/conditional
+ output/constant
+ output/definition
+ output/delay
+ output/disjunction
+ output/lambda
+ output/let
+ output/letrec
+ output/local-declare
+ output/named-lambda
+ output/post-process-expression
+ output/runtime-reference
+ output/sequence
+ output/the-environment
+ output/top-level-definition
+ output/top-level-sequence
+ output/top-level-syntax-definition
+ output/unassigned
+ output/unassigned-test
+ output/unspecific
+ output/variable
+ rename-identifier
+ rename-top-level-identifier
+ transformer-eval))
+
+(define-package (runtime syntax declaration)
+ (files "syntax-declaration")
+ (parent (runtime syntax))
+ (export (runtime syntax)
+ map-declaration-identifiers))
+
+(define-package (runtime syntax transforms)
+ (files "syntax-transforms")
+ (parent (runtime syntax))
+ (export ()
+ er-macro-transformer->expander
+ non-hygienic-macro-transformer->expander
+ rsc-macro-transformer->expander
+ sc-macro-transformer->expander
+ syntactic-keyword->item))
+
+(define-package (runtime syntax mit)
+ (files "mit-syntax")
+ (parent (runtime syntax))
+ (export (runtime syntax definitions)
+ classifier:begin
+ classifier:declare
+ classifier:define-syntax
+ classifier:er-macro-transformer
+ classifier:let-syntax
+ classifier:letrec
+ classifier:letrec-syntax
+ classifier:local-declare
+ classifier:non-hygienic-macro-transformer
+ classifier:rsc-macro-transformer
+ classifier:sc-macro-transformer
+ compiler:delay
+ compiler:if
+ compiler:lambda
+ compiler:named-lambda
+ compiler:or
+ compiler:quote
+ compiler:set!
+ compiler:the-environment)
+ (export (runtime mit-macros)
+ keyword:access
+ keyword:define
+ keyword:let
+ keyword:let-syntax
+ keyword:unassigned
+ keyword:unspecific))
+
+(define-package (runtime mit-macros)
+ (files "mit-macros")
+ (parent (runtime))
+ (export ()
+ (access :access)
+ (and :and)
+ (and-let* :and-let*)
+ (case :case)
+ (cond :cond)
+ (cond-expand :cond-expand)
+ (cons-stream :cons-stream)
+ (define :define)
+ (define-integrable :define-integrable)
+ (define-record-type :define-record-type)
+ (do :do)
+ (fluid-let :fluid-let)
+ (let :let)
+ (let* :let*)
+ (let*-syntax :let*-syntax)
+ (quasiquote :quasiquote)
+ (receive :receive)
+ supported-srfi-features)
(export (runtime)
- parse-define-form)
- (export (runtime defstruct)
- define-expander
- parse-mit-lambda-list))
+ parse-define-form))
-(define-package (runtime defstruct)
+(define-package (runtime syntax syntax-rules)
+ (files "syntax-rules")
+ (parent (runtime syntax))
+ (export (runtime syntax definitions)
+ er-macro-transformer:syntax-rules))
+
+(define-package (runtime syntax defstruct)
(files "defstr")
- (parent (runtime))
+ (parent (runtime syntax))
(export ()
- ;;define-structure
- ))
+ define-structure))
+
+(define-package (runtime syntax definitions)
+ (files "syntax-definitions")
+ (parent (runtime syntax))
+ (initialization (initialize-package!)))
(define-package (runtime system-macros)
(files "sysmac")
+++ /dev/null
-#| -*-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 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.
-
-|#
-
-;;;; Syntactic Closures
-;;; Based on a design by Alan Bawden.
-
-;;; This is a two-stage program: the first stage classifies input
-;;; expressions into types, e.g. "definition", "lambda body",
-;;; "expression", etc., and the second stage compiles those classified
-;;; expressions ("items") into output code. The classification stage
-;;; permits discovery of internal definitions prior to code
-;;; generation. It also identifies keywords and variables, which
-;;; allows a powerful form of syntactic binding to be implemented.
-
-;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in
-;;; Proceedings of the 1988 ACM Conference on Lisp and Functional
-;;; Programming, page 86.
-
-(declare (usual-integrations))
-\f
-;;;; Compiler
-
-(define (syntax form environment)
- (syntax* (list form) environment))
-
-(define (syntax* forms environment)
- (if (not (list? forms))
- (error:wrong-type-argument forms "list" 'SYNTAX*))
- (guarantee-syntactic-environment environment 'SYNTAX*)
- (fluid-let ((*rename-database* (initial-rename-database)))
- (output/post-process-expression
- (if (syntactic-environment/top-level? environment)
- (let ((environment
- (make-top-level-syntactic-environment environment)))
- (compile-body-items/top-level
- (classify/body-forms forms
- environment
- environment
- (make-top-level-history forms environment)
- select-object)))
- (output/sequence
- (compile/expressions forms
- environment
- (make-top-level-history forms environment)))))))
-
-(define (compile-item/top-level item)
- (if (binding-item? item)
- (let ((name (binding-item/name item))
- (value (binding-item/value item)))
- (if (keyword-value-item? value)
- (output/top-level-syntax-definition
- name
- (compile-item/expression (keyword-value-item/expression value)))
- (output/top-level-definition
- name
- (compile-item/expression value))))
- (compile-item/expression item)))
-
-(define (compile-body-items/top-level body-items)
- (call-with-values (lambda () (extract-declarations-from-body body-items))
- (lambda (declaration-items body-items)
- (output/top-level-sequence (map declaration-item/text declaration-items)
- (map compile-item/top-level body-items)))))
-\f
-(define (compile-item/expression item)
- (if (not (item? item))
- (error:wrong-type-argument item "item" 'COMPILE-ITEM/EXPRESSION))
- (let ((compiler (get-item-compiler item)))
- (if (not compiler)
- (error:bad-range-argument item 'COMPILE-ITEM/EXPRESSION))
- (compiler item)))
-
-(define (get-item-compiler item)
- (let ((entry
- (assq (record-type-descriptor (item/record item)) item-compilers)))
- (and entry
- (cdr entry))))
-
-(define (define-item-compiler rtd compiler)
- (let ((entry (assq rtd item-compilers)))
- (if entry
- (set-cdr! entry compiler)
- (begin
- (set! item-compilers (cons (cons rtd compiler) item-compilers))
- unspecific))))
-
-(define item-compilers '())
-
-(define (compile/expression expression environment history)
- (compile-item/expression
- (classify/expression expression environment history)))
-
-(define (compile/expressions expressions environment history)
- (compile/subexpressions expressions environment history select-object))
-
-(define (compile/subexpression expression environment history selector)
- (compile-item/expression
- (classify/subexpression expression environment history selector)))
-
-(define (compile/subexpressions expressions environment history selector)
- (select-map (lambda (expression selector)
- (compile/subexpression expression
- environment
- history
- selector))
- expressions
- selector))
-\f
-;;;; Classifier
-
-(define (classify/form form environment definition-environment history)
- (cond ((identifier? form)
- (let ((item
- (item/new-history (lookup-identifier environment form)
- history)))
- (if (keyword-item? item)
- (make-keyword-ref-item (strip-keyword-value-item item)
- form
- history)
- item)))
- ((syntactic-closure? form)
- (let ((form (syntactic-closure/form form))
- (environment
- (make-filtered-syntactic-environment
- (syntactic-closure/free-names form)
- environment
- (syntactic-closure/environment form))))
- (classify/form form
- environment
- definition-environment
- (history/replace-reduction form
- environment
- history))))
- ((pair? form)
- (let ((item
- (strip-keyword-value-item
- (classify/subexpression (car form) environment history
- select-car))))
- (cond ((classifier-item? item)
- ((classifier-item/classifier item) form
- environment
- definition-environment
- history))
- ((compiler-item? item)
- (classify/compiler item form environment history))
- ((expander-item? item)
- (classify/expander item
- form
- environment
- definition-environment
- history))
- (else
- (if (not (list? (cdr form)))
- (syntax-error history
- "Combination must be a proper list:"
- form))
- (let ((items
- (classify/subexpressions (cdr form)
- environment
- history
- select-cdr)))
- (make-expression-item
- history
- (lambda ()
- (output/combination
- (compile-item/expression item)
- (map compile-item/expression items)))))))))
- (else
- (make-expression-item history (lambda () (output/constant form))))))
-
-(define (classify/compiler item form environment history)
- (make-expression-item history
- (lambda ()
- ((compiler-item/compiler item) form environment history))))
-
-(define (classify/expander item form environment definition-environment
- history)
- (let ((form
- ((expander-item/expander item) form
- environment
- (expander-item/environment item))))
- (classify/form form
- environment
- definition-environment
- (history/add-reduction form environment history))))
-\f
-(define (classify/subform form environment definition-environment
- history selector)
- (classify/form form
- environment
- definition-environment
- (history/add-subproblem form environment history selector)))
-
-(define (classify/subforms forms environment definition-environment
- history selector)
- (select-map (lambda (form selector)
- (classify/subform form environment definition-environment
- history selector))
- forms
- selector))
-
-(define (classify/expression expression environment history)
- (classify/form expression environment null-syntactic-environment history))
-
-(define (classify/subexpression expression environment history selector)
- (classify/subform expression environment null-syntactic-environment
- history selector))
-
-(define (classify/subexpressions expressions environment history selector)
- (classify/subforms expressions environment null-syntactic-environment
- history selector))
-
-(define (classify/body forms environment definition-environment history
- selector)
- (make-body-item history
- (classify/body-forms forms
- environment
- definition-environment
- history
- selector)))
-
-(define (classify/body-forms forms environment definition-environment history
- selector)
- ;; Top-level syntactic definitions affect all forms that appear
- ;; after them, so classify FORMS in order.
- (let forms-loop ((forms forms) (selector selector) (body-items '()))
- (if (pair? forms)
- (let items-loop
- ((items
- (item->list
- (classify/subform (car forms)
- environment
- definition-environment
- history
- (selector/add-car selector))))
- (body-items body-items))
- (if (pair? items)
- (items-loop (cdr items)
- (if (null-binding-item? (car items))
- body-items
- (cons (car items) body-items)))
- (forms-loop (cdr forms)
- (selector/add-cdr selector)
- body-items)))
- (reverse! body-items))))
-
-(define (extract-declarations-from-body items)
- (let loop ((items items) (declarations '()) (items* '()))
- (if (pair? items)
- (if (declaration-item? (car items))
- (loop (cdr items)
- (cons (car items) declarations)
- items*)
- (loop (cdr items)
- declarations
- (cons (car items) items*)))
- (values (reverse! declarations) (reverse! items*)))))
-
-(define (strip-keyword-value-item item)
- (if (keyword-value-item? item)
- (keyword-value-item/item item)
- item))
-\f
-;;;; Syntactic Closures
-
-(define-record-type <syntactic-closure>
- (%make-syntactic-closure environment free-names form)
- syntactic-closure?
- (environment syntactic-closure/environment)
- (free-names syntactic-closure/free-names)
- (form syntactic-closure/form))
-
-(define (make-syntactic-closure environment free-names form)
- (guarantee-syntactic-environment environment 'MAKE-SYNTACTIC-CLOSURE)
- (guarantee-list-of-type free-names identifier?
- "list of identifiers" 'MAKE-SYNTACTIC-CLOSURE)
- (if (or (memq form free-names) ;LOOKUP-IDENTIFIER assumes this.
- (and (syntactic-closure? form)
- (null? (syntactic-closure/free-names form))
- (not (identifier? (syntactic-closure/form form))))
- (not (or (syntactic-closure? form)
- (pair? form)
- (symbol? form))))
- form
- (%make-syntactic-closure environment free-names form)))
-
-(define (strip-syntactic-closures object)
- (if (let loop ((object object))
- (if (pair? object)
- (or (loop (car object))
- (loop (cdr object)))
- (syntactic-closure? object)))
- (let loop ((object object))
- (if (pair? object)
- (cons (loop (car object))
- (loop (cdr object)))
- (if (syntactic-closure? object)
- (loop (syntactic-closure/form object))
- object)))
- object))
-
-(define (close-syntax form environment)
- (make-syntactic-closure environment '() form))
-\f
-(define (identifier? object)
- (or (symbol? object)
- (synthetic-identifier? object)))
-
-(define (synthetic-identifier? object)
- (and (syntactic-closure? object)
- (identifier? (syntactic-closure/form object))))
-
-(define (make-synthetic-identifier identifier)
- (close-syntax identifier null-syntactic-environment))
-
-(define (identifier->symbol identifier)
- (or (let loop ((identifier identifier))
- (if (syntactic-closure? identifier)
- (loop (syntactic-closure/form identifier))
- (and (symbol? identifier)
- identifier)))
- (error:wrong-type-argument identifier "identifier" 'IDENTIFIER->SYMBOL)))
-
-(define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
- (let ((item-1 (lookup-identifier environment-1 identifier-1))
- (item-2 (lookup-identifier environment-2 identifier-2)))
- (or (item=? item-1 item-2)
- ;; This is necessary because an identifier that is not
- ;; explicitly bound by an environment is mapped to a variable
- ;; item, and the variable items are not cached. Therefore
- ;; two references to the same variable result in two
- ;; different variable items.
- (and (variable-item? item-1)
- (variable-item? item-2)
- (eq? (variable-item/name item-1)
- (variable-item/name item-2))))))
-\f
-;;;; Syntactic Environments
-
-(define (syntactic-environment? object)
- (or (internal-syntactic-environment? object)
- (top-level-syntactic-environment? object)
- (environment? object)
- (filtered-syntactic-environment? object)
- (null-syntactic-environment? object)))
-
-(define (guarantee-syntactic-environment object name)
- (if (not (syntactic-environment? object))
- (error:wrong-type-argument object "syntactic environment" name)))
-
-(define (syntactic-environment/top-level? object)
- (or (top-level-syntactic-environment? object)
- (interpreter-environment? object)))
-
-(define (lookup-identifier environment identifier)
- (let ((item (syntactic-environment/lookup environment identifier)))
- (cond (item
- (if (reserved-name-item? item)
- (syntax-error (item/history item)
- "Premature reference to reserved name:"
- identifier)
- item))
- ((symbol? identifier)
- (make-variable-item identifier))
- ((syntactic-closure? identifier)
- (lookup-identifier (syntactic-closure/environment identifier)
- (syntactic-closure/form identifier)))
- (else
- (error:wrong-type-argument identifier "identifier"
- 'LOOKUP-IDENTIFIER)))))
-
-(define (syntactic-environment/lookup environment name)
- (cond ((internal-syntactic-environment? environment)
- (internal-syntactic-environment/lookup environment name))
- ((top-level-syntactic-environment? environment)
- (top-level-syntactic-environment/lookup environment name))
- ((environment? environment)
- (and (symbol? name)
- (environment/lookup environment name)))
- ((filtered-syntactic-environment? environment)
- (filtered-syntactic-environment/lookup environment name))
- ((null-syntactic-environment? environment)
- (null-syntactic-environment/lookup environment name))
- (else
- (error:wrong-type-argument environment "syntactic environment"
- 'SYNTACTIC-ENVIRONMENT/LOOKUP))))
-\f
-(define (syntactic-environment/define environment name item)
- (cond ((internal-syntactic-environment? environment)
- (internal-syntactic-environment/define environment name item))
- ((top-level-syntactic-environment? environment)
- (top-level-syntactic-environment/define environment name item))
- ((environment? environment)
- (environment/define environment name item))
- ((filtered-syntactic-environment? environment)
- (filtered-syntactic-environment/define environment name item))
- ((null-syntactic-environment? environment)
- (null-syntactic-environment/define environment name item))
- (else
- (error:wrong-type-argument environment "syntactic environment"
- 'SYNTACTIC-ENVIRONMENT/DEFINE))))
-
-(define (syntactic-environment/rename environment name)
- (cond ((internal-syntactic-environment? environment)
- (internal-syntactic-environment/rename environment name))
- ((top-level-syntactic-environment? environment)
- (top-level-syntactic-environment/rename environment name))
- ((environment? environment)
- (environment/rename environment name))
- ((filtered-syntactic-environment? environment)
- (filtered-syntactic-environment/rename environment name))
- ((null-syntactic-environment? environment)
- (null-syntactic-environment/rename environment name))
- (else
- (error:wrong-type-argument environment "syntactic environment"
- 'SYNTACTIC-ENVIRONMENT/RENAME))))
-
-(define (syntactic-environment->environment environment)
- (cond ((internal-syntactic-environment? environment)
- (internal-syntactic-environment->environment environment))
- ((top-level-syntactic-environment? environment)
- (top-level-syntactic-environment->environment environment))
- ((environment? environment)
- environment)
- ((filtered-syntactic-environment? environment)
- (filtered-syntactic-environment->environment environment))
- ((null-syntactic-environment? environment)
- (null-syntactic-environment->environment environment))
- (else
- (error:wrong-type-argument environment "syntactic environment"
- 'SYNTACTIC-ENVIRONMENT->ENVIRONMENT))))
-\f
-;;; Null syntactic environments signal an error for any operation.
-;;; They are used as the definition environment for expressions (to
-;;; prevent illegal use of definitions) and to seal off environments
-;;; used in magic keywords.
-
-(define-record-type <null-syntactic-environment>
- (%make-null-syntactic-environment)
- null-syntactic-environment?)
-
-(define null-syntactic-environment
- (%make-null-syntactic-environment))
-
-(define (null-syntactic-environment/lookup environment name)
- environment
- (error "Can't lookup name in null syntactic environment:" name))
-
-(define (null-syntactic-environment/define environment name item)
- environment
- (error "Can't bind name in null syntactic environment:" name item))
-
-(define (null-syntactic-environment/rename environment name)
- environment
- (error "Can't rename name in null syntactic environment:" name))
-
-(define (null-syntactic-environment->environment environment)
- environment
- (error "Can't evaluate in null syntactic environment."))
-
-;;; Runtime environments can be used to look up keywords, but can't be
-;;; modified.
-
-(define (environment/lookup environment name)
- (let ((item (environment-lookup-macro environment name)))
- (cond ((or (item? item) (not item))
- item)
- ;; **** Kludge to support bootstrapping.
- ((procedure? item)
- (non-hygienic-macro-transformer->expander item environment))
- (else
- (error:wrong-type-datum item "syntactic keyword")))))
-
-(define (environment/define environment name item)
- (environment-define-macro environment name item))
-
-(define (environment/rename environment name)
- environment
- (rename-top-level-identifier name))
-\f
-;;; Top-level syntactic environments represent top-level environments.
-;;; They are always layered over a real syntactic environment.
-
-(define-record-type <top-level-syntactic-environment>
- (%make-top-level-syntactic-environment parent bound)
- top-level-syntactic-environment?
- (parent top-level-syntactic-environment/parent)
- (bound top-level-syntactic-environment/bound
- set-top-level-syntactic-environment/bound!))
-
-(define (make-top-level-syntactic-environment parent)
- (guarantee-syntactic-environment parent
- 'MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT)
- (if (not (or (syntactic-environment/top-level? parent)
- (null-syntactic-environment? parent)))
- (error:bad-range-argument parent "top-level syntactic environment"
- 'MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT))
- (%make-top-level-syntactic-environment parent '()))
-
-(define (top-level-syntactic-environment/lookup environment name)
- (let ((binding
- (assq name (top-level-syntactic-environment/bound environment))))
- (if binding
- (cdr binding)
- (syntactic-environment/lookup
- (top-level-syntactic-environment/parent environment)
- name))))
-
-(define (top-level-syntactic-environment/define environment name item)
- (let ((bound (top-level-syntactic-environment/bound environment)))
- (let ((binding (assq name bound)))
- (if binding
- (set-cdr! binding item)
- (set-top-level-syntactic-environment/bound!
- environment
- (cons (cons name item) bound))))))
-
-(define (top-level-syntactic-environment/rename environment name)
- environment
- (rename-top-level-identifier name))
-
-(define (top-level-syntactic-environment->environment environment)
- (syntactic-environment->environment
- (top-level-syntactic-environment/parent environment)))
-\f
-;;; Internal syntactic environments represent environments created by
-;;; procedure application.
-
-(define-record-type <internal-syntactic-environment>
- (%make-internal-syntactic-environment parent bound free rename-state)
- internal-syntactic-environment?
- (parent internal-syntactic-environment/parent)
- (bound internal-syntactic-environment/bound
- set-internal-syntactic-environment/bound!)
- (free internal-syntactic-environment/free
- set-internal-syntactic-environment/free!)
- (rename-state internal-syntactic-environment/rename-state))
-
-(define (make-internal-syntactic-environment parent)
- (guarantee-syntactic-environment parent 'MAKE-INTERNAL-SYNTACTIC-ENVIRONMENT)
- (%make-internal-syntactic-environment parent '() '() (make-rename-id)))
-
-(define (internal-syntactic-environment/lookup environment name)
- (let ((binding
- (or (assq name (internal-syntactic-environment/bound environment))
- (assq name (internal-syntactic-environment/free environment)))))
- (if binding
- (cdr binding)
- (let ((item
- (syntactic-environment/lookup
- (internal-syntactic-environment/parent environment)
- name)))
- (set-internal-syntactic-environment/free!
- environment
- (cons (cons name item)
- (internal-syntactic-environment/free environment)))
- item))))
-
-(define (internal-syntactic-environment/define environment name item)
- (cond ((assq name (internal-syntactic-environment/bound environment))
- => (lambda (binding)
- (set-cdr! binding item)))
- ((assq name (internal-syntactic-environment/free environment))
- (if (reserved-name-item? item)
- (syntax-error (item/history item)
- "Premature reference to reserved name:"
- name)
- (error "Can't define name; already free:" name)))
- (else
- (set-internal-syntactic-environment/bound!
- environment
- (cons (cons name item)
- (internal-syntactic-environment/bound environment))))))
-
-(define (internal-syntactic-environment/rename environment name)
- (rename-identifier
- name
- (internal-syntactic-environment/rename-state environment)))
-
-(define (internal-syntactic-environment->environment environment)
- (syntactic-environment->environment
- (internal-syntactic-environment/parent environment)))
-\f
-;;; Filtered syntactic environments are used to implement syntactic
-;;; closures that have free names.
-
-(define-record-type <filtered-syntactic-environment>
- (%make-filtered-syntactic-environment names
- names-environment
- else-environment)
- filtered-syntactic-environment?
- (names filtered-syntactic-environment/names)
- (names-environment filtered-syntactic-environment/names-environment)
- (else-environment filtered-syntactic-environment/else-environment))
-
-(define (make-filtered-syntactic-environment names
- names-environment
- else-environment)
- (if (or (null? names)
- (eq? names-environment else-environment))
- else-environment
- (%make-filtered-syntactic-environment names
- names-environment
- else-environment)))
-
-(define (filtered-syntactic-environment/lookup environment name)
- (syntactic-environment/lookup
- (if (memq name (filtered-syntactic-environment/names environment))
- (filtered-syntactic-environment/names-environment environment)
- (filtered-syntactic-environment/else-environment environment))
- name))
-
-(define (filtered-syntactic-environment/define environment name item)
- ;; **** Shouldn't this be a syntax error? It can happen as the
- ;; result of a misplaced definition. ****
- (error "Can't bind name in filtered syntactic environment:"
- environment name item))
-
-(define (filtered-syntactic-environment/rename environment name)
- (syntactic-environment/rename
- (if (memq name (filtered-syntactic-environment/names environment))
- (filtered-syntactic-environment/names-environment environment)
- (filtered-syntactic-environment/else-environment environment))
- name))
-
-(define (filtered-syntactic-environment->environment environment)
- ;; **** Shouldn't this be a syntax error? It can happen as the
- ;; result of a partially-closed transformer. ****
- (error "Can't evaluate in filtered syntactic environment:" environment))
-\f
-;;;; Items
-
-;;; Some of the item code is in "syntax-transform.scm" because it is
-;;; needed during the cold load.
-
-(define item?
- (record-predicate <item>))
-
-(define item/history
- (record-accessor <item> 'HISTORY))
-
-(define (item/new-history item history)
- (make-item history (item/record item)))
-
-(define item/record
- (record-accessor <item> 'RECORD))
-
-(define (item=? x y)
- (eq? (item/record x) (item/record y)))
-
-(define (make-item-type name fields compiler)
- (let ((rtd (make-record-type name fields)))
- (define-item-compiler rtd compiler)
- rtd))
-
-(define (item-predicate rtd)
- (let ((predicate (record-predicate rtd)))
- (lambda (item)
- (predicate (item/record item)))))
-
-(define (item-accessor rtd field)
- (let ((accessor (record-accessor rtd field)))
- (lambda (item)
- (accessor (item/record item)))))
-
-(define (illegal-expression-item item description)
- (let ((history (item/history item)))
- (syntax-error history
- (string-append description
- " may not be used as an expression:")
- (history/original-form history))))
-
-;;; Reserved name items do not represent any form, but instead are
-;;; used to reserve a particular name in a syntactic environment. If
-;;; the classifier refers to a reserved name, a syntax error is
-;;; signalled. This is used in the implementation of LETREC-SYNTAX
-;;; to signal a meaningful error when one of the <init>s refers to
-;;; one of the names being bound.
-
-(define <reserved-name-item>
- (make-item-type "reserved-name-item" '()
- (lambda (item)
- (illegal-expression-item item "Reserved name"))))
-
-(define make-reserved-name-item
- (item-constructor <reserved-name-item> '()))
-
-(define reserved-name-item?
- (item-predicate <reserved-name-item>))
-\f
-;;; Keyword items represent macro keywords. There are several flavors
-;;; of keyword item.
-
-(define (keyword-item? item)
- (or (classifier-item? item)
- (compiler-item? item)
- (expander-item? item)
- (keyword-value-item? item)))
-
-(define (make-keyword-type name fields)
- (make-item-type name fields keyword-item-compiler))
-
-(define (keyword-item-compiler item)
- (illegal-expression-item item "Syntactic keyword"))
-
-
-(define <classifier-item>
- (make-keyword-type "classifier-item" '(CLASSIFIER)))
-
-(define make-classifier-item
- (keyword-constructor <classifier-item> '(CLASSIFIER)))
-
-(define classifier-item?
- (item-predicate <classifier-item>))
-
-(define classifier-item/classifier
- (item-accessor <classifier-item> 'CLASSIFIER))
-
-
-(define <compiler-item>
- (make-keyword-type "compiler-item" '(COMPILER)))
-
-(define make-compiler-item
- (keyword-constructor <compiler-item> '(COMPILER)))
-
-(define compiler-item?
- (item-predicate <compiler-item>))
-
-(define compiler-item/compiler
- (item-accessor <compiler-item> 'COMPILER))
-
-
-(define-item-compiler <expander-item>
- keyword-item-compiler)
-
-(define expander-item?
- (item-predicate <expander-item>))
-
-(define expander-item/expander
- (item-accessor <expander-item> 'EXPANDER))
-
-(define expander-item/environment
- (item-accessor <expander-item> 'ENVIRONMENT))
-
-
-(define <keyword-value-item>
- (make-keyword-type "keyword-value-item" '(ITEM EXPRESSION)))
-
-(define make-keyword-value-item
- (item-constructor <keyword-value-item> '(ITEM EXPRESSION)))
-
-(define keyword-value-item?
- (item-predicate <keyword-value-item>))
-
-(define keyword-value-item/item
- (item-accessor <keyword-value-item> 'ITEM))
-
-(define keyword-value-item/expression
- (item-accessor <keyword-value-item> 'EXPRESSION))
-
-(define (make-keyword-ref-item item identifier history)
- (make-keyword-value-item history item
- (make-expression-item history
- (let ((name (identifier->symbol identifier)))
- (lambda ()
- (output/combination
- (output/access-reference 'SYNTACTIC-KEYWORD->ITEM
- system-global-environment)
- (list name (output/the-environment))))))))
-\f
-;;; Variable items represent run-time variables.
-
-(define <variable-item>
- (make-item-type "variable-item" '(NAME)
- (lambda (item)
- (output/variable (variable-item/name item)))))
-
-(define make-variable-item
- (let ((constructor (item-constructor <variable-item> '(NAME))))
- (lambda (name)
- (constructor #f name))))
-
-(define variable-item?
- (item-predicate <variable-item>))
-
-(define variable-item/name
- (item-accessor <variable-item> 'NAME))
-
-;;; Expression items represent any kind of expression other than a
-;;; run-time variable or a sequence. The ANNOTATION field is used to
-;;; make expression items that can appear in non-expression contexts
-;;; (for example, this could be used in the implementation of SETF).
-
-(define <expression-item>
- (make-item-type "expression-item" '(COMPILER ANNOTATION)
- (lambda (item)
- ((expression-item/compiler item)))))
-
-(define make-special-expression-item
- (item-constructor <expression-item> '(COMPILER ANNOTATION)))
-
-(define expression-item?
- (item-predicate <expression-item>))
-
-(define expression-item/compiler
- (item-accessor <expression-item> 'COMPILER))
-
-(define expression-item/annotation
- (item-accessor <expression-item> 'ANNOTATION))
-
-(define (make-expression-item history compiler)
- (make-special-expression-item history compiler #f))
-
-;;; Unassigned items represent the right hand side of a binding that
-;;; has no explicit value.
-
-(define <unassigned-item>
- (make-item-type "unassigned-item" '()
- (lambda (item)
- item ;ignore
- (output/unassigned))))
-
-(define make-unassigned-item
- (item-constructor <unassigned-item> '()))
-
-(define unassigned-item?
- (item-predicate <unassigned-item>))
-
-;;; Declaration items represent block-scoped declarations that are to
-;;; be passed through to the compiler.
-
-(define <declaration-item>
- (make-item-type "declaration-item" '(TEXT)
- (lambda (item)
- (illegal-expression-item item "Declaration"))))
-
-(define make-declaration-item
- (item-constructor <declaration-item> '(TEXT)))
-
-(define declaration-item?
- (item-predicate <declaration-item>))
-
-(define declaration-item/text
- (let ((accessor (item-accessor <declaration-item> 'TEXT)))
- (lambda (item)
- ((accessor item)))))
-\f
-;;; Body items represent sequences (e.g. BEGIN).
-
-(define <body-item>
- (make-item-type "body-item" '(COMPONENTS)
- (lambda (item)
- (compile-body-items item (body-item/components item)))))
-
-(define (compile-body-items item items)
- (let ((items (flatten-body-items items)))
- (if (not (pair? items))
- (illegal-expression-item item "Empty sequence"))
- (output/sequence
- (map (lambda (item)
- (if (binding-item? item)
- (let ((value (binding-item/value item)))
- (if (keyword-value-item? value)
- (output/sequence '())
- (output/definition (binding-item/name item)
- (compile-item/expression value))))
- (compile-item/expression item)))
- items))))
-
-(define make-body-item
- (item-constructor <body-item> '(COMPONENTS)))
-
-(define body-item?
- (item-predicate <body-item>))
-
-(define body-item/components
- (item-accessor <body-item> 'COMPONENTS))
-
-;;; Binding items represent definitions, whether top-level or
-;;; internal, keyword or variable. Null binding items are for
-;;; definitions that don't emit code.
-
-(define <binding-item>
- (make-item-type "binding-item" '(NAME VALUE)
- (lambda (item)
- (illegal-expression-item item "Definition"))))
-
-(define make-binding-item
- (item-constructor <binding-item> '(NAME VALUE)))
-
-(define binding-item?
- (item-predicate <binding-item>))
-
-(define binding-item/name
- (item-accessor <binding-item> 'NAME))
-
-(define binding-item/value
- (item-accessor <binding-item> 'VALUE))
-
-(define <null-binding-item>
- (make-item-type "null-binding-item" '()
- (lambda (item)
- (illegal-expression-item item "Definition"))))
-
-(define make-null-binding-item
- (item-constructor <null-binding-item> '()))
-
-(define null-binding-item?
- (item-predicate <null-binding-item>))
-
-(define (bind-variable! environment name)
- (let ((rename (syntactic-environment/rename environment name)))
- (syntactic-environment/define environment
- name
- (make-variable-item rename))
- rename))
-\f
-;;;; Expansion History
-;;; This records each step of the expansion process, separating it
-;;; into subproblems (really, subforms) and reductions. The history
-;;; is attached to the items that are the result of classification,
-;;; so that meaningful debugging information is available after
-;;; classification has been performed. The history is NOT preserved
-;;; by the compilation process, although it might be useful to
-;;; extract a small part of the recorded information and store it in
-;;; the output (for example, keeping track of what input form each
-;;; output form corresponds to).
-
-;;; Note: this abstraction could be implemented in a much simpler
-;;; way, to reduce memory usage. A history need not remember
-;;; anything other than the original-form for the current reduction,
-;;; plus a bit saying whether that original-form is also the current
-;;; one (for replace-reduction).
-
-(define (make-top-level-history forms environment)
- (list (list (cons forms environment))))
-
-(define (history/add-reduction form environment history)
- (and history
- (cons (cons (cons form environment)
- (car history))
- (cdr history))))
-
-(define (history/replace-reduction form environment history)
- ;; This is like ADD-REDUCTION, but it discards the current reduction
- ;; before adding a new one. This is used when the current reduction
- ;; is not interesting, such as when reducing a syntactic closure.
- (and history
- (cons (cons (cons form environment)
- (cdar history))
- (cdr history))))
-
-(define (history/add-subproblem form environment history selector)
- (and history
- (cons (list (cons form environment))
- (cons (cons selector (car history))
- (cdr history)))))
-
-(define (history/original-form history)
- (and history
- (caar (last-pair (car history)))))
-\f
-;;;; Selectors
-;;; These are used by the expansion history to record subproblem
-;;; nesting so that debugging tools can show that nesting usefully.
-;;; By using abstract selectors, it is possible to locate the cell
-;;; that holds the pointer to a given subform.
-
-(define (selector/apply selector object)
- (if (pair? selector)
- (selector/apply (cdr selector)
- (if (>= (car selector) 0)
- (list-ref object (car selector))
- (list-tail object (- (car selector)))))
- object))
-
-(define (selector/add-car selector)
- (if (and (pair? selector) (< (car selector) 0))
- (cons (- (car selector)) (cdr selector))
- (cons 0 selector)))
-
-(define (selector/add-cdr selector)
- (if (and (pair? selector) (< (car selector) 0))
- (cons (- (car selector) 1) (cdr selector))
- (cons -1 selector)))
-
-(define select-object '())
-(define select-car (selector/add-car select-object))
-(define select-cdr (selector/add-cdr select-object))
-(define select-caar (selector/add-car select-car))
-(define select-cadr (selector/add-car select-cdr))
-(define select-cdar (selector/add-cdr select-car))
-(define select-cddr (selector/add-cdr select-cdr))
-(define select-caaar (selector/add-car select-caar))
-(define select-caadr (selector/add-car select-cadr))
-(define select-cadar (selector/add-car select-cdar))
-(define select-caddr (selector/add-car select-cddr))
-(define select-cdaar (selector/add-cdr select-caar))
-(define select-cdadr (selector/add-cdr select-cadr))
-(define select-cddar (selector/add-cdr select-cdar))
-(define select-cdddr (selector/add-cdr select-cddr))
-(define select-caaaar (selector/add-car select-caaar))
-(define select-caaadr (selector/add-car select-caadr))
-(define select-caadar (selector/add-car select-cadar))
-(define select-caaddr (selector/add-car select-caddr))
-(define select-cadaar (selector/add-car select-cdaar))
-(define select-cadadr (selector/add-car select-cdadr))
-(define select-caddar (selector/add-car select-cddar))
-(define select-cadddr (selector/add-car select-cdddr))
-(define select-cdaaar (selector/add-cdr select-caaar))
-(define select-cdaadr (selector/add-cdr select-caadr))
-(define select-cdadar (selector/add-cdr select-cadar))
-(define select-cdaddr (selector/add-cdr select-caddr))
-(define select-cddaar (selector/add-cdr select-cdaar))
-(define select-cddadr (selector/add-cdr select-cdadr))
-(define select-cdddar (selector/add-cdr select-cddar))
-(define select-cddddr (selector/add-cdr select-cdddr))
-
-(define (selector/add-cadr selector)
- (selector/add-car (selector/add-cdr selector)))
-
-(define (selector/add-cddr selector)
- (selector/add-cdr (selector/add-cdr selector)))
-
-(define (select-map procedure items selector)
- (let loop ((items items) (selector selector))
- (if (pair? items)
- (cons (procedure (car items) (selector/add-car selector))
- (loop (cdr items) (selector/add-cdr selector)))
- '())))
-
-(define (select-for-each procedure items selector)
- (let loop ((items items) (selector selector))
- (if (pair? items)
- (begin
- (procedure (car items) (selector/add-car selector))
- (loop (cdr items) (selector/add-cdr selector))))))
-\f
-;;;; Utilities
-
-(define (define-classifier keyword environment classifier)
- (syntactic-environment/define environment
- keyword
- (make-classifier-item classifier)))
-
-(define (define-compiler keyword environment compiler)
- (syntactic-environment/define environment
- keyword
- (make-compiler-item compiler)))
-
-(define (define-expander keyword environment expander)
- (syntactic-environment/define environment
- keyword
- (make-expander-item expander environment)))
-
-(define (classifier->keyword classifier)
- (item->keyword (make-classifier-item classifier)))
-
-(define (compiler->keyword compiler)
- (item->keyword (make-compiler-item compiler)))
-
-(define (expander->keyword expander environment)
- (item->keyword (make-expander-item expander environment)))
-
-(define (item->keyword item)
- (let ((environment
- (make-internal-syntactic-environment null-syntactic-environment)))
- (syntactic-environment/define environment 'KEYWORD item)
- (close-syntax 'KEYWORD environment)))
-
-(define (classifier->form classifier)
- `(,(classifier->keyword classifier)))
-
-(define (compiler->form compiler)
- `(,(compiler->keyword compiler)))
-
-(define (expander->form expander environment)
- `(,(expander->keyword expander environment)))
-
-(define (capture-syntactic-environment expander)
- (classifier->form
- (lambda (form environment definition-environment history)
- form ;ignore
- (let ((form (expander environment)))
- (classify/form form
- environment
- definition-environment
- (history/replace-reduction form environment history))))))
-
-(define (capture-expansion-history expander)
- (classifier->form
- (lambda (form environment definition-environment history)
- form ;ignore
- (let ((form (expander history)))
- (classify/form form
- environment
- definition-environment
- (history/replace-reduction form environment history))))))
-
-(define (call-with-syntax-error-procedure expander)
- (capture-expansion-history
- (lambda (history)
- (expander
- (lambda rest
- (apply syntax-error history rest))))))
-
-(define (flatten-body-items items)
- (append-map item->list items))
-
-(define (item->list item)
- (if (body-item? item)
- (flatten-body-items (body-item/components item))
- (list item)))
-
-(define (reverse-syntactic-environments environment procedure)
- (capture-syntactic-environment
- (lambda (closing-environment)
- (close-syntax (procedure closing-environment) environment))))
\ No newline at end of file
(declare (usual-integrations))
\f
-(define (syntax-check pattern form history)
+(define (syntax-check pattern form)
(if (not (syntax-match? (cdr pattern) (cdr form)))
- (syntax-error history "Ill-formed special form:" form)))
+ (ill-formed-syntax form)))
(define (ill-formed-syntax form)
- (call-with-syntax-error-procedure
- (lambda (syntax-error)
- (syntax-error "Ill-formed special form:" form))))
+ (syntax-error "Ill-formed special form:" form))
(define (syntax-match? pattern object)
(let ((match-error
(syntax-match? (cdr pattern) (cdr object))))))
(else
(eqv? pattern object)))))
-\f
-;;;; Lambda lists
-
-(define (r4rs-lambda-list? object)
- (let loop ((object object) (seen '()))
- (or (null? object)
- (if (identifier? object)
- (not (memq object seen))
- (and (pair? object)
- (identifier? (car object))
- (not (memq (car object) seen))
- (loop (cdr object) (cons (car object) seen)))))))
-
-(define (mit-lambda-list? object)
- (letrec
- ((parse-required
- (lambda (object seen)
- (or (null? object)
- (if (identifier? object)
- (not (memq object seen))
- (and (pair? object)
- (cond ((eq? (car object) lambda-optional-tag)
- (and (pair? (cdr object))
- (parse-parameter (cadr object) seen
- (lambda (seen)
- (parse-optional (cddr object) seen)))))
- ((eq? (car object) lambda-rest-tag)
- (parse-rest (cdr object) seen))
- (else
- (parse-parameter (car object) seen
- (lambda (seen)
- (parse-required (cdr object) seen))))))))))
- (parse-optional
- (lambda (object seen)
- (or (null? object)
- (if (identifier? object)
- (not (memq object seen))
- (and (pair? object)
- (cond ((eq? (car object) lambda-optional-tag)
- #f)
- ((eq? (car object) lambda-rest-tag)
- (parse-rest (cdr object) seen))
- (else
- (parse-parameter (car object) seen
- (lambda (seen)
- (parse-optional (cdr object) seen))))))))))
- (parse-rest
- (lambda (object seen)
- (and (pair? object)
- (parse-parameter (car object) seen
- (lambda (seen)
- seen
- (null? (cdr object)))))))
- (parse-parameter
- (lambda (object seen k)
- (if (identifier? object)
- (and (not (memq object seen))
- (k (cons object seen)))
- (and (pair? object)
- (identifier? (car object))
- (list? (cdr object))
- (not (memq (car object) seen))
- (k (cons (car object) seen)))))))
- (parse-required object '())))
-\f
-(define (parse-mit-lambda-list lambda-list)
- (let ((required (list '()))
- (optional (list '())))
- (define (parse-parameters cell pattern)
- (let loop ((pattern pattern))
- (cond ((null? pattern) (finish #f))
- ((identifier? pattern) (finish pattern))
- ((not (pair? pattern)) (bad-lambda-list pattern))
- ((eq? (car pattern) lambda-rest-tag)
- (if (and (pair? (cdr pattern)) (null? (cddr pattern)))
- (cond ((identifier? (cadr pattern)) (finish (cadr pattern)))
- ((and (pair? (cadr pattern))
- (identifier? (caadr pattern)))
- (finish (caadr pattern)))
- (else (bad-lambda-list (cdr pattern))))
- (bad-lambda-list (cdr pattern))))
- ((eq? (car pattern) lambda-optional-tag)
- (if (eq? cell required)
- (parse-parameters optional (cdr pattern))
- (bad-lambda-list pattern)))
- ((identifier? (car pattern))
- (set-car! cell (cons (car pattern) (car cell)))
- (loop (cdr pattern)))
- ((and (pair? (car pattern)) (identifier? (caar pattern)))
- (set-car! cell (cons (caar pattern) (car cell)))
- (loop (cdr pattern)))
- (else (bad-lambda-list pattern)))))
-
- (define (finish rest)
- (let ((required (reverse! (car required)))
- (optional (reverse! (car optional))))
- (do ((parameters
- (append required optional (if rest (list rest) '()))
- (cdr parameters)))
- ((null? parameters))
- (if (memq (car parameters) (cdr parameters))
- (error "lambda list has duplicate parameter:"
- (car parameters)
- (error-irritant/noise " in")
- lambda-list)))
- (values required optional rest)))
-
- (define (bad-lambda-list pattern)
- (error "Ill-formed lambda list:" pattern))
- (parse-parameters required lambda-list)))
\ No newline at end of file
+(define (syntax-match?* patterns instance)
+ (any (lambda (pattern)
+ (syntax-match? pattern instance))
+ patterns))
\ No newline at end of file
--- /dev/null
+#| -*-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 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))
+\f
+(define (classify/form form environment definition-environment)
+ (cond ((identifier? form)
+ (let ((item (lookup-identifier form environment)))
+ (if (keyword-item? item)
+ (make-keyword-value-item
+ (strip-keyword-value-item item)
+ (make-expression-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)
+ (let ((form (syntactic-closure/form form))
+ (free-names (syntactic-closure/free-names form))
+ (closing-env (syntactic-closure/environment form)))
+ (classify/form form
+ (make-partial-syntactic-environment free-names
+ environment
+ closing-env)
+ definition-environment)))
+ ((pair? form)
+ (let ((item
+ (strip-keyword-value-item
+ (classify/expression (car form) environment))))
+ (cond ((classifier-item? item)
+ ((classifier-item/classifier item) form
+ environment
+ definition-environment))
+ ((compiler-item? item)
+ (make-expression-item
+ (let ((compiler (compiler-item/compiler item)))
+ (lambda ()
+ (compiler form environment)))))
+ ((expander-item? item)
+ (classify/form ((expander-item/expander item) form
+ environment)
+ environment
+ definition-environment))
+ (else
+ (if (not (list? (cdr form)))
+ (syntax-error "Combination must be a proper list:" form))
+ (make-expression-item
+ (let ((items (classify/expressions (cdr form) environment)))
+ (lambda ()
+ (output/combination
+ (compile-item/expression item)
+ (map compile-item/expression items)))))))))
+ (else
+ (make-expression-item (lambda () (output/constant form))))))
+
+(define (strip-keyword-value-item item)
+ (if (keyword-value-item? item)
+ (keyword-value-item/item item)
+ item))
+\f
+(define (classify/forms forms environment definition-environment)
+ (map (lambda (form)
+ (classify/form form environment definition-environment))
+ forms))
+
+(define (classify/expression expression environment)
+ (classify/form expression environment null-syntactic-environment))
+
+(define (classify/expressions expressions environment)
+ (classify/forms expressions environment null-syntactic-environment))
+
+(define (classify/body forms environment definition-environment)
+ ;; Top-level syntactic definitions affect all forms that appear
+ ;; after them, so classify FORMS in order.
+ (make-body-item
+ (let forms-loop ((forms forms) (body-items '()))
+ (if (pair? forms)
+ (let items-loop
+ ((items
+ (item->list
+ (classify/form (car forms)
+ environment
+ definition-environment)))
+ (body-items body-items))
+ (if (pair? items)
+ (items-loop (cdr items)
+ (if (null-binding-item? (car items))
+ body-items
+ (cons (car items) body-items)))
+ (forms-loop (cdr forms) body-items)))
+ (reverse! body-items)))))
+
+(define (extract-declarations-from-body items)
+ (let loop ((items items) (declarations '()) (items* '()))
+ (if (pair? items)
+ (if (declaration-item? (car items))
+ (loop (cdr items)
+ (cons (car items) declarations)
+ items*)
+ (loop (cdr items)
+ declarations
+ (cons (car items) items*)))
+ (values (reverse! declarations) (reverse! items*)))))
\ No newline at end of file
--- /dev/null
+#| -*-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 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))
+\f
+(define (compile-item/top-level item)
+ (if (binding-item? item)
+ (let ((name (binding-item/name item))
+ (value (binding-item/value item)))
+ (if (keyword-value-item? value)
+ (output/top-level-syntax-definition
+ name
+ (compile-item/expression (keyword-value-item/expression value)))
+ (output/top-level-definition
+ name
+ (compile-item/expression value))))
+ (compile-item/expression item)))
+
+(define (compile-body-item/top-level body-item)
+ (receive (declaration-items body-items)
+ (extract-declarations-from-body (body-item/components body-item))
+ (output/top-level-sequence (map declaration-item/text declaration-items)
+ (map compile-item/top-level body-items))))
+
+(define (compile-body-items items)
+ (let ((items (flatten-body-items items)))
+ (if (not (pair? items))
+ (syntax-error "Empty body"))
+ (output/sequence
+ (map (lambda (item)
+ (if (binding-item? item)
+ (let ((value (binding-item/value item)))
+ (if (keyword-value-item? value)
+ (output/sequence '())
+ (output/definition (binding-item/name item)
+ (compile-item/expression value))))
+ (compile-item/expression item)))
+ items))))
+
+(define (compile-item/expression item)
+ (let ((compiler (get-item-compiler item)))
+ (if (not compiler)
+ (error:bad-range-argument item 'COMPILE-ITEM/EXPRESSION))
+ (compiler item)))
+
+(define (get-item-compiler item)
+ (let ((entry (assq (record-type-descriptor item) item-compilers)))
+ (and entry
+ (cdr entry))))
+
+(define (define-item-compiler rtd compiler)
+ (let ((entry (assq rtd item-compilers)))
+ (if entry
+ (set-cdr! entry compiler)
+ (begin
+ (set! item-compilers (cons (cons rtd compiler) item-compilers))
+ unspecific))))
+
+(define item-compilers '())
+\f
+(define (illegal-expression-compiler description)
+ (lambda (item)
+ (syntax-error (string description " may not be used as an expression:")
+ item)))
+
+(define-item-compiler <reserved-name-item>
+ (illegal-expression-compiler "Reserved name"))
+
+(let ((compiler (illegal-expression-compiler "Syntactic keyword")))
+ (define-item-compiler <classifier-item> compiler)
+ (define-item-compiler <compiler-item> compiler)
+ (define-item-compiler <expander-item> compiler)
+ (define-item-compiler <keyword-value-item> compiler))
+
+(define-item-compiler <variable-item>
+ (lambda (item)
+ (output/variable (variable-item/name item))))
+
+(define-item-compiler <expression-item>
+ (lambda (item)
+ ((expression-item/compiler item))))
+
+(define-item-compiler <body-item>
+ (lambda (item)
+ (compile-body-items (body-item/components item))))
+
+(define-item-compiler <declaration-item>
+ (illegal-expression-compiler "Declaration"))
+
+(define-item-compiler <binding-item>
+ (illegal-expression-compiler "Definition"))
+
+(define-item-compiler <null-binding-item>
+ (illegal-expression-compiler "Definition"))
\ No newline at end of file
--- /dev/null
+#| -*-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 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.
+
+|#
+
+;;;; Declarations
+
+(declare (usual-integrations))
+\f
+(define (define-declaration name pattern mapper)
+ (let ((entry (assq name known-declarations)))
+ (if entry
+ (set-cdr! entry (cons pattern mapper))
+ (begin
+ (set! known-declarations
+ (cons (cons name (cons pattern mapper))
+ known-declarations))
+ unspecific))))
+
+(define (map-declaration-identifiers procedure declaration)
+ (if (not (pair? declaration))
+ (error "Ill-formed declaration:" declaration))
+ (let ((entry (assq (car declaration) known-declarations)))
+ (if (and entry (syntax-match? (cadr entry) (cdr declaration)))
+ ((cddr entry) declaration procedure)
+ (begin
+ (warn "Unknown declaration:" declaration)
+ declaration))))
+
+(define known-declarations '())
+
+(for-each (lambda (keyword)
+ (define-declaration keyword '()
+ (lambda (declaration procedure)
+ procedure
+ declaration)))
+ '(AUTOMAGIC-INTEGRATIONS
+ NO-AUTOMAGIC-INTEGRATIONS
+ ETA-SUBSTITUTION
+ NO-ETA-SUBSTITUTION
+ OPEN-BLOCK-OPTIMIZATIONS
+ NO-OPEN-BLOCK-OPTIMIZATIONS))
+
+(for-each (lambda (keyword)
+ (define-declaration keyword '(* IDENTIFIER)
+ (lambda (declaration procedure)
+ (cons (car declaration)
+ (map procedure (cdr declaration))))))
+ ;; The names in USUAL-INTEGRATIONS are always global.
+ '(
+ USUAL-INTEGRATIONS
+ INTEGRATE
+ INTEGRATE-OPERATOR
+ INTEGRATE-SAFELY
+ IGNORE
+ TYPE-CHECKS
+ NO-TYPE-CHECKS
+ RANGE-CHECKS
+ NO-RANGE-CHECKS
+ ))
+
+(define-declaration 'INTEGRATE-EXTERNAL
+ `(* ,(lambda (object)
+ (or (string? object)
+ (pathname? object))))
+ (lambda (declaration procedure)
+ procedure
+ declaration))
+\f
+(for-each
+ (lambda (keyword)
+ (define-declaration keyword '(DATUM)
+ (lambda (declaration procedure)
+ (list (car declaration)
+ (let loop ((varset (cadr declaration)))
+ (cond ((syntax-match? '('SET * IDENTIFIER) varset)
+ (cons (car varset)
+ (map procedure (cdr varset))))
+ ((syntax-match?* '(('UNION * DATUM)
+ ('INTERSECTION * DATUM)
+ ('DIFFERENCE DATUM DATUM))
+ varset)
+ (cons (car varset)
+ (map loop (cdr varset))))
+ (else varset)))))))
+ '(CONSTANT
+ IGNORE-ASSIGNMENT-TRAPS
+ IGNORE-REFERENCE-TRAPS
+ PURE-FUNCTION
+ SIDE-EFFECT-FREE
+ USUAL-DEFINITION
+ UUO-LINK))
+
+(define-declaration 'REPLACE-OPERATOR '(* (IDENTIFIER * (DATUM DATUM)))
+ (lambda (declaration procedure)
+ (cons (car declaration)
+ (map (lambda (rule)
+ (cons (procedure (car rule))
+ (map (lambda (clause)
+ (list (car clause)
+ (if (identifier? (cadr clause))
+ (procedure (cadr clause))
+ (cadr clause))))
+ (cdr rule))))
+ (cdr declaration)))))
+
+(define-declaration 'REDUCE-OPERATOR '(* (IDENTIFIER DATUM * DATUM))
+ (lambda (declaration procedure)
+ (cons (car declaration)
+ (map (lambda (rule)
+ (cons* (procedure (car rule))
+ (if (identifier? (cadr rule))
+ (procedure (cadr rule))
+ (cadr rule))
+ (map (lambda (clause)
+ (if (syntax-match?*
+ '(('NULL-VALUE IDENTIFIER DATUM)
+ ('SINGLETON IDENTIFIER)
+ ('WRAPPER IDENTIFIER ? DATUM))
+ clause)
+ (cons* (car clause)
+ (procedure (cadr clause))
+ (cddr clause))
+ clause))
+ (cddr rule))))
+ (cdr declaration)))))
\ No newline at end of file
--- /dev/null
+#| -*-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 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
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (create-bindings system-global-environment))
+
+(define (create-bindings environment)
+
+ (define (def name item)
+ (syntactic-environment/define environment name item))
+
+ (define (define-classifier name classifier)
+ (def name (make-classifier-item classifier)))
+
+ (define-classifier 'BEGIN classifier:begin)
+ (define-classifier 'DECLARE classifier:declare)
+ (define-classifier 'DEFINE-SYNTAX classifier:define-syntax)
+ (define-classifier 'ER-MACRO-TRANSFORMER classifier:er-macro-transformer)
+ (define-classifier 'LET-SYNTAX classifier:let-syntax)
+ (define-classifier 'LETREC classifier:letrec)
+ (define-classifier 'LETREC-SYNTAX classifier:letrec-syntax)
+ (define-classifier 'LOCAL-DECLARE classifier:local-declare)
+ (define-classifier 'NON-HYGIENIC-MACRO-TRANSFORMER
+ classifier:non-hygienic-macro-transformer)
+ (define-classifier 'RSC-MACRO-TRANSFORMER classifier:rsc-macro-transformer)
+ (define-classifier 'SC-MACRO-TRANSFORMER classifier:sc-macro-transformer)
+
+ (define (define-compiler name compiler)
+ (def name (make-compiler-item compiler)))
+
+ (define-compiler 'DELAY compiler:delay)
+ (define-compiler 'IF compiler:if)
+ (define-compiler 'LAMBDA compiler:lambda)
+ (define-compiler 'NAMED-LAMBDA compiler:named-lambda)
+ (define-compiler 'OR compiler:or)
+ (define-compiler 'QUOTE compiler:quote)
+ (define-compiler 'SET! compiler:set!)
+ (define-compiler 'THE-ENVIRONMENT compiler:the-environment))
\ No newline at end of file
--- /dev/null
+#| -*-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 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.
+
+|#
+
+;;;; Syntactic Environments
+
+(declare (usual-integrations))
+\f
+(define (syntactic-environment? object)
+ (or (internal-syntactic-environment? object)
+ (top-level-syntactic-environment? object)
+ (environment? object)
+ (partial-syntactic-environment? object)
+ (null-syntactic-environment? object)))
+
+(define-guarantee syntactic-environment "syntactic environment")
+
+(define (syntactic-environment/top-level? object)
+ (or (top-level-syntactic-environment? object)
+ (interpreter-environment? object)))
+
+(define (syntactic-environment/lookup environment name)
+ (cond ((internal-syntactic-environment? environment)
+ (internal-syntactic-environment/lookup environment name))
+ ((top-level-syntactic-environment? environment)
+ (top-level-syntactic-environment/lookup environment name))
+ ((environment? environment)
+ (and (symbol? name)
+ (environment/lookup environment name)))
+ ((partial-syntactic-environment? environment)
+ (partial-syntactic-environment/lookup environment name))
+ ((null-syntactic-environment? environment)
+ (null-syntactic-environment/lookup environment name))
+ (else
+ (error:not-syntactic-environment environment
+ 'SYNTACTIC-ENVIRONMENT/LOOKUP))))
+
+(define (syntactic-environment/define environment name item)
+ (cond ((internal-syntactic-environment? environment)
+ (internal-syntactic-environment/define environment name item))
+ ((top-level-syntactic-environment? environment)
+ (top-level-syntactic-environment/define environment name item))
+ ((environment? environment)
+ (environment/define environment name item))
+ ((partial-syntactic-environment? environment)
+ (partial-syntactic-environment/define environment name item))
+ ((null-syntactic-environment? environment)
+ (null-syntactic-environment/define environment name item))
+ (else
+ (error:not-syntactic-environment environment
+ 'SYNTACTIC-ENVIRONMENT/DEFINE))))
+
+(define (syntactic-environment/rename environment name)
+ (cond ((internal-syntactic-environment? environment)
+ (internal-syntactic-environment/rename environment name))
+ ((top-level-syntactic-environment? environment)
+ (top-level-syntactic-environment/rename environment name))
+ ((environment? environment)
+ (environment/rename environment name))
+ ((partial-syntactic-environment? environment)
+ (partial-syntactic-environment/rename environment name))
+ ((null-syntactic-environment? environment)
+ (null-syntactic-environment/rename environment name))
+ (else
+ (error:not-syntactic-environment environment
+ 'SYNTACTIC-ENVIRONMENT/RENAME))))
+
+(define (syntactic-environment->environment environment)
+ (cond ((internal-syntactic-environment? environment)
+ (internal-syntactic-environment->environment environment))
+ ((top-level-syntactic-environment? environment)
+ (top-level-syntactic-environment->environment environment))
+ ((environment? environment)
+ environment)
+ ((partial-syntactic-environment? environment)
+ (partial-syntactic-environment->environment environment))
+ ((null-syntactic-environment? environment)
+ (null-syntactic-environment->environment environment))
+ (else
+ (error:not-syntactic-environment
+ environment
+ 'SYNTACTIC-ENVIRONMENT->ENVIRONMENT))))
+
+(define (bind-variable! environment name)
+ (let ((rename (syntactic-environment/rename environment name)))
+ (syntactic-environment/define environment
+ name
+ (make-variable-item rename))
+ rename))
+\f
+;;; Null syntactic environments signal an error for any operation.
+;;; They are used as the definition environment for expressions (to
+;;; prevent illegal use of definitions) and to seal off environments
+;;; used in magic keywords.
+
+(define-record-type <null-syntactic-environment>
+ (%make-null-syntactic-environment)
+ null-syntactic-environment?)
+
+(define null-syntactic-environment
+ (%make-null-syntactic-environment))
+
+(define (null-syntactic-environment/lookup environment name)
+ environment
+ (error "Can't lookup name in null syntactic environment:" name))
+
+(define (null-syntactic-environment/define environment name item)
+ environment
+ (error "Can't bind name in null syntactic environment:" name item))
+
+(define (null-syntactic-environment/rename environment name)
+ environment
+ (error "Can't rename name in null syntactic environment:" name))
+
+(define (null-syntactic-environment->environment environment)
+ environment
+ (error "Can't evaluate in null syntactic environment."))
+
+;;; Runtime environments can be used to look up keywords, but can't be
+;;; modified.
+
+(define (environment/lookup environment name)
+ (let ((item (environment-lookup-macro environment name)))
+ (if (procedure? item)
+ ;; **** Kludge to support bootstrapping.
+ (non-hygienic-macro-transformer->expander item environment)
+ item)))
+
+(define (environment/define environment name item)
+ (environment-define-macro environment name item))
+
+(define (environment/rename environment name)
+ environment
+ (rename-top-level-identifier name))
+\f
+;;; Top-level syntactic environments represent top-level environments.
+;;; They are always layered over a real syntactic environment.
+
+(define-record-type <top-level-syntactic-environment>
+ (%make-top-level-syntactic-environment parent bound)
+ top-level-syntactic-environment?
+ (parent top-level-syntactic-environment/parent)
+ (bound top-level-syntactic-environment/bound
+ set-top-level-syntactic-environment/bound!))
+
+(define (make-top-level-syntactic-environment parent)
+ (guarantee-syntactic-environment parent
+ 'MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT)
+ (if (not (or (syntactic-environment/top-level? parent)
+ (null-syntactic-environment? parent)))
+ (error:bad-range-argument parent "top-level syntactic environment"
+ 'MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT))
+ (%make-top-level-syntactic-environment parent '()))
+
+(define (top-level-syntactic-environment/lookup environment name)
+ (let ((binding
+ (assq name (top-level-syntactic-environment/bound environment))))
+ (if binding
+ (cdr binding)
+ (syntactic-environment/lookup
+ (top-level-syntactic-environment/parent environment)
+ name))))
+
+(define (top-level-syntactic-environment/define environment name item)
+ (let ((bound (top-level-syntactic-environment/bound environment)))
+ (let ((binding (assq name bound)))
+ (if binding
+ (set-cdr! binding item)
+ (set-top-level-syntactic-environment/bound!
+ environment
+ (cons (cons name item) bound))))))
+
+(define (top-level-syntactic-environment/rename environment name)
+ environment
+ (rename-top-level-identifier name))
+
+(define (top-level-syntactic-environment->environment environment)
+ (syntactic-environment->environment
+ (top-level-syntactic-environment/parent environment)))
+\f
+;;; Internal syntactic environments represent environments created by
+;;; procedure application.
+
+(define-record-type <internal-syntactic-environment>
+ (%make-internal-syntactic-environment parent bound free rename-state)
+ internal-syntactic-environment?
+ (parent internal-syntactic-environment/parent)
+ (bound internal-syntactic-environment/bound
+ set-internal-syntactic-environment/bound!)
+ (free internal-syntactic-environment/free
+ set-internal-syntactic-environment/free!)
+ (rename-state internal-syntactic-environment/rename-state))
+
+(define (make-internal-syntactic-environment parent)
+ (guarantee-syntactic-environment parent 'MAKE-INTERNAL-SYNTACTIC-ENVIRONMENT)
+ (%make-internal-syntactic-environment parent '() '() (make-rename-id)))
+
+(define (internal-syntactic-environment/lookup environment name)
+ (let ((binding
+ (or (assq name (internal-syntactic-environment/bound environment))
+ (assq name (internal-syntactic-environment/free environment)))))
+ (if binding
+ (cdr binding)
+ (let ((item
+ (syntactic-environment/lookup
+ (internal-syntactic-environment/parent environment)
+ name)))
+ (set-internal-syntactic-environment/free!
+ environment
+ (cons (cons name item)
+ (internal-syntactic-environment/free environment)))
+ item))))
+
+(define (internal-syntactic-environment/define environment name item)
+ (cond ((assq name (internal-syntactic-environment/bound environment))
+ => (lambda (binding)
+ (set-cdr! binding item)))
+ ((assq name (internal-syntactic-environment/free environment))
+ (if (reserved-name-item? item)
+ (syntax-error "Premature reference to reserved name:" name)
+ (error "Can't define name; already free:" name)))
+ (else
+ (set-internal-syntactic-environment/bound!
+ environment
+ (cons (cons name item)
+ (internal-syntactic-environment/bound environment))))))
+
+(define (internal-syntactic-environment/rename environment name)
+ (rename-identifier
+ name
+ (internal-syntactic-environment/rename-state environment)))
+
+(define (internal-syntactic-environment->environment environment)
+ (syntactic-environment->environment
+ (internal-syntactic-environment/parent environment)))
+\f
+;;; Partial syntactic environments are used to implement syntactic
+;;; closures that have free names.
+
+(define-record-type <partial-syntactic-environment>
+ (%make-partial-syntactic-environment names
+ names-environment
+ else-environment)
+ partial-syntactic-environment?
+ (names partial-syntactic-environment/names)
+ (names-environment partial-syntactic-environment/names-environment)
+ (else-environment partial-syntactic-environment/else-environment))
+
+(define (make-partial-syntactic-environment names
+ names-environment
+ else-environment)
+ (if (or (null? names)
+ (eq? names-environment else-environment))
+ else-environment
+ (%make-partial-syntactic-environment names
+ names-environment
+ else-environment)))
+
+(define (partial-syntactic-environment/lookup environment name)
+ (syntactic-environment/lookup
+ (if (memq name (partial-syntactic-environment/names environment))
+ (partial-syntactic-environment/names-environment environment)
+ (partial-syntactic-environment/else-environment environment))
+ name))
+
+(define (partial-syntactic-environment/define environment name item)
+ ;; **** Shouldn't this be a syntax error? It can happen as the
+ ;; result of a misplaced definition. ****
+ (error "Can't bind name in partial syntactic environment:"
+ environment name item))
+
+(define (partial-syntactic-environment/rename environment name)
+ (syntactic-environment/rename
+ (if (memq name (partial-syntactic-environment/names environment))
+ (partial-syntactic-environment/names-environment environment)
+ (partial-syntactic-environment/else-environment environment))
+ name))
+
+(define (partial-syntactic-environment->environment environment)
+ ;; **** Shouldn't this be a syntax error? It can happen as the
+ ;; result of a partially-closed transformer. ****
+ (error "Can't evaluate in partial syntactic environment:" environment))
\ No newline at end of file
--- /dev/null
+#| -*-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 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 Items
+
+(declare (usual-integrations))
+\f
+;;; Reserved name items do not represent any form, but instead are
+;;; used to reserve a particular name in a syntactic environment. If
+;;; the classifier refers to a reserved name, a syntax error is
+;;; signalled. This is used in the implementation of LETREC-SYNTAX
+;;; to signal a meaningful error when one of the <init>s refers to
+;;; one of the names being bound.
+
+(define-record-type <reserved-name-item>
+ (make-reserved-name-item)
+ reserved-name-item?)
+
+;;; Keyword items represent macro keywords. There are several flavors
+;;; of keyword item.
+
+(define-record-type <classifier-item>
+ (make-classifier-item classifier)
+ classifier-item?
+ (classifier classifier-item/classifier))
+
+(define-record-type <compiler-item>
+ (make-compiler-item compiler)
+ compiler-item?
+ (compiler compiler-item/compiler))
+
+(define-record-type <expander-item>
+ (make-expander-item expander)
+ expander-item?
+ (expander expander-item/expander))
+
+(define-record-type <keyword-value-item>
+ (make-keyword-value-item item expression)
+ keyword-value-item?
+ (item keyword-value-item/item)
+ (expression keyword-value-item/expression))
+
+(define (keyword-item? item)
+ (or (classifier-item? item)
+ (compiler-item? item)
+ (expander-item? item)
+ (keyword-value-item? item)))
+
+;;; Variable items represent run-time variables.
+
+(define-record-type <variable-item>
+ (make-variable-item name)
+ variable-item?
+ (name variable-item/name))
+\f
+;;; Expression items represent any kind of expression other than a
+;;; run-time variable or a sequence.
+
+(define-record-type <expression-item>
+ (make-expression-item compiler)
+ expression-item?
+ (compiler expression-item/compiler))
+
+;;; Body items represent sequences (e.g. BEGIN).
+
+(define-record-type <body-item>
+ (make-body-item components)
+ body-item?
+ (components body-item/components))
+
+(define (flatten-body-items items)
+ (append-map item->list items))
+
+(define (item->list item)
+ (if (body-item? item)
+ (flatten-body-items (body-item/components item))
+ (list item)))
+
+;;; Declaration items represent block-scoped declarations that are to
+;;; be passed through to the compiler.
+
+(define-record-type <declaration-item>
+ (make-declaration-item get-text)
+ declaration-item?
+ (get-text declaration-item/get-text))
+
+(define (declaration-item/text item)
+ ((declaration-item/get-text item)))
+
+;;; Binding items represent definitions, whether top-level or
+;;; internal, keyword or variable. Null binding items are for
+;;; definitions that don't emit code.
+
+(define-record-type <binding-item>
+ (make-binding-item name value)
+ binding-item?
+ (name binding-item/name)
+ (value binding-item/value))
+
+(define-record-type <null-binding-item>
+ (make-null-binding-item)
+ null-binding-item?)
\ No newline at end of file
(declare (usual-integrations))
\f
-(define (syntax-error history . rest)
- history ;ignore
- (apply error rest))
-
-(define (transformer-eval expression environment)
- (eval expression environment))
+(define (transformer-eval output environment)
+ (eval output (syntactic-environment->environment environment)))
(define (output/variable name)
(make-variable name))
(make-combination (ucode-primitive lexical-assignment)
(list environment name value)))
+(define (output/runtime-reference name)
+ (output/access-reference name system-global-environment))
+
(define (output/local-declare declarations body)
(make-declaration declarations body))
-(define lambda-tag:unnamed
- ((ucode-primitive string->symbol) "#[unnamed-procedure]"))
-
-(define lambda-tag:let
- ((ucode-primitive string->symbol) "#[let-procedure]"))
-
-(define lambda-tag:fluid-let
- ((ucode-primitive string->symbol) "#[fluid-let-procedure]"))
+(define lambda-tag:unnamed '|#[unnamed-procedure]|)
+(define lambda-tag:let '|#[let-procedure]|)
+(define lambda-tag:fluid-let '|#[fluid-let-procedure]|)
\f
-;;;; Declarations
-
-(define (define-declaration name pattern mapper)
- (let ((entry (assq name known-declarations)))
- (if entry
- (set-cdr! entry (cons pattern mapper))
- (begin
- (set! known-declarations
- (cons (cons name (cons pattern mapper))
- known-declarations))
- unspecific))))
-
-(define (process-declaration declaration
- selector
- map-identifier
- ill-formed-declaration)
- (if (pair? declaration)
- (let ((entry (assq (car declaration) known-declarations)))
- (if (and entry (syntax-match? (cadr entry) (cdr declaration)))
- ((cddr entry) declaration selector map-identifier)
- (begin
- (warn "Unknown declaration:" declaration)
- declaration)))
- (ill-formed-declaration declaration selector)))
-
-(define known-declarations '())
-
-(for-each (lambda (keyword)
- (define-declaration keyword '()
- (lambda (declaration selector map-identifier)
- selector map-identifier
- declaration)))
- '(AUTOMAGIC-INTEGRATIONS
- NO-AUTOMAGIC-INTEGRATIONS
- ETA-SUBSTITUTION
- NO-ETA-SUBSTITUTION
- OPEN-BLOCK-OPTIMIZATIONS
- NO-OPEN-BLOCK-OPTIMIZATIONS))
-
-(for-each (lambda (keyword)
- (define-declaration keyword '(* IDENTIFIER)
- (lambda (declaration selector map-identifier)
- (cons (car declaration)
- (select-map map-identifier
- (cdr declaration)
- (selector/add-cdr selector))))))
- ;; The names in USUAL-INTEGRATIONS are always global.
- '(
- USUAL-INTEGRATIONS
- INTEGRATE
- INTEGRATE-OPERATOR
- INTEGRATE-SAFELY
- IGNORE
- TYPE-CHECKS
- NO-TYPE-CHECKS
- RANGE-CHECKS
- NO-RANGE-CHECKS
- ))
-
-(define-declaration 'INTEGRATE-EXTERNAL
- `(* ,(lambda (object)
- (or (string? object)
- (pathname? object))))
- (lambda (declaration selector map-identifier)
- selector map-identifier
- declaration))
-\f
-(for-each
- (lambda (keyword)
- (define-declaration keyword '(DATUM)
- (lambda (declaration selector map-identifier)
- (list (car declaration)
- (let loop
- ((varset (cadr declaration))
- (selector (selector/add-cadr selector)))
- (cond ((syntax-match? '('SET * IDENTIFIER) varset)
- (cons (car varset)
- (select-map map-identifier
- (cdr varset)
- (selector/add-cdr selector))))
- ((or (syntax-match? '('UNION * DATUM) varset)
- (syntax-match? '('INTERSECTION * DATUM) varset)
- (syntax-match? '('DIFFERENCE DATUM DATUM) varset))
- (cons (car varset)
- (select-map loop
- (cdr varset)
- (selector/add-cdr selector))))
- (else varset)))))))
- '(CONSTANT
- IGNORE-ASSIGNMENT-TRAPS
- IGNORE-REFERENCE-TRAPS
- PURE-FUNCTION
- SIDE-EFFECT-FREE
- USUAL-DEFINITION
- UUO-LINK))
-
-(define-declaration 'REPLACE-OPERATOR '(* (IDENTIFIER * (DATUM DATUM)))
- (lambda (declaration selector map-identifier)
- (cons (car declaration)
- (select-map
- (lambda (rule selector)
- (cons (map-identifier (car rule) (selector/add-car selector))
- (select-map
- (lambda (clause selector)
- (list (car clause)
- (if (identifier? (cadr clause))
- (map-identifier (cadr clause)
- (selector/add-cadr selector))
- (cadr clause))))
- (cdr rule)
- (selector/add-cdr selector))))
- (cdr declaration)
- (selector/add-cdr selector)))))
-
-(define-declaration 'REDUCE-OPERATOR '(* (IDENTIFIER DATUM * DATUM))
- (lambda (declaration selector map-identifier)
- (cons (car declaration)
- (select-map
- (lambda (rule selector)
- (cons* (map-identifier (car rule) (selector/add-car selector))
- (if (identifier? (cadr rule))
- (map-identifier (cadr rule)
- (selector/add-cadr selector))
- (cadr rule))
- (select-map
- (lambda (clause selector)
- (if (or (syntax-match? '('NULL-VALUE IDENTIFIER DATUM)
- clause)
- (syntax-match? '('SINGLETON IDENTIFIER)
- clause)
- (syntax-match? '('WRAPPER IDENTIFIER ? DATUM)
- clause))
- (cons* (car clause)
- (map-identifier (cadr clause)
- (selector/add-cadr selector))
- (cddr clause))
- clause))
- (cddr rule)
- (selector/add-cddr selector))))
- (cdr declaration)
- (selector/add-cdr selector)))))
-\f
-;;;; Identifiers
-
-(define *rename-database*)
-
-(define-structure (rename-database (constructor initial-rename-database ())
- (conc-name rename-database/))
- (frame-number 0)
- (mapping-table (make-equal-hash-table) read-only #t)
- (unmapping-table (make-eq-hash-table) read-only #t)
- (id-table (make-eq-hash-table) read-only #t))
-
-(define (make-rename-id)
- (delay
- (let ((n (+ (rename-database/frame-number *rename-database*) 1)))
- (set-rename-database/frame-number! *rename-database* n)
- n)))
-
-(define (rename-identifier identifier rename-id)
- (let ((key (cons identifier rename-id))
- (mapping-table (rename-database/mapping-table *rename-database*)))
- (or (hash-table/get mapping-table key #f)
- (let ((mapped-identifier
- (string->uninterned-symbol
- (symbol-name (identifier->symbol identifier)))))
- (hash-table/put! mapping-table key mapped-identifier)
- (hash-table/put! (rename-database/unmapping-table *rename-database*)
- mapped-identifier
- key)
- mapped-identifier))))
-
-(define (rename-top-level-identifier identifier)
- (if (symbol? identifier)
- identifier
- (rename-identifier identifier (delay 0))))
-
-(define (make-name-generator)
- (let ((id (make-rename-id)))
- (lambda (identifier)
- (rename-identifier identifier id))))
-
-;;; Post processing
+;;;; Post processing
(define (output/post-process-expression expression)
(let ((unmapping (empty-unmapping)))
(or (hash-table/get unmapping identifier #f)
(finalize-mapped-identifier identifier)))
\f
-(define (unmap-identifier identifier)
- (let ((entry
- (hash-table/get (rename-database/unmapping-table *rename-database*)
- identifier
- #f)))
- (if entry
- (identifier->symbol (car entry))
- (begin
- (if (not (symbol? identifier))
- (error:bad-range-argument identifier 'UNMAP-IDENTIFIER))
- identifier))))
-
-(define (finalize-mapped-identifier identifier)
- (let ((entry
- (hash-table/get (rename-database/unmapping-table *rename-database*)
- identifier
- #f)))
- (if entry
- (let ((identifier (car entry))
- (frame-number (force (cdr entry))))
- (if (interned-symbol? identifier)
- (map-interned-symbol identifier frame-number)
- (map-uninterned-identifier identifier frame-number)))
- (begin
- (if (not (symbol? identifier))
- (error:bad-range-argument identifier
- 'FINALIZE-MAPPED-IDENTIFIER))
- identifier))))
-
-(define (map-interned-symbol symbol frame-number)
- (string->symbol
- (string-append "."
- (symbol-name symbol)
- "."
- (number->string frame-number))))
-
-(define (map-uninterned-identifier identifier frame-number)
- (let ((table (rename-database/id-table *rename-database*))
- (symbol (identifier->symbol identifier)))
- (let ((alist (hash-table/get table symbol '())))
- (let ((entry (assv frame-number alist)))
- (if entry
- (let ((entry* (assq identifier (cdr entry))))
- (if entry*
- (cdr entry*)
- (let ((mapped-symbol
- (map-indexed-symbol symbol
- frame-number
- (length (cdr entry)))))
- (set-cdr! entry
- (cons (cons identifier mapped-symbol)
- (cdr entry)))
- mapped-symbol)))
- (let ((mapped-symbol (map-indexed-symbol symbol frame-number 0)))
- (hash-table/put! table
- symbol
- (cons (list frame-number
- (cons identifier mapped-symbol))
- alist))
- mapped-symbol))))))
-
-(define (map-indexed-symbol symbol frame-number index-number)
- (string->symbol
- (string-append "."
- (symbol-name symbol)
- "."
- (number->string frame-number)
- "-"
- (number->string index-number))))
-\f
;;;; Compute substitution
(define (compute-substitution expression unmapping)
unmapping))
(loop (cdr identifiers) (cdr unmapped)))))
free-references))
-
-;;; Reference Set
-
-(define (null-reference-set)
- '())
-
-(define (singleton-reference-set identifier)
- (list (cons identifier (unmap-identifier identifier))))
-
-(define (reference-set-union s1 s2)
- (if (pair? s1)
- (if (assq (caar s1) s2)
- (reference-set-union (cdr s1) s2)
- (cons (car s1) (reference-set-union (cdr s1) s2)))
- s2))
-
-(define (add-to-reference-set identifier reference-set)
- (if (assq identifier reference-set)
- reference-set
- (cons (cons identifier (unmap-identifier identifier)) reference-set)))
-
-(define (remove-from-reference-set identifiers reference-set)
- (delete-matching-items reference-set
- (lambda (item)
- (memq (car item) identifiers))))
-
-(define (unmapping-collision? identifier unmapped-identifier reference-set)
- (find-matching-item reference-set
- (lambda (item)
- (and (eq? unmapped-identifier (cdr item))
- (not (eq? identifier (car item)))))))
\f
(define (compute-substitution/subexpression get-subexpression)
(lambda (expression unmapping)
(define (substitute-in-declarations substitution declarations)
(map (lambda (declaration)
- (process-declaration declaration select-object
- (lambda (identifier selector)
- selector
- (substitution identifier))
- (lambda (declaration selector)
- selector
- (error "Ill-formed declaration:"
- declaration))))
+ (map-declaration-identifiers substitution declaration))
declarations))
(define (alpha-substitute/default substitution expression)
(OPEN-BLOCK ,alpha-substitute/open-block)
(SEQUENCE ,alpha-substitute/sequence)
(UNASSIGNED? ,alpha-substitute/unassigned?)
- (VARIABLE ,alpha-substitute/variable))))
\ No newline at end of file
+ (VARIABLE ,alpha-substitute/variable))))
+\f
+;;;; Identifiers
+
+(define *rename-database*)
+
+(define-structure (rename-database (constructor initial-rename-database ())
+ (conc-name rename-database/))
+ (frame-number 0)
+ (mapping-table (make-equal-hash-table) read-only #t)
+ (unmapping-table (make-eq-hash-table) read-only #t)
+ (id-table (make-eq-hash-table) read-only #t))
+
+(define (make-rename-id)
+ (delay
+ (let ((n (+ (rename-database/frame-number *rename-database*) 1)))
+ (set-rename-database/frame-number! *rename-database* n)
+ n)))
+
+(define (rename-identifier identifier rename-id)
+ (let ((key (cons identifier rename-id))
+ (mapping-table (rename-database/mapping-table *rename-database*)))
+ (or (hash-table/get mapping-table key #f)
+ (let ((mapped-identifier
+ (utf8-string->uninterned-symbol
+ (symbol-name (identifier->symbol identifier)))))
+ (hash-table/put! mapping-table key mapped-identifier)
+ (hash-table/put! (rename-database/unmapping-table *rename-database*)
+ mapped-identifier
+ key)
+ mapped-identifier))))
+
+(define (rename-top-level-identifier identifier)
+ (if (symbol? identifier)
+ identifier
+ (rename-identifier identifier (delay 0))))
+
+(define (make-name-generator)
+ (let ((id (make-rename-id)))
+ (lambda (identifier)
+ (rename-identifier identifier id))))
+\f
+(define (unmap-identifier identifier)
+ (let ((entry
+ (hash-table/get (rename-database/unmapping-table *rename-database*)
+ identifier
+ #f)))
+ (if entry
+ (identifier->symbol (car entry))
+ (begin
+ (if (not (symbol? identifier))
+ (error:bad-range-argument identifier 'UNMAP-IDENTIFIER))
+ identifier))))
+
+(define (finalize-mapped-identifier identifier)
+ (let ((entry
+ (hash-table/get (rename-database/unmapping-table *rename-database*)
+ identifier
+ #f)))
+ (if entry
+ (let ((identifier (car entry))
+ (frame-number (force (cdr entry))))
+ (if (interned-symbol? identifier)
+ (map-interned-symbol identifier frame-number)
+ (map-uninterned-identifier identifier frame-number)))
+ (begin
+ (if (not (symbol? identifier))
+ (error:bad-range-argument identifier
+ 'FINALIZE-MAPPED-IDENTIFIER))
+ identifier))))
+
+(define (map-interned-symbol symbol-to-map frame-number)
+ (symbol "." symbol-to-map "." frame-number))
+
+(define (map-uninterned-identifier identifier frame-number)
+ (let ((table (rename-database/id-table *rename-database*))
+ (symbol (identifier->symbol identifier)))
+ (let ((alist (hash-table/get table symbol '())))
+ (let ((entry (assv frame-number alist)))
+ (if entry
+ (let ((entry* (assq identifier (cdr entry))))
+ (if entry*
+ (cdr entry*)
+ (let ((mapped-symbol
+ (map-indexed-symbol symbol
+ frame-number
+ (length (cdr entry)))))
+ (set-cdr! entry
+ (cons (cons identifier mapped-symbol)
+ (cdr entry)))
+ mapped-symbol)))
+ (let ((mapped-symbol (map-indexed-symbol symbol frame-number 0)))
+ (hash-table/put! table
+ symbol
+ (cons (list frame-number
+ (cons identifier mapped-symbol))
+ alist))
+ mapped-symbol))))))
+
+(define (map-indexed-symbol symbol-to-map frame-number index-number)
+ (symbol "." symbol-to-map "." frame-number "-" index-number))
+\f
+;;;; Reference Set
+
+(define (null-reference-set)
+ '())
+
+(define (singleton-reference-set identifier)
+ (list (cons identifier (unmap-identifier identifier))))
+
+(define (reference-set-union s1 s2)
+ (if (pair? s1)
+ (if (assq (caar s1) s2)
+ (reference-set-union (cdr s1) s2)
+ (cons (car s1) (reference-set-union (cdr s1) s2)))
+ s2))
+
+(define (add-to-reference-set identifier reference-set)
+ (if (assq identifier reference-set)
+ reference-set
+ (cons (cons identifier (unmap-identifier identifier)) reference-set)))
+
+(define (remove-from-reference-set identifiers reference-set)
+ (delete-matching-items reference-set
+ (lambda (item)
+ (memq (car item) identifiers))))
+
+(define (unmapping-collision? identifier unmapped-identifier reference-set)
+ (find-matching-item reference-set
+ (lambda (item)
+ (and (eq? unmapped-identifier (cdr item))
+ (not (eq? identifier (car item)))))))
\ No newline at end of file
(declare (usual-integrations))
\f
-(define-er-macro-transformer 'SYNTAX-RULES system-global-environment
- (lambda (form rename compare)
- (call-with-syntax-error-procedure
- (lambda (syntax-error)
- (expand/syntax-rules form rename compare syntax-error)))))
-
-(define (expand/syntax-rules form rename compare syntax-error)
- (if (syntax-match? '((* IDENTIFIER) * ((IDENTIFIER . DATUM) EXPRESSION))
- (cdr form))
- (let ((keywords (cadr form))
- (clauses (cddr form)))
- (if (let loop ((keywords keywords))
- (and (pair? keywords)
- (or (memq (car keywords) (cdr keywords))
- (loop (cdr keywords)))))
- (syntax-error "Keywords list contains duplicates:" keywords)
- (let ((r-form (rename 'FORM))
- (r-rename (rename 'RENAME))
- (r-compare (rename 'COMPARE)))
- `(,(rename 'ER-MACRO-TRANSFORMER)
- (,(rename 'LAMBDA)
- (,r-form ,r-rename ,r-compare)
- ,r-compare ;prevent compiler warnings
- ,(let loop ((clauses clauses))
- (if (pair? clauses)
- (let ((pattern (caar clauses)))
- (let ((sids
- (parse-pattern rename compare keywords
- pattern r-form)))
- `(,(rename 'IF)
- ,(generate-match rename compare keywords
- r-rename r-compare
- pattern r-form)
- ,(generate-output rename compare r-rename
- sids (cadar clauses)
- syntax-error)
- ,(loop (cdr clauses)))))
- `(,(rename 'BEGIN)
- ,r-rename ;prevent compiler warnings
- (,(rename 'ILL-FORMED-SYNTAX) ,r-form)))))))))
- (syntax-error "Ill-formed special form:" form)))
+(define-syntax syntax-rules
+ (er-macro-transformer
+ (lambda (form rename compare)
+ (syntax-check '(KEYWORD (* IDENTIFIER) * ((IDENTIFIER . DATUM) EXPRESSION))
+ form)
+ (let ((keywords (cadr form))
+ (clauses (cddr form)))
+ (if (let loop ((keywords keywords))
+ (and (pair? keywords)
+ (or (memq (car keywords) (cdr keywords))
+ (loop (cdr keywords)))))
+ (syntax-error "Keywords list contains duplicates:" keywords)
+ (let ((r-form (rename 'FORM))
+ (r-rename (rename 'RENAME))
+ (r-compare (rename 'COMPARE)))
+ `(,(rename 'ER-MACRO-TRANSFORMER)
+ (,(rename 'LAMBDA)
+ (,r-form ,r-rename ,r-compare)
+ ,r-compare ;prevent compiler warnings
+ ,(let loop ((clauses clauses))
+ (if (pair? clauses)
+ (let ((pattern (caar clauses)))
+ (let ((sids
+ (parse-pattern rename compare keywords
+ pattern r-form)))
+ `(,(rename 'IF)
+ ,(generate-match rename compare keywords
+ r-rename r-compare
+ pattern r-form)
+ ,(generate-output rename compare r-rename
+ sids (cadar clauses))
+ ,(loop (cdr clauses)))))
+ `(,(rename 'BEGIN)
+ ,r-rename ;prevent compiler warnings
+ (,(rename 'ILL-FORMED-SYNTAX) ,r-form))))))))))))
(define (parse-pattern rename compare keywords pattern expression)
(let loop
(else `(,(rename 'IF) ,predicate ,consequent #F))))))
(loop pattern expression)))
\f
-(define (generate-output rename compare r-rename sids template syntax-error)
+(define (generate-output rename compare r-rename sids template)
(let loop ((template template) (ellipses '()))
(cond ((identifier? template)
(let ((sid
(loop (cdr sids)))))))
(if sid
(begin
- (add-control! sid ellipses syntax-error)
+ (add-control! sid ellipses)
(sid-expression sid))
`(,r-rename ,(syntax-quote template)))))
((or (zero-or-more? template rename compare)
ellipsis
(loop (car template)
(cons ellipsis
- ellipses))
- syntax-error))
+ ellipses))))
(loop (cddr template) ellipses)))
((pair? template)
(optimized-cons rename compare
(else
`(,(rename 'QUOTE) ,template)))))
-(define (add-control! sid ellipses syntax-error)
+(define (add-control! sid ellipses)
(let loop ((sid sid) (ellipses ellipses))
(let ((control (sid-control sid)))
(cond (control
(syntax-error "Missing ellipsis in expansion." #f))
(loop control (cdr ellipses)))))))
-(define (generate-ellipsis rename ellipsis body syntax-error)
+(define (generate-ellipsis rename ellipsis body)
(let ((sids (ellipsis-sids ellipsis)))
(if (pair? sids)
(let ((name (sid-name (car sids)))
(define (syntax-quote expression)
`(,(compiler->keyword
- (lambda (form environment history)
+ (lambda (form environment)
environment ;ignore
- (syntax-check '(KEYWORD DATUM) form history)
+ (syntax-check '(KEYWORD DATUM) form)
(output/constant (cadr form))))
,expression))
(declare (usual-integrations))
\f
-;;;; Items
-
-(define (item-constructor rtd fields)
- (let ((constructor (record-constructor rtd fields)))
- (lambda (history . arguments)
- (make-item history (apply constructor arguments)))))
-
-(define (keyword-constructor type fields)
- (let ((constructor (item-constructor type fields)))
- (lambda arguments
- (apply constructor #f arguments))))
-
-(define <item>)
-(define make-item)
-(define <expander-item>)
-(define make-expander-item)
-
-(define (initialize-syntax-transforms!)
- (set! <item>
- (make-record-type "item" '(HISTORY RECORD)))
- (set! make-item
- (record-constructor <item> '(HISTORY RECORD)))
- (set! <expander-item>
- (make-record-type "expander-item" '(EXPANDER ENVIRONMENT)))
- (set! make-expander-item
- (keyword-constructor <expander-item> '(EXPANDER ENVIRONMENT)))
- unspecific)
-
(define (sc-macro-transformer->expander transformer closing-environment)
- (make-expander-item (lambda (form environment closing-environment)
- (make-syntactic-closure closing-environment '()
- (transformer form environment)))
- closing-environment))
+ (make-expander-item
+ (lambda (form use-environment)
+ (close-syntax (transformer form use-environment)
+ closing-environment))))
(define (rsc-macro-transformer->expander transformer closing-environment)
- (make-expander-item (lambda (form environment closing-environment)
- (make-syntactic-closure environment '()
- (transformer form closing-environment)))
- closing-environment))
+ (make-expander-item
+ (lambda (form use-environment)
+ (close-syntax (transformer form closing-environment)
+ use-environment))))
(define (er-macro-transformer->expander transformer closing-environment)
(make-expander-item
- (lambda (form environment closing-environment)
- (make-syntactic-closure environment '()
- (transformer
- form
- (let ((renames '()))
- (lambda (identifier)
- (let ((association (assq identifier renames)))
- (if association
- (cdr association)
- (let ((rename
- (make-syntactic-closure closing-environment '()
- identifier)))
- (set! renames (cons (cons identifier rename) renames))
- rename)))))
- (lambda (x y)
- (identifier=? environment x environment y)))))
- closing-environment))
+ (lambda (form use-environment)
+ (close-syntax (transformer form
+ (make-er-rename closing-environment)
+ (make-er-compare use-environment))
+ use-environment))))
+
+(define (make-er-rename closing-environment)
+ (let ((renames '()))
+ (lambda (identifier)
+ (let ((p (assq identifier renames)))
+ (if p
+ (cdr p)
+ (let ((rename (close-syntax identifier closing-environment)))
+ (set! renames (cons (cons identifier rename) renames))
+ rename))))))
+
+(define (make-er-compare use-environment)
+ (lambda (x y)
+ (identifier=? use-environment x
+ use-environment y)))
(define (non-hygienic-macro-transformer->expander transformer
closing-environment)
- (make-expander-item (lambda (form environment closing-environment)
- closing-environment
- (make-syntactic-closure environment '()
- (apply transformer (cdr form))))
- closing-environment))
+ closing-environment
+ (make-expander-item
+ (lambda (form use-environment)
+ (close-syntax (apply transformer (cdr form))
+ use-environment))))
(define (syntactic-keyword->item keyword environment)
(let ((item (environment-lookup-macro environment keyword)))
--- /dev/null
+#| -*-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 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.
+
+|#
+
+;;;; Syntactic Closures
+;;; Based on a design by Alan Bawden.
+
+;;; This is a two-stage program: the first stage classifies input
+;;; expressions into types, e.g. "definition", "lambda body",
+;;; "expression", etc., and the second stage compiles those classified
+;;; expressions ("items") into output code. The classification stage
+;;; permits discovery of internal definitions prior to code
+;;; generation. It also identifies keywords and variables, which
+;;; allows a powerful form of syntactic binding to be implemented.
+
+;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in
+;;; Proceedings of the 1988 ACM Conference on Lisp and Functional
+;;; Programming, page 86.
+
+(declare (usual-integrations))
+\f
+;;;; Top level
+
+(define (syntax form environment)
+ (syntax* (list form) environment))
+
+(define (syntax* forms environment)
+ (guarantee-list forms 'SYNTAX*)
+ (guarantee-syntactic-environment environment 'SYNTAX*)
+ (fluid-let ((*rename-database* (initial-rename-database)))
+ (output/post-process-expression
+ (if (syntactic-environment/top-level? environment)
+ (compile-body-item/top-level
+ (let ((environment
+ (make-top-level-syntactic-environment environment)))
+ (classify/body forms
+ environment
+ environment)))
+ (output/sequence (compile/expressions forms environment))))))
+
+(define (compile/expression expression environment)
+ (compile-item/expression (classify/expression expression environment)))
+
+(define (compile/expressions expressions environment)
+ (map (lambda (expression)
+ (compile/expression expression environment))
+ expressions))
+\f
+;;;; Syntactic closures
+
+(define-record-type <syntactic-closure>
+ (%make-syntactic-closure environment free-names form)
+ syntactic-closure?
+ (environment syntactic-closure/environment)
+ (free-names syntactic-closure/free-names)
+ (form syntactic-closure/form))
+
+(define-guarantee syntactic-closure "syntactic closure")
+
+(define (make-syntactic-closure environment free-names form)
+ (guarantee-syntactic-environment environment 'MAKE-SYNTACTIC-CLOSURE)
+ (guarantee-list-of-type free-names identifier?
+ "list of identifiers" 'MAKE-SYNTACTIC-CLOSURE)
+ (if (or (memq form free-names) ;LOOKUP-IDENTIFIER assumes this.
+ (and (syntactic-closure? form)
+ (null? (syntactic-closure/free-names form))
+ (not (identifier? (syntactic-closure/form form))))
+ (not (or (syntactic-closure? form)
+ (pair? form)
+ (symbol? form))))
+ form
+ (%make-syntactic-closure environment free-names form)))
+
+(define (strip-syntactic-closures object)
+ (if (let loop ((object object))
+ (if (pair? object)
+ (or (loop (car object))
+ (loop (cdr object)))
+ (syntactic-closure? object)))
+ (let loop ((object object))
+ (if (pair? object)
+ (cons (loop (car object))
+ (loop (cdr object)))
+ (if (syntactic-closure? object)
+ (loop (syntactic-closure/form object))
+ object)))
+ object))
+
+(define (close-syntax form environment)
+ (make-syntactic-closure environment '() form))
+\f
+;;;; Identifiers
+
+(define (identifier? object)
+ (or (symbol? object)
+ (synthetic-identifier? object)))
+
+(define (synthetic-identifier? object)
+ (and (syntactic-closure? object)
+ (identifier? (syntactic-closure/form object))))
+
+(define-guarantee identifier "identifier")
+(define-guarantee synthetic-identifier "synthetic identifier")
+
+(define (make-synthetic-identifier identifier)
+ (close-syntax identifier null-syntactic-environment))
+
+(define (identifier->symbol identifier)
+ (or (let loop ((identifier identifier))
+ (if (syntactic-closure? identifier)
+ (loop (syntactic-closure/form identifier))
+ (and (symbol? identifier)
+ identifier)))
+ (error:not-identifier identifier 'IDENTIFIER->SYMBOL)))
+
+(define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
+ (let ((item-1 (lookup-identifier identifier-1 environment-1))
+ (item-2 (lookup-identifier identifier-2 environment-2)))
+ (or (eq? item-1 item-2)
+ ;; This is necessary because an identifier that is not
+ ;; explicitly bound by an environment is mapped to a variable
+ ;; item, and the variable items are not cached. Therefore
+ ;; two references to the same variable result in two
+ ;; different variable items.
+ (and (variable-item? item-1)
+ (variable-item? item-2)
+ (eq? (variable-item/name item-1)
+ (variable-item/name item-2))))))
+
+(define (lookup-identifier identifier environment)
+ (let ((item (syntactic-environment/lookup environment identifier)))
+ (cond (item
+ (if (reserved-name-item? item)
+ (syntax-error "Premature reference to reserved name:" identifier)
+ item))
+ ((symbol? identifier)
+ (make-variable-item identifier))
+ ((syntactic-closure? identifier)
+ (lookup-identifier (syntactic-closure/form identifier)
+ (syntactic-closure/environment identifier)))
+ (else
+ (error:not-identifier identifier 'LOOKUP-IDENTIFIER)))))
+\f
+;;;; Utilities
+
+(define (syntax-error . rest)
+ (apply error rest))
+
+(define (classifier->keyword classifier)
+ (item->keyword (make-classifier-item classifier)))
+
+(define (compiler->keyword compiler)
+ (item->keyword (make-compiler-item compiler)))
+
+(define (item->keyword item)
+ (let ((environment
+ (make-internal-syntactic-environment null-syntactic-environment)))
+ (syntactic-environment/define environment 'KEYWORD item)
+ (close-syntax 'KEYWORD environment)))
+
+(define (capture-syntactic-environment expander)
+ `(,(classifier->keyword
+ (lambda (form environment definition-environment)
+ form ;ignore
+ (classify/form (expander environment)
+ environment
+ definition-environment)))))
+
+(define (reverse-syntactic-environments environment procedure)
+ (capture-syntactic-environment
+ (lambda (closing-environment)
+ (close-syntax (procedure closing-environment) environment))))
\ No newline at end of file
(er-macro-transformer
(lambda (form rename compare)
compare
- (parse-define-form form rename
- (lambda (name value)
- `(,(rename 'BEGIN)
- (,(rename 'DEFINE) ,name)
- (,(rename 'ADD-BOOT-INIT!)
- (,(rename 'LAMBDA) ()
- (,(rename 'SET!) ,name ,value)
- ,(rename 'UNSPECIFIC)))))))))
\ No newline at end of file
+ (receive (name value)
+ (parse-define-form form rename)
+ `(,(rename 'BEGIN)
+ (,(rename 'DEFINE) ,name)
+ (,(rename 'ADD-BOOT-INIT!)
+ (,(rename 'LAMBDA) ()
+ (,(rename 'SET!) ,name ,value)
+ ,(rename 'UNSPECIFIC))))))))
\ No newline at end of file
((eq? object #t) (*unparse-string "#t"))
((default-object? object) (*unparse-string "#!default"))
((eof-object? object) (*unparse-string "#!eof"))
- ((eq? object lambda-aux-tag) (*unparse-string "#!aux"))
- ((eq? object lambda-key-tag) (*unparse-string "#!key"))
- ((eq? object lambda-optional-tag) (*unparse-string "#!optional"))
- ((eq? object lambda-rest-tag) (*unparse-string "#!rest"))
+ ((eq? object lambda-tag:aux) (*unparse-string "#!aux"))
+ ((eq? object lambda-tag:key) (*unparse-string "#!key"))
+ ((eq? object lambda-tag:optional) (*unparse-string "#!optional"))
+ ((eq? object lambda-tag:rest) (*unparse-string "#!rest"))
((eq? object unspecific) (*unparse-string "#!unspecific"))
(else (unparse/default object))))
(define (lambda-list required optional rest auxiliary)
(let ((optional (if (null? optional)
'()
- (cons lambda-optional-tag optional)))
+ (cons lambda-tag:optional optional)))
(rest (cond ((not rest) '())
((null? auxiliary) rest)
- (else (list lambda-rest-tag rest)))))
+ (else (list lambda-tag:rest rest)))))
(if (null? auxiliary)
`(,@required ,@optional . ,rest)
- `(,@required ,@optional ,@rest ,lambda-aux-tag ,@auxiliary))))
+ `(,@required ,@optional ,@rest ,lambda-tag:aux ,@auxiliary))))
(define (lambda-components** expression receiver)
(lambda-components expression
integrate/top-level
integrate/get-top-level-block
reassign
- variable/final-value)
- (import (runtime parser)
- lambda-optional-tag))
+ variable/final-value))
(define-package (scode-optimizer cgen)
(files "cgen")
(let ((arg-list (append (procedure/required procedure)
(if (null? (procedure/optional procedure))
'()
- (cons lambda-optional-tag
+ (cons lambda-tag:optional
(procedure/optional procedure)))
(if (not (procedure/rest procedure))
'()
projects / mit-scheme.git / commitdiff