--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/mvalue.scm,v 3.0 1987/03/10 13:25:05 cph Rel $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Multiple Value Support
+
+(declare (usual-integrations))
+\f
+(define (transmit-values transmitter receiver)
+ (transmitter receiver))
+
+(define (multiple-value-list transmitter)
+ (transmitter list))
+
+(define (return . values)
+ (lambda (receiver)
+ (apply receiver values)))
+
+;;; For efficiency:
+
+(define (return-2 v0 v1)
+ (lambda (receiver)
+ (receiver v0 v1)))
+
+(define (return-3 v0 v1 v2)
+ (lambda (receiver)
+ (receiver v0 v1 v2)))
+
+(define (return-4 v0 v1 v2 v3)
+ (lambda (receiver)
+ (receiver v0 v1 v2 v3)))
+
+(define (return-5 v0 v1 v2 v3 v4)
+ (lambda (receiver)
+ (receiver v0 v1 v2 v3 v4)))
+
+(define (return-6 v0 v1 v2 v3 v4 v5)
+ (lambda (receiver)
+ (receiver v0 v1 v2 v3 v4 v5)))
+
+(define (list-multiple first . rest)
+ (apply call-multiple list first rest))
+
+(define (cons-multiple cars cdrs)
+ (call-multiple cons cars cdrs))
+
+(define (call-multiple procedure . transmitters)
+ (apply return
+ (apply map
+ procedure
+ (map multiple-value-list transmitters))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.0 1987/03/10 13:24:42 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Generate SCode from Expression
+
+(declare (usual-integrations))
+\f
+(define (cgen/external quotation)
+ (fluid-let ((flush-declarations? true))
+ (cgen/top-level quotation)))
+
+(define (cgen/external-with-declarations expression)
+ (fluid-let ((flush-declarations? false))
+ (cgen/expression (list false) expression)))
+
+(define (cgen/top-level quotation)
+ (let ((block (quotation/block quotation))
+ (expression (quotation/expression quotation)))
+ (cgen/declaration (block/declarations block)
+ (cgen/expression (list block) expression))))
+
+(define (cgen/declaration declarations expression)
+ (let ((declarations (maybe-flush-declarations declarations)))
+ (if (null? declarations)
+ expression
+ (make-declaration declarations expression))))
+
+(define flush-declarations?)
+
+(define (maybe-flush-declarations declarations)
+ (if (null? declarations)
+ '()
+ (let ((declarations (declarations/original declarations)))
+ (if flush-declarations?
+ (begin (for-each (lambda (declaration)
+ (if (not (declarations/known? declaration))
+ (warn "Unused declaration" declaration)))
+ declarations)
+ '())
+ declarations))))
+
+(define (cgen/expressions interns expressions)
+ (map (lambda (expression)
+ (cgen/expression interns expression))
+ expressions))
+
+(define (cgen/expression interns expression)
+ ((expression/method dispatch-vector expression) interns expression))
+
+(define dispatch-vector
+ (expression/make-dispatch-vector))
+
+(define define-method/cgen
+ (expression/make-method-definer dispatch-vector))
+
+(define (cgen/variable interns variable)
+ (cdr (or (assq variable (cdr interns))
+ (let ((association
+ (cons variable (make-variable (variable/name variable)))))
+ (set-cdr! interns (cons association (cdr interns)))
+ association))))
+\f
+(define-method/cgen 'ACCESS
+ (lambda (interns expression)
+ (make-access (cgen/expression interns (access/environment expression))
+ (access/name expression))))
+
+(define-method/cgen 'ASSIGNMENT
+ (lambda (interns expression)
+ (make-assignment-from-variable
+ (cgen/variable interns (assignment/variable expression))
+ (cgen/expression interns (assignment/value expression)))))
+
+(define-method/cgen 'COMBINATION
+ (lambda (interns expression)
+ (make-combination
+ (cgen/expression interns (combination/operator expression))
+ (cgen/expressions interns (combination/operands expression)))))
+
+(define-method/cgen 'CONDITIONAL
+ (lambda (interns expression)
+ (make-conditional
+ (cgen/expression interns (conditional/predicate expression))
+ (cgen/expression interns (conditional/consequent expression))
+ (cgen/expression interns (conditional/alternative expression)))))
+
+(define-method/cgen 'CONSTANT
+ (lambda (interns expression)
+ (constant/value expression)))
+
+(define-method/cgen 'DECLARATION
+ (lambda (interns expression)
+ (cgen/declaration (declaration/declarations expression)
+ (cgen/expression interns
+ (declaration/expression expression)))))
+
+(define-method/cgen 'DELAY
+ (lambda (interns expression)
+ (make-delay (cgen/expression interns (delay/expression expression)))))
+
+(define-method/cgen 'DISJUNCTION
+ (lambda (interns expression)
+ (make-disjunction
+ (cgen/expression interns (disjunction/predicate expression))
+ (cgen/expression interns (disjunction/alternative expression)))))
+
+(define-method/cgen 'IN-PACKAGE
+ (lambda (interns expression)
+ (make-in-package
+ (cgen/expression interns (in-package/environment expression))
+ (cgen/top-level (in-package/quotation expression)))))
+\f
+(define-method/cgen 'PROCEDURE
+ (lambda (interns procedure)
+ (make-lambda* (variable/name (procedure/name procedure))
+ (map variable/name (procedure/required procedure))
+ (map variable/name (procedure/optional procedure))
+ (let ((rest (procedure/rest procedure)))
+ (and rest (variable/name rest)))
+ (let ((block (procedure/block procedure)))
+ (make-open-block
+ '()
+ (maybe-flush-declarations (block/declarations block))
+ (cgen/expression (list block)
+ (procedure/body procedure)))))))
+
+(define-method/cgen 'OPEN-BLOCK
+ (lambda (interns expression)
+ (let ((block (open-block/block expression)))
+ (make-open-block '()
+ (maybe-flush-declarations (block/declarations block))
+ (cgen/body (list block) expression)))))
+
+(define (cgen/body interns open-block)
+ (make-sequence
+ (let loop
+ ((variables (open-block/variables open-block))
+ (values (open-block/values open-block))
+ (actions (open-block/actions open-block)))
+ (cond ((null? variables) (cgen/expressions interns actions))
+ ((null? actions) (error "Extraneous auxiliaries"))
+ ((eq? (car actions) open-block/value-marker)
+ (cons (make-definition (variable/name (car variables))
+ (cgen/expression interns (car values)))
+ (loop (cdr variables) (cdr values) (cdr actions))))
+ (else
+ (cons (cgen/expression interns (car actions))
+ (loop variables values (cdr actions))))))))
+
+(define-method/cgen 'QUOTATION
+ (lambda (interns expression)
+ (make-quotation (cgen/top-level expression))))
+
+(define-method/cgen 'REFERENCE
+ (lambda (interns expression)
+ (cgen/variable interns (reference/variable expression))))
+
+(define-method/cgen 'SEQUENCE
+ (lambda (interns expression)
+ (make-sequence (cgen/expressions interns (sequence/actions expression)))))
+
+(define-method/cgen 'THE-ENVIRONMENT
+ (lambda (interns expression)
+ (make-the-environment)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.0 1987/03/10 13:24:44 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Copy Expression
+
+(declare (usual-integrations))
+\f
+(define (copy/external block expression)
+ (fluid-let ((root-block block))
+ (copy/expression block (environment/make) expression)))
+
+(define (copy/expressions block environment expressions)
+ (map (lambda (expression)
+ (copy/expression block environment expression))
+ expressions))
+
+(define (copy/expression block environment expression)
+ ((expression/method dispatch-vector expression)
+ block environment expression))
+
+(define dispatch-vector
+ (expression/make-dispatch-vector))
+
+(define define-method/copy
+ (expression/make-method-definer dispatch-vector))
+
+(define (copy/quotation quotation)
+ (fluid-let ((root-block false))
+ (let ((block (quotation/block quotation)))
+ (quotation/make block
+ (copy/expression block
+ (environment/make)
+ (quotation/expression quotation))))))
+
+(define-method/copy 'ACCESS
+ (lambda (block environment expression)
+ (access/make (copy/expression block environment
+ (access/environment expression))
+ (access/name expression))))
+
+(define-method/copy 'ASSIGNMENT
+ (lambda (block environment expression)
+ (assignment/make
+ block
+ (copy/variable block environment (assignment/variable expression))
+ (copy/expression block environment (assignment/value expression)))))
+
+(define-method/copy 'COMBINATION
+ (lambda (block environment expression)
+ (combination/make
+ (copy/expression block environment (combination/operator expression))
+ (copy/expressions block environment (combination/operands expression)))))
+
+(define-method/copy 'CONDITIONAL
+ (lambda (block environment expression)
+ (conditional/make
+ (copy/expression block environment (conditional/predicate expression))
+ (copy/expression block environment (conditional/consequent expression))
+ (copy/expression block environment
+ (conditional/alternative expression)))))
+
+(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/expression block environment (declaration/expression expression)))))
+
+(define-method/copy 'DELAY
+ (lambda (block environment expression)
+ (delay/make
+ (copy/expression block environment (delay/expression expression)))))
+
+(define-method/copy 'DISJUNCTION
+ (lambda (block environment expression)
+ (disjunction/make
+ (copy/expression block environment (disjunction/predicate expression))
+ (copy/expression block environment
+ (disjunction/alternative expression)))))
+
+(define-method/copy 'IN-PACKAGE
+ (lambda (block environment expression)
+ (in-package/make
+ (copy/expression block environment (in-package/environment expression))
+ (copy/quotation (in-package/quotation expression)))))
+
+(define-method/copy 'PROCEDURE
+ (lambda (block environment procedure)
+ (transmit-values (copy/block block environment (procedure/block procedure))
+ (lambda (block environment)
+ (let ((rename (make-renamer environment)))
+ (procedure/make block
+ (rename (procedure/name procedure))
+ (map rename (procedure/required procedure))
+ (map rename (procedure/optional procedure))
+ (let ((rest (procedure/rest procedure)))
+ (and rest (rename rest)))
+ (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)))))))
+
+(define-method/copy 'QUOTATION
+ (lambda (block environment expression)
+ (copy/quotation expression)))
+
+(define-method/copy 'REFERENCE
+ (lambda (block environment expression)
+ (reference/make block
+ (copy/variable block
+ environment
+ (reference/variable expression)))))
+
+(define-method/copy 'SEQUENCE
+ (lambda (block environment expression)
+ (sequence/make
+ (copy/expressions block environment (sequence/actions expression)))))
+
+(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
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.0 1987/03/10 13:24:48 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Environment Model
+
+(declare (usual-integrations))
+\f
+(define variable/assoc
+ (association-procedure eq? variable/name))
+
+(define (block/unsafe! block)
+ (if (block/safe? block)
+ (begin (block/set-safe?! block false)
+ (if (block/parent block)
+ (block/unsafe! (block/parent block))))))
+
+(define (block/lookup-name block name)
+ (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))))))
+
+(define (block/lookup-names block names)
+ (map (lambda (name)
+ (block/lookup-name block name))
+ names))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.0 1987/03/10 13:24:54 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Free Variable Analysis
+
+(declare (usual-integrations))
+\f
+(define (free/expressions expressions)
+ (if (null? expressions)
+ eq?-set/null
+ (eq?-set/union (free/expression (car expressions))
+ (free/expressions (cdr expressions)))))
+
+(define (free/expression expression)
+ ((expression/method dispatch-vector expression) expression))
+
+(define dispatch-vector
+ (expression/make-dispatch-vector))
+
+(define define-method/free
+ (expression/make-method-definer dispatch-vector))
+
+(define-method/free 'ACCESS
+ (lambda (expression)
+ (free/expression (access/environment expression))))
+
+(define-method/free 'ASSIGNMENT
+ (lambda (expression)
+ (eq?-set/adjoin (assignment/variable expression)
+ (free/expression (assignment/value expression)))))
+
+(define-method/free 'COMBINATION
+ (lambda (expression)
+ (eq?-set/union (free/expression (combination/operator expression))
+ (free/expressions (combination/operands expression)))))
+
+(define-method/free 'CONDITIONAL
+ (lambda (expression)
+ (eq?-set/union
+ (free/expression (conditional/predicate expression))
+ (eq?-set/union (free/expression (conditional/consequent expression))
+ (free/expression (conditional/alternative expression))))))
+
+(define-method/free 'CONSTANT
+ (lambda (expression)
+ eq?-set/null))
+
+(define-method/free 'DECLARATION
+ (lambda (expression)
+ (free/expression (declaration/expression expression))))
+\f
+(define-method/free 'DELAY
+ (lambda (expression)
+ (free/expression (delay/expression expression))))
+
+(define-method/free 'DISJUNCTION
+ (lambda (expression)
+ (eq?-set/union (free/expression (disjunction/predicate expression))
+ (free/expression (disjunction/alternative expression)))))
+
+(define-method/free 'IN-PACKAGE
+ (lambda (expression)
+ (free/expression (in-package/environment expression))))
+
+(define-method/free 'PROCEDURE
+ (lambda (expression)
+ (eq?-set/difference (free/expression (procedure/body expression))
+ (block/bound-variables (procedure/block expression)))))
+
+(define-method/free 'OPEN-BLOCK
+ (lambda (expression)
+ (eq?-set/difference
+ (eq?-set/union (free/expressions (open-block/values expression))
+ (let loop ((actions (open-block/actions expression)))
+ (cond ((null? actions) eq?-set/null)
+ ((eq? (car actions) open-block/value-marker)
+ (loop (cdr actions)))
+ (else
+ (eq?-set/union (free/expression (car actions))
+ (loop (cdr actions)))))))
+ (block/bound-variables (open-block/block expression)))))
+
+(define-method/free 'QUOTATION
+ (lambda (expression)
+ eq?-set/null))
+
+(define-method/free 'REFERENCE
+ (lambda (expression)
+ (eq?-set/singleton (reference/variable expression))))
+
+(define-method/free 'SEQUENCE
+ (lambda (expression)
+ (free/expressions (sequence/actions expression))))
+
+(define-method/free 'THE-ENVIRONMENT
+ (lambda (expression)
+ eq?-set/null))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gconst.scm,v 3.0 1987/03/10 13:24:58 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Global Constants List
+
+(declare (usual-integrations))
+\f
+;;; This is a list of names that are bound in the global environment.
+;;; Normally the compiler will replace references to one of these
+;;; names with the value of that name, which is a constant.
+
+(define global-constant-objects
+ '(TRUE FALSE SYSTEM-GLOBAL-ENVIRONMENT
+
+ SCODE-EVAL FORCE WITH-THREADED-CONTINUATION
+ SET-INTERRUPT-ENABLES! WITH-INTERRUPT-MASK WITH-INTERRUPTS-REDUCED
+ GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED
+ PRIMITIVE-PROCEDURE-ARITY NOT FALSE?
+ STRING->SYMBOL ERROR-PROCEDURE
+
+ ;; Environment
+ LEXICAL-REFERENCE LEXICAL-ASSIGNMENT LOCAL-ASSIGNMENT
+ LEXICAL-UNASSIGNED? LEXICAL-UNBOUND? LEXICAL-UNREFERENCEABLE?
+
+ ;; Pointers
+ EQ?
+ PRIMITIVE-SET-TYPE MAKE-NON-POINTER-OBJECT
+ PRIMITIVE-TYPE? PRIMITIVE-TYPE PRIMITIVE-DATUM
+ OBJECT-DANGEROUS? MAKE-OBJECT-SAFE MAKE-OBJECT-DANGEROUS
+
+ ;; Numbers
+ ZERO? POSITIVE? NEGATIVE? 1+ -1+
+ INTEGER-DIVIDE INTEGER-DIVIDE-QUOTIENT INTEGER-DIVIDE-REMAINDER
+ TRUNCATE ROUND FLOOR CEILING
+ SQRT EXP LOG SIN COS
+
+ ;; Basic Compound Datatypes
+ CONS PAIR? CAR CDR SET-CAR! SET-CDR! GENERAL-CAR-CDR
+ NULL? LENGTH MEMQ ASSQ FIRST HEAD EMPTY-STREAM?
+
+ VECTOR-CONS VECTOR-LENGTH VECTOR-REF VECTOR-SET!
+ LIST->VECTOR SUBVECTOR->LIST
+
+ ;; Strings
+ STRING-ALLOCATE STRING? STRING-REF STRING-SET!
+ STRING-LENGTH STRING-MAXIMUM-LENGTH SET-STRING-LENGTH!
+ SUBSTRING=? SUBSTRING-CI=? SUBSTRING<?
+ SUBSTRING-MOVE-RIGHT! SUBSTRING-MOVE-LEFT!
+ SUBSTRING-FIND-NEXT-CHAR-IN-SET
+ SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET
+ SUBSTRING-MATCH-FORWARD SUBSTRING-MATCH-BACKWARD
+ SUBSTRING-MATCH-FORWARD-CI SUBSTRING-MATCH-BACKWARD-CI
+ SUBSTRING-UPCASE! SUBSTRING-DOWNCASE! STRING-HASH
+
+ ;; Byte Vectors (actually, String/Character operations)
+ VECTOR-8B-REF VECTOR-8B-SET! VECTOR-8B-FILL!
+ VECTOR-8B-FIND-NEXT-CHAR VECTOR-8B-FIND-PREVIOUS-CHAR
+ VECTOR-8B-FIND-NEXT-CHAR-CI VECTOR-8B-FIND-PREVIOUS-CHAR-CI
+
+ BIT-STRING-ALLOCATE MAKE-BIT-STRING BIT-STRING?
+ BIT-STRING-LENGTH BIT-STRING-REF BIT-STRING-CLEAR! BIT-STRING-SET!
+ BIT-STRING-ZERO? BIT-STRING=?
+ BIT-STRING-FILL! BIT-STRING-MOVE! BIT-STRING-MOVEC!
+ BIT-STRING-OR! BIT-STRING-AND! BIT-STRING-ANDC!
+ BIT-SUBSTRING-MOVE-RIGHT!
+ BIT-STRING->UNSIGNED-INTEGER UNSIGNED-INTEGER->BIT-STRING
+ READ-BITS! WRITE-BITS!
+
+ MAKE-CELL CELL? CELL-CONTENTS SET-CELL-CONTENTS!
+
+ ;; Characters
+ MAKE-CHAR CHAR-CODE CHAR-BITS
+ CHAR-ASCII? ASCII->CHAR CHAR->ASCII
+ INTEGER->CHAR CHAR->INTEGER
+ CHAR-UPCASE CHAR-DOWNCASE
+
+ ;; System Compound Datatypes
+ SYSTEM-PAIR-CONS SYSTEM-PAIR?
+ SYSTEM-PAIR-CAR SYSTEM-PAIR-SET-CAR!
+ SYSTEM-PAIR-CDR SYSTEM-PAIR-SET-CDR!
+
+ SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-SET-CXR0!
+ SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-SET-CXR1!
+ SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-SET-CXR2!
+
+ SYSTEM-LIST-TO-VECTOR SYSTEM-SUBVECTOR-TO-LIST SYSTEM-VECTOR?
+ SYSTEM-VECTOR-SIZE SYSTEM-VECTOR-REF SYSTEM-VECTOR-SET!
+ ))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.0 1987/03/10 13:25:03 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: System Construction
+
+(in-package system-global-environment
+(declare (usual-integrations))
+\f
+(define sf)
+(load "$zcomp/base/load" system-global-environment)
+
+(load-system system-global-environment
+ 'PACKAGE/BETA
+ '(SYSTEM-GLOBAL-ENVIRONMENT)
+ '(
+ (PACKAGE/BETA
+ "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
+ )
+
+ (PACKAGE/TOP-LEVEL
+ "toplev.bin" ;Top Level
+ )
+
+ (PACKAGE/TRANSFORM
+ "xform.bin" ;SCode -> Internal
+ )
+
+ (PACKAGE/INTEGRATE
+ "subst.bin" ;Beta Substitution Optimizer
+ )
+
+ (PACKAGE/CGEN
+ "cgen.bin" ;Internal -> SCode
+ )
+
+ (PACKAGE/EXPANSION
+ "usiexp.bin" ;Usual Integrations: Expanders
+ )
+
+ (PACKAGE/DECLARATION-PARSER
+ "pardec.bin" ;Declaration Parser
+ )
+
+ (PACKAGE/COPY
+ "copy.bin" ;Copy Expressions
+ )
+
+ (PACKAGE/FREE
+ "free.bin" ;Free Variable Analysis
+ )
+
+ (PACKAGE/SAFE?
+ "safep.bin" ;Safety Analysis
+ )
+
+ ))
+
+(in-package package/beta
+ (define beta/system
+ (make-environment
+ (define :name "Beta")
+ (define :version 3)
+ (define :modification 0)))
+ (add-system! beta/system)
+ (beta/initialize!))
+
+;;; end IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT
+)
\ No newline at end of file
--- /dev/null
+#| -*-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 $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Data Types
+
+(declare (usual-integrations))
+\f
+(let-syntax ()
+
+(define-syntax define-type
+ (macro (name enumeration slots)
+ (let ((enumerand (symbol-append name '/ENUMERAND)))
+ `(BEGIN
+ (DEFINE ,enumerand
+ (NAME->ENUMERAND ,(symbol-append 'ENUMERATION/ enumeration) ',name))
+ ((ACCESS ADD-UNPARSER-SPECIAL-OBJECT! UNPARSER-PACKAGE) ,enumerand
+ (LAMBDA (OBJECT)
+ (UNPARSE-WITH-BRACKETS
+ (LAMBDA ()
+ (WRITE ',name)
+ (WRITE-STRING " ")
+ (WRITE (HASH OBJECT))))))
+ (DEFINE ,(symbol-append name '?) (OBJECT/PREDICATE ,enumerand))
+ ,@(let loop ((slots slots) (index 1))
+ (if (null? slots)
+ '()
+ (let ((slot (car slots)))
+ (let ((ref-name (symbol-append name '/ slot))
+ (set-name (symbol-append name '/SET- slot '!)))
+ `((DECLARE (INTEGRATE-OPERATOR ,ref-name ,set-name))
+ (DEFINE (,ref-name ,name)
+ (DECLARE (INTEGRATE ,name))
+ (VECTOR-REF ,name ,index))
+ (DEFINE (,set-name ,name ,slot)
+ (DECLARE (INTEGRATE ,name ,slot))
+ (VECTOR-SET! ,name ,index ,slot))
+ ,@(loop (cdr slots) (1+ index)))))))))))
+
+(define-syntax define-simple-type
+ (macro (name enumeration slots)
+ (let ((make-name (symbol-append name '/MAKE)))
+ `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,make-name))
+ (DEFINE (,make-name ,@slots)
+ (DECLARE (INTEGRATE ,@slots))
+ (OBJECT/ALLOCATE ,(symbol-append name '/ENUMERAND) ,@slots))
+ (DEFINE-TYPE ,name ,enumeration ,slots)))))
+
+(declare (integrate object/allocate)
+ (integrate-operator object/enumerand))
+
+(define object/allocate vector)
+
+(define (object/enumerand object)
+ (declare (integrate object))
+ (vector-ref object 0))
+
+(define (object/predicate enumerand)
+ (lambda (object)
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (eq? enumerand (vector-ref object 0)))))
+\f
+;;;; 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))
+
+(declare (integrate-operator enumerand/enumeration enumerand/name
+ enumerand/index enumeration/cardinality
+ index->enumerand))
+
+(define (enumerand/enumeration enumerand)
+ (declare (integrate enumerand))
+ (vector-ref enumerand 0))
+
+(define (enumerand/name enumerand)
+ (declare (integrate enumerand))
+ (vector-ref enumerand 1))
+
+(define (enumerand/index enumerand)
+ (declare (integrate enumerand))
+ (vector-ref enumerand 2))
+
+(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))))))))
+\f
+;;;; Random Types
+
+(define enumeration/random
+ (enumeration/make
+ '(BLOCK
+ DELAYED-INTEGRATION
+ VARIABLE
+ )))
+
+(define-type block random
+ (parent children safe? declarations bound-variables expression))
+
+(define (block/make parent safe?)
+ (let ((block
+ (object/allocate block/enumerand parent '() safe? '() '()
+ false)))
+ (if parent
+ (block/set-children! parent (cons block (block/children parent))))
+ block))
+
+(define-type delayed-integration random
+ (state environment operations value))
+
+(define (delayed-integration/make operations expression)
+ (object/allocate delayed-integration/enumerand 'NOT-INTEGRATED false
+ operations expression))
+
+(define-simple-type variable random
+ (block name))
+
+(define (variable/make&bind! block name)
+ (let ((variable (variable/make block name)))
+ (block/set-bound-variables! block
+ (cons variable
+ (block/bound-variables block)))
+ variable))
+
+(define open-block/value-marker
+ "value marker")
+\f
+;;;; Expression Types
+
+(define enumeration/expression
+ (enumeration/make
+ '(ACCESS
+ ASSIGNMENT
+ COMBINATION
+ CONDITIONAL
+ CONSTANT
+ DECLARATION
+ DELAY
+ DISJUNCTION
+ IN-PACKAGE
+ OPEN-BLOCK
+ PROCEDURE
+ QUOTATION
+ REFERENCE
+ SEQUENCE
+ THE-ENVIRONMENT
+ )))
+
+(define (expression/make-dispatch-vector)
+ (make-vector (enumeration/cardinality enumeration/expression)))
+
+(define (expression/make-method-definer dispatch-vector)
+ (lambda (type-name method)
+ (vector-set! dispatch-vector
+ (enumerand/index
+ (name->enumerand enumeration/expression type-name))
+ method)))
+
+(declare (integrate-operator expression/method name->method))
+
+(define (expression/method dispatch-vector expression)
+ (declare (integrate dispatch-vector expression))
+ (vector-ref dispatch-vector (enumerand/index (object/enumerand expression))))
+
+(define (name->method dispatch-vector name)
+ ;; Useful for debugging
+ (declare (integrate dispatch-vector name))
+ (vector-ref dispatch-vector
+ (enumerand/index (name->enumerand enumeration/expression name))))
+\f
+(define-simple-type access expression (environment name))
+(define-simple-type assignment expression (block variable value))
+(define-simple-type combination expression (operator operands))
+(define-simple-type conditional expression (predicate consequent alternative))
+(define-simple-type constant expression (value))
+(define-simple-type declaration expression (declarations expression))
+(define-simple-type delay expression (expression))
+(define-simple-type disjunction expression (predicate alternative))
+(define-simple-type in-package expression (environment quotation))
+(define-simple-type open-block expression (block variables values actions))
+(define-simple-type procedure expression
+ (block name required optional rest body))
+(define-simple-type quotation expression (block expression))
+(define-simple-type reference expression (block variable))
+(define-simple-type sequence expression (actions))
+(define-simple-type the-environment expression (block))
+
+;;; end LET-SYNTAX
+)
\ No newline at end of file
--- /dev/null
+#| -*-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 $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Parse Declarations
+
+(declare (usual-integrations))
+\f
+(define (declarations/known? declaration)
+ (assq (car declaration) known-declarations))
+
+(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)))))
+
+(define (bindings/cons block before-bindings?)
+ (lambda (bindings applicator names global?)
+ (let ((result
+ (if global?
+ (return-3 applicator operations/bind-global names)
+ (return-3 applicator operations/bind
+ (block/lookup-names block names)))))
+ (transmit-values bindings
+ (lambda (before-bindings after-bindings)
+ (if before-bindings?
+ (return-2 (cons result before-bindings) after-bindings)
+ (return-2 before-bindings (cons result after-bindings))))))))
+
+(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?)))
+
+(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)))))
+
+(define (define-declaration name before-bindings? parser)
+ (let ((entry (assq name known-declarations)))
+ (if entry
+ (set-cdr! entry (return-2 before-bindings? parser))
+ (set! known-declarations
+ (cons (cons name (return-2 before-bindings? parser))
+ known-declarations)))))
+
+(define known-declarations
+ '())
+\f
+;;;; Integration of System Constants
+
+(define-declaration 'USUAL-INTEGRATIONS true
+ (lambda (block table/cons table deletions)
+ (let ((finish
+ (lambda (table operation names values)
+ (transmit-values
+ (if (null? deletions)
+ (return-2 names values)
+ (let deletion-loop ((names names) (values values))
+ (cond ((null? names) (return-2 '() '()))
+ ((memq (car names) deletions)
+ (deletion-loop (cdr names) (cdr values)))
+ (else
+ (cons-multiple
+ (return-2 (car names) (car values))
+ (deletion-loop (cdr names) (cdr values)))))))
+ (lambda (names values)
+ (bind/values table/cons table operation false names
+ values))))))
+ (finish (finish table 'INTEGRATE
+ usual-integrations/constant-names
+ usual-integrations/constant-values)
+ 'EXPAND
+ usual-integrations/expansion-names
+ usual-integrations/expansion-values))))
+
+(define-declaration 'INTEGRATE-PRIMITIVE-PROCEDURES false
+ (lambda (block table/cons table specifications)
+ (transmit-values
+ (let loop ((specifications specifications))
+ (if (null? specifications)
+ (return-2 '() '())
+ (cons-multiple (parse-primitive-specification
+ block
+ (car specifications))
+ (loop (cdr specifications)))))
+ (lambda (names values)
+ (bind/values table/cons table 'INTEGRATE true names values)))))
+
+(define (parse-primitive-specification block specification)
+ (let ((finish
+ (lambda (variable-name primitive-name)
+ (return-2 (block/lookup-name block variable-name)
+ (make-primitive-procedure
+ (constant->integration-info primitive-name))))))
+ (cond ((and (pair? specification)
+ (symbol? (car specification))
+ (pair? (cdr specification))
+ (symbol? (cadr specification))
+ (null? (cddr specification)))
+ (finish (first specification) (second specification)))
+ ((symbol? specification) (finish specification specification))
+ (else (error "Bad primitive specification" specification)))))
+\f
+;;;; Integration of User Code
+
+(define-declaration 'INTEGRATE false
+ (lambda (block table/cons table names)
+ (bind/no-values table/cons table 'INTEGRATE true names)))
+
+(define-declaration 'INTEGRATE-OPERATOR false
+ (lambda (block table/cons table names)
+ (bind/no-values table/cons table 'INTEGRATE-OPERATOR true names)))
+
+(define-declaration 'INTEGRATE-EXTERNAL true
+ (lambda (block table/cons table specifications)
+ (accumulate
+ (lambda (extern table)
+ (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))))))
+ table
+ (mapcan read-externs-file
+ (mapcan specification->pathnames specifications)))))
+
+(define (specification->pathnames specification)
+ (let ((value
+ (scode-eval (syntax specification system-global-syntax-table)
+ (access syntax-environment syntaxer-package))))
+ (if (pair? value)
+ (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))))))
+ (if info
+ (finish info)
+ (variable/final-value variable environment finish if-not))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.0 1987/03/10 13:25:18 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Beta Substitution
+
+(declare (usual-integrations))
+\f
+(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))))))
+
+(define (operations/bind-block operations block)
+ (let ((declarations (block/declarations block)))
+ (if (null? declarations)
+ (operations/shadow operations (block/bound-variables block))
+ (transmit-values (declarations/binders declarations)
+ (lambda (before-bindings after-bindings)
+ (after-bindings
+ (operations/shadow (before-bindings operations)
+ (block/bound-variables block))))))))
+
+(define (integrate/expressions operations environment expressions)
+ (map (lambda (expression)
+ (integrate/expression operations environment expression))
+ expressions))
+
+(define (integrate/expression operations environment expression)
+ ((expression/method dispatch-vector expression)
+ operations environment expression))
+
+(define dispatch-vector
+ (expression/make-dispatch-vector))
+
+(define define-method/integrate
+ (expression/make-method-definer dispatch-vector))
+\f
+;;;; Lookup
+
+(define-method/integrate 'REFERENCE
+ (lambda (operations environment expression)
+ (operations/lookup operations (reference/variable expression)
+ (lambda (operation info)
+ (case operation
+ ((INTEGRATE-OPERATOR EXPAND) expression)
+ ((INTEGRATE) (integrate/name expression info environment))
+ (else (error "Unknown operation" operation))))
+ (lambda () expression))))
+
+(define (integrate/reference-operator operations environment operator operands)
+ (let ((dont-integrate
+ (lambda ()
+ (combination/make operator operands))))
+ (operations/lookup operations (reference/variable operator)
+ (lambda (operation info)
+ (case operation
+ ((#F) (dont-integrate))
+ ((INTEGRATE INTEGRATE-OPERATOR)
+ (integrate/combination operations
+ environment
+ (integrate/name operator info environment)
+ operands))
+ ((EXPAND)
+ (info operands
+ identity-procedure ;expanded value can't be optimized further.
+ dont-integrate))
+ (else (error "Unknown operation" operation))))
+ dont-integrate)))
+
+(define-method/integrate 'ASSIGNMENT
+ (lambda (operations environment assignment)
+ (let ((variable (assignment/variable assignment)))
+ (operations/lookup operations variable
+ (lambda (operation info)
+ (case operation
+ ((INTEGRATE INTEGRATE-OPERATOR EXPAND)
+ (warn "Attempt to assign integrated name"
+ (variable/name variable)))
+ (else (error "Unknown operation" operation))))
+ (lambda () 'DONE))
+ (assignment/make (assignment/block assignment)
+ variable
+ (integrate/expression operations
+ environment
+ (assignment/value assignment))))))
+\f
+;;;; Binding
+
+(define-method/integrate 'OPEN-BLOCK
+ (lambda (operations environment expression)
+ (let ((operations
+ (operations/bind-block operations (open-block/block expression))))
+ (transmit-values
+ (environment/recursive-bind operations
+ environment
+ (open-block/variables expression)
+ (open-block/values expression))
+ (lambda (environment values)
+ (integrate/open-block operations
+ environment
+ expression
+ values))))))
+
+(define (integrate/open-block operations environment expression values)
+ (open-block/make (open-block/block expression)
+ (open-block/variables expression)
+ values
+ (map (lambda (action)
+ (if (eq? action open-block/value-marker)
+ action
+ (integrate/expression operations
+ environment
+ action)))
+ (open-block/actions expression))))
+
+(define (integrate/procedure operations environment procedure)
+ (let ((block (procedure/block procedure)))
+ (procedure/make block
+ (procedure/name procedure)
+ (procedure/required procedure)
+ (procedure/optional procedure)
+ (procedure/rest procedure)
+ (integrate/expression (operations/bind-block operations
+ block)
+ environment
+ (procedure/body procedure)))))
+
+(define-method/integrate 'PROCEDURE
+ integrate/procedure)
+\f
+(define-method/integrate 'COMBINATION
+ (lambda (operations environment combination)
+ (integrate/combination
+ operations
+ environment
+ (combination/operator combination)
+ (integrate/expressions operations
+ environment
+ (combination/operands combination)))))
+
+(define (integrate/combination operations environment operator operands)
+ (if (reference? operator)
+ (integrate/reference-operator operations
+ environment
+ operator
+ operands)
+ (combination/optimizing-make
+ (if (procedure? operator)
+ (integrate/procedure-operator operations
+ environment
+ operator
+ operands)
+ (let ((operator
+ (integrate/expression operations environment operator)))
+ (if (procedure? operator)
+ (integrate/procedure-operator operations
+ environment
+ operator
+ operands)
+ operator)))
+ operands)))
+
+(define (integrate/procedure-operator operations environment procedure
+ operands)
+ (integrate/procedure operations
+ (simulate-application environment procedure operands)
+ procedure))
+
+(define-method/integrate 'DECLARATION
+ (lambda (operations environment declaration)
+ (let ((declarations (declaration/declarations declaration)))
+ (declaration/make
+ declarations
+ (transmit-values (declarations/binders declarations)
+ (lambda (before-bindings after-bindings)
+ (integrate/expression (after-bindings (before-bindings operations))
+ environment
+ (declaration/expression declaration))))))))
+\f
+;;;; Easy Cases
+
+(define-method/integrate 'CONSTANT
+ (lambda (operations environment expression)
+ expression))
+
+(define-method/integrate 'THE-ENVIRONMENT
+ (lambda (operations environment expression)
+ expression))
+
+(define-method/integrate 'QUOTATION
+ (lambda (operations environment expression)
+ (integrate/quotation expression)))
+
+(define-method/integrate 'CONDITIONAL
+ (lambda (operations environment expression)
+ (conditional/make
+ (integrate/expression operations environment
+ (conditional/predicate expression))
+ (integrate/expression operations environment
+ (conditional/consequent expression))
+ (integrate/expression operations environment
+ (conditional/alternative expression)))))
+
+(define-method/integrate 'DISJUNCTION
+ (lambda (operations environment expression)
+ (disjunction/make
+ (integrate/expression operations environment
+ (disjunction/predicate expression))
+ (integrate/expression operations environment
+ (disjunction/alternative expression)))))
+\f
+(define-method/integrate 'SEQUENCE
+ (lambda (operations environment expression)
+ (sequence/make
+ (integrate/expressions operations environment
+ (sequence/actions expression)))))
+
+(define-method/integrate 'ACCESS
+ (lambda (operations environment expression)
+ (access/make (integrate/expression operations environment
+ (access/environment expression))
+ (access/name expression))))
+
+(define-method/integrate 'DELAY
+ (lambda (operations environment expression)
+ (delay/make
+ (integrate/expression operations environment
+ (delay/expression expression)))))
+
+(define-method/integrate 'IN-PACKAGE
+ (lambda (operations environment expression)
+ (in-package/make (integrate/expression operations environment
+ (in-package/environment expression))
+ (integrate/quotation (in-package/quotation expression)))))
+
+(define (integrate/quotation quotation)
+ (transmit-values (integrate/top-level (quotation/block quotation)
+ (quotation/expression quotation))
+ (lambda (operations environment expression)
+ expression)))
+\f
+;;;; Environment
+
+(define (environment/recursive-bind operations environment variables values)
+ ;; Used to implement mutually-recursive definitions that can
+ ;; integrate one another. When circularities are detected within
+ ;; the definition-reference graph, integration is disabled.
+ (let ((values
+ (map (lambda (value)
+ (delayed-integration/make operations value))
+ values)))
+ (let ((environment
+ (environment/bind-multiple environment variables values)))
+ (for-each (lambda (value)
+ (delayed-integration/set-environment! value environment))
+ values)
+ (return-2 environment
+ (map delayed-integration/force values)))))
+
+(define (integrate/name reference info environment)
+ (let ((variable (reference/variable reference)))
+ (let ((finish
+ (lambda (value)
+ (copy/expression (reference/block reference) value))))
+ (if info
+ (finish (info))
+ (environment/lookup environment variable
+ (lambda (value)
+ (if (delayed-integration? value)
+ (if (delayed-integration/in-progress? value)
+ reference
+ (finish (delayed-integration/force value)))
+ (finish value)))
+ (lambda () reference))))))
+
+(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)))
+ (lambda ()
+ (warn "Unable to integrate" (variable/name variable))
+ (if-not))))
+\f
+(define (simulate-application environment procedure operands)
+
+ (define (match-required environment required operands)
+ (cond ((null? required)
+ (match-optional environment
+ (procedure/optional procedure)
+ operands))
+ ((null? operands)
+ (error "Too few operands in call to procedure" procedure))
+ (else
+ (match-required (environment/bind environment
+ (car required)
+ (car operands))
+ (cdr required)
+ (cdr operands)))))
+
+ (define (match-optional environment optional operands)
+ (cond ((null? optional)
+ (match-rest environment (procedure/rest procedure) operands))
+ ((null? operands)
+ (match-rest environment (procedure/rest procedure) '()))
+ (else
+ (match-optional (environment/bind environment
+ (car optional)
+ (car operands))
+ (cdr optional)
+ (cdr operands)))))
+
+ (define (match-rest environment rest operands)
+ (cond (rest
+ ;; Other cases are too hairy -- don't bother.
+ (if (null? operands)
+ (environment/bind environment rest (constant/make '()))
+ environment))
+ ((null? operands)
+ environment)
+ (else
+ (error "Too many operands in call to procedure" procedure))))
+
+ (match-required environment (procedure/required procedure) operands))
+\f
+(define (environment/make)
+ '())
+
+(define (environment/bind environment variable value)
+ (cons (cons variable value) environment))
+
+(define (environment/bind-multiple 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 (delayed-integration/in-progress? delayed-integration)
+ (eq? (delayed-integration/state delayed-integration) 'BEING-INTEGRATED))
+
+(define (delayed-integration/force delayed-integration)
+ (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)))
+ (delayed-integration/set-state! delayed-integration
+ 'BEING-INTEGRATED)
+ (delayed-integration/set-environment! delayed-integration false)
+ (delayed-integration/set-operations! delayed-integration false)
+ (delayed-integration/set-value! delayed-integration false)
+ (integrate/expression operations environment expression))))
+ (delayed-integration/set-state! delayed-integration 'INTEGRATED)
+ (delayed-integration/set-value! delayed-integration value)))
+ ((INTEGRATED) 'DONE)
+ ((BEING-INTEGRATED)
+ (error "Attempt to re-force delayed integration" delayed-integration))
+ (else
+ (error "Delayed integration has unknown state" delayed-integration)))
+ (delayed-integration/value delayed-integration))
+\f
+;;;; Optimizations
+
+(define combination/optimizing-make)
+(let ()
+
+(set! combination/optimizing-make
+ (lambda (operator operands)
+ (let ((dont-optimize
+ (lambda ()
+ (combination/make operator operands))))
+ (if (and (procedure? operator)
+ (null? (procedure/optional operator))
+ (not (procedure/rest operator))
+ (block/safe? (procedure/block operator))
+ (not (open-block? (procedure/body operator))))
+ (let ((body (procedure/body operator)))
+ (let ((referenced (free/expression body)))
+ (if (not (memq (procedure/name operator)
+ referenced)) ;i.e. not a loop
+ ;; Simple LET-like combination. Delete any
+ ;; unreferenced parameters. If no parameters
+ ;; remain, delete the combination and lambda.
+ (transmit-values
+ ((delete-unused-parameters referenced)
+ (procedure/required operator)
+ operands)
+ (lambda (required operands)
+ (if (null? required)
+ body
+ (combination/make
+ (procedure/make (procedure/block operator)
+ (procedure/name operator)
+ required '() false body)
+ operands))))
+ (dont-optimize))))
+ (dont-optimize)))))
+
+(define (delete-unused-parameters referenced)
+ (define (loop parameters operands)
+ (if (null? parameters)
+ (return-2 '() operands)
+ (let ((rest (loop (cdr parameters) (cdr operands))))
+ (if (memq (car parameters) referenced)
+ (transmit-values rest
+ (lambda (parameters* operands*)
+ (return-2 (cons (car parameters) parameters*)
+ (cons (car operands) operands*))))
+ rest))))
+ loop)
+
+;;; end COMBINATION/OPTIMIZING-MAKE
+)
+\f
+#| This is too much of a pain to do now. Maybe later.
+
+(define procedure/optimizing-make)
+(let ()
+
+(set! procedure/optimizing-make
+ (lambda (block name required optional rest auxiliary body)
+ (if (and (not (null? auxiliary))
+ optimize-open-blocks?
+ (block/safe? block))
+ (let ((used
+ (used-auxiliaries (list-transform-positive auxiliary
+ variable-value)
+ (free/expression body))))
+ (procedure/make block name required optional rest used
+ (delete-unused-definitions used body)))
+ (procedure/make block name required optional rest auxiliary body))))
+
+(define (delete-unused-definitions used body)
+ ???)
+
+;;; A non-obvious program: (1) Collect all of the free references to
+;;; the block's bound variables which occur in the body of the block.
+;;; (2) Examine each of the values associated with that set of free
+;;; references, and add any new free references to the collection.
+;;; (3) Continue looping until no more free references are added.
+
+(define (used-auxiliaries auxiliary initial-used)
+ (let ((used (eq?-set/intersection auxiliary initial-used)))
+ (if (null? used)
+ '()
+ (let loop ((previous-used used) (new-used used))
+ (for-each (lambda (value)
+ (for-each (lambda (variable)
+ (if (and (memq variable auxiliary)
+ (not (memq variable used)))
+ (set! used (cons variable used))))
+ (free/expression value)))
+ (map variable/value new-used))
+ (let ((diffs
+ (let note-diffs ((used used))
+ (if (eq? used previous-used)
+ '()
+ (cons (cdar used)
+ (note-diffs (cdr used)))))))
+ (if (null? diffs)
+ used
+ (loop used diffs)))))))
+
+;;; end PROCEDURE/OPTIMIZING-MAKE
+)
+|#
\ No newline at end of file
--- /dev/null
+#| -*-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 $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Tables
+
+(declare (usual-integrations))
+\f
+;;;; Operations
+
+(define (operations/make)
+ (cons '() '()))
+
+(define (operations/lookup operations variable if-found if-not)
+ (let ((entry (assq variable (car operations)))
+ (finish
+ (lambda (entry)
+ (if-found (vector-ref (cdr entry) 1)
+ (vector-ref (cdr entry) 2)))))
+ (if entry
+ (if (cdr entry) (finish entry) (if-not))
+ (let ((entry (assq (variable/name variable) (cdr operations))))
+ (if entry (finish entry) (if-not))))))
+
+(define (operations/shadow operations variables)
+ (cons (map* (car operations)
+ (lambda (variable) (cons variable false))
+ variables)
+ (cdr operations)))
+
+(define (operations/bind-global operations operation export? names values)
+ (cons (car operations)
+ (map* (cdr operations)
+ (lambda (name value)
+ (cons name (vector export? operation value)))
+ names values)))
+
+(define (operations/bind operations operation export? names #!optional values)
+ (cons (let ((make-binding
+ (lambda (name value)
+ (cons name (vector export? operation value)))))
+ (if (unassigned? values)
+ (map* (car operations)
+ (lambda (name) (make-binding name false))
+ names)
+ (map* (car operations) make-binding names values)))
+ (cdr operations)))
+
+(define (operations/extract-external operations procedure)
+ (let loop ((elements (car operations)))
+ (if (null? elements)
+ '()
+ (let ((value (cdar elements)) (rest (loop (cdr elements))))
+ (if (and value (vector-ref value 0))
+ (procedure (caar elements) (vector-ref value 1)
+ (vector-ref value 2)
+ (lambda (value) (cons value rest))
+ (lambda () rest))
+ rest)))))
\ No newline at end of file
--- /dev/null
+#| -*-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 $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Top Level
+
+(declare (usual-integrations))
+\f
+;;;; User Interface
+
+(define generate-unfasl-files? false
+ "Set this non-false to cause unfasl files to be generated by default.")
+
+(define optimize-open-blocks? false
+ "Set this non-false to eliminate unreferenced auxiliary definitions.
+Currently this optimization is not implemented.")
+
+(define (integrate/procedure procedure declarations)
+ (if (compound-procedure? procedure)
+ (procedure-components procedure
+ (lambda (*lambda environment)
+ (scode-eval (integrate/scode *lambda declarations false)
+ 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/scode scode declarations receiver)
+ (integrate/simple identity-procedure scode declarations receiver))
+
+(define (sf input-string #!optional bin-string spec-string)
+ (if (unassigned? bin-string) (set! bin-string false))
+ (if (unassigned? spec-string) (set! spec-string false))
+ (syntax-file input-string bin-string spec-string))
+
+(define (scold input-string #!optional bin-string spec-string)
+ "Use this only for syntaxing the cold-load root file.
+Currently only the 68000 implementation needs this."
+ (if (unassigned? bin-string) (set! bin-string false))
+ (if (unassigned? spec-string) (set! spec-string false))
+ (fluid-let ((wrapping-hook wrap-with-control-point))
+ (syntax-file input-string bin-string spec-string)))
+\f
+;;;; File Syntaxer
+
+(define sf/default-input-pathname
+ (make-pathname false false false "scm" 'NEWEST))
+
+(define sf/default-externs-pathname
+ (make-pathname false false false "ext" 'NEWEST))
+
+(define sf/output-pathname-type "bin")
+(define sf/unfasl-pathname-type "unf")
+
+(define (syntax-file input-string bin-string spec-string)
+ (let ((eval-sf-expression
+ (lambda (input-string)
+ (let ((input-path
+ (pathname->input-truename
+ (merge-pathnames (->pathname input-string)
+ sf/default-input-pathname))))
+ (if (not input-path)
+ (error "SF: File does not exist" input-string))
+ (let ((bin-path
+ (let ((bin-path
+ (pathname-new-type input-path
+ sf/output-pathname-type)))
+ (if bin-string
+ (merge-pathnames (->pathname bin-string) bin-path)
+ bin-path))))
+ (let ((spec-path
+ (and (or spec-string generate-unfasl-files?)
+ (let ((spec-path
+ (pathname-new-type bin-path
+ sf/unfasl-pathname-type)))
+ (if spec-string
+ (merge-pathnames (->pathname spec-string)
+ spec-path)
+ spec-path)))))
+ (syntax-file* input-path bin-path spec-path)))))))
+ (if (list? input-string)
+ (for-each (lambda (input-string)
+ (eval-sf-expression input-string))
+ input-string)
+ (eval-sf-expression input-string)))
+ *the-non-printing-object*)
+\f
+(define (syntax-file* input-pathname bin-pathname spec-pathname)
+ (let ((start-date (date))
+ (start-time (time))
+ (input-filename (pathname->string input-pathname))
+ (bin-filename (pathname->string bin-pathname))
+ (spec-filename (and spec-pathname (pathname->string spec-pathname))))
+ (newline)
+ (write-string "Syntax file: ")
+ (write input-filename)
+ (write-string " ")
+ (write bin-filename)
+ (write-string " ")
+ (write spec-filename)
+ (transmit-values (integrate/file input-pathname '() spec-pathname)
+ (lambda (expression externs events)
+ (fasdump (wrapping-hook
+ (make-comment `((SOURCE-FILE . ,input-filename)
+ (DATE . ,start-date)
+ (TIME . ,start-time)
+ (FLUID-LET . ,*fluid-let-type*))
+ (set! expression false)))
+ bin-pathname)
+ (write-externs-file (pathname-new-type
+ bin-pathname
+ (pathname-type sf/default-externs-pathname))
+ (set! externs false))
+ (if spec-pathname
+ (begin (newline)
+ (write-string "Writing ")
+ (write spec-filename)
+ (with-output-to-file spec-pathname
+ (lambda ()
+ (newline)
+ (write `(DATE ,start-date ,start-time))
+ (newline)
+ (write `(FLUID-LET ,*fluid-let-type*))
+ (newline)
+ (write `(SOURCE-FILE ,input-filename))
+ (newline)
+ (write `(BINARY-FILE ,bin-filename))
+ (for-each (lambda (event)
+ (newline)
+ (write `(,(car event)
+ (RUNTIME ,(cdr event)))))
+ events)))
+ (write-string " -- done")))))))
+\f
+(define (read-externs-file pathname)
+ (fasload (merge-pathnames (->pathname pathname)
+ sf/default-externs-pathname)))
+
+(define (write-externs-file pathname externs)
+ (if (not (null? externs))
+ (fasdump externs pathname)))
+
+(define (print-spec identifier names)
+ (newline)
+ (newline)
+ (write-string "(")
+ (write identifier)
+ (let loop
+ ((names
+ (sort names
+ (lambda (x y)
+ (string<? (symbol->string x)
+ (symbol->string y))))))
+ (if (not (null? names))
+ (begin (newline)
+ (write (car names))
+ (loop (cdr names)))))
+ (write-string ")"))
+
+(define (wrapping-hook scode)
+ scode)
+
+(define control-point-tail
+ `(3 ,(primitive-set-type (microcode-type 'NULL) (* 4 4))
+ () () () () () () () () () () () () () () ()))
+
+(define (wrap-with-control-point scode)
+ (system-list-to-vector type-code-control-point
+ `(,return-address-restart-execution
+ ,scode
+ ,system-global-environment
+ ,return-address-non-existent-continuation
+ ,@control-point-tail)))
+
+(define type-code-control-point
+ (microcode-type 'CONTROL-POINT))
+
+(define return-address-restart-execution
+ (make-return-address (microcode-return 'RESTART-EXECUTION)))
+
+(define return-address-non-existent-continuation
+ (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION)))
+\f
+;;;; Optimizer Top Level
+
+(define (integrate/file file-name declarations compute-free?)
+ (integrate/kernel (lambda ()
+ (phase:syntax (phase:read file-name)))
+ declarations))
+
+(define (integrate/simple preprocessor input declarations receiver)
+ (transmit-values
+ (integrate/kernel (lambda () (preprocessor input)) declarations)
+ (or receiver
+ (lambda (expression externs events)
+ expression))))
+
+(define (integrate/kernel get-scode declarations)
+ (fluid-let ((previous-time false)
+ (previous-name false)
+ (events '()))
+ (transmit-values
+ (transmit-values
+ (transmit-values
+ (phase:transform (canonicalize-scode (get-scode) declarations))
+ phase:optimize)
+ phase:generate-scode)
+ (lambda (externs expression)
+ (end-phase)
+ (return-3 expression externs (reverse! events))))))
+
+(define (canonicalize-scode scode declarations)
+ (let ((declarations
+ ((access process-declarations syntaxer-package) declarations)))
+ (if (null? declarations)
+ scode
+ (scan-defines (make-sequence
+ (list (make-block-declaration declarations)
+ scode))
+ make-open-block))))
+\f
+(define (phase:read filename)
+ (mark-phase "Read")
+ (read-file filename))
+
+(define (phase:syntax s-expression)
+ (mark-phase "Syntax")
+ (syntax* s-expression (make-syntax-table system-global-syntax-table)))
+
+(define (phase:transform scode)
+ (mark-phase "Transform")
+ (transform/expression scode))
+
+(define (phase:optimize block expression)
+ (mark-phase "Optimize")
+ (integrate/expression block expression))
+
+(define (phase:generate-scode operations environment expression)
+ (mark-phase "Generate SCode")
+ (return-2 (operations->external operations environment)
+ (cgen/expression expression)))
+
+(define previous-time)
+(define previous-name)
+(define events)
+
+(define (mark-phase this-name)
+ (end-phase)
+ (newline)
+ (write-string " ")
+ (write-string this-name)
+ (write-string "...")
+ (set! previous-name this-name))
+
+(define (end-phase)
+ (let ((this-time (runtime)))
+ (if previous-time
+ (let ((dt (- this-time previous-time)))
+ (set! events (cons (cons previous-name dt) events))
+ (newline)
+ (write-string " Time: ")
+ (write dt)
+ (write-string " seconds.")))
+ (set! previous-time this-time)))
\ No newline at end of file
--- /dev/null
+#| -*-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 $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Usual Integrations: Constants
+
+(declare (usual-integrations))
+\f
+(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!))
+
+(define (usual-integrations/cache!)
+ (set! usual-integrations/constant-names
+ (list-copy global-constant-objects))
+ (set! usual-integrations/constant-values
+ (map (lambda (name)
+ (let ((object
+ (lexical-reference system-global-environment name)))
+ (if (not (scode-constant? object))
+ (error "USUAL-INTEGRATIONS: not a constant" name))
+ (constant->integration-info object)))
+ usual-integrations/constant-names))
+ (return-2 (constant/make constant) '()))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.0 1987/03/10 13:25:31 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Usual Integrations: Combination Expansions
+
+(declare (usual-integrations))
+\f
+;;;; N-ary Arithmetic Predicates
+
+(define (make-combination primitive operands)
+ (combination/make (constant/make primitive) operands))
+
+(define (constant-eq? expression constant)
+ (and (constant? expression)
+ (eq? (constant/value expression) constant)))
+
+(define (pairwise-test binary-predicate if-left-zero if-right-zero)
+ (lambda (operands if-expanded if-not-expanded)
+ (cond ((or (null? operands)
+ (null? (cdr operands)))
+ (error "Too few operands" operands))
+ ((null? (cddr operands))
+ (if-expanded
+ (cond ((constant-eq? (car operands) 0)
+ (make-combination if-left-zero (list (cadr operands))))
+ ((constant-eq? (cadr operands) 0)
+ (make-combination if-right-zero (list (car operands))))
+ (else
+ (make-combination binary-predicate operands)))))
+ (else
+ (if-not-expanded)))))
+
+(define (pairwise-test-inverse inverse-expansion)
+ (lambda (operands if-expanded if-not-expanded)
+ (inverse-expansion operands
+ (lambda (expression)
+ (if-expanded (make-combination not (list expression))))
+ if-not-expanded)))
+
+(define =-expansion
+ (pairwise-test (make-primitive-procedure '&=) zero? zero?))
+
+(define <-expansion
+ (pairwise-test (make-primitive-procedure '&<) positive? negative?))
+
+(define >-expansion
+ (pairwise-test (make-primitive-procedure '&>) negative? positive?))
+
+(define <=-expansion
+ (pairwise-test-inverse >-expansion))
+
+(define >=-expansion
+ (pairwise-test-inverse <-expansion))
+\f
+;;;; N-ary Arithmetic Field Operations
+
+(define (right-accumulation identity make-binary)
+ (lambda (operands if-expanded if-not-expanded)
+ (let ((operands (delq identity operands)))
+ (let ((n (length operands)))
+ (cond ((zero? n)
+ (if-expanded (constant/make identity)))
+ ((< n 5)
+ (if-expanded
+ (let loop
+ ((first (car operands))
+ (rest (cdr operands)))
+ (if (null? rest)
+ first
+ (make-binary first
+ (loop (car rest) (cdr rest)))))))
+ (else
+ (if-not-expanded)))))))
+
+(define +-expansion
+ (right-accumulation 0
+ (let ((&+ (make-primitive-procedure '&+)))
+ (lambda (x y)
+ (cond ((constant-eq? x 1) (make-combination 1+ (list y)))
+ ((constant-eq? y 1) (make-combination 1+ (list x)))
+ (else (make-combination &+ (list x y))))))))
+
+(define *-expansion
+ (right-accumulation 1
+ (let ((&* (make-primitive-procedure '&*)))
+ (lambda (x y)
+ (make-combination &* (list x y))))))
+\f
+(define (right-accumulation-inverse identity inverse-expansion make-binary)
+ (lambda (operands if-expanded if-not-expanded)
+ (let ((expand
+ (lambda (x y)
+ (if-expanded
+ (if (constant-eq? y identity)
+ x
+ (make-binary x y))))))
+ (cond ((null? operands)
+ (error "Too few operands"))
+ ((null? (cdr operands))
+ (expand (constant/make identity) (car operands)))
+ (else
+ (inverse-expansion (cdr operands)
+ (lambda (expression)
+ (expand (car operands) expression))
+ if-not-expanded))))))
+
+(define --expansion
+ (right-accumulation-inverse 0 +-expansion
+ (let ((&- (make-primitive-procedure '&-)))
+ (lambda (x y)
+ (if (constant-eq? y 1)
+ (make-combination -1+ (list x))
+ (make-combination &- (list x y)))))))
+
+(define /-expansion
+ (right-accumulation-inverse 1 *-expansion
+ (let ((&/ (make-primitive-procedure '&/)))
+ (lambda (x y)
+ (make-combination &/ (list x y))))))
+\f
+;;;; Miscellaneous Arithmetic
+
+(define (divide-component-expansion selector)
+ (lambda (operands if-expanded if-not-expanded)
+ (if-expanded
+ (make-combination selector
+ (list (make-combination integer-divide operands))))))
+
+(define quotient-expansion
+ (divide-component-expansion car))
+
+(define remainder-expansion
+ (divide-component-expansion cdr))
+\f
+;;;; N-ary List Operations
+
+(define apply*-expansion
+ (let ((apply-primitive (make-primitive-procedure 'APPLY)))
+ (lambda (operands if-expanded if-not-expanded)
+ (let ((n (length operands)))
+ (cond ((< n 2) (error "APPLY*-EXPANSION: Too few arguments" n))
+ ((< n 10)
+ (if-expanded
+ (make-combination
+ apply-primitive
+ (list (car operands)
+ (cons*-expansion-loop (cdr operands))))))
+ (else (if-not-expanded)))))))
+
+(define (cons*-expansion operands if-expanded if-not-expanded)
+ (let ((n (length operands)))
+ (cond ((zero? n) (error "CONS*-EXPANSION: No arguments!"))
+ ((< n 9) (if-expanded (cons*-expansion-loop operands)))
+ (else (if-not-expanded)))))
+
+(define (cons*-expansion-loop rest)
+ (if (null? (cdr rest))
+ (car rest)
+ (make-combination cons
+ (list (car rest)
+ (cons*-expansion-loop (cdr rest))))))
+
+(define (list-expansion operands if-expanded if-not-expanded)
+ (if (< (length operands) 9)
+ (if-expanded (list-expansion-loop operands))
+ (if-not-expanded)))
+
+(define (vector-expansion operands if-expanded if-not-expanded)
+ (if (< (length operands) 9)
+ (if-expanded (make-combination list->vector
+ (list (list-expansion-loop operands))))
+ (if-not-expanded)))
+
+(define (list-expansion-loop rest)
+ (if (null? rest)
+ (constant/make '())
+ (make-combination cons
+ (list (car rest)
+ (list-expansion-loop (cdr rest))))))
+\f
+;;;; General CAR/CDR Encodings
+
+(define (general-car-cdr-expansion encoding)
+ (lambda (operands if-expanded if-not-expanded)
+ (if (= (length operands) 1)
+ (if-expanded
+ (make-combination general-car-cdr
+ (list (car operands)
+ (constant/make encoding))))
+ (error "Wrong number of arguments" (length operands)))))
+
+(define caar-expansion (general-car-cdr-expansion #b111))
+(define cadr-expansion (general-car-cdr-expansion #b110))
+(define cdar-expansion (general-car-cdr-expansion #b101))
+(define cddr-expansion (general-car-cdr-expansion #b100))
+
+(define caaar-expansion (general-car-cdr-expansion #b1111))
+(define caadr-expansion (general-car-cdr-expansion #b1110))
+(define cadar-expansion (general-car-cdr-expansion #b1101))
+(define caddr-expansion (general-car-cdr-expansion #b1100))
+(define cdaar-expansion (general-car-cdr-expansion #b1011))
+(define cdadr-expansion (general-car-cdr-expansion #b1010))
+(define cddar-expansion (general-car-cdr-expansion #b1001))
+(define cdddr-expansion (general-car-cdr-expansion #b1000))
+
+(define caaaar-expansion (general-car-cdr-expansion #b11111))
+(define caaadr-expansion (general-car-cdr-expansion #b11110))
+(define caadar-expansion (general-car-cdr-expansion #b11101))
+(define caaddr-expansion (general-car-cdr-expansion #b11100))
+(define cadaar-expansion (general-car-cdr-expansion #b11011))
+(define cadadr-expansion (general-car-cdr-expansion #b11010))
+(define caddar-expansion (general-car-cdr-expansion #b11001))
+(define cadddr-expansion (general-car-cdr-expansion #b11000))
+(define cdaaar-expansion (general-car-cdr-expansion #b10111))
+(define cdaadr-expansion (general-car-cdr-expansion #b10110))
+(define cdadar-expansion (general-car-cdr-expansion #b10101))
+(define cdaddr-expansion (general-car-cdr-expansion #b10100))
+(define cddaar-expansion (general-car-cdr-expansion #b10011))
+(define cddadr-expansion (general-car-cdr-expansion #b10010))
+(define cdddar-expansion (general-car-cdr-expansion #b10001))
+(define cddddr-expansion (general-car-cdr-expansion #b10000))
+
+(define second-expansion cadr-expansion)
+(define third-expansion caddr-expansion)
+(define fourth-expansion cadddr-expansion)
+(define fifth-expansion (general-car-cdr-expansion #b110000))
+(define sixth-expansion (general-car-cdr-expansion #b1100000))
+(define seventh-expansion (general-car-cdr-expansion #b11000000))
+(define eighth-expansion (general-car-cdr-expansion #b110000000))
+\f
+;;;; Miscellaneous
+
+(define (make-string-expansion operands if-expanded if-not-expanded)
+ (let ((n (length operands)))
+ (cond ((zero? n)
+ (error "MAKE-STRING-EXPANSION: No arguments"))
+ ((= n 1)
+ (if-expanded (make-combination string-allocate operands)))
+ (else
+ (if-not-expanded)))))
+
+(define (identity-procedure-expansion operands if-expanded if-not-expanded)
+ (if (not (= (length operands) 1))
+ (error "IDENTITY-PROCEDURE-EXPANSION: wrong number of arguments"
+ (length operands)))
+ (if-expanded (car operands)))
+\f
+;;;; Tables
+
+(define usual-integrations/expansion-names
+ '(= < > <= >= + - * / quotient remainder
+ apply cons* list vector
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ second third fourth fifth sixth seventh eighth
+ make-string identity-procedure
+ ))
+
+(define usual-integrations/expansion-values
+ (list =-expansion <-expansion >-expansion <=-expansion >=-expansion
+ +-expansion --expansion *-expansion /-expansion
+ quotient-expansion remainder-expansion
+ apply*-expansion cons*-expansion list-expansion vector-expansion
+ caar-expansion cadr-expansion cdar-expansion cddr-expansion
+ caaar-expansion caadr-expansion cadar-expansion caddr-expansion
+ cdaar-expansion cdadr-expansion cddar-expansion cdddr-expansion
+ caaaar-expansion caaadr-expansion caadar-expansion caaddr-expansion
+ cadaar-expansion cadadr-expansion caddar-expansion cadddr-expansion
+ cdaaar-expansion cdaadr-expansion cdadar-expansion cdaddr-expansion
+ cddaar-expansion cddadr-expansion cdddar-expansion cddddr-expansion
+ second-expansion third-expansion fourth-expansion fifth-expansion
+ sixth-expansion seventh-expansion eighth-expansion
+ make-string-expansion identity-procedure-expansion
+ usual-integrations/expansion-values))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.0 1987/03/10 13:25:33 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Transform Input Expression
+
+(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
+;;; normally defined in the global environment. Names in this group
+;;; are supposed to be shadowed by top-level definitions in the user's
+;;; program.
+
+;;; Normally we would intern the variable objects corresponding to
+;;; those names in the block corresponding to the outermost
+;;; environment in the user's program. However, if the user had a
+;;; top-level definition which was intended to shadow one of those
+;;; names, both the definition and the declaration would refer to the
+;;; 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 (transform/top-level-1 block expression)
+ (fluid-let ((global-block
+ (let block/global-parent ((block 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)))))
+
+(define (transform/expressions block environment expressions)
+ (map (lambda (expression)
+ (transform/expression block environment expression))
+ expressions))
+
+(define (transform/expression block environment expression)
+ ((transform/dispatch expression) block environment expression))
+
+(define global-block)
+
+(define (environment/make)
+ '())
+
+(define (environment/lookup environment name)
+ (let ((association (assq name environment)))
+ (if association
+ (cdr association)
+ (block/lookup-name global-block name))))
+
+(define (environment/bind environment variables)
+ (map* environment
+ (lambda (variable)
+ (cons (variable/name variable) variable))
+ variables))
+\f
+(define (transform/open-block block environment expression)
+ (open-block-components expression
+ (transform/open-block* (block/make block true) environment)))
+
+(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-declarations! block (declarations/parse block declarations))
+ (let ((environment (environment/bind environment variables)))
+
+ (define (loop variables actions)
+ (cond ((null? variables)
+ (return-2 '() (map transform actions)))
+ ((null? actions)
+ (error "Extraneous auxiliaries" variables))
+
+ ;; Because `scan-defines' returns the auxiliary names in a
+ ;; particular order, we can expect to encounter them in that
+ ;; same order when looking through the body's actions.
+
+ ((and (scode-assignment? (car actions))
+ (eq? (assignment-name (car actions))
+ (variable/name (car variables))))
+ (transmit-values (loop (cdr variables) (cdr actions))
+ (lambda (values actions*)
+ (return-2
+ (cons (transform (assignment-value (car actions))) values)
+ (cons open-block/value-marker actions*)))))
+ (else
+ (transmit-values (loop variables (cdr actions))
+ (lambda (values actions*)
+ (return-2 values
+ (cons (transform (car actions)) actions*)))))))
+
+ (define (transform subexpression)
+ (transform/expression block environment subexpression))
+
+ (transmit-values (loop variables (sequence-actions body))
+ (lambda (values actions)
+ (open-block/make block variables values actions))))))
+
+(define (transform/variable block environment expression)
+ (reference/make block
+ (environment/lookup environment (variable-name expression))))
+
+(define (transform/assignment block environment expression)
+ (assignment-components expression
+ (lambda (name value)
+ (assignment/make block
+ (environment/lookup environment name)
+ (transform/expression block environment value)))))
+\f
+(define (transform/lambda block environment expression)
+ (lambda-components* expression
+ (lambda (name required optional rest body)
+ (let ((block (block/make block true)))
+ (transmit-values
+ (let ((name->variable (lambda (name) (variable/make block name))))
+ (return-4 (name->variable name)
+ (map name->variable required)
+ (map name->variable optional)
+ (and rest (name->variable rest))))
+ (lambda (name required optional rest)
+ (let ((bound
+ `(,name ,@required ,@optional ,@(if rest `(,rest) '()))))
+ (block/set-bound-variables! block bound)
+ (procedure/make
+ block name required optional rest
+ (transform/procedure-body block
+ (environment/bind environment bound)
+ body)))))))))
+
+(define (transform/procedure-body block environment expression)
+ (if (scode-open-block? expression)
+ (open-block-components expression
+ (lambda (auxiliary declarations body)
+ (if (null? auxiliary)
+ (begin (block/set-declarations!
+ block
+ (declarations/parse block declarations))
+ (transform/expression block environment body))
+ (transform/open-block block environment expression))))
+ (transform/expression block environment expression)))
+
+(define (transform/definition block environment expression)
+ (definition-components expression
+ (lambda (name value)
+ (error "Unscanned definition encountered. Unable to proceed." name))))
+
+(define (transform/access block environment expression)
+ (access-components expression
+ (lambda (environment* name)
+ (access/make (transform/expression block environment environment*)
+ name))))
+
+(define (transform/combination block environment expression)
+ (combination-components expression
+ (lambda (operator operands)
+ (combination/make (transform/expression block environment operator)
+ (transform/expressions block environment operands)))))
+
+(define (transform/comment block environment expression)
+ (transform/expression block (comment-expression environment expression)))
+\f
+(define (transform/conditional block environment expression)
+ (conditional-components expression
+ (lambda (predicate consequent alternative)
+ (conditional/make
+ (transform/expression block environment predicate)
+ (transform/expression block environment consequent)
+ (transform/expression block environment alternative)))))
+
+(define (transform/constant block environment expression)
+ (constant/make expression))
+
+(define (transform/declaration block environment expression)
+ (declaration-components expression
+ (lambda (declarations expression)
+ (declaration/make (declarations/parse block declarations)
+ (transform/expression block environment expression)))))
+
+(define (transform/delay block environment expression)
+ (delay/make
+ (transform/expression block environment (delay-expression expression))))
+
+(define (transform/disjunction block environment expression)
+ (disjunction-components expression
+ (lambda (predicate alternative)
+ (disjunction/make
+ (transform/expression block environment predicate)
+ (transform/expression block environment alternative)))))
+
+(define (transform/in-package block environment expression)
+ (in-package-components expression
+ (lambda (environment* expression)
+ (in-package/make (transform/expression block environment environment*)
+ (transform/quotation* expression)))))
+
+(define (transform/quotation block environment expression)
+ (transform/quotation* (quotation-expression expression)))
+
+(define (transform/quotation* expression)
+ (transmit-values (transform/top-level expression)
+ quotation/make))
+
+(define (transform/sequence block environment expression)
+ (sequence/make
+ (transform/expressions block environment (sequence-actions expression))))
+
+(define (transform/the-environment block environment expression)
+ (block/unsafe! block)
+ (the-environment/make block))
+\f
+(define transform/dispatch
+ (make-type-dispatcher
+ `((,access-type ,transform/access)
+ (,assignment-type ,transform/assignment)
+ (,combination-type ,transform/combination)
+ (,comment-type ,transform/comment)
+ (,conditional-type ,transform/conditional)
+ (,declaration-type ,transform/declaration)
+ (,definition-type ,transform/definition)
+ (,delay-type ,transform/delay)
+ (,disjunction-type ,transform/disjunction)
+ (,in-package-type ,transform/in-package)
+ (,lambda-type ,transform/lambda)
+ (,open-block-type ,transform/open-block)
+ (,quotation-type ,transform/quotation)
+ (,sequence-type ,transform/sequence)
+ (,the-environment-type ,transform/the-environment)
+ (,variable-type ,transform/variable))
+ transform/constant))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.0 1987/03/10 13:25:03 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: System Construction
+
+(in-package system-global-environment
+(declare (usual-integrations))
+\f
+(define sf)
+(load "$zcomp/base/load" system-global-environment)
+
+(load-system system-global-environment
+ 'PACKAGE/BETA
+ '(SYSTEM-GLOBAL-ENVIRONMENT)
+ '(
+ (PACKAGE/BETA
+ "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
+ )
+
+ (PACKAGE/TOP-LEVEL
+ "toplev.bin" ;Top Level
+ )
+
+ (PACKAGE/TRANSFORM
+ "xform.bin" ;SCode -> Internal
+ )
+
+ (PACKAGE/INTEGRATE
+ "subst.bin" ;Beta Substitution Optimizer
+ )
+
+ (PACKAGE/CGEN
+ "cgen.bin" ;Internal -> SCode
+ )
+
+ (PACKAGE/EXPANSION
+ "usiexp.bin" ;Usual Integrations: Expanders
+ )
+
+ (PACKAGE/DECLARATION-PARSER
+ "pardec.bin" ;Declaration Parser
+ )
+
+ (PACKAGE/COPY
+ "copy.bin" ;Copy Expressions
+ )
+
+ (PACKAGE/FREE
+ "free.bin" ;Free Variable Analysis
+ )
+
+ (PACKAGE/SAFE?
+ "safep.bin" ;Safety Analysis
+ )
+
+ ))
+
+(in-package package/beta
+ (define beta/system
+ (make-environment
+ (define :name "Beta")
+ (define :version 3)
+ (define :modification 0)))
+ (add-system! beta/system)
+ (beta/initialize!))
+
+;;; end IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT
+)
\ No newline at end of file
--- /dev/null
+#| -*-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 $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Top Level
+
+(declare (usual-integrations))
+\f
+;;;; User Interface
+
+(define generate-unfasl-files? false
+ "Set this non-false to cause unfasl files to be generated by default.")
+
+(define optimize-open-blocks? false
+ "Set this non-false to eliminate unreferenced auxiliary definitions.
+Currently this optimization is not implemented.")
+
+(define (integrate/procedure procedure declarations)
+ (if (compound-procedure? procedure)
+ (procedure-components procedure
+ (lambda (*lambda environment)
+ (scode-eval (integrate/scode *lambda declarations false)
+ 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/scode scode declarations receiver)
+ (integrate/simple identity-procedure scode declarations receiver))
+
+(define (sf input-string #!optional bin-string spec-string)
+ (if (unassigned? bin-string) (set! bin-string false))
+ (if (unassigned? spec-string) (set! spec-string false))
+ (syntax-file input-string bin-string spec-string))
+
+(define (scold input-string #!optional bin-string spec-string)
+ "Use this only for syntaxing the cold-load root file.
+Currently only the 68000 implementation needs this."
+ (if (unassigned? bin-string) (set! bin-string false))
+ (if (unassigned? spec-string) (set! spec-string false))
+ (fluid-let ((wrapping-hook wrap-with-control-point))
+ (syntax-file input-string bin-string spec-string)))
+\f
+;;;; File Syntaxer
+
+(define sf/default-input-pathname
+ (make-pathname false false false "scm" 'NEWEST))
+
+(define sf/default-externs-pathname
+ (make-pathname false false false "ext" 'NEWEST))
+
+(define sf/output-pathname-type "bin")
+(define sf/unfasl-pathname-type "unf")
+
+(define (syntax-file input-string bin-string spec-string)
+ (let ((eval-sf-expression
+ (lambda (input-string)
+ (let ((input-path
+ (pathname->input-truename
+ (merge-pathnames (->pathname input-string)
+ sf/default-input-pathname))))
+ (if (not input-path)
+ (error "SF: File does not exist" input-string))
+ (let ((bin-path
+ (let ((bin-path
+ (pathname-new-type input-path
+ sf/output-pathname-type)))
+ (if bin-string
+ (merge-pathnames (->pathname bin-string) bin-path)
+ bin-path))))
+ (let ((spec-path
+ (and (or spec-string generate-unfasl-files?)
+ (let ((spec-path
+ (pathname-new-type bin-path
+ sf/unfasl-pathname-type)))
+ (if spec-string
+ (merge-pathnames (->pathname spec-string)
+ spec-path)
+ spec-path)))))
+ (syntax-file* input-path bin-path spec-path)))))))
+ (if (list? input-string)
+ (for-each (lambda (input-string)
+ (eval-sf-expression input-string))
+ input-string)
+ (eval-sf-expression input-string)))
+ *the-non-printing-object*)
+\f
+(define (syntax-file* input-pathname bin-pathname spec-pathname)
+ (let ((start-date (date))
+ (start-time (time))
+ (input-filename (pathname->string input-pathname))
+ (bin-filename (pathname->string bin-pathname))
+ (spec-filename (and spec-pathname (pathname->string spec-pathname))))
+ (newline)
+ (write-string "Syntax file: ")
+ (write input-filename)
+ (write-string " ")
+ (write bin-filename)
+ (write-string " ")
+ (write spec-filename)
+ (transmit-values (integrate/file input-pathname '() spec-pathname)
+ (lambda (expression externs events)
+ (fasdump (wrapping-hook
+ (make-comment `((SOURCE-FILE . ,input-filename)
+ (DATE . ,start-date)
+ (TIME . ,start-time)
+ (FLUID-LET . ,*fluid-let-type*))
+ (set! expression false)))
+ bin-pathname)
+ (write-externs-file (pathname-new-type
+ bin-pathname
+ (pathname-type sf/default-externs-pathname))
+ (set! externs false))
+ (if spec-pathname
+ (begin (newline)
+ (write-string "Writing ")
+ (write spec-filename)
+ (with-output-to-file spec-pathname
+ (lambda ()
+ (newline)
+ (write `(DATE ,start-date ,start-time))
+ (newline)
+ (write `(FLUID-LET ,*fluid-let-type*))
+ (newline)
+ (write `(SOURCE-FILE ,input-filename))
+ (newline)
+ (write `(BINARY-FILE ,bin-filename))
+ (for-each (lambda (event)
+ (newline)
+ (write `(,(car event)
+ (RUNTIME ,(cdr event)))))
+ events)))
+ (write-string " -- done")))))))
+\f
+(define (read-externs-file pathname)
+ (fasload (merge-pathnames (->pathname pathname)
+ sf/default-externs-pathname)))
+
+(define (write-externs-file pathname externs)
+ (if (not (null? externs))
+ (fasdump externs pathname)))
+
+(define (print-spec identifier names)
+ (newline)
+ (newline)
+ (write-string "(")
+ (write identifier)
+ (let loop
+ ((names
+ (sort names
+ (lambda (x y)
+ (string<? (symbol->string x)
+ (symbol->string y))))))
+ (if (not (null? names))
+ (begin (newline)
+ (write (car names))
+ (loop (cdr names)))))
+ (write-string ")"))
+
+(define (wrapping-hook scode)
+ scode)
+
+(define control-point-tail
+ `(3 ,(primitive-set-type (microcode-type 'NULL) (* 4 4))
+ () () () () () () () () () () () () () () ()))
+
+(define (wrap-with-control-point scode)
+ (system-list-to-vector type-code-control-point
+ `(,return-address-restart-execution
+ ,scode
+ ,system-global-environment
+ ,return-address-non-existent-continuation
+ ,@control-point-tail)))
+
+(define type-code-control-point
+ (microcode-type 'CONTROL-POINT))
+
+(define return-address-restart-execution
+ (make-return-address (microcode-return 'RESTART-EXECUTION)))
+
+(define return-address-non-existent-continuation
+ (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION)))
+\f
+;;;; Optimizer Top Level
+
+(define (integrate/file file-name declarations compute-free?)
+ (integrate/kernel (lambda ()
+ (phase:syntax (phase:read file-name)))
+ declarations))
+
+(define (integrate/simple preprocessor input declarations receiver)
+ (transmit-values
+ (integrate/kernel (lambda () (preprocessor input)) declarations)
+ (or receiver
+ (lambda (expression externs events)
+ expression))))
+
+(define (integrate/kernel get-scode declarations)
+ (fluid-let ((previous-time false)
+ (previous-name false)
+ (events '()))
+ (transmit-values
+ (transmit-values
+ (transmit-values
+ (phase:transform (canonicalize-scode (get-scode) declarations))
+ phase:optimize)
+ phase:generate-scode)
+ (lambda (externs expression)
+ (end-phase)
+ (return-3 expression externs (reverse! events))))))
+
+(define (canonicalize-scode scode declarations)
+ (let ((declarations
+ ((access process-declarations syntaxer-package) declarations)))
+ (if (null? declarations)
+ scode
+ (scan-defines (make-sequence
+ (list (make-block-declaration declarations)
+ scode))
+ make-open-block))))
+\f
+(define (phase:read filename)
+ (mark-phase "Read")
+ (read-file filename))
+
+(define (phase:syntax s-expression)
+ (mark-phase "Syntax")
+ (syntax* s-expression (make-syntax-table system-global-syntax-table)))
+
+(define (phase:transform scode)
+ (mark-phase "Transform")
+ (transform/expression scode))
+
+(define (phase:optimize block expression)
+ (mark-phase "Optimize")
+ (integrate/expression block expression))
+
+(define (phase:generate-scode operations environment expression)
+ (mark-phase "Generate SCode")
+ (return-2 (operations->external operations environment)
+ (cgen/expression expression)))
+
+(define previous-time)
+(define previous-name)
+(define events)
+
+(define (mark-phase this-name)
+ (end-phase)
+ (newline)
+ (write-string " ")
+ (write-string this-name)
+ (write-string "...")
+ (set! previous-name this-name))
+
+(define (end-phase)
+ (let ((this-time (runtime)))
+ (if previous-time
+ (let ((dt (- this-time previous-time)))
+ (set! events (cons (cons previous-name dt) events))
+ (newline)
+ (write-string " Time: ")
+ (write dt)
+ (write-string " seconds.")))
+ (set! previous-time this-time)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff