\f
(define with-instance-variables
(make-unmapped-macro-reference-trap
- (make-compiler-item
+ (compiler-item
(lambda (form environment)
(syntax-check '(KEYWORD IDENTIFIER EXPRESSION (* IDENTIFIER) + EXPRESSION)
form)
with-instance-variables)
(import (runtime syntax)
compile/expression
- make-compiler-item))
+ compiler-item))
(define-package (edwin class-macros transform-instance-variables)
(files "xform")
(define (unbound? env name)
(eq? 'unbound (environment-reference-type env name)))
- (let ((env (->environment '())))
+ (define (provide-rename env old-name new-name)
+ (if (unbound? env new-name)
+ (eval `(define ,new-name ,old-name) env)))
- (define (provide-rename new-name old-name)
- (if (unbound? env new-name)
- (eval `(define ,new-name ,old-name) env)))
+ (let ((env (->environment '())))
(if (unbound? env 'guarantee)
(eval `(define (guarantee predicate object #!optional caller)
object)
env))
- (provide-rename 'random-bytevector 'random-byte-vector)
- (provide-rename 'string-foldcase 'string-downcase)
+ (provide-rename env 'random-byte-vector 'random-bytevector)
+ (provide-rename env 'string-downcase 'string-foldcase)
(for-each (lambda (old-name)
- (provide-rename (symbol 'scode- old-name) old-name))
+ (provide-rename env old-name (symbol 'scode- old-name)))
'(access-environment
access-name
access?
variable-name
variable?))
(for-each (lambda (root)
- (provide-rename (symbol 'make-scode- root)
- (symbol 'make- root)))
+ (provide-rename env
+ (symbol 'make- root)
+ (symbol 'make-scode- root)))
'(access
assignment
combination
the-environment
unassigned?
variable))
- (provide-rename 'set-scode-lambda-body! 'set-lambda-body!)
- (provide-rename 'undefined-scode-conditional-branch
- 'undefined-conditional-branch))
+ (provide-rename env 'set-lambda-body! 'set-scode-lambda-body!)
+ (provide-rename env
+ 'undefined-conditional-branch
+ 'undefined-scode-conditional-branch))
(let ((env (->environment '(runtime))))
(if (unbound? env 'select-on-bytes-per-word)
(er-macro-transformer
(lambda (form rename compare)
rename compare
- (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form)
+ (syntax-check '(keyword expression expression) form)
(let ((bpo (bytes-per-object)))
(case bpo
((4) (cadr form))
(link-variables system-global-environment 'microcode-type
env 'microcode-type))))
+ (let ((env (->environment '(runtime syntax))))
+ (provide-rename env 'make-compiler-item 'compiler-item))
+
(let ((env (->environment '(package))))
(if (eval '(not (link-description? '#(name1 (package name) name2 #f)))
env)
(lambda (form environment)
(syntax-check '(KEYWORD EXPRESSION) form)
(let ((item (classify/expression (cadr form) environment)))
- (make-keyword-value-item
+ (keyword-value-item
(transformer->expander (transformer-eval (compile-item/expression item)
environment)
environment)
- (make-expression-item
+ (expr-item
(lambda ()
(output/combination (output/runtime-reference name)
(list (compile-item/expression item)
(classify/body body environment))))))
(define (compile-body-item item)
- (receive (declaration-items items) (extract-declarations-from-body item)
- (output/body (map declaration-item/text declaration-items)
+ (receive (decl-items items) (extract-declarations-from-body item)
+ (output/body (map decl-item-text decl-items)
(compile-body-items items))))
(define (classifier:begin form environment)
(define (compiler:quote-identifier form environment)
(syntax-check '(keyword identifier) form)
(let ((item (lookup-identifier (cadr form) environment)))
- (if (not (variable-item? item))
+ (if (not (var-item? item))
(syntax-error "Can't quote a keyword identifier:" form))
- (output/quoted-identifier (variable-item/name item))))
+ (output/quoted-identifier (var-item-id item))))
(define (compiler:set! form environment)
(syntax-check '(KEYWORD FORM ? EXPRESSION) form)
(define (classify/location form environment)
(let ((item (classify/expression form environment)))
- (cond ((variable-item? item)
- (values (variable-item/name item) #f))
+ (cond ((var-item? item)
+ (values (var-item-id item) #f))
((access-item? item)
(values (access-item/name item) (access-item/environment item)))
(else
(lambda (form environment)
(let ((name (cadr form)))
(reserve-identifier environment name)
- (variable-binder make-binding-item
+ (variable-binder defn-item
environment
name
(classify/expression (caddr form) environment))))))
;; 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 name item)
- (make-body-item '()))))
+ (defn-item name item)
+ (seq-item '()))))
(define (keyword-binder environment name item)
(if (not (keyword-item? item))
(car binding)
(classify/expression (cadr binding) env)))
bindings)))
- (make-expression-item
+ (expr-item
(let ((names (map car bindings))
(values (map cdr bindings))
- (body-item
+ (seq-item
(classify/body
body
(make-internal-syntactic-environment binding-env))))
(lambda ()
(output/let names
(map compile-item/expression values)
- (compile-body-item body-item))))))))))
+ (compile-body-item seq-item))))))))))
(define (classifier:let-syntax form env)
(syntax-check '(keyword (* (identifier expression)) + form) form)
(define (classifier:declare form environment)
(syntax-check '(KEYWORD * (IDENTIFIER * DATUM)) form)
- (make-declaration-item
+ (decl-item
(lambda ()
(classify/declarations (cdr form) environment))))
(define (classify/declaration declaration environment)
(map-declaration-identifiers (lambda (identifier)
- (variable-item/name
+ (var-item-id
(classify/variable-reference identifier
environment)))
declaration))
(define (classify/variable-reference identifier environment)
(let ((item (classify/expression identifier environment)))
- (if (not (variable-item? item))
+ (if (not (var-item? item))
(syntax-error "Variable required in this context:" identifier))
item))
\ No newline at end of file
(files "syntax-items")
(parent (runtime syntax))
(export (runtime syntax)
- binding-item/name
- binding-item/value
- binding-item?
- body-item/components
- body-item?
- classifier-item/classifier
+ classifier-item
+ classifier-item-impl
classifier-item?
- compiler-item/compiler
+ compiler-item
+ compiler-item-impl
compiler-item?
- declaration-item/text
- declaration-item?
- expander-item/expander
+ decl-item
+ decl-item-text
+ decl-item?
+ defn-item
+ defn-item-id
+ defn-item-value
+ defn-item?
+ expander-item
+ expander-item-impl
expander-item?
- expression-item/compiler
- expression-item?
+ expr-item
+ expr-item-compiler
+ expr-item?
extract-declarations-from-body
- flatten-body-items
+ flatten-seq-items
item->list
keyword-item?
- keyword-value-item/expression
- keyword-value-item/item
+ keyword-value-item
+ keyword-value-item-expr
+ keyword-value-item-keyword
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-reserved-name-item
- make-variable-item
+ reserved-name-item
reserved-name-item?
- variable-item/name
- variable-item?))
+ seq-item
+ seq-item-elements
+ seq-item?
+ var-item
+ var-item-id
+ var-item?))
(define-package (runtime syntax environment)
(files "syntax-environment")
(cond ((identifier? form)
(let ((item (lookup-identifier form environment)))
(if (keyword-item? item)
- (make-keyword-value-item
+ (keyword-value-item
(strip-keyword-value-item item)
- (make-expression-item
+ (expr-item
(let ((name (identifier->symbol form)))
(lambda ()
(output/combination
(strip-keyword-value-item
(classify/expression (car form) environment))))
(cond ((classifier-item? item)
- ((classifier-item/classifier item) form environment))
+ ((classifier-item-impl item) form environment))
((compiler-item? item)
- (make-expression-item
- (let ((compiler (compiler-item/compiler item)))
+ (expr-item
+ (let ((compiler (compiler-item-impl item)))
(lambda ()
(compiler form environment)))))
((expander-item? item)
- (classify/form ((expander-item/expander item) form
- environment)
+ (classify/form ((expander-item-impl item) form environment)
environment))
(else
(if (not (list? (cdr form)))
(syntax-error "Combination must be a proper list:" form))
- (make-expression-item
+ (expr-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))))))
+ (expr-item (lambda () (output/constant form))))))
(define (strip-keyword-value-item item)
(if (keyword-value-item? item)
- (keyword-value-item/item item)
+ (keyword-value-item-keyword item)
item))
(define (classify/expression expression environment)
(define (classify/body forms environment)
;; Syntactic definitions affect all forms that appear after them, so classify
;; FORMS in order.
- (make-body-item
- (let loop ((forms forms) (body-items '()))
+ (seq-item
+ (let loop ((forms forms) (items '()))
(if (pair? forms)
(loop (cdr forms)
(reverse* (item->list (classify/form (car forms) environment))
- body-items))
- (reverse! body-items)))))
\ No newline at end of file
+ items))
+ (reverse! items)))))
\ No newline at end of file
(declare (usual-integrations))
\f
(define (compile-item/top-level item)
- (if (binding-item? item)
- (let ((name (identifier->symbol (binding-item/name item)))
- (value (binding-item/value item)))
+ (if (defn-item? item)
+ (let ((name (identifier->symbol (defn-item-id item)))
+ (value (defn-item-value item)))
(if (keyword-value-item? value)
(output/top-level-syntax-definition
name
- (compile-item/expression (keyword-value-item/expression value)))
+ (compile-item/expression (keyword-value-item-expr value)))
(output/top-level-definition
name
(compile-item/expression value))))
(compile-item/expression item)))
-(define (compile-body-item/top-level body-item)
- (receive (declaration-items body-items)
- (extract-declarations-from-body body-item)
- (output/top-level-sequence (map declaration-item/text declaration-items)
+(define (compile-body-item/top-level seq-item)
+ (receive (decl-items body-items)
+ (extract-declarations-from-body seq-item)
+ (output/top-level-sequence (map decl-item-text decl-items)
(map compile-item/top-level body-items))))
(define (compile-body-items items)
- (let ((items (flatten-body-items items)))
+ (let ((items (flatten-seq-items items)))
(if (not (pair? items))
(syntax-error "Empty body"))
(output/sequence
(append-map
(lambda (item)
- (if (binding-item? item)
- (let ((value (binding-item/value item)))
+ (if (defn-item? item)
+ (let ((value (defn-item-value item)))
(if (keyword-value-item? value)
'()
- (list (output/definition (binding-item/name item)
+ (list (output/definition (defn-item-id item)
(compile-item/expression value)))))
(list (compile-item/expression item))))
items))))
(list predicate)
compiler))))
-(define-item-compiler variable-item?
+(define-item-compiler var-item?
(lambda (item)
- (output/variable (variable-item/name item))))
+ (output/variable (var-item-id item))))
-(define-item-compiler expression-item?
+(define-item-compiler expr-item?
(lambda (item)
- ((expression-item/compiler item))))
+ ((expr-item-compiler item))))
-(define-item-compiler body-item?
+(define-item-compiler seq-item?
(lambda (item)
- (compile-body-items (body-item/components item))))
+ (compile-body-items (seq-item-elements item))))
(define (illegal-expression-compiler description)
(lambda (item)
(define-item-compiler keyword-item?
(illegal-expression-compiler "Syntactic keyword"))
-(define-item-compiler declaration-item?
+(define-item-compiler decl-item?
(illegal-expression-compiler "Declaration"))
-(define-item-compiler binding-item?
+(define-item-compiler defn-item?
(illegal-expression-compiler "Definition"))
\ No newline at end of file
(bind-keyword senv name item))
(define (define-classifier name classifier)
- (def name (make-classifier-item classifier)))
+ (def name (classifier-item classifier)))
(define-classifier 'BEGIN classifier:begin)
(define-classifier 'DECLARE classifier:declare)
(define-classifier 'SC-MACRO-TRANSFORMER classifier:sc-macro-transformer)
(define (define-compiler name compiler)
- (def name (make-compiler-item compiler)))
+ (def name (compiler-item compiler)))
(define-compiler 'DELAY compiler:delay)
(define-compiler 'IF compiler:if)
(define (syntactic-environment/reserve senv identifier)
(guarantee raw-identifier? identifier 'syntactic-environment/reserve)
- ((senv-store senv) identifier (make-reserved-name-item)))
+ ((senv-store senv) identifier (reserved-name-item)))
(define (syntactic-environment/bind-keyword senv identifier item)
(guarantee raw-identifier? identifier 'syntactic-environment/bind-keyword)
(define (syntactic-environment/bind-variable senv identifier)
(guarantee raw-identifier? identifier 'syntactic-environment/bind-variable)
(let ((rename ((senv-rename senv) identifier)))
- ((senv-store senv) identifier (make-variable-item rename))
+ ((senv-store senv) identifier (var-item rename))
rename))
(define (->syntactic-environment object #!optional caller)
;;; of keyword item.
(define-record-type <classifier-item>
- (make-classifier-item classifier)
+ (classifier-item impl)
classifier-item?
- (classifier classifier-item/classifier))
+ (impl classifier-item-impl))
(define-record-type <compiler-item>
- (make-compiler-item compiler)
+ (compiler-item impl)
compiler-item?
- (compiler compiler-item/compiler))
+ (impl compiler-item-impl))
(define-record-type <expander-item>
- (make-expander-item expander)
+ (expander-item impl)
expander-item?
- (expander expander-item/expander))
+ (impl expander-item-impl))
(define-record-type <keyword-value-item>
- (make-keyword-value-item item expression)
+ (keyword-value-item keyword expr)
keyword-value-item?
- (item keyword-value-item/item)
- (expression keyword-value-item/expression))
+ (keyword keyword-value-item-keyword)
+ (expr keyword-value-item-expr))
(define (keyword-item? object)
(or (classifier-item? object)
;;; Variable items represent run-time variables.
-(define (make-variable-item name)
- (guarantee identifier? name 'make-variable-item)
- (%make-variable-item name))
+(define (var-item id)
+ (guarantee identifier? id 'var-item)
+ (%var-item id))
-(define-record-type <variable-item>
- (%make-variable-item name)
- variable-item?
- (name variable-item/name))
+(define-record-type <var-item>
+ (%var-item id)
+ var-item?
+ (id var-item-id))
-(define-unparser-method variable-item?
- (simple-unparser-method 'variable-item
+(define-unparser-method var-item?
+ (simple-unparser-method 'var-item
(lambda (item)
- (list (variable-item/name item)))))
+ (list (var-item-id item)))))
;;; Reserved name items do not represent any form, but instead are
;;; used to reserve a particular name in a syntactic environment. If
;;; one of the names being bound.
(define-record-type <reserved-name-item>
- (make-reserved-name-item)
+ (reserved-name-item)
reserved-name-item?)
\f
;;; These items can't be stored in a syntactic environment.
-;;; Binding items represent definitions, whether top-level or internal, keyword
-;;; or variable.
+;;; Definition items, whether top-level or internal, keyword or variable.
-(define (make-binding-item name value)
- (guarantee identifier? name 'make-binding-item)
- (guarantee binding-item-value? value 'make-binding-item)
- (%make-binding-item name value))
+(define (defn-item id value)
+ (guarantee identifier? id 'defn-item)
+ (guarantee defn-item-value? value 'defn-item)
+ (%defn-item id value))
-(define (binding-item-value? object)
+(define (defn-item-value? object)
(not (or (reserved-name-item? object)
- (declaration-item? object))))
-(register-predicate! binding-item-value? 'binding-item-value)
+ (decl-item? object))))
+(register-predicate! defn-item-value? 'defn-item-value)
-(define-record-type <binding-item>
- (%make-binding-item name value)
- binding-item?
- (name binding-item/name)
- (value binding-item/value))
+(define-record-type <defn-item>
+ (%defn-item id value)
+ defn-item?
+ (id defn-item-id)
+ (value defn-item-value))
-(define-unparser-method binding-item?
- (simple-unparser-method 'binding-item
+(define-unparser-method defn-item?
+ (simple-unparser-method 'defn-item
(lambda (item)
- (list (binding-item/name item)
- (binding-item/value item)))))
+ (list (defn-item-id item)
+ (defn-item-value item)))))
-;;; Body items represent sequences (e.g. BEGIN).
+;;; Sequence items.
-(define-record-type <body-item>
- (make-body-item components)
- body-item?
- (components body-item/components))
+(define-record-type <seq-item>
+ (seq-item elements)
+ seq-item?
+ (elements seq-item-elements))
-(define (extract-declarations-from-body body-item)
- (partition declaration-item? (body-item/components body-item)))
+(define (extract-declarations-from-body seq-item)
+ (partition decl-item? (seq-item-elements seq-item)))
-(define (flatten-body-items items)
+(define (flatten-seq-items items)
(append-map item->list items))
(define (item->list item)
- (if (body-item? item)
- (flatten-body-items (body-item/components item))
+ (if (seq-item? item)
+ (flatten-seq-items (seq-item-elements item))
(list item)))
;;; 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))
+(define-record-type <expr-item>
+ (expr-item compiler)
+ expr-item?
+ (compiler expr-item-compiler))
;;; 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-record-type <decl-item>
+ (decl-item text-getter)
+ decl-item?
+ (text-getter decl-item-text-getter))
-(define (declaration-item/text item)
- ((declaration-item/get-text item)))
\ No newline at end of file
+(define (decl-item-text item)
+ ((decl-item-text-getter item)))
\ No newline at end of file
(declare (usual-integrations))
\f
(define (sc-macro-transformer->expander transformer closing-environment)
- (make-expander-item
+ (expander-item
(lambda (form use-environment)
(close-syntax (transformer form use-environment)
(->syntactic-environment closing-environment)))))
(define (rsc-macro-transformer->expander transformer closing-environment)
- (make-expander-item
+ (expander-item
(lambda (form use-environment)
(close-syntax (transformer form
(->syntactic-environment closing-environment))
use-environment))))
(define (er-macro-transformer->expander transformer closing-environment)
- (make-expander-item
+ (expander-item
(lambda (form use-environment)
(close-syntax (transformer form
(make-er-rename
(if (reserved-name-item? item)
(syntax-error "Premature reference to reserved name:" identifier))
(or item
- (make-variable-item identifier))))
+ (var-item identifier))))
(define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
(let ((item-1 (lookup-identifier identifier-1 environment-1))
;; 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))))))
+ (and (var-item? item-1)
+ (var-item? item-2)
+ (eq? (var-item-id item-1)
+ (var-item-id item-2))))))
(define (reserve-identifier senv identifier)
(cond ((raw-identifier? identifier)
(apply error rest))
(define (classifier->keyword classifier)
- (item->keyword (make-classifier-item classifier)))
+ (item->keyword (classifier-item classifier)))
(define (compiler->keyword compiler)
- (item->keyword (make-compiler-item compiler)))
+ (item->keyword (compiler-item compiler)))
(define (item->keyword item)
(close-syntax 'keyword (make-keyword-syntactic-environment 'keyword item)))
projects / mit-scheme.git / commitdiff