(integrate/expression operations environment expression))
expressions))
+(define (integrate/actions operations environment actions)
+ (let ((action (car actions)))
+ (if (null? (cdr actions))
+ (list (if (eq? action open-block/value-marker)
+ action
+ (integrate/expression operations environment action)))
+ (cons (cond ((reference? action)
+ ;; This clause lets you ignore a variable by
+ ;; mentioning it in a sequence.
+ (variable/may-ignore! (reference/variable action))
+ action)
+ ((eq? action open-block/value-marker)
+ action)
+ (else
+ (integrate/expression operations environment action)))
+ (integrate/actions operations environment (cdr actions))))))
+
(define (integrate/expression operations environment expression)
((expression/method dispatch-vector expression)
operations environment expression))
(define define-method/integrate
(expression/make-method-definer dispatch-vector))
\f
-;;;; Variables
+;;;; ACCESS
+(define-method/integrate 'ACCESS
+ (lambda (operations environment expression)
+ (let ((environment* (integrate/expression operations environment
+ (access/environment expression)))
+ (name (access/name expression)))
+ (cond ((and (constant/system-global-environment? environment*)
+ (assq name usual-integrations/constant-alist))
+ => (lambda (entry)
+ (constant/make (access/scode expression)
+ (constant/value (cdr entry)))))
+ (else (access/make (access/scode expression)
+ environment* name))))))
+;;;; ASSIGNMENT
(define-method/integrate 'ASSIGNMENT
(lambda (operations environment assignment)
(let ((variable (assignment/variable assignment)))
(warn "Attempt to assign integrated name"
(variable/name variable)))
(else (error "Unknown operation" operation))))
- (lambda () 'DONE))
- ;; The value of an assignment is the old value
- ;; of the variable, hence, it is refernced.
+ false-procedure)
+
(variable/reference! variable)
(assignment/make (assignment/scode assignment)
(assignment/block assignment)
environment
(assignment/value assignment))))))
+;;;; COMBINATION
+(define-method/integrate 'COMBINATION
+ (lambda (operations environment combination)
+ (integrate/combination
+ combination operations environment
+ (combination/block combination)
+ (combination/operator combination)
+ (integrate/expressions operations
+ environment
+ (combination/operands combination)))))
+
+;;;; CONDITIONAL
+(define-method/integrate 'CONDITIONAL
+ (lambda (operations environment expression)
+ (conditional/make
+ (conditional/scode expression)
+ (integrate/expression
+ operations environment
+ (conditional/predicate expression))
+ (integrate/expression
+ operations environment
+ (conditional/consequent expression))
+ (integrate/expression
+ operations environment
+ (conditional/alternative expression)))))
+
+;;; CONSTANT
+(define-method/integrate 'CONSTANT
+ (lambda (operations environment expression)
+ (declare (ignore operations environment))
+ expression))
+
+;;; DECLARATION
+(define-method/integrate 'DECLARATION
+ (lambda (operations environment declaration)
+ (let ((declarations (declaration/declarations declaration))
+ (expression (declaration/expression declaration)))
+ (declaration/make
+ (declaration/scode declaration)
+ declarations
+ (integrate/expression (declarations/bind operations declarations)
+ environment
+ expression)))))
+
+;;; DELAY
+(define-method/integrate 'DELAY
+ (lambda (operations environment expression)
+ (delay/make
+ (delay/scode expression)
+ (integrate/expression operations environment
+ (delay/expression expression)))))
+
+
+;;; DISJUNCTION
+(define-method/integrate 'DISJUNCTION
+ (lambda (operations environment expression)
+ (disjunction/make
+ (disjunction/scode expression)
+ (integrate/expression operations environment (disjunction/predicate expression))
+ (integrate/expression operations environment (disjunction/alternative expression)))))
+
+;;; OPEN-BLOCK
+(define-method/integrate 'OPEN-BLOCK
+ (lambda (operations environment expression)
+ (call-with-values
+ (lambda () (integrate/open-block operations environment expression))
+ (lambda (operations environment expression)
+ (declare (ignore operations environment))
+ expression))))
+
+;;; PROCEDURE
+(define-method/integrate 'PROCEDURE
+ (lambda (operations environment procedure)
+ (integrate/procedure operations
+ (simulate-unknown-application environment procedure)
+ procedure)))
+
+;;;; Quotation
+(define-method/integrate 'QUOTATION
+ (lambda (operations environment expression)
+ (declare (ignore operations environment))
+ (integrate/quotation expression)))
+
+(define (integrate/quotation quotation)
+ (call-with-values
+ (lambda ()
+ (integrate/top-level* (quotation/scode quotation)
+ (quotation/block quotation)
+ (quotation/expression quotation)))
+ (lambda (operations environment expression)
+ operations environment ;ignore
+ expression)))
+
+;;;; Reference
(define-method/integrate 'REFERENCE
(lambda (operations environment expression)
(let ((variable (reference/variable expression)))
(error "Unknown operation" operation))))
(lambda ()
(integration-failure)))))))
-\f
+
(define (reassign expr object)
(if (and expr (object/scode expr))
(with-new-scode (object/scode expr) object)
object))
-\f
-(define (integrate/reference-operator expression operations environment
- block operator operands)
- (let ((variable (reference/variable operator)))
- (letrec ((mark-integrated!
- (lambda ()
- (variable/integrated! variable)))
- (integration-failure
- (lambda ()
- (variable/reference! variable)
- (combination/make expression block
- operator operands)))
- (integration-success
- (lambda (operator)
- (mark-integrated!)
- (integrate/combination expression operations environment
- block operator operands))))
- (operations/lookup operations variable
- (lambda (operation info)
- (case operation
- ((#F) (integration-failure))
-
- ((EXPAND)
- (let ((new-expression (info expression operands (reference/block operator))))
- (if new-expression
- (begin
- (mark-integrated!)
- (integrate/expression operations environment new-expression))
- (integration-failure))))
-
- ((INTEGRATE INTEGRATE-OPERATOR)
- (let ((new-expression (integrate/name expression
- operator info environment)))
- (if new-expression
- (integration-success new-expression)
- (integration-failure))))
-
- (else
- (error "Unknown operation" operation))))
- (lambda ()
- (integration-failure))))))
+
+;;; SEQUENCE
+(define-method/integrate 'SEQUENCE
+ (lambda (operations environment expression)
+ ;; Optimize (begin (foo)) => (foo)
+ ;; Optimize (begin a b (foo) 22 (bar)) => (begin (foo) (bar))
+ (sequence/optimizing-make
+ expression
+ (integrate/actions operations environment
+ (sequence/actions expression)))))
+
+;;; THE-ENVIRONMENT
+(define-method/integrate 'THE-ENVIRONMENT
+ (lambda (operations environment expression)
+ operations
+ environment
+ expression))
+
\f
;;;; Binding
+;;; If not #f, display the top-level procedure names as they are
+;;; processed. Useful for debugging.
+(define sf:display-top-level-procedure-names? #f)
+
+(define (maybe-displaying-name name thunk)
+ (if (and sf:display-top-level-procedure-names?
+ (null? *current-block-names*))
+ (with-notification
+ (lambda (port)
+ (write-string "Integrating procedure " port)
+ (write name port))
+ thunk)
+ (thunk)))
+
(define (integrate/open-block operations environment expression)
(let ((variables (open-block/variables expression))
(block (open-block/block expression)))
block variables
vals actions))))))))
-(define-method/integrate 'OPEN-BLOCK
- (lambda (operations environment expression)
- (call-with-values
- (lambda () (integrate/open-block operations environment expression))
- (lambda (operations environment expression)
- operations environment
- expression))))
-\f
(define (variable/unreferenced? variable)
(and (not (variable/integrated variable))
(not (variable/referenced variable))
(not (variable/may-ignore? variable))
(not (variable/must-ignore? variable))))
-(define-method/integrate 'PROCEDURE
- (lambda (operations environment procedure)
- (integrate/procedure operations
- (simulate-unknown-application environment procedure)
- procedure)))
-
-;;; If not #f, display the top-level procedure names as they are
-;;; processed. Useful for debugging.
-(define sf:display-top-level-procedure-names? #f)
-
-(define (maybe-displaying-name name thunk)
- (if (and sf:display-top-level-procedure-names?
- (null? *current-block-names*))
- (with-notification
- (lambda (port)
- (write-string "Integrating procedure " port)
- (write name port))
- thunk)
- (thunk)))
-\f
(define (integrate/procedure operations environment procedure)
(let ((block (procedure/block procedure))
(name (procedure/name procedure))
rest
body)))))))
\f
-(define-method/integrate 'COMBINATION
- (lambda (operations environment combination)
- (integrate/combination
- combination operations environment
- (combination/block combination)
- (combination/operator combination)
- (integrate/expressions operations
- environment
- (combination/operands combination)))))
+
+;;; INTEGRATE-COMBINATION
+(define integrate-combination-dispatch-vector
+ (expression/make-dispatch-vector))
+
+(define define-method/integrate-combination
+ (expression/make-method-definer integrate-combination-dispatch-vector))
(define (integrate/combination expression operations environment
block operator operands)
- (cond ((reference? operator)
- (integrate/reference-operator expression operations environment
- block operator operands))
- ((and (access? operator)
- (constant/system-global-environment?
- (integrate/expression operations environment (access/environment operator))))
- (integrate/access-operator expression operations environment
- block operator operands))
- ((and (constant? operator)
- (primitive-procedure? (constant/value operator)))
- (let ((operands*
- (and (eq? (constant/value operator) (ucode-primitive apply))
- (integrate/hack-apply? operands))))
- (if operands*
- (integrate/combination expression operations environment
- block (car operands*) (cdr operands*))
- (integrate/primitive-operator expression operations environment
- block operator operands))))
- (else
- (combination/make
- expression
- block
- (let* ((integrate-procedure
- (lambda (operator)
- (integrate/procedure-operator operations environment
- block operator operands)))
- (operator
- (if (procedure? operator)
- (integrate-procedure operator)
- (let ((operator
- (integrate/expression operations
- environment
- operator)))
- (if (procedure? operator)
- (integrate-procedure operator)
- operator)))))
- (cond ((integrate/compound-operator operator operands)
- => integrate-procedure)
- (else operator)))
- operands))))
+ ((expression/method integrate-combination-dispatch-vector operator)
+ expression operations environment block operator operands))
+
+;;;; access-operator
+(define-method/integrate-combination 'ACCESS
+ (lambda (expression operations environment block operator operands)
+ (integrate/access-operator expression operations environment
+ block operator operands)))
+
+(define (integrate/access-operator expression operations environment block operator operands)
+ (let ((name (access/name operator))
+ (environment*
+ (integrate/expression operations environment (access/environment operator))))
+
+ (define (dont-integrate)
+ (combination/make
+ expression block
+ (access/make (access/scode operator) environment* name) operands))
+
+ (if (not (constant/system-global-environment? environment*))
+ (dont-integrate)
+ (operations/lookup-global
+ operations name
+ (lambda (operation info)
+ (case operation
+ ((#F) (dont-integrate))
+
+ ((EXPAND)
+ (cond ((info expression operands (reference/block operator))
+ => (lambda (new-expression)
+ (integrate/expression operations environment new-expression)))
+ (else (dont-integrate))))
+
+ ((INTEGRATE INTEGRATE-OPERATOR)
+ (let ((new-operator
+ (reassign operator
+ (copy/expression/intern block (integration-info/expression info)))))
+ (integrate/combination expression operations environment block new-operator operands)))
+
+ (else
+ (error "unknown operation" operation))))
+ dont-integrate))))
+
+;;; assignment-operator
+(define-method/integrate-combination 'ASSIGNMENT
+ (lambda (expression operations environment block operator operands)
+ (warn "Value of assignment used as an operator.")
+ ;; We don't try to make sense of this, we just
+ ;; build the code and let the runtime raise an error.
+ (combination/make expression
+ block
+ (integrate/expression operations environment operator)
+ operands)))
+
+;;; combination-operator
+(define-method/integrate-combination 'COMBINATION
+ (lambda (expression operations environment block operator operands)
+ (integrate-combination/default expression operations environment block operator operands)))
+
+;;; conditional-operator
+(define-method/integrate-combination 'CONDITIONAL
+ (lambda (expression operations environment block operator operands)
+ (integrate-combination/default expression operations environment block operator operands)))
+
+;;; constant-operator
+(define-method/integrate-combination 'CONSTANT
+ (lambda (expression operations environment block operator operands)
+ (if (primitive-procedure? (constant/value operator))
+ (let ((operands*
+ (and (eq? (constant/value operator) (ucode-primitive apply))
+ (integrate/hack-apply? operands))))
+ (if operands*
+ (integrate/combination expression operations environment
+ block (car operands*) (cdr operands*))
+ (integrate/primitive-operator expression operations environment
+ block operator operands)))
+ (begin
+ (warn "Application of constant value" (constant/value operator))
+ (integrate-combination/default expression operations environment block operator operands)))))
+
+(define (integrate/primitive-operator expression operations environment
+ block operator operands)
+ (declare (ignore operations environment))
+ (combination/make expression block operator operands))
+
+;;; declaration-operator
+(define-method/integrate-combination 'DECLARATION
+ (lambda (expression operations environment block operator operands)
+ (integrate-combination/default expression operations environment block operator operands)))
+
+;;; delay-operator
+(define-method/integrate-combination 'DELAY
+ (lambda (expression operations environment block operator operands)
+ ;; Nonsense - generate a warning.
+ (warn "Delayed object in operator position. This will cause a runtime error.")
+ (combination/make expression
+ block
+ (integrate/expression operations environment operator)
+ operands)))
+
+;;; disjunction-operator
+(define-method/integrate-combination 'DISJUNCTION
+ (lambda (expression operations environment block operator operands)
+ (integrate-combination/default expression operations environment block operator operands)))
+
+;;; open-block-operator
+(define-method/integrate-combination 'OPEN-BLOCK
+ (lambda (expression operations environment block operator operands)
+ (declare (ignore expression operations environment block operator operands))
+ ;; This shouldn't be possible.
+ (error "INTERNAL-ERROR: integrate-combination 'open-block")))
+
+;;; procedure-operator (let)
+(define-method/integrate-combination 'PROCEDURE
+ (lambda (expression operations environment block operator operands)
+ (integrate-combination/default expression operations environment block operator operands)))
(define (integrate/procedure-operator operations environment
block procedure operands)
procedure operands)
procedure))
-(define (integrate/primitive-operator expression operations environment
+;;; quotation-operator
+(define-method/integrate-combination 'QUOTATION
+ (lambda (expression operations environment block operator operands)
+ (integrate-combination/default expression operations environment block operator operands)))
+
+;;; reference-operator
+(define-method/integrate-combination 'REFERENCE
+ (lambda (expression operations environment block operator operands)
+ (integrate/reference-operator expression operations environment
+ block operator operands)))
+
+(define (integrate/reference-operator expression operations environment
block operator operands)
- (declare (ignore operations environment))
- (combination/make expression block operator operands))
+ (let ((variable (reference/variable operator)))
+ (letrec ((mark-integrated!
+ (lambda ()
+ (variable/integrated! variable)))
+ (integration-failure
+ (lambda ()
+ (variable/reference! variable)
+ (combination/make expression block
+ operator operands)))
+ (integration-success
+ (lambda (operator)
+ (mark-integrated!)
+ (integrate/combination expression operations environment
+ block operator operands))))
+ (operations/lookup operations variable
+ (lambda (operation info)
+ (case operation
+ ((#F) (integration-failure))
+
+ ((EXPAND)
+ (let ((new-expression (info expression operands (reference/block operator))))
+ (if new-expression
+ (begin
+ (mark-integrated!)
+ (integrate/expression operations environment new-expression))
+ (integration-failure))))
+
+ ((INTEGRATE INTEGRATE-OPERATOR)
+ (let ((new-expression (integrate/name expression
+ operator info environment)))
+ (if new-expression
+ (integration-success new-expression)
+ (integration-failure))))
+
+ (else
+ (error "Unknown operation" operation))))
+ (lambda ()
+ (integration-failure))))))
+
+;;; sequence-operator
+(define-method/integrate-combination 'SEQUENCE
+ (lambda (expression operations environment block operator operands)
+ (integrate-combination/default expression operations environment block operator operands)))
+
+;;; the-environment-operator
+(define-method/integrate-combination 'THE-ENVIRONMENT
+ (lambda (expression operations environment block operator operands)
+ (warn "(THE-ENVIRONMENT) used as an operator. Will cause a runtime error.")
+ (combination/make expression block
+ (integrate/expression operations environment operator)
+ operands)))
+
+(define (integrate-combination/default expression operations environment
+ block operator operands)
+ (combination/make
+ expression
+ block
+ (let* ((integrate-procedure
+ (lambda (operator)
+ (integrate/procedure-operator operations environment
+ block operator operands)))
+ (operator
+ (if (procedure? operator)
+ (integrate-procedure operator)
+ (let ((operator
+ (integrate/expression operations
+ environment
+ operator)))
+ (if (procedure? operator)
+ (integrate-procedure operator)
+ operator)))))
+ (cond ((integrate/compound-operator operator operands)
+ => integrate-procedure)
+ (else operator)))
+ operands))
+
+(define (integrate/hack-apply? operands)
+ (define (check operand)
+ (cond ((constant? operand)
+ (if (null? (constant/value operand))
+ '()
+ 'FAIL))
+ ((not (combination? operand))
+ 'FAIL)
+ (else
+ (let ((rator (combination/operator operand)))
+ (if (or (and (constant? rator)
+ (eq? (ucode-primitive cons)
+ (constant/value rator)))
+ (eq? 'cons (global-ref? rator)))
+ (let* ((rands (combination/operands operand))
+ (next (check (cadr rands))))
+ (if (eq? next 'FAIL)
+ 'FAIL
+ (cons (car rands) next)))
+ 'FAIL)))))
+
+ (and (not (null? operands))
+ (let ((tail (check (car (last-pair operands)))))
+ (and (not (eq? tail 'FAIL))
+ (append (except-last-pair operands)
+ tail)))))
+
\f
;;; ((let ((a (foo)) (b (bar)))
;;; (lambda (receiver)
(or (reference? expression)
(non-side-effecting-in-sequence? expression)))
\f
-(define-method/integrate 'DECLARATION
- (lambda (operations environment declaration)
- (let ((declarations (declaration/declarations declaration))
- (expression (declaration/expression declaration)))
- (declaration/make
- (declaration/scode declaration)
- declarations
- (integrate/expression (declarations/bind operations declarations)
- environment
- expression)))))
-
-;;;; Easy Cases
-
-(define-method/integrate 'CONSTANT
- (lambda (operations environment expression)
- operations
- environment
- expression))
-
-(define-method/integrate 'THE-ENVIRONMENT
- (lambda (operations environment expression)
- operations
- environment
- expression))
-
-(define-method/integrate 'QUOTATION
- (lambda (operations environment expression)
- operations
- environment
- (integrate/quotation expression)))
-\f
-(define-method/integrate 'CONDITIONAL
- (lambda (operations environment expression)
- (conditional/make
- (conditional/scode expression)
- (integrate/expression
- operations environment
- (conditional/predicate expression))
- (integrate/expression
- operations environment
- (conditional/consequent expression))
- (integrate/expression
- operations environment
- (conditional/alternative expression)))))
-
-(define-method/integrate 'DISJUNCTION
- (lambda (operations environment expression)
- (disjunction/make
- (disjunction/scode expression)
- (integrate/expression operations environment (disjunction/predicate expression))
- (integrate/expression operations environment (disjunction/alternative expression)))))
-\f
-(define-method/integrate 'SEQUENCE
- (lambda (operations environment expression)
- ;; Optimize (begin (foo)) => (foo)
- ;; Optimize (begin a b (foo) 22 (bar)) => (begin (foo) (bar))
- (sequence/optimizing-make
- expression
- (integrate/actions operations environment
- (sequence/actions expression)))))
-
-(define (integrate/actions operations environment actions)
- (let ((action (car actions)))
- (if (null? (cdr actions))
- (list (if (eq? action open-block/value-marker)
- action
- (integrate/expression operations environment action)))
- (cons (cond ((reference? action)
- ;; This clause lets you ignore a variable by
- ;; mentioning it in a sequence.
- (variable/may-ignore! (reference/variable action))
- action)
- ((eq? action open-block/value-marker)
- action)
- (else
- (integrate/expression operations environment action)))
- (integrate/actions operations environment (cdr actions))))))
-
(define (sequence/optimizing-make expression actions)
(let ((actions (remove-non-side-effecting actions)))
(if (null? (cdr actions))
(procedure? expression)
(and (access? expression)
(non-side-effecting-in-sequence? (access/environment expression)))))
-\f
-(define-method/integrate 'ACCESS
- (lambda (operations environment expression)
- (let ((environment* (integrate/expression operations environment
- (access/environment expression)))
- (name (access/name expression)))
- (cond ((and (constant/system-global-environment? environment*)
- (assq name usual-integrations/constant-alist))
- => (lambda (entry)
- (constant/make (access/scode expression)
- (constant/value (cdr entry)))))
- (else (access/make (access/scode expression)
- environment* name))))))
(define (constant/system-global-environment? expression)
(and (constant? expression)
(system-global-environment? (constant/value expression))))
-
-(define-method/integrate 'DELAY
- (lambda (operations environment expression)
- (delay/make
- (delay/scode expression)
- (integrate/expression operations environment
- (delay/expression expression)))))
-
-(define (integrate/quotation quotation)
- (call-with-values
- (lambda ()
- (integrate/top-level* (quotation/scode quotation)
- (quotation/block quotation)
- (quotation/expression quotation)))
- (lambda (operations environment expression)
- operations environment ;ignore
- expression)))
-
-(define (integrate/access-operator expression operations environment block operator operands)
- (let ((name (access/name operator))
- (environment*
- (integrate/expression operations environment (access/environment operator))))
-
- (define (dont-integrate)
- (combination/make
- expression block
- (access/make (access/scode operator) environment* name) operands))
-
- (if (not (constant/system-global-environment? environment*))
- (dont-integrate)
- (operations/lookup-global
- operations name
- (lambda (operation info)
- (case operation
- ((#F) (dont-integrate))
-
- ((EXPAND)
- (cond ((info expression operands (reference/block operator))
- => (lambda (new-expression)
- (integrate/expression operations environment new-expression)))
- (else (dont-integrate))))
-
- ((INTEGRATE INTEGRATE-OPERATOR)
- (let ((new-operator
- (reassign operator
- (copy/expression/intern block (integration-info/expression info)))))
- (integrate/combination expression operations environment block new-operator operands)))
-
- (else
- (error "unknown operation" operation))))
- dont-integrate))))
\f
;;;; Environment
(if-not))))
\f
-(define (integrate/hack-apply? operands)
- (define (check operand)
- (cond ((constant? operand)
- (if (null? (constant/value operand))
- '()
- 'FAIL))
- ((not (combination? operand))
- 'FAIL)
- (else
- (let ((rator (combination/operator operand)))
- (if (or (and (constant? rator)
- (eq? (ucode-primitive cons)
- (constant/value rator)))
- (eq? 'cons (global-ref? rator)))
- (let* ((rands (combination/operands operand))
- (next (check (cadr rands))))
- (if (eq? next 'FAIL)
- 'FAIL
- (cons (car rands) next)))
- 'FAIL)))))
-
- (and (not (null? operands))
- (let ((tail (check (car (last-pair operands)))))
- (and (not (eq? tail 'FAIL))
- (append (except-last-pair operands)
- tail)))))
-\f
-
(define (delayed-integration/in-progress? delayed-integration)
(eq? (delayed-integration/state delayed-integration) 'BEING-INTEGRATED))
projects / mit-scheme.git / commitdiff