From f5f74eb9aa575ad4f756bb84a90125f6a8a09319 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 19 Mar 1987 00:34:49 +0000
Subject: [PATCH] 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'.
---
v7/src/compiler/base/cfg1.scm | 82 ++++----
v7/src/compiler/base/ctypes.scm | 82 ++++----
v7/src/compiler/base/macros.scm | 196 ++++++++-----------
v7/src/compiler/base/utils.scm | 337 +++++---------------------------
4 files changed, 206 insertions(+), 491 deletions(-)
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
--
2.25.1