#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.5 1987/05/09 00:50:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.6 1987/07/08 04:35:44 jinx Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
(fluid-let ((root-block block)
(copy/variable/free copy/variable/free/intern)
(copy/declarations copy/declarations/intern))
- (copy/expression root-block
- (environment/rebind block (environment/make) uninterned)
- expression)))
+ (let ((environment (environment/rebind block (environment/make) uninterned)))
+ (copy/expression root-block
+ environment
+ expression))))
(define (copy/external/extern expression)
(fluid-let ((root-block (block/make false false))
(copy/variable/free copy/variable/free/extern)
(copy/declarations copy/declarations/extern))
- (let ((expression
- (copy/expression root-block (environment/make) expression)))
- (return-2 root-block expression))))
+ (let ((environment (environment/make)))
+ (let ((expression
+ (copy/expression root-block environment expression)))
+ (return-2 root-block expression)))))
(define (copy/expressions block environment expressions)
(map (lambda (expression)
(define (copy/quotation quotation)
(fluid-let ((root-block false))
- (let ((block (quotation/block quotation)))
+ (let ((block (quotation/block quotation))
+ (environment (environment/make)))
(quotation/make block
(copy/expression block
- (environment/make)
+ environment
(quotation/expression quotation))))))
\f
(define (copy/block parent environment block)
(define (copy/variable/free/extern variable)
(lambda ()
- (block/lookup-name root-block (variable/name variable))))
+ (block/lookup-name root-block (variable/name variable) true)))
\f
(define copy/declarations)
identity-procedure
(lambda ()
(block/lookup-name root-block
- (variable/name variable)))))
+ (variable/name variable) true))))
(lambda (expression)
(copy/expression block environment expression)))))
(environment/bind environment
variables
(map (lambda (variable)
- (block/lookup-name block (variable/name variable)))
+ (block/lookup-name block (variable/name variable) true))
variables)))
(define (make-renamer environment)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.2 1987/03/13 04:12:19 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.3 1987/07/08 04:39:27 jinx Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
(if (block/parent block)
(block/unsafe! (block/parent block))))))
-(define (block/lookup-name block name)
+(define (block/lookup-name block name intern?)
(let search ((block block))
(or (variable/assoc name (block/bound-variables block))
(let ((parent (block/parent block)))
- (if (not parent)
- (variable/make&bind! block name)
- (search parent))))))
+ (cond ((not (null? parent))
+ (search parent))
+ (intern?
+ (variable/make&bind! block name))
+ (else #f))))))
-(define (block/lookup-names block names)
+(define (block/lookup-names block names intern?)
(map (lambda (name)
- (block/lookup-name block name))
+ (block/lookup-name block name intern?))
names))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.10 1987/06/30 21:48:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.11 1987/07/08 04:42:25 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define scode-optimizer/system
(make-environment
- (define :name "SF")
+ (define :name "xSF")
(define :version 3)
- (define :modification 10)
+ (define :modification 10.1)
(define :files)
(define :files-lists
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.4 1987/05/08 02:34:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.5 1987/07/08 04:42:52 jinx Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
(lambda (bindings global? operation export? names values)
(let ((result
(binding/make global? operation export?
- (if global? names (block/lookup-names block names))
+ (if global?
+ names
+ (block/lookup-names block names true))
values)))
(transmit-values bindings
(lambda (before after)
(return-2 (cons result before) after)
(return-2 before (cons result after))))))))
+(declare (integrate-operator bind/general bind/values bind/no-values))
+
+(define (bind/general table/cons table global? operation export? names values)
+ (declare (integrate table/cons table global? operation export? names values))
+ (table/cons table global? operation export? names values))
+
(define (bind/values table/cons table operation export? names values)
+ (declare (integrate table/cons table operation export? names values))
(table/cons table (not export?) operation export? names values))
(define (bind/no-values table/cons table operation export? names)
+ (declare (integrate table/cons table operation export? names))
(table/cons table false operation export? names 'NO-VALUES))
\f
(define (declarations/known? declaration)
(transmit-values info
(lambda (value uninterned)
(finish value)))
- (variable/final-value variable environment finish if-not))))))
\ No newline at end of file
+ (variable/final-value variable environment finish if-not))))))
+\f
+;;;; User provided expansions and processors
+
+(define expander-evaluation-environment
+ (access package/expansion
+ package/scode-optimizer))
+
+(define-declaration 'EXPAND-OPERATOR true
+ (lambda (block table/cons table expanders)
+ (bind/general table/cons table false 'EXPAND false
+ (map car expanders)
+ (map (lambda (expander)
+ (eval (cadr expander)
+ expander-evaluation-environment))
+ expanders))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.5 1987/05/08 02:33:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.6 1987/07/08 04:43:11 jinx Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
+(define *top-level-block*)
+
+(define (integrate/get-top-level-block)
+ *top-level-block*)
+
(define (integrate/top-level block expression)
- (let ((operations (operations/bind-block (operations/make) block))
- (environment (environment/make)))
- (if (open-block? expression)
- (transmit-values
- (environment/recursive-bind operations environment
- (open-block/variables expression)
- (open-block/values expression))
- (lambda (environment values)
- (return-3 operations
- environment
- (quotation/make block
- (integrate/open-block operations
- environment
- expression
- values)))))
- (return-3 operations
- environment
- (quotation/make block
- (integrate/expression operations
- environment
- expression))))))
+ (fluid-let ((*top-level-block* block))
+ (let ((operations (operations/bind-block (operations/make) block))
+ (environment (environment/make)))
+ (if (open-block? expression)
+ (transmit-values
+ (environment/recursive-bind operations environment
+ (open-block/variables expression)
+ (open-block/values expression))
+ (lambda (environment values)
+ (return-3 operations
+ environment
+ (quotation/make block
+ (integrate/open-block operations
+ environment
+ expression
+ values)))))
+ (return-3 operations
+ environment
+ (quotation/make block
+ (integrate/expression operations
+ environment
+ expression)))))))
(define (operations/bind-block operations block)
(let ((declarations (block/declarations block)))
dont-integrate))
((EXPAND)
(info operands
- identity-procedure ;expanded value can't be optimized further.
- dont-integrate))
+ (lambda (new-expression)
+ (integrate/expression operations environment new-expression))
+ dont-integrate
+ (reference/block operator)))
(else (error "Unknown operation" operation))))
dont-integrate)))
(integrate/combination operations environment (cdr entry) operands)
(let ((entry (assq name usual-integrations/expansion-alist)))
(if entry
- ((cdr entry) operands identity-procedure dont-integrate)
+ ((cdr entry) operands identity-procedure
+ dont-integrate false)
(dont-integrate)))))))
(define (system-global-environment? expression)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.3 1987/05/09 20:30:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.4 1987/07/08 04:43:33 jinx Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
(eq? (constant/value expression) constant)))
(define (pairwise-test binary-predicate if-left-zero if-right-zero)
- (lambda (operands if-expanded if-not-expanded)
+ (lambda (operands if-expanded if-not-expanded block)
(cond ((or (null? operands)
(null? (cdr operands)))
(error "Too few operands" operands))
(if-not-expanded)))))
(define (pairwise-test-inverse inverse-expansion)
- (lambda (operands if-expanded if-not-expanded)
+ (lambda (operands if-expanded if-not-expanded block)
(inverse-expansion operands
(lambda (expression)
(if-expanded (make-combination not (list expression))))
- if-not-expanded)))
+ if-not-expanded
+ block)))
(define =-expansion
(pairwise-test (make-primitive-procedure '&=) zero? zero?))
;;;; N-ary Arithmetic Field Operations
(define (right-accumulation identity make-binary)
- (lambda (operands if-expanded if-not-expanded)
+ (lambda (operands if-expanded if-not-expanded block)
(let ((operands (delq identity operands)))
(let ((n (length operands)))
(cond ((zero? n)
(make-combination &* (list x y))))))
\f
(define (right-accumulation-inverse identity inverse-expansion make-binary)
- (lambda (operands if-expanded if-not-expanded)
+ (lambda (operands if-expanded if-not-expanded block)
(let ((expand
(lambda (x y)
(if-expanded
(inverse-expansion (cdr operands)
(lambda (expression)
(expand (car operands) expression))
- if-not-expanded))))))
+ if-not-expanded
+ block))))))
(define --expansion
(right-accumulation-inverse 0 +-expansion
;;;; Miscellaneous Arithmetic
(define (divide-component-expansion divide selector)
- (lambda (operands if-expanded if-not-expanded)
+ (lambda (operands if-expanded if-not-expanded block)
(if-expanded
(make-combination selector
(list (make-combination divide operands))))))
(define apply*-expansion
(let ((apply-primitive (make-primitive-procedure 'APPLY)))
- (lambda (operands if-expanded if-not-expanded)
+ (lambda (operands if-expanded if-not-expanded block)
(let ((n (length operands)))
(cond ((< n 2) (error "APPLY*-EXPANSION: Too few arguments" n))
((< n 10)
(cons*-expansion-loop (cdr operands))))))
(else (if-not-expanded)))))))
-(define (cons*-expansion operands if-expanded if-not-expanded)
+(define (cons*-expansion operands if-expanded if-not-expanded block)
(let ((n (length operands)))
(cond ((zero? n) (error "CONS*-EXPANSION: No arguments!"))
((< n 9) (if-expanded (cons*-expansion-loop operands)))
(list (car rest)
(cons*-expansion-loop (cdr rest))))))
-(define (list-expansion operands if-expanded if-not-expanded)
+(define (list-expansion operands if-expanded if-not-expanded block)
(if (< (length operands) 9)
(if-expanded (list-expansion-loop operands))
(if-not-expanded)))
-(define (vector-expansion operands if-expanded if-not-expanded)
+(define (vector-expansion operands if-expanded if-not-expanded block)
(if (< (length operands) 9)
(if-expanded (make-combination list->vector
(list (list-expansion-loop operands))))
;;;; General CAR/CDR Encodings
(define (general-car-cdr-expansion encoding)
- (lambda (operands if-expanded if-not-expanded)
+ (lambda (operands if-expanded if-not-expanded block)
(if (= (length operands) 1)
(if-expanded
(make-combination general-car-cdr
\f
;;;; Miscellaneous
-(define (make-string-expansion operands if-expanded if-not-expanded)
+(define (make-string-expansion operands if-expanded if-not-expanded block)
(let ((n (length operands)))
(cond ((zero? n)
(error "MAKE-STRING-EXPANSION: No arguments"))
(else
(if-not-expanded)))))
-(define (identity-procedure-expansion operands if-expanded if-not-expanded)
+(define (identity-procedure-expansion operands if-expanded if-not-expanded
+ block)
(if (not (= (length operands) 1))
(error "IDENTITY-PROCEDURE-EXPANSION: wrong number of arguments"
(length operands)))
(define usual-integrations/expansion-alist
(map cons
usual-integrations/expansion-names
- usual-integrations/expansion-values))
\ No newline at end of file
+ usual-integrations/expansion-values))
+
+;;; Scode->Scode expanders
+
+(define (scode->scode-expander scode-expander)
+ (lambda (operands if-expanded if-not-expanded block)
+ (scode-expander
+ (map (access cgen/external-with-declarations package/cgen)
+ operands)
+ (lambda (scode-expression)
+ (if-expanded
+ (transform/recursive
+ block
+ (integrate/get-top-level-block)
+ scode-expression)))
+ if-not-expanded)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.4 1987/06/05 21:36:10 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.5 1987/07/08 04:43:50 jinx Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
;;; same variable object. So, instead we intern them in GLOBAL-BLOCK,
;;; which never has any user defined names in it.
-(define (transform/top-level expression)
- (let ((block (block/make (block/make false false) false)))
- (return-2 block (transform/top-level-1 block expression))))
+(define try-deep-lookup?)
-(define (transform/top-level-1 block expression)
- (fluid-let ((global-block
- (let block/global-parent ((block block))
+(define (transform/top-level expression)
+ (fluid-let ((try-deep-lookup? false))
+ (let ((block (block/make (block/make false false) false)))
+ (return-2 block (transform/top-level-1 true block block expression)))))
+
+(define (transform/recursive block top-level-block expression)
+ (fluid-let ((try-deep-lookup? true))
+ (transform/top-level-1 false block top-level-block expression)))
+
+(define (transform/top-level-1 top-level? block top-level-block expression)
+ (fluid-let ((try-deep-lookup? (not top-level?))
+ (global-block
+ (let block/global-parent ((block top-level-block))
(if (block/parent block)
(block/global-parent (block/parent block))
block))))
(let ((environment (environment/make)))
- (if (scode-open-block? expression)
- (open-block-components expression
- (transform/open-block* block environment))
- (transform/expression block environment expression)))))
+ (cond ((not (scode-open-block? expression))
+ (transform/expression block environment expression))
+ ((not top-level?)
+ (error "transform/top-level-1: open blocks disallowed" expression))
+ (else
+ (open-block-components expression
+ (transform/open-block* block environment)))))))
(define (transform/expressions block environment expressions)
(map (lambda (expression)
(define (environment/make)
'())
-(define (environment/lookup environment name)
+(define (environment/lookup block environment name)
(let ((association (assq name environment)))
- (if association
- (cdr association)
- (block/lookup-name global-block name))))
+ (cond (association (cdr association))
+ ((and try-deep-lookup?
+ (block/lookup-name block name false)))
+ (else (block/lookup-name global-block name true)))))
(define (environment/bind environment variables)
(map* environment
(define (transform/variable block environment expression)
(reference/make block
- (environment/lookup environment (variable-name expression))))
+ (environment/lookup block environment (variable-name expression))))
(define (transform/assignment block environment expression)
(assignment-components expression
(lambda (name value)
(assignment/make block
- (environment/lookup environment name)
+ (environment/lookup block environment name)
(transform/expression block environment value)))))
\f
(define (transform/lambda block environment expression)
(map name->variable optional)
(and rest (name->variable rest))))
(lambda (required optional rest)
- (let ((bound `(,@required ,@optional ,@(if rest `(,rest) '()))))
+ (let* ((bound `(,@required ,@optional ,@(if rest `(,rest) '())))
+ (environment (environment/bind environment bound)))
(block/set-bound-variables! block bound)
(procedure/make
block name required optional rest
(transform/procedure-body block
- (environment/bind environment bound)
+ environment
body)))))))))
(define (transform/procedure-body block environment expression)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.10 1987/06/30 21:48:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.11 1987/07/08 04:42:25 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define scode-optimizer/system
(make-environment
- (define :name "SF")
+ (define :name "xSF")
(define :version 3)
- (define :modification 10)
+ (define :modification 10.1)
(define :files)
(define :files-lists
projects / mit-scheme.git / commitdiff