Also remove all FOO-components and FOO-subexpressions procedures.
More work remains: the lambda abstraction is an unholy mess and needs to be
cleaned up. The scan-defines stuff also merits some consideration.
(open-block-components expression unscan-defines)
expression)))
(if (eq? context 'REPL-BUFFER)
- (make-sequence
+ (make-scode-sequence
(map (lambda (expression)
- (if (definition? expression)
- (let ((name (definition-name expression))
- (value (definition-value expression)))
- (make-sequence
+ (if (scode-definition? expression)
+ (let ((name (scode-definition-name expression))
+ (value (scode-definition-value expression)))
+ (make-scode-sequence
(list expression
- (make-combination
- (make-quotation write-definition-value)
+ (make-scode-combination
+ (make-scode-quotation write-definition-value)
(cons name
(if (unassigned-reference-trap? value)
'()
- (list (make-variable name))))))))
+ (list (make-scode-variable name))))))))
expression))
- (sequence-actions expression)))
+ (scode-sequence-actions expression)))
expression)))
(define (write-definition-value name #!optional value)
(define (scode/unquasiquote exp)
(cond ((scode/combination? exp)
- (scode/combination-components
- exp
- (lambda (operator operands)
- (define (kernel operator-name)
- (case operator-name
- ((CONS)
- (cons (scode/unquasiquote (car operands))
- (scode/unquasiquote (cadr operands))))
- ((LIST)
- (apply list (map scode/unquasiquote operands)))
- ((CONS*)
- (apply cons* (map scode/unquasiquote operands)))
- ((APPEND)
- (append-map (lambda (component)
- (if (scode/constant? component)
- (scode/constant-value component)
- (list (list 'UNQUOTE-SPLICING component))))
- operands))
- (else (list 'UNQUOTE exp))))
- (cond ((eq? operator (ucode-primitive cons))
- ;; integrations
- (kernel 'CONS))
- ((scode/absolute-reference? operator)
- (kernel (scode/absolute-reference-name operator)))
- (else (list 'UNQUOTE exp))))))
+ (let ((operator (scode/combination-operator exp))
+ (operands (scode/combination-operands exp)))
+ (define (kernel operator-name)
+ (case operator-name
+ ((CONS)
+ (cons (scode/unquasiquote (car operands))
+ (scode/unquasiquote (cadr operands))))
+ ((LIST)
+ (apply list (map scode/unquasiquote operands)))
+ ((CONS*)
+ (apply cons* (map scode/unquasiquote operands)))
+ ((APPEND)
+ (append-map (lambda (component)
+ (if (scode/constant? component)
+ (scode/constant-value component)
+ (list (list 'UNQUOTE-SPLICING component))))
+ operands))
+ (else (list 'UNQUOTE exp))))
+ (cond ((eq? operator (ucode-primitive cons))
+ ;; integrations
+ (kernel 'CONS))
+ ((scode/absolute-reference? operator)
+ (kernel (scode/absolute-reference-name operator)))
+ (else (list 'UNQUOTE exp)))))
((scode/constant? exp)
(scode/constant-value exp))
(else (list 'UNQUOTE exp))))
(if (and (scode/constant? (car operands))
(bit-string? (scode/constant-value (car operands)))
(scode/combination? (cadr operands)))
- (scode/combination-components (cadr operands)
- (lambda (operator inner-operands)
- (if (and (or (is-operator? operator 'CONS-SYNTAX false)
- (is-operator? operator
- 'CONS
- (ucode-primitive cons)))
- (scode/constant? (car inner-operands))
- (bit-string?
- (scode/constant-value (car inner-operands))))
- (if-expanded
- (scode/make-combination
- (if (scode/constant? (cadr inner-operands))
- (ucode-primitive cons)
- operator)
- (cons (instruction-append
- (scode/constant-value (car operands))
- (scode/constant-value (car inner-operands)))
- (cdr inner-operands))))
- (default))))
+ (let ((operator (scode/combination-operator (cadr operands)))
+ (inner-operands (scode/combination-operands (cadr operands))))
+ (if (and (or (is-operator? operator 'CONS-SYNTAX false)
+ (is-operator? operator
+ 'CONS
+ (ucode-primitive cons)))
+ (scode/constant? (car inner-operands))
+ (bit-string?
+ (scode/constant-value (car inner-operands))))
+ (if-expanded
+ (scode/make-combination
+ (if (scode/constant? (cadr inner-operands))
+ (ucode-primitive cons)
+ operator)
+ (cons (instruction-append
+ (scode/constant-value (car operands))
+ (scode/constant-value (car inner-operands)))
+ (cdr inner-operands))))
+ (default)))
(default))))))
\f
;;;; INSTRUCTION->INSTRUCTION-SEQUENCE expander
(define (parse expression receiver)
(if (not (scode/combination? expression))
(receiver false false false)
- (scode/combination-components expression
- (lambda (operator operands)
- (cond ((and (not (is-operator? operator
- 'CONS
- (ucode-primitive cons)))
- (not (is-operator? operator 'CONS-SYNTAX false)))
- (receiver false false false))
- ((scode/constant? (cadr operands))
- (if (not (null? (scode/constant-value (cadr operands))))
- (error "INST->INST-SEQ-EXPANDER: bad CONS-SYNTAX tail"
- (scode/constant-value (cadr operands))))
- (let ((name
- (generate-uninterned-symbol 'INSTRUCTION-TAIL-)))
- (receiver true
- (cons name expression)
- (scode/make-variable name))))
- (else
- (parse (cadr operands)
- (lambda (mode info rest)
- (if (not mode)
- (receiver false false false)
- (receiver true info
- (scode/make-combination
- operator
- (list (car operands) rest))))))))))))
+ (let ((operator (scode/combination-operator expression))
+ (operands (scode/combination-operands expression)))
+ (cond ((and (not (is-operator? operator
+ 'CONS
+ (ucode-primitive cons)))
+ (not (is-operator? operator 'CONS-SYNTAX false)))
+ (receiver false false false))
+ ((scode/constant? (cadr operands))
+ (if (not (null? (scode/constant-value (cadr operands))))
+ (error "INST->INST-SEQ-EXPANDER: bad CONS-SYNTAX tail"
+ (scode/constant-value (cadr operands))))
+ (let ((name
+ (generate-uninterned-symbol 'INSTRUCTION-TAIL-)))
+ (receiver true
+ (cons name expression)
+ (scode/make-variable name))))
+ (else
+ (parse (cadr operands)
+ (lambda (mode info rest)
+ (if (not mode)
+ (receiver false false false)
+ (receiver true info
+ (scode/make-combination
+ operator
+ (list (car operands) rest)))))))))))
(scode->scode-expander
(lambda (operands if-expanded if-not-expanded)
(if (not (scode/combination? (car operands)))
(vector-ref linking-info 2)))))
(label->address *entry-label*)))
(for-each (lambda (entry)
- (set-lambda-body! (car entry)
- (label->address (cdr entry))))
+ (scode/set-lambda-body! (car entry)
+ (label->address (cdr entry))))
*ic-procedure-headers*))
((ucode-primitive declare-compiled-code-block 1) *code-vector*)
(if (not compiler:preserve-data-structures?)
(scode/merge-tests (scode/make-absolute-combination 'PAIR?
(list expression))
(scode/merge-tests car-test cdr-test))
- (combination-components car-test
- (lambda (car-operator car-operands)
- car-operator
- (combination-components cdr-test
- (lambda (cdr-operator cdr-operands)
- cdr-operator
- (scode/make-absolute-combination 'EQUAL?
- (list
- (scode/make-constant
- (cons (scode/constant-value (car car-operands))
- (scode/constant-value (car cdr-operands))))
- expression))))))))
+ (scode/make-absolute-combination 'equal?
+ (list
+ (scode/make-constant
+ (cons (scode/constant-value
+ (car (scode/combination-operands car-test)))
+ (scode/constant-value
+ (car (scode/combination-operands cdr-test)))))
+ expression))))
\f
;;;; car/cdr path compression
(lambda (exp)
(scode/make-combination (scode/make-variable transformer)
(list exp))))))
-
+
(define (transformer-bindings name rename expression mapper)
(if (eq? rename name)
(list (make-outer-binding name (mapper expression)))
make-outer-binding))
((can-integrate? code)
(possible true make-early-binding))
- (else
+ (else
(possible true make-late-binding))))))))
;; Mega kludge!
(else (scode/make-conjunction t1 t2))))
(define (scode/make-thunk body)
- (scode/make-lambda lambda-tag:unnamed '() '() false '() '() body))
+ (scode/make-lambda lambda-tag:unnamed '() '() false '() '() body))
(define (scode/let? obj)
(and (scode/combination? obj)
- (scode/combination-components
- obj
- (lambda (operator operands)
- operands
- (and (scode/lambda? operator)
- (scode/lambda-components
- operator
- (lambda (name . ignore)
- ignore
- (eq? name lambda-tag:let))))))))
+ (let ((operator (scode/combination-operator obj)))
+ (and (scode/lambda? operator)
+ (eq? lambda-tag:let (scode/lambda-name operator))))))
(define (scode/make-let names values declarations body)
(scode/make-combination
values))
(define (scode/let-components lcomb receiver)
- (scode/combination-components lcomb
- (lambda (operator values)
- (scode/lambda-components operator
- (lambda (tag names opt rest aux decls body)
- tag opt rest aux
- (receiver names values decls body))))))
+ (let ((operator (scode/combination-operator lcomb))
+ (values (scode/combination-operands lcomb)))
+ (scode/lambda-components operator
+ (lambda (tag names opt rest aux decls body)
+ tag opt rest aux
+ (receiver names values decls body)))))
\f
;;;; Scode utilities (continued)
(eq? (scode/absolute-combination-name object) 'ERROR-PROCEDURE))))
(define (scode/error-combination-components combination receiver)
- (scode/combination-components combination
- (lambda (operator operands)
- operator
- (receiver
- (car operands)
- (let loop ((irritants (cadr operands)))
- (cond ((null? irritants) '())
- ((and (scode/absolute-combination? irritants)
- (eq? (scode/absolute-combination-name irritants) 'LIST))
- (scode/absolute-combination-operands irritants))
- ((and (scode/combination? irritants)
- (eq? (scode/combination-operator irritants)
- (ucode-primitive cons)))
- (let ((operands (scode/combination-operands irritants)))
- (cons (car operands)
- (loop (cadr operands)))))
- (else
- (cadr operands))))))))
+ (let ((operands (scode/combination-operands combination)))
+ (receiver
+ (car operands)
+ (let loop ((irritants (cadr operands)))
+ (cond ((null? irritants) '())
+ ((and (scode/absolute-combination? irritants)
+ (eq? (scode/absolute-combination-name irritants) 'LIST))
+ (scode/absolute-combination-operands irritants))
+ ((and (scode/combination? irritants)
+ (eq? (scode/combination-operator irritants)
+ (ucode-primitive cons)))
+ (let ((operands (scode/combination-operands irritants)))
+ (cons (car operands)
+ (loop (cadr operands)))))
+ (else
+ (cadr operands)))))))
(define (scode/make-error-combination message operand)
(scode/make-absolute-combination
(canout-needs? a)
(canout-splice? a)))
-(define ((canonicalize/unary open close) expression bound context)
- (open expression
- (lambda (exp)
- (canonicalize/combine-unary close
- (canonicalize/expression exp bound context)))))
+(define ((canonicalize/unary combiner part1) expression bound context)
+ (canonicalize/combine-unary combiner
+ (canonicalize/expression (part1 expression) bound context)))
(define (canonicalize/combine-binary combiner a b)
(make-canout (combiner (canout-expr a) (canout-expr b))
(or (canout-needs? a) (canout-needs? b))
(and (canout-splice? a) (canout-splice? b))))
-(define ((canonicalize/binary open close) expression bound context)
- (open expression
- (lambda (a b)
- (canonicalize/combine-binary close
- (canonicalize/expression a bound context)
- (canonicalize/expression b bound context)))))
+(define ((canonicalize/binary combiner part1 part2) expression bound context)
+ (canonicalize/combine-binary combiner
+ (canonicalize/expression (part1 expression) bound context)
+ (canonicalize/expression (part2 expression) bound context)))
(define (canonicalize/combine-ternary combiner a b c)
(make-canout (combiner (canout-expr a) (canout-expr b) (canout-expr c))
(or (canout-needs? a) (canout-needs? b) (canout-needs? c))
(and (canout-splice? a) (canout-splice? b) (canout-splice? c))))
-(define ((canonicalize/ternary open close) expression bound context)
- (open expression
- (lambda (a b c)
- (canonicalize/combine-ternary close
- (canonicalize/expression a bound context)
- (canonicalize/expression b bound context)
- (canonicalize/expression c bound context)))))
+(define ((canonicalize/ternary combiner part1 part2 part3)
+ expression bound context)
+ (canonicalize/combine-ternary combiner
+ (canonicalize/expression (part1 expression) bound context)
+ (canonicalize/expression (part2 expression) bound context)
+ (canonicalize/expression (part3 expression) bound context)))
(define canonicalize/constant
canonicalize/trivial)
original-expression))
(define (comment body recvr)
- (scode/comment-components
- body
- (lambda (text nbody)
- (if (and (scode/comment-directive? text 'ENCLOSE)
- (scode/combination? nbody))
- (scode/combination-components
- nbody
- (lambda (operator operands)
- (if (and (eq? operator (ucode-primitive SCODE-EVAL))
- (scode/quotation? (car operands))
- (scode/variable? (cadr operands))
- (eq? (scode/variable-name (cadr operands))
- environment-variable))
- (recvr (scode/quotation-expression (car operands)))
- (normal))))
- (normal)))))
-
+ (let ((text (scode/comment-text body))
+ (nbody (scode/comment-expression body)))
+ (if (and (scode/comment-directive? text 'ENCLOSE)
+ (scode/combination? nbody))
+ (let ((operator (scode/combination-operator nbody))
+ (operands (scode/combination-operands nbody)))
+ (if (and (eq? operator (ucode-primitive SCODE-EVAL))
+ (scode/quotation? (car operands))
+ (scode/variable? (cadr operands))
+ (eq? (scode/variable-name (cadr operands))
+ environment-variable))
+ (recvr (scode/quotation-expression (car operands)))
+ (normal)))
+ (normal))))
+
(cond ((scode/variable? body)
(let ((name (scode/variable-name body)))
(if (eq? name environment-variable)
((not (scode/the-environment? exp))
(normal))
((scode/combination? body)
- (scode/combination-components
- body
- (lambda (operator operands)
- (if (or (not (scode/comment? operator))
- (not (null? operands)))
- (normal)
- (comment operator
- (lambda (nopr)
- (scode/make-combination nopr '())))))))
+ (let ((operator (scode/combination-operator body))
+ (operands (scode/combination-operands body)))
+ (if (or (not (scode/comment? operator))
+ (not (null? operands)))
+ (normal)
+ (comment operator
+ (lambda (nopr)
+ (scode/make-combination nopr '()))))))
((scode/comment? body)
(comment body (lambda (nbody) nbody)))
(else (normal))))
true true false)))))
(define (canonicalize/assignment expr bound context)
- (scode/assignment-components
- expr
- (lambda (name old-value)
- (let ((value (canonicalize/expression old-value bound context)))
- (cond ((eq? context 'ARBITRARY)
- (canonicalize/combine-binary scode/make-assignment
- (make-canout name true false (if (memq name bound) true false))
- value))
- ((memq name bound)
- (canonicalize/combine-binary scode/make-assignment
- (make-canout name true false true)
- value))
- (else
- (make-canout
- (scode/make-combination (ucode-primitive LEXICAL-ASSIGNMENT)
- (list (scode/make-variable environment-variable)
- name
- (canout-expr value)))
- (canout-safe? value)
- true false)))))))
+ (let ((name (scode/assignment-name expr))
+ (old-value (scode/assignment-value expr)))
+ (let ((value (canonicalize/expression old-value bound context)))
+ (cond ((eq? context 'ARBITRARY)
+ (canonicalize/combine-binary scode/make-assignment
+ (make-canout name true false (if (memq name bound) true false))
+ value))
+ ((memq name bound)
+ (canonicalize/combine-binary scode/make-assignment
+ (make-canout name true false true)
+ value))
+ (else
+ (make-canout
+ (scode/make-combination (ucode-primitive LEXICAL-ASSIGNMENT)
+ (list (scode/make-variable environment-variable)
+ name
+ (canout-expr value)))
+ (canout-safe? value)
+ true false))))))
\f
;;;; Hairy expressions
(define (canonicalize/definition expression bound context)
- (scode/definition-components expression
- (lambda (name value)
- (let ((value (canonicalize/expression value bound context)))
- (if (memq context '(ONCE-ONLY ARBITRARY))
- (error "canonicalize/definition: unscanned definition"
- expression))
- (single-definition name value context)))))
+ (let ((name (scode/definition-name expression))
+ (value (scode/definition-value expression)))
+ (let ((value (canonicalize/expression value bound context)))
+ (if (memq context '(ONCE-ONLY ARBITRARY))
+ (error "canonicalize/definition: unscanned definition"
+ expression))
+ (single-definition name value context))))
(define (canonicalize/the-environment expr bound context)
expr bound context ;; ignored
(define (canonicalize/sequence expr bound context)
(cond ((not (scode/open-block? expr))
- (scode/sequence-components expr
- (lambda (actions)
- (canonicalize/combine-unary
- scode/make-sequence
- (combine-list (map (lambda (act)
- (canonicalize/expression act bound context))
- actions))))))
+ (canonicalize/combine-unary
+ scode/make-sequence
+ (combine-list (map (lambda (act)
+ (canonicalize/expression act bound context))
+ (scode/sequence-actions expr)))))
((or (eq? context 'ONCE-ONLY)
(eq? context 'ARBITRARY)
(and (eq? context 'FIRST-CLASS)
;; Collect continguous simple definitions into multi-definitions
;; in an attempt to make the top-level code smaller.
;; Note: MULTI-DEFINITION can reorder the definitions, so this
-;; code must be careful. Currently it only collects
+;; code must be careful. Currently it only collects
;; lambda expressions or expressions with no free variables.
;; Note: call-with-current-continuation at top-level may
;; expose this, but unless the programmer goes out of his/her
(if (or (not (scode/sequence? expr))
(scode/open-block? expr))
(give-up)
- (scode/sequence-components
- expr
- (lambda (actions)
+ (let ((actions (scode/sequence-actions expr)))
(define (add-group group groups)
(cond ((null? group)
groups)
(cons out
(add-group group groups))
'())))
- (scode/definition-components
- next
- (lambda (name value)
- (let ((value*
- (canonicalize/expression value bound context)))
- (cond ((not (canout-safe? value*))
- (give-up))
- ((or (scode/lambda? value)
- ;; This means that there are no free vars.
- (canout-splice? value*))
- (collect (cdr actions)
- groups
- (cons (list name value*)
- group)))
- (else
- (collect (cdr actions)
- (cons (single-definition name value*
- context)
- (add-group group groups))
- '()))))))))))
-
- (collect actions '() '())))))
+ (let ((name (scode/definition-name next))
+ (value (scode/definition-value next)))
+ (let ((value*
+ (canonicalize/expression value bound context)))
+ (cond ((not (canout-safe? value*))
+ (give-up))
+ ((or (scode/lambda? value)
+ ;; This means that there are no free vars.
+ (canout-splice? value*))
+ (collect (cdr actions)
+ groups
+ (cons (list name value*)
+ group)))
+ (else
+ (collect (cdr actions)
+ (cons (single-definition name value*
+ context)
+ (add-group group groups))
+ '())))))))))
+
+ (collect actions '() '()))))
\f
;;;; Hairier expressions
(EQ? (SCODE/ABSOLUTE-REFERENCE-NAME ,value) ',name)))))))
(define (canonicalize/combination expr bound context)
- (scode/combination-components
- expr
- (lambda (operator operands)
- (cond ((lambda? operator)
- (canonicalize/let operator operands bound context))
- ((and (is-operator? operator lexical-unassigned?)
- (scode/the-environment? (car operands))
- (symbol? (cadr operands)))
- (canonicalize/unassigned? (cadr operands) expr bound context))
- ((and (is-operator? operator error-procedure)
- (scode/the-environment? (caddr operands)))
- (canonicalize/error operator operands bound context))
- (else
- (canonicalize/combine-binary
- scode/make-combination
- (canonicalize/expression operator bound context)
- (combine-list
- (map (lambda (op)
- (canonicalize/expression op bound context))
- operands))))))))
+ (let ((operator (scode/combination-operator expr))
+ (operands (scode/combination-operands expr)))
+ (cond ((scode/lambda? operator)
+ (canonicalize/let operator operands bound context))
+ ((and (is-operator? operator lexical-unassigned?)
+ (scode/the-environment? (car operands))
+ (symbol? (cadr operands)))
+ (canonicalize/unassigned? (cadr operands) expr bound context))
+ ((and (is-operator? operator error-procedure)
+ (scode/the-environment? (caddr operands)))
+ (canonicalize/error operator operands bound context))
+ (else
+ (canonicalize/combine-binary
+ scode/make-combination
+ (canonicalize/expression operator bound context)
+ (combine-list
+ (map (lambda (op)
+ (canonicalize/expression op bound context))
+ operands)))))))
(define (canonicalize/unassigned? name expr bound context)
(cond ((not (eq? context 'FIRST-CLASS))
;;;; Protect from further canonicalization
(define (canonicalize/comment expr bound context)
- (scode/comment-components
- expr
- (lambda (text body)
- (if (not (and (scode/comment-directive? text 'PROCESSED 'ENCLOSE)
- (scode/combination? body)))
- (canonicalize/combine-unary
- (lambda (body*)
- (scode/make-comment text body*))
- (canonicalize/expression body bound context))
- (scode/combination-components
- body
- (lambda (operator operands)
- (if (and (eq? operator (ucode-primitive SCODE-EVAL))
- (scode/the-environment? (cadr operands)))
- (make-canout
- (scode/make-directive
- (scode/make-combination
- operator
- (list (car operands)
- (scode/make-variable environment-variable)))
- (cadr text)
- (caddr text))
- false true false)
- (make-canout expr true true false))))))))
+ (let ((text (scode/comment-text expr))
+ (body (scode/comment-expression expr)))
+ (if (not (and (scode/comment-directive? text 'PROCESSED 'ENCLOSE)
+ (scode/combination? body)))
+ (canonicalize/combine-unary
+ (lambda (body*)
+ (scode/make-comment text body*))
+ (canonicalize/expression body bound context))
+ (let ((operator (scode/combination-operator body))
+ (operands (scode/combination-operands body)))
+ (if (and (eq? operator (ucode-primitive SCODE-EVAL))
+ (scode/the-environment? (cadr operands)))
+ (make-canout
+ (scode/make-directive
+ (scode/make-combination
+ operator
+ (list (car operands)
+ (scode/make-variable environment-variable)))
+ (cadr text)
+ (caddr text))
+ false true false)
+ (make-canout expr true true false))))))
;;;; Utility for hairy expressions
;; For the following optimization it is assumed that
;; scode/make-evaluation is called only in restricted ways.
(else
- (scode/combination-components
- exp
- (lambda (operator operands)
- (if (or (not (null? operands))
- (not (scode/lambda? operator)))
- (default)
- (scode/lambda-components
- operator
- (lambda (name req opt rest aux decls body)
- name req opt rest aux decls ;; ignored
- (if (not (scode/comment? body))
- (default)
- (scode/comment-components
- body
- (lambda (text expr)
- expr ;; ignored
- (if (not (scode/comment-directive? text 'PROCESSED))
- (default)
- exp))))))))))))
+ (let ((operator (scode/combination-operator exp))
+ (operands (scode/combination-operands exp)))
+ (if (or (not (null? operands))
+ (not (scode/lambda? operator)))
+ (default)
+ (scode/lambda-components
+ operator
+ (lambda (name req opt rest aux decls body)
+ name req opt rest aux decls ;; ignored
+ (if (and (scode/comment? body)
+ (scode/comment-directive? (scode/comment-text body)
+ 'processed))
+ exp
+ (default)))))))))
\f
;;;; Hair cubed
(canonicalize/bind-environment (canout-expr nbody)
env-code
body)))
-
+
(if (canonicalize/optimization-low? context)
nexpr
(scode/make-evaluation nexpr
(nary-entry
(sc-macro-transformer
(lambda (form environment)
- (let ((nary (cadr form))
- (name (caddr form)))
+ (let ((name (cadr form))
+ (parts (cddr form)))
`(DISPATCH-ENTRY ,name
,(close-syntax
- `(,(symbol 'CANONICALIZE/ nary)
- ,(symbol 'SCODE/ name '-COMPONENTS)
- ,(symbol 'SCODE/MAKE- name))
- environment))))))
-
- (binary-entry
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(NARY-ENTRY BINARY ,(cadr form))))))
+ `(,(case (length parts)
+ ((1) 'canonicalize/unary)
+ ((2) 'canonicalize/binary)
+ ((3) 'canonicalize/ternary)
+ (else (error "Unsupported entry:" name)))
+ ,(symbol 'scode/make- name)
+ ,@(map (lambda (part)
+ (symbol 'scode/ name '- part))
+ parts))
+ environment)))))))
;; quotations are treated as constants.
- (binary-entry access)
+ (nary-entry access environment name)
(standard-entry assignment)
(standard-entry comment)
- (nary-entry ternary conditional)
+ (nary-entry conditional predicate consequent alternative)
(standard-entry definition)
- (nary-entry unary delay)
- (binary-entry disjunction)
+ (nary-entry delay expression)
+ (nary-entry disjunction predicate alternative)
(standard-entry variable)
(standard-entry the-environment)
(dispatch-entry combination canonicalize/combination)
(cons value values)
auxiliary
(if (null? actions*)
- (list undefined-conditional-branch)
+ (list undefined-scode-conditional-branch)
actions*)))
(lambda (names* values auxiliary actions*)
(return-4 names*
first-action
(generate/expression
block continuation context
- (make-sequence (cdr (scode/sequence-actions expression))))))
+ (scode/make-sequence (cdr (scode/sequence-actions expression))))))
(error "Not a sequence" expression)))
(define (generate/conditional block continuation context expression)
- (scode/conditional-components expression
- (lambda (predicate consequent alternative)
- (let ((predicate
- (generate/subproblem/predicate
- block continuation context
- predicate 'CONDITIONAL-DECIDE expression)))
- (let ((simple
- (lambda (hooks branch)
- ((scfg*ctype->ctype! continuation)
- (make-scfg (cfg-entry-node predicate) hooks)
- (generate/expression block continuation context branch)))))
- (cond ((hooks-null? (pcfg-consequent-hooks predicate))
- (simple (pcfg-alternative-hooks predicate) alternative))
- ((hooks-null? (pcfg-alternative-hooks predicate))
- (simple (pcfg-consequent-hooks predicate) consequent))
- (else
- (let ((finish
- (lambda (continuation combiner)
- (combiner
- predicate
- (generate/expression block continuation
- (context/conditional context)
- consequent)
- (generate/expression block continuation
- (context/conditional context)
- alternative)))))
- ((continuation/case continuation
- (lambda () (finish continuation pcfg*scfg->scfg!))
- (lambda () (finish continuation pcfg*scfg->scfg!))
- (lambda () (finish continuation pcfg*pcfg->pcfg!))
- (lambda ()
- (with-reified-continuation block
- continuation
- scfg*subproblem->subproblem!
- (lambda (push continuation)
- push ;ignore
- (finish continuation
- (lambda (predicate consequent alternative)
- (make-subproblem/canonical
- (pcfg*scfg->scfg!
- predicate
- (subproblem-prefix consequent)
- (subproblem-prefix alternative))
- continuation))))))))))))))))
+ (let ((predicate (scode/conditional-predicate expression))
+ (consequent (scode/conditional-consequent expression))
+ (alternative (scode/conditional-alternative expression)))
+ (let ((predicate
+ (generate/subproblem/predicate
+ block continuation context
+ predicate 'CONDITIONAL-DECIDE expression)))
+ (let ((simple
+ (lambda (hooks branch)
+ ((scfg*ctype->ctype! continuation)
+ (make-scfg (cfg-entry-node predicate) hooks)
+ (generate/expression block continuation context branch)))))
+ (cond ((hooks-null? (pcfg-consequent-hooks predicate))
+ (simple (pcfg-alternative-hooks predicate) alternative))
+ ((hooks-null? (pcfg-alternative-hooks predicate))
+ (simple (pcfg-consequent-hooks predicate) consequent))
+ (else
+ (let ((finish
+ (lambda (continuation combiner)
+ (combiner
+ predicate
+ (generate/expression block continuation
+ (context/conditional context)
+ consequent)
+ (generate/expression block continuation
+ (context/conditional context)
+ alternative)))))
+ ((continuation/case continuation
+ (lambda () (finish continuation pcfg*scfg->scfg!))
+ (lambda () (finish continuation pcfg*scfg->scfg!))
+ (lambda () (finish continuation pcfg*pcfg->pcfg!))
+ (lambda ()
+ (with-reified-continuation block
+ continuation
+ scfg*subproblem->subproblem!
+ (lambda (push continuation)
+ push ;ignore
+ (finish continuation
+ (lambda (predicate consequent alternative)
+ (make-subproblem/canonical
+ (pcfg*scfg->scfg!
+ predicate
+ (subproblem-prefix consequent)
+ (subproblem-prefix alternative))
+ continuation)))))))))))))))
\f
(define (generate/combination block continuation context expression)
- (scode/combination-components expression
- (lambda (operator operands)
- (cond ((eq? (ucode-primitive not) operator)
- (generate/conditional block continuation context
- (scode/make-conditional (car operands)
- #F #T)))
- ((and (eq? (ucode-primitive general-car-cdr) operator)
- (let ((n (cadr operands)))
- (and (exact-integer? n)
- (positive? n))))
- (generate/expression
- block continuation context
- (let loop ((expression (car operands)) (n (cadr operands)))
- (if (= n 1)
- expression
- (loop (scode/make-combination
- (if (= (remainder n 2) 1)
- (ucode-primitive car)
- (ucode-primitive cdr))
- (list expression))
- (quotient n 2))))))
- (else
- (generate/operator
- block continuation context expression operator
- (generate/operands expression operands block continuation context 1)))))))
+ (let ((operator (scode/combination-operator expression))
+ (operands (scode/combination-operands expression)))
+ (cond ((eq? (ucode-primitive not) operator)
+ (generate/conditional block continuation context
+ (scode/make-conditional (car operands)
+ #F #T)))
+ ((and (eq? (ucode-primitive general-car-cdr) operator)
+ (let ((n (cadr operands)))
+ (and (exact-integer? n)
+ (positive? n))))
+ (generate/expression
+ block continuation context
+ (let loop ((expression (car operands)) (n (cadr operands)))
+ (if (= n 1)
+ expression
+ (loop (scode/make-combination
+ (if (= (remainder n 2) 1)
+ (ucode-primitive car)
+ (ucode-primitive cdr))
+ (list expression))
+ (quotient n 2))))))
+ (else
+ (generate/operator
+ block continuation context expression operator
+ (generate/operands expression operands block continuation context
+ 1))))))
(define (generate/operands expression operands block continuation context index)
(let walk ((operands operands) (index index))
(if (pair? operands)
;; This forces the order of evaluation
- (let ((next (generate/subproblem/value block continuation context
- (car operands) 'COMBINATION-OPERAND
- expression index)))
+ (let ((next
+ (generate/subproblem/value block continuation context
+ (car operands) 'COMBINATION-OPERAND
+ expression index)))
(cons next
(walk (cdr operands) (1+ index))))
'())))
\f
-(define (generate/operator block continuation context expression operator operands*)
+(define (generate/operator block continuation context expression operator
+ operands*)
(let ((make-combination
(lambda (push continuation)
(make-combination
(continue/effect block continuation #f))))
(define (generate/assignment block continuation context expression)
- (scode/assignment-components expression
- (lambda (name value)
- (if (continuation/effect? continuation)
- (generate/assignment* make-assignment find-name 'ASSIGNMENT-CONTINUE
- block continuation context
- expression name value)
- (generate/combination
- block continuation context
- (let ((old-value (generate-uninterned-symbol "set-old-"))
- (new-value (generate-uninterned-symbol "set-new-")))
- (scode/make-let (list new-value)
- (list value)
- (scode/make-let (list old-value)
- (list (scode/make-safe-variable name))
- (scode/make-assignment name (scode/make-variable new-value))
- (scode/make-variable old-value)))))))))
+ (let ((name (scode/assignment-name expression))
+ (value (scode/assignment-value expression)))
+ (if (continuation/effect? continuation)
+ (generate/assignment* make-assignment find-name 'ASSIGNMENT-CONTINUE
+ block continuation context
+ expression name value)
+ (generate/combination
+ block continuation context
+ (let ((old-value (generate-uninterned-symbol "set-old-"))
+ (new-value (generate-uninterned-symbol "set-new-")))
+ (scode/make-let (list new-value)
+ (list value)
+ (scode/make-let (list old-value)
+ (list (scode/make-safe-variable name))
+ (scode/make-assignment name (scode/make-variable new-value))
+ (scode/make-variable old-value))))))))
(define (generate/definition block continuation context expression)
- (scode/definition-components expression
- (lambda (name value)
- (if (continuation/effect? continuation)
- (generate/assignment* make-definition make-definition-variable
- 'DEFINITION-CONTINUE block continuation
- context expression name
- (insert-letrec name value))
- (generate/expression
- block continuation context
- (scode/make-sequence (list expression name)))))))
+ (let ((name (scode/definition-name expression))
+ (value (scode/definition-value expression)))
+ (if (continuation/effect? continuation)
+ (generate/assignment* make-definition make-definition-variable
+ 'DEFINITION-CONTINUE block continuation
+ context expression name
+ (insert-letrec name value))
+ (generate/expression
+ block continuation context
+ (scode/make-sequence (list expression name))))))
(define (make-definition-variable block name)
(let ((bound (block-bound-variables block)))
block continuation context expression))
(define (generate/disjunction/control block continuation context expression)
- (scode/disjunction-components expression
- (lambda (predicate alternative)
- (generate/conditional
- block continuation context
- (scode/make-conditional predicate #t alternative)))))
+ (let ((predicate (scode/disjunction-predicate expression))
+ (alternative (scode/disjunction-alternative expression)))
+ (generate/conditional
+ block continuation context
+ (scode/make-conditional predicate #t alternative))))
(define (generate/disjunction/value block continuation context expression)
- (scode/disjunction-components expression
- (lambda (predicate alternative)
- (if (and (scode/combination? predicate)
- (boolean-valued-operator?
- (scode/combination-operator predicate)))
- (generate/conditional
- block continuation context
- (scode/make-conditional predicate #t alternative))
- (generate/combination
- block continuation context
- (let ((temp (generate-uninterned-symbol "or-predicate-")))
- (scode/make-let (list temp)
- (list predicate)
- (let ((predicate (scode/make-variable temp)))
- (scode/make-conditional predicate
- predicate
- alternative)))))))))
+ (let ((predicate (scode/disjunction-predicate expression))
+ (alternative (scode/disjunction-alternative expression)))
+ (if (and (scode/combination? predicate)
+ (boolean-valued-operator?
+ (scode/combination-operator predicate)))
+ (generate/conditional
+ block continuation context
+ (scode/make-conditional predicate #t alternative))
+ (generate/combination
+ block continuation context
+ (let ((temp (generate-uninterned-symbol "or-predicate-")))
+ (scode/make-let (list temp)
+ (list predicate)
+ (let ((predicate (scode/make-variable temp)))
+ (scode/make-conditional predicate
+ predicate
+ alternative))))))))
(define (boolean-valued-operator? operator)
(cond ((scode/primitive-procedure? operator)
#f)))
\f
(define (generate/access block continuation context expression)
- (scode/access-components expression
- (lambda (environment name)
- (generate/combination
- block continuation context
- (scode/make-combination (ucode-primitive lexical-reference)
- (list environment name))))))
+ (generate/combination
+ block continuation context
+ (scode/make-combination (ucode-primitive lexical-reference)
+ (list (scode/access-environment expression)
+ (scode/access-name expression)))))
;; Handle directives inserted by the canonicalizer
(define (generate/comment block continuation context comment)
- (scode/comment-components comment
- (lambda (text expression)
- (if (not (scode/comment-directive? text))
- (generate/expression block continuation context expression)
- (case (caadr text)
- ((PROCESSED)
- (generate/expression block continuation context expression))
- ((COMPILE)
- (if (not (scode/quotation? expression))
- (error "Bad COMPILE directive" comment))
- (continue/rvalue-constant
- block continuation
- (make-constant
- (compile-recursively
- (scode/quotation-expression expression)
- #f
- #f))))
- ((COMPILE-PROCEDURE)
- (let ((process
- (lambda (name)
- (if compiler:compile-by-procedures?
- (continue/rvalue-constant
- block continuation
- (make-constant
- (compile-recursively expression #t name)))
- (generate/expression block continuation
- context expression))))
- (fail
- (lambda ()
- (error "Bad COMPILE-PROCEDURE directive" comment))))
- (cond ((scode/lambda? expression)
- (process (lambda-name expression)))
- ((scode/open-block? expression)
- (scode/open-block-components
- expression
- (lambda (names decls body)
- decls ; ignored
- (if (and (null? names) (scode/lambda? body))
- (process (lambda-name body))
- (fail)))))
- (else
- (fail)))))
- ((ENCLOSE)
- (generate/enclose block continuation context expression))
- ((CONSTANTIFY)
- (generate/constantify block continuation context comment expression))
- (else
- (warn "generate/comment: Unknown directive" (cadr text) comment)
- (generate/expression block continuation context expression)))))))
+ (let ((text (scode/comment-text comment))
+ (expression (scode/comment-expression comment)))
+ (if (not (scode/comment-directive? text))
+ (generate/expression block continuation context expression)
+ (case (caadr text)
+ ((PROCESSED)
+ (generate/expression block continuation context expression))
+ ((COMPILE)
+ (if (not (scode/quotation? expression))
+ (error "Bad COMPILE directive" comment))
+ (continue/rvalue-constant
+ block continuation
+ (make-constant
+ (compile-recursively
+ (scode/quotation-expression expression)
+ #f
+ #f))))
+ ((COMPILE-PROCEDURE)
+ (let ((process
+ (lambda (name)
+ (if compiler:compile-by-procedures?
+ (continue/rvalue-constant
+ block continuation
+ (make-constant
+ (compile-recursively expression #t name)))
+ (generate/expression block continuation
+ context expression))))
+ (fail
+ (lambda ()
+ (error "Bad COMPILE-PROCEDURE directive" comment))))
+ (cond ((scode/lambda? expression)
+ (process (scode/lambda-name expression)))
+ ((scode/open-block? expression)
+ (scode/open-block-components
+ expression
+ (lambda (names decls body)
+ decls ; ignored
+ (if (and (null? names) (scode/lambda? body))
+ (process (scode/lambda-name body))
+ (fail)))))
+ (else
+ (fail)))))
+ ((ENCLOSE)
+ (generate/enclose block continuation context expression))
+ ((CONSTANTIFY)
+ (generate/constantify block continuation context comment expression))
+ (else
+ (warn "generate/comment: Unknown directive" (cadr text) comment)
+ (generate/expression block continuation context expression))))))
\f
;; CONSTANTIFY directives are generated when an expression is introduced by
;; the canonicalizer. It instructs fggen that the expression may be constant
;; for some more information.
(define (generate/enclose block continuation context expression)
- (scode/combination-components
- expression
- (lambda (operator operands)
- operator ;; ignored
- (generate/lambda*
- (block-parent block) continuation
- context (context/make-internal)
- (scode/quotation-expression (car operands))
- #f
- (make-reference block
- (find-name block
- (scode/variable-name (cadr operands)))
- #f)))))
+ (let ((operands (scode/combination-operands expression)))
+ (generate/lambda*
+ (block-parent block) continuation
+ context (context/make-internal)
+ (scode/quotation-expression (car operands))
+ #f
+ (make-reference block
+ (find-name block
+ (scode/variable-name (cadr operands)))
+ #f))))
\f
(define (generate/delay block continuation context expression)
(generate/combination
ucode-primitive
ucode-type)
(import ()
- (scode/access-components access-components)
- (scode/access-environment access-environment)
- (scode/access-name access-name)
- (scode/access? access?)
- (scode/assignment-components assignment-components)
- (scode/assignment-name assignment-name)
- (scode/assignment-value assignment-value)
- (scode/assignment? assignment?)
- (scode/combination-components combination-components)
- (scode/combination-operands combination-operands)
- (scode/combination-operator combination-operator)
- (scode/combination? combination?)
- (scode/comment-components comment-components)
- (scode/comment-expression comment-expression)
- (scode/comment-text comment-text)
- (scode/comment? comment?)
- (scode/conditional-alternative conditional-alternative)
- (scode/conditional-components conditional-components)
- (scode/conditional-consequent conditional-consequent)
- (scode/conditional-predicate conditional-predicate)
- (scode/conditional? conditional?)
+ (scode/access-environment scode-access-environment)
+ (scode/access-name scode-access-name)
+ (scode/access? scode-access?)
+ (scode/assignment-name scode-assignment-name)
+ (scode/assignment-value scode-assignment-value)
+ (scode/assignment? scode-assignment?)
+ (scode/combination-operands scode-combination-operands)
+ (scode/combination-operator scode-combination-operator)
+ (scode/combination? scode-combination?)
+ (scode/comment-expression scode-comment-expression)
+ (scode/comment-text scode-comment-text)
+ (scode/comment? scode-comment?)
+ (scode/conditional-alternative scode-conditional-alternative)
+ (scode/conditional-consequent scode-conditional-consequent)
+ (scode/conditional-predicate scode-conditional-predicate)
+ (scode/conditional? scode-conditional?)
(scode/constant? scode-constant?)
- (scode/declaration-components declaration-components)
- (scode/declaration-expression declaration-expression)
- (scode/declaration-text declaration-text)
- (scode/declaration? declaration?)
- (scode/definition-components definition-components)
- (scode/definition-name definition-name)
- (scode/definition-value definition-value)
- (scode/definition? definition?)
- (scode/delay-components delay-components)
- (scode/delay-expression delay-expression)
- (scode/delay? delay?)
- (scode/disjunction-alternative disjunction-alternative)
- (scode/disjunction-components disjunction-components)
- (scode/disjunction-predicate disjunction-predicate)
- (scode/disjunction? disjunction?)
- (scode/lambda-components lambda-components)
- (scode/lambda? lambda?)
- (scode/make-access make-access)
- (scode/make-assignment make-assignment)
- (scode/make-combination make-combination)
- (scode/make-comment make-comment)
- (scode/make-conditional make-conditional)
- (scode/make-declaration make-declaration)
- (scode/make-definition make-definition)
- (scode/make-delay make-delay)
- (scode/make-disjunction make-disjunction)
- (scode/make-lambda make-lambda)
+ (scode/declaration-expression scode-declaration-expression)
+ (scode/declaration-text scode-declaration-text)
+ (scode/declaration? scode-declaration?)
+ (scode/definition-name scode-definition-name)
+ (scode/definition-value scode-definition-value)
+ (scode/definition? scode-definition?)
+ (scode/delay-expression scode-delay-expression)
+ (scode/delay? scode-delay?)
+ (scode/disjunction-alternative scode-disjunction-alternative)
+ (scode/disjunction-predicate scode-disjunction-predicate)
+ (scode/disjunction? scode-disjunction?)
+ (scode/lambda-components scode-lambda-components)
+ (scode/lambda-body scode-lambda-body)
+ (scode/lambda-name scode-lambda-name)
+ (scode/lambda? scode-lambda?)
+ (scode/make-access make-scode-access)
+ (scode/make-assignment make-scode-assignment)
+ (scode/make-combination make-scode-combination)
+ (scode/make-comment make-scode-comment)
+ (scode/make-conditional make-scode-conditional)
+ (scode/make-declaration make-scode-declaration)
+ (scode/make-definition make-scode-definition)
+ (scode/make-delay make-scode-delay)
+ (scode/make-disjunction make-scode-disjunction)
+ (scode/make-lambda make-scode-lambda)
(scode/make-open-block make-open-block)
- (scode/make-quotation make-quotation)
- (scode/make-sequence make-sequence)
- (scode/make-the-environment make-the-environment)
- (scode/make-unassigned? make-unassigned?)
- (scode/make-variable make-variable)
+ (scode/make-quotation make-scode-quotation)
+ (scode/make-sequence make-scode-sequence)
+ (scode/make-the-environment make-scode-the-environment)
+ (scode/make-unassigned? make-scode-unassigned?)
+ (scode/make-variable make-scode-variable)
(scode/open-block-components open-block-components)
(scode/open-block? open-block?)
(scode/primitive-procedure? primitive-procedure?)
(scode/procedure? procedure?)
- (scode/quotation-expression quotation-expression)
- (scode/quotation? quotation?)
- (scode/sequence-actions sequence-actions)
- (scode/sequence-components sequence-components)
- (scode/sequence-immediate-first sequence-immediate-first)
- (scode/sequence-immediate-second sequence-immediate-second)
- (scode/sequence-first sequence-first)
- (scode/sequence-second sequence-second)
- (scode/sequence? sequence?)
+ (scode/quotation-expression scode-quotation-expression)
+ (scode/quotation? scode-quotation?)
+ (scode/sequence-actions scode-sequence-actions)
+ (scode/sequence? scode-sequence?)
+ (scode/set-lambda-body! set-scode-lambda-body!)
(scode/symbol? symbol?)
- (scode/the-environment? the-environment?)
- (scode/unassigned?-name unassigned?-name)
- (scode/unassigned?? unassigned??)
- (scode/variable-components variable-components)
- (scode/variable-name variable-name)
- (scode/variable? variable?)))
+ (scode/the-environment? scode-the-environment?)
+ (scode/unassigned?-name scode-unassigned?-name)
+ (scode/unassigned?? scode-unassigned??)
+ (scode/variable-name scode-variable-name)
+ (scode/variable? scode-variable?)))
\f
(define-package (compiler reference-contexts)
(files "base/refctx")
ucode-primitive
ucode-type)
(import ()
- (scode/access-components access-components)
- (scode/access-environment access-environment)
- (scode/access-name access-name)
- (scode/access? access?)
- (scode/assignment-components assignment-components)
- (scode/assignment-name assignment-name)
- (scode/assignment-value assignment-value)
- (scode/assignment? assignment?)
- (scode/combination-components combination-components)
- (scode/combination-operands combination-operands)
- (scode/combination-operator combination-operator)
- (scode/combination? combination?)
- (scode/comment-components comment-components)
- (scode/comment-expression comment-expression)
- (scode/comment-text comment-text)
- (scode/comment? comment?)
- (scode/conditional-alternative conditional-alternative)
- (scode/conditional-components conditional-components)
- (scode/conditional-consequent conditional-consequent)
- (scode/conditional-predicate conditional-predicate)
- (scode/conditional? conditional?)
+ (scode/access-environment scode-access-environment)
+ (scode/access-name scode-access-name)
+ (scode/access? scode-access?)
+ (scode/assignment-name scode-assignment-name)
+ (scode/assignment-value scode-assignment-value)
+ (scode/assignment? scode-assignment?)
+ (scode/combination-operands scode-combination-operands)
+ (scode/combination-operator scode-combination-operator)
+ (scode/combination? scode-combination?)
+ (scode/comment-expression scode-comment-expression)
+ (scode/comment-text scode-comment-text)
+ (scode/comment? scode-comment?)
+ (scode/conditional-alternative scode-conditional-alternative)
+ (scode/conditional-consequent scode-conditional-consequent)
+ (scode/conditional-predicate scode-conditional-predicate)
+ (scode/conditional? scode-conditional?)
(scode/constant? scode-constant?)
- (scode/declaration-components declaration-components)
- (scode/declaration-expression declaration-expression)
- (scode/declaration-text declaration-text)
- (scode/declaration? declaration?)
- (scode/definition-components definition-components)
- (scode/definition-name definition-name)
- (scode/definition-value definition-value)
- (scode/definition? definition?)
- (scode/delay-components delay-components)
- (scode/delay-expression delay-expression)
- (scode/delay? delay?)
- (scode/disjunction-alternative disjunction-alternative)
- (scode/disjunction-components disjunction-components)
- (scode/disjunction-predicate disjunction-predicate)
- (scode/disjunction? disjunction?)
- (scode/lambda-components lambda-components)
- (scode/lambda? lambda?)
- (scode/make-access make-access)
- (scode/make-assignment make-assignment)
- (scode/make-combination make-combination)
- (scode/make-comment make-comment)
- (scode/make-conditional make-conditional)
- (scode/make-declaration make-declaration)
- (scode/make-definition make-definition)
- (scode/make-delay make-delay)
- (scode/make-disjunction make-disjunction)
- (scode/make-lambda make-lambda)
+ (scode/declaration-expression scode-declaration-expression)
+ (scode/declaration-text scode-declaration-text)
+ (scode/declaration? scode-declaration?)
+ (scode/delay-expression scode-delay-expression)
+ (scode/delay? scode-delay?)
+ (scode/disjunction-alternative scode-disjunction-alternative)
+ (scode/disjunction-predicate scode-disjunction-predicate)
+ (scode/disjunction? scode-disjunction?)
+ (scode/lambda-components scode-lambda-components)
+ (scode/lambda-body scode-lambda-body)
+ (scode/lambda-name scode-lambda-name)
+ (scode/lambda? scode-lambda?)
+ (scode/make-access make-scode-access)
+ (scode/make-assignment make-scode-assignment)
+ (scode/make-combination make-scode-combination)
+ (scode/make-comment make-scode-comment)
+ (scode/make-conditional make-scode-conditional)
+ (scode/make-declaration make-scode-declaration)
+ (scode/make-definition make-scode-definition)
+ (scode/make-delay make-scode-delay)
+ (scode/make-disjunction make-scode-disjunction)
+ (scode/make-lambda make-scode-lambda)
(scode/make-open-block make-open-block)
- (scode/make-quotation make-quotation)
- (scode/make-sequence make-sequence)
- (scode/make-the-environment make-the-environment)
- (scode/make-unassigned? make-unassigned?)
- (scode/make-variable make-variable)
+ (scode/make-quotation make-scode-quotation)
+ (scode/make-sequence make-scode-sequence)
+ (scode/make-the-environment make-scode-the-environment)
+ (scode/make-unassigned? make-scode-unassigned?)
+ (scode/make-variable make-scode-variable)
(scode/open-block-components open-block-components)
(scode/open-block? open-block?)
(scode/primitive-procedure? primitive-procedure?)
(scode/procedure? procedure?)
- (scode/quotation-expression quotation-expression)
- (scode/quotation? quotation?)
- (scode/sequence-actions sequence-actions)
- (scode/sequence-components sequence-components)
- (scode/sequence-immediate-first sequence-immediate-first)
- (scode/sequence-immediate-second sequence-immediate-second)
- (scode/sequence-first sequence-first)
- (scode/sequence-second sequence-second)
- (scode/sequence? sequence?)
+ (scode/quotation-expression scode-quotation-expression)
+ (scode/quotation? scode-quotation?)
+ (scode/sequence-actions scode-sequence-actions)
+ (scode/sequence? scode-sequence?)
+ (scode/set-lambda-body! set-scode-lambda-body!)
(scode/symbol? symbol?)
- (scode/the-environment? the-environment?)
- (scode/unassigned?-name unassigned?-name)
- (scode/unassigned?? unassigned??)
- (scode/variable-components variable-components)
- (scode/variable-name variable-name)
- (scode/variable? variable?)))
+ (scode/the-environment? scode-the-environment?)
+ (scode/unassigned?-name scode-unassigned?-name)
+ (scode/unassigned?? scode-unassigned??)
+ (scode/variable-name scode-variable-name)
+ (scode/variable? scode-variable?)))
\f
(define-package (compiler reference-contexts)
(files "base/refctx")
(define (write-constant block symbol-table constant)
(write-string (cdr (write-to-string constant 60)))
- (cond ((lambda? constant)
+ (cond ((scode-lambda? constant)
(let ((expression (lambda-body constant)))
(if (and (compiled-code-address? expression)
(eq? (compiled-code-address->block expression) block))
ucode-primitive
ucode-type)
(import ()
- (scode/access-components access-components)
- (scode/access-environment access-environment)
- (scode/access-name access-name)
- (scode/access? access?)
- (scode/assignment-components assignment-components)
- (scode/assignment-name assignment-name)
- (scode/assignment-value assignment-value)
- (scode/assignment? assignment?)
- (scode/combination-components combination-components)
- (scode/combination-operands combination-operands)
- (scode/combination-operator combination-operator)
- (scode/combination? combination?)
- (scode/comment-components comment-components)
- (scode/comment-expression comment-expression)
- (scode/comment-text comment-text)
- (scode/comment? comment?)
- (scode/conditional-alternative conditional-alternative)
- (scode/conditional-components conditional-components)
- (scode/conditional-consequent conditional-consequent)
- (scode/conditional-predicate conditional-predicate)
- (scode/conditional? conditional?)
+ (scode/access-environment scode-access-environment)
+ (scode/access-name scode-access-name)
+ (scode/access? scode-access?)
+ (scode/assignment-name scode-assignment-name)
+ (scode/assignment-value scode-assignment-value)
+ (scode/assignment? scode-assignment?)
+ (scode/combination-operands scode-combination-operands)
+ (scode/combination-operator scode-combination-operator)
+ (scode/combination? scode-combination?)
+ (scode/comment-expression scode-comment-expression)
+ (scode/comment-text scode-comment-text)
+ (scode/comment? scode-comment?)
+ (scode/conditional-alternative scode-conditional-alternative)
+ (scode/conditional-consequent scode-conditional-consequent)
+ (scode/conditional-predicate scode-conditional-predicate)
+ (scode/conditional? scode-conditional?)
(scode/constant? scode-constant?)
- (scode/declaration-components declaration-components)
- (scode/declaration-expression declaration-expression)
- (scode/declaration-text declaration-text)
- (scode/declaration? declaration?)
- (scode/definition-components definition-components)
- (scode/definition-name definition-name)
- (scode/definition-value definition-value)
- (scode/definition? definition?)
- (scode/delay-components delay-components)
- (scode/delay-expression delay-expression)
- (scode/delay? delay?)
- (scode/disjunction-alternative disjunction-alternative)
- (scode/disjunction-components disjunction-components)
- (scode/disjunction-predicate disjunction-predicate)
- (scode/disjunction? disjunction?)
- (scode/lambda-components lambda-components)
- (scode/lambda? lambda?)
- (scode/make-access make-access)
- (scode/make-assignment make-assignment)
- (scode/make-combination make-combination)
- (scode/make-comment make-comment)
- (scode/make-conditional make-conditional)
- (scode/make-declaration make-declaration)
- (scode/make-definition make-definition)
- (scode/make-delay make-delay)
- (scode/make-disjunction make-disjunction)
- (scode/make-lambda make-lambda)
+ (scode/declaration-expression scode-declaration-expression)
+ (scode/declaration-text scode-declaration-text)
+ (scode/declaration? scode-declaration?)
+ (scode/definition-name scode-definition-name)
+ (scode/definition-value scode-definition-value)
+ (scode/definition? scode-definition?)
+ (scode/delay-expression scode-delay-expression)
+ (scode/delay? scode-delay?)
+ (scode/disjunction-alternative scode-disjunction-alternative)
+ (scode/disjunction-predicate scode-disjunction-predicate)
+ (scode/disjunction? scode-disjunction?)
+ (scode/lambda-components scode-lambda-components)
+ (scode/lambda-body scode-lambda-body)
+ (scode/lambda-name scode-lambda-name)
+ (scode/lambda? scode-lambda?)
+ (scode/make-access make-scode-access)
+ (scode/make-assignment make-scode-assignment)
+ (scode/make-combination make-scode-combination)
+ (scode/make-comment make-scode-comment)
+ (scode/make-conditional make-scode-conditional)
+ (scode/make-declaration make-scode-declaration)
+ (scode/make-definition make-scode-definition)
+ (scode/make-delay make-scode-delay)
+ (scode/make-disjunction make-scode-disjunction)
+ (scode/make-lambda make-scode-lambda)
(scode/make-open-block make-open-block)
- (scode/make-quotation make-quotation)
- (scode/make-sequence make-sequence)
- (scode/make-the-environment make-the-environment)
- (scode/make-unassigned? make-unassigned?)
- (scode/make-variable make-variable)
+ (scode/make-quotation make-scode-quotation)
+ (scode/make-sequence make-scode-sequence)
+ (scode/make-the-environment make-scode-the-environment)
+ (scode/make-unassigned? make-scode-unassigned?)
+ (scode/make-variable make-scode-variable)
(scode/open-block-components open-block-components)
(scode/open-block? open-block?)
(scode/primitive-procedure? primitive-procedure?)
(scode/procedure? procedure?)
- (scode/quotation-expression quotation-expression)
- (scode/quotation? quotation?)
- (scode/sequence-actions sequence-actions)
- (scode/sequence-components sequence-components)
- (scode/sequence-immediate-first sequence-immediate-first)
- (scode/sequence-immediate-second sequence-immediate-second)
- (scode/sequence-first sequence-first)
- (scode/sequence-second sequence-second)
- (scode/sequence? sequence?)
+ (scode/quotation-expression scode-quotation-expression)
+ (scode/quotation? scode-quotation?)
+ (scode/sequence-actions scode-sequence-actions)
+ (scode/sequence? scode-sequence?)
+ (scode/set-lambda-body! set-scode-lambda-body!)
(scode/symbol? symbol?)
- (scode/the-environment? the-environment?)
- (scode/unassigned?-name unassigned?-name)
- (scode/unassigned?? unassigned??)
- (scode/variable-components variable-components)
- (scode/variable-name variable-name)
- (scode/variable? variable?)))
+ (scode/the-environment? scode-the-environment?)
+ (scode/unassigned?-name scode-unassigned?-name)
+ (scode/unassigned?? scode-unassigned??)
+ (scode/variable-name scode-variable-name)
+ (scode/variable? scode-variable?)))
\f
(define-package (compiler reference-contexts)
(files "base/refctx")
(define (write-constant constant cursor)
(write-string (cdr (write-to-string constant 60)))
- (cond ((lambda? constant)
+ (cond ((scode-lambda? constant)
(let ((expression (lambda-body constant)))
(if (and (compiled-code-address? expression)
(eq? (compiled-code-address->block expression)
ucode-primitive
ucode-type)
(import ()
- (scode/access-components access-components)
- (scode/access-environment access-environment)
- (scode/access-name access-name)
- (scode/access? access?)
- (scode/assignment-components assignment-components)
- (scode/assignment-name assignment-name)
- (scode/assignment-value assignment-value)
- (scode/assignment? assignment?)
- (scode/combination-components combination-components)
- (scode/combination-operands combination-operands)
- (scode/combination-operator combination-operator)
- (scode/combination? combination?)
- (scode/comment-components comment-components)
- (scode/comment-expression comment-expression)
- (scode/comment-text comment-text)
- (scode/comment? comment?)
- (scode/conditional-alternative conditional-alternative)
- (scode/conditional-components conditional-components)
- (scode/conditional-consequent conditional-consequent)
- (scode/conditional-predicate conditional-predicate)
- (scode/conditional? conditional?)
+ (scode/access-environment scode-access-environment)
+ (scode/access-name scode-access-name)
+ (scode/access? scode-access?)
+ (scode/assignment-name scode-assignment-name)
+ (scode/assignment-value scode-assignment-value)
+ (scode/assignment? scode-assignment?)
+ (scode/combination-operands scode-combination-operands)
+ (scode/combination-operator scode-combination-operator)
+ (scode/combination? scode-combination?)
+ (scode/comment-expression scode-comment-expression)
+ (scode/comment-text scode-comment-text)
+ (scode/comment? scode-comment?)
+ (scode/conditional-alternative scode-conditional-alternative)
+ (scode/conditional-consequent scode-conditional-consequent)
+ (scode/conditional-predicate scode-conditional-predicate)
+ (scode/conditional? scode-conditional?)
(scode/constant? scode-constant?)
- (scode/declaration-components declaration-components)
- (scode/declaration-expression declaration-expression)
- (scode/declaration-text declaration-text)
- (scode/declaration? declaration?)
- (scode/definition-components definition-components)
- (scode/definition-name definition-name)
- (scode/definition-value definition-value)
- (scode/definition? definition?)
- (scode/delay-components delay-components)
- (scode/delay-expression delay-expression)
- (scode/delay? delay?)
- (scode/disjunction-alternative disjunction-alternative)
- (scode/disjunction-components disjunction-components)
- (scode/disjunction-predicate disjunction-predicate)
- (scode/disjunction? disjunction?)
- (scode/lambda-components lambda-components)
- (scode/lambda? lambda?)
- (scode/make-access make-access)
- (scode/make-assignment make-assignment)
- (scode/make-combination make-combination)
- (scode/make-comment make-comment)
- (scode/make-conditional make-conditional)
- (scode/make-declaration make-declaration)
- (scode/make-definition make-definition)
- (scode/make-delay make-delay)
- (scode/make-disjunction make-disjunction)
- (scode/make-lambda make-lambda)
+ (scode/declaration-expression scode-declaration-expression)
+ (scode/declaration-text scode-declaration-text)
+ (scode/declaration? scode-declaration?)
+ (scode/definition-name scode-definition-name)
+ (scode/definition-value scode-definition-value)
+ (scode/definition? scode-definition?)
+ (scode/delay-expression scode-delay-expression)
+ (scode/delay? scode-delay?)
+ (scode/disjunction-alternative scode-disjunction-alternative)
+ (scode/disjunction-predicate scode-disjunction-predicate)
+ (scode/disjunction? scode-disjunction?)
+ (scode/lambda-components scode-lambda-components)
+ (scode/lambda-body scode-lambda-body)
+ (scode/lambda-name scode-lambda-name)
+ (scode/lambda? scode-lambda?)
+ (scode/make-access make-scode-access)
+ (scode/make-assignment make-scode-assignment)
+ (scode/make-combination make-scode-combination)
+ (scode/make-comment make-scode-comment)
+ (scode/make-conditional make-scode-conditional)
+ (scode/make-declaration make-scode-declaration)
+ (scode/make-definition make-scode-definition)
+ (scode/make-delay make-scode-delay)
+ (scode/make-disjunction make-scode-disjunction)
+ (scode/make-lambda make-scode-lambda)
(scode/make-open-block make-open-block)
- (scode/make-quotation make-quotation)
- (scode/make-sequence make-sequence)
- (scode/make-the-environment make-the-environment)
- (scode/make-unassigned? make-unassigned?)
- (scode/make-variable make-variable)
+ (scode/make-quotation make-scode-quotation)
+ (scode/make-sequence make-scode-sequence)
+ (scode/make-the-environment make-scode-the-environment)
+ (scode/make-unassigned? make-scode-unassigned?)
+ (scode/make-variable make-scode-variable)
(scode/open-block-components open-block-components)
(scode/open-block? open-block?)
(scode/primitive-procedure? primitive-procedure?)
(scode/procedure? procedure?)
- (scode/quotation-expression quotation-expression)
- (scode/quotation? quotation?)
- (scode/sequence-actions sequence-actions)
- (scode/sequence-components sequence-components)
- (scode/sequence-immediate-first sequence-immediate-first)
- (scode/sequence-immediate-second sequence-immediate-second)
- (scode/sequence-first sequence-first)
- (scode/sequence-second sequence-second)
- (scode/sequence? sequence?)
+ (scode/quotation-expression scode-quotation-expression)
+ (scode/quotation? scode-quotation?)
+ (scode/sequence-actions scode-sequence-actions)
+ (scode/sequence? scode-sequence?)
+ (scode/set-lambda-body! set-scode-lambda-body!)
(scode/symbol? symbol?)
- (scode/the-environment? the-environment?)
- (scode/unassigned?-name unassigned?-name)
- (scode/unassigned?? unassigned??)
- (scode/variable-components variable-components)
- (scode/variable-name variable-name)
- (scode/variable? variable?)))
+ (scode/the-environment? scode-the-environment?)
+ (scode/unassigned?-name scode-unassigned?-name)
+ (scode/unassigned?? scode-unassigned??)
+ (scode/variable-name scode-variable-name)
+ (scode/variable? scode-variable?)))
\f
(define-package (compiler reference-contexts)
(files "base/refctx")
(define (write-constant block symbol-table constant)
(write-string (cdr (write-to-string constant 60)))
- (cond ((lambda? constant)
- (let ((expression (lambda-body constant)))
+ (cond ((scode/lambda? constant)
+ (let ((expression (scode/lambda-body constant)))
(if (and (compiled-code-address? expression)
(eq? (compiled-code-address->block expression) block))
(begin
(if (pair? others)
(cons (vector false
'EXPRESSION
- (analyze-and-compress (make-sequence others)))
+ (analyze-and-compress (make-scode-sequence others)))
definition-analysis)
definition-analysis))))
(if (block-declaration? (car expressions))
(rest)
(receive (definitions others) (rest)
- (if (definition? (car expressions))
+ (if (scode-definition? (car expressions))
(values (cons (car expressions) definitions) others)
(values definitions (cons (car expressions) others))))))))
(define (process-top-level expression)
- (cond ((comment? expression)
- (process-top-level (comment-expression expression)))
- ((sequence? expression)
- (append-map! process-top-level (sequence-actions expression)))
+ (cond ((scode-comment? expression)
+ (process-top-level (scode-comment-expression expression)))
+ ((scode-sequence? expression)
+ (append-map! process-top-level (scode-sequence-actions expression)))
(else
(list expression))))
(define (analyze/top-level/definition definition)
- (let ((name (definition-name definition))
- (expression (definition-value definition)))
+ (let ((name (scode-definition-name definition))
+ (expression (scode-definition-value definition)))
(cond ((unassigned-reference-trap? expression)
(vector name 'UNASSIGNED '#()))
((scode-constant? expression)
(vector name 'CONSTANT '#()))
(else
(vector name
- (cond ((lambda? expression) 'LAMBDA)
- ((delay? expression) 'DELAY)
+ (cond ((scode-lambda? expression) 'LAMBDA)
+ ((scode-delay? expression) 'DELAY)
(else 'EXPRESSION))
(analyze-and-compress expression))))))
(error "Illegal expression" expression))
(define (analyze/access expression)
- (if (access-environment expression)
+ (if (scode-access-environment expression)
(warn "Access to non-global environment:" (unsyntax expression)))
(list expression))
(define (analyze/variable expression)
- (list (variable-name expression)))
+ (list (scode-variable-name expression)))
(define (analyze/assignment expression)
- (eq-set-adjoin (assignment-name expression)
- (analyze/expression (assignment-value expression))))
+ (eq-set-adjoin (scode-assignment-name expression)
+ (analyze/expression (scode-assignment-value expression))))
(define (analyze/combination expression)
- (eq-set-union (analyze/expression (combination-operator expression))
- (analyze/expressions (combination-operands expression))))
+ (eq-set-union (analyze/expression (scode-combination-operator expression))
+ (analyze/expressions (scode-combination-operands expression))))
(define (analyze/lambda expression)
- (lambda-components expression
+ (scode-lambda-components expression
(lambda (name required optional rest auxiliary declarations body)
name declarations
(eq-set-difference (analyze/expression body)
auxiliary)))))
\f
(define (analyze/error-combination expression)
- (combination-components expression
- (lambda (operator operands)
- (analyze/expressions (list operator (car operands) (cadr operands))))))
+ (let ((operator (scode-combination-operator expression))
+ (operands (scode-combination-operands expression)))
+ (analyze/expressions (list operator (car operands) (cadr operands)))))
(define (analyze/delay expression)
- (analyze/expression (delay-expression expression)))
+ (analyze/expression (scode-delay-expression expression)))
(define (analyze/sequence expression)
- (analyze/expressions (sequence-actions expression)))
+ (analyze/expressions (scode-sequence-actions expression)))
(define (analyze/conditional expression)
- (analyze/expressions (conditional-components expression list)))
+ (analyze/expressions
+ (list (scode-conditional-predicate expression)
+ (scode-conditional-consequent expression)
+ (scode-conditional-alternative expression))))
(define (analyze/disjunction expression)
- (analyze/expressions (disjunction-components expression list)))
+ (analyze/expressions
+ (list (scode-disjunction-predicate expression)
+ (scode-disjunction-alternative expression))))
(define (analyze/comment expression)
- (analyze/expression (comment-expression expression)))
+ (analyze/expression (scode-comment-expression expression)))
(define analyze/dispatch
(make-scode-walker
(make-reference primitive-package
(primitive-procedure-name name)
expression))
- ((access? name)
- (if (eq? (access-environment name)
+ ((scode-access? name)
+ (if (eq? (scode-access-environment name)
system-global-environment)
(make-reference root-package
- (access-name name)
+ (scode-access-name name)
expression)
(warn "Non-root access" (unsyntax name))))
(else
(files "xform")
(parent (edwin class-macros))
(export (edwin class-macros)
- transform-instance-variables)
- (import ()
- (make-scode-variable make-variable)
- (scode-variable-name variable-name)))
+ transform-instance-variables))
(define-package (edwin class-constructor)
(files "clscon")
(let ((entry (assq (scode-variable-name variable) transforms)))
(if (not entry)
variable
- (make-combination (make-primitive-procedure 'VECTOR-REF)
- (list name-of-self (cdr entry))))))
+ (make-scode-combination (make-primitive-procedure 'vector-ref)
+ (list name-of-self (cdr entry))))))
(define (transform-assignment transforms assignment)
- (assignment-components assignment
- (lambda (name value)
- (let ((entry (assq name transforms))
- (value (transform-expression transforms value)))
- (if (not entry)
- (make-assignment name value)
- (make-combination (make-primitive-procedure 'VECTOR-SET!)
- (list name-of-self
- (cdr entry)
- value)))))))
+ (let ((name (scode-assignment-name assignment))
+ (value (scode-assignment-value assignment)))
+ (let ((entry (assq name transforms))
+ (value (transform-expression transforms value)))
+ (if (not entry)
+ (make-scode-assignment name value)
+ (make-scode-combination (make-primitive-procedure 'vector-set!)
+ (list name-of-self
+ (cdr entry)
+ value))))))
(define (transform-combination transforms combination)
- (combination-components combination
- (lambda (operator operands)
- (make-combination (transform-expression transforms operator)
- (transform-expressions transforms operands)))))
+ (let ((operator (scode-combination-operator combination))
+ (operands (scode-combination-operands combination)))
+ (make-scode-combination (transform-expression transforms operator)
+ (transform-expressions transforms operands))))
\f
(define (transform-lambda transforms expression)
(lambda-components** expression
body)))))
(define (transform-definition transforms definition)
- (definition-components definition
- (lambda (name value)
- (error "Free definition encountered:" name)
- (make-definition name (transform-expression transforms value)))))
+ (let ((name (scode-definition-name definition))
+ (value (scode-definition-value definition)))
+ (error "Free definition encountered:" name)
+ (make-scode-definition name (transform-expression transforms value))))
(define (transform-sequence transforms expression)
- (make-sequence (transform-expressions transforms
- (sequence-actions expression))))
+ (make-scode-sequence
+ (transform-expressions transforms (scode-sequence-actions expression))))
(define (transform-conditional transforms conditional)
- (conditional-components conditional
- (lambda (predicate consequent alternative)
- (make-conditional (transform-expression transforms predicate)
- (transform-expression transforms consequent)
- (transform-expression transforms alternative)))))
+ (make-scode-conditional
+ (transform-expression transforms (scode-conditional-predicate conditional))
+ (transform-expression transforms (scode-conditional-consequent conditional))
+ (transform-expression transforms
+ (scode-conditional-alternative conditional))))
(define (transform-disjunction transforms disjunction)
- (disjunction-components disjunction
- (lambda (predicate alternative)
- (make-disjunction (transform-expression transforms predicate)
- (transform-expression transforms alternative)))))
+ (make-scode-disjunction
+ (transform-expression transforms (scode-disjunction-predicate disjunction))
+ (transform-expression transforms
+ (scode-disjunction-alternative disjunction))))
(define (transform-comment transforms comment)
- (comment-components comment
- (lambda (text expression)
- (make-comment text (transform-expression transforms expression)))))
+ (make-scode-comment
+ (scode-comment-text comment)
+ (transform-expression transforms (scode-comment-expression comment))))
(define (transform-delay transforms expression)
- (make-delay (transform-expression transforms (delay-expression expression))))
+ (make-scode-delay
+ (transform-expression transforms (scode-delay-expression expression))))
(define scode-walker
(make-scode-walker transform-constant
(string-append library "-const.bin"))
(not c-include-noisily?))))
(let ((enums.struct-values
- (if (comment? comment) (comment-expression comment)
+ (if (scode-comment? comment) (scode-comment-expression comment)
(error:wrong-type-datum comment "a fasl comment"))))
(warn-new-cdecls includes)
(set-c-includes/enum-values! includes (car enums.struct-values))
(define (make-advice-hook)
;; This inserts the actual procedure in a constant list.
- (make-combination
- (make-combination (ucode-primitive car)
+ (make-scode-combination
+ (make-scode-combination (ucode-primitive car)
(list (list hook/advised-procedure-wrapper)))
- (list (make-the-environment))))
+ (list (make-scode-the-environment))))
(define (hook/advised-procedure-wrapper environment)
(advised-procedure-wrapper environment))
table)))
\f
(define (walk/combination walker expression)
- (let ((operator (combination-operator expression)))
+ (let ((operator (scode-combination-operator expression)))
(cond ((and (or (eq? operator (ucode-primitive lexical-unassigned?))
- (absolute-reference-to? operator 'LEXICAL-UNASSIGNED?))
- (let ((operands (combination-operands expression)))
- (and (the-environment? (car operands))
+ (scode-absolute-reference-to? operator
+ 'lexical-unassigned?))
+ (let ((operands (scode-combination-operands expression)))
+ (and (scode-the-environment? (car operands))
(symbol? (cadr operands)))))
(scode-walker/unassigned? walker))
((or (eq? operator (ucode-primitive error-procedure))
- (absolute-reference-to? operator 'ERROR-PROCEDURE))
+ (scode-absolute-reference-to? operator 'error-procedure))
(scode-walker/error-combination walker))
(else
(scode-walker/combination walker)))))
(define (walk/comment walker expression)
- (if (declaration? expression)
+ (if (scode-declaration? expression)
(scode-walker/declaration walker)
(scode-walker/comment walker)))
("savres" (runtime save/restore))
("scan" (runtime scode-scan))
("scode" (runtime scode))
- ("scomb" (runtime scode-combinator))
("sdata" (runtime scode-data))
("sfile" (runtime simple-file-ops))
("socket" (runtime socket))
(define (environment-procedure-name environment)
(let ((scode-lambda (environment-lambda environment)))
(and scode-lambda
- (lambda-name scode-lambda))))
+ (scode-lambda-name scode-lambda))))
(define (environment-lambda environment)
(cond ((system-global-environment? environment)
(define (method/force-snap-thunk frame)
(let ((promise (stack-frame/ref frame 1)))
- (values (make-combination (ucode-primitive force 1)
- (list (make-evaluated-object promise)))
+ (values (make-scode-combination (ucode-primitive force 1)
+ (list (make-evaluated-object promise)))
undefined-environment
(cond ((promise-forced? promise) undefined-expression)
((promise-non-expression? promise) unknown-expression)
(promise-expression promise)))))))
(define ((method/application-frame index) frame)
- (values (make-combination
+ (values (make-scode-combination
(make-evaluated-object (stack-frame/ref frame index))
(stack-frame-list frame (1+ index)))
undefined-environment
undefined-expression))
(define (method/compiler-lookup-apply-trap-restart frame)
- (values (make-combination (make-variable (stack-frame/ref frame 2))
- (stack-frame-list frame 6))
+ (values (make-scode-combination
+ (make-scode-variable (stack-frame/ref frame 2))
+ (stack-frame-list frame 6))
(stack-frame/ref frame 3)
undefined-expression))
(define (method/compiler-error-restart frame)
(let ((primitive (stack-frame/ref frame 2)))
(if (primitive-procedure? primitive)
- (values (make-combination (make-variable 'apply)
- (list primitive
- unknown-expression))
+ (values (make-scode-combination (make-scode-variable 'apply)
+ (list primitive
+ unknown-expression))
undefined-environment
undefined-expression)
(stack-frame/debugging-info/default frame))))
(validate-subexpression
frame
(if (zero? (vector-ref source-code 2))
- (combination-operator expression)
- (list-ref (combination-operands expression)
+ (scode-combination-operator expression)
+ (list-ref (scode-combination-operands expression)
(-1+ (vector-ref source-code 2)))))))
((COMBINATION-ELEMENT)
(win2 undefined-environment
(lose))))
(lose))))
((dbg-procedure? object)
- (values (lambda-body (dbg-procedure/source-code object))
+ (values (scode-lambda-body (dbg-procedure/source-code object))
(and (dbg-procedure/block object)
(get-environment))
undefined-expression))
(let ((method (method/application-frame 3)))
(record-method 'INTERNAL-APPLY method)
(record-method 'INTERNAL-APPLY-VAL method))
- (let ((method (method/compiler-reference-trap make-variable)))
+ (let ((method (method/compiler-reference-trap make-scode-variable)))
(record-method 'COMPILER-REFERENCE-TRAP-RESTART method)
(record-method 'COMPILER-SAFE-REFERENCE-TRAP-RESTART method))
(record-method 'COMPILER-UNASSIGNED?-TRAP-RESTART
- (method/compiler-reference-trap make-unassigned?))
+ (method/compiler-reference-trap make-scode-unassigned?))
(record-method 'COMPILER-ASSIGNMENT-TRAP-RESTART
- (method/compiler-assignment-trap make-assignment))
+ (method/compiler-assignment-trap make-scode-assignment))
(record-method 'COMPILER-LOOKUP-APPLY-TRAP-RESTART
method/compiler-lookup-apply-trap-restart)
(record-method 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART
(eq? 'unbound (environment-reference-type env name)))
(let ((env (->environment '())))
+
+ (define (provide-rename new-name old-name)
+ (if (unbound? env new-name)
+ (eval `(define ,new-name ,old-name) env)))
+
(if (unbound? env 'guarantee)
(eval `(define (guarantee predicate object #!optional caller)
(if (predicate object)
(eval '(define (bytes-per-object)
(vector-ref (gc-space-status) 0))
env))
- (if (unbound? env 'random-bytevector)
- (eval '(define random-bytevector random-byte-vector) env))
- (if (unbound? env 'string-foldcase)
- (eval '(define string-foldcase string-downcase) env)))
+
+ (provide-rename 'random-bytevector 'random-byte-vector)
+ (provide-rename 'string-foldcase 'string-downcase)
+
+ (for-each (lambda (old-name)
+ (provide-rename (symbol 'scode- old-name) old-name))
+ '(access-environment
+ access-name
+ access?
+ assignment-name
+ assignment-value
+ assignment?
+ combination-operands
+ combination-operator
+ combination?
+ comment-expression
+ comment-text
+ comment?
+ conditional-alternative
+ conditional-consequent
+ conditional-predicate
+ conditional?
+ constant?
+ declaration-expression
+ declaration-text
+ declaration?
+ definition-name
+ definition-value
+ definition?
+ delay-expression
+ delay?
+ disjunction-alternative
+ disjunction-predicate
+ disjunction?
+ lambda-components
+ lambda-body
+ lambda-name
+ lambda?
+ quotation-expression
+ quotation?
+ sequence-actions
+ sequence?
+ the-environment?
+ unassigned?-name
+ unassigned??
+ variable-name
+ variable?))
+ (for-each (lambda (root)
+ (provide-rename (symbol 'make-scode- root)
+ (symbol 'make- root)))
+ '(access
+ assignment
+ combination
+ comment
+ conditional
+ declaration
+ definition
+ delay
+ disjunction
+ lambda
+ quotation
+ sequence
+ the-environment
+ unassigned?
+ variable))
+ (provide-rename 'set-scode-lambda-body! 'set-lambda-body!))
(let ((env (->environment '(runtime))))
(if (unbound? env 'select-on-bytes-per-word)
blocks))
0
com-pathname))
- ((and (comment? value)
- (dbg-info-vector? (comment-text value)))
- (let ((blocks (dbg-info-vector/blocks-vector (comment-text value))))
+ ((and (scode-comment? value)
+ (dbg-info-vector? (scode-comment-text value)))
+ (let ((blocks
+ (dbg-info-vector/blocks-vector (scode-comment-text value))))
(fasload-update-internal (vector-ref blocks 0)
blocks
1
(or (and (dbg-procedure? object)
(let ((scode (dbg-procedure/source-code object)))
(and scode
- (lambda-body scode))))
+ (scode-lambda-body scode))))
entry)))
\f
;;; Support of BSM files
(declare (usual-integrations))
\f
-(define lambda-body)
-(define set-lambda-body!)
-(define lambda-bound)
-(define lambda-bound?)
-(define lambda-interface)
-(define lambda-name)
+(define scode-lambda-body)
+(define set-scode-lambda-body!)
+(define scode-lambda-bound)
+(define scode-lambda-bound?)
+(define scode-lambda-interface)
+(define scode-lambda-name)
;;; A lambda is an abstract 7-tuple consisting of these elements:
;;; name name of the lambda
-;;; required list of symbols, required arguments in order (null if no required)
-;;; optional list of symbols, optional arguments in order, (null if no optionals)
+;;; required list of symbols, required arguments in order
+;;; optional list of symbols, optional arguments in order
;;; rest symbol, rest argument, #F if no rest argument
-;;; auxiliary list of auxiliaries to be bound to unassigned, (null if no auxiliaries)
+;;; auxiliary list of auxiliaries to be bound to unassigned
;;; declarations list of declarations for the lexical block
;;; body an expression. If there are auxiliaries, the body typically
;;; begins with the appropriate assignments.
(dispatch-1 'LAMBDA-ARITY
slambda-arity
xlambda-arity))
- (set! lambda-body
- (dispatch-0 'LAMBDA-BODY
+ (set! scode-lambda-body
+ (dispatch-0 'scode-lambda-body
clambda-unwrapped-body
xlambda-unwrapped-body))
- (set! lambda-bound
- (dispatch-0 'LAMBDA-BOUND
+ (set! scode-lambda-bound
+ (dispatch-0 'scode-lambda-bound
clambda-bound
xlambda-bound))
- (set! lambda-bound?
- (dispatch-1 'LAMBDA-BOUND?
+ (set! scode-lambda-bound?
+ (dispatch-1 'scode-lambda-bound?
clambda-bound?
xlambda-bound?))
(set! lambda-immediate-body
(dispatch-0 'LAMBDA-IMMEDIATE-BODY
slambda-body
xlambda-body))
- (set! lambda-interface
- (dispatch-0 'LAMBDA-INTERFACE
+ (set! scode-lambda-interface
+ (dispatch-0 'scode-lambda-interface
slambda-interface
xlambda-interface))
- (set! lambda-name
- (dispatch-0 'LAMBDA-NAME
+ (set! scode-lambda-name
+ (dispatch-0 'scode-lambda-name
slambda-name
xlambda-name))
(set! lambda-names-vector
(dispatch-1 'LAMBDA-WRAPPER-COMPONENTS
clambda-wrapper-components
xlambda-wrapper-components))
- (set! set-lambda-body!
- (dispatch-1 'SET-LAMBDA-BODY!
+ (set! set-scode-lambda-body!
+ (dispatch-1 'set-scode-lambda-body!
set-clambda-unwrapped-body!
set-xlambda-unwrapped-body!)))
\f
(set-physical-body! *lambda new-body)))))
(define-integrable (make-wrapper original-body new-body state)
- (make-comment (vector wrapper-tag original-body state) new-body))
+ (make-scode-comment (vector wrapper-tag original-body state) new-body))
(define (wrapper? object)
- (and (comment? object)
- (let ((text (comment-text object)))
+ (and (scode-comment? object)
+ (let ((text (scode-comment-text object)))
(and (vector? text)
(not (zero? (vector-length text)))
(eq? (vector-ref text 0) wrapper-tag)))))
'(LAMBDA-WRAPPER))
(define-integrable (wrapper-body wrapper)
- (comment-expression wrapper))
+ (scode-comment-expression wrapper))
(define-integrable (set-wrapper-body! wrapper body)
- (set-comment-expression! wrapper body))
+ (set-scode-comment-expression! wrapper body))
(define-integrable (wrapper-state wrapper)
- (vector-ref (comment-text wrapper) 2))
+ (vector-ref (scode-comment-text wrapper) 2))
(define-integrable (set-wrapper-state! wrapper new-state)
- (vector-set! (comment-text wrapper) 2 new-state))
+ (vector-set! (scode-comment-text wrapper) 2 new-state))
(define-integrable (wrapper-original-body wrapper)
- (vector-ref (comment-text wrapper) 1))
+ (vector-ref (scode-comment-text wrapper) 1))
(define-integrable (set-wrapper-original-body! wrapper body)
- (vector-set! (comment-text wrapper) 1 body))
+ (vector-set! (scode-comment-text wrapper) 1 body))
\f
;;;; Compound Lambda
(lambda-body-has-internal-lambda? (slambda-body clambda)))
(define (lambda-body-auxiliary body)
- (if (combination? body)
- (let ((operator (combination-operator body)))
+ (if (scode-combination? body)
+ (let ((operator (scode-combination-operator body)))
(if (internal-lambda? operator)
(slambda-auxiliary operator)
'()))
'()))
(define (lambda-body-has-internal-lambda? body)
- (and (combination? body)
- (let ((operator (combination-operator body)))
+ (and (scode-combination? body)
+ (let ((operator (scode-combination-operator body)))
(and (internal-lambda? operator)
operator))))
(define (auxiliary-bound? body symbol)
- (and (combination? body)
- (let ((operator (combination-operator body)))
+ (and (scode-combination? body)
+ (let ((operator (scode-combination-operator body)))
(and (internal-lambda? operator)
(internal-lambda-bound? operator symbol)))))
\f
;;;; Generic Lambda
-(define (lambda? object)
+(define (scode-lambda? object)
(or (slambda? object)
(xlambda? object)))
-(define (make-lambda name required optional rest auxiliary declarations body)
+(define (make-scode-lambda name required optional rest auxiliary declarations
+ body)
(let ((interface (append required optional (if rest (list rest) '()))))
(let ((dup-interface (find-list-duplicates interface))
(dup-auxiliary (find-list-duplicates auxiliary)))
(let ((body*
(if (null? declarations)
body
- (make-sequence (list (make-block-declaration declarations)
- body)))))
+ (make-scode-sequence (list (make-block-declaration declarations)
+ body)))))
(cond ((and (< (length required) 256)
(< (length optional) 256)
(or (not (null? optional))
(else
(make-clambda name required auxiliary body*)))))
-(define (lambda-components *lambda receiver)
+(define (scode-lambda-components *lambda receiver)
(&lambda-components *lambda
(lambda (name required optional rest auxiliary body)
- (let ((actions (and (sequence? body) (sequence-actions body))))
+ (let ((actions
+ (and (scode-sequence? body)
+ (scode-sequence-actions body))))
(if (and actions (block-declaration? (car actions)))
(receiver name required optional rest auxiliary
(block-declaration-text (car actions))
- (make-sequence (cdr actions)))
+ (make-scode-sequence (cdr actions)))
(receiver name required optional rest auxiliary '() body))))))
(define (find-list-duplicates items)
(define (make-auxiliary-lambda auxiliary body)
(if (null? auxiliary)
body
- (make-combination (%make-internal-lambda auxiliary body)
- (make-unassigned auxiliary))))
+ (make-scode-combination (%make-internal-lambda auxiliary body)
+ (make-unassigned auxiliary))))
(define (internal-lambda? *lambda)
(and (slambda? *lambda)
(scan-defines
body
(lambda (auxiliary declarations body*)
- (make-lambda name required optional rest auxiliary declarations body*))))
+ (make-scode-lambda name required optional rest auxiliary declarations
+ body*))))
(define (lambda-components* *lambda receiver)
- (lambda-components *lambda
+ (scode-lambda-components *lambda
(lambda (name required optional rest auxiliary declarations body)
(receiver name required optional rest
(make-open-block auxiliary declarations body)))))
(file-regular? pathname)))
(define (load/purification-root object)
- (or (and (comment? object)
- (let ((text (comment-text object)))
+ (or (and (scode-comment? object)
+ (let ((text (scode-comment-text object)))
(and (dbg-info-vector? text)
(dbg-info-vector/purification-root text))))
(and (object-type? (ucode-type compiled-entry) object)
(case (frame/type frame)
((EVAL-ERROR)
(let ((expression (eval-frame/expression frame)))
- (if (variable? expression)
+ (if (scode-variable? expression)
(signal-reference (eval-frame/environment frame)
- (variable-name expression)))))
+ (scode-variable-name expression)))))
((ASSIGNMENT-CONTINUE)
(signal-other (eval-frame/environment frame)
- (assignment-name (eval-frame/expression frame))))
+ (scode-assignment-name (eval-frame/expression frame))))
((ACCESS-CONTINUE)
(signal-reference (pop-return-frame/value continuation)
- (access-name (eval-frame/expression frame))))
+ (scode-access-name (eval-frame/expression frame))))
((INTERNAL-APPLY INTERNAL-APPLY-VAL)
(let ((operator (apply-frame/operator frame)))
(cond ((or (eq? (ucode-primitive lexical-reference) operator)
;; result of the evaluation to be the object she was referring
;; to. If the quotation isn't there, the user just gets
;; confused.
- (make-quotation object)))
+ (make-scode-quotation object)))
(define (parse-unhash object)
(if (not (exact-nonnegative-integer? object))
(error "copy-SEQUENCE-object: Unknown type" obj)))
(define (copy-COMBINATION-object obj)
- (make-combination
- (copy-object (combination-operator obj))
- (map copy-object (combination-operands obj))))
+ (make-scode-combination
+ (copy-object (scode-combination-operator obj))
+ (map copy-object (scode-combination-operands obj))))
(define (copy-LAMBDA-object obj)
(cond ((object-type? (ucode-type lambda) obj)
(error "COPY-LAMBDA-object: Unknown type" obj))))
(define (copy-VARIABLE-object obj)
- (let ((var (make-variable (variable-name obj))))
+ (let ((var (make-scode-variable (scode-variable-name obj))))
(add-association! obj var)
var))
(define (copy-COMMENT-object obj)
- (let ((the-text (comment-text obj)))
+ (let ((the-text (scode-comment-text obj)))
(if (not (dbg-info-vector? the-text))
(%%copy-pair (ucode-type COMMENT) obj)
(let ((the-car (system-pair-car obj))
(else
(error "Illegal arity for entity:" procedure)))))
((%compound-procedure? p)
- (lambda-components (%compound-procedure-lambda p)
+ (scode-lambda-components (%compound-procedure-lambda p)
(lambda (name required optional rest auxiliary decl body)
name auxiliary decl body
(let ((r (fix:- (length required) e)))
with-obarray-lock)
(initialization (initialize-package!)))
-(define-package (runtime alternative-lambda)
- (files "lambdx")
- (parent (runtime))
- (export ()
- lambda-components*
- lambda-components**
- lambda-pattern/name
- lambda-pattern/optional
- lambda-pattern/required
- lambda-pattern/rest
- lambda-pattern?
- make-lambda*
- make-lambda**
- make-lambda-pattern))
-
(define-package (runtime merge-sort)
(files "msort")
(parent (runtime))
(files "lambda")
(parent (runtime))
(export ()
- block-declaration?
block-declaration-text
- lambda?
- lambda-body
- lambda-bound
- lambda-bound?
- lambda-components
- lambda-interface
- lambda-name
+ block-declaration?
make-block-declaration
- make-lambda
- set-lambda-body!)
+ make-scode-lambda
+ scode-lambda-body
+ scode-lambda-bound
+ scode-lambda-bound?
+ scode-lambda-components
+ scode-lambda-interface
+ scode-lambda-name
+ scode-lambda?
+ set-scode-lambda-body!)
(export (runtime advice)
lambda-unwrap-body!
lambda-wrap-body!
lambda-immediate-body)
(initialization (initialize-package!)))
+(define-package (runtime alternative-lambda)
+ (files "lambdx")
+ (parent (runtime))
+ (export ()
+ lambda-components*
+ lambda-components**
+ lambda-pattern/name
+ lambda-pattern/optional
+ lambda-pattern/required
+ lambda-pattern/rest
+ lambda-pattern?
+ make-lambda*
+ make-lambda**
+ make-lambda-pattern))
+
(define-package (runtime list)
(files "list")
(parent (runtime))
(files "scode")
(parent (runtime))
(export ()
- absolute-reference-name
- absolute-reference-to?
- absolute-reference?
- access-components
- access-environment
- access-name
- access?
- assignment-components
- assignment-components-with-variable
- assignment-name
- assignment-value
- assignment-variable
- assignment?
- comment-components
- comment-expression
- comment-text
- comment?
- declaration-components
- declaration-expression
- declaration-text
- declaration?
- definition-components
- definition-name
- definition-value
- definition?
- delay-components
- delay-expression
- delay?
- make-absolute-reference
- make-access
- make-assignment
- make-assignment-from-variable
- make-comment
- make-declaration
- make-definition
- make-delay
- make-quotation
- make-the-environment
- make-variable
- quotation-expression
- quotation?
+ make-scode-absolute-reference
+ make-scode-access
+ make-scode-assignment
+ make-scode-combination
+ make-scode-comment
+ make-scode-conditional
+ make-scode-declaration
+ make-scode-definition
+ make-scode-delay
+ make-scode-disjunction
+ make-scode-quotation
+ make-scode-sequence
+ make-scode-the-environment
+ make-scode-unassigned?
+ make-scode-variable
+ scode-absolute-reference-name
+ scode-absolute-reference-to?
+ scode-absolute-reference?
+ scode-access-environment
+ scode-access-name
+ scode-access?
+ scode-assignment-name
+ scode-assignment-value
+ scode-assignment?
+ scode-combination-operands
+ scode-combination-operator
+ scode-combination?
+ scode-comment-expression
+ scode-comment-text
+ scode-comment?
+ scode-conditional-alternative
+ scode-conditional-consequent
+ scode-conditional-predicate
+ scode-conditional?
scode-constant?
- set-comment-expression!
- set-comment-text!
- set-declaration-expression!
- set-declaration-text!
- the-environment?
- variable-components
- variable-name
- variable?)
- (initialization (initialize-package!)))
-
-(define-package (runtime scode-combinator)
- (files "scomb")
- (parent (runtime))
- (export ()
- combination-components
- combination-operands
- combination-operator
- combination-size
- combination-subexpressions
- combination?
- conditional-alternative
- conditional-components
- conditional-consequent
- conditional-predicate
- conditional-subexpressions
- conditional?
- disjunction-alternative
- disjunction-components
- disjunction-predicate
- disjunction-subexpressions
- disjunction?
- make-combination
- make-conditional
- make-disjunction
- make-sequence
- make-unassigned?
- sequence-actions
- sequence-components
- sequence-immediate-actions
- sequence-immediate-first
- sequence-immediate-second
- sequence-first
- sequence-second
- sequence?
- unassigned?-components
- unassigned?-name
- unassigned??
- undefined-conditional-branch)
- (initialization (initialize-package!)))
+ scode-declaration-expression
+ scode-declaration-text
+ scode-declaration?
+ scode-definition-name
+ scode-definition-value
+ scode-definition?
+ scode-delay-expression
+ scode-delay?
+ scode-disjunction-alternative
+ scode-disjunction-predicate
+ scode-disjunction?
+ scode-quotation-expression
+ scode-quotation?
+ scode-sequence-actions
+ scode-sequence?
+ scode-the-environment?
+ scode-unassigned?-name
+ scode-unassigned??
+ scode-variable-name
+ scode-variable?
+ undefined-scode-conditional-branch)
+ (export (runtime lambda-abstraction)
+ set-scode-comment-expression!))
(define-package (runtime scode-data)
(files "sdata")
&triple-third
&typed-pair-cons
&typed-triple-cons)
- (export (runtime scode)
- &pair-car
- &pair-cdr
- &pair-set-car!
- &pair-set-cdr!
- &singleton-element
- &typed-pair-cons
- &typed-singleton-cons)
- (export (runtime scode-combinator)
- &pair-car
- &pair-cdr
- &pair-set-car!
- &pair-set-cdr!
- &subvector->list
- &triple-first
- &triple-second
- &triple-set-first!
- &triple-set-second!
- &triple-set-third!
- &triple-third
- &typed-pair-cons
- &typed-triple-cons
- &typed-vector-cons
- &vector-length
- &vector-ref)
(export (runtime scode-scan)
&pair-car
&pair-cdr
open-block-actions
open-block-components
open-block-declarations
- open-block-definitions
open-block-names
open-block?
scan-defines
;;; OPEN-BLOCK-COMPONENTS, will connect directly to SCAN-DEFINES and
;;; UNSCAN-DEFINES, respectively.
-(define-integrable open-block-tag
- ((ucode-primitive string->symbol) "#[open-block]"))
-
(define-integrable sequence-type
(ucode-type sequence))
;;; This depends on the fact that the lambda abstraction will preserve
;;; the order of the auxiliaries. That is, giving MAKE-LAMBDA a list
-;;; of auxiliaries will result in LAMBDA-COMPONENTS returning an
+;;; of auxiliaries will result in SCODE-LAMBDA-COMPONENTS returning an
;;; EQUAL? list.
(define (scan-defines expression receiver)
((scan-loop expression receiver) '() '() null-sequence))
(define (scan-loop expression receiver)
- (cond ((open-block? expression) ; must come before SEQUENCE? clause
+ (cond ((open-block? expression) ; must come before SCODE-SEQUENCE? clause
(scan-loop
(%open-block-actions expression)
(lambda (names declarations body)
(receiver (append (%open-block-names expression) names)
- (append (%open-block-declarations expression) declarations)
+ (append (%open-block-declarations expression)
+ declarations)
body))))
- ((sequence? expression)
+ ((scode-sequence? expression)
;; Build the sequence from the tail-end first so that the
;; null-sequence shows up in the tail and is detected by
;; cons-sequence.
- (scan-loop (sequence-immediate-second expression)
- (scan-loop (sequence-immediate-first expression)
- receiver)))
- ((definition? expression)
- (definition-components expression
- (lambda (name value)
- (lambda (names declarations body)
- (receiver (cons name names)
- declarations
- (cons-sequence (make-assignment name value)
- body))))))
+ (let loop
+ ((actions (scode-sequence-actions expression))
+ (receiver receiver))
+ (if (pair? actions)
+ (loop (cdr actions)
+ (scan-loop (car actions) receiver))
+ receiver)))
+ ((scode-definition? expression)
+ (let ((name (scode-definition-name expression))
+ (value (scode-definition-value expression)))
+ (lambda (names declarations body)
+ (receiver (cons name names)
+ declarations
+ (cons-sequence (make-scode-assignment name value)
+ body)))))
((block-declaration? expression)
(lambda (names declarations body)
(receiver names
(cond ((not (pair? names))
(values '() body))
- ((assignment? body)
- (assignment-components body
- (lambda (name value)
- (if (eq? name (car names))
- (values (cdr names) (make-definition name value))
- (values names body)))))
-
- ((sequence? body)
- (let ((head (sequence-immediate-first body))
- (tail (sequence-immediate-second body)))
-
- (receive (names1 unscanned-head) (unscan-loop names head)
- (receive (names2 unscanned-tail) (unscan-loop names1 tail)
- (values names2
- ;; Only cons a new sequence if something changed.
- (if (and (eq? head unscanned-head)
- (eq? tail unscanned-tail))
- body
- (&typed-pair-cons
- sequence-type
- unscanned-head unscanned-tail)))))))
+ ((scode-assignment? body)
+ (let ((name (scode-assignment-name body))
+ (value (scode-assignment-value body)))
+ (if (eq? name (car names))
+ (values (cdr names) (make-scode-definition name value))
+ (values names body))))
+
+ ((scode-sequence? body)
+ (let loop
+ ((names names)
+ (actions (scode-sequence-actions body))
+ (unscanned-actions '()))
+ (if (pair? actions)
+ (receive (names* unscanned-action)
+ (unscan-loop names (car actions))
+ (loop names*
+ (cdr actions)
+ (cons unscanned-action unscanned-actions)))
+ (values names
+ (make-scode-sequence (reverse unscanned-actions))))))
(else
(values names body))))
(if (and (null? names)
(null? declarations))
actions
- (&typed-pair-cons
- sequence-type
- (make-open-block-descriptor names declarations)
- (&typed-pair-cons
- sequence-type
- (make-open-block-definitions names)
- actions))))
+ (make-scode-sequence
+ (cons (make-open-block-descriptor names declarations)
+ (append (map %make-open-block-definition names)
+ (list actions))))))
+
+(define (%make-open-block-definition name)
+ (make-scode-definition name (make-unassigned-reference-trap)))
(define (open-block? object)
- (and (sequence? object)
- (open-block-descriptor? (sequence-immediate-first object))
- (sequence? (sequence-immediate-second object))))
+ (and (scode-sequence? object)
+ (let ((actions (scode-sequence-actions object)))
+ (and (open-block-descriptor? (car actions))
+ (let ((names (%open-block-descriptor-names (car actions))))
+ (and (fix:> (length (cdr actions)) (length names))
+ (every %open-block-definition-named?
+ names
+ (cdr actions))))))))
+
+(define (%open-block-definition-named? name expr)
+ (and (scode-definition? expr)
+ (eq? name (scode-definition-name expr))
+ (unassigned-reference-trap? (scode-definition-value expr))))
-(define (open-block-actions open-block)
- (guarantee-open-block open-block 'OPEN-BLOCK-ACTIONS)
- (%open-block-actions open-block))
+(define (open-block-names open-block)
+ (guarantee open-block? open-block 'open-block-names)
+ (%open-block-names open-block))
(define (open-block-declarations open-block)
- (guarantee-open-block open-block 'OPEN-BLOCK-DECLARATIONS)
+ (guarantee open-block? open-block 'open-block-declarations)
(%open-block-declarations open-block))
-(define (open-block-definitions open-block)
- (guarantee-open-block open-block 'OPEN-BLOCK-DEFINITIONS)
- (%open-block-definitions open-block))
-
-(define (open-block-names open-block)
- (guarantee-open-block open-block 'OPEN-BLOCK-NAMES)
- (%open-block-names open-block))
+(define (open-block-actions open-block)
+ (guarantee open-block? open-block 'open-block-actions)
+ (%open-block-actions open-block))
(define (open-block-components open-block receiver)
- (guarantee-open-block open-block 'OPEN-BLOCK-COMPONENTS)
- (let ((descriptor (sequence-immediate-first open-block)))
- (receiver (%open-block-descriptor-names descriptor)
- (%open-block-descriptor-declarations descriptor)
- (%open-block-actions open-block))))
-
-(define (make-open-block-definitions names)
- (let ((definitions
- (map (lambda (name)
- (make-definition name (make-unassigned-reference-trap)))
- names)))
- (if (null? definitions)
- '()
- (make-sequence definitions))))
-
-(define-guarantee open-block "SCode open-block")
+ (guarantee open-block? open-block 'open-block-components)
+ (receiver (%open-block-names open-block)
+ (%open-block-declarations open-block)
+ (%open-block-actions open-block)))
(define (%open-block-descriptor open-block)
- (sequence-immediate-first open-block))
+ (car (scode-sequence-actions open-block)))
-(define (%open-block-actions open-block)
- (sequence-immediate-second (sequence-immediate-second open-block)))
+(define (%open-block-names open-block)
+ (%open-block-descriptor-names (%open-block-descriptor open-block)))
(define (%open-block-declarations open-block)
(%open-block-descriptor-declarations (%open-block-descriptor open-block)))
-(define (%open-block-definitions open-block)
- (sequence-immediate-first (sequence-immediate-second open-block)))
-
-(define (%open-block-names open-block)
- (%open-block-descriptor-names (%open-block-descriptor open-block)))
+(define (%open-block-actions open-block)
+ (make-scode-sequence
+ (list-tail (cdr (scode-sequence-actions open-block))
+ (length (%open-block-names open-block)))))
-(define (make-open-block-descriptor names declarations)
+(define-integrable (make-open-block-descriptor names declarations)
(vector open-block-tag names declarations))
(define (open-block-descriptor? object)
(and (vector? object)
- (not (zero? (vector-length object)))
- (eq? (vector-ref object 0) open-block-tag)))
+ (fix:> (vector-length object) 0)
+ (eq? open-block-tag (vector-ref object 0))))
+
+(define-integrable open-block-tag '|#[open-block]|)
-(define (%open-block-descriptor-names descriptor)
+(define-integrable (%open-block-descriptor-names descriptor)
(vector-ref descriptor 1))
-(define (%open-block-descriptor-declarations descriptor)
+(define-integrable (%open-block-descriptor-declarations descriptor)
(vector-ref descriptor 2))
\ No newline at end of file
;;; package: (runtime scode)
(declare (usual-integrations))
-
-(define (initialize-package!)
- (set! scode-constant/type-vector (make-scode-constant/type-vector))
- unspecific)
\f
;;;; Constant
-(define scode-constant/type-vector)
-
-(define (scode-constant? object)
- (if (vector-ref scode-constant/type-vector (object-type object))
- #t
+(define (scode-expression? object)
+ (or (vector-ref scode-type-vector (object-type object))
(and (compiled-code-address? object)
- (not (eq? (compiled-entry-type object) 'COMPILED-EXPRESSION)))))
+ (eq? 'compiled-expression (compiled-entry-type object)))))
-(define (make-scode-constant/type-vector)
+(define-deferred scode-type-vector
(let ((type-vector (make-vector (microcode-type/code-limit) #f)))
(for-each (lambda (name)
(vector-set! type-vector (microcode-type name) #t))
- '(BIGNUM
- CHARACTER
- COMPILED-CODE-BLOCK
- CONTROL-POINT
- DELAYED
- ENTITY
- ENVIRONMENT
- EXTENDED-PROCEDURE
- FALSE
- FLONUM
- HUNK3-A
- INTERNED-SYMBOL
- NEGATIVE-FIXNUM
- NON-MARKED-VECTOR
- PAIR
- POSITIVE-FIXNUM
- PRIMITIVE
- PROCEDURE
- QUAD
- RATNUM
- RECNUM
- REFERENCE-TRAP
- RETURN-CODE
- STRING
- TRIPLE
- TRUE
- UNINTERNED-SYMBOL
- VECTOR
- VECTOR-16B
- VECTOR-1B))
+ '(access assignment combination comment conditional constant
+ definition delay disjunction extended-lambda lambda
+ lexpr quotation sequence the-environment variable))
type-vector))
+(define (scode-constant? object)
+ (not (scode-expression? object)))
+
;;;; Quotation
-(define (make-quotation expression)
- (&typed-singleton-cons (ucode-type quotation) expression))
+(define (make-scode-quotation expression)
+ (system-pair-cons (ucode-type quotation)
+ (unmap-reference-trap expression)
+ '()))
-(define (quotation? object)
+(define (scode-quotation? object)
(object-type? (ucode-type quotation) object))
-(define-guarantee quotation "SCode quotation")
-
-(define (quotation-expression quotation)
- (guarantee-quotation quotation 'QUOTATION-EXPRESSION)
- (&singleton-element quotation))
+(define (scode-quotation-expression quotation)
+ (guarantee scode-quotation? quotation 'scode-quotation-expression)
+ (map-reference-trap (lambda () (system-pair-car quotation))))
;;;; Variable
-(define (make-variable name)
- (guarantee symbol? name 'MAKE-VARIABLE)
+(define (make-scode-variable name)
+ (guarantee symbol? name 'make-scode-variable)
(system-hunk3-cons (ucode-type variable) name #t '()))
-(define (variable? object)
+(define (scode-variable? object)
(object-type? (ucode-type variable) object))
-(define-guarantee variable "SCode variable")
-
-(define (variable-name variable)
- (guarantee-variable variable 'VARIABLE-NAME)
+(define (scode-variable-name variable)
+ (guarantee scode-variable? variable 'scode-variable-name)
(system-hunk3-cxr0 variable))
-(define (variable-components variable receiver)
- (receiver (variable-name variable)))
-\f
-;;;; Definition/Assignment
+;;;; Definition
-(define (make-definition name value)
- (guarantee symbol? name 'MAKE-DEFINITION)
- (&typed-pair-cons (ucode-type definition) name value))
+(define (make-scode-definition name value)
+ (guarantee symbol? name 'make-scode-definition)
+ (system-pair-cons (ucode-type definition)
+ (unmap-reference-trap name)
+ (unmap-reference-trap value)))
-(define (definition? object)
+(define (scode-definition? object)
(object-type? (ucode-type definition) object))
-(define-guarantee definition "SCode definition")
-
-(define (definition-name definition)
- (guarantee-definition definition 'DEFINITION-NAME)
+(define (scode-definition-name definition)
+ (guarantee scode-definition? definition 'scode-definition-name)
(system-pair-car definition))
-(define (definition-value definition)
- (guarantee-definition definition 'DEFINITION-VALUE)
- (&pair-cdr definition))
+(define (scode-definition-value definition)
+ (guarantee scode-definition? definition 'scode-definition-value)
+ (map-reference-trap (lambda () (system-pair-cdr definition))))
+\f
+;;;; Assignment
-(define (definition-components definition receiver)
- (receiver (definition-name definition)
- (definition-value definition)))
+(define (make-scode-assignment name value)
+ (guarantee symbol? name 'make-scode-assignment)
+ (system-pair-cons (ucode-type assignment)
+ (make-scode-variable name)
+ (unmap-reference-trap value)))
-(define (assignment? object)
+(define (scode-assignment? object)
(object-type? (ucode-type assignment) object))
-(define-guarantee assignment "SCode assignment")
+(define (scode-assignment-name assignment)
+ (guarantee scode-assignment? assignment 'scode-assignment-name)
+ (scode-variable-name (system-pair-car assignment)))
-(define (make-assignment-from-variable variable value)
- (guarantee-variable variable 'MAKE-ASSIGNMENT-FROM-VARIABLE)
- (&typed-pair-cons (ucode-type assignment) variable value))
+(define (scode-assignment-value assignment)
+ (guarantee scode-assignment? assignment 'scode-assignment-value)
+ (map-reference-trap (lambda () (system-pair-cdr assignment))))
-(define (assignment-variable assignment)
- (guarantee-assignment assignment 'ASSIGNMENT-VARIABLE)
- (system-pair-car assignment))
-
-(define (assignment-value assignment)
- (guarantee-assignment assignment 'ASSIGNMENT-VALUE)
- (&pair-cdr assignment))
-
-(define (assignment-components-with-variable assignment receiver)
- (receiver (assignment-variable assignment)
- (assignment-value assignment)))
-
-(define (make-assignment name value)
- (guarantee symbol? name 'MAKE-ASSIGNMENT)
- (make-assignment-from-variable (make-variable name) value))
-
-(define (assignment-name assignment)
- (variable-name (assignment-variable assignment)))
-
-(define (assignment-components assignment receiver)
- (receiver (assignment-name assignment)
- (assignment-value assignment)))
-\f
;;;; Comment
-(define (make-comment text expression)
- (&typed-pair-cons (ucode-type comment) expression text))
+(define (make-scode-comment text expression)
+ (system-pair-cons (ucode-type comment)
+ (unmap-reference-trap expression)
+ text))
-(define (comment? object)
+(define (scode-comment? object)
(object-type? (ucode-type comment) object))
-(define-guarantee comment "SCode comment")
-
-(define (comment-text comment)
- (guarantee-comment comment 'COMMENT-TEXT)
+(define (scode-comment-text comment)
+ (guarantee scode-comment? comment 'scode-comment-text)
(system-pair-cdr comment))
-(define (set-comment-text! comment text)
- (guarantee-comment comment 'SET-COMMENT-TEXT!)
- (system-pair-set-cdr! comment text))
-
-(define (comment-expression comment)
- (guarantee-comment comment 'COMMENT-EXPRESSION)
- (&pair-car comment))
+(define (scode-comment-expression comment)
+ (guarantee scode-comment? comment 'scode-comment-expression)
+ (map-reference-trap (lambda () (system-pair-car comment))))
-(define (set-comment-expression! comment expression)
- (guarantee-comment comment 'SET-COMMENT-EXPRESSION!)
- (&pair-set-car! comment expression))
-
-(define (comment-components comment receiver)
- (receiver (comment-text comment)
- (comment-expression comment)))
+(define (set-scode-comment-expression! comment expression)
+ (guarantee scode-comment? comment 'set-scode-comment-expression!)
+ (system-pair-set-car! comment (unmap-reference-trap expression)))
;;;; Declaration
-(define (make-declaration text expression)
- (make-comment (cons declaration-tag text) expression))
+(define (make-scode-declaration text expression)
+ (make-scode-comment (cons declaration-tag text) expression))
-(define (declaration? object)
- (and (comment? object)
- (let ((text (comment-text object)))
+(define (scode-declaration? object)
+ (and (scode-comment? object)
+ (let ((text (scode-comment-text object)))
(and (pair? text)
(eq? (car text) declaration-tag)))))
(define declaration-tag
((ucode-primitive string->symbol) "#[declaration]"))
-(define-guarantee declaration "SCode declaration")
-
-(define (declaration-text declaration)
- (guarantee-declaration declaration 'DECLARATION-TEXT)
- (cdr (comment-text declaration)))
+(define (scode-declaration-text declaration)
+ (guarantee scode-declaration? declaration 'scode-declaration-text)
+ (cdr (scode-comment-text declaration)))
-(define (set-declaration-text! declaration text)
- (guarantee-declaration declaration 'SET-DECLARATION-TEXT!)
- (set-cdr! (comment-text declaration) text))
-
-(define (declaration-expression declaration)
- (guarantee-declaration declaration 'DECLARATION-EXPRESSION)
- (comment-expression declaration))
-
-(define (set-declaration-expression! declaration expression)
- (guarantee-declaration declaration 'SET-DECLARATION-EXPRESSION!)
- (set-comment-expression! declaration expression))
-
-(define (declaration-components declaration receiver)
- (receiver (declaration-text declaration)
- (declaration-expression declaration)))
+(define (scode-declaration-expression declaration)
+ (guarantee scode-declaration? declaration 'scode-declaration-expression)
+ (scode-comment-expression declaration))
\f
;;;; The-Environment
-(define (make-the-environment)
+(define (make-scode-the-environment)
(object-new-type (ucode-type the-environment) 0))
-(define (the-environment? object)
+(define (scode-the-environment? object)
(object-type? (ucode-type the-environment) object))
;;;; Access
-(define (make-access environment name)
- (guarantee symbol? name 'MAKE-ACCESS)
- (&typed-pair-cons (ucode-type access) environment name))
+(define (make-scode-access environment name)
+ (guarantee symbol? name 'make-scode-access)
+ (system-pair-cons (ucode-type access)
+ (unmap-reference-trap environment)
+ name))
-(define (access? object)
+(define (scode-access? object)
(object-type? (ucode-type access) object))
-(define-guarantee access "SCode access")
-
-(define (access-environment expression)
- (guarantee-access expression 'ACCESS-ENVIRONMENT)
- (&pair-car expression))
-
-(define (access-name expression)
- (guarantee-access expression 'ACCESS-NAME)
- (system-pair-cdr expression))
+(define (scode-access-environment access)
+ (guarantee scode-access? access 'scode-access-environment)
+ (map-reference-trap (lambda () (system-pair-car access))))
-(define (access-components expression receiver)
- (receiver (access-environment expression)
- (access-name expression)))
+(define (scode-access-name access)
+ (guarantee scode-access? access 'scode-access-name)
+ (system-pair-cdr access))
;;;; Absolute Reference
-(define (make-absolute-reference name . rest)
- (let loop ((reference (make-access system-global-environment name))
- (rest rest))
- (if (pair? rest)
- (loop (make-access reference (car rest)) (cdr rest))
- reference)))
+(define (make-scode-absolute-reference name)
+ (make-scode-access system-global-environment name))
-(define (absolute-reference? object)
- (and (access? object)
- (system-global-environment? (access-environment object))))
+(define (scode-absolute-reference? object)
+ (and (scode-access? object)
+ (system-global-environment? (scode-access-environment object))))
-(define-guarantee absolute-reference "SCode absolute reference")
+(define (scode-absolute-reference-name reference)
+ (guarantee scode-absolute-reference? reference 'scode-absolute-reference-name)
+ (scode-access-name reference))
-(define (absolute-reference-name reference)
- (guarantee-absolute-reference reference 'ABSOLUTE-REFERENCE-NAME)
- (access-name reference))
-
-(define (absolute-reference-to? object name)
- (and (absolute-reference? object)
- (eq? (absolute-reference-name object) name)))
+(define (scode-absolute-reference-to? object name)
+ (and (scode-absolute-reference? object)
+ (eq? name (scode-absolute-reference-name object))))
;;;; Delay
-(define (make-delay expression)
- (&typed-singleton-cons (ucode-type delay) expression))
+(define (make-scode-delay expression)
+ (system-pair-cons (ucode-type delay)
+ (unmap-reference-trap expression)
+ '()))
-(define (delay? object)
+(define (scode-delay? object)
(object-type? (ucode-type delay) object))
-(define-guarantee delay "SCode delay")
+(define (scode-delay-expression delay)
+ (guarantee scode-delay? delay 'scode-delay-expression)
+ (map-reference-trap (lambda () (system-pair-car delay))))
+\f
+;;;; Sequence
+
+(define (make-scode-sequence actions)
+ (guarantee non-empty-list? actions 'make-sequence)
+ (let loop ((actions actions))
+ (if (pair? (cdr actions))
+ (system-pair-cons (ucode-type sequence)
+ (unmap-reference-trap (car actions))
+ (unmap-reference-trap (loop (cdr actions))))
+ (car actions))))
+
+(define (scode-sequence? object)
+ (object-type? (ucode-type sequence) object))
+
+(define (scode-sequence-actions expression)
+ (if (scode-sequence? expression)
+ (append-map scode-sequence-actions
+ (list (map-reference-trap
+ (lambda ()
+ (system-pair-car expression)))
+ (map-reference-trap
+ (lambda ()
+ (system-pair-cdr expression)))))
+ (list expression)))
+
+;;;; Combination
+
+(define (make-scode-combination operator operands)
+ (guarantee list? operands 'make-scode-combination)
+ (system-list->vector (ucode-type combination)
+ (cons (unmap-reference-trap operator)
+ (let loop ((operands operands))
+ (if (pair? operands)
+ (cons (unmap-reference-trap (car operands))
+ (loop (cdr operands)))
+ '())))))
+
+(define (scode-combination? object)
+ (object-type? (ucode-type combination) object))
+
+(define (scode-combination-operator combination)
+ (guarantee scode-combination? combination 'scode-combination-operator)
+ (map-reference-trap (lambda () (system-vector-ref combination 0))))
+
+(define (scode-combination-operands combination)
+ (guarantee scode-combination? combination 'scode-combination-operands)
+ (let loop
+ ((operands
+ (system-subvector->list combination
+ 1
+ (system-vector-length combination))))
+ (if (pair? operands)
+ (cons (map-reference-trap (lambda () (car operands)))
+ (loop (cdr operands)))
+ '())))
+
+;;;; Unassigned?
+
+(define (make-scode-unassigned? name)
+ (make-scode-combination (ucode-primitive lexical-unassigned?)
+ (list (make-scode-the-environment) name)))
+
+(define (scode-unassigned?? object)
+ (and (scode-combination? object)
+ (eq? (scode-combination-operator object)
+ (ucode-primitive lexical-unassigned?))
+ (let ((operands (scode-combination-operands object)))
+ (and (= 2 (length operands))
+ (scode-the-environment? (car operands))
+ (symbol? (cadr operands))))))
+
+(define (scode-unassigned?-name expression)
+ (guarantee scode-unassigned?? expression 'scode-unassigned?-name)
+ (cadr (scode-combination-operands expression)))
+\f
+;;;; Conditional
+
+(define (make-scode-conditional predicate consequent alternative)
+ (object-new-type (ucode-type conditional)
+ (hunk3-cons (unmap-reference-trap predicate)
+ (unmap-reference-trap consequent)
+ (unmap-reference-trap alternative))))
+
+(define (scode-conditional? object)
+ (object-type? (ucode-type conditional) object))
-(define (delay-expression expression)
- (guarantee-delay expression 'DELAY-EXPRESSION)
- (&singleton-element expression))
+(define undefined-scode-conditional-branch unspecific)
-(define (delay-components expression receiver)
- (receiver (delay-expression expression)))
\ No newline at end of file
+(define (scode-conditional-predicate conditional)
+ (guarantee scode-conditional? conditional 'scode-conditional-predicate)
+ (map-reference-trap (lambda () (system-hunk3-cxr0 conditional))))
+
+(define (scode-conditional-consequent conditional)
+ (guarantee scode-conditional? conditional 'scode-conditional-consequent)
+ (map-reference-trap (lambda () (system-hunk3-cxr1 conditional))))
+
+(define (scode-conditional-alternative conditional)
+ (guarantee scode-conditional? conditional 'scode-conditional-alternative)
+ (map-reference-trap (lambda () (system-hunk3-cxr2 conditional))))
+
+;;;; Disjunction
+
+(define (make-scode-disjunction predicate alternative)
+ (system-pair-cons (ucode-type disjunction)
+ (unmap-reference-trap predicate)
+ (unmap-reference-trap alternative)))
+
+(define (scode-disjunction? object)
+ (object-type? (ucode-type disjunction) object))
+
+(define (scode-disjunction-predicate disjunction)
+ (guarantee scode-disjunction? disjunction 'scode-disjunction-predicate)
+ (map-reference-trap (lambda () (system-pair-car disjunction))))
+
+(define (scode-disjunction-alternative disjunction)
+ (guarantee scode-disjunction? disjunction 'scode-disjunction-alternative)
+ (map-reference-trap (lambda () (system-pair-cdr disjunction))))
+\f
+;;;; Lambda
+
+(define (make-scode-lambda name required optional rest body)
+ (guarantee symbol? name 'make-scode-lambda)
+ (guarantee list-of-unique-symbols? required 'make-scode-lambda)
+ (guarantee list-of-unique-symbols? optional 'make-scode-lambda)
+ (if rest (guarantee symbol? rest 'make-scode-lambda))
+ (cond ((and (null? optional)
+ (not rest))
+ (make-slambda name required body))
+ ((and (< (length required) 256)
+ (< (length optional) 256))
+ (make-xlambda name required optional rest body))
+ (else
+ (error "Unable to encode these lambda parameters:"
+ required optional))))
+
+(define (scode-lambda? object)
+ (or (slambda? object)
+ (xlambda? object)))
+
+(define (scode-lambda-name lambda)
+ (cond ((slambda? lambda) (slambda-name lambda))
+ ((xlambda? lambda) (xlambda-name lambda))
+ (else (error:not-a scode-lambda? lambda 'scode-lambda-name))))
+
+(define (scode-lambda-required lambda)
+ (cond ((slambda? lambda) (slambda-required lambda))
+ ((xlambda? lambda) (xlambda-required lambda))
+ (else (error:not-a scode-lambda? lambda 'scode-lambda-required))))
+
+(define (scode-lambda-optional lambda)
+ (cond ((slambda? lambda) '())
+ ((xlambda? lambda) (xlambda-optional lambda))
+ (else (error:not-a scode-lambda? lambda 'scode-lambda-optional))))
+
+(define (scode-lambda-rest lambda)
+ (cond ((slambda? lambda) #f)
+ ((xlambda? lambda) (xlambda-rest lambda))
+ (else (error:not-a scode-lambda? lambda 'scode-lambda-rest))))
+
+(define (scode-lambda-body lambda)
+ (cond ((slambda? lambda) (slambda-body lambda))
+ ((xlambda? lambda) (xlambda-body lambda))
+ (else (error:not-a scode-lambda? lambda 'scode-lambda-body))))
+\f
+;;; Simple representation
+
+(define (make-slambda name required body)
+ (system-pair-cons (ucode-type lambda)
+ (unmap-reference-trap body)
+ (list->vector (cons name required))))
+
+(define (slambda? object)
+ (object-type? (ucode-type lambda) object))
+
+(define (slambda-name slambda)
+ (vector-ref (system-pair-cdr slambda) 0))
+
+(define (slambda-required slambda)
+ (let ((v (system-pair-cdr slambda)))
+ (subvector->list v 1 (vector-length v))))
+
+(define (slambda-body slambda)
+ (map-reference-trap (lambda () (system-pair-car slambda))))
+
+;;; Extended representation
+
+(define (make-xlambda name required optional rest body)
+ (let ((v
+ (list->vector
+ (cons name
+ (append required optional (if rest (list rest) '())))))
+ (arity
+ (let ((n-required (length required))
+ (n-optional (length optional)))
+ (fix:or (fix:or n-optional
+ (fix:lsh n-required 8))
+ (fix:lsh (if rest 1 0) 16)))))
+ (object-new-type (ucode-type extended-lambda)
+ (hunk3-cons (unmap-reference-trap body)
+ v
+ arity))))
+
+(define (xlambda? object)
+ (object-type? (ucode-type extended-lambda) object))
+
+(define (xlambda-name xlambda)
+ (vector-ref (system-hunk3-cxr1 xlambda) 0))
+
+(define (xlambda-required xlambda)
+ (receive (optional-start optional-end rest?) (decode-xlambda-arity xlambda)
+ (declare (ignore optional-end rest?))
+ (subvector->list (system-hunk3-cxr1 xlambda) 1 optional-start)))
+
+(define (xlambda-optional xlambda)
+ (receive (optional-start optional-end rest?) (decode-xlambda-arity xlambda)
+ (declare (ignore rest?))
+ (subvector->list (system-hunk3-cxr1 xlambda) optional-start optional-end)))
+
+(define (xlambda-rest xlambda)
+ (receive (optional-start optional-end rest?) (decode-xlambda-arity xlambda)
+ (declare (ignore optional-start))
+ (and rest?
+ (vector-ref (system-hunk3-cxr1 xlambda) optional-end))))
+
+(define (decode-xlambda-arity xlambda)
+ (let ((arity (object-datum (system-hunk3-cxr2 xlambda))))
+ (let ((optional-start (fix:+ 1 (fix:and (fix:lsh arity -8) #xff))))
+ (values optional-start
+ (fix:+ optional-start (fix:and arity #xff))
+ (fix:= 1 (fix:lsh arity -16))))))
+
+(define (xlambda-body xlambda)
+ (map-reference-trap (lambda () (system-hunk3-cxr0 xlambda))))
\ 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, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; SCode Combinator Abstractions
-;;; package: (runtime scode-combinator)
-
-(declare (usual-integrations))
-
-\f
-;;;; Sequence
-
-(define-integrable (%make-sequence first second)
- (&typed-pair-cons (ucode-type sequence) first second))
-
-(define-integrable (sequence? object)
- (object-type? (ucode-type sequence) object))
-
-(define-integrable (%sequence-immediate-first sequence) (&pair-car sequence))
-(define-integrable (%sequence-immediate-second sequence) (&pair-cdr sequence))
-
-(define-guarantee sequence "SCode sequence")
-
-(define (make-sequence actions)
- (if (null? actions)
- (error "MAKE-SEQUENCE: No actions"))
- (let loop ((actions actions))
- (if (null? (cdr actions))
- (car actions)
- (%make-sequence (car actions) (loop (cdr actions))))))
-
-(define (sequence-first expression)
- (guarantee-sequence expression 'SEQUENCE-FIRST)
- (%sequence-immediate-first expression))
-
-(define (sequence-second expression)
- (guarantee-sequence expression 'SEQUENCE-SECOND)
- (%sequence-immediate-second expression))
-
-(define (sequence-immediate-first expression)
- (guarantee-sequence expression 'SEQUENCE-IMMEDIATE-FIRST)
- (%sequence-immediate-first expression))
-
-(define (sequence-immediate-second expression)
- (guarantee-sequence expression 'SEQUENCE-IMMEDIATE-SECOND)
- (%sequence-immediate-second expression))
-
-(define (sequence-immediate-actions expression)
- (guarantee-sequence expression 'SEQUENCE-IMMEDIATE-ACTIONS)
- (list (%sequence-immediate-first expression)
- (%sequence-immediate-second expression)))
-
-(define (sequence-actions expression)
- (if (sequence? expression)
- (append! (sequence-actions (%sequence-immediate-first expression))
- (sequence-actions (%sequence-immediate-second expression)))
- (list expression)))
-
-(define (sequence-components expression receiver)
- (receiver (sequence-actions expression)))
-
-(define (copy-sequence expression)
- (guarantee-sequence expression 'COPY-SEQUENCE)
- (%make-sequence (%sequence-immediate-first expression)
- (%sequence-immediate-second expression)))
-
-\f
-;;;; Conditional
-
-(define (make-conditional predicate consequent alternative)
- (&typed-triple-cons (ucode-type conditional)
- predicate
- consequent
- alternative))
-
-(define (conditional? object)
- (object-type? (ucode-type conditional) object))
-
-(define-guarantee conditional "SCode conditional")
-
-(define undefined-conditional-branch unspecific)
-
-(define (conditional-predicate conditional)
- (guarantee-conditional conditional 'CONDITIONAL-PREDICATE)
- (&triple-first conditional))
-
-(define (conditional-consequent conditional)
- (guarantee-conditional conditional 'CONDITIONAL-CONSEQUENT)
- (&triple-second conditional))
-
-(define (conditional-alternative conditional)
- (guarantee-conditional conditional 'CONDITIONAL-ALTERNATIVE)
- (&triple-third conditional))
-
-(define (conditional-components conditional receiver)
- (receiver (conditional-predicate conditional)
- (conditional-consequent conditional)
- (conditional-alternative conditional)))
-
-(define (conditional-subexpressions expression)
- (conditional-components expression list))
-
-;;;; Disjunction
-
-(define (make-disjunction predicate alternative)
- (&typed-pair-cons (ucode-type disjunction) predicate alternative))
-
-(define (disjunction? object)
- (object-type? (ucode-type disjunction) object))
-
-(define-guarantee disjunction "SCode disjunction")
-
-(define (disjunction-predicate disjunction)
- (guarantee-disjunction disjunction 'DISJUNCTION-PREDICATE)
- (&pair-car disjunction))
-
-(define (disjunction-alternative disjunction)
- (guarantee-disjunction disjunction 'DISJUNCTION-ALTERNATIVE)
- (&pair-cdr disjunction))
-
-(define (disjunction-components disjunction receiver)
- (receiver (disjunction-predicate disjunction)
- (disjunction-alternative disjunction)))
-
-(define (disjunction-subexpressions expression)
- (disjunction-components expression list))
-\f
-;;;; Combination
-
-(define (combination? object)
- (object-type? (ucode-type combination) object))
-
-(define-guarantee combination "SCode combination")
-
-(define (make-combination operator operands)
- (&typed-vector-cons (ucode-type combination)
- (cons operator operands)))
-
-(define (combination-size combination)
- (guarantee-combination combination 'COMBINATION-SIZE)
- (&vector-length combination))
-
-(define (combination-operator combination)
- (guarantee-combination combination 'COMBINATION-OPERATOR)
- (&vector-ref combination 0))
-
-(define (combination-operands combination)
- (guarantee-combination combination 'COMBINATION-OPERANDS)
- (&subvector->list combination 1 (&vector-length combination)))
-
-(define (combination-components combination receiver)
- (guarantee-combination combination 'COMBINATION-OPERANDS)
- (receiver (&vector-ref combination 0)
- (&subvector->list combination 1 (&vector-length combination))))
-
-(define (combination-subexpressions expression)
- (combination-components expression cons))
-
-;;;; Unassigned?
-
-(define (make-unassigned? name)
- (make-combination (ucode-primitive lexical-unassigned?)
- (list (make-the-environment) name)))
-
-(define (unassigned?? object)
- (and (combination? object)
- (eq? (combination-operator object)
- (ucode-primitive lexical-unassigned?))
- (let ((operands (combination-operands object)))
- (and (the-environment? (car operands))
- (symbol? (cadr operands))))))
-
-(define-guarantee unassigned? "SCode unassigned test")
-
-(define (unassigned?-name expression)
- (guarantee-unassigned? expression 'UNASSIGNED?-NAME)
- (cadr (combination-operands expression)))
-
-(define (unassigned?-components expression receiver)
- (receiver (unassigned?-name expression)))
\ No newline at end of file
scode-predicates))
(define scode-predicates
- (list access? assignment? combination? comment?
- conditional? definition? delay? disjunction? lambda?
- quotation? sequence? the-environment? variable?))
+ (list scode-access? scode-assignment? scode-combination? scode-comment?
+ scode-conditional? scode-definition? scode-delay? scode-disjunction?
+ scode-lambda? scode-quotation? scode-sequence? scode-the-environment?
+ scode-variable?))
(define (inspect-system-pair o)
(stream (iline "car" (system-pair-car o))
(eval output (syntactic-environment->environment environment)))
(define (output/variable name)
- (make-variable name))
+ (make-scode-variable name))
(define (output/constant datum)
datum)
(define (output/assignment name value)
- (make-assignment name value))
+ (make-scode-assignment name value))
(define (output/top-level-definition name value)
- (make-definition name
- (if (lambda? value)
- (lambda-components* value
- (lambda (name* required optional rest body)
- (if (eq? name* lambda-tag:unnamed)
- (make-lambda* name required optional rest body)
- value)))
- value)))
+ (make-scode-definition name
+ (if (scode-lambda? value)
+ (lambda-components* value
+ (lambda (name* required optional rest body)
+ (if (eq? name* lambda-tag:unnamed)
+ (make-lambda* name required optional rest body)
+ value)))
+ value)))
(define (output/top-level-syntax-definition name value)
- (make-definition name (make-macro-reference-trap-expression value)))
+ (make-scode-definition name (make-macro-reference-trap-expression value)))
(define (output/conditional predicate consequent alternative)
- (make-conditional predicate consequent alternative))
+ (make-scode-conditional predicate consequent alternative))
(define (output/disjunction predicate alternative)
- (make-disjunction predicate alternative))
+ (make-scode-disjunction predicate alternative))
(define (output/sequence expressions)
- (make-sequence expressions))
+ (make-scode-sequence expressions))
(define (output/combination operator operands)
- (make-combination operator operands))
+ (make-scode-combination operator operands))
(define (output/lambda lambda-list body)
(output/named-lambda lambda-tag:unnamed lambda-list body))
(make-lambda* name required optional rest body))))
(define (output/delay expression)
- (make-delay expression))
+ (make-scode-delay expression))
(define (output/unassigned-test name)
- (make-unassigned? name))
+ (make-scode-unassigned? name))
(define (output/unassigned)
(make-unassigned-reference-trap))
"-value"))) names)))
(output/let
names (map (lambda (name) name (output/unassigned)) names)
- (make-sequence
+ (make-scode-sequence
(cons (output/let
temps values
- (make-sequence (map (lambda (name temp)
- (make-assignment name (make-variable temp)))
- names temps)))
+ (make-scode-sequence
+ (map (lambda (name temp)
+ (make-scode-assignment name (make-scode-variable temp)))
+ names
+ temps)))
(list
(let ((body (scan-defines body make-open-block)))
(if (open-block? body)
(define (output/body declarations body)
(scan-defines (let ((declarations (apply append declarations)))
(if (pair? declarations)
- (make-sequence
+ (make-scode-sequence
(list (make-block-declaration declarations)
body))
body))
make-open-block))
(define (output/definition name value)
- (make-definition name value))
+ (make-scode-definition name value))
(define (output/top-level-sequence declarations expressions)
(let ((declarations (apply append declarations))
(make-open-block
(lambda (expressions)
- (scan-defines (make-sequence expressions) make-open-block))))
+ (scan-defines (make-scode-sequence expressions) make-open-block))))
(if (pair? declarations)
(make-open-block
(cons (make-block-declaration declarations)
(output/unspecific)))))
(define (output/the-environment)
- (make-the-environment))
+ (make-scode-the-environment))
(define (output/access-reference name environment)
- (make-access environment name))
+ (make-scode-access environment name))
(define (output/access-assignment name environment value)
- (make-combination (ucode-primitive lexical-assignment)
+ (make-scode-combination (ucode-primitive lexical-assignment)
(list environment name value)))
(define (output/runtime-reference name)
(define (compute-substitution/variable expression unmapping)
unmapping
- (singleton-reference-set (variable-name expression)))
+ (singleton-reference-set (scode-variable-name expression)))
(define (compute-substitution/assignment expression unmapping)
- (add-to-reference-set (assignment-name expression)
- (compute-substitution (assignment-value expression)
- unmapping)))
+ (add-to-reference-set
+ (scode-assignment-name expression)
+ (compute-substitution (scode-assignment-value expression)
+ unmapping)))
(define (compute-substitution/unassigned? expression unmapping)
unmapping
- (singleton-reference-set (unassigned?-name expression)))
+ (singleton-reference-set (scode-unassigned?-name expression)))
(define (compute-substitution/lambda expression unmapping)
(lambda-components** expression
(null-reference-set)))))
(define compute-substitution/access
- (compute-substitution/subexpression access-environment))
+ (compute-substitution/subexpression scode-access-environment))
(define compute-substitution/combination
- (compute-substitution/subexpressions combination-subexpressions))
+ (compute-substitution/subexpressions
+ (lambda (expr)
+ (cons (scode-combination-operator expr)
+ (scode-combination-operands expr)))))
(define compute-substitution/comment
- (compute-substitution/subexpression comment-expression))
+ (compute-substitution/subexpression scode-comment-expression))
(define compute-substitution/conditional
- (compute-substitution/subexpressions conditional-subexpressions))
+ (compute-substitution/subexpressions
+ (lambda (expr)
+ (list (scode-conditional-predicate expr)
+ (scode-conditional-consequent expr)
+ (scode-conditional-alternative expr)))))
(define compute-substitution/definition
- (compute-substitution/subexpression definition-value))
+ (compute-substitution/subexpression scode-definition-value))
(define compute-substitution/delay
- (compute-substitution/subexpression delay-expression))
+ (compute-substitution/subexpression scode-delay-expression))
(define compute-substitution/disjunction
- (compute-substitution/subexpressions disjunction-subexpressions))
+ (compute-substitution/subexpressions
+ (lambda (expr)
+ (list (scode-disjunction-predicate expr)
+ (scode-disjunction-alternative expr)))))
(define compute-substitution/sequence
- (compute-substitution/subexpressions sequence-actions))
+ (compute-substitution/subexpressions scode-sequence-actions))
(define (compute-substitution/default expression unmapping)
expression unmapping
((scode-walk alpha-substitute-walker expression) substitution expression))
(define (alpha-substitute/variable substitution expression)
- (make-variable (substitution (variable-name expression))))
+ (make-scode-variable (substitution (scode-variable-name expression))))
(define (alpha-substitute/assignment substitution expression)
- (make-assignment (substitution (assignment-name expression))
- (alpha-substitute substitution
- (assignment-value expression))))
+ (make-scode-assignment
+ (substitution (scode-assignment-name expression))
+ (alpha-substitute substitution (scode-assignment-value expression))))
(define (alpha-substitute/unassigned? substitution expression)
- (make-unassigned? (substitution (unassigned?-name expression))))
+ (make-scode-unassigned? (substitution (scode-unassigned?-name expression))))
(define (alpha-substitute/lambda substitution expression)
(lambda-components** expression
(alpha-substitute substitution body)))))
(define (alpha-substitute/declaration substitution expression)
- (make-declaration (substitute-in-declarations substitution
- (declaration-text expression))
- (alpha-substitute substitution
- (declaration-expression expression))))
+ (make-scode-declaration
+ (substitute-in-declarations substitution (scode-declaration-text expression))
+ (alpha-substitute substitution (scode-declaration-expression expression))))
(define (substitute-in-declarations substitution declarations)
(map (lambda (declaration)
substitution
expression)
-(define (simple-substitution reconstruct get-subexpression)
+(define (simple-substitution reconstruct . parts)
(lambda (substitution expression)
- (reconstruct expression
- (alpha-substitute substitution
- (get-subexpression expression)))))
+ (apply reconstruct
+ (map (lambda (part)
+ (alpha-substitute substitution (part expression)))
+ parts))))
+
+(define (partial-substitution selector reconstruct . parts)
+ (lambda (substitution expression)
+ (apply reconstruct
+ (map (lambda (substitute? part)
+ (if substitute?
+ (alpha-substitute substitution (part expression))
+ (part expression)))
+ selector
+ parts))))
(define (combinator-substitution reconstruct get-subexpressions)
(lambda (substitution expression)
(get-subexpressions expression)))))
\f
(define alpha-substitute/access
- (simple-substitution (lambda (expression environment)
- (make-access environment (access-name expression)))
- access-environment))
+ (partial-substitution '(#t #f)
+ make-scode-access
+ scode-access-environment
+ scode-access-name))
(define alpha-substitute/combination
(combinator-substitution (lambda (subexpressions)
- (make-combination (car subexpressions)
- (cdr subexpressions)))
- combination-subexpressions))
+ (make-scode-combination (car subexpressions)
+ (cdr subexpressions)))
+ (lambda (expression)
+ (cons (scode-combination-operator expression)
+ (scode-combination-operands expression)))))
(define alpha-substitute/comment
- (simple-substitution (lambda (expression subexpression)
- (make-comment (comment-text expression)
- subexpression))
- comment-expression))
+ (partial-substitution '(#f #t)
+ make-scode-comment
+ scode-comment-text
+ scode-comment-expression))
(define alpha-substitute/conditional
- (combinator-substitution (lambda (subexpressions)
- (make-conditional (car subexpressions)
- (cadr subexpressions)
- (caddr subexpressions)))
- conditional-subexpressions))
+ (simple-substitution make-scode-conditional
+ scode-conditional-predicate
+ scode-conditional-consequent
+ scode-conditional-alternative))
(define alpha-substitute/definition
- (simple-substitution (lambda (expression value)
- (make-definition (definition-name expression) value))
- definition-value))
+ (partial-substitution '(#f #t)
+ make-scode-definition
+ scode-definition-name
+ scode-definition-value))
(define alpha-substitute/delay
- (simple-substitution (lambda (expression subexpression)
- expression
- (make-delay subexpression))
- delay-expression))
+ (simple-substitution make-scode-delay
+ scode-delay-expression))
(define alpha-substitute/disjunction
- (combinator-substitution (lambda (subexpressions)
- (make-disjunction (car subexpressions)
- (cadr subexpressions)))
- disjunction-subexpressions))
+ (simple-substitution make-scode-disjunction
+ scode-disjunction-predicate
+ scode-disjunction-alternative))
(define alpha-substitute/sequence
- (combinator-substitution make-sequence sequence-actions))
+ (combinator-substitution make-scode-sequence scode-sequence-actions))
(define alpha-substitute-walker
(make-scode-walker alpha-substitute/default
(unparse-symbol-name (symbol->string symbol) context)
(*unparse-with-brackets 'UNINTERNED-SYMBOL symbol context
(lambda (context*)
- (*unparse-string (symbol->string symbol) context)))))
+ (*unparse-string (symbol->string symbol) context*)))))
(define (unparse-symbol symbol context)
(if (keyword? symbol)
(define (unparse/assignment assignment context)
(*unparse-with-brackets 'ASSIGNMENT assignment context
(lambda (context*)
- (*unparse-object (assignment-name assignment) context*))))
+ (*unparse-object (scode-assignment-name assignment) context*))))
(define (unparse/definition definition context)
(*unparse-with-brackets 'DEFINITION definition context
(lambda (context*)
- (*unparse-object (definition-name definition) context*))))
+ (*unparse-object (scode-definition-name definition) context*))))
(define (unparse/lambda lambda-object context)
(*unparse-with-brackets 'LAMBDA lambda-object context
(lambda (context*)
- (*unparse-object (lambda-name lambda-object) context*))))
+ (*unparse-object (scode-lambda-name lambda-object) context*))))
(define (unparse/variable variable context)
(*unparse-with-brackets 'VARIABLE variable context
(lambda (context*)
- (*unparse-object (variable-name variable) context*))))
+ (*unparse-object (scode-variable-name variable) context*))))
(define (unparse/number object context)
(*unparse-string (number->string
(define unsyntaxer:macroize? #t)
(define unsyntaxer:elide-global-accesses? #t)
-(define unsyntaxer:fold-sequence-tail? #t)
(define unsyntaxer:show-comments? #f)
;;; The substitutions mechanism is for putting the '### marker in
(define (is-bound? name environment)
(any (lambda (binding-lambda)
- (lambda-bound? binding-lambda name))
+ (scode-lambda-bound? binding-lambda name))
environment))
(define (unsyntax scode)
(define (unsyntax-QUOTATION environment quotation)
`(SCODE-QUOTE
- ,(unsyntax-object environment (quotation-expression quotation))))
+ ,(unsyntax-object environment (scode-quotation-expression quotation))))
-(define (unsyntax-VARIABLE-object environment object)
+(define (unsyntax-variable-object environment object)
(declare (ignore environment))
- (variable-name object))
+ (scode-variable-name object))
(define (unsyntax-ACCESS-object environment object)
(or (and unsyntaxer:elide-global-accesses?
unsyntaxer:macroize?
- (access-components object
- (lambda (access-environment name)
- (and (or (eq? access-environment system-global-environment)
- (and (variable? access-environment)
- (eq? (variable-name access-environment)
- 'system-global-environment)))
- (not (is-bound? name environment))
- name))))
+ (let ((access-environment (scode-access-environment object))
+ (name (scode-access-name object)))
+ (and (or (eq? access-environment system-global-environment)
+ (and (scode-variable? access-environment)
+ (eq? (scode-variable-name access-environment)
+ 'system-global-environment)))
+ (not (is-bound? name environment))
+ name)))
`(ACCESS ,@(unexpand-access environment object))))
(define (unexpand-access environment object)
(let loop ((object object) (separate? #t))
(if (and separate?
- (access? object)
+ (scode-access? object)
(not (has-substitution? object)))
- (access-components object
- (lambda (environment name)
- `(,name ,@(loop environment (eq? #t unsyntaxer:macroize?)))))
+ `(,(scode-access-name object)
+ ,@(loop (scode-access-environment object)
+ (eq? #t unsyntaxer:macroize?)))
`(,(unsyntax-object environment object)))))
-(define (unsyntax-DEFINITION-object environment definition)
- (definition-components definition
- (lambda (name value) (unexpand-definition environment name value))))
+(define (unsyntax-definition-object environment definition)
+ (unexpand-definition environment
+ (scode-definition-name definition)
+ (scode-definition-value definition)))
-(define (unsyntax-ASSIGNMENT-object environment assignment)
- (assignment-components assignment
- (lambda (name value)
- `(SET! ,name ,@(unexpand-binding-value environment value)))))
+(define (unsyntax-assignment-object environment assignment)
+ `(SET! ,(scode-assignment-name assignment)
+ ,@(unexpand-binding-value environment
+ (scode-assignment-value assignment))))
(define (unexpand-definition environment name value)
(cond ((macro-reference-trap-expression? value)
environment
(macro-reference-trap-expression-transformer value)))))
((and (eq? #t unsyntaxer:macroize?)
- (lambda? value)
+ (scode-lambda? value)
(not (has-substitution? value)))
(lambda-components* value
(lambda (lambda-name required optional rest body)
\f
(define (unsyntax-COMMENT-object environment comment)
(let ((expression
- (unsyntax-object environment (comment-expression comment))))
+ (unsyntax-object environment (scode-comment-expression comment))))
(if unsyntaxer:show-comments?
- `(COMMENT ,(comment-text comment) ,expression)
+ `(COMMENT ,(scode-comment-text comment) ,expression)
expression)))
(define (unsyntax-DECLARATION-object environment declaration)
- (declaration-components declaration
- (lambda (text expression)
- `(LOCAL-DECLARE ,text ,(unsyntax-object environment expression)))))
-
-(define (unsyntax-SEQUENCE-object environment seq)
- (let ((first-action (sequence-immediate-first seq)))
- (if (block-declaration? first-action)
+ `(LOCAL-DECLARE
+ ,(scode-declaration-text declaration)
+ ,(unsyntax-object environment (scode-declaration-expression declaration))))
+
+(define (unsyntax-sequence-object environment seq)
+ (let loop ((actions (scode-sequence-actions seq)))
+ (if (and (block-declaration? (car actions))
+ (pair? (cdr actions)))
`(BEGIN
- (DECLARE ,@(block-declaration-text first-action))
- ,@(unsyntax-sequence environment (sequence-immediate-second seq)))
+ (DECLARE ,@(block-declaration-text (car actions)))
+ ,@(loop (cdr actions)))
`(BEGIN
,@(unsyntax-sequence-actions environment seq)))))
(define (unsyntax-sequence environment seq)
- (if (sequence? seq)
+ (if (scode-sequence? seq)
(if (eq? #t unsyntaxer:macroize?)
(unsyntax-sequence-actions environment seq)
`((BEGIN ,@(unsyntax-sequence-actions environment seq))))
(list (unsyntax-object environment seq))))
(define (unsyntax-sequence-actions environment seq)
- (let ((tail (if (and unsyntaxer:fold-sequence-tail?
- (sequence? (sequence-immediate-second seq)))
- (unsyntax-sequence-actions environment (sequence-immediate-second seq))
- (list (unsyntax-object environment (sequence-immediate-second seq))))))
- (let ((substitution (has-substitution? (sequence-immediate-first seq))))
- (cond (substitution
- (cons (cdr substitution) tail))
- ((and (eq? #t unsyntaxer:macroize?)
- (sequence? (sequence-immediate-first seq)))
- (append (unsyntax-sequence-actions environment
- (sequence-immediate-first seq))
- tail))
- (else
- (cons (unsyntax-object environment
- (sequence-immediate-first seq)) tail))))))
+ (let loop ((actions (scode-sequence-actions seq)))
+ (if (pair? actions)
+ (cons (let ((substitution (has-substitution? (car actions))))
+ (if substitution
+ (cdr substitution)
+ (unsyntax-object environment (car actions))))
+ (loop (cdr actions)))
+ '())))
(define (unsyntax-OPEN-BLOCK-object environment open-block)
(if (eq? #t unsyntaxer:macroize?)
(unsyntax-SEQUENCE-object environment open-block)))
(define (unsyntax-DELAY-object environment object)
- `(DELAY ,(unsyntax-object environment (delay-expression object))))
+ `(DELAY ,(unsyntax-object environment (scode-delay-expression object))))
(define (unsyntax-THE-ENVIRONMENT-object environment object)
(declare (ignore environment object))
`(THE-ENVIRONMENT))
\f
-(define (unsyntax-DISJUNCTION-object environment object)
- `(OR ,@(disjunction-components object
+(define (unsyntax-disjunction-object environment object)
+ `(or ,@(let ((predicate (scode-disjunction-predicate object))
+ (alternative (scode-disjunction-alternative object)))
(if (eq? #t unsyntaxer:macroize?)
- (lambda (predicate alternative)
- (unexpand-disjunction environment predicate alternative))
- (lambda (predicate alternative)
- (list (unsyntax-object environment predicate)
- (unsyntax-object environment alternative)))))))
+ (unexpand-disjunction environment predicate alternative)
+ (list (unsyntax-object environment predicate)
+ (unsyntax-object environment alternative))))))
(define (unexpand-disjunction environment predicate alternative)
`(,(unsyntax-object environment predicate)
- ,@(if (disjunction? alternative)
- (disjunction-components alternative
- (lambda (predicate alternative)
- (unexpand-disjunction environment predicate alternative)))
+ ,@(if (scode-disjunction? alternative)
+ (unexpand-disjunction environment
+ (scode-disjunction-predicate alternative)
+ (scode-disjunction-alternative alternative))
`(,(unsyntax-object environment alternative)))))
-(define (unsyntax-CONDITIONAL-object environment conditional)
- (conditional-components conditional
+(define (unsyntax-conditional-object environment conditional)
+ (let ((predicate (scode-conditional-predicate conditional))
+ (consequent (scode-conditional-consequent conditional))
+ (alternative (scode-conditional-alternative conditional)))
(if (eq? #t unsyntaxer:macroize?)
- (lambda (predicate consequent alternative)
- (unsyntax-conditional environment predicate consequent alternative))
- (lambda (predicate consequent alternative)
- (unsyntax-conditional/default
- environment predicate consequent alternative)))))
+ (unsyntax-conditional environment predicate consequent alternative)
+ (unsyntax-conditional/default
+ environment predicate consequent alternative))))
(define (unsyntax-conditional/default environment
predicate consequent alternative)
(define (unsyntax-conditional environment predicate consequent alternative)
(cond ((not alternative)
`(AND ,@(unexpand-conjunction environment predicate consequent)))
- ((eq? alternative undefined-conditional-branch)
+ ((eq? alternative undefined-scode-conditional-branch)
`(IF ,(unsyntax-object environment predicate)
,(unsyntax-object environment consequent)))
- ((eq? consequent undefined-conditional-branch)
+ ((eq? consequent undefined-scode-conditional-branch)
`(IF (,(ucode-primitive not) ,(unsyntax-object environment predicate))
,(unsyntax-object environment alternative)))
- ((and (conditional? alternative)
+ ((and (scode-conditional? alternative)
(not (has-substitution? alternative)))
`(COND ,@(unsyntax-cond-conditional environment predicate
consequent
,@(unsyntax-cond-alternative environment alternative)))
(define (unsyntax-cond-alternative environment alternative)
- (cond ((eq? alternative undefined-conditional-branch)
+ (cond ((eq? alternative undefined-scode-conditional-branch)
'())
((has-substitution? alternative)
=>
(lambda (substitution)
`((ELSE ,substitution))))
- ((disjunction? alternative)
- (disjunction-components alternative
- (lambda (predicate alternative)
- (unsyntax-cond-disjunction environment predicate alternative))))
- ((conditional? alternative)
- (conditional-components alternative
- (lambda (predicate consequent alternative)
- (unsyntax-cond-conditional environment
- predicate consequent alternative))))
+ ((scode-disjunction? alternative)
+ (unsyntax-cond-disjunction
+ environment
+ (scode-disjunction-predicate alternative)
+ (scode-disjunction-alternative alternative)))
+ ((scode-conditional? alternative)
+ (unsyntax-cond-conditional
+ environment
+ (scode-conditional-predicate alternative)
+ (scode-conditional-consequent alternative)
+ (scode-conditional-alternative alternative)))
(else
`((ELSE ,@(unsyntax-sequence environment alternative))))))
(define (unexpand-conjunction environment predicate consequent)
- (if (and (conditional? consequent)
+ (if (and (scode-conditional? consequent)
(not (has-substitution? consequent)))
`(,(unsyntax-object environment predicate)
- ,@(conditional-components consequent
- (lambda (predicate consequent alternative)
- (if (not alternative)
- (unexpand-conjunction environment predicate consequent)
- `(,(unsyntax-conditional environment predicate
- consequent
- alternative))))))
+ ,@(let ((predicate (scode-conditional-predicate consequent))
+ (consequent (scode-conditional-consequent consequent))
+ (alternative (scode-conditional-alternative consequent)))
+ (if (not alternative)
+ (unexpand-conjunction environment predicate consequent)
+ `(,(unsyntax-conditional environment predicate
+ consequent
+ alternative)))))
`(,(unsyntax-object environment predicate)
,(unsyntax-object environment consequent))))
\f
(define (unsyntax-EXTENDED-LAMBDA-object environment expression)
(if unsyntaxer:macroize?
(unsyntax-lambda environment expression)
- `(&XLAMBDA (,(lambda-name expression) ,@(lambda-interface expression))
+ `(&XLAMBDA (,(scode-lambda-name expression) ,@(scode-lambda-interface expression))
,(unsyntax-object environment (lambda-immediate-body expression)))))
(define (unsyntax-LAMBDA-object environment expression)
(if unsyntaxer:macroize?
(unsyntax-lambda environment expression)
- (collect-lambda (lambda-name expression)
- (lambda-interface expression)
+ (collect-lambda (scode-lambda-name expression)
+ (scode-lambda-interface expression)
(list (unsyntax-object environment
(lambda-immediate-body expression))))))
`(NAMED-LAMBDA (,name . ,bvl) ,@body)))
(define (unsyntax-lambda-list expression)
- (if (not (lambda? expression))
+ (if (not (scode-lambda? expression))
(error:wrong-type-argument expression "SCode lambda"
'UNSYNTAX-LAMBDA-LIST))
(lambda-components* expression
(unsyntax-lambda-body-sequence environment body)))
(define (unsyntax-lambda-body-sequence environment body)
- (if (sequence? body)
- (let ((first-action (sequence-immediate-first body)))
- (if (block-declaration? first-action)
- `((DECLARE ,@(block-declaration-text first-action))
- ,@(unsyntax-sequence environment (sequence-immediate-second body)))
+ (if (scode-sequence? body)
+ (let ((actions (scode-sequence-actions body)))
+ (if (and (block-declaration? (car actions))
+ (pair? (cdr actions)))
+ `((DECLARE ,@(block-declaration-text (car actions)))
+ ,@(unsyntax-sequence environment
+ (make-scode-sequence (cdr actions))))
(unsyntax-sequence environment body)))
(list (unsyntax-object environment body))))
\f
;;;; Combinations
-(define (unsyntax-COMBINATION-object environment combination)
+(define (unsyntax-combination-object environment combination)
(rewrite-named-let
- (combination-components combination
- (lambda (operator operands)
- (let ((ordinary-combination
- (lambda ()
- `(,(unsyntax-object environment operator)
- ,@(map (lambda (operand)
- (unsyntax-object environment operand))
- operands)))))
- (cond ((or (not (eq? #t unsyntaxer:macroize?))
- (has-substitution? operator))
- (ordinary-combination))
- ((and (or (eq? operator (ucode-primitive cons))
- (absolute-reference-to? operator 'CONS))
- (= (length operands) 2)
- (delay? (cadr operands))
- (not (has-substitution? (cadr operands))))
- `(CONS-STREAM ,(unsyntax-object environment (car operands))
- ,(unsyntax-object environment
- (delay-expression (cadr operands)))))
- ((lambda? operator)
- (lambda-components* operator
- (lambda (name required optional rest body)
- (if (and (null? optional)
- (not rest)
- (= (length required) (length operands)))
- (if (or (eq? name lambda-tag:unnamed)
- (eq? name lambda-tag:let))
- `(LET ,(unsyntax-let-bindings environment required operands)
- ,@(with-bindings environment operator
- (lambda (environment*)
- (unsyntax-lambda-body environment* body))))
- (ordinary-combination))
- (ordinary-combination)))))
- (else
- (ordinary-combination))))))))
+ (let ((operator (scode-combination-operator combination))
+ (operands (scode-combination-operands combination)))
+ (let ((ordinary-combination
+ (lambda ()
+ `(,(unsyntax-object environment operator)
+ ,@(map (lambda (operand)
+ (unsyntax-object environment operand))
+ operands)))))
+ (cond ((or (not (eq? #t unsyntaxer:macroize?))
+ (has-substitution? operator))
+ (ordinary-combination))
+ ((and (or (eq? operator (ucode-primitive cons))
+ (scode-absolute-reference-to? operator 'cons))
+ (= (length operands) 2)
+ (scode-delay? (cadr operands))
+ (not (has-substitution? (cadr operands))))
+ `(CONS-STREAM ,(unsyntax-object environment (car operands))
+ ,(unsyntax-object environment
+ (scode-delay-expression (cadr operands)))))
+ ((scode-lambda? operator)
+ (lambda-components* operator
+ (lambda (name required optional rest body)
+ (if (and (null? optional)
+ (not rest)
+ (= (length required) (length operands)))
+ (if (or (eq? name lambda-tag:unnamed)
+ (eq? name lambda-tag:let))
+ `(LET ,(unsyntax-let-bindings environment required operands)
+ ,@(with-bindings environment operator
+ (lambda (environment*)
+ (unsyntax-lambda-body environment* body))))
+ (ordinary-combination))
+ (ordinary-combination)))))
+ (else
+ (ordinary-combination)))))))
(define (unsyntax-let-bindings environment names values)
(map (lambda (name value)
(fix:= 15 (primitive-object-ref (getter) 0))))))
(define (make-macro-reference-trap-expression transformer)
- (make-combination (ucode-primitive primitive-object-set-type)
- (list (ucode-type reference-trap)
- (make-combination (ucode-primitive cons)
- (list 15 transformer)))))
+ (make-scode-combination
+ (ucode-primitive primitive-object-set-type)
+ (list (ucode-type reference-trap)
+ (make-scode-combination (ucode-primitive cons)
+ (list 15 transformer)))))
(define (macro-reference-trap-expression? expression)
- (and (combination? expression)
- (eq? (combination-operator expression)
+ (and (scode-combination? expression)
+ (eq? (scode-combination-operator expression)
(ucode-primitive primitive-object-set-type))
- (let ((operands (combination-operands expression)))
+ (let ((operands (scode-combination-operands expression)))
(and (pair? operands)
(eqv? (car operands) (ucode-type reference-trap))
(pair? (cdr operands))
(let ((expression (cadr operands)))
- (and (combination? expression)
- (eq? (combination-operator expression)
+ (and (scode-combination? expression)
+ (eq? (scode-combination-operator expression)
(ucode-primitive cons))
- (let ((operands (combination-operands expression)))
+ (let ((operands (scode-combination-operands expression)))
(and (pair? operands)
(eqv? (car operands) 15)
(pair? (cdr operands))
(null? (cddr operands))))))
(define (macro-reference-trap-expression-transformer expression)
- (cadr (combination-operands (cadr (combination-operands expression)))))
\ No newline at end of file
+ (cadr (scode-combination-operands (cadr (scode-combination-operands expression)))))
\ No newline at end of file
(hook/extended-scode-eval
(cond ((null? bound-names)
expression)
- ((or (definition? expression)
+ ((or (scode-definition? expression)
(and (open-block? expression)
(open-block-components expression
(lambda (names declarations body)
unspecific)
\f
(define (rewrite/variable expression environment bound-names)
- (let ((name (variable-name expression)))
+ (let ((name (scode-variable-name expression)))
(if (memq name bound-names)
(ccenv-lookup environment name)
expression)))
(define (rewrite/unassigned? expression environment bound-names)
- (let ((name (unassigned?-name expression)))
+ (let ((name (scode-unassigned?-name expression)))
(if (memq name bound-names)
- (make-combination (make-absolute-reference 'UNASSIGNED-REFERENCE-TRAP?)
- (list (ccenv-lookup environment name)))
+ (make-scode-combination
+ (make-scode-absolute-reference 'unassigned-reference-trap?)
+ (list (ccenv-lookup environment name)))
expression)))
(define (ccenv-lookup environment name)
- (make-combination (make-absolute-reference 'ENVIRONMENT-LOOKUP)
- (list (environment-that-binds environment name) name)))
+ (make-scode-combination (make-scode-absolute-reference 'environment-lookup)
+ (list (environment-that-binds environment name)
+ name)))
(define (rewrite/assignment expression environment bound-names)
- (let ((name (assignment-name expression))
+ (let ((name (scode-assignment-name expression))
(value
- (rewrite/expression (assignment-value expression)
+ (rewrite/expression (scode-assignment-value expression)
environment
bound-names)))
(if (memq name bound-names)
(error
"Cannot perform assignment to this compiled-code variable:"
name))
- (make-combination (make-absolute-reference 'ENVIRONMENT-ASSIGN!)
- (list environment name value)))
- (make-assignment name value))))
+ (make-scode-combination
+ (make-scode-absolute-reference 'environment-assign!)
+ (list environment name value)))
+ (make-scode-assignment name value))))
(define (rewrite/lambda expression environment bound-names)
(lambda-components* expression
(rewrite/expression body
environment
(difference bound-names
- (lambda-bound expression)))))))
+ (scode-lambda-bound expression)))))))
(define (rewrite/the-environment expression environment bound-names)
expression environment bound-names
(error "Can't take (the-environment) of compiled-code environment"))
(define (rewrite/access expression environment bound-names)
- (make-access (rewrite/expression (access-environment expression)
- environment
- bound-names)
- (access-name expression)))
+ (make-scode-access (rewrite/expression (scode-access-environment expression)
+ environment
+ bound-names)
+ (scode-access-name expression)))
(define (rewrite/combination expression environment bound-names)
- (make-combination (rewrite/expression (combination-operator expression)
- environment
- bound-names)
- (rewrite/expressions (combination-operands expression)
- environment
- bound-names)))
+ (make-scode-combination (rewrite/expression (scode-combination-operator expression)
+ environment
+ bound-names)
+ (rewrite/expressions (scode-combination-operands expression)
+ environment
+ bound-names)))
\f
(define (rewrite/comment expression environment bound-names)
- (make-comment (comment-text expression)
- (rewrite/expression (comment-expression expression)
- environment
- bound-names)))
+ (make-scode-comment (scode-comment-text expression)
+ (rewrite/expression (scode-comment-expression expression)
+ environment
+ bound-names)))
(define (rewrite/conditional expression environment bound-names)
- (make-conditional (rewrite/expression (conditional-predicate expression)
- environment
- bound-names)
- (rewrite/expression (conditional-consequent expression)
- environment
- bound-names)
- (rewrite/expression (conditional-alternative expression)
- environment
- bound-names)))
+ (make-scode-conditional (rewrite/expression (scode-conditional-predicate expression)
+ environment
+ bound-names)
+ (rewrite/expression (scode-conditional-consequent expression)
+ environment
+ bound-names)
+ (rewrite/expression (scode-conditional-alternative expression)
+ environment
+ bound-names)))
(define (rewrite/delay expression environment bound-names)
- (make-delay (rewrite/expression (delay-expression expression)
- environment
- bound-names)))
-
-(define (rewrite/disjunction expression environment bound-names)
- (make-disjunction (rewrite/expression (disjunction-predicate expression)
- environment
- bound-names)
- (rewrite/expression (disjunction-alternative expression)
+ (make-scode-delay (rewrite/expression (scode-delay-expression expression)
environment
bound-names)))
+(define (rewrite/disjunction expression environment bound-names)
+ (make-scode-disjunction (rewrite/expression (scode-disjunction-predicate expression)
+ environment
+ bound-names)
+ (rewrite/expression (scode-disjunction-alternative expression)
+ environment
+ bound-names)))
+
(define (rewrite/sequence expression environment bound-names)
- (make-sequence (rewrite/expressions (sequence-actions expression)
- environment
- bound-names)))
+ (make-scode-sequence (rewrite/expressions (scode-sequence-actions expression)
+ environment
+ bound-names)))
(define (rewrite/constant expression environment bound-names)
environment bound-names
(define (reduction? f1 f2)
;; Args are SCode expressions. True if F2 is a reduction of F1.
- (cond ((conditional? f2)
- (or (eq? f1 (conditional-consequent f2))
- (eq? f1 (conditional-alternative f2))))
- ((sequence? f2)
- (eq? f1 (car (last-pair (sequence-actions f2)))))
+ (cond ((scode-conditional? f2)
+ (or (eq? f1 (scode-conditional-consequent f2))
+ (eq? f1 (scode-conditional-alternative f2))))
+ ((scode-sequence? f2)
+ (eq? f1 (car (last-pair (scode-sequence-actions f2)))))
(else #f)))
\f
;;;; Stepper nodes
(let ((declarations (maybe-flush-declarations declarations)))
(if (null? declarations)
expression
- (make-declaration declarations expression))))
+ (make-scode-declaration declarations expression))))
(define flush-declarations?)
(define (cgen/variable interns variable)
(cdr (or (assq variable (cdr interns))
(let ((association
- (cons variable (make-variable (variable/name variable)))))
+ (cons variable
+ (make-scode-variable (variable/name variable)))))
(set-cdr! interns (cons association (cdr interns)))
association))))
\f
(define-method/cgen 'ACCESS
(lambda (interns expression)
- (make-access (cgen/expression interns (access/environment expression))
- (access/name expression))))
+ (make-scode-access (cgen/expression interns (access/environment expression))
+ (access/name expression))))
(define-method/cgen 'ASSIGNMENT
(lambda (interns expression)
- (make-assignment-from-variable
- (cgen/variable interns (assignment/variable expression))
+ (make-scode-assignment
+ (scode-variable-name
+ (cgen/variable interns (assignment/variable expression)))
(cgen/expression interns (assignment/value expression)))))
(define-method/cgen 'COMBINATION
(lambda (interns expression)
- (make-combination
+ (make-scode-combination
(cgen/expression interns (combination/operator expression))
(cgen/expressions interns (combination/operands expression)))))
(define-method/cgen 'CONDITIONAL
(lambda (interns expression)
- (make-conditional
+ (make-scode-conditional
(cgen/expression interns (conditional/predicate expression))
(cgen/expression interns (conditional/consequent expression))
(cgen/expression interns (conditional/alternative expression)))))
(define-method/cgen 'DELAY
(lambda (interns expression)
- (make-delay (cgen/expression interns (delay/expression expression)))))
+ (make-scode-delay (cgen/expression interns (delay/expression expression)))))
(define-method/cgen 'DISJUNCTION
(lambda (interns expression)
- (make-disjunction
+ (make-scode-disjunction
(cgen/expression interns (disjunction/predicate expression))
(cgen/expression interns (disjunction/alternative expression)))))
\f
(make-open-block
(map variable/name (open-block/variables expression))
(maybe-flush-declarations (block/declarations block))
- (make-sequence
+ (make-scode-sequence
(let loop
((variables (open-block/variables expression))
(values (open-block/values expression))
(cond ((null? variables) (cgen/expressions (list block) actions))
((null? actions) (error "Extraneous auxiliaries"))
((eq? (car actions) open-block/value-marker)
- (cons (make-assignment (variable/name (car variables))
- (cgen/expression (list block) (car values)))
+ (cons (make-scode-assignment (variable/name (car variables))
+ (cgen/expression (list block) (car values)))
(loop (cdr variables) (cdr values) (cdr actions))))
(else
(cons (cgen/expression (list block) (car actions))
(define-method/cgen 'QUOTATION
(lambda (interns expression)
interns ; ignored
- (make-quotation (cgen/top-level expression))))
+ (make-scode-quotation (cgen/top-level expression))))
(define-method/cgen 'REFERENCE
(lambda (interns expression)
(sequence/actions expression))))
(if (null? (cdr actions))
(cgen/expression interns (car actions))
- (make-sequence (cgen/expressions interns actions))))))
+ (make-scode-sequence (cgen/expressions interns actions))))))
(define (remove-references actions)
(if (null? (cdr actions))
(define-method/cgen 'THE-ENVIRONMENT
(lambda (interns expression)
interns expression ; ignored
- (make-the-environment)))
+ (make-scode-the-environment)))
\f
;;; Debugging utility
(define (pp-expression form #!optional port)
SYSTEM-GLOBAL-ENVIRONMENT ;suppresses warnings about (access ...)
THE-EMPTY-STREAM
TRUE
- UNDEFINED-CONDITIONAL-BRANCH
+ UNDEFINED-SCODE-CONDITIONAL-BRANCH
UNSPECIFIC))
(define global-primitives
(declare (usual-integrations))
-(define scode-assignment? assignment?)
-(define scode-open-block? open-block?)
-(define scode-sequence? sequence?)
\ No newline at end of file
+(define scode-open-block? open-block?)
\ No newline at end of file
;; True if expression is a call to one of the primitive-boolean-predicates.
(define (expression/call-to-boolean-predicate? expression)
- (and (combination? expression)
+ (and (scode-combination? expression)
(let ((operator (combination/operator expression)))
(and (constant? operator)
(let ((operator-value (constant/value operator)))
;; True if expression is a call to one of the effect-free-primitives.
(define (expression/call-to-effect-free-primitive? expression)
- (and (combination? expression)
+ (and (scode-combination? expression)
(let ((operator (combination/operator expression)))
(and (constant? operator)
(let ((operator-value (constant/value operator)))
;; True if expression is a call to NOT.
;; Used in conditional simplification.
(define (expression/call-to-not? expression)
- (and (combination? expression)
+ (and (scode-combination? expression)
(let ((operator (combination/operator expression)))
(and (constant? operator)
(let ((operator-value (constant/value operator)))
(define (expression/constant-eq? expression value)
(cond ((constant? expression) (eq? (constant/value expression) value))
- ((declaration? expression)
+ ((scode-declaration? expression)
(expression/constant-eq? (declaration/expression expression) value))
(else #f)))
name))
(define (global-ref? object)
- (and (access? object)
+ (and (scode-access? object)
(expression/constant-eq? (access/environment object) system-global-environment)
(access/name object)))
(define (sequence/make scode actions)
(define (sequence/collect-actions collected actions)
(fold-left (lambda (reversed action)
- (if (sequence? action)
+ (if (scode-sequence? action)
(sequence/collect-actions reversed (sequence/actions action))
(cons action reversed)))
collected
(files "gimprt")
(parent ())
(export (scode-optimizer)
- scode-assignment?
- scode-open-block?
- scode-sequence?))
+ scode-open-block?))
(define-package (scode-optimizer top-level)
(files "toplev")
integrated-predicate
consequent
alternative)
- (cond ((sequence? integrated-predicate)
+ (cond ((scode-sequence? integrated-predicate)
(sequence/make
(and expression (object/scode expression))
(append (except-last-pair (sequence/actions integrated-predicate))
(integrate/expression
operations environment alternative))))
- ((sequence? integrated-predicate)
+ ((scode-sequence? integrated-predicate)
(sequence/make
(and expression (object/scode expression))
(append (except-last-pair (sequence/actions integrated-predicate))
(if (null? (constant/value operand))
'()
'FAIL))
- ((not (combination? operand))
+ ((not (scode-combination? operand))
'FAIL)
(else
(let ((rator (combination/operator operand)))
(procedure-with-body body (encloser (procedure/body body))))
(scan-operator body encloser)))
(define (scan-operator operator encloser)
- (cond ((sequence? operator)
+ (cond ((scode-sequence? operator)
(let ((reversed-actions (reverse (sequence/actions operator))))
(scan-body (car reversed-actions)
(let ((commands (cdr reversed-actions)))
(sequence-with-actions
operator
(reverse (cons expression commands)))))))))
- ((combination? operator)
+ ((scode-combination? operator)
(let ((descend
(lambda (operator*)
(and (not (open-block? (procedure/body operator*)))
(combination/operands operator))
=> descend)
(else #f))))
- ((declaration? operator)
+ ((scode-declaration? operator)
(scan-body (declaration/expression operator)
(lambda (expression)
(encloser
(let ((do-it
(let ((start-date (get-decoded-time)))
(lambda ()
- (fasdump (make-comment
+ (fasdump (make-scode-comment
`((SOURCE-FILE . ,(->namestring input-pathname))
(DATE ,(decoded-time/year start-date)
,(decoded-time/month start-date)
;;;; General CAR/CDR Encodings
(define (call-to-car? expression)
- (and (combination? expression)
+ (and (scode-combination? expression)
(constant-eq? (combination/operator expression) (ucode-primitive car))
(length=? (combination/operands expression) 1)))
(define (call-to-cdr? expression)
- (and (combination? expression)
+ (and (scode-combination? expression)
(constant-eq? (combination/operator expression) (ucode-primitive cdr))
(length=? (combination/operands expression) 1)))
(define (call-to-general-car-cdr? expression)
- (and (combination? expression)
+ (and (scode-combination? expression)
(constant-eq? (combination/operator expression)
(ucode-primitive general-car-cdr))
(length=? (combination/operands expression) 2)
(transform/expression block environment subexpression))))
(let loop
((variables variables)
- (actions (sequence-actions body)))
+ (actions (scode-sequence-actions body)))
(cond ((null? variables)
(values '() (map transform actions)))
((null? actions)
;; encounter them in that same order when
;; looking through the body's actions.
((and (scode-assignment? (car actions))
- (eq? (assignment-name (car actions))
+ (eq? (scode-assignment-name (car actions))
(variable/name (car variables))))
(call-with-values
(lambda () (loop (cdr variables) (cdr actions)))
(lambda (vals actions*)
(values
- (cons (transform (assignment-value (car actions)))
+ (cons (transform
+ (scode-assignment-value (car actions)))
vals)
(cons open-block/value-marker actions*)))))
(else
(reference/make expression
block
(environment/lookup environment
- (variable-name expression))))
+ (scode-variable-name expression))))
(define (transform/assignment block environment expression)
- (assignment-components expression
- (lambda (name value)
- (let ((variable (environment/lookup environment name)))
- (variable/side-effect! variable)
- (assignment/make expression
- block
- variable
- (transform/expression block environment value))))))
+ (let ((name (scode-assignment-name expression))
+ (value (scode-assignment-value expression)))
+ (let ((variable (environment/lookup environment name)))
+ (variable/side-effect! variable)
+ (assignment/make expression
+ block
+ variable
+ (transform/expression block environment value)))))
\f
(define (transform/lambda block environment expression)
(lambda-components* expression
(environment/bind environment
(block/bound-variables block))))
(build-procedure expression block name required optional rest
- (transform/procedure-body block environment body)))))))))
+ (transform/procedure-body block environment
+ body)))))))))
;; If procedure body is a sequence, scan the first elements and turn variable
;; references into IGNORE declarations.
(define (build-procedure expression block name required optional rest body)
- (if (sequence? body)
+ (if (scode-sequence? body)
(do ((actions (sequence/actions body) (cdr actions))
- (ignores '() (cons (variable/name (reference/variable (car actions))) ignores)))
+ (ignores '()
+ (cons (variable/name (reference/variable (car actions)))
+ ignores)))
((or (null? (cdr actions))
(not (reference? (car actions))))
(let ((final-body (if (null? (cdr actions))
expression block name required optional rest
(if (null? ignores)
final-body
- (declaration/make #f (declarations/parse block `((ignore ,@ignores)))
+ (declaration/make #f
+ (declarations/parse block
+ `((ignore ,@ignores)))
final-body))))))
- (procedure/make
- expression block name required optional rest
- body)))
+ (procedure/make expression block name required optional rest body)))
(define (transform/procedure-body block environment expression)
(if (scode-open-block? expression)
(transform/expression block environment expression)))
(define (transform/definition block environment expression)
- (definition-components expression
- (lambda (name value)
- (if (not (eq? block top-level-block))
- (error "Unscanned definition encountered (unable to proceed):" name))
- (transform/combination*
- expression block environment
- (make-combination (make-primitive-procedure 'LOCAL-ASSIGNMENT)
- (list (make-the-environment) name value))))))
+ (let ((name (scode-definition-name expression))
+ (value (scode-definition-value expression)))
+ (if (not (eq? block top-level-block))
+ (error "Unscanned definition encountered (unable to proceed):" name))
+ (transform/combination*
+ expression block environment
+ (make-scode-combination
+ (make-primitive-procedure 'local-assignment)
+ (list (make-scode-the-environment) name value)))))
(define (transform/access block environment expression)
- (access-components expression
- (lambda (environment* name)
- (access/make expression
- block
- (transform/expression block environment environment*)
- name))))
+ (access/make expression
+ block
+ (transform/expression block
+ environment
+ (scode-access-environment expression))
+ (scode-access-name expression)))
(define (transform/combination block environment expression)
(transform/combination* expression block environment expression))
(define (transform/combination* expression block environment expression*)
- (combination-components expression*
- (lambda (operator operands)
- (combination/%make expression
- block
- (transform/expression block environment operator)
- (transform/expressions block environment operands)))))
+ (let ((operator (scode-combination-operator expression*))
+ (operands (scode-combination-operands expression*)))
+ (combination/%make expression
+ block
+ (transform/expression block environment operator)
+ (transform/expressions block environment operands))))
(define (transform/comment block environment expression)
- (transform/expression block environment (comment-expression expression)))
+ (transform/expression block environment
+ (scode-comment-expression expression)))
\f
(define (transform/conditional block environment expression)
- (conditional-components expression
- (lambda (predicate consequent alternative)
- (conditional/make
- expression
- (transform/expression block environment predicate)
- (transform/expression block environment consequent)
- (transform/expression block environment alternative)))))
+ (let ((predicate (scode-conditional-predicate expression))
+ (consequent (scode-conditional-consequent expression))
+ (alternative (scode-conditional-alternative expression)))
+ (conditional/make
+ expression
+ (transform/expression block environment predicate)
+ (transform/expression block environment consequent)
+ (transform/expression block environment alternative))))
(define (transform/constant block environment expression)
block environment ; ignored
(constant/make expression expression))
(define (transform/declaration block environment expression)
- (declaration-components expression
- (lambda (declarations expression*)
- (declaration/make expression
- (declarations/parse block declarations)
- (transform/expression block environment
- expression*)))))
+ (declaration/make
+ expression
+ (declarations/parse block (scode-declaration-text expression))
+ (transform/expression block environment
+ (scode-declaration-expression expression))))
(define (transform/delay block environment expression)
(delay/make
expression
- (transform/expression block environment (delay-expression expression))))
+ (transform/expression block environment
+ (scode-delay-expression expression))))
(define (transform/disjunction block environment expression)
- (disjunction-components expression
- (lambda (predicate alternative)
- (disjunction/make
- expression
- (transform/expression block environment predicate)
- (transform/expression block environment alternative)))))
+ (disjunction/make
+ expression
+ (transform/expression block environment
+ (scode-disjunction-predicate expression))
+ (transform/expression block environment
+ (scode-disjunction-alternative expression))))
(define (transform/quotation block environment expression)
block environment ;ignored
- (transform/quotation* expression (quotation-expression expression)))
+ (transform/quotation* expression (scode-quotation-expression expression)))
(define (transform/quotation* expression expression*)
(call-with-values (lambda () (transform/top-level expression* '()))
;; to signal ignored variables.
(sequence/%make
expression
- (transform/expressions block environment (sequence-actions expression))))
+ (transform/expressions block environment
+ (scode-sequence-actions expression))))
(define (transform/the-environment block environment expression)
environment ; ignored
(CALL-NEXT-METHOD)
,@body)
instance-environment)))
- (free-variable? (car (lambda-bound l))
- (lambda-body l)))))
+ (free-variable? (car (scode-lambda-bound l))
+ (scode-lambda-body l)))))
(values body #f)))
\f
(define free-variable?
`((ACCESS
,(lambda (name expr)
name
- (if (access-environment expr)
+ (if (scode-access-environment expr)
(illegal expr)
#f)))
(ASSIGNMENT
,(lambda (name expr)
- (or (eq? name (assignment-name expr))
- (do-expr name (assignment-value expr)))))
+ (or (eq? name (scode-assignment-name expr))
+ (do-expr name (scode-assignment-value expr)))))
(COMBINATION
,(lambda (name expr)
- (or (do-expr name (combination-operator expr))
- (do-exprs name (combination-operands expr)))))
+ (or (do-expr name (scode-combination-operator expr))
+ (do-exprs name (scode-combination-operands expr)))))
(COMMENT
,(lambda (name expr)
- (do-expr name (comment-expression expr))))
+ (do-expr name (scode-comment-expression expr))))
(CONDITIONAL
,(lambda (name expr)
- (do-exprs name (conditional-components expr list))))
+ (or (do-expr name (scode-conditional-predicate expr))
+ (do-expr name (scode-conditional-consequent expr))
+ (do-expr name (scode-conditional-alternative expr)))))
(DELAY
,(lambda (name expr)
- (do-expr name (delay-expression expr))))
+ (do-expr name (scode-delay-expression expr))))
(DISJUNCTION
,(lambda (name expr)
- (do-exprs name (disjunction-components expr list))))
+ (or (do-expr name (scode-disjunction-predicate expr))
+ (do-expr name (scode-disjunction-alternative expr)))))
(DEFINITION
,(lambda (name expr)
- (and (not (eq? name (definition-name expr)))
- (do-expr name (definition-value expr)))))
+ (and (not (eq? name (scode-definition-name expr)))
+ (do-expr name (scode-definition-value expr)))))
(LAMBDA
,(lambda (name expr)
- (and (not (memq name (lambda-bound expr)))
- (do-expr name (lambda-body expr)))))
+ (and (not (memq name (scode-lambda-bound expr)))
+ (do-expr name (scode-lambda-body expr)))))
(SEQUENCE
,(lambda (name expr)
- (do-exprs name (sequence-actions expr))))
+ (do-exprs name (scode-sequence-actions expr))))
(VARIABLE
,(lambda (name expr)
- (eq? name (variable-name expr)))))))
+ (eq? name (scode-variable-name expr)))))))
(illegal (lambda (expr) (error "Illegal expression:" expr))))
do-expr))
projects / mit-scheme.git / commitdiff