From: Chris Hanson Date: Wed, 24 Jan 2018 08:07:59 +0000 (-0800) Subject: Greatly simplify SCode abstraction and change names to contain "scode". X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~311 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=816b9122751c9b60b85f9ce3db0df8a516f763cb;p=mit-scheme.git Greatly simplify SCode abstraction and change names to contain "scode". 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. --- diff --git a/src/6001/nodefs.scm b/src/6001/nodefs.scm index 9bf33b730..910e1824d 100644 --- a/src/6001/nodefs.scm +++ b/src/6001/nodefs.scm @@ -53,21 +53,21 @@ USA. (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) diff --git a/src/compiler/back/syerly.scm b/src/compiler/back/syerly.scm index e7d745a3b..514a15272 100644 --- a/src/compiler/back/syerly.scm +++ b/src/compiler/back/syerly.scm @@ -78,31 +78,30 @@ USA. (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)))) @@ -172,25 +171,25 @@ USA. (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)))))) ;;;; INSTRUCTION->INSTRUCTION-SEQUENCE expander @@ -200,31 +199,31 @@ USA. (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))) diff --git a/src/compiler/base/asstop.scm b/src/compiler/base/asstop.scm index dab3e0601..81caa1740 100644 --- a/src/compiler/base/asstop.scm +++ b/src/compiler/base/asstop.scm @@ -209,8 +209,8 @@ USA. (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?) diff --git a/src/compiler/base/pmerly.scm b/src/compiler/base/pmerly.scm index db50558d7..cef610cb8 100644 --- a/src/compiler/base/pmerly.scm +++ b/src/compiler/base/pmerly.scm @@ -383,18 +383,14 @@ USA. (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)))) ;;;; car/cdr path compression @@ -460,7 +456,7 @@ USA. (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))) @@ -500,7 +496,7 @@ USA. make-outer-binding)) ((can-integrate? code) (possible true make-early-binding)) - (else + (else (possible true make-late-binding)))))))) ;; Mega kludge! @@ -623,20 +619,13 @@ USA. (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 @@ -650,12 +639,12 @@ USA. 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))))) ;;;; Scode utilities (continued) diff --git a/src/compiler/base/scode.scm b/src/compiler/base/scode.scm index 1226766e4..634700f49 100644 --- a/src/compiler/base/scode.scm +++ b/src/compiler/base/scode.scm @@ -101,24 +101,22 @@ USA. (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 diff --git a/src/compiler/fggen/canon.scm b/src/compiler/fggen/canon.scm index c768de898..a7ce9d0e5 100644 --- a/src/compiler/fggen/canon.scm +++ b/src/compiler/fggen/canon.scm @@ -136,11 +136,9 @@ ARBITRARY: The expression may be executed more than once. It (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)) @@ -148,12 +146,10 @@ ARBITRARY: The expression may be executed more than once. It (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)) @@ -161,13 +157,12 @@ ARBITRARY: The expression may be executed more than once. It (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) @@ -198,23 +193,21 @@ ARBITRARY: The expression may be executed more than once. It 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) @@ -225,15 +218,14 @@ ARBITRARY: The expression may be executed more than once. It ((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)))) @@ -275,37 +267,36 @@ ARBITRARY: The expression may be executed more than once. It 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)))))) ;;;; 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 @@ -337,13 +328,11 @@ ARBITRARY: The expression may be executed more than once. It (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) @@ -447,7 +436,7 @@ ARBITRARY: The expression may be executed more than once. It ;; 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 @@ -460,9 +449,7 @@ ARBITRARY: The expression may be executed more than once. It (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) @@ -495,28 +482,27 @@ ARBITRARY: The expression may be executed more than once. It (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 '() '())))) ;;;; Hairier expressions @@ -530,26 +516,25 @@ ARBITRARY: The expression may be executed more than once. It (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)) @@ -585,30 +570,28 @@ ARBITRARY: The expression may be executed more than once. It ;;;; 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 @@ -639,25 +622,20 @@ ARBITRARY: The expression may be executed more than once. It ;; 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))))))))) ;;;; Hair cubed @@ -754,7 +732,7 @@ ARBITRARY: The expression may be executed more than once. It (canonicalize/bind-environment (canout-expr nbody) env-code body))) - + (if (canonicalize/optimization-low? context) nexpr (scode/make-evaluation nexpr @@ -841,29 +819,29 @@ ARBITRARY: The expression may be executed more than once. It (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) diff --git a/src/compiler/fggen/fggen.scm b/src/compiler/fggen/fggen.scm index 29d5eb97d..4f4eccccb 100644 --- a/src/compiler/fggen/fggen.scm +++ b/src/compiler/fggen/fggen.scm @@ -483,7 +483,7 @@ USA. (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* @@ -514,94 +514,98 @@ USA. 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))))))))))))))) (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)))) '()))) -(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 @@ -680,34 +684,34 @@ USA. (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))) @@ -735,30 +739,30 @@ USA. 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) @@ -770,65 +774,64 @@ USA. #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)))))) ;; CONSTANTIFY directives are generated when an expression is introduced by ;; the canonicalizer. It instructs fggen that the expression may be constant @@ -868,19 +871,16 @@ USA. ;; 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)))) (define (generate/delay block continuation context expression) (generate/combination diff --git a/src/compiler/machines/C/compiler.pkg b/src/compiler/machines/C/compiler.pkg index 3e2647a56..90b0a0fa9 100644 --- a/src/compiler/machines/C/compiler.pkg +++ b/src/compiler/machines/C/compiler.pkg @@ -100,81 +100,69 @@ USA. 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?))) (define-package (compiler reference-contexts) (files "base/refctx") diff --git a/src/compiler/machines/i386/compiler.pkg b/src/compiler/machines/i386/compiler.pkg index 97ef53ac0..8dee49e3b 100644 --- a/src/compiler/machines/i386/compiler.pkg +++ b/src/compiler/machines/i386/compiler.pkg @@ -101,81 +101,66 @@ USA. 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?))) (define-package (compiler reference-contexts) (files "base/refctx") diff --git a/src/compiler/machines/i386/dassm1.scm b/src/compiler/machines/i386/dassm1.scm index 2057f614a..c414a3fb2 100644 --- a/src/compiler/machines/i386/dassm1.scm +++ b/src/compiler/machines/i386/dassm1.scm @@ -174,7 +174,7 @@ USA. (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)) diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg index 5ae0589b1..c0bc3ab34 100644 --- a/src/compiler/machines/svm/compiler.pkg +++ b/src/compiler/machines/svm/compiler.pkg @@ -101,81 +101,69 @@ USA. 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?))) (define-package (compiler reference-contexts) (files "base/refctx") diff --git a/src/compiler/machines/svm/disassembler.scm b/src/compiler/machines/svm/disassembler.scm index 305c8da36..072314581 100644 --- a/src/compiler/machines/svm/disassembler.scm +++ b/src/compiler/machines/svm/disassembler.scm @@ -244,7 +244,7 @@ USA. (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) diff --git a/src/compiler/machines/x86-64/compiler.pkg b/src/compiler/machines/x86-64/compiler.pkg index 5464e1650..c9824f551 100644 --- a/src/compiler/machines/x86-64/compiler.pkg +++ b/src/compiler/machines/x86-64/compiler.pkg @@ -101,81 +101,69 @@ USA. 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?))) (define-package (compiler reference-contexts) (files "base/refctx") diff --git a/src/compiler/machines/x86-64/dassm1.scm b/src/compiler/machines/x86-64/dassm1.scm index 2057f614a..84f045f6c 100644 --- a/src/compiler/machines/x86-64/dassm1.scm +++ b/src/compiler/machines/x86-64/dassm1.scm @@ -174,8 +174,8 @@ USA. (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 diff --git a/src/cref/anfile.scm b/src/cref/anfile.scm index a1b8023cf..273604c3e 100644 --- a/src/cref/anfile.scm +++ b/src/cref/anfile.scm @@ -38,7 +38,7 @@ USA. (if (pair? others) (cons (vector false 'EXPRESSION - (analyze-and-compress (make-sequence others))) + (analyze-and-compress (make-scode-sequence others))) definition-analysis) definition-analysis)))) @@ -49,29 +49,29 @@ USA. (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)))))) @@ -94,23 +94,23 @@ USA. (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) @@ -120,24 +120,29 @@ USA. auxiliary))))) (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 diff --git a/src/cref/redpkg.scm b/src/cref/redpkg.scm index 5cf93f644..98fc91d04 100644 --- a/src/cref/redpkg.scm +++ b/src/cref/redpkg.scm @@ -217,11 +217,11 @@ USA. (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 diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 3c98a4b77..1de7fc0e4 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -293,10 +293,7 @@ USA. (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") diff --git a/src/edwin/xform.scm b/src/edwin/xform.scm index 194cd6b9f..0f3ddb5f3 100644 --- a/src/edwin/xform.scm +++ b/src/edwin/xform.scm @@ -63,26 +63,26 @@ USA. (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)))) (define (transform-lambda transforms expression) (lambda-components** expression @@ -100,35 +100,36 @@ USA. 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 diff --git a/src/ffi/syntax.scm b/src/ffi/syntax.scm index 8c5365e71..cad2339cd 100644 --- a/src/ffi/syntax.scm +++ b/src/ffi/syntax.scm @@ -74,7 +74,7 @@ USA. (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)) diff --git a/src/runtime/advice.scm b/src/runtime/advice.scm index 656fb8e8e..8abbf5f02 100644 --- a/src/runtime/advice.scm +++ b/src/runtime/advice.scm @@ -67,10 +67,10 @@ USA. (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)) diff --git a/src/runtime/codwlk.scm b/src/runtime/codwlk.scm index 311cbee05..fab46b05a 100644 --- a/src/runtime/codwlk.scm +++ b/src/runtime/codwlk.scm @@ -126,21 +126,22 @@ USA. table))) (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))) diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm index 74421e641..b5418fccf 100644 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@ -146,7 +146,6 @@ USA. ("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)) diff --git a/src/runtime/environment.scm b/src/runtime/environment.scm index 0a090fba4..861322a98 100644 --- a/src/runtime/environment.scm +++ b/src/runtime/environment.scm @@ -110,7 +110,7 @@ USA. (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) diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm index bbb7f86fa..3c15a9e90 100644 --- a/src/runtime/framex.scm +++ b/src/runtime/framex.scm @@ -130,8 +130,8 @@ USA. (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) @@ -140,7 +140,7 @@ USA. (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 @@ -158,17 +158,18 @@ USA. 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)))) @@ -234,8 +235,8 @@ USA. (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 @@ -250,7 +251,7 @@ USA. (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)) @@ -283,13 +284,13 @@ USA. (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 diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm index 1093bf104..e594e5be0 100644 --- a/src/runtime/host-adapter.scm +++ b/src/runtime/host-adapter.scm @@ -41,6 +41,11 @@ USA. (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) @@ -57,10 +62,72 @@ USA. (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) diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index 3e5d3327a..e60ca8b0e 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -169,9 +169,10 @@ USA. 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 @@ -362,7 +363,7 @@ USA. (or (and (dbg-procedure? object) (let ((scode (dbg-procedure/source-code object))) (and scode - (lambda-body scode)))) + (scode-lambda-body scode)))) entry))) ;;; Support of BSM files diff --git a/src/runtime/lambda.scm b/src/runtime/lambda.scm index d6094da07..bf859fea1 100644 --- a/src/runtime/lambda.scm +++ b/src/runtime/lambda.scm @@ -29,19 +29,19 @@ USA. (declare (usual-integrations)) -(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. @@ -92,28 +92,28 @@ USA. (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 @@ -132,8 +132,8 @@ USA. (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!))) @@ -185,11 +185,11 @@ USA. (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))))) @@ -198,22 +198,22 @@ USA. '(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)) ;;;; Compound Lambda @@ -241,22 +241,22 @@ USA. (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))))) @@ -402,11 +402,12 @@ USA. ;;;; 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))) @@ -421,8 +422,8 @@ USA. (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)) @@ -435,14 +436,16 @@ USA. (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) @@ -565,8 +568,8 @@ USA. (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) diff --git a/src/runtime/lambdx.scm b/src/runtime/lambdx.scm index 20e2717a9..7afb22e2f 100644 --- a/src/runtime/lambdx.scm +++ b/src/runtime/lambdx.scm @@ -33,10 +33,11 @@ USA. (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))))) diff --git a/src/runtime/load.scm b/src/runtime/load.scm index 1abe1d7d8..02f793d4d 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -221,8 +221,8 @@ USA. (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) diff --git a/src/runtime/microcode-errors.scm b/src/runtime/microcode-errors.scm index 554d23b19..c3c6019da 100644 --- a/src/runtime/microcode-errors.scm +++ b/src/runtime/microcode-errors.scm @@ -526,15 +526,15 @@ USA. (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) diff --git a/src/runtime/parser.scm b/src/runtime/parser.scm index c4bbe692a..bcca96490 100644 --- a/src/runtime/parser.scm +++ b/src/runtime/parser.scm @@ -586,7 +586,7 @@ USA. ;; 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)) diff --git a/src/runtime/prgcop.scm b/src/runtime/prgcop.scm index 2c582e51f..a2beac791 100644 --- a/src/runtime/prgcop.scm +++ b/src/runtime/prgcop.scm @@ -232,9 +232,9 @@ USA. (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) @@ -247,12 +247,12 @@ USA. (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)) diff --git a/src/runtime/procedure.scm b/src/runtime/procedure.scm index 60e19913f..9a8ce1c47 100644 --- a/src/runtime/procedure.scm +++ b/src/runtime/procedure.scm @@ -102,7 +102,7 @@ USA. (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))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 16a728a1a..23f4d1e2e 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -606,21 +606,6 @@ USA. 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)) @@ -2816,18 +2801,18 @@ USA. (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! @@ -2844,6 +2829,21 @@ USA. 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)) @@ -3888,97 +3888,64 @@ USA. (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") @@ -3996,31 +3963,6 @@ USA. &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 @@ -4050,7 +3992,6 @@ USA. open-block-actions open-block-components open-block-declarations - open-block-definitions open-block-names open-block? scan-defines diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm index 889f45be7..d43faed8b 100644 --- a/src/runtime/scan.scm +++ b/src/runtime/scan.scm @@ -45,9 +45,6 @@ USA. ;;; 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)) @@ -63,35 +60,40 @@ USA. ;;; 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 @@ -110,27 +112,26 @@ USA. (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)))) @@ -154,78 +155,73 @@ USA. (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 diff --git a/src/runtime/scode.scm b/src/runtime/scode.scm index 834edca66..e7091e3fd 100644 --- a/src/runtime/scode.scm +++ b/src/runtime/scode.scm @@ -28,277 +28,423 @@ USA. ;;; package: (runtime scode) (declare (usual-integrations)) - -(define (initialize-package!) - (set! scode-constant/type-vector (make-scode-constant/type-vector)) - unspecific) ;;;; 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))) - -;;;; 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)))) + +;;;; 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))) - ;;;; 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)) ;;;; 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)))) + +;;;; 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))) + +;;;; 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)))) + +;;;; 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)))) + +;;; 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 diff --git a/src/runtime/scomb.scm b/src/runtime/scomb.scm deleted file mode 100644 index b17508db2..000000000 --- a/src/runtime/scomb.scm +++ /dev/null @@ -1,202 +0,0 @@ -#| -*-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)) - - -;;;; 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))) - - -;;;; 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)) - -;;;; 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 diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index 79e8480be..3a112f9f8 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -1104,9 +1104,10 @@ swank:xref 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)) diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm index 355d58740..b06c90e0b 100644 --- a/src/runtime/syntax-output.scm +++ b/src/runtime/syntax-output.scm @@ -33,38 +33,38 @@ USA. (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)) @@ -75,10 +75,10 @@ USA. (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)) @@ -96,12 +96,14 @@ USA. "-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) @@ -111,20 +113,20 @@ USA. (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) @@ -138,13 +140,13 @@ USA. (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) @@ -178,16 +180,17 @@ USA. (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 @@ -237,28 +240,38 @@ USA. (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 @@ -286,15 +299,15 @@ USA. ((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 @@ -311,10 +324,9 @@ USA. (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) @@ -325,11 +337,22 @@ USA. 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) @@ -339,48 +362,48 @@ USA. (get-subexpressions expression))))) (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 diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index ee66ac7d0..394bd352b 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -447,7 +447,7 @@ USA. (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) @@ -788,22 +788,22 @@ USA. (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 diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm index 74240e021..0590d2139 100644 --- a/src/runtime/unsyn.scm +++ b/src/runtime/unsyn.scm @@ -59,7 +59,6 @@ USA. (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 @@ -91,7 +90,7 @@ USA. (define (is-bound? name environment) (any (lambda (binding-lambda) - (lambda-bound? binding-lambda name)) + (scode-lambda-bound? binding-lambda name)) environment)) (define (unsyntax scode) @@ -132,43 +131,44 @@ USA. (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) @@ -178,7 +178,7 @@ USA. 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) @@ -200,48 +200,42 @@ USA. (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?) @@ -252,37 +246,36 @@ USA. (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)) -(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) @@ -293,13 +286,13 @@ USA. (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 @@ -319,35 +312,38 @@ USA. ,@(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)))) @@ -356,14 +352,14 @@ USA. (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)))))) @@ -382,7 +378,7 @@ USA. `(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 @@ -399,53 +395,55 @@ USA. (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)))) ;;;; 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) diff --git a/src/runtime/urtrap.scm b/src/runtime/urtrap.scm index 096ae2710..ccb851d05 100644 --- a/src/runtime/urtrap.scm +++ b/src/runtime/urtrap.scm @@ -157,24 +157,25 @@ USA. (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)) @@ -182,4 +183,4 @@ USA. (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 diff --git a/src/runtime/xeval.scm b/src/runtime/xeval.scm index 0b6ebb0b1..691258238 100644 --- a/src/runtime/xeval.scm +++ b/src/runtime/xeval.scm @@ -45,7 +45,7 @@ USA. (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) @@ -116,26 +116,28 @@ USA. unspecific) (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) @@ -144,9 +146,10 @@ USA. (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 @@ -156,60 +159,60 @@ USA. (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))) (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 diff --git a/src/runtime/ystep.scm b/src/runtime/ystep.scm index 9a8df24a9..db15814d7 100644 --- a/src/runtime/ystep.scm +++ b/src/runtime/ystep.scm @@ -280,11 +280,11 @@ USA. (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))) ;;;; Stepper nodes diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm index c5c905ca8..35555e9ac 100644 --- a/src/sf/cgen.scm +++ b/src/sf/cgen.scm @@ -60,7 +60,7 @@ USA. (let ((declarations (maybe-flush-declarations declarations))) (if (null? declarations) expression - (make-declaration declarations expression)))) + (make-scode-declaration declarations expression)))) (define flush-declarations?) @@ -123,30 +123,32 @@ USA. (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)))) (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))))) @@ -164,11 +166,11 @@ USA. (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))))) @@ -194,7 +196,7 @@ USA. (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)) @@ -202,8 +204,8 @@ USA. (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)) @@ -212,7 +214,7 @@ USA. (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) @@ -226,7 +228,7 @@ USA. (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)) @@ -239,7 +241,7 @@ USA. (define-method/cgen 'THE-ENVIRONMENT (lambda (interns expression) interns expression ; ignored - (make-the-environment))) + (make-scode-the-environment))) ;;; Debugging utility (define (pp-expression form #!optional port) diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm index 7d43deb24..afdc8aa38 100644 --- a/src/sf/gconst.scm +++ b/src/sf/gconst.scm @@ -37,7 +37,7 @@ USA. SYSTEM-GLOBAL-ENVIRONMENT ;suppresses warnings about (access ...) THE-EMPTY-STREAM TRUE - UNDEFINED-CONDITIONAL-BRANCH + UNDEFINED-SCODE-CONDITIONAL-BRANCH UNSPECIFIC)) (define global-primitives diff --git a/src/sf/gimprt.scm b/src/sf/gimprt.scm index c48cc6f70..d6944ccde 100644 --- a/src/sf/gimprt.scm +++ b/src/sf/gimprt.scm @@ -29,6 +29,4 @@ USA. (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 diff --git a/src/sf/object.scm b/src/sf/object.scm index 11c3f1b57..4f1b66540 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -263,7 +263,7 @@ USA. ;; 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))) @@ -296,7 +296,7 @@ USA. ;; 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))) @@ -308,7 +308,7 @@ USA. ;; 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))) @@ -319,7 +319,7 @@ USA. (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))) @@ -330,7 +330,7 @@ USA. name)) (define (global-ref? object) - (and (access? object) + (and (scode-access? object) (expression/constant-eq? (access/environment object) system-global-environment) (access/name object))) @@ -568,7 +568,7 @@ USA. (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 diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index acaf8a2de..01dd5fa9d 100644 --- a/src/sf/sf.pkg +++ b/src/sf/sf.pkg @@ -46,9 +46,7 @@ USA. (files "gimprt") (parent ()) (export (scode-optimizer) - scode-assignment? - scode-open-block? - scode-sequence?)) + scode-open-block?)) (define-package (scode-optimizer top-level) (files "toplev") diff --git a/src/sf/subst.scm b/src/sf/subst.scm index 676efaf05..791f89c3b 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -181,7 +181,7 @@ USA. 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)) @@ -272,7 +272,7 @@ USA. (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)) @@ -723,7 +723,7 @@ USA. (if (null? (constant/value operand)) '() 'FAIL)) - ((not (combination? operand)) + ((not (scode-combination? operand)) 'FAIL) (else (let ((rator (combination/operator operand))) @@ -795,7 +795,7 @@ USA. (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))) @@ -804,7 +804,7 @@ USA. (sequence-with-actions operator (reverse (cons expression commands))))))))) - ((combination? operator) + ((scode-combination? operator) (let ((descend (lambda (operator*) (and (not (open-block? (procedure/body operator*))) @@ -822,7 +822,7 @@ USA. (combination/operands operator)) => descend) (else #f)))) - ((declaration? operator) + ((scode-declaration? operator) (scan-body (declaration/expression operator) (lambda (expression) (encloser diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm index 12bec9d0c..66c041c15 100644 --- a/src/sf/toplev.scm +++ b/src/sf/toplev.scm @@ -128,7 +128,7 @@ USA. (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) diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm index 0fa9a09ac..4f2feae43 100644 --- a/src/sf/usiexp.scm +++ b/src/sf/usiexp.scm @@ -383,17 +383,17 @@ USA. ;;;; 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) diff --git a/src/sf/xform.scm b/src/sf/xform.scm index 53d87f6b1..3dfa2da8e 100644 --- a/src/sf/xform.scm +++ b/src/sf/xform.scm @@ -132,7 +132,7 @@ USA. (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) @@ -142,13 +142,14 @@ USA. ;; 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 @@ -165,17 +166,17 @@ USA. (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))))) (define (transform/lambda block environment expression) (lambda-components* expression @@ -193,14 +194,17 @@ USA. (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)) @@ -210,11 +214,11 @@ USA. 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) @@ -229,74 +233,77 @@ USA. (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))) (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* '())) @@ -308,7 +315,8 @@ USA. ;; 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 diff --git a/src/sos/macros.scm b/src/sos/macros.scm index 1ad6c2e8a..65d66572c 100644 --- a/src/sos/macros.scm +++ b/src/sos/macros.scm @@ -443,8 +443,8 @@ USA. (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))) (define free-variable? @@ -463,43 +463,46 @@ USA. `((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))