From 1ddf8c01ec14615e5df7a568415d68f054407f59 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Mon, 9 May 2011 12:49:10 -0700 Subject: [PATCH] Fix whitespace. --- src/sf/analyze.scm | 274 ++++++------ src/sf/object.scm | 546 +++++++++++------------ src/sf/sf.pkg | 146 +++--- src/sf/subst.scm | 1050 ++++++++++++++++++++++---------------------- 4 files changed, 1008 insertions(+), 1008 deletions(-) diff --git a/src/sf/analyze.scm b/src/sf/analyze.scm index a30f1e5ac..4d809300e 100644 --- a/src/sf/analyze.scm +++ b/src/sf/analyze.scm @@ -28,7 +28,7 @@ USA. ;;; package: (scode-optimizer analyze) (declare (usual-integrations) - (integrate-external "object")) + (integrate-external "object")) ;;; EXPRESSION/ALWAYS-FALSE? @@ -52,17 +52,17 @@ USA. (define-method/always-false? 'COMBINATION (lambda (expression) (cond ((expression/call-to-not? expression) - (expression/never-false? (first (combination/operands expression)))) - ((procedure? (combination/operator expression)) - (expression/always-false? (procedure/body (combination/operator expression)))) - (else #f)))) + (expression/never-false? (first (combination/operands expression)))) + ((procedure? (combination/operator expression)) + (expression/always-false? (procedure/body (combination/operator expression)))) + (else #f)))) (define-method/always-false? 'CONDITIONAL (lambda (expression) (and (or (expression/always-false? (conditional/predicate expression)) - (expression/always-false? (conditional/consequent expression))) - (or (expression/never-false? (conditional/predicate expression)) - (expression/always-false? (conditional/alternative expression)))))) + (expression/always-false? (conditional/consequent expression))) + (or (expression/never-false? (conditional/predicate expression)) + (expression/always-false? (conditional/alternative expression)))))) (define-method/always-false? 'CONSTANT (lambda (expression) @@ -79,7 +79,7 @@ USA. (define-method/always-false? 'DISJUNCTION (lambda (expression) (and (expression/always-false? (disjunction/predicate expression)) - (expression/always-false? (disjunction/alternative expression))))) + (expression/always-false? (disjunction/alternative expression))))) (define-method/always-false? 'OPEN-BLOCK (lambda (expression) @@ -121,21 +121,21 @@ USA. (define-method/boolean? 'COMBINATION (lambda (expression) (or (expression/call-to-boolean-predicate? expression) - (and (procedure? (combination/operator expression)) - (boolean? (procedure/body (combination/operator expression))))))) + (and (procedure? (combination/operator expression)) + (boolean? (procedure/body (combination/operator expression))))))) (define-method/boolean? 'CONDITIONAL (lambda (expression) (and (or (expression/always-false? (conditional/predicate expression)) - (expression/boolean? (conditional/consequent expression))) - (or (expression/never-false? (conditional/predicate expression)) - (expression/boolean? (conditional/alternative expression)))))) + (expression/boolean? (conditional/consequent expression))) + (or (expression/never-false? (conditional/predicate expression)) + (expression/boolean? (conditional/alternative expression)))))) (define-method/boolean? 'CONSTANT (lambda (expression) ;; jrm: do not accept unspecific here. (or (not (constant/value expression)) - (eq? (constant/value expression) #t)))) + (eq? (constant/value expression) #t)))) (define-method/boolean? 'DECLARATION (lambda (expression) @@ -146,8 +146,8 @@ USA. (define-method/boolean? 'DISJUNCTION (lambda (expression) (and (expression/boolean? (disjunction/predicate expression)) - (or (expression/never-false? (disjunction/predicate expression)) - (expression/boolean? (disjunction/alternative expression)))))) + (or (expression/never-false? (disjunction/predicate expression)) + (expression/boolean? (disjunction/alternative expression)))))) (define-method/boolean? 'OPEN-BLOCK (lambda (expression) @@ -188,17 +188,17 @@ USA. (define-method/effect-free? 'COMBINATION (lambda (expression) (and (for-all? (combination/operands expression) expression/effect-free?) - (or (expression/call-to-effect-free-primitive? expression) - (and (procedure? (combination/operator expression)) - (expression/effect-free? (procedure/body (combination/operator expression)))))))) + (or (expression/call-to-effect-free-primitive? expression) + (and (procedure? (combination/operator expression)) + (expression/effect-free? (procedure/body (combination/operator expression)))))))) (define-method/effect-free? 'CONDITIONAL (lambda (expression) (and (expression/effect-free? (conditional/predicate expression)) - (or (expression/always-false? (conditional/predicate expression)) - (expression/effect-free? (conditional/consequent expression))) - (or (expression/never-false? (conditional/predicate expression)) - (expression/effect-free? (conditional/alternative expression)))))) + (or (expression/always-false? (conditional/predicate expression)) + (expression/effect-free? (conditional/consequent expression))) + (or (expression/never-false? (conditional/predicate expression)) + (expression/effect-free? (conditional/alternative expression)))))) (define-method/effect-free? 'CONSTANT true-procedure) @@ -212,8 +212,8 @@ USA. (define-method/effect-free? 'DISJUNCTION (lambda (expression) (and (expression/effect-free? (disjunction/predicate expression)) - (or (expression/never-false? (disjunction/predicate expression)) - (expression/effect-free? (disjunction/alternative expression)))))) + (or (expression/never-false? (disjunction/predicate expression)) + (expression/effect-free? (disjunction/alternative expression)))))) ;; This could be smarter and skip the assignments ;; done for the letrec, but it is easier to just @@ -247,9 +247,9 @@ USA. (define (expressions/free-variables expressions) (fold-left (lambda (answer expression) - (lset-union eq? answer (expression/free-variables expression))) - (no-free-variables) - expressions)) + (lset-union eq? answer (expression/free-variables expression))) + (no-free-variables) + expressions)) (define free-variables-dispatch-vector (expression/make-dispatch-vector)) @@ -264,25 +264,25 @@ USA. (define-method/free-variables 'ASSIGNMENT (lambda (expression) (lset-adjoin eq? - (expression/free-variables (assignment/value expression)) - (assignment/variable expression)))) + (expression/free-variables (assignment/value expression)) + (assignment/variable expression)))) (define-method/free-variables 'COMBINATION (lambda (expression) (lset-union eq? - (expression/free-variables (combination/operator expression)) - (expressions/free-variables (combination/operands expression))))) + (expression/free-variables (combination/operator expression)) + (expressions/free-variables (combination/operands expression))))) (define-method/free-variables 'CONDITIONAL (lambda (expression) (lset-union eq? - (expression/free-variables (conditional/predicate expression)) - (if (expression/always-false? (conditional/predicate expression)) - (no-free-variables) - (expression/free-variables (conditional/consequent expression))) - (if (expression/never-false? (conditional/predicate expression)) - (no-free-variables) - (expression/free-variables (conditional/alternative expression)))))) + (expression/free-variables (conditional/predicate expression)) + (if (expression/always-false? (conditional/predicate expression)) + (no-free-variables) + (expression/free-variables (conditional/consequent expression))) + (if (expression/never-false? (conditional/predicate expression)) + (no-free-variables) + (expression/free-variables (conditional/alternative expression)))))) (define-method/free-variables 'CONSTANT (lambda (expression) @@ -300,20 +300,20 @@ USA. (define-method/free-variables 'DISJUNCTION (lambda (expression) (lset-union eq? - (expression/free-variables (disjunction/predicate expression)) - (if (expression/never-false? (disjunction/predicate expression)) - (no-free-variables) - (expression/free-variables (disjunction/alternative expression)))))) + (expression/free-variables (disjunction/predicate expression)) + (if (expression/never-false? (disjunction/predicate expression)) + (no-free-variables) + (expression/free-variables (disjunction/alternative expression)))))) (define-method/free-variables 'OPEN-BLOCK (lambda (expression) (let ((omit (block/bound-variables (open-block/block expression)))) (fold-left (lambda (variables action) - (if (eq? action open-block/value-marker) - variables - (lset-union eq? variables (lset-difference eq? (expression/free-variables action) omit)))) - (lset-difference eq? (expressions/free-variables (open-block/values expression)) omit) - (open-block/actions expression))))) + (if (eq? action open-block/value-marker) + variables + (lset-union eq? variables (lset-difference eq? (expression/free-variables action) omit)))) + (lset-difference eq? (expressions/free-variables (open-block/values expression)) omit) + (open-block/actions expression))))) (define-method/free-variables 'PROCEDURE (lambda (expression) @@ -356,10 +356,10 @@ USA. (define (expressions/free-variable? expressions variable) (fold-left (lambda (answer expression) - (or answer - (expression/free-variable? expression variable))) - #f - expressions)) + (or answer + (expression/free-variable? expression variable))) + #f + expressions)) (define is-free-dispatch-vector (expression/make-dispatch-vector)) @@ -374,22 +374,22 @@ USA. (define-method/free-variable? 'ASSIGNMENT (lambda (expression variable) (or (eq? variable (assignment/variable expression)) - (expression/free-variable? (assignment/value expression) variable)))) + (expression/free-variable? (assignment/value expression) variable)))) (define-method/free-variable? 'COMBINATION (lambda (expression variable) (or (expression/free-variable? (combination/operator expression) variable) - (expressions/free-variable? (combination/operands expression) variable)))) + (expressions/free-variable? (combination/operands expression) variable)))) (define-method/free-variable? 'CONDITIONAL (lambda (expression variable) (or (expression/free-variable? (conditional/predicate expression) variable) - (cond ((expression/always-false? (conditional/predicate expression)) - (expression/free-variable? (conditional/alternative expression) variable)) - ((expression/never-false? (conditional/predicate expression)) - (expression/free-variable? (conditional/consequent expression) variable)) - ((expression/free-variable? (conditional/consequent expression) variable)) - (else (expression/free-variable? (conditional/alternative expression) variable)))))) + (cond ((expression/always-false? (conditional/predicate expression)) + (expression/free-variable? (conditional/alternative expression) variable)) + ((expression/never-false? (conditional/predicate expression)) + (expression/free-variable? (conditional/consequent expression) variable)) + ((expression/free-variable? (conditional/consequent expression) variable)) + (else (expression/free-variable? (conditional/alternative expression) variable)))))) (define-method/free-variable? 'CONSTANT false-procedure) @@ -404,19 +404,19 @@ USA. (define-method/free-variable? 'DISJUNCTION (lambda (expression variable) (or (expression/free-variable? (disjunction/predicate expression) variable) - (if (expression/never-false? (disjunction/predicate expression)) - #f - (expression/free-variable? (disjunction/alternative expression) variable))))) + (if (expression/never-false? (disjunction/predicate expression)) + #f + (expression/free-variable? (disjunction/alternative expression) variable))))) (define-method/free-variable? 'OPEN-BLOCK (lambda (expression variable) (fold-left (lambda (answer action) - (or answer - (if (eq? action open-block/value-marker) - #f - (expression/free-variable? action variable)))) - #f - (open-block/actions expression)))) + (or answer + (if (eq? action open-block/value-marker) + #f + (expression/free-variable? action variable)))) + #f + (open-block/actions expression)))) (define-method/free-variable? 'PROCEDURE (lambda (expression variable) @@ -431,12 +431,12 @@ USA. (define-method/free-variable? 'SEQUENCE (lambda (expression variable) (fold-left (lambda (answer action) - (or answer - (if (eq? action open-block/value-marker) - #f - (expression/free-variable? action variable)))) - #f - (sequence/actions expression)))) + (or answer + (if (eq? action open-block/value-marker) + #f + (expression/free-variable? action variable)))) + #f + (sequence/actions expression)))) (define-method/free-variable? 'THE-ENVIRONMENT false-procedure) @@ -456,9 +456,9 @@ USA. (define (expressions/free-variable-info expressions variable info) (fold-left (lambda (answer expression) - (expression/free-variable-info-dispatch expression variable answer)) - info - expressions)) + (expression/free-variable-info-dispatch expression variable answer)) + info + expressions)) (define free-info-dispatch-vector (expression/make-dispatch-vector)) @@ -473,16 +473,16 @@ USA. (define-method/free-variable-info 'ASSIGNMENT (lambda (expression variable info) (or (eq? variable (assignment/variable expression)) - (expression/free-variable-info-dispatch (assignment/value expression) variable info)))) + (expression/free-variable-info-dispatch (assignment/value expression) variable info)))) (define-method/free-variable-info 'COMBINATION (lambda (expression variable info) (let ((operator (combination/operator expression)) - (inner-info (expressions/free-variable-info (combination/operands expression) variable info))) + (inner-info (expressions/free-variable-info (combination/operands expression) variable info))) (if (and (reference? operator) - (eq? (reference/variable operator) variable)) - (cons (fix:1+ (car inner-info)) (cdr inner-info)) - (expression/free-variable-info-dispatch operator variable inner-info))))) + (eq? (reference/variable operator) variable)) + (cons (fix:1+ (car inner-info)) (cdr inner-info)) + (expression/free-variable-info-dispatch operator variable inner-info))))) (define-method/free-variable-info 'CONDITIONAL (lambda (expression variable info) @@ -514,11 +514,11 @@ USA. (define-method/free-variable-info 'OPEN-BLOCK (lambda (expression variable info) (fold-left (lambda (info action) - (if (eq? action open-block/value-marker) - info - (expression/free-variable-info-dispatch action variable info))) - info - (open-block/actions expression)))) + (if (eq? action open-block/value-marker) + info + (expression/free-variable-info-dispatch action variable info))) + info + (open-block/actions expression)))) (define-method/free-variable-info 'PROCEDURE (lambda (expression variable info) @@ -532,8 +532,8 @@ USA. (define-method/free-variable-info 'REFERENCE (lambda (expression variable info) (if (eq? (reference/variable expression) variable) - (cons (car info) (fix:1+ (cdr info))) - info))) + (cons (car info) (fix:1+ (cdr info))) + info))) (define-method/free-variable-info 'SEQUENCE (lambda (expression variable info) @@ -566,17 +566,17 @@ USA. (define-method/never-false? 'COMBINATION (lambda (expression) (cond ((expression/call-to-not? expression) - (expression/always-false? (first (combination/operands expression)))) - ((procedure? (combination/operator expression)) - (expression/never-false? (procedure/body (combination/operator expression)))) - (else #f)))) + (expression/always-false? (first (combination/operands expression)))) + ((procedure? (combination/operator expression)) + (expression/never-false? (procedure/body (combination/operator expression)))) + (else #f)))) (define-method/never-false? 'CONDITIONAL (lambda (expression) (and (or (expression/always-false? (conditional/predicate expression)) - (expression/never-false? (conditional/consequent expression))) - (or (expression/never-false? (conditional/predicate expression)) - (expression/never-false? (conditional/alternative expression)))))) + (expression/never-false? (conditional/consequent expression))) + (or (expression/never-false? (conditional/predicate expression)) + (expression/never-false? (conditional/alternative expression)))))) (define-method/never-false? 'CONSTANT constant/value) @@ -589,7 +589,7 @@ USA. (define-method/never-false? 'DISJUNCTION (lambda (expression) (or (expression/never-false? (disjunction/predicate expression)) - (expression/never-false? (disjunction/alternative expression))))) + (expression/never-false? (disjunction/alternative expression))))) (define-method/never-false? 'OPEN-BLOCK (lambda (expression) @@ -629,19 +629,19 @@ USA. (define-method/pure-false? 'COMBINATION (lambda (expression) (cond ((expression/call-to-not? expression) - (expression/pure-true? (first (combination/operands expression)))) - ((procedure? (combination/operator expression)) - (and (for-all? (combination/operands expression) expression/effect-free?) - (expression/pure-false? (procedure/body (combination/operator expression))))) - (else #f)))) + (expression/pure-true? (first (combination/operands expression)))) + ((procedure? (combination/operator expression)) + (and (for-all? (combination/operands expression) expression/effect-free?) + (expression/pure-false? (procedure/body (combination/operator expression))))) + (else #f)))) (define-method/pure-false? 'CONDITIONAL (lambda (expression) (and (expression/effect-free? (conditional/predicate expression)) - (or (expression/always-false? (conditional/predicate expression)) - (expression/pure-false? (conditional/consequent expression))) - (or (expression/never-false? (conditional/predicate expression)) - (expression/pure-false? (conditional/alternative expression)))))) + (or (expression/always-false? (conditional/predicate expression)) + (expression/pure-false? (conditional/consequent expression))) + (or (expression/never-false? (conditional/predicate expression)) + (expression/pure-false? (conditional/alternative expression)))))) (define-method/pure-false? 'CONSTANT (lambda (expression) @@ -657,7 +657,7 @@ USA. (define-method/pure-false? 'DISJUNCTION (lambda (expression) (and (expression/pure-false? (disjunction/predicate expression)) - (expression/pure-false? (disjunction/alternative expression))))) + (expression/pure-false? (disjunction/alternative expression))))) ;; Could be smarter (define-method/pure-false? 'OPEN-BLOCK false-procedure) @@ -671,8 +671,8 @@ USA. (define-method/pure-false? 'SEQUENCE (lambda (expression) (and (for-all? (except-last-pair (sequence/actions expression)) - expression/effect-free?) ;; unlikely - (expression/pure-false? (last (sequence/actions expression)))))) + expression/effect-free?) ;; unlikely + (expression/pure-false? (last (sequence/actions expression)))))) (define-method/pure-false? 'THE-ENVIRONMENT false-procedure) @@ -698,19 +698,19 @@ USA. (define-method/pure-true? 'COMBINATION (lambda (expression) (cond ((expression/call-to-not? expression) - (expression/pure-false? (first (combination/operands expression)))) - ((procedure? (combination/operator expression)) - (and (for-all? (combination/operands expression) expression/effect-free?) - (expression/pure-true? (procedure/body (combination/operator expression))))) - (else #f)))) + (expression/pure-false? (first (combination/operands expression)))) + ((procedure? (combination/operator expression)) + (and (for-all? (combination/operands expression) expression/effect-free?) + (expression/pure-true? (procedure/body (combination/operator expression))))) + (else #f)))) (define-method/pure-true? 'CONDITIONAL (lambda (expression) (and (expression/effect-free? (conditional/predicate expression)) - (or (expression/always-false? (conditional/predicate expression)) - (expression/pure-true? (conditional/consequent expression))) - (or (expression/never-false? (conditional/predicate expression)) - (expression/pure-true? (conditional/alternative expression)))))) + (or (expression/always-false? (conditional/predicate expression)) + (expression/pure-true? (conditional/consequent expression))) + (or (expression/never-false? (conditional/predicate expression)) + (expression/pure-true? (conditional/alternative expression)))))) (define-method/pure-true? 'CONSTANT (lambda (expression) @@ -725,8 +725,8 @@ USA. (define-method/pure-true? 'DISJUNCTION (lambda (expression) (and (expression/effect-free? (disjunction/predicate expression)) - (expression/boolean? (disjunction/predicate expression)) - (expression/pure-true? (disjunction/alternative expression))))) + (expression/boolean? (disjunction/predicate expression)) + (expression/pure-true? (disjunction/alternative expression))))) (define-method/pure-true? 'OPEN-BLOCK false-procedure) @@ -739,8 +739,8 @@ USA. (define-method/pure-true? 'SEQUENCE (lambda (expression) (and (for-all? (except-last-pair (sequence/actions expression)) - expression/effect-free?) - (expression/pure-true? (last (sequence/actions expression)))))) + expression/effect-free?) + (expression/pure-true? (last (sequence/actions expression)))))) (define-method/pure-true? 'THE-ENVIRONMENT false-procedure) @@ -771,13 +771,13 @@ USA. (define-method/size 'COMBINATION (lambda (expression) (fold-left (lambda (total operand) - (fix:+ total (expression/size operand))) - (fix:1+ (expression/size (combination/operator expression))) - (combination/operands expression)))) + (fix:+ total (expression/size operand))) + (fix:1+ (expression/size (combination/operator expression))) + (combination/operands expression)))) (define-method/size 'CONDITIONAL (lambda (expression) - (fix:+ + (fix:+ (expression/size (conditional/predicate expression)) (fix:+ (expression/size (conditional/consequent expression)) @@ -797,16 +797,16 @@ USA. (define-method/size 'DISJUNCTION (lambda (expression) (fix:+ (expression/size (disjunction/predicate expression)) - (fix:1+ (expression/size (disjunction/alternative expression)))))) + (fix:1+ (expression/size (disjunction/alternative expression)))))) (define-method/size 'OPEN-BLOCK (lambda (expression) (fold-left (lambda (total action) - (if (eq? action open-block/value-marker) - total - (fix:+ total (expression/size action)))) - 1 - (open-block/actions expression)))) + (if (eq? action open-block/value-marker) + total + (fix:+ total (expression/size action)))) + 1 + (open-block/actions expression)))) (define-method/size 'PROCEDURE (lambda (expression) @@ -824,6 +824,6 @@ USA. (define-method/size 'SEQUENCE (lambda (expression) (fold-left (lambda (total action) - (fix:+ total (expression/size action))) - 1 - (sequence/actions expression)))) + (fix:+ total (expression/size action))) + 1 + (sequence/actions expression)))) diff --git a/src/sf/object.scm b/src/sf/object.scm index 9103709ca..05c6be3dd 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -33,23 +33,23 @@ USA. (define (enumeration/make names) (let ((enumerands - (let loop ((names names) (index 0)) - (if (pair? names) - (cons (vector #f (car names) index) - (loop (cdr names) (1+ index))) - '())))) + (let loop ((names names) (index 0)) + (if (pair? names) + (cons (vector #f (car names) index) + (loop (cdr names) (1+ index))) + '())))) (let ((enumeration - (cons (list->vector enumerands) - (map (lambda (enumerand) - (cons (enumerand/name enumerand) enumerand)) - enumerands)))) + (cons (list->vector enumerands) + (map (lambda (enumerand) + (cons (enumerand/name enumerand) enumerand)) + enumerands)))) (for-each (lambda (enumerand) - (vector-set! enumerand 0 enumeration)) - enumerands) + (vector-set! enumerand 0 enumeration)) + enumerands) enumeration))) (define-structure (enumerand (type vector) - (conc-name enumerand/)) + (conc-name enumerand/)) (enumeration #f read-only #t) (name #f read-only #t) (index #f read-only #t)) @@ -62,7 +62,7 @@ USA. (define (enumeration/name->enumerand enumeration name) (cdr (or (assq name (cdr enumeration)) - (error "Unknown enumeration name:" name)))) + (error "Unknown enumeration name:" name)))) (define-integrable (enumeration/name->index enumeration name) (enumerand/index (enumeration/name->enumerand enumeration name))) @@ -71,16 +71,16 @@ USA. (sc-macro-transformer (lambda (form environment) (let ((enumeration-name (cadr form)) - (enumerand-names (caddr form))) + (enumerand-names (caddr form))) `(BEGIN - (DEFINE ,enumeration-name - (ENUMERATION/MAKE ',enumerand-names)) - ,@(map (lambda (enumerand-name) - `(DEFINE ,(symbol-append enumerand-name '/ENUMERAND) - (ENUMERATION/NAME->ENUMERAND - ,(close-syntax enumeration-name environment) - ',enumerand-name))) - enumerand-names)))))) + (DEFINE ,enumeration-name + (ENUMERATION/MAKE ',enumerand-names)) + ,@(map (lambda (enumerand-name) + `(DEFINE ,(symbol-append enumerand-name '/ENUMERAND) + (ENUMERATION/NAME->ENUMERAND + ,(close-syntax enumeration-name environment) + ',enumerand-name))) + enumerand-names)))))) (define-enumeration enumeration/random (block @@ -115,21 +115,21 @@ USA. (sc-macro-transformer (lambda (form environment) (let ((name (second form)) - (constructor-name (third form)) ;; symbol or #F - (slots (fourth form))) + (constructor-name (third form)) ;; symbol or #F + (slots (fourth form))) `(BEGIN - (DEFINE-STRUCTURE - (,name - (TYPE VECTOR) - (NAMED - ,(close-syntax (symbol-append name '/ENUMERAND) environment)) - (TYPE-DESCRIPTOR ,(symbol-append 'RTD: name)) - (CONC-NAME ,(symbol-append name '/)) - (CONSTRUCTOR ,(or constructor-name - (symbol-append name '/MAKE)))) - (scode #f read-only #t) - ,@slots) - (DEFINE-GUARANTEE ,name ,(symbol->string name))))))) + (DEFINE-STRUCTURE + (,name + (TYPE VECTOR) + (NAMED + ,(close-syntax (symbol-append name '/ENUMERAND) environment)) + (TYPE-DESCRIPTOR ,(symbol-append 'RTD: name)) + (CONC-NAME ,(symbol-append name '/)) + (CONSTRUCTOR ,(or constructor-name + (symbol-append name '/MAKE)))) + (scode #f read-only #t) + ,@slots) + (DEFINE-GUARANTEE ,name ,(symbol->string name))))))) ;;; These accessors apply to all the record types. (define-integrable (object/enumerand object) @@ -148,10 +148,10 @@ USA. ;;; BLOCK (define-structure (block (type vector) - (named block/enumerand) - (conc-name block/) - (constructor block/%make - (parent safe? bound-variables))) + (named block/enumerand) + (conc-name block/) + (constructor block/%make + (parent safe? bound-variables))) parent (children '()) safe? @@ -163,15 +163,15 @@ USA. (define (block/make parent safe? bound-variables) (let ((block (block/%make parent safe? bound-variables))) (if parent - (set-block/children! parent (cons block (block/children parent)))) + (set-block/children! parent (cons block (block/children parent)))) block)) ;;; DELAYED-INTEGRATION (define-structure (delayed-integration - (type vector) - (named delayed-integration/enumerand) - (conc-name delayed-integration/) - (constructor delayed-integration/make (operations value))) + (type vector) + (named delayed-integration/enumerand) + (conc-name delayed-integration/) + (constructor delayed-integration/make (operations value))) (state 'NOT-INTEGRATED) (environment #f) operations @@ -184,17 +184,17 @@ USA. ;; This makes debugging an awful lot easier. ;; Note that there is no SCODE slot. (define-structure (variable - (type vector) - (named variable/enumerand) - (type-descriptor rtd:variable) - (conc-name variable/) - (constructor variable/make (block name flags)) - (print-procedure - (standard-unparser-method - 'variable - (lambda (var port) - (write-string " " port) - (write (variable/name var) port))))) + (type vector) + (named variable/enumerand) + (type-descriptor rtd:variable) + (conc-name variable/) + (constructor variable/make (block name flags)) + (print-procedure + (standard-unparser-method + 'variable + (lambda (var port) + (write-string " " port) + (write (variable/name var) port))))) block name flags) @@ -221,116 +221,116 @@ USA. ;; The primitive predicates that only return #T or #F. (define primitive-boolean-predicates (map (lambda (name) - (make-primitive-procedure name #t)) + (make-primitive-procedure name #t)) '( - %RECORD? - &< - &= - &> - BIT-STRING? - CELL? - CHAR-ASCII? - CHAR? - EQ? - EQUAL-FIXNUM? - FIXNUM? - FLONUM-EQUAL? - FLONUM-GREATER? - FLONUM-LESS? - FLONUM-NEGATIVE? - FLONUM-POSITIVE? - FLONUM-ZERO? - FLONUM? - GREATER-THAN-FIXNUM? - INDEX-FIXNUM? - INTEGER-EQUAL? - INTEGER-GREATER? - INTEGER-LESS? - INTEGER-NEGATIVE? - INTEGER-POSITIVE? - INTEGER-ZERO? - LESS-THAN-FIXNUM? - NEGATIVE-FIXNUM? - NEGATIVE? - NOT - NULL? - OBJECT-TYPE? - PAIR? - POSITIVE-FIXNUM? - POSITIVE? - STRING? - VECTOR? - ZERO-FIXNUM? - ZERO? - ))) + %RECORD? + &< + &= + &> + BIT-STRING? + CELL? + CHAR-ASCII? + CHAR? + EQ? + EQUAL-FIXNUM? + FIXNUM? + FLONUM-EQUAL? + FLONUM-GREATER? + FLONUM-LESS? + FLONUM-NEGATIVE? + FLONUM-POSITIVE? + FLONUM-ZERO? + FLONUM? + GREATER-THAN-FIXNUM? + INDEX-FIXNUM? + INTEGER-EQUAL? + INTEGER-GREATER? + INTEGER-LESS? + INTEGER-NEGATIVE? + INTEGER-POSITIVE? + INTEGER-ZERO? + LESS-THAN-FIXNUM? + NEGATIVE-FIXNUM? + NEGATIVE? + NOT + NULL? + OBJECT-TYPE? + PAIR? + POSITIVE-FIXNUM? + POSITIVE? + STRING? + VECTOR? + ZERO-FIXNUM? + ZERO? + ))) ;; True if expression is a call to one of the primitive-boolean-predicates. (define (expression/call-to-boolean-predicate? expression) (and (combination? expression) (let ((operator (combination/operator expression))) - (and (constant? operator) - (let ((operator-value (constant/value operator))) - (and (memq operator-value primitive-boolean-predicates) - (procedure-arity-valid? - operator-value - (length (combination/operands expression))))))))) + (and (constant? operator) + (let ((operator-value (constant/value operator))) + (and (memq operator-value primitive-boolean-predicates) + (procedure-arity-valid? + operator-value + (length (combination/operands expression))))))))) ;; These primitives have no side effects. We consider primitives ;; that check their arguments *have* a side effect. (Conservative) (define effect-free-primitives (map (lambda (name) - (make-primitive-procedure name #t)) + (make-primitive-procedure name #t)) '( - %RECORD? - BIT-STRING? - CELL? - CHAR? - EQ? - FIXNUM? - FLONUM? - NOT - NULL? - OBJECT-TYPE - OBJECT-TYPE? - PAIR? - STRING? - VECTOR? - ))) + %RECORD? + BIT-STRING? + CELL? + CHAR? + EQ? + FIXNUM? + FLONUM? + NOT + NULL? + OBJECT-TYPE + OBJECT-TYPE? + PAIR? + STRING? + VECTOR? + ))) ;; True if expression is a call to one of the effect-free-primitives. (define (expression/call-to-effect-free-primitive? expression) (and (combination? expression) (let ((operator (combination/operator expression))) - (and (constant? operator) - (let ((operator-value (constant/value operator))) - (and (memq operator-value effect-free-primitives) - (procedure-arity-valid? - operator-value - (length (combination/operands expression))))))))) + (and (constant? operator) + (let ((operator-value (constant/value operator))) + (and (memq operator-value effect-free-primitives) + (procedure-arity-valid? + operator-value + (length (combination/operands expression))))))))) ;; True if expression is a call to NOT. ;; Used in conditional simplification. (define (expression/call-to-not? expression) (and (combination? expression) (let ((operator (combination/operator expression))) - (and (constant? operator) - (let ((operator-value (constant/value operator))) - (and (eq? operator-value (ucode-primitive not)) - (procedure-arity-valid? - operator-value - (length (combination/operands expression))))))))) + (and (constant? operator) + (let ((operator-value (constant/value operator))) + (and (eq? operator-value (ucode-primitive not)) + (procedure-arity-valid? + operator-value + (length (combination/operands expression))))))))) (define (expression/constant-eq? expression value) (cond ((constant? expression) (eq? (constant/value expression) value)) - ((declaration? expression) - (expression/constant-eq? (declaration/expression expression) value)) - (else #f))) + ((declaration? expression) + (expression/constant-eq? (declaration/expression expression) value)) + (else #f))) (define-integrable (global-ref/make name) (access/make #f - #f - (constant/make #f system-global-environment) - name)) + #f + (constant/make #f system-global-environment) + name)) (define (global-ref? object) (and (access? object) @@ -354,10 +354,10 @@ USA. (define (foldable-combination? operator operands) (and (constant? operator) (let ((operator-value (constant/value operator))) - (and (primitive-procedure? operator-value) - (procedure-arity-valid? operator-value (length operands)) - (memq operator-value combination/constant-folding-operators))) - ;; Check that the arguments are constant. + (and (primitive-procedure? operator-value) + (procedure-arity-valid? operator-value (length operands)) + (memq operator-value combination/constant-folding-operators))) + ;; Check that the arguments are constant. (for-all? operands constant?))) ;; An operator is reducable if we can safely rewrite its argument list. @@ -369,111 +369,111 @@ USA. ;; if there are declarations we don't understand, we ;; should leave things alone. (for-all? (declarations/original - (block/declarations (procedure/block operator))) - declarations/known?) + (block/declarations (procedure/block operator))) + declarations/known?) ;; Unintegrated optionals are tricky and rare. Punt. (for-all? (procedure/optional operator) variable/integrated) ;; Unintegrated rest arguments are tricky and rare. Punt. (let ((rest-arg (procedure/rest operator))) - (or (not rest-arg) (variable/integrated rest-arg))))) + (or (not rest-arg) (variable/integrated rest-arg))))) (define (combination/make expression block operator operands) (cond ((and (foldable-combination? operator operands) - (noisy-test sf:enable-constant-folding? "Fold constant")) - (combination/fold-constant expression - (constant/value operator) - (map constant/value operands))) - - ((and (reducable-operator? operator) - (noisy-test sf:enable-argument-deletion? "Delete argument")) - (call-with-values (lambda () (partition-operands operator operands)) - (lambda (new-argument-list new-operand-list other-operands) - ;; The new-argument-list has the remaining arguments - ;; after reduction. The new-operand-list is the remaining - ;; operands after reduction. The other-operands are a - ;; list of operands that must be evaluated (for effect) - ;; but whose value is discarded. - (let ((result-body - (if (or (pair? new-argument-list) - ;; need to avoid things like this - ;; (foo bar (let () (define (baz) ..) ..)) - ;; optimizing into - ;; (foo bar (define (baz) ..) ..) - (open-block? (procedure/body operator))) - (combination/%make - (and expression (object/scode expression)) - block - (procedure/make - (procedure/scode operator) - (procedure/block operator) - (procedure/name operator) - new-argument-list - '() - #f - (procedure/body operator)) - new-operand-list) - (procedure/body operator)))) - (if (null? other-operands) - result-body - (sequence/make - (and expression (object/scode expression)) - (append other-operands (list result-body)))))))) - (else - (combination/%make (and expression (object/scode expression)) block operator operands)))) + (noisy-test sf:enable-constant-folding? "Fold constant")) + (combination/fold-constant expression + (constant/value operator) + (map constant/value operands))) + + ((and (reducable-operator? operator) + (noisy-test sf:enable-argument-deletion? "Delete argument")) + (call-with-values (lambda () (partition-operands operator operands)) + (lambda (new-argument-list new-operand-list other-operands) + ;; The new-argument-list has the remaining arguments + ;; after reduction. The new-operand-list is the remaining + ;; operands after reduction. The other-operands are a + ;; list of operands that must be evaluated (for effect) + ;; but whose value is discarded. + (let ((result-body + (if (or (pair? new-argument-list) + ;; need to avoid things like this + ;; (foo bar (let () (define (baz) ..) ..)) + ;; optimizing into + ;; (foo bar (define (baz) ..) ..) + (open-block? (procedure/body operator))) + (combination/%make + (and expression (object/scode expression)) + block + (procedure/make + (procedure/scode operator) + (procedure/block operator) + (procedure/name operator) + new-argument-list + '() + #f + (procedure/body operator)) + new-operand-list) + (procedure/body operator)))) + (if (null? other-operands) + result-body + (sequence/make + (and expression (object/scode expression)) + (append other-operands (list result-body)))))))) + (else + (combination/%make (and expression (object/scode expression)) block operator operands)))) (define (combination/fold-constant expression operator operands) (let ((result (apply operator operands))) (if (not (eq? sf:enable-constant-folding? #t)) (with-notification (lambda (port) - (display "Folding (" port) - (display operator port) - (for-each (lambda (operand) (display " " port) (write operand port)) operands) - (display ") => " port) - (write result port)))) + (display "Folding (" port) + (display operator port) + (for-each (lambda (operand) (display " " port) (write operand port)) operands) + (display ") => " port) + (write result port)))) (constant/make (and expression (object/scode expression)) result))) (define-integrable (partition-operands operator operands) (let ((free-in-body (expression/free-variables (procedure/body operator)))) - (let loop ((parameters (append (procedure/required operator) - (procedure/optional operator))) - (operands operands) - (required-parameters '()) - (referenced-operands '()) - (unreferenced-operands '())) + (let loop ((parameters (append (procedure/required operator) + (procedure/optional operator))) + (operands operands) + (required-parameters '()) + (referenced-operands '()) + (unreferenced-operands '())) (cond ((null? parameters) - (if (or (procedure/rest operator) (null? operands)) - (values (reverse required-parameters) ; preserve order - (reverse referenced-operands) - (if (or (null? operands) - (variable/integrated (procedure/rest operator))) - unreferenced-operands - (append operands unreferenced-operands))) - (error "Argument mismatch" operands))) - ((null? operands) - (error "Argument mismatch" parameters)) - (else - (let ((this-parameter (car parameters)) - (this-operand (car operands))) - (cond ((memq this-parameter free-in-body) - (loop (cdr parameters) - (cdr operands) - (cons this-parameter required-parameters) - (cons this-operand referenced-operands) - unreferenced-operands)) - ((variable/integrated this-parameter) - (loop (cdr parameters) - (cdr operands) - required-parameters - referenced-operands - unreferenced-operands)) - (else - (loop (cdr parameters) - (cdr operands) - required-parameters - referenced-operands - (cons this-operand - unreferenced-operands)))))))))) + (if (or (procedure/rest operator) (null? operands)) + (values (reverse required-parameters) ; preserve order + (reverse referenced-operands) + (if (or (null? operands) + (variable/integrated (procedure/rest operator))) + unreferenced-operands + (append operands unreferenced-operands))) + (error "Argument mismatch" operands))) + ((null? operands) + (error "Argument mismatch" parameters)) + (else + (let ((this-parameter (car parameters)) + (this-operand (car operands))) + (cond ((memq this-parameter free-in-body) + (loop (cdr parameters) + (cdr operands) + (cons this-parameter required-parameters) + (cons this-operand referenced-operands) + unreferenced-operands)) + ((variable/integrated this-parameter) + (loop (cdr parameters) + (cdr operands) + required-parameters + referenced-operands + unreferenced-operands)) + (else + (loop (cdr parameters) + (cdr operands) + required-parameters + referenced-operands + (cons this-operand + unreferenced-operands)))))))))) ;;; Sequence @@ -481,38 +481,38 @@ USA. (define (sequence/make scode actions) (define (sequence/collect-actions collected actions) (fold-left (lambda (reversed action) - (if (sequence? action) - (sequence/collect-actions reversed (sequence/actions action)) - (cons action reversed))) - collected - actions)) + (if (sequence? action) + (sequence/collect-actions reversed (sequence/actions action)) + (cons action reversed))) + collected + actions)) (let ((filtered-actions - (fold-left (lambda (filtered action) - (if (expression/effect-free? action) - (if (null? filtered) - (list action) - filtered) - (cons action filtered))) - '() - (sequence/collect-actions '() actions)))) + (fold-left (lambda (filtered action) + (if (expression/effect-free? action) + (if (null? filtered) + (list action) + filtered) + (cons action filtered))) + '() + (sequence/collect-actions '() actions)))) (if (null? (cdr filtered-actions)) - (car filtered-actions) - (sequence/%make scode filtered-actions)))) + (car filtered-actions) + (sequence/%make scode filtered-actions)))) ;; Done specially so we can tweak the print method. ;; This makes debugging an awful lot easier. (define-structure (reference - (type vector) - (named reference/enumerand) - (type-descriptor rtd:reference) - (conc-name reference/) - (constructor reference/make) - (print-procedure - (standard-unparser-method - 'reference - (lambda (ref port) - (write-string " to " port) - (write (variable/name (reference/variable ref)) port))))) + (type vector) + (named reference/enumerand) + (type-descriptor rtd:reference) + (conc-name reference/) + (constructor reference/make) + (print-procedure + (standard-unparser-method + 'reference + (lambda (ref port) + (write-string " to " port) + (write (variable/name (reference/variable ref)) port))))) (scode #f read-only #t) block variable) @@ -526,16 +526,16 @@ USA. (lambda (form environment) environment (let ((name (cadr form)) - (tester (caddr form)) - (setter (cadddr form))) + (tester (caddr form)) + (setter (cadddr form))) `(BEGIN - (DEFINE (,tester VARIABLE) - (MEMQ ',name (VARIABLE/FLAGS VARIABLE))) - (DEFINE (,setter VARIABLE) - (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE))) - (SET-VARIABLE/FLAGS! - VARIABLE - (CONS ',name (VARIABLE/FLAGS VARIABLE)))))))))) + (DEFINE (,tester VARIABLE) + (MEMQ ',name (VARIABLE/FLAGS VARIABLE))) + (DEFINE (,setter VARIABLE) + (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE))) + (SET-VARIABLE/FLAGS! + VARIABLE + (CONS ',name (VARIABLE/FLAGS VARIABLE)))))))))) (define-flag SIDE-EFFECTED variable/side-effected variable/side-effect!) (define-flag REFERENCED variable/referenced variable/reference!) @@ -554,8 +554,8 @@ USA. (define (expression/make-method-definer dispatch-vector) (lambda (type-name method) (vector-set! dispatch-vector - (enumeration/name->index enumeration/expression type-name) - method))) + (enumeration/name->index enumeration/expression type-name) + method))) (define-integrable (expression/method dispatch-vector expression) (vector-ref dispatch-vector (enumerand/index (object/enumerand expression)))) @@ -563,7 +563,7 @@ USA. (define-integrable (name->method dispatch-vector name) ;; Useful for debugging (vector-ref dispatch-vector - (enumeration/name->index enumeration/expression name))) + (enumeration/name->index enumeration/expression name))) ;;; Integration Info (define integration-info-tag @@ -596,10 +596,10 @@ USA. (define (noisy-test switch text) (and switch (cond ((eq? switch 'warn) - (warn "Not performing possible action:" text) - #f) - ((not (eq? switch #t)) - (with-notification - (lambda (port) (write-string text port))) - #t) - (else #t)))) + (warn "Not performing possible action:" text) + #f) + ((not (eq? switch #t)) + (with-notification + (lambda (port) (write-string text port))) + #t) + (else #t)))) diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index 2750bce4c..2468fc75e 100644 --- a/src/sf/sf.pkg +++ b/src/sf/sf.pkg @@ -30,138 +30,138 @@ USA. (define-package (scode-optimizer) (files "pthmap" - "object" - "emodel" - "gconst" - "usicon" - "tables") + "object" + "emodel" + "gconst" + "usicon" + "tables") (parent ()) (import (runtime scode-combinator) - combination/constant-folding-operators) + combination/constant-folding-operators) (export () - sf:enable-argument-deletion? - sf:enable-constant-folding?)) + sf:enable-argument-deletion? + sf:enable-constant-folding?)) (define-package (scode-optimizer global-imports) (files "gimprt") (parent ()) (export (scode-optimizer) - scode-assignment? - scode-open-block? - scode-sequence?)) + scode-assignment? + scode-open-block? + scode-sequence?)) (define-package (scode-optimizer top-level) (files "toplev") (parent (scode-optimizer)) (export () - sf - sf/default-declarations - sf/default-syntax-table - sf/pathname-defaulting - sf/set-usual-integrations-default-deletions! - sf/top-level-definitions - sf/usual-integrations-default-deletions - sf:noisy? - syntax&integrate) + sf + sf/default-declarations + sf/default-syntax-table + sf/pathname-defaulting + sf/set-usual-integrations-default-deletions! + sf/top-level-definitions + sf/usual-integrations-default-deletions + sf:noisy? + syntax&integrate) (export (scode-optimizer) - integrate/procedure - integrate/file - integrate/sexp - integrate/scode - read-externs-file)) + integrate/procedure + integrate/file + integrate/sexp + integrate/scode + read-externs-file)) (define-package (scode-optimizer transform) (files "xform") (parent (scode-optimizer)) (export (scode-optimizer) - transform/top-level - transform/recursive)) + transform/top-level + transform/recursive)) (define-package (scode-optimizer integrate) (files "subst") (parent (scode-optimizer)) (export () - sf:display-top-level-procedure-names? - sf:enable-conditional-folding? - sf:enable-disjunction-folding? - sf:enable-elide-double-negatives? - sf:enable-safe-integration?) + sf:display-top-level-procedure-names? + sf:enable-conditional-folding? + sf:enable-disjunction-folding? + sf:enable-elide-double-negatives? + sf:enable-safe-integration?) (export (scode-optimizer) - integrate/top-level - integrate/get-top-level-block - reassign - variable/final-value)) + integrate/top-level + integrate/get-top-level-block + reassign + variable/final-value)) (define-package (scode-optimizer cgen) (files "cgen") (parent (scode-optimizer)) (export (scode-optimizer) - *sf-associate* - cgen/external - pp-expression) + *sf-associate* + cgen/external + pp-expression) (export (scode-optimizer expansion) - cgen/external-with-declarations)) + cgen/external-with-declarations)) (define-package (scode-optimizer expansion) (files "usiexp" "reduct") (parent (scode-optimizer)) (export (scode-optimizer) - reducer/make - replacement/make - usual-integrations/expansion-names - usual-integrations/expansion-values - usual-integrations/expansion-alist) + reducer/make + replacement/make + usual-integrations/expansion-names + usual-integrations/expansion-values + usual-integrations/expansion-alist) (export (scode-optimizer declarations) - expander-evaluation-environment)) + expander-evaluation-environment)) (define-package (scode-optimizer declarations) (files "pardec") (parent (scode-optimizer)) (export (scode-optimizer) - declarations/bind - declarations/known? - declarations/make-null - declarations/map - declarations/original - declarations/parse - guarantee-known-declaration - operations->external)) + declarations/bind + declarations/known? + declarations/make-null + declarations/map + declarations/original + declarations/parse + guarantee-known-declaration + operations->external)) (define-package (scode-optimizer copy) (files "copy") (parent (scode-optimizer)) (export (scode-optimizer) - copy/expression/intern - copy/expression/extern)) + copy/expression/intern + copy/expression/extern)) (define-package (scode-optimizer analyze) (files "analyze") (parent (scode-optimizer)) (export (scode-optimizer) - expression/always-false? - expression/boolean? - expression/effect-free? - expression/free-variable? - expression/free-variable-info - expression/free-variables - expression/never-false? - expression/pure-false? - expression/pure-true? - expression/size)) + expression/always-false? + expression/boolean? + expression/effect-free? + expression/free-variable? + expression/free-variable-info + expression/free-variables + expression/never-false? + expression/pure-false? + expression/pure-true? + expression/size)) (define-package (scode-optimizer change-type) (files "chtype") (parent (scode-optimizer)) (export (scode-optimizer) - change-type/block - change-type/expression)) + change-type/block + change-type/expression)) (define-package (scode-optimizer build-utilities) (files "butils") (parent ()) (export () - compile-directory - compile-directory? - sf-conditionally - sf-directory - sf-directory?)) \ No newline at end of file + compile-directory + compile-directory? + sf-conditionally + sf-directory + sf-directory?)) \ No newline at end of file diff --git a/src/sf/subst.scm b/src/sf/subst.scm index e0236d4da..2233e8549 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -28,7 +28,7 @@ USA. ;;; package: (scode-optimizer integrate) (declare (usual-integrations) - (integrate-external "object")) + (integrate-external "object")) (define *top-level-block*) @@ -41,52 +41,52 @@ USA. (define (ignored-variable-warning name) (warn (string-append "Variable \"" - (symbol->string name) - "\" was declared IGNORE, but used anyway.") - name *current-block-names*)) + (symbol->string name) + "\" was declared IGNORE, but used anyway.") + name *current-block-names*)) (define (integrate/top-level block expression) (integrate/top-level* (object/scode expression) block expression)) (define (integrate/top-level* scode block expression) (fluid-let ((*top-level-block* block) - (*current-block-names* '())) + (*current-block-names* '())) (call-with-values - (lambda () - (let ((operations (operations/make)) - (environment (environment/make))) - (if (open-block? expression) - (integrate/open-block operations environment expression) - (let ((operations - (declarations/bind operations - (block/declarations block)))) - (values operations - environment - (integrate/expression operations - environment - expression)))))) + (lambda () + (let ((operations (operations/make)) + (environment (environment/make))) + (if (open-block? expression) + (integrate/open-block operations environment expression) + (let ((operations + (declarations/bind operations + (block/declarations block)))) + (values operations + environment + (integrate/expression operations + environment + expression)))))) (lambda (operations environment expression) (values operations environment - (quotation/make scode - block - expression)))))) + (quotation/make scode + block + expression)))))) (define (integrate/expressions operations environment expressions) (map (lambda (expression) - (integrate/expression operations environment expression)) + (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 ((eq? action open-block/value-marker) - action) - (else - (integrate/expression operations environment action))) - (integrate/actions operations environment (cdr actions)))))) + (list (if (eq? action open-block/value-marker) + action + (integrate/expression operations environment action))) + (cons (cond ((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) @@ -102,34 +102,34 @@ USA. (define-method/integrate 'ACCESS (lambda (operations environment expression) (let ((environment* (integrate/expression operations environment - (access/environment expression))) - (name (access/name expression))) + (access/environment expression))) + (name (access/name expression))) (define (dont-integrate) - (access/make (access/scode expression) - (access/block expression) - environment* name)) + (access/make (access/scode expression) + (access/block expression) + environment* name)) (if (not (constant/system-global-environment? environment*)) - (dont-integrate) - (operations/lookup-global - operations name - (lambda (operation info) - (case operation - ((#F EXPAND INTEGRATE-OPERATOR) (dont-integrate)) - - ((IGNORE) - (ignored-variable-warning name) - (dont-integrate)) - - ((INTEGRATE) - (reassign name (copy/expression/intern - (access/block expression) - (integration-info/expression info)))) - - (else - (error "Unknown operation" operation)))) - dont-integrate))))) + (dont-integrate) + (operations/lookup-global + operations name + (lambda (operation info) + (case operation + ((#F EXPAND INTEGRATE-OPERATOR) (dont-integrate)) + + ((IGNORE) + (ignored-variable-warning name) + (dont-integrate)) + + ((INTEGRATE) + (reassign name (copy/expression/intern + (access/block expression) + (integration-info/expression info)))) + + (else + (error "Unknown operation" operation)))) + dont-integrate))))) ;;;; ASSIGNMENT (define-method/integrate 'ASSIGNMENT @@ -137,23 +137,23 @@ USA. (let ((variable (assignment/variable assignment))) (operations/lookup operations variable (lambda (operation info) - info ;ignore - (case operation - ((IGNORE) - (ignored-variable-warning (variable/name variable))) - ((EXPAND INTEGRATE INTEGRATE-OPERATOR) - (warn "Attempt to assign integrated name" - (variable/name variable))) - (else (error "Unknown operation" operation)))) + info ;ignore + (case operation + ((IGNORE) + (ignored-variable-warning (variable/name variable))) + ((EXPAND INTEGRATE INTEGRATE-OPERATOR) + (warn "Attempt to assign integrated name" + (variable/name variable))) + (else (error "Unknown operation" operation)))) false-procedure) (variable/reference! variable) (assignment/make (assignment/scode assignment) - (assignment/block assignment) - variable - (integrate/expression operations - environment - (assignment/value assignment)))))) + (assignment/block assignment) + variable + (integrate/expression operations + environment + (assignment/value assignment)))))) ;;;; COMBINATION (define-method/integrate 'COMBINATION @@ -163,63 +163,63 @@ USA. (combination/block combination) (combination/operator combination) (integrate/expressions operations - environment - (combination/operands combination))))) + environment + (combination/operands combination))))) ;;;; CONDITIONAL (define-method/integrate 'CONDITIONAL (lambda (operations environment expression) (integrate/conditional operations environment expression - (integrate/expression - operations environment - (conditional/predicate expression)) - (conditional/consequent expression) - (conditional/alternative expression)))) + (integrate/expression + operations environment + (conditional/predicate expression)) + (conditional/consequent expression) + (conditional/alternative expression)))) (define sf:enable-conditional-folding? #t) (define (integrate/conditional operations environment expression - integrated-predicate - consequent - alternative) + integrated-predicate + consequent + alternative) (cond ((expression/call-to-not? integrated-predicate) - ;; (if (not ) ) => (if ) - (integrate/conditional - operations environment expression - (first (combination/operands integrated-predicate)) - alternative consequent)) - - ((sequence? integrated-predicate) - (sequence/make - (and expression (object/scode expression)) - (append (except-last-pair (sequence/actions integrated-predicate)) - (list (integrate/conditional - operations environment #f - (last (sequence/actions integrated-predicate)) - consequent - alternative))))) - - ((and (expression/never-false? integrated-predicate) - (noisy-test sf:enable-conditional-folding? - "Fold constant true conditional")) - (sequence/make - (and expression (conditional/scode expression)) - (list integrated-predicate - (integrate/expression operations environment consequent)))) - - ((and (expression/always-false? integrated-predicate) - (noisy-test sf:enable-conditional-folding? - "Fold constant false conditional")) - (sequence/make - (and expression (conditional/scode expression)) - (list integrated-predicate - (integrate/expression operations environment alternative)))) - - (else - (conditional/make (and expression (conditional/scode expression)) - integrated-predicate - (integrate/expression operations environment consequent) - (integrate/expression operations environment alternative))))) + ;; (if (not ) ) => (if ) + (integrate/conditional + operations environment expression + (first (combination/operands integrated-predicate)) + alternative consequent)) + + ((sequence? integrated-predicate) + (sequence/make + (and expression (object/scode expression)) + (append (except-last-pair (sequence/actions integrated-predicate)) + (list (integrate/conditional + operations environment #f + (last (sequence/actions integrated-predicate)) + consequent + alternative))))) + + ((and (expression/never-false? integrated-predicate) + (noisy-test sf:enable-conditional-folding? + "Fold constant true conditional")) + (sequence/make + (and expression (conditional/scode expression)) + (list integrated-predicate + (integrate/expression operations environment consequent)))) + + ((and (expression/always-false? integrated-predicate) + (noisy-test sf:enable-conditional-folding? + "Fold constant false conditional")) + (sequence/make + (and expression (conditional/scode expression)) + (list integrated-predicate + (integrate/expression operations environment alternative)))) + + (else + (conditional/make (and expression (conditional/scode expression)) + integrated-predicate + (integrate/expression operations environment consequent) + (integrate/expression operations environment alternative))))) ;;; CONSTANT (define-method/integrate 'CONSTANT @@ -231,16 +231,16 @@ USA. (define-method/integrate 'DECLARATION (lambda (operations environment declaration) (let ((answer - (integrate/expression - (declarations/bind operations - (declaration/declarations declaration)) - environment (declaration/expression declaration)))) + (integrate/expression + (declarations/bind operations + (declaration/declarations declaration)) + environment (declaration/expression declaration)))) (if (constant? answer) - answer - (declaration/make - (declaration/scode declaration) - (declaration/declarations declaration) - answer))))) + answer + (declaration/make + (declaration/scode declaration) + (declaration/declarations declaration) + answer))))) ;;; DELAY (define-method/integrate 'DELAY @@ -248,7 +248,7 @@ USA. (delay/make (delay/scode expression) (integrate/expression operations environment - (delay/expression expression))))) + (delay/expression expression))))) ;;; DISJUNCTION @@ -263,62 +263,62 @@ USA. (define sf:enable-disjunction-folding? #t) (define (integrate/disjunction operations environment expression - integrated-predicate alternative) + integrated-predicate alternative) (cond ((expression/call-to-not? integrated-predicate) - ;; (or (not e1) e2) => (if e1 e2 #t) - (integrate/conditional - operations environment expression - (first (combination/operands integrated-predicate)) - alternative - (constant/make #f #t))) - - ((and (expression/never-false? integrated-predicate) - (noisy-test sf:enable-disjunction-folding? - "Fold constant true disjunction")) - ;; (or ) => if is never false - integrated-predicate) - - ((and (expression/always-false? integrated-predicate) - (noisy-test sf:enable-disjunction-folding? - "Fold constant false disjunction")) - ;; (or ) - ;; => (begin ) if is always false - (sequence/make (and expression (object/scode expression)) - (list integrated-predicate - (integrate/expression - operations environment alternative)))) - - ((sequence? integrated-predicate) - (sequence/make - (and expression (object/scode expression)) - (append (except-last-pair (sequence/actions integrated-predicate)) - (list (integrate/disjunction - operations environment #f - (last (sequence/actions integrated-predicate)) - alternative))))) - - (else - (disjunction/make (and expression (object/scode expression)) - integrated-predicate - (integrate/expression - operations - environment alternative))))) + ;; (or (not e1) e2) => (if e1 e2 #t) + (integrate/conditional + operations environment expression + (first (combination/operands integrated-predicate)) + alternative + (constant/make #f #t))) + + ((and (expression/never-false? integrated-predicate) + (noisy-test sf:enable-disjunction-folding? + "Fold constant true disjunction")) + ;; (or ) => if is never false + integrated-predicate) + + ((and (expression/always-false? integrated-predicate) + (noisy-test sf:enable-disjunction-folding? + "Fold constant false disjunction")) + ;; (or ) + ;; => (begin ) if is always false + (sequence/make (and expression (object/scode expression)) + (list integrated-predicate + (integrate/expression + operations environment alternative)))) + + ((sequence? integrated-predicate) + (sequence/make + (and expression (object/scode expression)) + (append (except-last-pair (sequence/actions integrated-predicate)) + (list (integrate/disjunction + operations environment #f + (last (sequence/actions integrated-predicate)) + alternative))))) + + (else + (disjunction/make (and expression (object/scode expression)) + integrated-predicate + (integrate/expression + operations + environment alternative))))) ;;; OPEN-BLOCK (define-method/integrate 'OPEN-BLOCK (lambda (operations environment expression) (call-with-values - (lambda () (integrate/open-block operations environment expression)) + (lambda () (integrate/open-block operations environment expression)) (lambda (operations environment expression) - (declare (ignore 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))) + (simulate-unknown-application environment procedure) + procedure))) ;;;; Quotation (define-method/integrate 'QUOTATION @@ -329,11 +329,11 @@ USA. (define (integrate/quotation quotation) (call-with-values (lambda () - (integrate/top-level* (quotation/scode quotation) - (quotation/block quotation) - (quotation/expression quotation))) + (integrate/top-level* (quotation/scode quotation) + (quotation/block quotation) + (quotation/expression quotation))) (lambda (operations environment expression) - operations environment ;ignore + operations environment ;ignore expression))) ;;;; Reference @@ -341,30 +341,30 @@ USA. (lambda (operations environment expression) (let ((variable (reference/variable expression))) (define (dont-integrate) - (variable/reference! variable) - expression) + (variable/reference! variable) + expression) (operations/lookup operations variable (lambda (operation info) - (case operation - ((IGNORE) - (ignored-variable-warning (variable/name variable)) - (dont-integrate)) + (case operation + ((IGNORE) + (ignored-variable-warning (variable/name variable)) + (dont-integrate)) - ((EXPAND INTEGRATE-OPERATOR) - (dont-integrate)) + ((EXPAND INTEGRATE-OPERATOR) + (dont-integrate)) - ((INTEGRATE) - (let ((new-expression - (integrate/name expression expression info environment))) - (if new-expression - (begin (variable/integrated! variable) - new-expression) - (dont-integrate)))) + ((INTEGRATE) + (let ((new-expression + (integrate/name expression expression info environment))) + (if new-expression + (begin (variable/integrated! variable) + new-expression) + (dont-integrate)))) - (else - (error "Unknown operation" operation)))) + (else + (error "Unknown operation" operation)))) dont-integrate)))) @@ -379,7 +379,7 @@ USA. (sequence/make (and expression (object/scode expression)) (integrate/actions operations environment - (sequence/actions expression))))) + (sequence/actions expression))))) ;;; THE-ENVIRONMENT (define-method/integrate 'THE-ENVIRONMENT @@ -397,47 +397,47 @@ USA. (define (maybe-displaying-name name thunk) (if (and sf:display-top-level-procedure-names? - (null? *current-block-names*)) + (null? *current-block-names*)) (with-notification (lambda (port) - (write-string "Integrating procedure " port) - (write name 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 (open-block/block expression))) (let ((operations - (declarations/bind (operations/shadow operations variables) - (block/declarations block)))) + (declarations/bind (operations/shadow operations variables) + (block/declarations block)))) (call-with-values - (lambda () - (environment/recursive-bind operations - environment - variables - (open-block/values expression))) - (lambda (environment vals) - (let ((actions - (integrate/actions operations - environment - (open-block/actions expression)))) - ;; Complain about unreferenced variables. - ;; If the block is unsafe, then it is likely that - ;; there will be a lot of them on purpose (top level or - ;; the-environment) so no complaining. - (if (block/safe? (open-block/block expression)) - (for-each (lambda (variable) - (if (variable/unreferenced? variable) - (warn "Unreferenced defined variable:" - (variable/name variable)))) - variables)) - (values operations - environment - (open-block/make - (and expression (object/scode expression)) - block variables - vals actions)))))))) + (lambda () + (environment/recursive-bind operations + environment + variables + (open-block/values expression))) + (lambda (environment vals) + (let ((actions + (integrate/actions operations + environment + (open-block/actions expression)))) + ;; Complain about unreferenced variables. + ;; If the block is unsafe, then it is likely that + ;; there will be a lot of them on purpose (top level or + ;; the-environment) so no complaining. + (if (block/safe? (open-block/block expression)) + (for-each (lambda (variable) + (if (variable/unreferenced? variable) + (warn "Unreferenced defined variable:" + (variable/name variable)))) + variables)) + (values operations + environment + (open-block/make + (and expression (object/scode expression)) + block variables + vals actions)))))))) (define (variable/unreferenced? variable) (and (not (variable/integrated variable)) @@ -453,55 +453,55 @@ USA. (define (integrate/procedure operations environment procedure) (let ((block (procedure/block procedure)) - (name (procedure/name procedure)) - (required (procedure/required procedure)) - (optional (procedure/optional procedure)) - (rest (procedure/rest procedure))) + (name (procedure/name procedure)) + (required (procedure/required procedure)) + (optional (procedure/optional procedure)) + (rest (procedure/rest procedure))) (maybe-displaying-name name (lambda () (fluid-let ((*current-block-names* (cons name *current-block-names*))) - (let* ((operations (declarations/bind - (operations/shadow - operations - (append required optional (if rest (list rest) '()))) - (block/declarations block))) - - (body (integrate/expression - (if (block/safe? block) - (make-additional-declarations - operations environment - (procedure/body procedure) - (block/bound-variables block)) - operations) - environment - (procedure/body procedure)))) - ;; Possibly complain about variables bound and not - ;; referenced. - (if (block/safe? block) - (for-each (lambda (variable) - (if (variable/unreferenced? variable) - (warn "Unreferenced bound variable:" - (variable/name variable) - *current-block-names*))) - (if rest - (append required optional (list rest)) - (append required optional)))) - (procedure/make (procedure/scode procedure) - block - name - required - optional - rest - body))))))) + (let* ((operations (declarations/bind + (operations/shadow + operations + (append required optional (if rest (list rest) '()))) + (block/declarations block))) + + (body (integrate/expression + (if (block/safe? block) + (make-additional-declarations + operations environment + (procedure/body procedure) + (block/bound-variables block)) + operations) + environment + (procedure/body procedure)))) + ;; Possibly complain about variables bound and not + ;; referenced. + (if (block/safe? block) + (for-each (lambda (variable) + (if (variable/unreferenced? variable) + (warn "Unreferenced bound variable:" + (variable/name variable) + *current-block-names*))) + (if rest + (append required optional (list rest)) + (append required optional)))) + (procedure/make (procedure/scode procedure) + block + name + required + optional + rest + body))))))) (define sf:enable-safe-integration? #t) (define (make-additional-declarations operations environment body variables) (fold-left (lambda (operations variable) - (make-additional-declaration operations environment body variable)) - operations - variables)) + (make-additional-declaration operations environment body variable)) + operations + variables)) (define (make-additional-declaration operations environment body variable) ;; Possibly augment operations with an appropriate declaration. @@ -513,40 +513,40 @@ USA. ;; Already a declaration, don't override it. (constant-procedure operations) (lambda () - ;; No operations on this variable, check if it has - ;; a value - (environment/lookup - environment variable - (lambda (value) - ;; it has a value, see if we should integrate it - (make-additional-declaration-with-value operations body variable value)) - ;; No value - (constant-procedure operations) - ;; No binding - (constant-procedure operations)))))) + ;; No operations on this variable, check if it has + ;; a value + (environment/lookup + environment variable + (lambda (value) + ;; it has a value, see if we should integrate it + (make-additional-declaration-with-value operations body variable value)) + ;; No value + (constant-procedure operations) + ;; No binding + (constant-procedure operations)))))) (define (make-additional-declaration-with-value operations body variable value) (cond ((and (or (and (access? value) (global-ref? value)) - (constant? value) - (and (reference? value) - (not (variable/side-effected (reference/variable value))) - (block/safe? (variable/block (reference/variable value))))) - (noisy-test sf:enable-safe-integration? "Safe declarations")) - (operations/bind operations 'INTEGRATE variable - (make-integration-info value))) - ((procedure? value) - (let ((info (expression/free-variable-info body variable))) - ;; Avoid exponential code explosion. - ;; The *parser code gets out of control if you don't limit this. - (if (and (fix:zero? (cdr info)) ; No argument references - (or (fix:= (car info) 1) ; Exactly one operator use - (and (fix:> (car info) 1) - (< (* (expression/size value) (car info)) 500))) - (noisy-test sf:enable-safe-integration? "Safe declarations")) - (operations/bind operations 'INTEGRATE-OPERATOR variable - (make-integration-info value)) - operations))) - (else operations))) + (constant? value) + (and (reference? value) + (not (variable/side-effected (reference/variable value))) + (block/safe? (variable/block (reference/variable value))))) + (noisy-test sf:enable-safe-integration? "Safe declarations")) + (operations/bind operations 'INTEGRATE variable + (make-integration-info value))) + ((procedure? value) + (let ((info (expression/free-variable-info body variable))) + ;; Avoid exponential code explosion. + ;; The *parser code gets out of control if you don't limit this. + (if (and (fix:zero? (cdr info)) ; No argument references + (or (fix:= (car info) 1) ; Exactly one operator use + (and (fix:> (car info) 1) + (< (* (expression/size value) (car info)) 500))) + (noisy-test sf:enable-safe-integration? "Safe declarations")) + (operations/bind operations 'INTEGRATE-OPERATOR variable + (make-integration-info value)) + operations))) + (else operations))) ;;; INTEGRATE-COMBINATION @@ -557,7 +557,7 @@ USA. (expression/make-method-definer integrate-combination-dispatch-vector)) (define (integrate/combination expression operations environment - block operator operands) + block operator operands) ((expression/method integrate-combination-dispatch-vector operator) expression operations environment block operator operands)) @@ -565,47 +565,47 @@ USA. (define-method/integrate-combination 'ACCESS (lambda (expression operations environment block operator operands) (integrate/access-operator expression operations environment - block operator operands))) + 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)))) + (environment* + (integrate/expression operations environment (access/environment operator)))) (define (dont-integrate) (combination/make expression block (access/make (access/scode operator) - (access/block operator) - environment* name) operands)) + (access/block 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)))) - - ((IGNORE) - (ignored-variable-warning (variable/name name)) - (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)))) + (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)))) + + ((IGNORE) + (ignored-variable-warning (variable/name name)) + (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 @@ -614,9 +614,9 @@ USA. ;; 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))) + block + (integrate/expression operations environment operator) + operands))) ;;; combination-operator (define-method/integrate-combination 'COMBINATION @@ -635,31 +635,31 @@ USA. (lambda (expression operations environment block operator operands) ;; Elide a double negative only if it doesn't change the type of the answer. (cond ((and (expression/constant-eq? operator (ucode-primitive not)) - (length=? operands 1) - (expression/call-to-not? (first operands)) - (expression/boolean? - (first (combination/operands (first operands)))) - (noisy-test sf:enable-elide-double-negatives? - "Elide double negative")) - (first (combination/operands (first operands)))) - - ((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 - (warn "Application of constant value" (constant/value operator)) - (integrate-combination/default expression operations environment - block operator operands))))) + (length=? operands 1) + (expression/call-to-not? (first operands)) + (expression/boolean? + (first (combination/operands (first operands)))) + (noisy-test sf:enable-elide-double-negatives? + "Elide double negative")) + (first (combination/operands (first operands)))) + + ((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 + (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) + block operator operands) (declare (ignore operations environment)) (combination/make expression block operator operands)) @@ -674,15 +674,15 @@ USA. ;; 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))) + 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))) + block operator operands))) ;;; open-block-operator (define-method/integrate-combination 'OPEN-BLOCK @@ -695,136 +695,136 @@ USA. (define-method/integrate-combination 'PROCEDURE (lambda (expression operations environment block operator operands) (integrate-combination/default expression operations environment - block operator operands))) + block operator operands))) (define (integrate/procedure-operator operations environment - block procedure operands) + block procedure operands) (integrate/procedure operations - (simulate-application environment block - procedure operands) - procedure)) + (simulate-application environment block + procedure operands) + procedure)) ;;; quotation-operator (define-method/integrate-combination 'QUOTATION (lambda (expression operations environment block operator operands) - (integrate-combination/default 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))) + block operator operands))) (define (integrate/reference-operator expression operations environment - block operator operands) + 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)))) + (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)))) - - ((IGNORE) - (ignored-variable-warning (variable/name variable)) - (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)))))) + (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)))) + + ((IGNORE) + (ignored-variable-warning (variable/name variable)) + (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))) + 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))) + (integrate/expression operations environment operator) + operands))) (define (integrate-combination/default expression operations environment - block operator operands) + 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))))) + (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))) + => 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))))) + (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))))) + (and (not (eq? tail 'FAIL)) + (append (except-last-pair operands) + tail))))) ;;; ((let ((a (foo)) (b (bar))) @@ -873,56 +873,56 @@ USA. (define (integrate/compound-operator operator operands) (define (scan-body body encloser) (if (procedure? body) - (and (not (open-block? (procedure/body body))) - (procedure-with-body body (encloser (procedure/body body)))) - (scan-operator body encloser))) + (and (not (open-block? (procedure/body body))) + (procedure-with-body body (encloser (procedure/body body)))) + (scan-operator body encloser))) (define (scan-operator operator encloser) (cond ((sequence? operator) - (let ((reversed-actions (reverse (sequence/actions operator)))) - (scan-body (car reversed-actions) - (let ((commands (cdr reversed-actions))) - (lambda (expression) - (encloser - (sequence-with-actions - operator - (reverse (cons expression commands))))))))) - ((combination? operator) - (let ((descend - (lambda (operator*) - (and (not (open-block? (procedure/body operator*))) - (scan-body - (procedure/body operator*) - (lambda (body*) - (encloser - (combination-with-operator - operator - (procedure-with-body operator* body*)))))))) - (operator* (combination/operator operator))) - (cond ((procedure? operator*) (descend operator*)) - ((integrate/compound-operator - operator* - (combination/operands operator)) - => descend) - (else #f)))) - ((declaration? operator) - (scan-body (declaration/expression operator) - (lambda (expression) - (encloser - (declaration-with-expression operator expression))))) - (else #f))) + (let ((reversed-actions (reverse (sequence/actions operator)))) + (scan-body (car reversed-actions) + (let ((commands (cdr reversed-actions))) + (lambda (expression) + (encloser + (sequence-with-actions + operator + (reverse (cons expression commands))))))))) + ((combination? operator) + (let ((descend + (lambda (operator*) + (and (not (open-block? (procedure/body operator*))) + (scan-body + (procedure/body operator*) + (lambda (body*) + (encloser + (combination-with-operator + operator + (procedure-with-body operator* body*)))))))) + (operator* (combination/operator operator))) + (cond ((procedure? operator*) (descend operator*)) + ((integrate/compound-operator + operator* + (combination/operands operator)) + => descend) + (else #f)))) + ((declaration? operator) + (scan-body (declaration/expression operator) + (lambda (expression) + (encloser + (declaration-with-expression operator expression))))) + (else #f))) (and (for-all? operands expression/effect-free?) (scan-operator operator (lambda (body) body)))) (define (combination-with-operator combination operator) (combination/make combination - (combination/block combination) - operator - (combination/operands combination))) + (combination/block combination) + operator + (combination/operands combination))) (define (declaration-with-expression declaration expression) (declaration/make (declaration/scode declaration) - (declaration/declarations declaration) - expression)) + (declaration/declarations declaration) + expression)) ;;; Replacing the body may cause variables from outside the original ;;; body to be shadowed, so we use a sleazy stupid hack to work around @@ -935,12 +935,12 @@ USA. (for-each hackify-variable (procedure/optional procedure)) (cond ((procedure/rest procedure) => hackify-variable)) (procedure/make (procedure/scode procedure) - (procedure/block procedure) - (procedure/name procedure) - (procedure/required procedure) - (procedure/optional procedure) - (procedure/rest procedure) - body)) + (procedure/block procedure) + (procedure/name procedure) + (procedure/required procedure) + (procedure/optional procedure) + (procedure/rest procedure) + body)) (define (hackify-variable variable) (set-variable/name! @@ -961,43 +961,43 @@ USA. ;; integrate one another. When circularities are detected within ;; the definition-reference graph, integration is disabled. (let ((vals - (map (lambda (value) - (delayed-integration/make operations value)) - vals))) + (map (lambda (value) + (delayed-integration/make operations value)) + vals))) (let ((environment - (environment/bind-multiple environment variables vals))) + (environment/bind-multiple environment variables vals))) (for-each (lambda (value) - (set-delayed-integration/environment! value environment)) - vals) + (set-delayed-integration/environment! value environment)) + vals) (values environment (map delayed-integration/force vals))))) (define (integrate/name expr reference info environment) (let ((variable (reference/variable reference))) (let ((finish - (lambda (value) - (reassign - expr - (copy/expression/intern (reference/block reference) value))))) + (lambda (value) + (reassign + expr + (copy/expression/intern (reference/block reference) value))))) (if info - (finish (integration-info/expression info)) - (environment/lookup environment variable - (lambda (value) - (if (delayed-integration? value) - (if (delayed-integration/in-progress? value) - #f - (finish (delayed-integration/force value))) - (finish value))) - false-procedure - false-procedure))))) + (finish (integration-info/expression info)) + (environment/lookup environment variable + (lambda (value) + (if (delayed-integration? value) + (if (delayed-integration/in-progress? value) + #f + (finish (delayed-integration/force value))) + (finish value))) + false-procedure + false-procedure))))) (define (variable/final-value variable environment if-value if-not) (environment/lookup environment variable (lambda (value) (if (delayed-integration? value) - (if (delayed-integration/in-progress? value) - (error "Unfinished integration" value) - (if-value (delayed-integration/force value))) - (if-value value))) + (if (delayed-integration/in-progress? value) + (error "Unfinished integration" value) + (if-value (delayed-integration/force value))) + (if-value value))) (lambda () (if-not)) (lambda () @@ -1012,24 +1012,24 @@ USA. (case (delayed-integration/state delayed-integration) ((NOT-INTEGRATED) (let ((value - (let ((environment - (delayed-integration/environment delayed-integration)) - (operations - (delayed-integration/operations delayed-integration)) - (expression (delayed-integration/value delayed-integration))) - (set-delayed-integration/state! delayed-integration - 'BEING-INTEGRATED) - (set-delayed-integration/environment! delayed-integration #f) - (set-delayed-integration/operations! delayed-integration #f) - (set-delayed-integration/value! delayed-integration #f) - (integrate/expression operations environment expression)))) + (let ((environment + (delayed-integration/environment delayed-integration)) + (operations + (delayed-integration/operations delayed-integration)) + (expression (delayed-integration/value delayed-integration))) + (set-delayed-integration/state! delayed-integration + 'BEING-INTEGRATED) + (set-delayed-integration/environment! delayed-integration #f) + (set-delayed-integration/operations! delayed-integration #f) + (set-delayed-integration/value! delayed-integration #f) + (integrate/expression operations environment expression)))) (set-delayed-integration/state! delayed-integration 'INTEGRATED) (set-delayed-integration/value! delayed-integration value))) ((INTEGRATED) 'DONE) ((BEING-INTEGRATED) (error "Attempt to re-force delayed integration" - delayed-integration)) + delayed-integration)) (else (error "Delayed integration has unknown state" - delayed-integration))) + delayed-integration))) (delayed-integration/value delayed-integration)) \ No newline at end of file -- 2.25.1