#| -*-Scheme-*-
-$Id: macros.scm,v 1.5 2001/12/20 18:03:05 cph Exp $
+$Id: macros.scm,v 1.6 2001/12/21 18:22:15 cph Exp $
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
\f
(define (initialize-package!)
(for-each (lambda (keyword transform)
- (syntax-table/define system-global-environment
- keyword
- transform))
+ (environment-define-macro system-global-environment
+ keyword
+ transform))
'(AND
CASE
CONS-STREAM
#| -*-Scheme-*-
-$Id: make.scm,v 14.79 2001/12/21 05:17:59 cph Exp $
+$Id: make.scm,v 14.80 2001/12/21 18:22:20 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
names)
parent)
values))))
-
-(define environment-define-macro)
\f
(let ((environment-for-package
(*make-environment system-global-environment
(define-integrable substring-move-right!
(ucode-primitive substring-move-right!))
-;; This definition is replaced later in the boot sequence.
-(set! environment-define-macro
- (lambda (environment name transformer)
- (local-assignment environment
- name
- ((ucode-primitive primitive-object-set-type)
- (ucode-type reference-trap)
- (cons 15 transformer)))))
-
(define microcode-identification (microcode-identify))
(define os-name-string (vector-ref microcode-identification 8))
(define tty-output-descriptor (tty-output-channel))
(RUNTIME SCODE-WALKER)
(RUNTIME CONTINUATION-PARSER)
(RUNTIME PROGRAM-COPIER)
- (RUNTIME ENVIRONMENT)
;; Generic Procedures
((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING! #t)
((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES! #t)
(RUNTIME SYNTAXER)
(RUNTIME ILLEGAL-DEFINITIONS)
(RUNTIME MACROS)
- (RUNTIME SYSTEM-MACROS)
((RUNTIME DEFSTRUCT) INITIALIZE-DEFINE-STRUCTURE-MACRO! #t)
(RUNTIME UNSYNTAXER)
(RUNTIME PRETTY-PRINTER)
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.399 2001/12/21 05:18:12 cph Exp $
+$Id: runtime.pkg,v 14.400 2001/12/21 18:22:33 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
environment-bound-names
environment-bound?
environment-define
- ;; Defined in "make.scm":
- ;; environment-define-macro
+ environment-define-macro
environment-has-parent?
environment-lambda
environment-lookup
(define-package (runtime macros)
(files "macros")
(parent (runtime))
+ #|
+ (export ()
+ and
+ case
+ cons-stream
+ define-integrable
+ do
+ let*
+ letrec
+ quasiquote
+ sequence)
+ |#
(initialization (initialize-package!)))
(define-package (runtime microcode-errors)
(export ()
cached-reference-trap-value
cached-reference-trap?
- macro->reference-trap
+ macro-reference-trap-transformer
macro-reference-trap?
- macro->unmapped-reference-trap
+ make-macro-reference-trap
make-unassigned-reference-trap
make-unbound-reference-trap
+ make-unmapped-macro-reference-trap
make-unmapped-unassigned-reference-trap
make-unmapped-unbound-reference-trap
map-reference-trap
map-reference-trap-value
- reference-trap->macro
reference-trap-kind
reference-trap-kind-name
reference-trap?
unassigned-reference-trap?
unbound-reference-trap?
unmap-reference-trap
+ unmapped-macro-reference-trap?
unmapped-unassigned-reference-trap?
unmapped-unbound-reference-trap?))
(files "syntab")
(parent (runtime))
(export ()
- environment-syntax-table
guarantee-syntax-table
make-syntax-table
- set-environment-syntax-table!
- syntax-table/copy
syntax-table/define
- syntax-table/defined-names
- syntax-table/extend
- syntax-table/parent
syntax-table/ref
- syntax-table?))
+ syntax-table?)
+ (export (runtime syntaxer)
+ syntax-table/environment
+ syntax-table/extend))
(define-package (runtime syntaxer)
(files "syntax")
(define-package (runtime system-macros)
(files "sysmac")
(parent (runtime))
- (initialization (initialize-package!)))
+ (export (runtime)
+ define-primitives
+ ucode-primitive
+ ucode-return-address
+ ucode-type))
(define-package (runtime truncated-string-output)
(files "strott")
#| -*-Scheme-*-
-$Id: syntab.scm,v 14.8 2001/12/20 06:52:49 cph Exp $
+$Id: syntab.scm,v 14.9 2001/12/21 18:22:36 cph Exp $
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
(predicate %syntax-table?)
(conc-name syntax-table/))
alist
- (%parent #f read-only #t))
+ (parent #f read-only #t))
(define (syntax-table? object)
(or (%syntax-table? object)
- (interpreter-environment? object)))
+ (environment? object)))
-(define (make-syntax-table #!optional parent)
- (%make-syntax-table '()
- (if (default-object? parent)
- #f
- (guarantee-syntax-table parent 'MAKE-SYNTAX-TABLE))))
+(define (make-syntax-table parent)
+ (guarantee-syntax-table parent 'MAKE-SYNTAX-TABLE)
+ (%make-syntax-table '() parent))
(define (guarantee-syntax-table table procedure)
- (cond ((%syntax-table? table) table)
- ((interpreter-environment? table) (environment-syntax-table table))
- (else (error:wrong-type-argument table "syntax table" procedure))))
-
-(define (syntax-table/parent table)
- (syntax-table/%parent (guarantee-syntax-table table 'SYNTAX-TABLE/PARENT)))
+ (if (not (syntax-table? table))
+ (error:wrong-type-argument table "syntax table" procedure))
+ table)
(define (syntax-table/ref table name)
- (let loop ((table (guarantee-syntax-table table 'SYNTAX-TABLE/REF)))
- (and table
- (let ((entry (assq name (syntax-table/alist table))))
- (if entry
- (cdr entry)
- (loop (syntax-table/%parent table)))))))
+ (guarantee-syntax-table table 'SYNTAX-TABLE/REF)
+ (let loop ((table table))
+ (if (%syntax-table? table)
+ (let ((entry (assq name (syntax-table/alist table))))
+ (if entry
+ (cdr entry)
+ (let ((parent (syntax-table/parent table)))
+ (if (eq? parent 'NONE)
+ #f
+ (loop parent)))))
+ (and (environment-bound? table name)
+ (environment-lookup-macro table name)))))
(define (syntax-table/define table name transform)
- (let ((table (guarantee-syntax-table table 'SYNTAX-TABLE/DEFINE)))
- (let ((entry (assq name (syntax-table/alist table))))
- (if entry
- (set-cdr! entry transform)
- (set-syntax-table/alist! table
- (cons (cons name transform)
- (syntax-table/alist table)))))))
-
-(define (syntax-table/defined-names table)
- (map car
- (syntax-table/alist
- (guarantee-syntax-table table 'SYNTAX-TABLE/DEFINED-NAMES))))
-
-(define (syntax-table/copy table)
- (let loop ((table (guarantee-syntax-table table 'SYNTAX-TABLE/COPY)))
- (and table
- (%make-syntax-table (alist-copy (syntax-table/alist table))
- (loop (syntax-table/%parent table))))))
+ (guarantee-syntax-table table 'SYNTAX-TABLE/DEFINE)
+ (if (%syntax-table? table)
+ (let ((entry (assq name (syntax-table/alist table))))
+ (if entry
+ (set-cdr! entry transform)
+ (set-syntax-table/alist! table
+ (cons (cons name transform)
+ (syntax-table/alist table)))))
+ (environment-define-macro table name transform)))
(define (syntax-table/extend table alist)
- (%make-syntax-table (alist-copy alist)
- (guarantee-syntax-table table 'SYNTAX-TABLE/EXTEND)))
-
-(define (environment-syntax-table environment)
- (environment-lookup environment syntax-table-tag))
-
-(define (set-environment-syntax-table! environment table)
- (environment-define environment
- syntax-table-tag
- (guarantee-syntax-table table
- 'SET-ENVIRONMENT-SYNTAX-TABLE!)))
-
-(define-integrable syntax-table-tag
- ((ucode-primitive string->symbol)
- "#[(runtime syntax-table)syntax-table-tag]"))
\ No newline at end of file
+ (guarantee-syntax-table table 'SYNTAX-TABLE/EXTEND)
+ (%make-syntax-table (alist-copy alist) table))
+
+(define (syntax-table/environment table)
+ (guarantee-syntax-table table 'SYNTAX-TABLE/ENVIRONMENT)
+ (let loop ((table table))
+ (if (%syntax-table? table)
+ (loop (syntax-table/parent table))
+ table)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: syntax.scm,v 14.47 2001/12/21 05:18:17 cph Exp $
+$Id: syntax.scm,v 14.48 2001/12/21 18:22:41 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(enable-scan-defines!)
(set! *disallow-illegal-definitions?* #t)
(set! hook/syntax-expression default/syntax-expression)
- (set-environment-syntax-table! system-global-environment (make-syntax-table))
- (install-system-global-syntax!)
- (set-environment-syntax-table! user-initial-environment
- (make-syntax-table system-global-environment))
- (set! syntaxer/default-environment
- (extend-interpreter-environment system-global-environment))
- unspecific)
+ (install-system-global-syntax!))
(define *syntax-table*)
(define *current-keyword* #f)
(define *disallow-illegal-definitions?*)
(define (install-system-global-syntax!)
- (for-each (lambda (entry)
- (syntax-table/define system-global-environment
- (car entry)
- (make-primitive-syntaxer (cadr entry))))
- `(
- ;; R*RS special forms
- (BEGIN ,syntax/begin)
- (COND ,syntax/cond)
- (DEFINE ,syntax/define)
- (DELAY ,syntax/delay)
- (IF ,syntax/if)
- (LAMBDA ,syntax/lambda)
- (LET ,syntax/let)
- (OR ,syntax/or)
- (QUOTE ,syntax/quote)
- (SET! ,syntax/set!)
-
- ;; Syntax extensions
- (DEFINE-SYNTAX ,syntax/define-syntax)
- (LET-SYNTAX ,syntax/let-syntax)
-
- ;; Environment extensions
- (ACCESS ,syntax/access)
- (THE-ENVIRONMENT ,syntax/the-environment)
- (UNASSIGNED? ,syntax/unassigned?)
- ;; To facilitate upgrade to new option argument mechanism.
- (DEFAULT-OBJECT? ,syntax/unassigned?)
-
- ;; Miscellaneous extensions
- (DECLARE ,syntax/declare)
- (FLUID-LET ,syntax/fluid-let)
- (LOCAL-DECLARE ,syntax/local-declare)
- (NAMED-LAMBDA ,syntax/named-lambda))))
+ (for-each
+ (lambda (entry)
+ (environment-define-macro system-global-environment
+ (car entry)
+ (make-primitive-syntaxer (cadr entry))))
+ `(
+ ;; R*RS special forms
+ (BEGIN ,syntax/begin)
+ (COND ,syntax/cond)
+ (DEFINE ,syntax/define)
+ (DELAY ,syntax/delay)
+ (IF ,syntax/if)
+ (LAMBDA ,syntax/lambda)
+ (LET ,syntax/let)
+ (OR ,syntax/or)
+ (QUOTE ,syntax/quote)
+ (SET! ,syntax/set!)
+
+ ;; Syntax extensions
+ (DEFINE-SYNTAX ,syntax/define-syntax)
+ (LET-SYNTAX ,syntax/let-syntax)
+
+ ;; Environment extensions
+ (ACCESS ,syntax/access)
+ (THE-ENVIRONMENT ,syntax/the-environment)
+ (UNASSIGNED? ,syntax/unassigned?)
+ ;; To facilitate upgrade to new option argument mechanism.
+ (DEFAULT-OBJECT? ,syntax/unassigned?)
+
+ ;; Miscellaneous extensions
+ (DECLARE ,syntax/declare)
+ (FLUID-LET ,syntax/fluid-let)
+ (LOCAL-DECLARE ,syntax/local-declare)
+ (NAMED-LAMBDA ,syntax/named-lambda))))
\f
;;;; Top Level Syntaxers
(fluid-let ((*syntax-table*
(if (eq? table 'DEFAULT)
(if (unassigned? *syntax-table*)
- (environment-syntax-table
- (nearest-repl/environment))
+ (nearest-repl/environment)
*syntax-table*)
(guarantee-syntax-table table name)))
(*current-keyword* #f))
((pair? expression)
(if (not (list? expression))
(error "syntax-expression: not a valid expression" expression))
- (let ((transform (syntax-table/ref syntax-table (car expression))))
+ (let ((transform
+ (and (symbol? (car expression))
+ (syntax-table/ref syntax-table (car expression)))))
(if transform
(if (primitive-syntaxer? transform)
(transform-apply (primitive-syntaxer/transform transform)
top-level?
(let ((make-definition
(lambda (name value)
- (if (syntax-table/ref *syntax-table* name)
- (syntax-error "redefinition of syntactic keyword" name))
(make-definition name value))))
(cond ((symbol? pattern)
(make-definition
(define (syntax/define-syntax top-level? name value)
(if (not (symbol? name))
(syntax-error "illegal name" name))
- (syntax-table/define *syntax-table*
- name
- (syntax-eval (syntax-subexpression value)))
- (if top-level?
- (syntax-expression
- top-level?
- `((ACCESS ENVIRONMENT-DEFINE-MACRO #F) (THE-ENVIRONMENT) ',name ,value))
- name))
-
-(define-integrable (syntax-eval scode)
- (extended-scode-eval scode syntaxer/default-environment))
-
-(define syntaxer/default-environment)
+ (let ((value (syntax-subexpression value)))
+ (syntax-table/define *syntax-table* name (syntax-eval value))
+ (if top-level?
+ (make-definition name (make-macro-reference-trap value))
+ name)))
+
+(define (syntax-eval scode)
+ (extended-scode-eval scode (syntax-table/environment *syntax-table*)))
\f
;;;; FLUID-LET
#| -*-Scheme-*-
-$Id: sysmac.scm,v 14.5 2001/12/19 21:41:14 cph Exp $
+$Id: sysmac.scm,v 14.6 2001/12/21 18:22:44 cph Exp $
Copyright (c) 1988, 1999, 2001 Massachusetts Institute of Technology
(declare (usual-integrations))
-(define (initialize-package!)
- (let ((environment (->environment '(RUNTIME))))
- (set-environment-syntax-table! environment
- (make-syntax-table (->environment '())))
- (for-each (lambda (entry)
- (syntax-table/define environment (car entry) (cadr entry)))
- `((DEFINE-PRIMITIVES ,transform/define-primitives)
- (UCODE-PRIMITIVE ,transform/ucode-primitive)
- (UCODE-RETURN-ADDRESS ,transform/ucode-return-address)
- (UCODE-TYPE ,transform/ucode-type)))))
-
-(define transform/define-primitives
+(define-syntax define-primitives
(let ((primitive-definition
(lambda (variable-name primitive-args)
`(DEFINE-INTEGRABLE ,variable-name
(primitive-definition (car name) (cdr name)))))
names)))))
-(define transform/ucode-type
+(define-syntax ucode-type
(lambda arguments
(apply microcode-type arguments)))
-(define transform/ucode-primitive
+(define-syntax ucode-primitive
(lambda arguments
(apply make-primitive-procedure arguments)))
-(define transform/ucode-return-address
+(define-syntax ucode-return-address
(lambda arguments
(make-return-address (apply microcode-return arguments))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: uenvir.scm,v 14.49 2001/12/21 05:18:22 cph Exp $
+$Id: uenvir.scm,v 14.50 2001/12/21 18:22:49 cph Exp $
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (initialize-package!)
- ;; This variable is predefined in "make.scm" for the boot sequence.
- ;; Otherwise it would be defined here.
- (set! environment-define-macro real-environment-define-macro)
- unspecific)
-
(define (environment? object)
(or (system-global-environment? object)
(ic-environment? object)
(else
(illegal-environment environment 'ENVIRONMENT-DEFINE))))
-(define real-environment-define-macro
- (named-lambda (environment-define-macro environment name value)
- (cond ((interpreter-environment? environment)
- (interpreter-environment/define-macro environment name value))
- ((or (stack-ccenv? environment)
- (closure-ccenv? environment))
- (error:bad-range-argument environment 'ENVIRONMENT-DEFINE-MACRO))
- (else
- (illegal-environment environment 'ENVIRONMENT-DEFINE-MACRO)))))
+(define (environment-define-macro environment name value)
+ (cond ((interpreter-environment? environment)
+ (interpreter-environment/define-macro environment name value))
+ ((or (stack-ccenv? environment)
+ (closure-ccenv? environment))
+ (error:bad-range-argument environment 'ENVIRONMENT-DEFINE-MACRO))
+ (else
+ (illegal-environment environment 'ENVIRONMENT-DEFINE-MACRO))))
(define (illegal-environment object procedure)
(error:wrong-type-argument object "environment" procedure))
(define (interpreter-environment/lookup-macro environment name)
(let ((value (safe-lexical-reference environment name)))
(and (macro-reference-trap? value)
- (reference-trap->macro value))))
+ (macro-reference-trap-transformer value))))
(define (interpreter-environment/assign! environment name value)
(lexical-assignment environment name value)
(local-assignment environment name value))
(define (interpreter-environment/define-macro environment name value)
- (local-assignment environment name (macro->unmapped-reference-trap value)))
+ (local-assignment environment name
+ (make-unmapped-macro-reference-trap value)))
\f
(define (ic-environment/bound-names environment)
(map-ic-environment-bindings environment
(define (stack-ccenv/bound? environment name)
(or (dbg-block/find-name (stack-ccenv/block environment) name)
- (let ((parent (stack-ccenv/parent environment)))
- (and parent
- (environment-bound? parent name)))))
+ (environment-bound? (stack-ccenv/parent environment) name)))
(define (stack-ccenv/assigned? environment name)
(and (stack-ccenv/lookup environment name) #t))
(closure-ccenv/variable-bound?
environment
(vector-ref (dbg-block/layout-vector block) index)))))
- (let ((parent (closure-ccenv/parent environment)))
- (and parent
- (environment-bound? parent name)))))
+ (environment-bound? (closure-ccenv/parent environment) name)))
(define (closure-ccenv/assigned? environment name)
(and (closure-ccenv/lookup environment name) #t))
#| -*-Scheme-*-
-$Id: unsyn.scm,v 14.24 2001/12/20 20:32:02 cph Exp $
+$Id: unsyn.scm,v 14.25 2001/12/21 18:22:53 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
`(SET! ,name ,@(unexpand-binding-value value)))))
(define (unexpand-definition name value)
- (if (and (eq? #t unsyntaxer:macroize?)
- (lambda? value)
- (not (has-substitution? value)))
- (lambda-components** value
- (lambda (lambda-name required optional rest body)
- (if (eq? lambda-name name)
- `(DEFINE (,name . ,(lambda-list required optional rest '()))
- ,@(with-bindings required optional rest
- unsyntax-sequence body))
- `(DEFINE ,name ,@(unexpand-binding-value value)))))
- `(DEFINE ,name ,@(unexpand-binding-value value))))
+ (cond ((macro-reference-trap? value)
+ `(DEFINE-SYNTAX ,name
+ ,(macro-reference-trap-transformer value)))
+ ((and (eq? #t unsyntaxer:macroize?)
+ (lambda? value)
+ (not (has-substitution? value)))
+ (lambda-components** value
+ (lambda (lambda-name required optional rest body)
+ (if (eq? lambda-name name)
+ `(DEFINE (,name . ,(lambda-list required optional rest '()))
+ ,@(with-bindings required optional rest
+ unsyntax-sequence body))
+ `(DEFINE ,name ,@(unexpand-binding-value value))))))
+ (else
+ `(DEFINE ,name ,@(unexpand-binding-value value)))))
(define (unexpand-binding-value value)
(if (unassigned-reference-trap? value)
#| -*-Scheme-*-
-$Id: urtrap.scm,v 14.8 2001/12/21 04:37:56 cph Exp $
+$Id: urtrap.scm,v 14.9 2001/12/21 18:22:57 cph Exp $
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
(cached-reference-trap-value value)
value)))
-(define (macro->reference-trap transformer)
+(define (make-macro-reference-trap transformer)
(make-reference-trap 15 transformer))
(define (macro-reference-trap? object)
(and (reference-trap? object)
(fix:= 15 (reference-trap-kind object))))
-(define (reference-trap->macro trap)
+(define (macro-reference-trap-transformer trap)
(if (not (macro-reference-trap? trap))
(error:wrong-type-argument trap "macro reference trap"
- 'MACRO-REFERENCE-TRAP-VALUE))
+ 'MACRO-REFERENCE-TRAP-TRANSFORMER))
(reference-trap-extra trap))
-(define (macro->unmapped-reference-trap transformer)
+(define (make-unmapped-macro-reference-trap transformer)
(primitive-object-set-type (ucode-type reference-trap)
- (cons 15 transformer)))
\ No newline at end of file
+ (cons 15 transformer)))
+
+(define (unmapped-macro-reference-trap? getter)
+ (and (primitive-object-type? (ucode-type reference-trap) (getter))
+ (let ((index (object-datum (getter))))
+ (and (> index trap-max-immediate)
+ (fix:= 15 (primitive-object-ref (getter) 0))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff