(else (scode/make-conjunction t1 t2))))
(define (scode/make-thunk body)
- (scode/make-lambda lambda-tag:unnamed '() '() false '() '() body))
+ (scode/make-lambda scode-lambda-name:unnamed '() '() false '() '() body))
(define (scode/let? obj)
(and (scode/combination? obj)
(let ((operator (scode/combination-operator obj)))
(and (scode/lambda? operator)
- (eq? lambda-tag:let (scode/lambda-name operator))))))
+ (eq? scode-lambda-name:let (scode/lambda-name operator))))))
(define (scode/make-let names values declarations body)
(scode/make-combination
- (scode/make-lambda lambda-tag:let
+ (scode/make-lambda scode-lambda-name:let
names
'()
false
(scan-defines (scode/make-sequence body)
(lambda (auxiliary declarations body)
(scode/make-combination
- (scode/make-lambda lambda-tag:let names '() false
+ (scode/make-lambda scode-lambda-name:let names '() false
auxiliary declarations body)
values))))
\f
(loop (cdr items) passed (cons (car items) failed))))))
(define (generate-label #!optional prefix)
- (if (default-object? prefix) (set! prefix 'LABEL))
+ (if (default-object? prefix) (set! prefix 'label))
(string->uninterned-symbol
(canonicalize-label-name
(string-append
(symbol->string
- (cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA)
- ((eq? prefix lambda-tag:let) 'LET)
- ((eq? prefix lambda-tag:fluid-let) 'FLUID-LET)
+ (cond ((eq? prefix scode-lambda-name:unnamed) 'lambda)
+ ((eq? prefix scode-lambda-name:let) 'let)
+ ((eq? prefix scode-lambda-name:fluid-let) 'fluid-let)
(else prefix)))
"-"
(number->string (generate-label-number))))))
(define (normal)
(scode/make-directive
(scode/make-combination
- (scode/make-lambda lambda-tag:let
+ (scode/make-lambda scode-lambda-name:let
(list environment-variable) '() false '()
'()
body)
(let* ((env-code (scode/make-the-environment))
(nbody
(canonicalize/expression
- (unscan-defines auxiliary decls (canout-expr nbody))
+ (unscan-defines auxiliary decls
+ (canout-expr nbody))
'()
(if (canonicalize/optimization-low? context)
'FIRST-CLASS
(scode/make-absolute-reference '*MAKE-ENVIRONMENT)
(cons* (scode/make-variable environment-variable)
(list->vector
- (cons lambda-tag:unnamed names))
+ (cons scode-lambda-name:unnamed names))
(map scode/make-variable names)))))
(if (and (scode/the-environment? body)
(null? auxiliary))
env-code
- (let* ((uexpr (unscan-defines auxiliary decls (canout-expr nbody)))
+ (let* ((uexpr
+ (unscan-defines auxiliary decls
+ (canout-expr nbody)))
(nexpr
(canout-expr
(canonicalize/expression
'TOP-LEVEL)))))
(if (canonicalize/optimization-low? context)
- (canonicalize/bind-environment nexpr env-code uexpr)
+ (canonicalize/bind-environment nexpr env-code
+ uexpr)
(scode/make-evaluation
(canonicalize/bind-environment
nexpr
(return-3 '() '()
(scode/make-combination
(scode/make-lambda
- lambda-tag:let auxiliary '() #f names '()
+ scode-lambda-name:let auxiliary '() #f names '()
(scode/make-sequence
(map* actions scode/make-assignment names values)))
(map (lambda (name)
(ucode-primitive system-pair-cons)
(list (ucode-type delayed)
0
- (scode/make-lambda lambda-tag:unnamed '() '() #f '() '()
+ (scode/make-lambda scode-lambda-name:unnamed '() '() #f '() '()
(scode/delay-expression expression))))))
(define (generate/error-combination block continuation context expression)
make-alien-function
alien-function/filename)
(import (runtime syntax)
- syntactic-environment->runtime)
+ senv->runtime)
(export ()
c-include
load-c-includes
(call-with-destructured-c-include-form
form
(lambda (library)
- (let ((ienv (syntactic-environment->runtime usage-env)))
+ (let ((ienv (senv->runtime usage-env)))
(if (and (environment-bound? ienv 'C-INCLUDES)
(environment-assigned? ienv 'C-INCLUDES))
(let ((value (environment-lookup ienv 'C-INCLUDES))
(define (find-c-includes env)
;; Returns the c-includes structure bound to 'C-INCLUDES in ENV.
(guarantee syntactic-environment? env 'find-c-includes)
- (let ((ienv (syntactic-environment->runtime env)))
+ (let ((ienv (senv->runtime env)))
(if (and (environment-bound? ienv 'C-INCLUDES)
(environment-assigned? ienv 'C-INCLUDES))
(let ((includes (environment-lookup ienv 'C-INCLUDES)))
(system-list->vector
(ucode-type environment)
(cons (system-pair-cons (ucode-type procedure)
- (make-slambda lambda-tag:unnamed names unspecific)
+ (make-slambda scode-lambda-name:unnamed
+ names
+ unspecific)
environment)
(if (eq? values 'DEFAULT)
(let ((values (make-list (length names))))
\f
(define user-initial-environment
(*make-environment system-global-environment
- (vector lambda-tag:unnamed)))
+ (vector scode-lambda-name:unnamed)))
(define user-initial-prompt
"]=>")
(provide-rename env 'random-byte-vector 'random-bytevector)
(provide-rename env 'string-downcase 'string-foldcase)
+ (provide-rename env 'lambda-tag:unnamed 'scode-lambda-name:unnamed)
+ (provide-rename env 'lambda-tag:let 'scode-lambda-name:let)
+ (provide-rename env 'lambda-tag:fluid-let 'scode-lambda-name:fluid-let)
(for-each (lambda (old-name)
(provide-rename env old-name (symbol 'scode- old-name)))
(symbol->string (cdr association)))))
(define-deferred special-form-procedure-names
- `((,lambda-tag:unnamed . LAMBDA)
- (,lambda-tag:internal-lambda . LAMBDA)
- (,lambda-tag:let . LET)
- (,lambda-tag:fluid-let . FLUID-LET)))
+ `((,scode-lambda-name:unnamed . lambda)
+ (,scode-lambda-name:internal-lambda . lambda)
+ (,scode-lambda-name:let . let)
+ (,scode-lambda-name:fluid-let . fluid-let)))
(define (compiled-procedure/lambda entry)
(let ((procedure (compiled-entry/dbg-object entry)))
;; This should be fixed some day.
;; From lambda.scm
- (eq? object lambda-tag:internal-lambda)
+ (eq? object scode-lambda-name:internal-lambda)
;; From syntax-output.scm
- (eq? object lambda-tag:fluid-let)
- (eq? object lambda-tag:let)
- (eq? object lambda-tag:unnamed)
+ (eq? object scode-lambda-name:fluid-let)
+ (eq? object scode-lambda-name:let)
+ (eq? object scode-lambda-name:unnamed)
))
\f
(define (parse-mit-lambda-list lambda-list)
\f
;;;; Internal Lambda
-(define-integrable lambda-tag:internal-lambda
- ((ucode-primitive string->symbol) "#[internal-lambda]"))
-
(define-integrable (%make-internal-lambda names body)
- (make-slambda lambda-tag:internal-lambda names body))
+ (make-slambda scode-lambda-name:internal-lambda names body))
(define (make-auxiliary-lambda auxiliary body)
(if (null? auxiliary)
(define (internal-lambda? *lambda)
(and (slambda? *lambda)
- (eq? (slambda-name *lambda) lambda-tag:internal-lambda)))
+ (eq? (slambda-name *lambda) scode-lambda-name:internal-lambda)))
(define (internal-lambda-bound? *lambda symbol)
(and (slambda? *lambda)
\f
(let ((environment-for-package
(*make-environment system-global-environment
- (vector lambda-tag:unnamed))))
+ (vector scode-lambda-name:unnamed))))
(define-integrable + (ucode-primitive integer-add))
(define-integrable - (ucode-primitive integer-subtract))
(make-synthetic-identifier
(identifier->symbol (car binding))))
bindings)))
- `((,r-named-lambda (,lambda-tag:unnamed ,@(map car bindings))
+ `((,r-named-lambda (,scode-lambda-name:unnamed ,@(map car bindings))
((,r-lambda ,temps
,@(map (lambda (binding temp)
`(,r-set! ,(car binding)
(r-lambda (rename 'LAMBDA))
(r-named-lambda (rename 'NAMED-LAMBDA))
(r-set! (rename 'SET!)))
- `((,r-named-lambda (,lambda-tag:unnamed ,@(map car bindings))
+ `((,r-named-lambda (,scode-lambda-name:unnamed ,@(map car bindings))
,@(map (lambda (binding)
`(,r-set! ,@binding)) bindings)
((,r-lambda () ,@(cddr form))))
(output/named-lambda (identifier->symbol (caadr form)) bvl body)))
(define (compile/lambda bvl body environment)
- (let ((environment (make-internal-syntactic-environment environment)))
+ (let ((environment (make-internal-senv environment)))
;; Force order -- bind names before classifying body.
(let ((bvl
(map-mit-lambda-list (lambda (identifier)
(item (classify-form (caddr form) environment)))
(keyword-binder environment name item)
;; User-defined macros at top level are preserved in the output.
- (if (and (top-level-syntactic-environment? environment)
+ (if (and (senv-top-level? environment)
(expander-item? item))
(syntax-defn-item name (expander-item-expr item))
(seq-item '()))))
(lambda (form env)
(let ((bindings (cadr form))
(body (cddr form))
- (binding-env (make-internal-syntactic-environment env)))
+ (binding-env (make-internal-senv env)))
(let ((bindings
(map (lambda (binding)
(variable-binder cons
(seq-item
(classify-body
body
- (make-internal-syntactic-environment binding-env))))
+ (make-internal-senv binding-env))))
(lambda ()
(output/let names
(map compile-expr-item values)
(syntax-check '(keyword (* (identifier expression)) + form) form)
(let ((bindings (cadr form))
(body (cddr form))
- (binding-env (make-internal-syntactic-environment env)))
+ (binding-env (make-internal-senv env)))
(for-each (lambda (binding)
(keyword-binder binding-env
(car binding)
(classify-form (cadr binding) env)))
bindings)
- (classify-body body (make-internal-syntactic-environment binding-env))))
+ (classify-body body (make-internal-senv binding-env))))
(define keyword:let-syntax
(classifier->keyword classifier:let-syntax))
(syntax-check '(keyword (* (identifier expression)) + form) form)
(let ((bindings (cadr form))
(body (cddr form))
- (binding-env (make-internal-syntactic-environment env)))
+ (binding-env (make-internal-senv env)))
(for-each (lambda (binding)
(reserve-identifier (car binding) binding-env))
bindings)
(map (lambda (binding)
(classify-form (cadr binding) binding-env))
bindings))
- (classify-body body (make-internal-syntactic-environment binding-env))))
+ (classify-body body (make-internal-senv binding-env))))
;; TODO: this is a compiler rather than a macro because it uses the
;; special OUTPUT/DISJUNCTION. Unfortunately something downstream in
(define (compiler:the-environment form environment)
(syntax-check '(KEYWORD) form)
- (if (not (top-level-syntactic-environment? environment))
+ (if (not (senv-top-level? environment))
(syntax-error "This form allowed only at top level:" form))
(output/the-environment))
internal-lambda?
lambda-names-vector
make-slambda)
- (export (runtime compiler-info)
- lambda-tag:internal-lambda)
- (export (runtime lambda-list)
- lambda-tag:internal-lambda)
(export (runtime unsyntaxer)
lambda-immediate-body)
(initialization (initialize-package!)))
scode-disjunction-alternative
scode-disjunction-predicate
scode-disjunction?
+ scode-lambda-name:fluid-let
+ scode-lambda-name:internal-lambda
+ scode-lambda-name:let
+ scode-lambda-name:unnamed
scode-quotation-expression
scode-quotation?
scode-sequence-actions
bind-keyword
bind-variable
lookup-identifier
- make-internal-syntactic-environment
- make-keyword-syntactic-environment
- make-partial-syntactic-environment
+ make-internal-senv
+ make-keyword-senv
+ make-partial-senv
reserve-identifier
- syntactic-environment->runtime
- top-level-syntactic-environment?
- syntactic-environment?))
+ senv->runtime
+ senv-top-level?))
(define-package (runtime syntax check)
(files "syntax-check")
(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)
output/access-assignment
output/access-reference
(cond ((slambda? lambda) (slambda-body lambda))
((xlambda? lambda) (xlambda-body lambda))
(else (error:not-a scode-lambda? lambda 'scode-lambda-body))))
+
+(define scode-lambda-name:unnamed '|#[unnamed-procedure]|)
+(define scode-lambda-name:let '|#[let-procedure]|)
+(define scode-lambda-name:fluid-let '|#[fluid-let-procedure]|)
+(define scode-lambda-name:internal-lambda '|#[internal-lambda]|)
\f
;;; Simple representation
((environment? env) (%internal-runtime-senv env))
(else (error:not-a environment? env 'runtime-environment->syntactic))))
-(define (syntactic-environment->runtime senv)
+(define (senv->runtime senv)
((senv-get-runtime senv)))
-(define (top-level-syntactic-environment? senv)
+(define (senv-top-level? senv)
(eq? 'top-level ((senv-get-type senv))))
(define ((id-dispatcher handle-raw caller) identifier senv)
\f
;;; Keyword environments are used to make keywords that represent items.
-(define (make-keyword-syntactic-environment name item)
+(define (make-keyword-senv name item)
(define (get-type)
'keyword)
;;; Internal syntactic environments represent environments created by
;;; procedure application.
-(define (make-internal-syntactic-environment parent)
- (guarantee syntactic-environment? parent 'make-internal-syntactic-environment)
+(define (make-internal-senv parent)
+ (guarantee syntactic-environment? parent 'make-internal-senv)
(let ((bound '())
(free '())
(get-runtime (senv-get-runtime parent))
;;; Partial syntactic environments are used to implement syntactic
;;; closures that have free names.
-(define (make-partial-syntactic-environment free-ids free-senv bound-senv)
- (let ((caller 'make-partial-syntactic-environment))
+(define (make-partial-senv free-ids free-senv bound-senv)
+ (let ((caller 'make-partial-senv))
(guarantee list-of-unique-symbols? free-ids caller)
(guarantee syntactic-environment? free-senv caller)
(guarantee syntactic-environment? bound-senv caller))
(declare (usual-integrations))
\f
(define (transformer-eval output environment)
- (eval output (syntactic-environment->runtime environment)))
+ (eval output (senv->runtime environment)))
(define (output/variable name)
(make-scode-variable name))
(if (scode-lambda? value)
(lambda-components* value
(lambda (name* required optional rest body)
- (if (eq? name* lambda-tag:unnamed)
+ (if (eq? name* scode-lambda-name:unnamed)
(make-lambda* name required optional rest body)
value)))
value)))
(make-scode-combination operator operands))
(define (output/lambda lambda-list body)
- (output/named-lambda lambda-tag:unnamed lambda-list body))
+ (output/named-lambda scode-lambda-name:unnamed lambda-list body))
(define (output/named-lambda name lambda-list body)
(call-with-values (lambda () (parse-mit-lambda-list lambda-list))
unspecific)
\f
(define (output/let names values body)
- (output/combination (output/named-lambda lambda-tag:let names body) values))
+ (output/combination (output/named-lambda scode-lambda-name:let names body)
+ values))
(define (output/letrec names values body)
(let ((temps
(list environment name value)))
(define (output/runtime-reference name)
- (output/access-reference name system-global-environment))
-
-(define lambda-tag:unnamed '|#[unnamed-procedure]|)
-(define lambda-tag:let '|#[let-procedure]|)
-(define lambda-tag:fluid-let '|#[fluid-let-procedure]|)
\ No newline at end of file
+ (output/access-reference name system-global-environment))
\ No newline at end of file
(runtime-environment->syntactic environment))))
(with-identifier-renaming
(lambda ()
- (if (top-level-syntactic-environment? senv)
+ (if (senv-top-level? senv)
(compile-top-level-body (classify-body forms senv))
(output/sequence
(map (lambda (expr)
(compile-expr expr senv))
forms)))))))
-(define (compile-expr expression environment)
- (compile-expr-item (classify-form expression environment)))
+(define (compile-expr expr senv)
+ (compile-expr-item (classify-form expr senv)))
\f
;;;; Classifier
-(define (classify-form form environment)
+(define (classify-form form senv)
(cond ((identifier? form)
- (lookup-identifier form environment))
+ (lookup-identifier form senv))
((syntactic-closure? form)
(classify-form
(syntactic-closure-form form)
- (make-partial-syntactic-environment (syntactic-closure-free form)
- environment
- (syntactic-closure-senv form))))
+ (make-partial-senv (syntactic-closure-free form)
+ senv
+ (syntactic-closure-senv form))))
((pair? form)
- (let ((item (classify-form (car form) environment)))
+ (let ((item (classify-form (car form) senv)))
(cond ((classifier-item? item)
- ((classifier-item-impl item) form environment))
+ ((classifier-item-impl item) form senv))
((compiler-item? item)
(expr-item
(let ((compiler (compiler-item-impl item)))
(lambda ()
- (compiler form environment)))))
+ (compiler form senv)))))
((expander-item? item)
- (classify-form ((expander-item-impl item) form environment)
- environment))
+ (classify-form ((expander-item-impl item) form senv)
+ senv))
(else
(if (not (list? (cdr form)))
(syntax-error "Combination must be a proper list:" form))
(expr-item
(let ((items
(map (lambda (expr)
- (classify-form expr environment))
+ (classify-form expr senv))
(cdr form))))
(lambda ()
(output/combination
(else
(expr-item (lambda () (output/constant form))))))
-(define (classify-body forms environment)
+(define (classify-body forms senv)
;; Syntactic definitions affect all forms that appear after them, so classify
;; FORMS in order.
(seq-item
(let loop ((forms forms) (items '()))
(if (pair? forms)
(loop (cdr forms)
- (reverse* (item->list (classify-form (car forms) environment))
+ (reverse* (item->list (classify-form (car forms) senv))
items))
(reverse! items)))))
\f
(item->keyword (compiler-item compiler)))
(define (item->keyword item)
- (close-syntax 'keyword (make-keyword-syntactic-environment 'keyword item)))
+ (close-syntax 'keyword (make-keyword-senv 'keyword item)))
(define (capture-syntactic-environment expander)
`(,(classifier->keyword
(lambda-components* (procedure-lambda procedure)
(lambda (name required optional rest body)
required optional rest body
- (and (not (eq? name lambda-tag:unnamed))
+ (and (not (eq? name scode-lambda-name:unnamed))
(lambda (context*)
(*unparse-object name context*))))))))
(unsyntax-lambda-body environment* body)))))))
(define (collect-lambda name bvl body)
- (if (eq? name lambda-tag:unnamed)
+ (if (eq? name scode-lambda-name:unnamed)
`(LAMBDA ,bvl ,@body)
`(NAMED-LAMBDA (,name . ,bvl) ,@body)))
(if (and (null? optional)
(not rest)
(= (length required) (length operands)))
- (if (or (eq? name lambda-tag:unnamed)
- (eq? name lambda-tag:let))
+ (if (or (eq? name scode-lambda-name:unnamed)
+ (eq? name scode-lambda-name:let))
`(LET ,(unsyntax-let-bindings environment required operands)
,@(with-bindings environment operator
(lambda (environment*)
'(CHAR-BITS-LIMIT
CHAR-CODE-LIMIT
FALSE
- LAMBDA-TAG:UNNAMED ;needed for cold load
+ scode-lambda-name:unnamed ;needed for cold load
SYSTEM-GLOBAL-ENVIRONMENT ;suppresses warnings about (access ...)
THE-EMPTY-STREAM
TRUE
(let ((variable (variable/make&bind! block name)))
(procedure/make
#f
- block lambda-tag:let (list variable) '() #f
+ block scode-lambda-name:let (list variable) '() #f
(make-body block
(reference/make #f block variable)))))
(list operand)))
block
(procedure/make
#f
- block lambda-tag:let variables '() #f
+ block scode-lambda-name:let variables '() #f
(let ((block (block/make block #t '())))
(let ((variable (variable/make&bind! block 'RECEIVER)))
(procedure/make
- #f block lambda-tag:unnamed (list variable) '() #f
+ #f block scode-lambda-name:unnamed (list variable) '() #f
(declaration/make
#f
;; The receiver is used only once, and all its operand
projects / mit-scheme.git / commitdiff