From: Chris Hanson Date: Mon, 13 Jun 1988 12:31:31 +0000 (+0000) Subject: First checkin for runtime system version 14. X-Git-Tag: 20090517-FFI~12729 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ecc692b4771858ce476c26eae61326ee8a685478;p=mit-scheme.git First checkin for runtime system version 14. --- diff --git a/v7/src/sf/butils.scm b/v7/src/sf/butils.scm new file mode 100644 index 000000000..e091f99a5 --- /dev/null +++ b/v7/src/sf/butils.scm @@ -0,0 +1,117 @@ +#| -*-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)) + +(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))) + +(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 diff --git a/v7/src/sf/cgen.scm b/v7/src/sf/cgen.scm index 4fd5847a4..c33db2ac1 100644 --- a/v7/src/sf/cgen.scm +++ b/v7/src/sf/cgen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -202,7 +202,21 @@ MIT in each case. |# (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) diff --git a/v7/src/sf/chtype.scm b/v7/src/sf/chtype.scm index 727c9b1a5..570763b4b 100644 --- a/v7/src/sf/chtype.scm +++ b/v7/src/sf/chtype.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -36,12 +36,12 @@ MIT in each case. |# (declare (usual-integrations) (automagic-integrations) - (integrate-external "object" "mvalue")) + (integrate-external "object")) -(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) @@ -68,7 +68,7 @@ MIT in each case. |# (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))))) diff --git a/v7/src/sf/copy.scm b/v7/src/sf/copy.scm index e3ee471b4..8af62b479 100644 --- a/v7/src/sf/copy.scm +++ b/v7/src/sf/copy.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -38,27 +38,28 @@ MIT in each case. |# (open-block-optimizations) (eta-substitution) (automagic-integrations) - (integrate-external "object" "mvalue")) + (integrate-external "object")) (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) @@ -96,17 +97,17 @@ MIT in each case. |# (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))) @@ -123,7 +124,7 @@ MIT in each case. |# ((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" @@ -175,11 +176,12 @@ MIT in each case. |# (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) @@ -204,8 +206,7 @@ MIT in each case. |# (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 @@ -216,6 +217,15 @@ MIT in each case. |# (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 @@ -256,7 +266,9 @@ MIT in each case. |# (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 @@ -270,8 +282,9 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/emodel.scm b/v7/src/sf/emodel.scm index 02958a853..8eadea8db 100644 --- a/v7/src/sf/emodel.scm +++ b/v7/src/sf/emodel.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -42,7 +42,7 @@ MIT in each case. |# (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)))))) diff --git a/v7/src/sf/free.scm b/v7/src/sf/free.scm index fd54547fd..80c5de7b5 100644 --- a/v7/src/sf/free.scm +++ b/v7/src/sf/free.scm @@ -1,6 +1,6 @@ #| -*-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 diff --git a/v7/src/sf/gconst.scm b/v7/src/sf/gconst.scm index 0f4702d29..3a7df21b1 100644 --- a/v7/src/sf/gconst.scm +++ b/v7/src/sf/gconst.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -41,84 +41,194 @@ MIT in each case. |# ;;; 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=? SUBSTRINGCHAR + 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! + SUBSTRINGLIST + 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 diff --git a/v7/src/sf/gimprt.scm b/v7/src/sf/gimprt.scm new file mode 100644 index 000000000..a591f8a7e --- /dev/null +++ b/v7/src/sf/gimprt.scm @@ -0,0 +1,41 @@ +#| -*-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 diff --git a/v7/src/sf/lsets.scm b/v7/src/sf/lsets.scm index e38c1789e..51043f4cb 100644 --- a/v7/src/sf/lsets.scm +++ b/v7/src/sf/lsets.scm @@ -32,11 +32,10 @@ MIT in each case. |# ;;;; Unordered Set abstraction -(declare (usual-integrations)) -(declare (automagic-integrations)) -(declare (open-block-optimizations)) +(declare (usual-integrations) + (automagic-integrations) + (open-block-optimizations)) - #| Each set has an ELEMENT-TYPE which is a predicate that all elements of @@ -72,119 +71,62 @@ to figure out what is going on in this code. (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))) -|# - + (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)))) - + (define-integrable (%subset predicate list) ((list-deletor (invert-sense predicate)) list)) @@ -220,15 +162,14 @@ to figure out what is going on in this code. ;;; 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) @@ -243,8 +184,7 @@ to figure out what is going on in this code. (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)) @@ -252,7 +192,7 @@ to figure out what is going on in this code. (lambda (etype2 pred2 stream2) etype2 pred2 ; are ignored (receiver etype1 pred1 stream1 stream2)))))) - + (define (set/member? set element) (spread-set set (lambda (element-type predicate list) @@ -262,8 +202,8 @@ to figure out what is going on in this code. (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))) @@ -271,7 +211,7 @@ to figure out what is going on in this code. (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))))) @@ -299,8 +239,7 @@ to figure out what is going on in this code. (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) @@ -312,25 +251,22 @@ to figure out what is going on in this code. (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)))) - + #| (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 @@ -341,21 +277,20 @@ to figure out what is going on in this code. (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) @@ -401,7 +336,6 @@ to figure out what is going on in this code. (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 diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index 6163f5207..0ba89aaba 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -34,87 +34,9 @@ MIT in each case. |# ;;;; SCode Optimizer: System Construction -(in-package system-global-environment (declare (usual-integrations)) - -(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 diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm index 49d9daafa..bf43d28d7 100644 --- a/v7/src/sf/object.scm +++ b/v7/src/sf/object.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -34,72 +34,32 @@ MIT in each case. |# ;;;; SCode Optimizer: Data Types -(declare (usual-integrations)) -(declare (automagic-integrations)) -(declare (open-block-optimizations)) +(declare (usual-integrations) + (automagic-integrations) + (open-block-optimizations)) -(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))))) - -;;;; 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))))) ;;;; Enumerations @@ -120,29 +80,16 @@ MIT in each case. |# 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) @@ -161,44 +108,50 @@ MIT in each case. |# 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 @@ -207,7 +160,7 @@ MIT in each case. |# (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!) @@ -250,15 +203,11 @@ MIT in each case. |# (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))) @@ -281,4 +230,16 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm index a8d7718f4..987f6dbc9 100644 --- a/v7/src/sf/pardec.scm +++ b/v7/src/sf/pardec.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -38,36 +38,35 @@ MIT in each case. |# (open-block-optimizations) (automagic-integrations) (eta-substitution) - (integrate-external "object" "mvalue")) + (integrate-external "object")) (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) @@ -77,29 +76,21 @@ MIT in each case. |# 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)) -(define (declarations/known? declaration) - (assq (car declaration) known-declarations)) - ;; before-bindings? should be true if binding should nullify ;; the declaration. It should be false if a binding and the ;; declaration can "coexist". @@ -107,11 +98,14 @@ MIT in each case. |# (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 '()) @@ -119,13 +113,13 @@ MIT in each case. |# (let loop ((table table) (items items)) (if (null? items) table - (loop (cons (car items) table) (cdr items))))) + (loop (cons table (car items)) (cdr items))))) (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) @@ -136,8 +130,8 @@ MIT in each case. |# (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 @@ -175,74 +169,49 @@ MIT in each case. |# (list-copy (binding/names binding)) '())) (declarations/after declarations))) - -(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)) ;;;; 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) @@ -252,24 +221,29 @@ MIT in each case. |# (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)) @@ -280,80 +254,39 @@ MIT in each case. |# (else (error "Bad primitive specification" specification))))) ;;; 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)) ;;;; 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 @@ -366,7 +299,7 @@ MIT in each case. |# (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))))) @@ -377,17 +310,14 @@ MIT in each case. |# (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)))))) ;;;; User provided reductions and expansions @@ -396,7 +326,7 @@ MIT in each case. |# (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) @@ -404,17 +334,13 @@ MIT in each case. |# (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) diff --git a/v7/src/sf/pthmap.scm b/v7/src/sf/pthmap.scm index d070c50b6..b234a8729 100644 --- a/v7/src/sf/pthmap.scm +++ b/v7/src/sf/pthmap.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -34,10 +34,10 @@ MIT in each case. |# ;;;; 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)) (define pathname-map/make) (define pathname-map?) @@ -57,13 +57,9 @@ MIT in each case. |# (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)) @@ -72,9 +68,9 @@ MIT in each case. |# (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)))) @@ -110,7 +106,7 @@ MIT in each case. |# (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))) @@ -131,7 +127,7 @@ MIT in each case. |# (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)) diff --git a/v7/src/sf/reduct.scm b/v7/src/sf/reduct.scm index c150bf178..e21b897b6 100644 --- a/v7/src/sf/reduct.scm +++ b/v7/src/sf/reduct.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -127,7 +127,7 @@ Examples: (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)) diff --git a/v7/src/sf/sf.pkg b/v7/src/sf/sf.pkg new file mode 100644 index 000000000..29262267a --- /dev/null +++ b/v7/src/sf/sf.pkg @@ -0,0 +1,152 @@ +#| -*-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 + +(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 diff --git a/v7/src/sf/sf.sf b/v7/src/sf/sf.sf new file mode 100644 index 000000000..b21889282 --- /dev/null +++ b/v7/src/sf/sf.sf @@ -0,0 +1,40 @@ +#| -*-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 diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm index 8be34813e..0b73fe8bc 100644 --- a/v7/src/sf/subst.scm +++ b/v7/src/sf/subst.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -37,19 +37,15 @@ MIT in each case. |# (declare (usual-integrations) (eta-substitution) (open-block-optimizations) - (integrate-external "object" "mvalue" "lsets")) + (integrate-external "object" "lsets")) - -(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) @@ -57,34 +53,36 @@ MIT in each case. |# (*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) @@ -115,15 +113,15 @@ MIT in each case. |# (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)))) @@ -148,8 +146,9 @@ MIT in each case. |# (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) @@ -166,7 +165,7 @@ MIT in each case. |# (and (reference? value) (not (variable/side-effected (reference/variable value))) (block/safe? (variable/block (reference/variable value)))))) - + (define (integrate/reference-operator operations environment operator operands) (let ((variable (reference/variable operator))) (let ((dont-integrate @@ -214,7 +213,7 @@ MIT in each case. |# (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" @@ -238,16 +237,15 @@ MIT in each case. |# (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) @@ -275,30 +273,22 @@ MIT in each case. |# (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 @@ -306,9 +296,19 @@ MIT in each case. |# 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)))) + +(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 @@ -333,9 +333,8 @@ you ask for. |# - -(define *eta-substitution-switch #f) - +(define *eta-substitution-switch #F) + (define (integrate/procedure operations environment procedure) (let ((block (procedure/block procedure)) (required (procedure/required procedure)) @@ -354,9 +353,7 @@ you ask for. ;; 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*))) @@ -369,8 +366,8 @@ you ask for. (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) @@ -390,13 +387,6 @@ you ask for. (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))) - (define-method/integrate 'COMBINATION (lambda (operations environment combination) @@ -445,7 +435,7 @@ you ask for. (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 @@ -481,7 +471,7 @@ you ask for. (consequent (integrate/expression operations environment (conditional/consequent expression))) - (alternative (integrate/expression + (alternative (integrate/expression operations environment (conditional/alternative expression)))) (if (constant? predicate) @@ -505,46 +495,59 @@ you ask for. predicate) (disjunction/make predicate alternative))))) - -;; 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))))) + (define-method/integrate 'ACCESS (lambda (operations environment expression) (let ((environment* (access/environment expression)) @@ -589,40 +592,42 @@ you ask for. (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))) ;;;; 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) @@ -660,7 +665,7 @@ you ask for. (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)))) @@ -715,14 +720,10 @@ you ask for. (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) @@ -745,14 +746,14 @@ you ask for. (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)) @@ -812,7 +813,7 @@ forms are simply removed. (and (constant? operator) (primitive-procedure? (constant/value operator)) (memq (constant/value operator) *foldable-primitive-procedures))) - + ;;; 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 @@ -828,8 +829,7 @@ forms are simply removed. ((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) @@ -858,7 +858,7 @@ forms are simply removed. (append unreferenced-operands (list form)))))))) (else (combination/make operator operands))))) - + (define (delete-unreferenced-parameters parameters body operands receiver) (let ((free-in-body (free/expression body))) (let loop ((parameters parameters) @@ -867,13 +867,13 @@ forms are simply removed. (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) @@ -910,7 +910,7 @@ forms are simply removed. ;; 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 @@ -920,7 +920,7 @@ forms are simply removed. (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 @@ -943,8 +943,8 @@ forms are simply removed. ; (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)))) @@ -966,7 +966,7 @@ forms are simply removed. (fill-table (cdr vars) (cdr vals))))) (fill-table vars vals) table)) - + (declare (integrate varlist->varset nodelist->nodeset empty-nodeset singleton-nodeset empty-varset singleton-varset)) @@ -1000,7 +1000,7 @@ forms are simply removed. (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)) @@ -1021,67 +1021,51 @@ forms are simply removed. (cond ((null? actions) '()) ((eq? (car actions) open-block/value-marker) (get-body (cdr actions))) (else (cons (car actions) (get-body (cdr actions)))))) - + ;;; 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))) - + (define (build-graph vars table:var->vals table:vals->free body-free) (let ((table:variable->node (make-generic-eq?-table))) @@ -1107,14 +1091,14 @@ forms are simply removed. (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) @@ -1137,7 +1121,7 @@ forms are simply removed. (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) @@ -1145,7 +1129,7 @@ forms are simply removed. (lambda () (error "Broken analysis: free var")))) body-free) base-node)) - + (define (collapse-circularities! graph) ;; Search for a circularity: if found, collapse it, and repeat ;; until none are found. @@ -1203,18 +1187,18 @@ forms are simply removed. (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))))) - + (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)) @@ -1233,7 +1217,7 @@ forms are simply removed. (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)) @@ -1265,10 +1249,10 @@ forms are simply removed. let-children letrec-children children))))))) - + (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) @@ -1280,7 +1264,7 @@ forms are simply removed. (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")))) @@ -1288,7 +1272,7 @@ forms are simply removed. (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 @@ -1301,10 +1285,10 @@ forms are simply removed. 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) @@ -1312,7 +1296,5 @@ forms are simply removed. (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 diff --git a/v7/src/sf/table.scm b/v7/src/sf/table.scm index dab7e35ac..08a6d0bd5 100644 --- a/v7/src/sf/table.scm +++ b/v7/src/sf/table.scm @@ -30,13 +30,11 @@ Technology nor of any adaptation thereof in any advertising, 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)) + ;;; simple table abstraction ;;; ;;; A table is a mutable mapping from key to value. There is a @@ -49,30 +47,23 @@ MIT in each case. |# ;;; 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) @@ -91,7 +82,7 @@ MIT in each case. |# identity-procedure (lambda () #f))) keylist)) - + ;;; Returns a table (define (make-generic-eq?-table) @@ -138,6 +129,4 @@ MIT in each case. |# ((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 diff --git a/v7/src/sf/tables.scm b/v7/src/sf/tables.scm index e0495f861..1adb712d9 100644 --- a/v7/src/sf/tables.scm +++ b/v7/src/sf/tables.scm @@ -1,6 +1,6 @@ #| -*-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 diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index 8efd8f895..c195dec93 100644 --- a/v7/src/sf/toplev.scm +++ b/v7/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -36,18 +36,14 @@ MIT in each case. |# (declare (usual-integrations) (automagic-integrations) - (open-block-optimizations) - (integrate-external "mvalue")) + (open-block-optimizations)) ;;;; 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) @@ -58,23 +54,21 @@ MIT in each case. |# (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))) (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 @@ -90,11 +84,11 @@ Currently only the 68000 implementation needs this." (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 @@ -103,10 +97,8 @@ Currently only the 68000 implementation needs this." (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)) @@ -119,49 +111,70 @@ Currently only the 68000 implementation needs this." ;;;; 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))))))) -(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)))) @@ -172,17 +185,19 @@ Currently only the 68000 implementation needs this." (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 @@ -196,9 +211,12 @@ Currently only the 68000 implementation needs this." (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) @@ -245,16 +263,16 @@ Currently only the 68000 implementation needs this." 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)) @@ -268,17 +286,18 @@ Currently only the 68000 implementation needs this." ;;;; 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) @@ -286,19 +305,22 @@ Currently only the 68000 implementation needs this." (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 @@ -311,23 +333,24 @@ Currently only the 68000 implementation needs this." (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) diff --git a/v7/src/sf/usicon.scm b/v7/src/sf/usicon.scm index e0042edf5..75903f202 100644 --- a/v7/src/sf/usicon.scm +++ b/v7/src/sf/usicon.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -35,7 +35,7 @@ MIT in each case. |# ;;;; SCode Optimizer: Usual Integrations: Constants (declare (usual-integrations) - (integrate-external "object" "mvalue")) + (integrate-external "object")) (define usual-integrations/constant-names) (define usual-integrations/constant-values) @@ -62,10 +62,4 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index cf772693c..d604dba7c 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -284,6 +284,7 @@ MIT in each case. |# (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 @@ -291,6 +292,7 @@ MIT in each case. |# (error "IDENTITY-PROCEDURE-EXPANSION: wrong number of arguments" (length operands))) (if-expanded (car operands))) +|# ;;;; Tables @@ -302,7 +304,7 @@ MIT in each case. |# 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 @@ -320,7 +322,7 @@ MIT in each case. |# 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 @@ -337,12 +339,15 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/xform.scm b/v7/src/sf/xform.scm index eba49719f..269a5c152 100644 --- a/v7/src/sf/xform.scm +++ b/v7/src/sf/xform.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -38,7 +38,7 @@ MIT in each case. |# (eta-substitution) (automagic-integrations) (open-block-optimizations) - (integrate-external "object" "mvalue")) + (integrate-external "object")) ;;; GLOBAL-BLOCK is used to handle (USUAL-INTEGRATIONS), as follows. ;;; This declaration refers to a large group of names, which are @@ -59,7 +59,7 @@ MIT in each case. |# (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)) @@ -76,7 +76,8 @@ MIT in each case. |# (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))))))) @@ -89,7 +90,7 @@ MIT in each case. |# (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) @@ -116,15 +117,15 @@ MIT in each case. |# (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)) @@ -135,27 +136,28 @@ MIT in each case. |# ((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 @@ -170,16 +172,17 @@ MIT in each case. |# (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 @@ -191,7 +194,7 @@ MIT in each case. |# (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)) @@ -265,11 +268,11 @@ MIT in each case. |# (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) @@ -282,22 +285,22 @@ MIT in each case. |# (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 diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm index 08c8b0891..6d67bd6a4 100644 --- a/v8/src/sf/make.scm +++ b/v8/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -34,87 +34,9 @@ MIT in each case. |# ;;;; SCode Optimizer: System Construction -(in-package system-global-environment (declare (usual-integrations)) - -(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 diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm index 86719228b..75bd2a45c 100644 --- a/v8/src/sf/toplev.scm +++ b/v8/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -36,18 +36,14 @@ MIT in each case. |# (declare (usual-integrations) (automagic-integrations) - (open-block-optimizations) - (integrate-external "mvalue")) + (open-block-optimizations)) ;;;; 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) @@ -58,23 +54,21 @@ MIT in each case. |# (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))) (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 @@ -90,11 +84,11 @@ Currently only the 68000 implementation needs this." (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 @@ -103,10 +97,8 @@ Currently only the 68000 implementation needs this." (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)) @@ -119,49 +111,70 @@ Currently only the 68000 implementation needs this." ;;;; 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))))))) -(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)))) @@ -172,17 +185,19 @@ Currently only the 68000 implementation needs this." (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 @@ -196,9 +211,12 @@ Currently only the 68000 implementation needs this." (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) @@ -245,16 +263,16 @@ Currently only the 68000 implementation needs this." 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)) @@ -268,17 +286,18 @@ Currently only the 68000 implementation needs this." ;;;; 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) @@ -286,19 +305,22 @@ Currently only the 68000 implementation needs this." (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 @@ -311,23 +333,24 @@ Currently only the 68000 implementation needs this." (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)