#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.1 1987/03/10 14:56:46 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.2 1987/03/13 04:11:49 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
;;;; SCode Optimizer: Generate SCode from Expression
-(declare (usual-integrations)
- (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
\f
(define (cgen/external quotation)
(fluid-let ((flush-declarations? true))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.1 1987/03/10 14:57:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.2 1987/03/13 04:12:02 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
;;;; SCode Optimizer: Copy Expression
-(declare (usual-integrations)
- (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
\f
-(define (copy/external block expression)
- (fluid-let ((root-block block))
- (copy/expression block (environment/make) expression)))
+(define root-block)
+
+(define (copy/external/intern block expression uninterned)
+ (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)))
+
+(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))))
(define (copy/expressions block environment expressions)
(map (lambda (expression)
(copy/expression block
(environment/make)
(quotation/expression quotation))))))
+\f
+(define (copy/block parent environment block)
+ (let ((result (block/make parent (block/safe? block)))
+ (old-bound (block/bound-variables block)))
+ (let ((new-bound
+ (map (lambda (variable)
+ (variable/make result (variable/name variable)))
+ old-bound)))
+ (let ((environment (environment/bind environment old-bound new-bound)))
+ (block/set-bound-variables! result new-bound)
+ (block/set-declarations!
+ result
+ (copy/declarations block environment (block/declarations block)))
+ (return-2 result environment)))))
+
+(define copy/variable/free)
+
+(define (copy/variable block environment variable)
+ (environment/lookup environment variable
+ identity-procedure
+ (copy/variable/free variable)))
+
+(define (copy/variable/free/intern variable)
+ (lambda ()
+ (let ((name (variable/name variable)))
+ (let loop ((block root-block))
+ (let ((variable* (variable/assoc name (block/bound-variables block))))
+ (cond ((eq? variable variable*)
+ variable)
+ ((not (block/parent block))
+ (error "Unable to find free variable during copy" name))
+ ((not variable*)
+ (loop (block/parent block)))
+ ((block/safe? (variable/block variable*))
+ (variable/set-name! variable* (rename-symbol name))
+ (loop (block/parent block)))
+ (else
+ (error "Integration requires renaming unsafe variable"
+ name))))))))
+
+(define (rename-symbol symbol)
+ (string->uninterned-symbol (symbol->string symbol)))
+
+(define (copy/variable/free/extern variable)
+ (lambda ()
+ (block/lookup-name root-block (variable/name variable))))
+\f
+(define copy/declarations)
+
+(define (copy/declarations/intern block environment declarations)
+ (if (null? declarations)
+ '()
+ (declarations/map declarations
+ (lambda (variable)
+ (environment/lookup environment variable
+ identity-procedure
+ (lambda () variable)))
+ identity-procedure)))
+(define (copy/declarations/extern block environment declarations)
+ (if (null? declarations)
+ '()
+ (declarations/map declarations
+ (lambda (variable)
+ (environment/lookup environment variable
+ identity-procedure
+ (lambda ()
+ (block/lookup-name root-block variable))))
+ (lambda (expression)
+ (copy/expression block environment expression)))))
+
+(define (environment/make)
+ '())
+
+(define (environment/bind environment variables values)
+ (map* environment cons variables values))
+
+(define (environment/lookup environment variable if-found if-not)
+ (let ((association (assq variable environment)))
+ (if association
+ (if-found (cdr association))
+ (if-not))))
+
+(define (environment/rebind block environment variables)
+ (environment/bind environment
+ variables
+ (map (lambda (variable)
+ (block/lookup-name block (variable/name variable)))
+ variables)))
+
+(define (make-renamer environment)
+ (lambda (variable)
+ (environment/lookup environment variable
+ identity-procedure
+ (lambda () (error "Missing variable during copy operation" variable)))))
+\f
(define-method/copy 'ACCESS
(lambda (block environment expression)
(access/make (copy/expression block environment
(define-method/copy 'CONSTANT
(lambda (block environment expression)
expression))
-\f
+
(define-method/copy 'DECLARATION
(lambda (block environment expression)
(declaration/make
- (copy/declarations environment (declaration/declarations expression))
+ (copy/declarations block environment
+ (declaration/declarations expression))
(copy/expression block environment (declaration/expression expression)))))
(define-method/copy 'DELAY
(copy/expression block environment (disjunction/predicate expression))
(copy/expression block environment
(disjunction/alternative expression)))))
-
+\f
(define-method/copy 'IN-PACKAGE
(lambda (block environment expression)
(in-package/make
(map rename (procedure/optional procedure))
(let ((rest (procedure/rest procedure)))
(and rest (rename rest)))
- (copy/expression block
- environment
+ (copy/expression block environment
(procedure/body procedure))))))))
-\f
+
(define-method/copy 'OPEN-BLOCK
(lambda (block environment expression)
(transmit-values
(copy/block block environment (open-block/block expression))
(lambda (block environment)
- (open-block/make block
- (map (make-renamer environment)
- (open-block/variables expression))
- (copy/expressions block
- environment
- (open-block/values expression))
- (map (lambda (action)
- (if (eq? action open-block/value-marker)
- action
- (copy/expression block
- environment
- action)))
- (open-block/actions expression)))))))
+ (open-block/make
+ block
+ (map (make-renamer environment) (open-block/variables expression))
+ (copy/expressions block environment (open-block/values expression))
+ (map (lambda (action)
+ (if (eq? action open-block/value-marker)
+ action
+ (copy/expression block environment action)))
+ (open-block/actions expression)))))))
(define-method/copy 'QUOTATION
(lambda (block environment expression)
(define-method/copy 'REFERENCE
(lambda (block environment expression)
(reference/make block
- (copy/variable block
- environment
+ (copy/variable block environment
(reference/variable expression)))))
(define-method/copy 'SEQUENCE
(define-method/copy 'THE-ENVIRONMENT
(lambda (block environment expression)
- (error "Attempt to integrate expression containing (THE-ENVIRONMENT)")))
-\f
-(define (copy/block parent environment block)
- (let ((result (block/make parent (block/safe? block)))
- (old-bound (block/bound-variables block)))
- (let ((new-bound
- (map (lambda (variable)
- (variable/make result (variable/name variable)))
- old-bound)))
- (let ((environment (environment/bind environment old-bound new-bound)))
- (block/set-bound-variables! result new-bound)
- (block/set-declarations!
- result
- (copy/declarations environment (block/declarations block)))
- (return-2 result environment)))))
-
-(define (copy/declarations environment declarations)
- (if (null? declarations)
- '()
- (declarations/rename declarations
- (lambda (variable)
- (environment/lookup environment variable
- identity-procedure
- (lambda () variable))))))
-
-(define root-block)
-
-(define (copy/variable block environment variable)
- (environment/lookup environment variable
- identity-procedure
- (lambda ()
- (for-each rename-variable!
- (let ((name (variable/name variable)))
- (let loop ((block root-block))
- (let ((variable*
- (variable/assoc name
- (block/bound-variables block))))
- (cond ((not variable*) (loop (block/parent block)))
- ((eq? variable variable*) '())
- (else
- (cons variable* (loop (block/parent block)))))))))
- variable)))
-
-(define (rename-variable! variable)
- (if (block/safe? (variable/block variable))
- (variable/set-name! variable (rename (variable/name variable)))
- (error "Integration requires renaming unsafe variable" variable)))
-
-(define (rename name)
- (string->uninterned-symbol (symbol->string name)))
-\f
-(define (environment/make)
- '())
-
-(define (environment/bind environment variables values)
- (map* environment cons variables values))
-
-(define (environment/lookup environment variable if-found if-not)
- (let ((association (assq variable environment)))
- (if association
- (if-found (cdr association))
- (if-not))))
-
-(define (make-renamer environment)
- (lambda (variable)
- (environment/lookup environment variable
- identity-procedure
(error "Attempt to integrate expression containing (THE-ENVIRONMENT)")))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.1 1987/03/10 14:53:32 cph Exp $
+$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 $
Copyright (c) 1987 Massachusetts Institute of Technology
;;;; SCode Optimizer: Environment Model
-(declare (usual-integrations)
- (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
\f
(define variable/assoc
(association-procedure eq? variable/name))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.1 1987/03/10 14:54:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.2 1987/03/13 04:12:30 cph Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
;;;; SCode Optimizer: Free Variable Analysis
-(declare (usual-integrations)
- (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
\f
(define (free/expressions expressions)
(if (null? expressions)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.2 1987/03/10 14:54:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.3 1987/03/13 04:12:41 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define sf)
+(define sf/set-file-syntax-table!)
+(define sf/add-file-declarations!)
(load "$zcomp/base/load" system-global-environment)
(load-system system-global-environment
'(SYSTEM-GLOBAL-ENVIRONMENT)
'(
(PACKAGE/SCODE-OPTIMIZER
- "mvalue.bin" ;Multiple Value Support
- "eqsets.bin" ;Set Data Abstraction
-
- "object.bin" ;Data Structures
- "emodel.bin" ;Environment Model
- "gconst.bin" ;Global Primitives List
- "usicon.bin" ;Usual Integrations: Constants
- "tables.bin" ;Table Abstractions
- "packag.bin" ;Global packaging
+ "mvalue" ;Multiple Value Support
+ "eqsets" ;Set Data Abstraction
+
+ "object" ;Data Structures
+ "emodel" ;Environment Model
+ "gconst" ;Global Primitives List
+ "usicon" ;Usual Integrations: Constants
+ "tables" ;Table Abstractions
+ "packag" ;Global packaging
)
(PACKAGE/TOP-LEVEL
- "toplev.bin" ;Top Level
+ "toplev" ;Top Level
)
(PACKAGE/TRANSFORM
- "xform.bin" ;SCode -> Internal
+ "xform" ;SCode -> Internal
)
(PACKAGE/INTEGRATE
- "subst.bin" ;Beta Substitution Optimizer
+ "subst" ;Beta Substitution Optimizer
)
(PACKAGE/CGEN
- "cgen.bin" ;Internal -> SCode
+ "cgen" ;Internal -> SCode
)
(PACKAGE/EXPANSION
- "usiexp.bin" ;Usual Integrations: Expanders
+ "usiexp" ;Usual Integrations: Expanders
)
- (PACKAGE/DECLARATION-PARSER
- "pardec.bin" ;Declaration Parser
+ (PACKAGE/DECLARATIONS
+ "pardec" ;Declaration Parser
)
(PACKAGE/COPY
- "copy.bin" ;Copy Expressions
+ "copy" ;Copy Expressions
)
(PACKAGE/FREE
- "free.bin" ;Free Variable Analysis
+ "free" ;Free Variable Analysis
)
(PACKAGE/SAFE?
- "safep.bin" ;Safety Analysis
+ "safep" ;Safety Analysis
+ )
+
+ (PACKAGE/CHANGE-TYPE
+ "chtype" ;Type interning
)
))
(make-environment
(define :name "SF")
(define :version 3)
- (define :modification 1)))
+ (define :modification 2)))
(add-system! scode-optimizer/system)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 3.0 1987/03/10 13:25:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 3.1 1987/03/13 04:12:53 cph Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
(let ((enumerand (symbol-append name '/ENUMERAND)))
`(BEGIN
(DEFINE ,enumerand
- (NAME->ENUMERAND ,(symbol-append 'ENUMERATION/ enumeration) ',name))
+ (ENUMERATION/NAME->ENUMERAND ,(symbol-append 'ENUMERATION/
+ enumeration)
+ ',name))
((ACCESS ADD-UNPARSER-SPECIAL-OBJECT! UNPARSER-PACKAGE) ,enumerand
(LAMBDA (OBJECT)
(UNPARSE-WITH-BRACKETS
(DECLARE (INTEGRATE ,@slots))
(OBJECT/ALLOCATE ,(symbol-append name '/ENUMERAND) ,@slots))
(DEFINE-TYPE ,name ,enumeration ,slots)))))
+\f
+;;;; Objects
(declare (integrate object/allocate)
- (integrate-operator object/enumerand))
+ (integrate-operator object/enumerand object/set-enumerand!))
(define object/allocate vector)
(declare (integrate object))
(vector-ref object 0))
+(define (object/set-enumerand! object enumerand)
+ (declare (integrate object enumerand))
+ (vector-set! object 0 enumerand))
+
(define (object/predicate enumerand)
(lambda (object)
(and (vector? object)
;;;; Enumerations
(define (enumeration/make names)
- (let ((enumeration (make-vector (length names))))
- (let loop ((names names) (index 0))
- (if (not (null? names))
- (begin
- (vector-set! enumeration index
- (vector enumeration (car names) index))
- (loop (cdr names) (1+ index)))))
- enumeration))
+ (let ((enumerands
+ (let loop ((names names) (index 0))
+ (if (null? names)
+ '()
+ (cons (vector false (car names) index)
+ (loop (cdr names) (1+ index)))))))
+ (let ((enumeration
+ (cons (list->vector enumerands)
+ (map (lambda (enumerand)
+ (cons (enumerand/name enumerand) enumerand))
+ enumerands))))
+ (for-each (lambda (enumerand)
+ (vector-set! enumerand 0 enumeration))
+ enumerands)
+ enumeration)))
(declare (integrate-operator enumerand/enumeration enumerand/name
enumerand/index enumeration/cardinality
- index->enumerand))
+ enumeration/index->enumerand))
(define (enumerand/enumeration enumerand)
(declare (integrate enumerand))
(define (enumeration/cardinality enumeration)
(declare (integrate enumeration))
- (vector-length enumeration))
-
-(define (index->enumerand enumerand index)
- (declare (integrate enumerand index))
- (vector-ref enumerand index))
-
-(define (name->enumerand enumeration name)
- (let ((length (enumeration/cardinality enumeration)))
- (let loop ((index 0))
- (and (< index length)
- (let ((enumerand (index->enumerand enumeration index)))
- (if (eqv? name (enumerand/name enumerand))
- enumerand
- (loop (1+ index))))))))
+ (vector-length (car enumeration)))
+
+(define (enumeration/index->enumerand enumeration index)
+ (declare (integrate enumeration index))
+ (vector-ref (car enumeration) index))
+
+(define (enumeration/name->enumerand enumeration name)
+ (cdr (or (assq name (cdr enumeration))
+ (error "Unknown enumeration name" name))))
+
+(define (enumeration/name->index enumeration name)
+ (enumerand/index (enumeration/name->enumerand enumeration name)))
\f
;;;; Random Types
)))
(define-type block random
- (parent children safe? declarations bound-variables expression))
+ (parent children safe? declarations bound-variables))
(define (block/make parent safe?)
(let ((block
- (object/allocate block/enumerand parent '() safe? '() '()
- false)))
+ (object/allocate block/enumerand parent '() safe?
+ (declarations/make-null) '())))
(if parent
(block/set-children! parent (cons block (block/children parent))))
block))
(define-type delayed-integration random
(state environment operations value))
+(declare (integrate-operator delayed-integration/make))
+
(define (delayed-integration/make operations expression)
+ (declare (integrate operations expression))
(object/allocate delayed-integration/enumerand 'NOT-INTEGRATED false
operations expression))
variable))
(define open-block/value-marker
- "value marker")
+ ;; This must be an interned object because we will fasdump it and
+ ;; fasload it back in.
+ (make-named-tag "open-block/value-marker"))
\f
;;;; Expression Types
(define (expression/make-method-definer dispatch-vector)
(lambda (type-name method)
(vector-set! dispatch-vector
- (enumerand/index
- (name->enumerand enumeration/expression type-name))
+ (enumeration/name->index enumeration/expression type-name)
method)))
(declare (integrate-operator expression/method name->method))
;; Useful for debugging
(declare (integrate dispatch-vector name))
(vector-ref dispatch-vector
- (enumerand/index (name->enumerand enumeration/expression name))))
+ (enumeration/name->index enumeration/expression name)))
\f
(define-simple-type access expression (environment name))
(define-simple-type assignment expression (block variable value))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.0 1987/03/10 13:25:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.1 1987/03/13 04:13:19 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (declarations/known? declaration)
- (assq (car declaration) known-declarations))
+(define (declarations/make-null)
+ (declarations/make '() '() '()))
(define (declarations/parse block declarations)
- (return-2
- declarations
- (accumulate
- (lambda (declaration bindings)
- (let ((association (assq (car declaration) known-declarations)))
- (if (not association)
- bindings
- (transmit-values (cdr association)
- (lambda (before-bindings? parser)
- (let ((block
- (if before-bindings?
- (let ((block (block/parent block)))
- (if (block/parent block)
- (warn "Declaration not at top level"
- declaration))
- block)
- block)))
- (parser block (bindings/cons block before-bindings?) bindings
- (cdr declaration))))))))
- (return-2 '() '())
- declarations)))
-
-(define (declarations/rename declarations rename)
- (declarations/map declarations
- (lambda (bindings)
- (map (lambda (binding)
- (transmit-values binding
- (lambda (applicator binder names)
- (return-3 applicator binder (map rename names)))))
- bindings))))
-
-(define (declarations/binders declarations)
- (transmit-values declarations
- (lambda (original bindings)
- (call-multiple (lambda (bindings)
- (lambda (operations)
- (accumulate (lambda (binding operations)
- (transmit-values binding
- (lambda (applicator binder names)
- (applicator binder operations
- names))))
- operations bindings)))
- bindings))))
-
-(define (declarations/original declarations)
- (transmit-values declarations
- (lambda (original bindings)
- original)))
-\f
-(define (declarations/map declarations procedure)
- (transmit-values declarations
- (lambda (original bindings)
- (return-2 original (call-multiple procedure bindings)))))
+ (transmit-values
+ (accumulate
+ (lambda (declaration bindings)
+ (let ((association (assq (car declaration) known-declarations)))
+ (if (not association)
+ bindings
+ (transmit-values (cdr association)
+ (lambda (before-bindings? parser)
+ (let ((block
+ (if before-bindings?
+ (let ((block (block/parent block)))
+ (if (block/parent block)
+ (warn "Declaration not at top level"
+ declaration))
+ block)
+ block)))
+ (parser block
+ (bindings/cons block before-bindings?)
+ bindings
+ (cdr declaration))))))))
+ (return-2 '() '())
+ declarations)
+ (lambda (before after)
+ (declarations/make declarations before after))))
(define (bindings/cons block before-bindings?)
- (lambda (bindings applicator names global?)
+ (lambda (bindings global? operation export? names values)
(let ((result
- (if global?
- (return-3 applicator operations/bind-global names)
- (return-3 applicator operations/bind
- (block/lookup-names block names)))))
+ (binding/make global? operation export?
+ (if global? names (block/lookup-names block names))
+ values)))
(transmit-values bindings
- (lambda (before-bindings after-bindings)
+ (lambda (before after)
(if before-bindings?
- (return-2 (cons result before-bindings) after-bindings)
- (return-2 before-bindings (cons result after-bindings))))))))
+ (return-2 (cons result before) after)
+ (return-2 before (cons result after))))))))
(define (bind/values table/cons table operation export? names values)
- (table/cons table
- (lambda (binder operations names)
- (binder operations operation export? names values))
- names
- (not export?)))
+ (table/cons table (not export?) operation export? names values))
(define (bind/no-values table/cons table operation export? names)
- (table/cons table
- (lambda (binder operations names)
- (binder operations operation export? names))
- names
- false))
-
-(define (accumulate cons table items)
- (let loop ((table table) (items items))
- (if (null? items)
- table
- (loop (cons (car items) table) (cdr items)))))
+ (table/cons table false operation export? names 'NO-VALUES))
+\f
+(define (declarations/known? declaration)
+ (assq (car declaration) known-declarations))
(define (define-declaration name before-bindings? parser)
(let ((entry (assq name known-declarations)))
(define known-declarations
'())
+
+(define (accumulate cons table items)
+ (let loop ((table table) (items items))
+ (if (null? items)
+ table
+ (loop (cons (car items) table) (cdr items)))))
+\f
+(define (declarations/binders declarations)
+ (let ((procedure
+ (lambda (bindings)
+ (lambda (operations)
+ (accumulate (lambda (binding operations)
+ ((if (binding/global? binding)
+ operations/bind-global
+ operations/bind)
+ operations
+ (binding/operation binding)
+ (binding/export? binding)
+ (binding/names binding)
+ (binding/values binding)))
+ operations
+ bindings)))))
+ (return-2 (procedure (declarations/before declarations))
+ (procedure (declarations/after declarations)))))
+
+(define (declarations/for-each-variable declarations procedure)
+ (declarations/for-each-binding declarations
+ (lambda (binding)
+ (if (not (binding/global? binding))
+ (for-each procedure (binding/names binding))))))
+
+(define (declarations/for-each-binding declarations procedure)
+ (let ((procedure
+ (lambda (bindings)
+ (for-each procedure bindings))))
+ (procedure (declarations/before declarations))
+ (procedure (declarations/after declarations))))
+
+(define (declarations/map declarations per-name per-value)
+ (declarations/map-binding declarations
+ (lambda (binding)
+ (let ((global? (binding/global? binding))
+ (names (binding/names binding))
+ (values (binding/values binding)))
+ (binding/make global?
+ (binding/operation binding)
+ (binding/export? binding)
+ (if global? names (map per-name names))
+ (if (eq? values 'NO-VALUES)
+ values
+ (map per-value values)))))))
+
+(define (declarations/map-binding declarations procedure)
+ (let ((procedure
+ (lambda (bindings)
+ (map procedure bindings))))
+ (declarations/make (declarations/original declarations)
+ (procedure (declarations/before declarations))
+ (procedure (declarations/after declarations)))))
+\f
+(declare (integrate-operator declarations/make declarations/original
+ declarations/before declarations/after))
+
+(define (declarations/make original before after)
+ (declare (integrate original before after))
+ (vector original before after))
+
+(define (declarations/original declarations)
+ (declare (integrate declarations))
+ (vector-ref declarations 0))
+
+(define (declarations/before declarations)
+ (declare (integrate declarations))
+ (vector-ref declarations 1))
+
+(define (declarations/after declarations)
+ (declare (integrate declarations))
+ (vector-ref declarations 2))
+
+(declare (integrate-operator binding/make binding/global? binding/operation
+ binding/export? binding/names binding/values))
+
+(define (binding/make global? operation export? names values)
+ (declare (integrate global? operation export? names values))
+ (vector global? operation export? names values))
+
+(define (binding/global? binding)
+ (declare (integrate binding))
+ (vector-ref binding 0))
+
+(define (binding/operation binding)
+ (declare (integrate binding))
+ (vector-ref binding 1))
+
+(define (binding/export? binding)
+ (declare (integrate binding))
+ (vector-ref binding 2))
+
+(define (binding/names binding)
+ (declare (integrate binding))
+ (vector-ref binding 3))
+
+(define (binding/values binding)
+ (declare (integrate binding))
+ (vector-ref binding 4))
\f
;;;; Integration of System Constants
(let ((finish
(lambda (variable-name primitive-name)
(return-2 (block/lookup-name block variable-name)
- (make-primitive-procedure
- (constant->integration-info primitive-name))))))
+ (constant->integration-info
+ (make-primitive-procedure primitive-name))))))
(cond ((and (pair? specification)
(symbol? (car specification))
(pair? (cdr specification))
(bind/values table/cons table (vector-ref extern 1) false
(list (vector-ref extern 0))
(list
- (expression->integration-info
- (transform/expression-with-block
- block
- (vector-ref extern 2))))))
+ (intern-type (vector-ref extern 2)
+ (vector-ref extern 3)))))
table
(mapcan read-externs-file
(mapcan specification->pathnames specifications)))))
(map ->pathname value)
(list (->pathname value)))))
-(define (expression->integration-info expression)
- (lambda ()
- expression))
-
(define (operations->external operations environment)
(operations/extract-external operations
(lambda (variable operation info if-ok if-not)
(let ((finish
(lambda (value)
(if-ok
- (vector (variable/name variable)
- operation
- (cgen/expression-with-declarations value))))))
+ (transmit-values (copy/expression/extern value)
+ (lambda (block expression)
+ (vector (variable/name variable)
+ operation
+ block
+ expression)))))))
(if info
(finish info)
(variable/final-value variable environment finish if-not))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.1 1987/03/10 14:57:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.2 1987/03/13 04:13:46 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
;;;; SCode Optimizer: Beta Substitution
-(declare (usual-integrations)
- (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
\f
(define (integrate/top-level block expression)
(let ((operations (operations/bind-block (operations/make) block))
(define (integrate/name reference info environment)
(let ((variable (reference/variable reference)))
(let ((finish
- (lambda (value)
- (copy/expression (reference/block reference) value))))
+ (lambda (value uninterned)
+ (copy/expression (reference/block reference) value uninterned))))
(if info
- (finish (info))
+ (transmit-values info finish)
(environment/lookup environment variable
(lambda (value)
(if (delayed-integration? value)
(if (delayed-integration/in-progress? value)
reference
- (finish (delayed-integration/force value)))
- (finish value)))
+ (finish (delayed-integration/force value) '()))
+ (finish value '())))
(lambda () reference))))))
(define (variable/final-value variable environment if-value if-not)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 3.0 1987/03/10 13:25:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 3.1 1987/03/13 04:14:10 cph Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
(cons name (vector export? operation value)))
names values)))
-(define (operations/bind operations operation export? names #!optional values)
+(define (operations/bind operations operation export? names values)
(cons (let ((make-binding
(lambda (name value)
(cons name (vector export? operation value)))))
- (if (unassigned? values)
+ (if (eq? values 'NO-VALUES)
(map* (car operations)
(lambda (name) (make-binding name false))
names)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.0 1987/03/10 13:25:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.1 1987/03/13 04:14:20 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
environment)))
(error "INTEGRATE/PROCEDURE: Not a compound procedure" procedure)))
-(define (integrate/sexp s-expression declarations receiver)
- (integrate/simple phase:syntax (list s-expression) declarations receiver))
+(define (integrate/sexp s-expression syntax-table declarations receiver)
+ (integrate/simple (lambda (s-expressions)
+ (phase:syntax s-expressions syntax-table))
+ (list s-expression) declarations receiver))
(define (integrate/scode scode declarations receiver)
(integrate/simple identity-procedure scode declarations receiver))
(fluid-let ((wrapping-hook wrap-with-control-point))
(syntax-file input-string bin-string spec-string)))
\f
+(define (sf/set-file-syntax-table! pathname syntax-table)
+ (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
+ (let ((association (find-file-info/assoc pathname)))
+ (if association
+ (set-cdr! association
+ (transmit-values (cdr association)
+ (lambda (ignore declarations)
+ (return-2 syntax-table declarations))))
+ (set! file-info
+ (cons (cons pathname (return-2 syntax-table '()))
+ file-info))))))
+
+(define (sf/add-file-declarations! pathname declarations)
+ (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
+ (let ((association (find-file-info/assoc pathname)))
+ (if association
+ (set-cdr! association
+ (transmit-values (cdr association)
+ (lambda (syntax-table declarations*)
+ (return-2 syntax-table
+ (append! declarations*
+ (list-copy declarations))))))
+ (set! file-info
+ (cons (cons pathname (return-2 false declarations))
+ file-info))))))
+
+(define file-info
+ '())
+
+(define (find-file-info pathname)
+ (let ((association
+ (find-file-info/assoc (pathname->absolute-pathname pathname))))
+ (if association
+ (cdr association)
+ (return-2 false '()))))
+
+(define (find-file-info/assoc pathname)
+ (list-search-positive file-info
+ (lambda (entry)
+ (pathname=? (car entry) pathname))))
+
+(define (pathname=? x y)
+ (and (equal? (pathname-device x) (pathname-device y))
+ (equal? (pathname-directory x) (pathname-directory y))
+ (equal? (pathname-name x) (pathname-name y))))
+\f
;;;; File Syntaxer
(define sf/default-input-pathname
(write bin-filename)
(write-string " ")
(write spec-filename)
- (transmit-values (integrate/file input-pathname '() spec-pathname)
+ (transmit-values
+ (transmit-values (find-file-info input-pathname)
+ (lambda (syntax-table declarations)
+ (integrate/file input-pathname syntax-table declarations
+ spec-pathname)))
(lambda (expression externs events)
(fasdump (wrapping-hook
(make-comment `((SOURCE-FILE . ,input-filename)
sf/default-externs-pathname)))
(define (write-externs-file pathname externs)
- (if (not (null? externs))
- (fasdump externs pathname)))
+ (cond ((not (null? externs))
+ (fasdump externs pathname))
+ ((file-exists? pathname)
+ (delete-file pathname))))
(define (print-spec identifier names)
(newline)
\f
;;;; Optimizer Top Level
-(define (integrate/file file-name declarations compute-free?)
+(define (integrate/file file-name syntax-table declarations compute-free?)
(integrate/kernel (lambda ()
- (phase:syntax (phase:read file-name)))
+ (phase:syntax (phase:read file-name) syntax-table))
declarations))
(define (integrate/simple preprocessor input declarations receiver)
(mark-phase "Read")
(read-file filename))
-(define (phase:syntax s-expression)
+(define (phase:syntax s-expression #!optional syntax-table)
+ (if (or (unassigned? syntax-table) (not syntax-table))
+ (set! syntax-table (make-syntax-table system-global-syntax-table)))
(mark-phase "Syntax")
- (syntax* s-expression (make-syntax-table system-global-syntax-table)))
+ (syntax* s-expression syntax-table))
(define (phase:transform scode)
(mark-phase "Transform")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 3.0 1987/03/10 13:25:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 3.1 1987/03/13 04:14:39 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define usual-integrations/constant-names)
(define usual-integrations/constant-values)
-(define (constant->integration-info constant)
- (lambda ()
- (constant/make constant)))
-
(define (usual-integrations/delete-constant! name)
(set! global-constant-objects (delq! name global-constant-objects))
(usual-integrations/cache!))
(error "USUAL-INTEGRATIONS: not a constant" name))
(constant->integration-info object)))
usual-integrations/constant-names))
+ 'DONE)
+
+(define (constant->integration-info constant)
(return-2 (constant/make constant) '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.1 1987/03/10 14:58:01 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.2 1987/03/13 04:14:48 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
;;;; SCode Optimizer: Transform Input Expression
-(declare (usual-integrations)
- (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
\f
;;; GLOBAL-BLOCK is used to handle (USUAL-INTEGRATIONS), as follows.
;;; This declaration refers to a large group of names, which are
(define ((transform/open-block* block environment) auxiliary declarations body)
(let ((variables (map (lambda (name) (variable/make block name)) auxiliary)))
- (block/set-bound-variables! block variables)
+ (block/set-bound-variables! block
+ (append (block/bound-variables block)
+ variables))
(block/set-declarations! block (declarations/parse block declarations))
(let ((environment (environment/bind environment variables)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.2 1987/03/10 14:54:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.3 1987/03/13 04:12:41 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define sf)
+(define sf/set-file-syntax-table!)
+(define sf/add-file-declarations!)
(load "$zcomp/base/load" system-global-environment)
(load-system system-global-environment
'(SYSTEM-GLOBAL-ENVIRONMENT)
'(
(PACKAGE/SCODE-OPTIMIZER
- "mvalue.bin" ;Multiple Value Support
- "eqsets.bin" ;Set Data Abstraction
-
- "object.bin" ;Data Structures
- "emodel.bin" ;Environment Model
- "gconst.bin" ;Global Primitives List
- "usicon.bin" ;Usual Integrations: Constants
- "tables.bin" ;Table Abstractions
- "packag.bin" ;Global packaging
+ "mvalue" ;Multiple Value Support
+ "eqsets" ;Set Data Abstraction
+
+ "object" ;Data Structures
+ "emodel" ;Environment Model
+ "gconst" ;Global Primitives List
+ "usicon" ;Usual Integrations: Constants
+ "tables" ;Table Abstractions
+ "packag" ;Global packaging
)
(PACKAGE/TOP-LEVEL
- "toplev.bin" ;Top Level
+ "toplev" ;Top Level
)
(PACKAGE/TRANSFORM
- "xform.bin" ;SCode -> Internal
+ "xform" ;SCode -> Internal
)
(PACKAGE/INTEGRATE
- "subst.bin" ;Beta Substitution Optimizer
+ "subst" ;Beta Substitution Optimizer
)
(PACKAGE/CGEN
- "cgen.bin" ;Internal -> SCode
+ "cgen" ;Internal -> SCode
)
(PACKAGE/EXPANSION
- "usiexp.bin" ;Usual Integrations: Expanders
+ "usiexp" ;Usual Integrations: Expanders
)
- (PACKAGE/DECLARATION-PARSER
- "pardec.bin" ;Declaration Parser
+ (PACKAGE/DECLARATIONS
+ "pardec" ;Declaration Parser
)
(PACKAGE/COPY
- "copy.bin" ;Copy Expressions
+ "copy" ;Copy Expressions
)
(PACKAGE/FREE
- "free.bin" ;Free Variable Analysis
+ "free" ;Free Variable Analysis
)
(PACKAGE/SAFE?
- "safep.bin" ;Safety Analysis
+ "safep" ;Safety Analysis
+ )
+
+ (PACKAGE/CHANGE-TYPE
+ "chtype" ;Type interning
)
))
(make-environment
(define :name "SF")
(define :version 3)
- (define :modification 1)))
+ (define :modification 2)))
(add-system! scode-optimizer/system)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.0 1987/03/10 13:25:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.1 1987/03/13 04:14:20 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
environment)))
(error "INTEGRATE/PROCEDURE: Not a compound procedure" procedure)))
-(define (integrate/sexp s-expression declarations receiver)
- (integrate/simple phase:syntax (list s-expression) declarations receiver))
+(define (integrate/sexp s-expression syntax-table declarations receiver)
+ (integrate/simple (lambda (s-expressions)
+ (phase:syntax s-expressions syntax-table))
+ (list s-expression) declarations receiver))
(define (integrate/scode scode declarations receiver)
(integrate/simple identity-procedure scode declarations receiver))
(fluid-let ((wrapping-hook wrap-with-control-point))
(syntax-file input-string bin-string spec-string)))
\f
+(define (sf/set-file-syntax-table! pathname syntax-table)
+ (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
+ (let ((association (find-file-info/assoc pathname)))
+ (if association
+ (set-cdr! association
+ (transmit-values (cdr association)
+ (lambda (ignore declarations)
+ (return-2 syntax-table declarations))))
+ (set! file-info
+ (cons (cons pathname (return-2 syntax-table '()))
+ file-info))))))
+
+(define (sf/add-file-declarations! pathname declarations)
+ (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
+ (let ((association (find-file-info/assoc pathname)))
+ (if association
+ (set-cdr! association
+ (transmit-values (cdr association)
+ (lambda (syntax-table declarations*)
+ (return-2 syntax-table
+ (append! declarations*
+ (list-copy declarations))))))
+ (set! file-info
+ (cons (cons pathname (return-2 false declarations))
+ file-info))))))
+
+(define file-info
+ '())
+
+(define (find-file-info pathname)
+ (let ((association
+ (find-file-info/assoc (pathname->absolute-pathname pathname))))
+ (if association
+ (cdr association)
+ (return-2 false '()))))
+
+(define (find-file-info/assoc pathname)
+ (list-search-positive file-info
+ (lambda (entry)
+ (pathname=? (car entry) pathname))))
+
+(define (pathname=? x y)
+ (and (equal? (pathname-device x) (pathname-device y))
+ (equal? (pathname-directory x) (pathname-directory y))
+ (equal? (pathname-name x) (pathname-name y))))
+\f
;;;; File Syntaxer
(define sf/default-input-pathname
(write bin-filename)
(write-string " ")
(write spec-filename)
- (transmit-values (integrate/file input-pathname '() spec-pathname)
+ (transmit-values
+ (transmit-values (find-file-info input-pathname)
+ (lambda (syntax-table declarations)
+ (integrate/file input-pathname syntax-table declarations
+ spec-pathname)))
(lambda (expression externs events)
(fasdump (wrapping-hook
(make-comment `((SOURCE-FILE . ,input-filename)
sf/default-externs-pathname)))
(define (write-externs-file pathname externs)
- (if (not (null? externs))
- (fasdump externs pathname)))
+ (cond ((not (null? externs))
+ (fasdump externs pathname))
+ ((file-exists? pathname)
+ (delete-file pathname))))
(define (print-spec identifier names)
(newline)
\f
;;;; Optimizer Top Level
-(define (integrate/file file-name declarations compute-free?)
+(define (integrate/file file-name syntax-table declarations compute-free?)
(integrate/kernel (lambda ()
- (phase:syntax (phase:read file-name)))
+ (phase:syntax (phase:read file-name) syntax-table))
declarations))
(define (integrate/simple preprocessor input declarations receiver)
(mark-phase "Read")
(read-file filename))
-(define (phase:syntax s-expression)
+(define (phase:syntax s-expression #!optional syntax-table)
+ (if (or (unassigned? syntax-table) (not syntax-table))
+ (set! syntax-table (make-syntax-table system-global-syntax-table)))
(mark-phase "Syntax")
- (syntax* s-expression (make-syntax-table system-global-syntax-table)))
+ (syntax* s-expression syntax-table))
(define (phase:transform scode)
(mark-phase "Transform")
projects / mit-scheme.git / commitdiff