--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/butils.scm,v 4.1 1988/06/13 12:29:01 cph Rel $
+
+Copyright (c) 1988 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. |#
+
+;;;; Build utilities
+
+(declare (usual-integrations))
+\f
+(define (directory-processor input-type output-type process-file)
+ (let ((directory-read
+ (let ((input-pattern
+ (make-pathname false false '() 'WILD input-type 'NEWEST)))
+ (lambda (directory)
+ (directory-read
+ (merge-pathnames (pathname-as-directory
+ (->pathname directory))
+ input-pattern))))))
+ (lambda (input-directory #!optional output-directory force?)
+ (let ((output-directory
+ (if (default-object? output-directory) false output-directory))
+ (force? (if (default-object? force?) false force?)))
+ (for-each (let ((output-directory-path
+ (and output-directory
+ (->pathname output-directory))))
+ (lambda (pathname)
+ (if (or force?
+ (not
+ (compare-file-modification-times
+ (pathname-default-type pathname input-type)
+ (let ((output-pathname
+ (pathname-new-type pathname
+ output-type)))
+ (if output-directory-path
+ (merge-pathnames output-directory-path
+ output-pathname)
+ output-pathname)))))
+ (process-file pathname output-directory))))
+ (if (pair? input-directory)
+ (mapcan directory-read input-directory)
+ (directory-read input-directory)))))))
+
+(define sf-directory
+ (directory-processor "scm" "bin"
+ (lambda (pathname output-directory)
+ (sf pathname output-directory))))
+
+(define compile-directory
+ (directory-processor "bin" "com"
+ (lambda (pathname output-directory)
+ (compile-bin-file pathname output-directory))))
+
+(define sf-directory?)
+(define compile-directory?)
+(let ((show-pathname
+ (lambda (pathname output-directory)
+ output-directory
+ (newline)
+ (write-string "Process file: ")
+ (write-string (pathname->string pathname)))))
+ (set! sf-directory? (directory-processor "scm" "bin" show-pathname))
+ (set! compile-directory? (directory-processor "bin" "com" show-pathname)))
+\f
+(define (sf-conditionally filename)
+ (let ((kernel
+ (lambda (filename)
+ (if (file-processed? filename "scm" "bin")
+ (begin
+ (newline)
+ (write-string "Syntax file: ")
+ (write filename)
+ (write-string " is up to date"))
+ (sf filename))))) (if (pair? filename)
+ (for-each kernel filename)
+ (kernel filename))))
+
+(define (file-processed? filename input-type output-type)
+ (let ((pathname (->pathname filename)))
+ (compare-file-modification-times
+ (pathname-default-type pathname input-type)
+ (pathname-new-type pathname output-type))))
+
+(define (compare-file-modification-times x y)
+ (let ((x (file-modification-time x)))
+ (and x
+ (let ((y (file-modification-time y)))
+ (and y
+ (< x y))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.6 1988/04/23 08:49:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 4.1 1988/06/13 12:29:04 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(define-method/cgen 'SEQUENCE
(lambda (interns expression)
- (make-sequence (cgen/expressions interns (sequence/actions expression)))))
+ (let ((actions
+ (if flush-declarations?
+ (remove-references (sequence/actions expression))
+ (sequence/actions expression))))
+ (if (null? (cdr actions))
+ (cgen/expression interns (car actions))
+ (make-sequence (cgen/expressions interns actions))))))
+
+(define (remove-references actions)
+ (if (null? (cdr actions))
+ actions
+ (let ((rest (remove-references (cdr actions))))
+ (if (reference? (car actions))
+ rest
+ (cons (car actions) rest)))))
(define-method/cgen 'THE-ENVIRONMENT
(lambda (interns expression)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/chtype.scm,v 1.3 1988/04/23 08:49:52 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/chtype.scm,v 4.1 1988/06/13 12:29:10 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(declare (usual-integrations)
(automagic-integrations)
- (integrate-external "object" "mvalue"))
+ (integrate-external "object"))
\f
-(define (change-type/external block expression)
+(define (intern-type block expression)
(change-type/block block)
(change-type/expression expression)
- (return-2 expression (block/bound-variables block)))
+ (make-integration-info expression (block/bound-variables block)))
(define (change-type/block block)
(change-type/object enumeration/random block)
(declare (integrate-operator change-type/object))
(define (change-type/object enumeration object)
- (object/set-enumerand!
+ (set-object/enumerand!
object
(enumeration/name->enumerand enumeration
(enumerand/name (object/enumerand object)))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.8 1988/04/23 08:50:05 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 4.1 1988/06/13 12:29:14 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(open-block-optimizations)
(eta-substitution)
(automagic-integrations)
- (integrate-external "object" "mvalue"))
+ (integrate-external "object"))
\f
(define root-block)
-(define (copy/external/intern block expression uninterned)
+(define (copy/expression/intern block expression uninterned)
(fluid-let ((root-block block)
(copy/variable/free copy/variable/free/intern)
(copy/declarations copy/declarations/intern))
- (let ((environment (environment/rebind block (environment/make) uninterned)))
+ (let ((environment
+ (environment/rebind block (environment/make) uninterned)))
(copy/expression root-block
environment
expression))))
-(define (copy/external/extern expression)
+(define (copy/expression/extern expression)
(fluid-let ((root-block (block/make false false))
(copy/variable/free copy/variable/free/extern)
(copy/declarations copy/declarations/extern))
(let ((environment (environment/make)))
(let ((expression
(copy/expression root-block environment expression)))
- (return-2 root-block expression)))))
+ (values root-block expression)))))
(define (copy/expressions block environment expressions)
(map (lambda (expression)
(variable/flags variable)))
old-bound)))
(let ((environment (environment/bind environment old-bound new-bound)))
- (block/set-bound-variables! result new-bound)
- (block/set-declarations!
+ (set-block/bound-variables! result new-bound)
+ (set-block/declarations!
result
(copy/declarations block environment (block/declarations block)))
- (block/set-flags! result (block/flags block))
- (return-2 result environment)))))
+ (set-block/flags! result (block/flags block))
+ (values result environment)))))
(define copy/variable/free)
(define (copy/variable block environment variable)
- block ; ignored
+ block ;ignored
(environment/lookup environment variable
identity-procedure
(copy/variable/free variable)))
((not variable*)
(loop (block/parent block)))
((block/safe? (variable/block variable*))
- (variable/set-name! variable* (rename-symbol name))
+ (set-variable/name! variable* (rename-symbol name))
(loop (block/parent block)))
(else
(error "Integration requires renaming unsafe variable"
(if-not))))
(define (environment/rebind block environment variables)
- (environment/bind environment
- variables
- (map (lambda (variable)
- (block/lookup-name block (variable/name variable) true))
- variables)))
+ (environment/bind
+ environment
+ variables
+ (map (lambda (variable)
+ (block/lookup-name block (variable/name variable) true))
+ variables)))
(define (make-renamer environment)
(lambda (variable)
(lambda (block environment expression)
(let ((operator (combination/operator expression))
(operands (combination/operands expression)))
- (if (and (constant? operator)
- (eq? error-procedure (constant/value operator))
+ (if (and (operator/error-procedure? operator)
(the-environment? (caddr operands)))
(combination/make
operator
(copy/expression block environment operator)
(copy/expressions block environment operands))))))
+(define (operator/error-procedure? operator)
+ (or (and (constant? operator)
+ (eq? error-procedure (constant/value operator)))
+ (and (access? operator)
+ (eq? 'ERROR-PROCEDURE (access/name operator))
+ (let ((environment (access/environment operator)))
+ (and (constant? environment)
+ (not (constant/value environment)))))))
+
(define-method/copy 'CONDITIONAL
(lambda (block environment expression)
(conditional/make
(define-method/copy 'PROCEDURE
(lambda (block environment procedure)
- (transmit-values (copy/block block environment (procedure/block procedure))
+ (with-values
+ (lambda ()
+ (copy/block block environment (procedure/block procedure)))
(lambda (block environment)
(let ((rename (make-renamer environment)))
(procedure/make block
(define-method/copy 'OPEN-BLOCK
(lambda (block environment expression)
- (transmit-values
- (copy/block block environment (open-block/block expression))
+ (with-values
+ (lambda ()
+ (copy/block block environment (open-block/block expression)))
(lambda (block environment)
(open-block/make
block
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.5 1988/04/23 08:50:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 4.1 1988/06/13 12:29:20 cph Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (block/unsafe! block)
(if (block/safe? block)
- (begin (block/set-safe?! block false)
+ (begin (set-block/safe?! block false)
(if (block/parent block)
(block/unsafe! (block/parent block))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.4 1988/04/23 08:50:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 4.1 1988/06/13 12:31:26 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gconst.scm,v 3.7 1988/04/12 15:01:28 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gconst.scm,v 4.1 1988/06/13 12:29:28 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
;;; names with the value of that name, which is a constant.
(define global-constant-objects
- '(TRUE FALSE SYSTEM-GLOBAL-ENVIRONMENT
-
- SCODE-EVAL FORCE
- 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
-
- ;; Numbers
- ZERO? POSITIVE? NEGATIVE? 1+ -1+
- INTEGER-DIVIDE INTEGER-DIVIDE-QUOTIENT INTEGER-DIVIDE-REMAINDER
- TRUNCATE ROUND FLOOR CEILING
- SQRT EXP LOG SIN COS
-
- ;; Fixnum Arithmetic
- FIX:ZERO? FIX:NEGATIVE? FIX:POSITIVE? FIX:= FIX:< FIX:>
- FIX:1+ FIX:-1+ FIX:+ FIX:- FIX:* FIX:DIVIDE FIX:GCD
-
- ;; Basic Compound Datatypes
- CONS PAIR? CAR CDR SET-CAR! SET-CDR! GENERAL-CAR-CDR
- NULL? LENGTH MEMQ ASSQ FIRST HEAD EMPTY-STREAM?
-
- VECTOR VECTOR-CONS VECTOR-LENGTH VECTOR-REF VECTOR-SET!
- LIST->VECTOR SUBVECTOR->LIST
- SUBVECTOR-MOVE-RIGHT! SUBVECTOR-MOVE-LEFT! SUBVECTOR-FILL!
-
- ;; 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!
+ '(
+ *THE-NON-PRINTING-OBJECT*
+ -1+
+ 1+
+ ASCII->CHAR
+ BIT-STRING->UNSIGNED-INTEGER
+ BIT-STRING-ALLOCATE
+ BIT-STRING-AND!
+ BIT-STRING-ANDC!
+ BIT-STRING-CLEAR!
+ BIT-STRING-FILL!
+ BIT-STRING-LENGTH
+ BIT-STRING-MOVE!
+ BIT-STRING-MOVEC!
+ BIT-STRING-OR!
+ BIT-STRING-REF
+ BIT-STRING-SET!
+ BIT-STRING-XOR!
+ BIT-STRING-ZERO?
+ BIT-STRING=?
+ BIT-STRING?
+ BIT-SUBSTRING-FIND-NEXT-SET-BIT
+ BIT-SUBSTRING-MOVE-RIGHT!
+ CAR
+ CDR
+ CEILING
+ CELL-CONTENTS
+ CELL?
+ CHAR->ASCII
+ CHAR->INTEGER
+ CHAR-ASCII?
+ CHAR-BITS
+ CHAR-BITS-LIMIT
+ CHAR-CODE
+ CHAR-CODE-LIMIT
+ CHAR-DOWNCASE
+ CHAR-INTEGER-LIMIT
+ CHAR-UPCASE
+ CHAR:NEWLINE
+ COMPILED-CODE-ADDRESS->BLOCK
+ COMPILED-CODE-ADDRESS->OFFSET
+ CONS
+ ENABLE-INTERRUPTS!
+ ENVIRONMENT-LINK-NAME EQ?
+ ERROR-PROCEDURE
+ EXECUTE-AT-NEW-STATE-POINT
+ FALSE
+ FALSE?
+ FIX:*
+ FIX:+
+ FIX:-
+ FIX:-1+
+ FIX:1+
+ FIX:<
+ FIX:=
+ FIX:>
+ FIX:DIVIDE
+ FIX:GCD
+ FIX:NEGATIVE?
+ FIX:POSITIVE?
+ FIX:ZERO?
+ FLOOR
+ FORCE
+ GENERAL-CAR-CDR
+ GET-FIXED-OBJECTS-VECTOR
+ GET-FLUID-BINDINGS
+ GET-NEXT-CONSTANT
+ HUNK3-CONS
+ INTEGER->CHAR
+ INTEGER-DIVIDE
+ INTEGER-DIVIDE-QUOTIENT
+ INTEGER-DIVIDE-REMAINDER
+ INTERRUPT-BIT/GC
+ INTERRUPT-BIT/GLOBAL-1
+ INTERRUPT-BIT/GLOBAL-2
+ INTERRUPT-BIT/GLOBAL-3
+ INTERRUPT-BIT/GLOBAL-GC
+ INTERRUPT-BIT/KBD
+ INTERRUPT-BIT/STACK
+ INTERRUPT-BIT/SUSPEND
+ INTERRUPT-BIT/TIMER
+ INTERRUPT-MASK/ALL
+ INTERRUPT-MASK/GC-OK
+ INTERRUPT-MASK/NONE
+ LAMBDA-TAG:FLUID-LET
+ LAMBDA-TAG:LET
+ LAMBDA-TAG:MAKE-ENVIRONMENT
+ LAMBDA-TAG:UNNAMED
+ LENGTH
+ LEXICAL-ASSIGNMENT
+ LEXICAL-REFERENCE
+ LEXICAL-UNASSIGNED?
+ LEXICAL-UNBOUND?
+ LEXICAL-UNREFERENCEABLE?
+ LIST->VECTOR
+ LOCAL-ASSIGNMENT
+ MAKE-BIT-STRING
+ MAKE-CELL
+ MAKE-CHAR
+ MAKE-NON-POINTER-OBJECT
+ NEGATIVE?
+ NOT
+ NULL?
+ OBJECT-CONSTANT?
+ OBJECT-DATUM
+ OBJECT-GC-TYPE
+ OBJECT-NEW-TYPE
+ OBJECT-PURE?
+ OBJECT-TYPE
+ OBJECT-TYPE?
+ PAIR?
+ POSITIVE?
+ PRIMITIVE-PROCEDURE-ARITY
+ PROCESS-TIME-CLOCK
+ READ-BITS!
+ REAL-TIME-CLOCK
+ ROUND
+ SCODE-EVAL
+ SET-CAR!
+ SET-CDR!
+ SET-CELL-CONTENTS!
+ SET-CURRENT-DYNAMIC-STATE!
+ SET-FLUID-BINDINGS!
+ SET-INTERRUPT-ENABLES!
+ SET-STRING-LENGTH!
+ STRING->SYMBOL
+ STRING-ALLOCATE
+ STRING-HASH
+ STRING-HASH-MOD
+ STRING-LENGTH
+ STRING-MAXIMUM-LENGTH
+ STRING-REF
+ STRING-SET!
+ STRING?
+ SUBSTRING-CI=?
+ SUBSTRING-DOWNCASE!
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 STRING-HASH-MOD
-
- ;; 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!
- BIT-SUBSTRING-FIND-NEXT-SET-BIT
-
- 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
+ SUBSTRING-MATCH-BACKWARD
+ SUBSTRING-MATCH-BACKWARD-CI
+ SUBSTRING-MATCH-FORWARD
+ SUBSTRING-MATCH-FORWARD-CI
+ SUBSTRING-MOVE-LEFT!
+ SUBSTRING-MOVE-RIGHT!
+ SUBSTRING-UPCASE!
+ SUBSTRING<?
+ SUBSTRING=?
+ SUBVECTOR->LIST
+ SUBVECTOR-FILL!
+ SUBVECTOR-MOVE-LEFT!
+ SUBVECTOR-MOVE-RIGHT!
+ SYSTEM-GLOBAL-ENVIRONMENT
+ SYSTEM-HUNK3-CXR0
+ SYSTEM-HUNK3-CXR1
+ SYSTEM-HUNK3-CXR2
+ SYSTEM-HUNK3-SET-CXR0!
+ SYSTEM-HUNK3-SET-CXR1!
+ SYSTEM-HUNK3-SET-CXR2!
+ SYSTEM-LIST->VECTOR
+ SYSTEM-PAIR-CAR
+ SYSTEM-PAIR-CDR
+ SYSTEM-PAIR-CONS
+ SYSTEM-PAIR-SET-CAR!
+ SYSTEM-PAIR-SET-CDR!
+ SYSTEM-PAIR?
+ SYSTEM-SUBVECTOR->LIST
+ SYSTEM-VECTOR-LENGTH
+ SYSTEM-VECTOR-REF
+ SYSTEM-VECTOR-SET!
+ SYSTEM-VECTOR?
+ THE-EMPTY-STREAM
+ TRANSLATE-TO-STATE-POINT
+ TRUE
+ TRUNCATE
+ UNDEFINED-CONDITIONAL-BRANCH
+ UNSIGNED-INTEGER->BIT-STRING
+ VECTOR
+ VECTOR-8B-FILL!
+ VECTOR-8B-FIND-NEXT-CHAR
+ VECTOR-8B-FIND-NEXT-CHAR-CI
+ VECTOR-8B-FIND-PREVIOUS-CHAR
+ VECTOR-8B-FIND-PREVIOUS-CHAR-CI
+ VECTOR-8B-REF
+ VECTOR-8B-SET!
+ VECTOR-LENGTH
+ VECTOR-REF
+ VECTOR-SET!
+ WITH-HISTORY-DISABLED
+ WITH-INTERRUPT-MASK
+ WRITE-BITS!
+ ZERO? ))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gimprt.scm,v 4.1 1988/06/13 12:29:33 cph Rel $
+
+Copyright (c) 1988 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 Imports
+
+(declare (usual-integrations))
+
+(define scode-assignment? assignment?)
+(define scode-open-block? open-block?)
+(define scode-sequence? sequence?)
\ No newline at end of file
;;;; Unordered Set abstraction
-(declare (usual-integrations))
-(declare (automagic-integrations))
-(declare (open-block-optimizations))
+(declare (usual-integrations)
+ (automagic-integrations)
+ (open-block-optimizations))
\f
-
#|
Each set has an ELEMENT-TYPE which is a predicate that all elements of
(define any-type?)
|#
-
-(using-syntax sf-syntax-table
-
-(declare (integrate-operator list-deletor member-procedure))
-
-(declare (integrate empty-set
- singleton-set
- set/member?
- set/adjoin
- set/remove
- set->list
- set/for-each
- set/map
- set/empty?
- ))
-
-#|
-
-;;; Snarfed from "runtime/list.scm"
-
-(define (member-procedure predicate)
- (lambda (element list)
- (let loop ((list list))
- (and (pair? list)
- (if (predicate (car list) element)
- list
- (loop (cdr list)))))))
-
-(define (list-deletor predicate)
- (define (list-deletor-loop list)
- (if (pair? list)
- (if (predicate (car list))
- (list-deletor-loop (cdr list))
- (cons (car list) (list-deletor-loop (cdr list))))
- '()))
- list-deletor-loop)
-
-(define-named-structure set element-type predicate elements)
-
-((access add-unparser-special-object! unparser-package)
- *set-tag
- (lambda (set)
- (unparse-with-brackets
- (lambda ()
- (write-string "Unordered Set ")
- (write (hash set))
- (write-string " of ")
- (display (%set-element-type set))))))
-
-(define-integrable (check-type element-type element)
- (or (element-type element)
- (error "Element of wrong type -- CHECK-TYPE" element-type element)))
-|#
-
+\f
(define-integrable (check-type element-type element)
- element-type element ;are ignored
- #t)
+ element-type element ;ignore
+ true)
(define-integrable (member-procedure predicate)
- predicate ; ignore
+ predicate ;ignore
memq)
-(define (list-deletor predicate)
- (declare (integrate predicate))
- (define (list-deletor-loop list)
- (if (pair? list)
- (if (predicate (car list))
- (list-deletor-loop (cdr list))
- (cons (car list) (list-deletor-loop (cdr list))))
- '()))
- list-deletor-loop)
+(define-integrable (list-deletor predicate)
+ (letrec ((list-deletor-loop
+ (lambda (list)
+ (if (pair? list)
+ (if (predicate (car list))
+ (list-deletor-loop (cdr list))
+ (cons (car list) (list-deletor-loop (cdr list))))
+ '()))))
+ list-deletor-loop))
-(define-integrable (set? object) object #t)
+(define-integrable (set? object)
+ object ;ignore
+ true)
(define-integrable (%make-set element-type predicate elements)
- element-type ; ignore two
- predicate
+ element-type predicate ;ignore
elements)
(define-integrable (%unsafe-set-element-type set)
- set ; ignore
+ set ;ignore
(lambda (object)
(declare (integrate object))
- object ; ignore
- #t))
+ object ;ignore
+ true))
(define-integrable (%unsafe-set-predicate set)
- set ; ignore
+ set ;ignore
eq?)
-(define-integrable (%unsafe-set-elements set) set)
+(define-integrable (%unsafe-set-elements set)
+ set)
(define-integrable (set-element-type set)
(%unsafe-set-element-type set))
-(declare (integrate-operator adjoin-lists-without-duplicates))
-
-(define (adjoin-lists-without-duplicates predicate l1 l2)
- predicate ; is ignored
- (declare (integrate l1 l2))
- (let ((member? memq))
- (declare (integrate member?))
- (define (loop new-list old-list)
- (cond ((null? old-list) new-list)
- ((member? (car old-list) new-list) (loop new-list (cdr old-list)))
- (else (loop (cons (car old-list) new-list) (cdr old-list)))))
- (loop l1 l2)))
+(define-integrable (adjoin-lists-without-duplicates predicate l1 l2)
+ predicate ;ignore
+ (let loop ((new-list l1) (old-list l2))
+ (cond ((null? old-list) new-list)
+ ((memq (car old-list) new-list) (loop new-list (cdr old-list)))
+ (else (loop (cons (car old-list) new-list) (cdr old-list))))))
(define-integrable (invert-sense predicate)
(lambda (object)
(declare (integrate object))
(not (predicate object))))
-
+\f
(define-integrable (%subset predicate list)
((list-deletor (invert-sense predicate)) list))
;;; End of speed hack.
-(declare (integrate-operator spread-set spread-2-sets))
-
+(declare (integrate-operator spread-set))
(define (spread-set set receiver)
(declare (integrate receiver))
(if (not (set? set))
- (error "Object not a set" set)
- (receiver (%unsafe-set-element-type set)
- (%unsafe-set-predicate set)
- (%unsafe-set-elements set))))
+ (error "Object not a set" set))
+ (receiver (%unsafe-set-element-type set)
+ (%unsafe-set-predicate set)
+ (%unsafe-set-elements set)))
#|
(define (spread-2-sets set1 set2 receiver)
(error "Set mismatch")
(receiver etype1 pred1 stream1 stream2)))))))
|#
-(define (spread-2-sets set1 set2 receiver)
- (declare (integrate set1 set2 receiver))
+(define-integrable (spread-2-sets set1 set2 receiver)
(spread-set set1
(lambda (etype1 pred1 stream1)
(declare (integrate etype1 pred1))
(lambda (etype2 pred2 stream2)
etype2 pred2 ; are ignored
(receiver etype1 pred1 stream1 stream2))))))
-
+\f
(define (set/member? set element)
(spread-set set
(lambda (element-type predicate list)
(declare (integrate-operator adjoin-element))
(define (adjoin-element predicate element list)
- (declare (integrate list))
- predicate ; is ignored
+ (declare (integrate list))
+ predicate ;ignore
(if (memq element list)
list
(cons element list)))
(define (set/adjoin set element)
(spread-set set
(lambda (element-type predicate list)
- (declare (integrate stream))
+ (declare (integrate list))
(check-type element-type element)
(%make-set element-type predicate
(adjoin-element predicate element list)))))
(spread-set set
(lambda (element-type predicate list)
(declare (integrate list))
- element-type
- predicate
+ element-type predicate ;ignore
(list->stream list))))
(define (list->stream list)
(spread-set set
(lambda (element-type predicate l)
(declare (integrate list))
- element-type
- predicate
+ element-type predicate ;ignore
(apply list l))))
(define (set/for-each function set)
(spread-set set
(lambda (element-type predicate list)
(declare (integrate list))
- element-type
- predicate
+ element-type predicate ;ignore
(for-each function list))))
-
+\f
#|
(define (set/map new-element-type new-predicate function set)
(spread-set set
- (lambda (e p list)
+ (lambda (element-type predicate list)
(declare (integrate list))
- e
- p
+ element-type predicate ;ignore
(%make-set new-element-type new-predicate
(remove-duplicates
new-predicate
(error "Element of wrong type" new-element))))
list))))))
|#
+
(define (set/map new-element-type new-predicate function set)
(spread-set set
- (lambda (e p l)
+ (lambda (element-type predicate list)
(declare (integrate list))
- e
- p
+ element-type predicate ;ignore
(%make-set new-element-type new-predicate
- (remove-duplicates eq? (map function l))))))
+ (remove-duplicates eq? (map function list))))))
(define (set/empty? set)
(spread-set set
(lambda (element-type predicate list)
(declare (integrate list))
- element-type
- predicate
+ element-type predicate ;ignore
(null? list))))
(define (interleave l1 l2)
(not ((member-procedure pred) l1-element l2)))
l1)))))
-(define (any-type? element) element true)
-
-)
-
+(define (any-type? element)
+ element ;ignore
+ true)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.4 1988/05/11 04:18:27 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.5 1988/06/13 12:29:43 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
;;;; SCode Optimizer: System Construction
-(in-package system-global-environment
(declare (usual-integrations))
-\f
-(define sf)
-(define sfu? false)
-(define sf/set-default-syntax-table!)
-(define sf/set-file-syntax-table!)
-(define sf/add-file-declarations!)
-(define package/scode-optimizer
- (make-environment
- (define package/top-level (make-environment))
- (define package/transform (make-environment))
- (define package/integrate (make-environment))
- (define package/cgen (make-environment))
- (define package/expansion (make-environment))
- (define package/declarations (make-environment))
- (define package/copy (make-environment))
- (define package/free (make-environment))
- (define package/change-type (make-environment))))
-
-(in-package package/scode-optimizer
-
- (define scode-optimizer/system
- (make-environment
- (define :name "SF")
- (define :version 4)
- (define :modification 4)
- (define :files)
-
- (define :rcs-header ;RCS sets up this string.
- "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.4 1988/05/11 04:18:27 jinx Exp $")
-
- (define :files-lists
- (list
- (cons system-global-environment
- '(
- "sfmac.bin" ; Macros for SF
- ))
- (cons package/scode-optimizer
- '(
- "mvalue.bin" ; Multiple Value Support
- "lsets.bin" ; Set Data Abstraction
- "table.bin" ; Table Abstraction
- "pthmap.bin" ; Pathname Map Abstraction
- "object.bin" ; Data Structures
- "emodel.bin" ; Environment Model
- "gconst.bin" ; Global Primitives List
- "usicon.bin" ; Usual Integrations: Constants
- "tables.bin" ; Operation Table Abstractions
- "packag.bin" ; Global packaging
- ))
- (cons package/top-level
- '("toplev.bin")) ; Top Level
- (cons package/transform
- '("xform.bin")) ; SCode -> Internal
- (cons package/integrate
- '("subst.bin")) ; Beta Substitution Optimizer
- (cons package/cgen
- '("cgen.bin")) ; Internal -> SCode
- (cons package/expansion
- '("usiexp.bin" ; Usual Integrations: Expanders
- "reduct.bin")) ; User defined expanders
- (cons package/declarations
- '("pardec.bin")) ; Declaration Parser
- (cons package/copy
- '("copy.bin")) ; Copy Expressions
- (cons package/free
- '("free.bin")) ; Free Variable Analysis
- (cons package/change-type
- '("chtype.bin")) ; Type interning
- ))))
-
- (load-system! scode-optimizer/system true)
-
- (scode-optimizer/initialize!))
-
-#|
-
-See also the file SFSF.scm
-
-|#
-;;; end IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT
-)
\ No newline at end of file
+(package/system-loader "sf" '() 'QUERY)
+((package/reference (find-package '(SCODE-OPTIMIZER))
+ 'USUAL-INTEGRATIONS/CACHE!))
+(add-system! (make-system "SF" 4 5 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 3.2 1988/03/22 17:37:47 jrm Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 4.1 1988/06/13 12:29:47 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
;;;; SCode Optimizer: Data Types
-(declare (usual-integrations))
-(declare (automagic-integrations))
-(declare (open-block-optimizations))
+(declare (usual-integrations)
+ (automagic-integrations)
+ (open-block-optimizations))
\f
-(let-syntax ()
-
-(define-syntax define-type
- (macro (name enumeration slots)
- (let ((enumerand (symbol-append name '/ENUMERAND)))
- `(BEGIN
- (DEFINE ,enumerand
- (ENUMERATION/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)))))
-\f
-;;;; Objects
-
-(declare (integrate object/allocate)
- (integrate-operator object/enumerand object/set-enumerand!))
-
-(define object/allocate vector)
-
-(define (object/enumerand object)
- (declare (integrate object))
+(let-syntax
+ ((define-enumerand
+ (macro (name enumeration)
+ `(DEFINE ,(symbol-append name '/ENUMERAND)
+ (ENUMERATION/NAME->ENUMERAND
+ ,(symbol-append 'ENUMERATION/ enumeration)
+ ',name))))
+ (define-simple-type
+ (macro (name enumeration slots)
+ `(BEGIN
+ (DEFINE-ENUMERAND ,name ,enumeration)
+ (DEFINE-STRUCTURE (,name
+ (NAMED ,(symbol-append name '/ENUMERAND))
+ (CONC-NAME ,(symbol-append name '/))
+ (CONSTRUCTOR ,(symbol-append name '/MAKE)))
+ ,@slots)))))
+
+(define-integrable (object/enumerand object)
(vector-ref object 0))
-(define (object/set-enumerand! object enumerand)
- (declare (integrate object enumerand))
+(define-integrable (set-object/enumerand! object enumerand)
(vector-set! object 0 enumerand))
-
-(define (object/predicate enumerand)
- (lambda (object)
- (and (vector? object)
- (not (zero? (vector-length object)))
- (eq? enumerand (vector-ref object 0)))))
\f
;;;; Enumerations
enumerands)
enumeration)))
-(declare (integrate-operator enumerand/enumeration enumerand/name
- enumerand/index enumeration/cardinality
- enumeration/index->enumerand
- enumeration/name->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-structure (enumerand (type vector)
+ (conc-name enumerand/))
+ (enumeration false read-only true)
+ (name false read-only true)
+ (index false read-only true))
-(define (enumeration/cardinality enumeration)
- (declare (integrate enumeration))
+(define-integrable (enumeration/cardinality enumeration)
(vector-length (car enumeration)))
-(define (enumeration/index->enumerand enumeration index)
- (declare (integrate enumeration index))
+(define-integrable (enumeration/index->enumerand enumeration index)
(vector-ref (car enumeration) index))
(define (enumeration/name->enumerand enumeration name)
VARIABLE
)))
-(define-type block random
- (parent children safe? declarations bound-variables flags))
+(define-enumerand block random)
+(define-structure (block (named block/enumerand)
+ (conc-name block/)
+ (constructor %block/make))
+ parent
+ children
+ safe?
+ declarations
+ bound-variables
+ flags)
(define (block/make parent safe?)
(let ((block
- (object/allocate block/enumerand parent '() safe?
- (declarations/make-null) '() '())))
+ (%block/make parent '() safe? (declarations/make-null) '() '())))
(if parent
- (block/set-children! parent (cons block (block/children parent))))
+ (set-block/children! parent (cons block (block/children parent))))
block))
-(define-type delayed-integration random
- (state environment operations value))
-
-(declare (integrate-operator delayed-integration/make))
-
-(define (delayed-integration/make operations expression)
- (declare (integrate operations expression))
- (object/allocate delayed-integration/enumerand 'NOT-INTEGRATED false
- operations expression))
+(define-enumerand delayed-integration random)
+(define-structure (delayed-integration
+ (named delayed-integration/enumerand)
+ (conc-name delayed-integration/)
+ (constructor delayed-integration/make (operations value)))
+ (state 'NOT-INTEGRATED)
+ (environment false)
+ operations
+ value)
(define-simple-type variable random
(block name flags))
(define (variable/make&bind! block name)
(let ((variable (variable/make block name '())))
- (block/set-bound-variables! block
+ (set-block/bound-variables! block
(cons variable
(block/bound-variables block)))
variable))
-(define (variable/flag? variable flag)
+(define-integrable (variable/flag? variable flag)
(memq flag (variable/flags variable)))
-(define (variable/set-flag! variable flag)
- (declare (integrate variable/flag))
+(define (set-variable/flag! variable flag)
(if (not (variable/flag? variable flag))
- (variable/set-flags! variable
+ (set-variable/flags! variable
(cons flag (variable/flags variable)))))
(let-syntax ((define-flag
(DEFINE (,tester VARIABLE)
(VARIABLE/FLAG? VARIABLE (QUOTE ,name)))
(DEFINE (,setter VARIABLE)
- (VARIABLE/SET-FLAG! VARIABLE (QUOTE ,name)))))))
+ (SET-VARIABLE/FLAG! VARIABLE (QUOTE ,name)))))))
(define-flag SIDE-EFFECTED variable/side-effected variable/side-effect!)
(define-flag REFERENCED variable/referenced variable/reference!)
(enumeration/name->index enumeration/expression type-name)
method)))
-(declare (integrate-operator expression/method name->method))
-
-(define (expression/method dispatch-vector expression)
- (declare (integrate dispatch-vector expression))
+(define-integrable (expression/method dispatch-vector expression)
(vector-ref dispatch-vector (enumerand/index (object/enumerand expression))))
-(define (name->method dispatch-vector name)
+(define-integrable (name->method dispatch-vector name)
;; Useful for debugging
- (declare (integrate dispatch-vector name))
(vector-ref dispatch-vector
(enumeration/name->index enumeration/expression name)))
\f
(define-simple-type the-environment expression (block))
;;; end LET-SYNTAX
-)
\ No newline at end of file
+)
+
+(define-integrable (constant->integration-info constant)
+ (make-integration-info (constant/make constant) '()))
+
+(define-integrable (make-integration-info expression uninterned-variables)
+ (cons expression uninterned-variables))
+
+(define-integrable (integration-info/expression integration-info)
+ (car integration-info))
+
+(define-integrable (integration-info/uninterned-variables integration-info)
+ (cdr integration-info))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.8 1988/05/11 04:18:50 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 4.1 1988/06/13 12:29:54 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(open-block-optimizations)
(automagic-integrations)
(eta-substitution)
- (integrate-external "object" "mvalue"))
+ (integrate-external "object"))
\f
(define (declarations/make-null)
(declarations/make '() '() '()))
(define (declarations/parse block declarations)
- (transmit-values
- (accumulate
- (lambda (declaration bindings)
- (let ((association (assq (car declaration) known-declarations)))
- (if (not association)
- bindings
- (transmit-values (cdr association)
- (lambda (before-bindings? parser)
- (let ((block
- (if before-bindings?
- (let ((block (block/parent block)))
- (if (block/parent block)
- (warn "Declaration not at top level"
- declaration))
- block)
- block)))
- (parser block
- (bindings/cons block before-bindings?)
- bindings
- (cdr declaration))))))))
- (return-2 '() '())
- declarations)
- (lambda (before after)
- (declarations/make declarations before after))))
+ (let ((bindings
+ (accumulate
+ (lambda (bindings declaration)
+ (let ((association (assq (car declaration) known-declarations)))
+ (if (not association)
+ bindings
+ (let ((before-bindings? (car (cdr association)))
+ (parser (cdr (cdr association))))
+ (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)))))))
+ (cons '() '())
+ declarations)))
+ (declarations/make declarations (car bindings) (cdr bindings))))
(define (bindings/cons block before-bindings?)
(lambda (bindings global? operation export? names values)
names
(block/lookup-names block names true))
values)))
- (transmit-values bindings
- (lambda (before after)
- (if before-bindings?
- (return-2 (cons result before) after)
- (return-2 before (cons result after))))))))
+ (if before-bindings?
+ (cons (cons result (car bindings)) (cdr bindings))
+ (cons (car bindings) (cons result (cdr bindings)))))))
-(declare (integrate-operator bind/general bind/values bind/no-values))
-
-(define (bind/general table/cons table global? operation export? names values)
- (declare (integrate table/cons table global? operation export? names values))
+(define-integrable (bind/general table/cons table global? operation export?
+ names values)
(table/cons table global? operation export? names values))
-(define (bind/values table/cons table operation export? names values)
- (declare (integrate table/cons table operation export? names values))
+(define-integrable (bind/values table/cons table operation export? names
+ values)
(table/cons table (not export?) operation export? names values))
-(define (bind/no-values table/cons table operation export? names)
- (declare (integrate table/cons table operation export? names))
+(define-integrable (bind/no-values table/cons table operation export? names)
(table/cons table false operation export? names 'NO-VALUES))
\f
-(define (declarations/known? declaration)
- (assq (car declaration) known-declarations))
-
;; before-bindings? should be true if binding <name> should nullify
;; the declaration. It should be false if a binding and the
;; declaration can "coexist".
(define (define-declaration name before-bindings? parser)
(let ((entry (assq name known-declarations)))
(if entry
- (set-cdr! entry (return-2 before-bindings? parser))
+ (set-cdr! entry (cons before-bindings? parser))
(set! known-declarations
- (cons (cons name (return-2 before-bindings? parser))
+ (cons (cons name (cons before-bindings? parser))
known-declarations)))))
+(define-integrable (declarations/known? declaration)
+ (assq (car declaration) known-declarations))
+
(define known-declarations
'())
(let loop ((table table) (items items))
(if (null? items)
table
- (loop (cons (car items) table) (cdr items)))))
+ (loop (cons table (car items)) (cdr items)))))
\f
(define (declarations/binders declarations)
(let ((procedure
(lambda (bindings)
(lambda (operations)
- (accumulate (lambda (binding operations)
+ (accumulate (lambda (operations binding)
((if (binding/global? binding)
operations/bind-global
operations/bind)
(binding/values binding)))
operations
bindings)))))
- (return-2 (procedure (declarations/before declarations))
- (procedure (declarations/after declarations)))))
+ (values (procedure (declarations/before declarations))
+ (procedure (declarations/after declarations)))))
(define (declarations/for-each-variable declarations procedure)
(declarations/for-each-binding declarations
(list-copy (binding/names binding))
'()))
(declarations/after declarations)))
-\f
-(declare (integrate-operator declarations/make declarations/original
- declarations/before declarations/after))
-
-(define (declarations/make original before after)
- (declare (integrate original before after))
- (vector original before after))
-
-(define (declarations/original declarations)
- (declare (integrate declarations))
- (vector-ref declarations 0))
-
-(define (declarations/before declarations)
- (declare (integrate declarations))
- (vector-ref declarations 1))
-
-(define (declarations/after declarations)
- (declare (integrate declarations))
- (vector-ref declarations 2))
-
-(declare (integrate-operator binding/make binding/global? binding/operation
- binding/export? binding/names binding/values))
-
-(define (binding/make global? operation export? names values)
- (declare (integrate global? operation export? names values))
- (vector global? operation export? names values))
-
-(define (binding/global? binding)
- (declare (integrate binding))
- (vector-ref binding 0))
-
-(define (binding/operation binding)
- (declare (integrate binding))
- (vector-ref binding 1))
-
-(define (binding/export? binding)
- (declare (integrate binding))
- (vector-ref binding 2))
-
-(define (binding/names binding)
- (declare (integrate binding))
- (vector-ref binding 3))
-(define (binding/values binding)
- (declare (integrate binding))
- (vector-ref binding 4))
+(define-structure (declarations
+ (type vector)
+ (constructor declarations/make)
+ (conc-name declarations/))
+ (original false read-only true)
+ (before false read-only true)
+ (after false read-only true))
+
+(define-structure (binding
+ (type vector)
+ (constructor binding/make)
+ (conc-name binding/))
+ (global? false read-only true)
+ (operation false read-only true)
+ (export? false read-only true)
+ (names false read-only true)
+ (values false read-only true))
\f
;;;; Integration of System Constants
(define-declaration 'USUAL-INTEGRATIONS true
(lambda (block table/cons table deletions)
- block ; ignored
+ block ;ignored
(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))))))
+ (lambda (table operation names vals)
+ (with-values
+ (lambda ()
+ (if (null? deletions)
+ (values names vals)
+ (let deletion-loop ((names names) (vals vals))
+ (cond ((null? names) (values '() '()))
+ ((memq (car names) deletions)
+ (deletion-loop (cdr names) (cdr vals)))
+ (else
+ (with-values
+ (lambda ()
+ (deletion-loop (cdr names) (cdr vals)))
+ (lambda (names* vals*)
+ (values (cons (car names) names*)
+ (cons (car vals) vals*)))))))))
+ (lambda (names vals)
+ (bind/values table/cons table operation false names vals))))))
(finish (finish table 'INTEGRATE
usual-integrations/constant-names
usual-integrations/constant-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)))))
+ (with-values
+ (lambda ()
+ (let loop ((specifications specifications))
+ (if (null? specifications)
+ (values '() '())
+ (with-values (lambda () (loop (cdr specifications)))
+ (lambda (names vals)
+ (with-values
+ (lambda ()
+ (parse-primitive-specification block
+ (car specifications)))
+ (lambda (name value)
+ (values (cons name names) (cons value vals)))))))))
+ (lambda (names vals)
+ (bind/values table/cons table 'INTEGRATE true names vals)))))
(define (parse-primitive-specification block specification)
- block ; ignored
+ block ;ignored
(let ((finish
(lambda (variable-name primitive-name)
- (return-2 variable-name
- (constant->integration-info
- (make-primitive-procedure primitive-name))))))
+ (values variable-name
+ (constant->integration-info
+ (make-primitive-procedure primitive-name))))))
(cond ((and (pair? specification)
(symbol? (car specification))
(pair? (cdr specification))
(else (error "Bad primitive specification" specification)))))
\f
;;; Special declarations courtesy JRM
-
-;; I return the operations table unmodified, but bash on the
-;; block. This actually works pretty well.
-
-;; One problem here with this multiple values hack is that
-;; table is a multiple value -- yuck!
-
-(define-declaration 'AUTOMAGIC-INTEGRATIONS false
- (lambda (block table/cons table names)
- table/cons
- names
- (block/set-flags! block
- (cons 'AUTOMAGIC-INTEGRATIONS (block/flags block)))
- table))
-
-(define-declaration 'ETA-SUBSTITUTION false
- (lambda (block table/cons table names)
- table/cons
- names
- (block/set-flags! block
- (cons 'ETA-SUBSTITUTION (block/flags block)))
- table))
-
-(define-declaration 'OPEN-BLOCK-OPTIMIZATIONS false
- (lambda (block table/cons table names)
- table/cons
- names
- (block/set-flags! block
- (cons 'OPEN-BLOCK-OPTIMIZATIONS (block/flags block)))
- table))
-
-(define-declaration 'NO-AUTOMAGIC-INTEGRATIONS false
- (lambda (block table/cons table names)
- table/cons
- names
- (block/set-flags! block
- (cons 'NO-AUTOMAGIC-INTEGRATIONS (block/flags block)))
- table))
-
-(define-declaration 'NO-ETA-SUBSTITUTION false
- (lambda (block table/cons table names)
- table/cons
- names
- (block/set-flags! block
- (cons 'NO-ETA-SUBSTITUTION (block/flags block)))
- table))
-
-(define-declaration 'NO-OPEN-BLOCK-OPTIMIZATIONS false
- (lambda (block table/cons table names)
- table/cons
- names
- (block/set-flags! block
- (cons 'NO-OPEN-BLOCK-OPTIMIZATIONS
- (block/flags block)))
- table))
-
+;;; I return the operations table unmodified, but bash on the
+;;; block. This actually works pretty well.
+
+(for-each (lambda (flag)
+ (define-declaration flag false
+ (lambda (block table/cons table names)
+ table/cons names ;ignore
+ (set-block/flags! block (cons flag (block/flags block)))
+ table)))
+ '(AUTOMAGIC-INTEGRATIONS
+ ETA-SUBSTITUTION
+ OPEN-BLOCK-OPTIMIZATIONS
+ NO-AUTOMAGIC-INTEGRATIONS
+ NO-ETA-SUBSTITUTION
+ NO-OPEN-BLOCK-OPTIMIZATIONS))
\f
;;;; Integration of User Code
(define-declaration 'INTEGRATE false
(lambda (block table/cons table names)
- block ; ignored
+ block ;ignored
(bind/no-values table/cons table 'INTEGRATE true names)))
(define-declaration 'INTEGRATE-OPERATOR false
(lambda (block table/cons table names)
- block ; ignored
+ block ;ignored
(bind/no-values table/cons table 'INTEGRATE-OPERATOR true names)))
(define-declaration 'INTEGRATE-EXTERNAL true
(lambda (block table/cons table specifications)
- block ; ignored
+ block ;ignored
(accumulate
- (lambda (extern table)
+ (lambda (table extern)
(bind/values table/cons table (vector-ref extern 1) false
(list (vector-ref extern 0))
(list
(define (specification->pathnames specification)
(let ((value
(scode-eval (syntax specification system-global-syntax-table)
- (access syntax-environment syntaxer-package))))
+ syntaxer/default-environment)))
(if (pair? value)
(map ->pathname value)
(list (->pathname value)))))
(let ((finish
(lambda (value)
(if-ok
- (transmit-values (copy/expression/extern value)
+ (with-values (lambda () (copy/expression/extern value))
(lambda (block expression)
(vector (variable/name variable)
operation
block
expression)))))))
(if info
- (transmit-values info
- (lambda (value uninterned)
- uninterned ; ignored
- (finish value)))
+ (finish (integration-info/expression info))
(variable/final-value variable environment finish if-not))))))
\f
;;;; User provided reductions and expansions
(define-declaration 'REDUCE-OPERATOR false
(lambda (block table/cons table reduction-rules)
- block ; ignored
+ block ;ignored
;; Maybe it wants to be exported?
(bind/general table/cons table false 'EXPAND false
(map car reduction-rules)
(reducer/make rule block))
reduction-rules))))
-;; Expansions. These should be used with great care, and require
-;; knowing a fair amount about the internals of sf. This declaration
-;; is purely a hook, with no convenience.
-
-(define expander-evaluation-environment
- (access package/expansion
- package/scode-optimizer))
+;;; Expansions. These should be used with great care, and require
+;;; knowing a fair amount about the internals of sf. This declaration
+;;; is purely a hook, with no convenience.
(define-declaration 'EXPAND-OPERATOR true
(lambda (block table/cons table expanders)
- block ; ignored
+ block ;ignored
(bind/general table/cons table false 'EXPAND false
(map car expanders)
(map (lambda (expander)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pthmap.scm,v 1.2 1988/03/22 17:38:21 jrm Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pthmap.scm,v 4.1 1988/06/13 12:30:05 cph Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
;;;; Pathname Maps
-(declare (usual-integrations))
-(declare (automagic-integrations))
-(declare (open-block-optimizations))
-(declare (eta-substitution))
+(declare (usual-integrations)
+ (automagic-integrations)
+ (open-block-optimizations)
+ (eta-substitution))
\f
(define pathname-map/make)
(define pathname-map?)
(define pathname-map/tag "pathname-map")
(define pathname-map/root-node cdr)
-((access add-unparser-special-pair! unparser-package)
+(unparser/set-tagged-pair-method!
pathname-map/tag
- (lambda (map)
- ((access unparse-with-brackets unparser-package)
- (lambda ()
- (write-string "PATHNAME-MAP ")
- (write (hash map))))))
+ (unparser/standard-method "PATHNAME-MAP"))
(declare (integrate-operator node/make))
(define unbound-value "unbound-value")
(define node/value car)
-(define node/set-value! set-car!)
+(define set-node/value! set-car!)
(define node/alist cdr)
-(define node/set-alist! set-cdr!)
+(define set-node/alist! set-cdr!)
(define (node/associate node key)
(let ((entry (assoc key (node/alist node))))
(set! pathname-map/insert!
(named-lambda (pathname-map/insert! map pathname value)
- (node/set-value! (find-or-create-node (pathname-map/root-node map)
+ (set-node/value! (find-or-create-node (pathname-map/root-node map)
(make-node-list pathname))
value)))
(define (create-node node node-list)
(let ((next (node/make)))
- (node/set-alist! node
+ (set-node/alist! node
(cons (cons (car node-list) next)
(node/alist node)))
(if (null? (cdr node-list))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/reduct.scm,v 1.1 1988/05/11 04:20:07 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/reduct.scm,v 4.1 1988/06/13 12:30:09 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(reference/make
block
(or (block/lookup-name block name false)
- (block/lookup-name global-block name true))))
+ (block/lookup-name (integrate/get-top-level-block) name true))))
(declare (integrate-operator handle-variable))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/sf.pkg,v 4.1 1988/06/13 12:28:55 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. |#
+
+;;;; SF Packaging
+\f
+(global-definitions "../runtime/runtim")
+
+(define-package (scode-optimizer)
+ (files "lsets"
+ "table"
+ "pthmap"
+ "object"
+ "emodel"
+ "gconst"
+ "usicon"
+ "tables")
+ (parent ()))
+
+(define-package (scode-optimizer global-imports)
+ (files "gimprt")
+ (parent ())
+ (export (scode-optimizer)
+ scode-assignment?
+ scode-open-block?
+ scode-sequence?))
+
+(define-package (scode-optimizer top-level)
+ (files "toplev")
+ (parent (scode-optimizer))
+ (export ()
+ sf
+ sf/add-file-declarations!
+ sf/set-default-syntax-table!
+ sf/set-file-syntax-table!
+ sfu?)
+ (export (scode-optimizer)
+ integrate/procedure
+ integrate/file
+ integrate/sexp
+ integrate/scode
+ read-externs-file)
+ (import (runtime syntaxer)
+ process-declarations))
+
+(define-package (scode-optimizer transform)
+ (files "xform")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ transform/top-level
+ transform/recursive))
+
+(define-package (scode-optimizer integrate)
+ (files "subst")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ integrate/top-level
+ integrate/get-top-level-block
+ variable/final-value))
+
+(define-package (scode-optimizer cgen)
+ (files "cgen")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ cgen/external)
+ (export (scode-optimizer expansion)
+ cgen/external-with-declarations))
+
+(define-package (scode-optimizer expansion)
+ (files "usiexp" "reduct")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ reducer/make
+ usual-integrations/expansion-names
+ usual-integrations/expansion-values
+ usual-integrations/expansion-alist)
+ (export (scode-optimizer declarations)
+ expander-evaluation-environment))
+
+(define-package (scode-optimizer declarations)
+ (files "pardec")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ declarations/known?
+ declarations/make-null
+ declarations/parse
+ declarations/binders
+ declarations/original
+ declarations/map
+ declarations/for-each-variable
+ declarations/integrated-variables
+ operations->external))
+
+(define-package (scode-optimizer copy)
+ (files "copy")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ copy/expression/intern
+ copy/expression/extern))
+
+(define-package (scode-optimizer free)
+ (files "free")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ free/expression))
+
+(define-package (scode-optimizer change-type)
+ (files "chtype")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ intern-type))
+
+(define-package (scode-optimizer build-utilities)
+ (files "butils")
+ (parent ())
+ (export ()
+ compile-directory
+ compile-directory?
+ file-processed?
+ sf-conditionally
+ sf-directory
+ sf-directory?))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/sf.sf,v 4.1 1988/06/13 12:28:58 cph Exp $
+
+Copyright (c) 1988 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. |#
+
+(sf/set-default-syntax-table! system-global-syntax-table)
+(sf-conditionally "object")
+(sf-conditionally "lsets")
+(sf-directory ".")
+(cref/generate-all "sf")(sf "sf.con" "sf.bcon")
+(sf "sf.ldr" "sf.bldr")
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.10 1988/05/11 04:19:05 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 4.1 1988/06/13 12:30:15 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(declare (usual-integrations)
(eta-substitution)
(open-block-optimizations)
- (integrate-external "object" "mvalue" "lsets"))
+ (integrate-external "object" "lsets"))
\f
-
-(using-syntax sf-syntax-table
-
(define *top-level-block*)
(define (integrate/get-top-level-block)
*top-level-block*)
-;; Block names are added to this list so
-;; warnings can be more descriptive.
-
+;;; Block names are added to this list so warnings can be more
+;;; descriptive.
(define *current-block-names*)
(define (integrate/top-level block expression)
(*current-block-names* '()))
(process-block-flags (block/flags block)
(lambda ()
- (let ((operations (operations/bind-block (operations/make) block))
+ (let ((operations (operations/bind-block (operations/make) block))
(environment (environment/make)))
(if (open-block? expression)
- (transmit-values
- (environment/recursive-bind operations environment
- (open-block/variables expression)
- (open-block/values expression))
- (lambda (environment values)
- (return-3 operations
- environment
- (quotation/make block
- (integrate/open-block operations
- environment
- expression
- values)))))
- (return-3 operations
- environment
- (quotation/make block
- (integrate/expression operations
- environment
- expression)))
+ (with-values
+ (lambda ()
+ (environment/recursive-bind
+ operations environment
+ (open-block/variables expression)
+ (open-block/values expression)))
+ (lambda (environment vals)
+ (values operations
+ environment
+ (quotation/make block
+ (integrate/open-block operations
+ environment
+ expression
+ vals)))))
+ (values 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)
+ (with-values (lambda () (declarations/binders declarations))
(lambda (before-bindings after-bindings)
(after-bindings
(operations/shadow (before-bindings operations)
(operations/lookup operations variable
(lambda (operation info)
(case operation
- ((INTEGRATE-OPERATOR EXPAND)
- (variable/reference! variable)
+ ((INTEGRATE-OPERATOR EXPAND)
+ (variable/reference! variable)
expression)
((INTEGRATE)
(integrate/name expression info environment
(lambda (new-expression)
(variable/integrated! variable)
new-expression)
- (lambda ()
+ (lambda ()
(variable/reference! variable)
expression)))
(else (error "Unknown operation" operation))))
(lambda (value)
(if (constant-value? value)
(if-win
- (copy/expression (reference/block reference) value
- #f))
+ (copy/expression/intern (reference/block reference)
+ value
+ #f))
(if-fail)))))
(environment/lookup environment variable
(lambda (value)
(and (reference? value)
(not (variable/side-effected (reference/variable value)))
(block/safe? (variable/block (reference/variable value))))))
-
+\f
(define (integrate/reference-operator operations environment operator operands)
(let ((variable (reference/variable operator)))
(let ((dont-integrate
(let ((variable (assignment/variable assignment)))
(operations/lookup operations variable
(lambda (operation info)
- info
+ info ;ignore
(case operation
((INTEGRATE INTEGRATE-OPERATOR EXPAND)
(warn "Attempt to assign integrated name"
(operations/bind-block operations (open-block/block expression))))
(process-block-flags (block/flags (open-block/block expression))
(lambda ()
- (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))))))))
+ (with-values
+ (lambda ()
+ (environment/recursive-bind operations
+ environment
+ (open-block/variables expression)
+ (open-block/values expression)))
+ (lambda (environment vals)
+ (integrate/open-block operations environment expression
+ vals))))))))
(define (process-block-flags flags continuation)
(if (null? flags)
(else (error "Bad flag"))))))
(define (integrate/open-block operations environment expression values)
- (let ((actions (map (lambda (action)
- (if (eq? action open-block/value-marker)
- action
- (integrate/expression operations environment action)))
- (open-block/actions expression)))
+ (let ((actions
+ (integrate/actions operations environment
+ (open-block/actions expression)))
(vars (open-block/variables expression)))
;; Complain about unreferenced variables.
;; If the block is unsafe, then it is likely that
;; there will be a lot of them on purpose (top level or
;; the-environment) so no complaining.
(if (block/safe? (open-block/block expression))
- (for-each (lambda (var)
- (if (and (not (variable/integrated var))
- (not (variable/referenced var))
- (not (variable/can-ignore? var)))
+ (for-each (lambda (variable)
+ (if (variable/unreferenced? variable)
(warn "Unreferenced defined variable:"
- (variable/name var))))
+ (variable/name variable))))
vars))
(if (open-block/optimized expression)
- (open-block/make (open-block/block expression)
- vars
- values
- actions
- #t)
+ (open-block/make (open-block/block expression) vars values actions #t)
(open-block/optimizing-make (open-block/block expression)
vars
values
operations
environment))))
-;; Cannot optimize (lambda () (bar)) => bar (eta substitution)
-;; because BAR may be a procedure with different
-;; arity than the lambda
+(define (variable/unreferenced? variable)
+ (and (not (variable/integrated variable))
+ (not (variable/referenced variable))
+ (not (variable/can-ignore? variable))))
+\f
+(define-method/integrate 'PROCEDURE
+ (lambda (operations environment procedure)
+ (integrate/procedure operations
+ (simulate-unknown-application environment procedure)
+ procedure)))
+
+;; Cannot optimize (lambda () (bar)) => bar (eta substitution) because
+;; BAR may be a procedure with different arity than the lambda
#| You can get some weird stuff with this
|#
-
-(define *eta-substitution-switch #f)
-
+(define *eta-substitution-switch #F)
+\f
(define (integrate/procedure operations environment procedure)
(let ((block (procedure/block procedure))
(required (procedure/required procedure))
;; referenced.
(if (block/safe? block)
(for-each (lambda (variable)
- (if (and (not (variable/referenced variable))
- (not (variable/integrated variable))
- (not (variable/can-ignore? variable)))
+ (if (variable/unreferenced? variable)
(warn "Unreferenced bound variable:"
(variable/name variable)
*current-block-names*)))
(null? rest)
(let ((operands (combination/operands body)))
(match-up? operands required))
- (set/empty?
- (set/intersection
+ (set/empty?
+ (set/intersection
(list->set variable? eq? required)
(free/expression (combination/operator body)))))
(combination/operator body)
(eq? (reference/variable this-operand) this-required)
(match-up? (cdr operands) (cdr required)))))))
-
-(define-method/integrate 'PROCEDURE
- (lambda (operations environment procedure)
- (integrate/procedure operations
- (simulate-unknown-application environment procedure)
- procedure)))
-
\f
(define-method/integrate 'COMBINATION
(lambda (operations environment combination)
(let ((declarations (declaration/declarations declaration)))
(declaration/make
declarations
- (transmit-values (declarations/binders declarations)
+ (with-values (lambda () (declarations/binders declarations))
(lambda (before-bindings after-bindings)
(integrate/expression (after-bindings (before-bindings operations))
environment
(consequent (integrate/expression
operations environment
(conditional/consequent expression)))
- (alternative (integrate/expression
+ (alternative (integrate/expression
operations environment
(conditional/alternative expression))))
(if (constant? predicate)
predicate)
(disjunction/make predicate alternative)))))
\f
-
-;; Optimize (begin (foo)) => (foo)
-;; Optimize (begin a b (foo) 22 (bar)) => (begin (foo) (bar))
-
(define-method/integrate 'SEQUENCE
(lambda (operations environment expression)
+ ;; Optimize (begin (foo)) => (foo)
+ ;; Optimize (begin a b (foo) 22 (bar)) => (begin (foo) (bar))
(sequence/optimizing-make
- (integrate/expressions operations environment
- (sequence/actions expression)))))
-
-(define (sequence/optimizing-make expression-list)
- (define (remove-non-side-effecting-expressions expression-list)
- (cond ((null? (cdr expression-list)) expression-list)
- ;; This clause lets you ignore a variable by mentioning it
- ;; in a sequence.
- ((reference? (car expression-list))
- (variable/can-ignore! (reference/variable (car expression-list)))
- (remove-non-side-effecting-expressions (cdr expression-list)))
- ((non-side-effecting-in-sequence? (car expression-list))
- (remove-non-side-effecting-expressions (cdr expression-list)))
- (else (cons (car expression-list)
- (remove-non-side-effecting-expressions
- (cdr expression-list))))))
- (let ((pruned-elist (remove-non-side-effecting-expressions expression-list)))
- (if (null? (cdr pruned-elist))
- (car pruned-elist)
- (sequence/make pruned-elist))))
-
-;; To do this right, we really need a compiler that knows
-;; about call for effect, call for predicate, etc.
+ (integrate/actions operations environment
+ (sequence/actions expression)))))
+
+(define (integrate/actions operations environment actions)
+ (let ((action (car actions)))
+ (if (null? (cdr actions))
+ (list (if (eq? action open-block/value-marker)
+ action
+ (integrate/expression operations environment action)))
+ (cons (cond ((reference? action)
+ ;; This clause lets you ignore a variable by
+ ;; mentioning it in a sequence.
+ (variable/can-ignore! (reference/variable action))
+ action)
+ ((eq? action open-block/value-marker)
+ action)
+ (else
+ (integrate/expression operations environment action)))
+ (integrate/actions operations environment (cdr actions))))))
+
+(define (sequence/optimizing-make actions)
+ (let ((actions (remove-non-side-effecting actions)))
+ (if (null? (cdr actions))
+ (car actions)
+ (sequence/make actions))))
+
+(define (remove-non-side-effecting actions)
+ ;; Do not remove references from sequences, because they have
+ ;; meaning as declarations. The output code generator will take
+ ;; care of removing them when they are no longer needed.
+ (if (null? (cdr actions))
+ actions
+ (let ((rest (remove-non-side-effecting (cdr actions))))
+ (if (non-side-effecting-in-sequence? (car actions))
+ rest
+ (cons (car actions) rest)))))
(define (non-side-effecting-in-sequence? expression)
- (or (constant? expression)
+ ;; Compiler does a better job of this because it is smarter about
+ ;; what kinds of expressions can cause side effects. But this
+ ;; should be adequate to catch most of the simple cases.
+ (or (constant? expression)
(quotation? expression)
- (delay? expression)
+ (delay? expression)
(procedure? expression)
- ;; access if the environment is okay to not
- ;; eval.
- ))
-
+ (and (access? expression)
+ (non-side-effecting-in-sequence? (access/environment expression)))))
+\f
(define-method/integrate 'ACCESS
(lambda (operations environment expression)
(let ((environment* (access/environment expression))
(integrate/quotation (in-package/quotation expression)))))
(define (integrate/quotation quotation)
- (transmit-values (integrate/top-level (quotation/block quotation)
- (quotation/expression quotation))
+ (with-values
+ (lambda ()
+ (integrate/top-level (quotation/block quotation)
+ (quotation/expression quotation)))
(lambda (operations environment expression)
- operations
- environment
+ operations environment ;ignore
expression)))
\f
;;;; Environment
-(define (environment/recursive-bind operations environment variables values)
+(define (environment/recursive-bind operations environment variables vals)
;; 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
+ (let ((vals
(map (lambda (value)
(delayed-integration/make operations value))
- values)))
+ vals)))
(let ((environment
- (environment/bind-multiple environment variables values)))
+ (environment/bind-multiple environment variables vals)))
(for-each (lambda (value)
- (delayed-integration/set-environment! value environment))
- values)
- (return-2 environment
- (map delayed-integration/force values)))))
+ (set-delayed-integration/environment! value environment))
+ vals)
+ (values environment (map delayed-integration/force vals)))))
(define (integrate/name reference info environment if-integrated if-not)
(let ((variable (reference/variable reference)))
(let ((finish
(lambda (value uninterned)
(if-integrated
- (copy/expression (reference/block reference) value
- uninterned)))))
+ (copy/expression/intern (reference/block reference)
+ value
+ uninterned)))))
(if info
- (transmit-values info finish)
+ (finish (integration-info/expression info)
+ (integration-info/uninterned-variables info))
(environment/lookup environment variable
(lambda (value)
(if (delayed-integration? value)
(define (bind-optional environment optional)
(if (null? optional)
(bind-rest environment (procedure/rest procedure))
- (bind-optional
+ (bind-optional
(environment/bind environment (car optional) *unknown-value)
(cdr optional))))
(define (environment/make)
'())
-(declare (integrate environment/bind environment/bind-multiple))
-
-(define (environment/bind environment variable value)
- (declare (integrate environment variable value))
+(define-integrable (environment/bind environment variable value)
(cons (cons variable value) environment))
-(define (environment/bind-multiple environment variables values)
- (declare (integrate environment variables values))
+(define-integrable (environment/bind-multiple environment variables values)
(map* environment cons variables values))
(define (environment/lookup environment variable if-found if-unknown if-not)
(operations
(delayed-integration/operations delayed-integration))
(expression (delayed-integration/value delayed-integration)))
- (delayed-integration/set-state! delayed-integration
+ (set-delayed-integration/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)
+ (set-delayed-integration/environment! delayed-integration false)
+ (set-delayed-integration/operations! delayed-integration false)
+ (set-delayed-integration/value! delayed-integration false)
(integrate/expression operations environment expression))))
- (delayed-integration/set-state! delayed-integration 'INTEGRATED)
- (delayed-integration/set-value! delayed-integration value)))
+ (set-delayed-integration/state! delayed-integration 'INTEGRATED)
+ (set-delayed-integration/value! delayed-integration value)))
((INTEGRATED) 'DONE)
((BEING-INTEGRATED)
(error "Attempt to re-force delayed integration" delayed-integration))
(and (constant? operator)
(primitive-procedure? (constant/value operator))
(memq (constant/value operator) *foldable-primitive-procedures)))
-
+\f
;;; deal with (let () (define ...))
;;; deal with (let ((x 7)) (let ((y 4)) ...)) => (let ((x 7) (y 4)) ...)
;;; Actually, we really don't want to hack with these for various
((and (procedure? operator)
(null? (procedure/optional operator))
(not (procedure/rest operator))
- (block/safe? (procedure/block operator))
- )
+ (block/safe? (procedure/block operator)))
(delete-unreferenced-parameters
(procedure/required operator)
(procedure/body operator)
(append unreferenced-operands (list form))))))))
(else
(combination/make operator operands)))))
-
+\f
(define (delete-unreferenced-parameters parameters body operands receiver)
(let ((free-in-body (free/expression body)))
(let loop ((parameters parameters)
(referenced-operands '())
(unreferenced-operands '()))
(cond ((null? parameters)
- (if (null? operands)
+ (if (null? operands)
(receiver (reverse required-parameters) ; preserve order
(reverse referenced-operands)
unreferenced-operands)
- (error "Argument mismatch" (block/bound-variables block))))
- ((null? operands) (error "Argument mismatch"
- (block/bound-variables block)))
+ (error "Argument mismatch" operands)))
+ ((null? operands)
+ (error "Argument mismatch" parameters))
(else (let ((this-parameter (car parameters))
(this-operand (car operands)))
(cond ((set/member? free-in-body this-parameter)
;; 2 Identify the circular dependencies and place them in
;; a open block.
;; 3 Identify the bindings that can be made in parallel and
-;; make LET type statements.
+;; make LET type statements.
;; 4 This deletes unused bindings in an open block and
;; compartmentalizes the environment.
;; 5 Re-optimize the code in the body. This can help if the
(let ()
-(set! open-block/optimizing-make
+(set! open-block/optimizing-make
(named-lambda (open-block/optimizing-make block vars values actions
operations environment)
(if (and *block-optimizing-switch
; (print-template template)
(integrate/expression
operations
- environment (build-new-code template
- (block/parent block)
+ environment (build-new-code template
+ (block/parent block)
table:var->vals actions))))))
(open-block/make block vars values actions #t))))
(fill-table (cdr vars) (cdr vals)))))
(fill-table vars vals)
table))
-
+\f
(declare (integrate varlist->varset nodelist->nodeset
empty-nodeset singleton-nodeset
empty-varset singleton-varset))
(let ((table (make-generic-eq?-table)))
(define (kernel val)
(let ((free-variables (free/expression val)))
- (table-put! table val
+ (table-put! table val
(set/intersection bound-variables free-variables))))
(for-each kernel vals)
table))
(cond ((null? actions) '())
((eq? (car actions) open-block/value-marker) (get-body (cdr actions)))
(else (cons (car actions) (get-body (cdr actions))))))
-
+\f
;;; Graph structure for figuring out dependencies in a LETREC
-(define-unsafe-named-structure node type vars needs needed-by depth)
+(define-structure (node
+ (constructor %make-node (type vars))
+ (conc-name %node-))
+ type
+ (vars false read-only true)
+ (needs (empty-nodeset))
+ (needed-by (empty-nodeset))
+ (depth false))
-((access add-unparser-special-object! unparser-package)
- *node-tag
- (lambda (node)
- (unparse-with-brackets
- (lambda ()
- (write-string "Node")
- (write (hash node))))))
+(define-integrable (make-base-node)
+ (%make-node 'BASE (empty-varset)))
-(declare (integrate make-base-node variable->node make-letrec-node))
+(define-integrable (variable->node variable)
+ (%make-node 'SETUP (singleton-varset variable)))
-(define (make-base-node)
- (%make-node 'BASE
- (empty-varset)
- (empty-nodeset)
- (empty-nodeset)
- #f))
-
-(define (variable->node variable)
- (declare (integrate variable))
- (%make-node 'SETUP
- (singleton-varset variable)
- (empty-nodeset)
- (empty-nodeset)
- #F))
-
-(define (make-letrec-node variable-set)
- (declare (integrate variable-set))
- (%make-node 'LETREC
- variable-set
- (empty-nodeset)
- (empty-nodeset)
- #f))
-
-(declare (integrate add-node-need! remove-node-need!
- add-node-needed-by! remove-node-needed-by!))
+(define-integrable (make-letrec-node variable-set)
+ (%make-node 'LETREC variable-set))
+(declare (integrate add-node-need!
+ remove-node-need!
+ add-node-needed-by!
+ remove-node-needed-by!))
(define (add-node-need! needer what-i-need)
(declare (integrate what-i-need))
- (%set-node-needs! needer (set/adjoin (%node-needs needer) what-i-need)))
+ (set-%node-needs! needer (set/adjoin (%node-needs needer) what-i-need)))
(define (remove-node-need! needer what-i-no-longer-need)
(declare (integrate what-i-no-longer-need))
- (%set-node-needs! needer
+ (set-%node-needs! needer
(set/remove (%node-needs needer) what-i-no-longer-need)))
(define (add-node-needed-by! needee what-needs-me)
(declare (integrate what-needs-me))
- (%set-node-needed-by! needee
+ (set-%node-needed-by! needee
(set/adjoin (%node-needed-by needee) what-needs-me)))
(define (remove-node-needed-by! needee what-needs-me)
(declare (integrate what-needs-me))
- (%set-node-needed-by! needee
+ (set-%node-needed-by! needee
(set/remove (%node-needed-by needee) what-needs-me)))
-
+\f
(define (build-graph vars table:var->vals table:vals->free body-free)
(let ((table:variable->node (make-generic-eq?-table)))
(set/for-each (lambda (needee)
(remove-node-need! needee node))
(%node-needed-by node))
- (%set-node-type! node 'UNLINKED))
+ (set-%node-type! node 'UNLINKED))
(declare (integrate unlink-nodes!))
(define (unlink-nodes! nodelist)
(for-each unlink-node! nodelist))
-(define (link-nodes! body-free
+(define (link-nodes! body-free
table:var->vals table:vals->free variables table:var->node)
(define (kernel variable)
(for-each kernel variables)
(let ((base-node (make-base-node)))
- (set/for-each
+ (set/for-each
(lambda (needed-var)
(table-get table:var->node needed-var
(lambda (needed-node)
(lambda () (error "Broken analysis: free var"))))
body-free)
base-node))
-
+\f
(define (collapse-circularities! graph)
;; Search for a circularity: if found, collapse it, and repeat
;; until none are found.
(let ((letrec-node (make-letrec-node varset)))
(set/for-each (lambda (need) (link-2-nodes! letrec-node need)) needs-set)
- (set/for-each
+ (set/for-each
(lambda (needer) (link-2-nodes! needer letrec-node)) needed-by)
;; now delete nodes in nodelist
(unlink-nodes! nodelist)))))
-
+\f
(define (label-node-depth! graph)
(define (label-nodes! nodeset depth)
(if (set/empty? nodeset)
'()
(begin
- (set/for-each (lambda (node) (%set-node-depth! node depth)) nodeset)
- (label-nodes!
+ (set/for-each (lambda (node) (set-%node-depth! node depth)) nodeset)
+ (label-nodes!
(apply set/union* (map %node-needs (set->list nodeset)))
(1+ depth)))))
(label-nodes! (singleton-nodeset graph) 0))
(set/for-each print-graph (%node-needs node)))))
(define (collapse-parallel-nodelist depth nodeset)
- (if (set/empty? nodeset)
+ (if (set/empty? nodeset)
'()
(let loop ((nodestream (set->list nodeset))
(let-children (empty-varset))
let-children
letrec-children
children)))))))
-
+\f
(define (linearize graph)
(collapse-parallel-nodelist 0 (%node-needs graph)))
-
+
(define (build-new-code template parent vars->vals actions)
(let ((body (sequence/optimizing-make (get-body actions))))
(let loop ((template template)
(let ((this-type (car this))
(this-vars (cdr this)))
(let ((this-vals
- (map (lambda (var)
+ (map (lambda (var)
(table-get vars->vals var
(lambda (val) val)
(lambda () (error "broken"))))
(if (eq? this-type 'LET)
(let ((block (block/make block true)))
- (block/set-bound-variables! block this-vars)
+ (set-block/bound-variables! block this-vars)
(loop (cdr template)
block
(combination/optimizing-make
code)
this-vals)))
(let ((block (block/make block true)))
- (block/set-bound-variables! block this-vars)
+ (set-block/bound-variables! block this-vars)
(loop (cdr template)
block
- (open-block/make
+ (open-block/make
block this-vars this-vals
(append (make-list
(length this-vals)
(list code))
#t)))))))))))
-) ;; End of OPEN-BLOCK/OPTIMIZING-MAKE
-
-
-) ;; End of USING-SYNTAX SF-SYNTAX-TABLE
\ No newline at end of file
+;; End of OPEN-BLOCK/OPTIMIZING-MAKE
+)
\ No newline at end of file
promotional, or sales literature without prior written consent from
MIT in each case. |#
-(declare (usual-integrations))
-(declare (automagic-integrations))
-(declare (open-block-optimizations))
-(declare (eta-substitution))
-
-(using-syntax sf-syntax-table
-
+(declare (usual-integrations)
+ (automagic-integrations)
+ (open-block-optimizations)
+ (eta-substitution))
+\f
;;; simple table abstraction
;;;
;;; A table is a mutable mapping from key to value. There is a
;;; My big problem with this is that we have to go through the continuation
;;; passing style get function whether we want to or not.
-(define-named-structure table
- get-function
- put!-function
- remove!-function
- anything-else)
-
-((access add-unparser-special-object! unparser-package)
- *table-tag
- (lambda (table)
- (unparse-with-brackets
- (lambda ()
- (write-string "Table ")
- (write (hash table))))))
-
-(define (table-get table key if-found if-not-found)
+(define-structure (table (conc-name %table-)
+ (constructor %make-table))
+ (get-function false read-only true)
+ (put!-function false read-only true)
+ (remove!-function false read-only true)
+ (anything-else false read-only true))
+
+(define-integrable (table-get table key if-found if-not-found)
((%table-get-function table) key if-found if-not-found))
-(define (table-put! table key value)
+(define-integrable (table-put! table key value)
((%table-put!-function table) key value))
-(define (table-remove! table key)
+(define-integrable (table-remove! table key)
((%table-remove!-function table) key))
-(define (table-function table operation arglist)
+(define-integrable (table-function table operation arglist)
((%table-anything-else table) operation arglist))
(define (table-get-chain key1 if-found if-not-found . tables)
identity-procedure
(lambda () #f)))
keylist))
-
+\f
;;; Returns a table
(define (make-generic-eq?-table)
((predicate) eq?)
(else (error "Don't understand that message"))))
- (%make-table get put! remove! dispatch)))
-
-)
\ No newline at end of file
+ (%make-table get put! remove! dispatch)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 3.3 1988/04/23 08:51:46 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 4.1 1988/06/13 12:31:31 cph Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.11 1988/04/23 08:52:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.1 1988/06/13 12:30:37 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(declare (usual-integrations)
(automagic-integrations)
- (open-block-optimizations)
- (integrate-external "mvalue"))
+ (open-block-optimizations))
\f
;;;; User Interface
(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)))
+ (procedure-components procedure
+ (lambda (*lambda environment)
+ (scode-eval (integrate/scode *lambda declarations false) environment))))
(define (integrate/sexp s-expression syntax-table declarations receiver)
(integrate/simple (lambda (s-expressions)
(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))
+ (syntax-file input-string
+ (if (default-object? bin-string) false bin-string)
+ (if (default-object? spec-string) false 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
(define (sf/set-default-syntax-table! syntax-table)
- (if (or (false? syntax-table)
- (syntax-table? syntax-table))
- (set! default-syntax-table syntax-table)
- (error "Illegal syntax table" syntax-table)))
+ (if (not (or (false? syntax-table)
+ (syntax-table? syntax-table)))
+ (error "Illegal syntax table" syntax-table))
+ (set! default-syntax-table syntax-table))
(define (sf/set-file-syntax-table! pathname syntax-table)
(pathname-map/insert! file-info/syntax-table
(define (file-info/find pathname)
(let ((pathname (pathname/normalize pathname)))
- (return-2 (pathname-map/lookup file-info/syntax-table
- pathname
- identity-procedure
- (lambda () default-syntax-table))
- (file-info/get-declarations pathname))))
+ (values (pathname-map/lookup file-info/syntax-table
+ pathname
+ identity-procedure
+ (lambda () default-syntax-table))
+ (file-info/get-declarations pathname))))
(define (file-info/get-declarations pathname)
(pathname-map/lookup file-info/declarations
(lambda () '())))
(define (pathname/normalize pathname)
- (pathname-new-version
- (merge-pathnames (pathname->absolute-pathname (->pathname pathname))
- sf/default-input-pathname)
- false))
+ (pathname-default-type (pathname->absolute-pathname (->pathname pathname))
+ "scm"))
(define file-info/syntax-table
(pathname-map/make))
\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))
+ (make-pathname false false false false "ext" 'NEWEST))
-(define sf/output-pathname-type "bin")
-(define sf/unfasl-pathname-type "unf")
+(define sfu? false)
(define (syntax-file input-string bin-string spec-string)
- (for-each
- (lambda (pathname)
- (let ((input-path (pathname->input-truename pathname)))
- (if (not input-path)
- (error "SF: File does not exist" pathname))
- (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 sfu?)
- (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)))))
- (stickify-input-filenames input-string sf/default-input-pathname)))
+ (for-each (lambda (input-string)
+ (with-values
+ (lambda ()
+ (sf/pathname-defaulting input-string
+ bin-string
+ spec-string))
+ (lambda (input-pathname bin-pathname spec-pathname)
+ (with-values (lambda () (file-info/find input-pathname))
+ (lambda (syntax-table declarations)
+ (sf/internal input-pathname bin-pathname spec-pathname
+ syntax-table declarations))))))
+ (if (pair? input-string)
+ input-string
+ (list input-string))))
+
+(define (sf/pathname-defaulting input-string bin-string spec-string)
+ (let ((pathname
+ (merge-pathnames
+ (->pathname input-string)
+ (make-pathname false false '() false "scm" 'NEWEST))))
+ (let ((input-path (pathname->input-truename pathname)))
+ (if (not input-path)
+ (error "SF: File does not exist" pathname))
+ (let ((input-type (pathname-type input-path)))
+ (let ((bin-path
+ (let ((bin-path
+ (pathname-new-type
+ input-path
+ (if (equal? "scm" input-type)
+ "bin"
+ (string-append "b" input-type)))))
+ (if bin-string
+ (merge-pathnames (->pathname bin-string) bin-path)
+ bin-path))))
+ (let ((spec-path
+ (and (or spec-string sfu?)
+ (let ((spec-path
+ (pathname-new-type
+ bin-path
+ (if (equal? "scm" input-type)
+ "unf"
+ (string-append "u" input-type)))))
+ (if spec-string
+ (merge-pathnames (->pathname spec-string)
+ spec-path)
+ spec-path)))))
+ (values input-path bin-path spec-path)))))))
\f
-(define (syntax-file* input-pathname bin-pathname spec-pathname)
+(define (sf/internal input-pathname bin-pathname spec-pathname
+ syntax-table declarations)
(fluid-let ((sf/default-externs-pathname
- (make-pathname (pathname-device input-pathname)
+ (make-pathname (pathname-host input-pathname)
+ (pathname-device input-pathname)
(pathname-directory input-pathname)
false
"ext"
'NEWEST)))
- (let ((start-date (date))
- (start-time (time))
+ (let ((start-date (get-decoded-time))
(input-filename (pathname->string input-pathname))
(bin-filename (pathname->string bin-pathname))
(spec-filename (and spec-pathname (pathname->string spec-pathname))))
(write bin-filename)
(write-string " ")
(write spec-filename)
- (transmit-values
- (transmit-values (file-info/find input-pathname)
- (lambda (syntax-table declarations)
- (integrate/file input-pathname syntax-table declarations
- spec-pathname)))
+ (with-values
+ (lambda ()
+ (integrate/file input-pathname syntax-table declarations
+ 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*))
+ (DATE ,(decoded-time/year start-date)
+ ,(decoded-time/month start-date)
+ ,(decoded-time/day start-date))
+ (TIME ,(decoded-time/hour start-date)
+ ,(decoded-time/minute start-date)
+ ,(decoded-time/second start-date)))
(set! expression false)))
bin-pathname)
(write-externs-file (pathname-new-type
(with-output-to-file spec-pathname
(lambda ()
(newline)
- (write `(DATE ,start-date ,start-time))
- (newline)
- (write `(FLUID-LET ,*fluid-let-type*))
+ (write `(DATE ,(decoded-time/year start-date)
+ ,(decoded-time/month start-date)
+ ,(decoded-time/day start-date)
+ ,(decoded-time/hour start-date)
+ ,(decoded-time/minute start-date)
+ ,(decoded-time/second start-date)))
(newline)
(write `(SOURCE-FILE ,input-filename))
(newline)
scode)
(define control-point-tail
- `(3 ,(primitive-set-type (microcode-type 'NULL) (* 4 4))
+ `(3 ,(object-new-type (microcode-type 'NULL) 16)
() () () () () () () () () () () () () () ()))
(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)))
+ (system-list->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))
;;;; Optimizer Top Level
(define (integrate/file file-name syntax-table declarations compute-free?)
- compute-free? ; ignored
+ compute-free? ;ignored
(integrate/kernel (lambda ()
(phase:syntax (phase:read file-name) syntax-table))
declarations))
(define (integrate/simple preprocessor input declarations receiver)
- (transmit-values
- (integrate/kernel (lambda () (preprocessor input)) declarations)
+ (with-values
+ (lambda ()
+ (integrate/kernel (lambda () (preprocessor input)) declarations))
(or receiver
(lambda (expression externs events)
- externs events ; ignored
+ externs events ;ignored
expression))))
(define (integrate/kernel get-scode declarations)
(previous-process-time false)
(previous-real-time false)
(events '()))
- (transmit-values
- (transmit-values
- (transmit-values
- (phase:transform (canonicalize-scode (get-scode) declarations))
- phase:optimize)
- phase:generate-scode)
+ (with-values
+ (lambda ()
+ (with-values
+ (lambda ()
+ (with-values
+ (lambda ()
+ (phase:transform (canonicalize-scode (get-scode)
+ declarations)))
+ phase:optimize))
+ phase:generate-scode))
(lambda (externs expression)
(end-phase)
- (return-3 expression externs (reverse! events))))))
+ (values expression externs (reverse! events))))))
(define (canonicalize-scode scode declarations)
- (let ((declarations
- ((access process-declarations syntaxer-package) declarations)))
+ (let ((declarations (process-declarations declarations)))
(if (null? declarations)
scode
(scan-defines (make-sequence
(read-file filename))
(define (phase:syntax s-expression #!optional syntax-table)
- (if (or (unassigned? syntax-table) (not syntax-table))
- (set! syntax-table (make-syntax-table system-global-syntax-table)))
(mark-phase "Syntax")
- (syntax* s-expression syntax-table))
+ (syntax* s-expression
+ (if (or (default-object? syntax-table) (not syntax-table))
+ (make-syntax-table system-global-syntax-table)
+ syntax-table)))
(define (phase:transform scode)
(mark-phase "Transform")
- (transform/expression scode))
+ (transform/top-level scode))
(define (phase:optimize block expression)
(mark-phase "Optimize")
- (integrate/expression block expression))
+ (integrate/top-level block expression))
(define (phase:generate-scode operations environment expression)
(mark-phase "Generate SCode")
- (return-2 (operations->external operations environment)
- (cgen/expression expression)))
+ (values (operations->external operations environment)
+ (cgen/external expression)))
(define previous-name)
(define previous-process-time)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 3.4 1988/04/23 08:52:19 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 4.1 1988/06/13 12:30:46 cph Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
;;;; SCode Optimizer: Usual Integrations: Constants
(declare (usual-integrations)
- (integrate-external "object" "mvalue"))
+ (integrate-external "object"))
\f
(define usual-integrations/constant-names)
(define usual-integrations/constant-values)
(constant/make
(lexical-reference system-global-environment name))))
usual-integrations/constant-names))
- 'DONE)
-
-(declare (integrate-operator constant->integration-info))
-
-(define (constant->integration-info constant)
- (declare (integrate constant))
- (return-2 (constant/make constant) '()))
+ 'DONE)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.8 1988/05/11 04:19:27 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 4.1 1988/06/13 12:30:50 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(else
(if-not-expanded)))))
+#| ;; Not a desirable optimization with current compiler.
(define (identity-procedure-expansion operands if-expanded if-not-expanded
block)
if-not-expanded block ; ignored
(error "IDENTITY-PROCEDURE-EXPANSION: wrong number of arguments"
(length operands)))
(if-expanded (car operands)))
+|#
\f
;;;; Tables
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
+ make-string
))
(define usual-integrations/expansion-values
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
+ make-string-expansion
))
(define usual-integrations/expansion-alist
(define (scode->scode-expander scode-expander)
(lambda (operands if-expanded if-not-expanded block)
(scode-expander
- (map (access cgen/external-with-declarations package/cgen)
- operands)
+ (map cgen/external-with-declarations operands)
(lambda (scode-expression)
(if-expanded
(transform/recursive
block
(integrate/get-top-level-block)
scode-expression)))
- if-not-expanded)))
\ No newline at end of file
+ if-not-expanded)))
+
+;;; Kludge for EXPAND-OPERATOR declaration.
+(define expander-evaluation-environment
+ (the-environment))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.8 1988/04/23 08:55:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 4.1 1988/06/13 12:30:56 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(eta-substitution)
(automagic-integrations)
(open-block-optimizations)
- (integrate-external "object" "mvalue"))
+ (integrate-external "object"))
\f
;;; GLOBAL-BLOCK is used to handle (USUAL-INTEGRATIONS), as follows.
;;; This declaration refers to a large group of names, which are
(define (transform/top-level expression)
(fluid-let ((try-deep-lookup? false))
(let ((block (block/make (block/make false false) false)))
- (return-2 block (transform/top-level-1 true block block expression)))))
+ (values block (transform/top-level-1 true block block expression)))))
(define (transform/recursive block top-level-block expression)
(fluid-let ((try-deep-lookup? true))
(cond ((not (scode-open-block? expression))
(transform/expression block environment expression))
((not top-level?)
- (error "transform/top-level-1: open blocks disallowed" expression))
+ (error "TRANSFORM/TOP-LEVEL-1: open blocks disallowed"
+ expression))
(else
(open-block-components expression
(transform/open-block* block environment)))))))
(declare (integrate-operator transform/expression))
(define (transform/expression block environment expression)
- ((transform/dispatch expression) block environment expression))
+ ((scode-walk transform/dispatch expression) block environment expression))
(define global-block)
(define ((transform/open-block* block environment) auxiliary declarations body)
(let ((variables (map (lambda (name) (variable/make block name '()))
auxiliary)))
- (block/set-bound-variables! block
+ (set-block/bound-variables! block
(append (block/bound-variables block)
variables))
- (block/set-declarations! block (declarations/parse block declarations))
+ (set-block/declarations! block (declarations/parse block declarations))
(let ((environment (environment/bind environment variables)))
(define (loop variables actions)
(cond ((null? variables)
- (return-2 '() (map transform actions)))
+ (values '() (map transform actions)))
((null? actions)
(error "Extraneous auxiliaries" variables))
((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)
+ (with-values (lambda () (loop (cdr variables) (cdr actions)))
+ (lambda (vals actions*)
+ (values
+ (cons (transform (assignment-value (car actions))) vals)
(cons open-block/value-marker actions*)))))
(else
- (transmit-values (loop variables (cdr actions))
- (lambda (values actions*)
- (return-2 values
- (cons (transform (car actions)) actions*)))))))
+ (with-values (lambda () (loop variables (cdr actions)))
+ (lambda (vals actions*)
+ (values vals (cons (transform (car actions)) actions*)))))))
- (define (transform subexpression)
+ (define-integrable (transform subexpression)
(transform/expression block environment subexpression))
- (transmit-values (loop variables (sequence-actions body))
- (lambda (values actions)
- (open-block/make block variables values actions #f))))))
+ (with-values (lambda () (loop variables (sequence-actions body)))
+ (lambda (vals actions)
+ (open-block/make block variables vals actions false))))))
(define (transform/variable block environment expression)
(reference/make block
- (environment/lookup block environment (variable-name expression))))
+ (environment/lookup block
+ environment
+ (variable-name expression))))
(define (transform/assignment block environment expression)
(assignment-components 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-3 (map name->variable required)
+ (with-values
+ (lambda ()
+ (let ((name->variable
+ (lambda (name) (variable/make block name '()))))
+ (values (map name->variable required)
(map name->variable optional)
- (and rest (name->variable rest))))
+ (and rest (name->variable rest)))))
(lambda (required optional rest)
(let* ((bound `(,@required ,@optional ,@(if rest `(,rest) '())))
(environment (environment/bind environment bound)))
- (block/set-bound-variables! block bound)
+ (set-block/bound-variables! block bound)
(procedure/make
block name required optional rest
(transform/procedure-body block
(open-block-components expression
(lambda (auxiliary declarations body)
(if (null? auxiliary)
- (begin (block/set-declarations!
+ (begin (set-block/declarations!
block
(declarations/parse block declarations))
(transform/expression block environment body))
(transform/quotation* expression)))))
(define (transform/quotation block environment expression)
- block environment ;ignored
+ block environment ;ignored
(transform/quotation* (quotation-expression expression)))
(define (transform/quotation* expression)
- (transmit-values (transform/top-level expression)
+ (with-values (lambda () (transform/top-level expression))
quotation/make))
(define (transform/sequence block environment expression)
(the-environment/make block))
(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)
- (,error-combination-type ,transform/error-combination)
- (,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
+ (make-scode-walker
+ transform/constant
+ `((ACCESS ,transform/access)
+ (ASSIGNMENT ,transform/assignment)
+ (COMBINATION ,transform/combination)
+ (COMMENT ,transform/comment)
+ (CONDITIONAL ,transform/conditional)
+ (DECLARATION ,transform/declaration)
+ (DEFINITION ,transform/definition)
+ (DELAY ,transform/delay)
+ (DISJUNCTION ,transform/disjunction)
+ (ERROR-COMBINATION ,transform/error-combination)
+ (IN-PACKAGE ,transform/in-package)
+ (LAMBDA ,transform/lambda)
+ (OPEN-BLOCK ,transform/open-block)
+ (QUOTATION ,transform/quotation)
+ (SEQUENCE ,transform/sequence)
+ (THE-ENVIRONMENT ,transform/the-environment)
+ (VARIABLE ,transform/variable))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.4 1988/05/11 04:18:27 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.5 1988/06/13 12:29:43 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
;;;; SCode Optimizer: System Construction
-(in-package system-global-environment
(declare (usual-integrations))
-\f
-(define sf)
-(define sfu? false)
-(define sf/set-default-syntax-table!)
-(define sf/set-file-syntax-table!)
-(define sf/add-file-declarations!)
-(define package/scode-optimizer
- (make-environment
- (define package/top-level (make-environment))
- (define package/transform (make-environment))
- (define package/integrate (make-environment))
- (define package/cgen (make-environment))
- (define package/expansion (make-environment))
- (define package/declarations (make-environment))
- (define package/copy (make-environment))
- (define package/free (make-environment))
- (define package/change-type (make-environment))))
-
-(in-package package/scode-optimizer
-
- (define scode-optimizer/system
- (make-environment
- (define :name "SF")
- (define :version 4)
- (define :modification 4)
- (define :files)
-
- (define :rcs-header ;RCS sets up this string.
- "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.4 1988/05/11 04:18:27 jinx Exp $")
-
- (define :files-lists
- (list
- (cons system-global-environment
- '(
- "sfmac.bin" ; Macros for SF
- ))
- (cons package/scode-optimizer
- '(
- "mvalue.bin" ; Multiple Value Support
- "lsets.bin" ; Set Data Abstraction
- "table.bin" ; Table Abstraction
- "pthmap.bin" ; Pathname Map Abstraction
- "object.bin" ; Data Structures
- "emodel.bin" ; Environment Model
- "gconst.bin" ; Global Primitives List
- "usicon.bin" ; Usual Integrations: Constants
- "tables.bin" ; Operation Table Abstractions
- "packag.bin" ; Global packaging
- ))
- (cons package/top-level
- '("toplev.bin")) ; Top Level
- (cons package/transform
- '("xform.bin")) ; SCode -> Internal
- (cons package/integrate
- '("subst.bin")) ; Beta Substitution Optimizer
- (cons package/cgen
- '("cgen.bin")) ; Internal -> SCode
- (cons package/expansion
- '("usiexp.bin" ; Usual Integrations: Expanders
- "reduct.bin")) ; User defined expanders
- (cons package/declarations
- '("pardec.bin")) ; Declaration Parser
- (cons package/copy
- '("copy.bin")) ; Copy Expressions
- (cons package/free
- '("free.bin")) ; Free Variable Analysis
- (cons package/change-type
- '("chtype.bin")) ; Type interning
- ))))
-
- (load-system! scode-optimizer/system true)
-
- (scode-optimizer/initialize!))
-
-#|
-
-See also the file SFSF.scm
-
-|#
-;;; end IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT
-)
\ No newline at end of file
+(package/system-loader "sf" '() 'QUERY)
+((package/reference (find-package '(SCODE-OPTIMIZER))
+ 'USUAL-INTEGRATIONS/CACHE!))
+(add-system! (make-system "SF" 4 5 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.11 1988/04/23 08:52:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.1 1988/06/13 12:30:37 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(declare (usual-integrations)
(automagic-integrations)
- (open-block-optimizations)
- (integrate-external "mvalue"))
+ (open-block-optimizations))
\f
;;;; User Interface
(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)))
+ (procedure-components procedure
+ (lambda (*lambda environment)
+ (scode-eval (integrate/scode *lambda declarations false) environment))))
(define (integrate/sexp s-expression syntax-table declarations receiver)
(integrate/simple (lambda (s-expressions)
(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))
+ (syntax-file input-string
+ (if (default-object? bin-string) false bin-string)
+ (if (default-object? spec-string) false 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
(define (sf/set-default-syntax-table! syntax-table)
- (if (or (false? syntax-table)
- (syntax-table? syntax-table))
- (set! default-syntax-table syntax-table)
- (error "Illegal syntax table" syntax-table)))
+ (if (not (or (false? syntax-table)
+ (syntax-table? syntax-table)))
+ (error "Illegal syntax table" syntax-table))
+ (set! default-syntax-table syntax-table))
(define (sf/set-file-syntax-table! pathname syntax-table)
(pathname-map/insert! file-info/syntax-table
(define (file-info/find pathname)
(let ((pathname (pathname/normalize pathname)))
- (return-2 (pathname-map/lookup file-info/syntax-table
- pathname
- identity-procedure
- (lambda () default-syntax-table))
- (file-info/get-declarations pathname))))
+ (values (pathname-map/lookup file-info/syntax-table
+ pathname
+ identity-procedure
+ (lambda () default-syntax-table))
+ (file-info/get-declarations pathname))))
(define (file-info/get-declarations pathname)
(pathname-map/lookup file-info/declarations
(lambda () '())))
(define (pathname/normalize pathname)
- (pathname-new-version
- (merge-pathnames (pathname->absolute-pathname (->pathname pathname))
- sf/default-input-pathname)
- false))
+ (pathname-default-type (pathname->absolute-pathname (->pathname pathname))
+ "scm"))
(define file-info/syntax-table
(pathname-map/make))
\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))
+ (make-pathname false false false false "ext" 'NEWEST))
-(define sf/output-pathname-type "bin")
-(define sf/unfasl-pathname-type "unf")
+(define sfu? false)
(define (syntax-file input-string bin-string spec-string)
- (for-each
- (lambda (pathname)
- (let ((input-path (pathname->input-truename pathname)))
- (if (not input-path)
- (error "SF: File does not exist" pathname))
- (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 sfu?)
- (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)))))
- (stickify-input-filenames input-string sf/default-input-pathname)))
+ (for-each (lambda (input-string)
+ (with-values
+ (lambda ()
+ (sf/pathname-defaulting input-string
+ bin-string
+ spec-string))
+ (lambda (input-pathname bin-pathname spec-pathname)
+ (with-values (lambda () (file-info/find input-pathname))
+ (lambda (syntax-table declarations)
+ (sf/internal input-pathname bin-pathname spec-pathname
+ syntax-table declarations))))))
+ (if (pair? input-string)
+ input-string
+ (list input-string))))
+
+(define (sf/pathname-defaulting input-string bin-string spec-string)
+ (let ((pathname
+ (merge-pathnames
+ (->pathname input-string)
+ (make-pathname false false '() false "scm" 'NEWEST))))
+ (let ((input-path (pathname->input-truename pathname)))
+ (if (not input-path)
+ (error "SF: File does not exist" pathname))
+ (let ((input-type (pathname-type input-path)))
+ (let ((bin-path
+ (let ((bin-path
+ (pathname-new-type
+ input-path
+ (if (equal? "scm" input-type)
+ "bin"
+ (string-append "b" input-type)))))
+ (if bin-string
+ (merge-pathnames (->pathname bin-string) bin-path)
+ bin-path))))
+ (let ((spec-path
+ (and (or spec-string sfu?)
+ (let ((spec-path
+ (pathname-new-type
+ bin-path
+ (if (equal? "scm" input-type)
+ "unf"
+ (string-append "u" input-type)))))
+ (if spec-string
+ (merge-pathnames (->pathname spec-string)
+ spec-path)
+ spec-path)))))
+ (values input-path bin-path spec-path)))))))
\f
-(define (syntax-file* input-pathname bin-pathname spec-pathname)
+(define (sf/internal input-pathname bin-pathname spec-pathname
+ syntax-table declarations)
(fluid-let ((sf/default-externs-pathname
- (make-pathname (pathname-device input-pathname)
+ (make-pathname (pathname-host input-pathname)
+ (pathname-device input-pathname)
(pathname-directory input-pathname)
false
"ext"
'NEWEST)))
- (let ((start-date (date))
- (start-time (time))
+ (let ((start-date (get-decoded-time))
(input-filename (pathname->string input-pathname))
(bin-filename (pathname->string bin-pathname))
(spec-filename (and spec-pathname (pathname->string spec-pathname))))
(write bin-filename)
(write-string " ")
(write spec-filename)
- (transmit-values
- (transmit-values (file-info/find input-pathname)
- (lambda (syntax-table declarations)
- (integrate/file input-pathname syntax-table declarations
- spec-pathname)))
+ (with-values
+ (lambda ()
+ (integrate/file input-pathname syntax-table declarations
+ 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*))
+ (DATE ,(decoded-time/year start-date)
+ ,(decoded-time/month start-date)
+ ,(decoded-time/day start-date))
+ (TIME ,(decoded-time/hour start-date)
+ ,(decoded-time/minute start-date)
+ ,(decoded-time/second start-date)))
(set! expression false)))
bin-pathname)
(write-externs-file (pathname-new-type
(with-output-to-file spec-pathname
(lambda ()
(newline)
- (write `(DATE ,start-date ,start-time))
- (newline)
- (write `(FLUID-LET ,*fluid-let-type*))
+ (write `(DATE ,(decoded-time/year start-date)
+ ,(decoded-time/month start-date)
+ ,(decoded-time/day start-date)
+ ,(decoded-time/hour start-date)
+ ,(decoded-time/minute start-date)
+ ,(decoded-time/second start-date)))
(newline)
(write `(SOURCE-FILE ,input-filename))
(newline)
scode)
(define control-point-tail
- `(3 ,(primitive-set-type (microcode-type 'NULL) (* 4 4))
+ `(3 ,(object-new-type (microcode-type 'NULL) 16)
() () () () () () () () () () () () () () ()))
(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)))
+ (system-list->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))
;;;; Optimizer Top Level
(define (integrate/file file-name syntax-table declarations compute-free?)
- compute-free? ; ignored
+ compute-free? ;ignored
(integrate/kernel (lambda ()
(phase:syntax (phase:read file-name) syntax-table))
declarations))
(define (integrate/simple preprocessor input declarations receiver)
- (transmit-values
- (integrate/kernel (lambda () (preprocessor input)) declarations)
+ (with-values
+ (lambda ()
+ (integrate/kernel (lambda () (preprocessor input)) declarations))
(or receiver
(lambda (expression externs events)
- externs events ; ignored
+ externs events ;ignored
expression))))
(define (integrate/kernel get-scode declarations)
(previous-process-time false)
(previous-real-time false)
(events '()))
- (transmit-values
- (transmit-values
- (transmit-values
- (phase:transform (canonicalize-scode (get-scode) declarations))
- phase:optimize)
- phase:generate-scode)
+ (with-values
+ (lambda ()
+ (with-values
+ (lambda ()
+ (with-values
+ (lambda ()
+ (phase:transform (canonicalize-scode (get-scode)
+ declarations)))
+ phase:optimize))
+ phase:generate-scode))
(lambda (externs expression)
(end-phase)
- (return-3 expression externs (reverse! events))))))
+ (values expression externs (reverse! events))))))
(define (canonicalize-scode scode declarations)
- (let ((declarations
- ((access process-declarations syntaxer-package) declarations)))
+ (let ((declarations (process-declarations declarations)))
(if (null? declarations)
scode
(scan-defines (make-sequence
(read-file filename))
(define (phase:syntax s-expression #!optional syntax-table)
- (if (or (unassigned? syntax-table) (not syntax-table))
- (set! syntax-table (make-syntax-table system-global-syntax-table)))
(mark-phase "Syntax")
- (syntax* s-expression syntax-table))
+ (syntax* s-expression
+ (if (or (default-object? syntax-table) (not syntax-table))
+ (make-syntax-table system-global-syntax-table)
+ syntax-table)))
(define (phase:transform scode)
(mark-phase "Transform")
- (transform/expression scode))
+ (transform/top-level scode))
(define (phase:optimize block expression)
(mark-phase "Optimize")
- (integrate/expression block expression))
+ (integrate/top-level block expression))
(define (phase:generate-scode operations environment expression)
(mark-phase "Generate SCode")
- (return-2 (operations->external operations environment)
- (cgen/expression expression)))
+ (values (operations->external operations environment)
+ (cgen/external expression)))
(define previous-name)
(define previous-process-time)
projects / mit-scheme.git / commitdiff