From: Chris Hanson Date: Thu, 19 Mar 1987 00:34:49 +0000 (+0000) Subject: Reorganize code for new directory structure. Break some large useful X-Git-Tag: 20090517-FFI~13668 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f5f74eb9aa575ad4f756bb84a90125f6a8a09319;p=mit-scheme.git Reorganize code for new directory structure. Break some large useful files into smaller ones that can be compiled. Delete all `using-syntax' occurrences and `Edwin Variables'. --- diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm index d5fa874d1..233ff6cce 100644 --- a/v7/src/compiler/base/cfg1.scm +++ b/v7/src/compiler/base/cfg1.scm @@ -1,46 +1,40 @@ -;;; -*-Scheme-*- -;;; -;;; Copyright (c) 1986 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. -;;; +#| -*-Scheme-*- -;;;; Control Flow Graph Abstraction +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.147 1987/03/19 00:32:34 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. -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.146 1986/12/21 19:33:44 cph Exp $ +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. |# + +;;;; Control Flow Graph Abstraction (declare (usual-integrations)) -(using-syntax (access compiler-syntax-table compiler-package) ;;;; Node Datatypes @@ -544,14 +538,4 @@ (define pcfg*pcfg->scfg! (pcfg*pcfg->cfg! pcfg->scfg! make-scfg*)) -) - -;;; end USING-SYNTAX -) - -;;; Edwin Variables: -;;; Scheme Environment: compiler-package -;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package) -;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package) -;;; End: (for-each edge-disconnect-right! edges)) \ No newline at end of file diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index 7528951fa..661352a7d 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,46 +1,40 @@ -;;; -*-Scheme-*- -;;; -;;; Copyright (c) 1986 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. -;;; +#| -*-Scheme-*- -;;;; Compiler CFG Datatypes +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.40 1987/03/19 00:32:49 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. -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.39 1986/12/21 19:33:58 cph Exp $ +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. |# + +;;;; Compiler CFG Datatypes (declare (usual-integrations)) -(using-syntax (access compiler-syntax-table compiler-package) (define-snode assignment block lvalue rvalue) @@ -102,14 +96,4 @@ (define-unparser continuation-tag (lambda (continuation) - (write (continuation-label continuation)))) - -;;; end USING-SYNTAX -) - -;;; Edwin Variables: -;;; Scheme Environment: compiler-package -;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package) -;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package) -;;; End: (symbol-hash-table/lookup *label->object* label)) \ No newline at end of file diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index 0b0d67598..1d6a4aa25 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,78 +1,74 @@ -;;; -*-Scheme-*- -;;; -;;; Copyright (c) 1986 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. -;;; +#| -*-Scheme-*- -;;;; Compiler Macros +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.56 1987/03/19 00:33:44 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.55 1987/01/01 16:55:28 cph Exp $ +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. |# + +;;;; Compiler Macros (declare (usual-integrations)) -(in-package compiler-package - (define compiler-syntax-table - (make-syntax-table system-global-syntax-table)) +(define compiler-syntax-table + (make-syntax-table system-global-syntax-table)) - (define lap-generator-syntax-table - (make-syntax-table compiler-syntax-table)) +(define lap-generator-syntax-table + (make-syntax-table compiler-syntax-table)) - (define assembler-syntax-table - (make-syntax-table compiler-syntax-table))) +(define assembler-syntax-table + (make-syntax-table compiler-syntax-table)) -(syntax-table-define (access compiler-syntax-table compiler-package) 'PACKAGE - (lambda (expression) - (apply (lambda (names . body) - (make-sequence - `(,@(map (lambda (name) - (make-definition name (make-unassigned-object))) - names) - ,(make-combination - (let ((block (syntax* body))) - (if (open-block? block) - (open-block-components block - (lambda (names* declarations body) - (make-lambda lambda-tag:let '() '() #!FALSE - (list-transform-negative names* - (lambda (name) - (memq name names))) - declarations - body))) - (make-lambda lambda-tag:let '() '() #!FALSE '() - '() block))) - '())))) - (cdr expression)))) +(syntax-table-define compiler-syntax-table 'PACKAGE + (in-package system-global-environment + (declare (usual-integrations)) + (lambda (expression) + (apply (lambda (names . body) + (make-sequence + `(,@(map (lambda (name) + (make-definition name (make-unassigned-object))) + names) + ,(make-combination + (let ((block (syntax* body))) + (if (open-block? block) + (open-block-components block + (lambda (names* declarations body) + (make-lambda lambda-tag:let '() '() false + (list-transform-negative names* + (lambda (name) + (memq name names))) + declarations + body))) + (make-lambda lambda-tag:let '() '() false '() + '() block))) + '())))) + (cdr expression))))) (let () @@ -99,6 +95,7 @@ (named-lambda (lambda-list->bound-names lambda-list) (cond ((symbol? lambda-list) lambda-list) + ((null? lambda-list) '()) ((not (pair? lambda-list)) (error "Illegal rest variable" lambda-list)) ((eq? (car lambda-list) @@ -109,8 +106,7 @@ (else (accumulate lambda-list)))))) -(syntax-table-define (access compiler-syntax-table compiler-package) - 'DEFINE-EXPORT +(syntax-table-define compiler-syntax-table 'DEFINE-EXPORT (macro (pattern . body) (parse-define-syntax pattern body (lambda (name body) @@ -119,8 +115,7 @@ `(SET! ,(car pattern) (NAMED-LAMBDA ,pattern ,@body)))))) -(syntax-table-define (access compiler-syntax-table compiler-package) - 'DEFINE-INTEGRABLE +(syntax-table-define compiler-syntax-table 'DEFINE-INTEGRABLE (macro (pattern . body) #| (parse-define-syntax pattern body @@ -128,7 +123,7 @@ `(BEGIN (DECLARE (INTEGRATE ,pattern)) (DEFINE ,pattern ,@body))) (lambda (pattern body) - `(BEGIN (DECLARE (INTEGRATE ,(car pattern))) + `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern))) (DEFINE ,pattern ,@(if (list? (cdr pattern)) `(DECLARE @@ -141,8 +136,7 @@ ) -(syntax-table-define (access compiler-syntax-table compiler-package) - 'DEFINE-VECTOR-SLOTS +(syntax-table-define compiler-syntax-table 'DEFINE-VECTOR-SLOTS (macro (class index . slots) (define (loop slots n) (if (null? slots) @@ -163,7 +157,7 @@ ((define-type-definition (macro (name reserved) (let ((parent (symbol-append name '-TAG))) - `(SYNTAX-TABLE-DEFINE (ACCESS COMPILER-SYNTAX-TABLE COMPILER-PACKAGE) + `(SYNTAX-TABLE-DEFINE COMPILER-SYNTAX-TABLE ',(symbol-append 'DEFINE- name) (macro (type . slots) (let ((tag-name (symbol-append type '-TAG))) @@ -182,8 +176,7 @@ (define-type-definition rvalue 1) (define-type-definition vnode 10)) -(syntax-table-define (access compiler-syntax-table compiler-package) - 'DESCRIPTOR-LIST +(syntax-table-define compiler-syntax-table 'DESCRIPTOR-LIST (macro (type . slots) `(LIST ,@(map (lambda (slot) (let ((ref-name (symbol-append type '- slot))) @@ -212,25 +205,21 @@ ,@(loop (cdr components) (* ref-index 2) (* set-index 2)))))))))) - (syntax-table-define (access compiler-syntax-table compiler-package) - 'DEFINE-RTL-EXPRESSION + (syntax-table-define compiler-syntax-table 'DEFINE-RTL-EXPRESSION (macro (type prefix . components) (rtl-common type prefix components identity-procedure))) - (syntax-table-define (access compiler-syntax-table compiler-package) - 'DEFINE-RTL-STATEMENT + (syntax-table-define compiler-syntax-table 'DEFINE-RTL-STATEMENT (macro (type prefix . components) (rtl-common type prefix components (lambda (expression) `(STATEMENT->SCFG ,expression))))) - (syntax-table-define (access compiler-syntax-table compiler-package) - 'DEFINE-RTL-PREDICATE + (syntax-table-define compiler-syntax-table 'DEFINE-RTL-PREDICATE (macro (type prefix . components) (rtl-common type prefix components (lambda (expression) `(PREDICATE->PCFG ,expression)))))) -(syntax-table-define (access compiler-syntax-table compiler-package) - 'DEFINE-REGISTER-REFERENCES +(syntax-table-define compiler-syntax-table 'DEFINE-REGISTER-REFERENCES (macro (slot) (let ((name (symbol-append 'REGISTER- slot))) (let ((vector (symbol-append '* name '*))) @@ -241,35 +230,22 @@ (,(symbol-append 'SET- name '!) REGISTER VALUE) (VECTOR-SET! ,vector REGISTER VALUE))))))) -(syntax-table-define (access compiler-syntax-table compiler-package) - 'UCODE-TYPE +(syntax-table-define compiler-syntax-table 'UCODE-TYPE (macro (name) (microcode-type name))) -(syntax-table-define (access compiler-syntax-table compiler-package) - 'UCODE-PRIMITIVE +(syntax-table-define compiler-syntax-table 'UCODE-PRIMITIVE (macro (name) (make-primitive-procedure name))) -(syntax-table-define (access lap-generator-syntax-table compiler-package) - 'DEFINE-RULE - (in-package compiler-package - (declare (usual-integrations)) - (macro (type pattern . body) - (parse-rule pattern body - (lambda (pattern names transformer qualifier actions) - `(,(case type - ((STATEMENT) 'ADD-STATEMENT-RULE!) - ((PREDICATE) 'ADD-STATEMENT-RULE!) - (else (error "Unknown rule type" type))) - ',pattern - ,(rule-result-expression names transformer qualifier - `(BEGIN ,@actions)))))))) - -;;;; Datatype Definers - -;;; Edwin Variables: -;;; Scheme Environment: system-global-environment -;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package) -;;; End: +(syntax-table-define lap-generator-syntax-table 'DEFINE-RULE + (macro (type pattern . body) + (parse-rule pattern body + (lambda (pattern names transformer qualifier actions) + `(,(case type + ((STATEMENT) 'ADD-STATEMENT-RULE!) + ((PREDICATE) 'ADD-STATEMENT-RULE!) + (else (error "Unknown rule type" type))) + ',pattern + ,(rule-result-expression names transformer qualifier `(BEGIN ,@actions))))))) \ No newline at end of file diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index 5c32f2688..858daeeb9 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,174 +1,40 @@ -;;; -*-Scheme-*- -;;; -;;; 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. -;;; +#| -*-Scheme-*- -;;;; Compiler Utilities +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.81 1987/03/19 00:34:49 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. -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.80 1987/01/01 18:51:18 cph Exp $ +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. |# + +;;;; Compiler Utilities (declare (usual-integrations)) -(using-syntax (access compiler-syntax-table compiler-package) - -;;;; Support for tagged objects - -(define (make-vector-tag parent name) - (let ((tag (cons '() (or parent vector-tag:object)))) - (vector-tag-put! tag ':TYPE-NAME name) - ((access add-unparser-special-object! unparser-package) - tag tagged-vector-unparser) - tag)) - -(define *tagged-vector-unparser-show-hash* - true) - -(define (tagged-vector-unparser object) - (unparse-with-brackets - (lambda () - (write-string "LIAR ") - (if *tagged-vector-unparser-show-hash* - (begin (fluid-let ((*unparser-radix* 10)) - (write (hash object))) - (write-string " "))) - (fluid-let ((*unparser-radix* 16)) - ((vector-method object ':UNPARSE) object))))) - -(define (vector-tag-put! tag key value) - (let ((entry (assq key (car tag)))) - (if entry - (set-cdr! entry value) - (set-car! tag (cons (cons key value) (car tag)))))) - -(define (vector-tag-get tag key) - (define (loop tag) - (and (pair? tag) - (or (assq key (car tag)) - (loop (cdr tag))))) - (let ((value - (or (assq key (car tag)) - (loop (cdr tag))))) - (and value (cdr value)))) - -(define vector-tag:object - (list '())) - -(vector-tag-put! vector-tag:object ':TYPE-NAME 'OBJECT) - -(define-integrable (vector-tag vector) - (vector-ref vector 0)) - -(define (define-vector-method tag name method) - (vector-tag-put! tag name method) - name) - -(define (vector-tag-method tag name) - (or (vector-tag-get tag name) - (error "Unbound method" tag name))) - -(define-integrable (vector-tag-parent-method tag name) - (vector-tag-method (cdr tag) name)) - -(define-integrable (vector-method vector name) - (vector-tag-method (vector-tag vector) name)) - -(define (define-unparser tag unparser) - (define-vector-method tag ':UNPARSE unparser)) - -(define-integrable make-tagged-vector - vector) - -(define ((tagged-vector-predicate tag) object) - (and (vector? object) - (not (zero? (vector-length object))) - (eq? tag (vector-tag object)))) - -(define (tagged-vector-subclass-predicate tag) - (define (loop tag*) - (or (eq? tag tag*) - (and (pair? tag*) - (loop (cdr tag*))))) - (lambda (object) - (and (vector? object) - (not (zero? (vector-length object))) - (loop (vector-tag object))))) - -(define tagged-vector? - (tagged-vector-subclass-predicate vector-tag:object)) - -(define-unparser vector-tag:object - (lambda (object) - (write (vector-method object ':TYPE-NAME)))) - -(define (->tagged-vector object) - (or (and (tagged-vector? object) object) - (and (integer? object) - (let ((object (unhash object))) - (and (tagged-vector? object) object))))) - -;;;; Queue - -(define (make-queue) - (cons '() '())) - -(define-integrable (queue-empty? queue) - (null? (car queue))) - -(define-integrable (queued? queue item) - (memq item (car queue))) - -(define (enqueue! queue object) - (let ((next (cons object '()))) - (if (null? (cdr queue)) - (set-car! queue next) - (set-cdr! (cdr queue) next)) - (set-cdr! queue next))) - -(define (dequeue! queue) - (let ((next (car queue))) - (if (null? (cdr next)) - (begin (set-car! queue '()) - (set-cdr! queue '())) - (set-car! queue (cdr next))) - (car next))) - -(define (queue-map! queue procedure) - (define (loop) - (if (not (queue-empty? queue)) - (begin (procedure (dequeue! queue)) - (loop)))) - (loop)) ;;;; Miscellaneous @@ -199,7 +65,6 @@ (cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA) ((eq? prefix lambda-tag:let) 'LET) ((eq? prefix lambda-tag:make-environment) 'MAKE-ENVIRONMENT) - ((eq? prefix lambda-tag:make-package) 'MAKE-PACKAGE) ((or (eq? prefix lambda-tag:shallow-fluid-let) (eq? prefix lambda-tag:deep-fluid-let) (eq? prefix lambda-tag:common-lisp-fluid-let)) @@ -236,97 +101,11 @@ (write-line (- (runtime) start)) value))) -;;;; Set Operations - -(define (eq-set-adjoin element set) - (if (memq element set) - set - (cons element set))) - -(define (eqv-set-adjoin element set) - (if (memv element set) - set - (cons element set))) - -(define (eq-set-delete set item) - (define (loop set) - (cond ((null? set) '()) - ((eq? (car set) item) (cdr set)) - (else (cons (car set) (loop (cdr set)))))) - (loop set)) - -(define (eqv-set-delete set item) - (define (loop set) - (cond ((null? set) '()) - ((eqv? (car set) item) (cdr set)) - (else (cons (car set) (loop (cdr set)))))) - (loop set)) - -(define (eq-set-substitute set old new) - (define (loop set) - (cond ((null? set) '()) - ((eq? (car set) old) (cons new (cdr set))) - (else (cons (car set) (loop (cdr set)))))) - (loop set)) - -(define (eqv-set-substitute set old new) - (define (loop set) - (cond ((null? set) '()) - ((eqv? (car set) old) (cons new (cdr set))) - (else (cons (car set) (loop (cdr set)))))) - (loop set)) - -(define (set-search set procedure) - (define (loop items) - (and (not (null? items)) - (or (procedure (car items)) - (loop (cdr items))))) - (loop set)) - -;;; The dataflow analyzer assumes that -;;; (eq? (list-tail (eq-set-union x y) n) y) for some n. - -(define (eq-set-union x y) - (if (null? y) - x - (let loop ((x x) (y y)) - (if (null? x) - y - (loop (cdr x) - (if (memq (car x) y) - y - (cons (car x) y))))))) - -(define (eqv-set-union x y) - (if (null? y) - x - (let loop ((x x) (y y)) - (if (null? x) - y - (loop (cdr x) - (if (memv (car x) y) - y - (cons (car x) y))))))) - -(define (eq-set-difference x y) - (define (loop x) - (cond ((null? x) '()) - ((memq (car x) y) (loop (cdr x))) - (else (cons (car x) (loop (cdr x)))))) - (loop x)) - -(define (eqv-set-difference x y) - (define (loop x) - (cond ((null? x) '()) - ((memv (car x) y) (loop (cdr x))) - (else (cons (car x) (loop (cdr x)))))) - (loop x)) - ;;;; SCode Interface (let-syntax ((define-scode-operator (macro (name) - `(DEFINE ,(symbol-append 'SCODE: name) + `(DEFINE ,(symbol-append 'SCODE/ name) (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT))))) (define-scode-operator access-components) (define-scode-operator access?) @@ -343,6 +122,7 @@ (define-scode-operator lambda-components) (define-scode-operator lambda?) (define-scode-operator make-access) + (define-scode-operator make-assignment) (define-scode-operator make-combination) (define-scode-operator make-conditional) (define-scode-operator make-definition) @@ -362,20 +142,20 @@ (define-scode-operator variable-name) (define-scode-operator variable?)) -(define scode:constant? +(define scode/constant? (access scode-constant? system-global-environment)) -(define (scode:error-combination-components combination receiver) - (scode:combination-components combination +(define (scode/error-combination-components combination receiver) + (scode/combination-components combination (lambda (operator operands) (receiver (car operands) (let ((irritant (cadr operands))) - (cond ((scode:access? irritant) '()) - ((scode:combination? irritant) - (scode:combination-components irritant + (cond ((scode/access? irritant) '()) + ((scode/combination? irritant) + (scode/combination-components irritant (lambda (operator operands) - (if (and (scode:access? operator) - (scode:access-components operator + (if (and (scode/access? operator) + (scode/access-components operator (lambda (environment name) (and (null? environment) (eq? name 'LIST))))) @@ -383,13 +163,18 @@ (list irritant))))) (else (list irritant)))))))) -(define (scode:procedure-type-code *lambda) +(define (scode/procedure-type-code *lambda) (cond ((primitive-type? type-code:lambda *lambda) type-code:procedure) ((primitive-type? type-code:extended-lambda *lambda) type-code:extended-procedure) (else - (error "SCODE:PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda)))) + (error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda)))) + +(define (scode/make-let names values body) + (scode/make-combination (scode/make-lambda lambda-tag:let names '() false '() + '() body) + values)) ;;;; Type Codes @@ -482,7 +267,7 @@ (or (non-pointer-object? object) (number? object) (symbol? object) - (scode:primitive-procedure? object) + (scode/primitive-procedure? object) (eq? object compiled-error-procedure))) (define (operator-constant-foldable? operator) @@ -497,21 +282,7 @@ + - * / 1+ -1+ abs quotient remainder modulo integer-divide gcd lcm floor ceiling truncate round exp log expt sqrt sin cos tan asin acos atan - (ucode-primitive &+) - (ucode-primitive &-) - (ucode-primitive &*) - (ucode-primitive &/) - (ucode-primitive &<) - (ucode-primitive &>) - (ucode-primitive &=) - (ucode-primitive &atan))) - -;;; end USING-SYNTAX -) - -;;; Edwin Variables: -;;; Scheme Environment: compiler-package -;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package) -;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package) -;;; End: + (ucode-primitive &+) (ucode-primitive &-) + (ucode-primitive &*) (ucode-primitive &/) + (ucode-primitive &<) (ucode-primitive &>) (ucode-primitive &=) (ucode-primitive &atan))) \ No newline at end of file