From ea3b462e8e1a3af8933304a72a3a565cc7900a22 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 8 Feb 2002 03:13:05 +0000
Subject: [PATCH] Eliminate non-hygienic macros.
---
v7/src/compiler/back/asmmac.scm | 4 +-
v7/src/compiler/base/cfg1.scm | 10 +-
v7/src/compiler/base/macros.scm | 543 +++++++++++-------
v7/src/compiler/base/scode.scm | 64 +--
v7/src/compiler/base/utils.scm | 14 +-
v7/src/compiler/etc/comcmp.scm | 11 +-
v7/src/compiler/fggen/canon.scm | 76 ++-
v7/src/compiler/fggen/fggen.scm | 34 +-
v7/src/compiler/machines/C/compiler.pkg | 78 ++-
v7/src/compiler/machines/alpha/compiler.pkg | 78 ++-
v7/src/compiler/machines/bobcat/compiler.pkg | 78 ++-
v7/src/compiler/machines/i386/compiler.pkg | 76 ++-
v7/src/compiler/machines/mips/compiler.pkg | 78 ++-
.../compiler/machines/spectrum/compiler.pkg | 78 ++-
v7/src/compiler/machines/vax/compiler.pkg | 78 ++-
v7/src/compiler/rtlbase/rtlcfg.scm | 7 +-
v7/src/compiler/rtlbase/rtlreg.scm | 27 +-
v7/src/compiler/rtlbase/valclass.scm | 69 +--
18 files changed, 1000 insertions(+), 403 deletions(-)
diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm
index 84175aa7b..dde56c135 100644
--- a/v7/src/compiler/back/asmmac.scm
+++ b/v7/src/compiler/back/asmmac.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: asmmac.scm,v 1.11 2002/02/07 05:57:44 cph Exp $
+$Id: asmmac.scm,v 1.12 2002/02/08 03:06:16 cph Exp $
Copyright (c) 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology
@@ -27,7 +27,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
(define-syntax define-instruction
(sc-macro-transformer
(lambda (form environment)
- (if (syntax-match? '(SYMBOL * DATUM) (cdr form))
+ (if (syntax-match? '(SYMBOL * (DATUM + DATUM)) (cdr form))
`(ADD-INSTRUCTION!
',(cadr form)
,(compile-database (cddr form)
diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm
index 3d8df9f48..1af4bb28f 100644
--- a/v7/src/compiler/base/cfg1.scm
+++ b/v7/src/compiler/base/cfg1.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: cfg1.scm,v 4.5 1999/01/02 06:06:43 cph Exp $
+$Id: cfg1.scm,v 4.6 2002/02/08 03:07:00 cph Exp $
-Copyright (c) 1987, 1989, 1999 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1999, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -32,7 +32,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
(set-vector-tag-description!
cfg-node-tag
(lambda (node)
- (descriptor-list node generation alist previous-edges)))
+ (descriptor-list node node generation alist previous-edges)))
(define snode-tag (make-vector-tag cfg-node-tag 'SNODE false))
(define snode? (tagged-vector/subclass-predicate snode-tag))
@@ -46,7 +46,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
snode-tag
(lambda (snode)
(append! ((vector-tag-description (vector-tag-parent snode-tag)) snode)
- (descriptor-list snode next-edge))))
+ (descriptor-list snode snode next-edge))))
(define pnode-tag (make-vector-tag cfg-node-tag 'PNODE false))
(define pnode? (tagged-vector/subclass-predicate pnode-tag))
@@ -60,7 +60,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
pnode-tag
(lambda (pnode)
(append! ((vector-tag-description (vector-tag-parent pnode-tag)) pnode)
- (descriptor-list pnode consequent-edge alternative-edge))))
+ (descriptor-list pnode pnode consequent-edge alternative-edge))))
(define (add-node-previous-edge! node edge)
(set-node-previous-edges! node (cons edge (node-previous-edges node))))
diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm
index d102eab3e..353f251c7 100644
--- a/v7/src/compiler/base/macros.scm
+++ b/v7/src/compiler/base/macros.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: macros.scm,v 4.23 2002/02/03 03:38:53 cph Exp $
+$Id: macros.scm,v 4.24 2002/02/08 03:07:04 cph Exp $
Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
@@ -26,29 +26,31 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
(declare (usual-integrations))
(define-syntax last-reference
- (non-hygienic-macro-transformer
- (lambda (name)
- (let ((x (generate-uninterned-symbol)))
- `(IF COMPILER:PRESERVE-DATA-STRUCTURES?
- ,name
- (LET ((,x ,name))
- (SET! ,name)
- ,x))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(IDENTIFIER) (cdr form))
+ (let ((name (close-syntax (cadr form) environment)))
+ `(IF COMPILER:PRESERVE-DATA-STRUCTURES?
+ ,name
+ (LET ((TEMP ,name))
+ (SET! ,name)
+ TEMP)))
+ (ill-formed-syntax form)))))
(define-syntax package
(rsc-macro-transformer
(lambda (form environment)
- (if (not (syntax-match? '((* IDENTIFIER) * EXPRESSION) (cdr form)))
- (error "Ill-formed special form:" form))
- (let ((names (cadr form))
- (body (cddr form)))
- `(,(make-syntactic-closure environment '() 'BEGIN)
- ,@(map (let ((r-define
- (make-syntactic-closure environment '() 'DEFINE)))
- (lambda (name)
- `(,r-define ,name)))
- names)
- (,(make-syntactic-closure environment '() 'LET) () ,@body))))))
+ (if (syntax-match? '((* IDENTIFIER) * EXPRESSION) (cdr form))
+ (let ((names (cadr form))
+ (body (cddr form)))
+ `(,(make-syntactic-closure environment '() 'BEGIN)
+ ,@(map (let ((r-define
+ (make-syntactic-closure environment '() 'DEFINE)))
+ (lambda (name)
+ `(,r-define ,name)))
+ names)
+ (,(make-syntactic-closure environment '() 'LET) () ,@body)))
+ (ill-formed-syntax form)))))
(define-syntax define-export
(rsc-macro-transformer
@@ -62,245 +64,342 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
(,(make-syntactic-closure environment '() 'NAMED-LAMBDA)
,@(cdr form))))
(else
- (error "Ill-formed special form:" form))))))
+ (ill-formed-syntax form))))))
(define-syntax define-vector-slots
- (non-hygienic-macro-transformer
- (lambda (class index . slots)
- (define (loop slots n)
- (if (pair? slots)
- (let ((make-defs
- (lambda (slot)
- (let ((ref-name (symbol-append class '- slot)))
- `(BEGIN
- (DEFINE-INTEGRABLE (,ref-name ,class)
- (VECTOR-REF ,class ,n))
- (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!)
- ,class ,slot)
- (VECTOR-SET! ,class ,n ,slot))))))
- (rest (loop (cdr slots) (1+ n))))
- (if (pair? (car slots))
- (map* rest make-defs (car slots))
- (cons (make-defs (car slots)) rest)))
- '()))
- (if (pair? slots)
- `(BEGIN ,@(loop slots index))
- 'UNSPECIFIC))))
+ (sc-macro-transformer
+ (let ((pattern
+ `(SYMBOL ,exact-nonnegative-integer?
+ * ,(lambda (x)
+ (or (symbol? x)
+ (and (pair? x)
+ (list-of-type? x symbol?)))))))
+ (lambda (form environment)
+ environment
+ (if (syntax-match? pattern (cdr form))
+ (let ((class (cadr form))
+ (index (caddr form))
+ (slots (cdddr form)))
+ (let ((make-defs
+ (lambda (slot index)
+ (let ((ref-name (symbol-append class '- slot)))
+ `((DEFINE-INTEGRABLE (,ref-name V)
+ (VECTOR-REF V ,index))
+ (DEFINE-INTEGRABLE
+ (,(symbol-append 'SET- ref-name '!) V OBJECT)
+ (VECTOR-SET! V ,index OBJECT)))))))
+ (if (pair? slots)
+ `(BEGIN
+ ,@(let loop ((slots slots) (index index))
+ (if (pair? slots)
+ (append (if (pair? (car slots))
+ (append-map (lambda (slot)
+ (make-defs slot index))
+ (car slots))
+ (make-defs (car slots) index))
+ (loop (cdr slots) (+ index 1)))
+ '())))
+ 'UNSPECIFIC)))
+ (ill-formed-syntax form))))))
(define-syntax define-root-type
- (non-hygienic-macro-transformer
- (lambda (type . slots)
- (let ((tag-name (symbol-append type '-TAG)))
- `(BEGIN (DEFINE ,tag-name
- (MAKE-VECTOR-TAG #F ',type #F))
- (DEFINE ,(symbol-append type '?)
- (TAGGED-VECTOR/SUBCLASS-PREDICATE ,tag-name))
- (DEFINE-VECTOR-SLOTS ,type 1 ,@slots)
- (SET-VECTOR-TAG-DESCRIPTION!
- ,tag-name
- (LAMBDA (,type)
- (DESCRIPTOR-LIST ,type ,@slots))))))))
-
-(define-syntax descriptor-list
- (non-hygienic-macro-transformer
- (lambda (type . slots)
- (let ((ref-name (lambda (slot) (symbol-append type '- slot))))
- `(LIST ,@(map (lambda (slot)
- (if (pair? slot)
- (let ((ref-names (map ref-name slot)))
- ``(,',ref-names ,(,(car ref-names) ,type)))
- (let ((ref-name (ref-name slot)))
- ``(,',ref-name ,(,ref-name ,type)))))
- slots))))))
+ (sc-macro-transformer
+ (let ((pattern
+ `(SYMBOL * ,(lambda (x)
+ (or (symbol? x)
+ (and (pair? x)
+ (list-of-type? x symbol?)))))))
+ (lambda (form environment)
+ (if (syntax-match? pattern (cdr form))
+ (let ((type (cadr form))
+ (slots (cddr form)))
+ (let ((tag-name (symbol-append type '-TAG)))
+ (let ((tag-ref (close-syntax tag-name environment)))
+ `(BEGIN
+ (DEFINE ,tag-name
+ (MAKE-VECTOR-TAG #F ',type #F))
+ (DEFINE ,(symbol-append type '?)
+ (TAGGED-VECTOR/SUBCLASS-PREDICATE ,tag-ref))
+ (DEFINE-VECTOR-SLOTS ,type 1 ,@slots)
+ (SET-VECTOR-TAG-DESCRIPTION! ,tag-ref
+ (LAMBDA (OBJECT)
+ (DESCRIPTOR-LIST OBJECT ,type ,@slots)))))))
+ (ill-formed-syntax form))))))
(let-syntax
((define-type-definition
- (non-hygienic-macro-transformer
- (lambda (name reserved enumeration)
- (let ((parent (symbol-append name '-TAG)))
- `(define-syntax ,(symbol-append 'DEFINE- name)
- (non-hygienic-macro-transformer
- (lambda (type . slots)
- (let ((tag-name (symbol-append type '-TAG)))
- `(BEGIN
- (DEFINE ,tag-name
- (MAKE-VECTOR-TAG ,',parent ',type ,',enumeration))
- (DEFINE ,(symbol-append type '?)
- (TAGGED-VECTOR/PREDICATE ,tag-name))
- (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots)
- (SET-VECTOR-TAG-DESCRIPTION!
- ,tag-name
- (LAMBDA (,type)
- (APPEND!
- ((VECTOR-TAG-DESCRIPTION ,',parent) ,type)
- (DESCRIPTOR-LIST ,type ,@slots))))))))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (reserved (caddr form))
+ (enumeration (close-syntax (cadddr form) environment)))
+ (let ((parent
+ (close-syntax (symbol-append name '-TAG) environment)))
+ `(define-syntax ,(symbol-append 'DEFINE- name)
+ (sc-macro-transformer
+ (let ((pattern
+ `(SYMBOL * ,(lambda (x)
+ (or (symbol? x)
+ (and (pair? x)
+ (list-of-type? x symbol?)))))))
+ (lambda (form environment)
+ (let ((type (cadr form))
+ (slots (cddr form)))
+ (let ((tag-name (symbol-append type '-TAG)))
+ (let ((tag-ref (close-syntax tag-name environment)))
+ `(BEGIN
+ (DEFINE ,tag-name
+ (MAKE-VECTOR-TAG ,',parent ',type
+ ,',enumeration))
+ (DEFINE ,(symbol-append type '?)
+ (TAGGED-VECTOR/PREDICATE ,tag-name))
+ (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots)
+ (SET-VECTOR-TAG-DESCRIPTION!
+ ,tag-name
+ (LAMBDA (OBJECT)
+ (APPEND!
+ ((VECTOR-TAG-DESCRIPTION ,',parent) OBJECT)
+ (DESCRIPTOR-LIST OBJECT
+ ,type
+ ,@slots))))))))))))))))))
(define-type-definition snode 5 #f)
(define-type-definition pnode 6 #f)
(define-type-definition rvalue 2 rvalue-types)
(define-type-definition lvalue 14 #f))
+(define-syntax descriptor-list
+ (sc-macro-transformer
+ (let ((pattern
+ `(IDENTIFIER SYMBOL
+ * ,(lambda (x)
+ (or (symbol? x)
+ (and (pair? x)
+ (list-of-type? x symbol?)))))))
+ (lambda (form environment)
+ (if (syntax-match? pattern (cdr form))
+ (let ((object (close-syntax (cadr form) environment))
+ (type (caddr form))
+ (slots (cdddr form)))
+ (let ((ref-name
+ (lambda (slot)
+ (close-syntax (symbol-append type '- slot)
+ environment))))
+ `(LIST
+ ,@(map (lambda (slot)
+ (if (pair? slot)
+ (let ((names (map ref-name slot)))
+ ``(,',names ,(,(car names) ,object)))
+ (let ((name (ref-name slot)))
+ ``(,',name ,(,name ,object)))))
+ slots))))
+ (ill-formed-syntax form))))))
+
;;; Kludge to make these compile efficiently.
(define-syntax make-snode
- (non-hygienic-macro-transformer
- (lambda (tag . extra)
- `((ACCESS VECTOR ,system-global-environment)
- ,tag #F '() '() #F ,@extra))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(+ EXPRESSION) (cdr form))
+ (let ((tag (close-syntax (cadr form) environment))
+ (extra
+ (map (lambda (form) (close-syntax form environment))
+ (cddr form))))
+ `((ACCESS VECTOR ,system-global-environment)
+ ,tag #F '() '() #F ,@extra))
+ (ill-formed-syntax form)))))
(define-syntax make-pnode
- (non-hygienic-macro-transformer
- (lambda (tag . extra)
- `((ACCESS VECTOR ,system-global-environment)
- ,tag #F '() '() #F #F ,@extra))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(+ EXPRESSION) (cdr form))
+ (let ((tag (close-syntax (cadr form) environment))
+ (extra
+ (map (lambda (form) (close-syntax form environment))
+ (cddr form))))
+ `((ACCESS VECTOR ,system-global-environment)
+ ,tag #F '() '() #F #F ,@extra))
+ (ill-formed-syntax form)))))
(define-syntax make-rvalue
- (non-hygienic-macro-transformer
- (lambda (tag . extra)
- `((ACCESS VECTOR ,system-global-environment)
- ,tag #F ,@extra))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(+ EXPRESSION) (cdr form))
+ (let ((tag (close-syntax (cadr form) environment))
+ (extra
+ (map (lambda (form) (close-syntax form environment))
+ (cddr form))))
+ `((ACCESS VECTOR ,system-global-environment)
+ ,tag #F ,@extra))
+ (ill-formed-syntax form)))))
(define-syntax make-lvalue
- (non-hygienic-macro-transformer
- (lambda (tag . extra)
- (let ((result (generate-uninterned-symbol)))
- `(let ((,result
- ((ACCESS VECTOR ,system-global-environment)
- ,tag #F '() '() '() '() '() '() 'NOT-CACHED
- #F '() #F #F '() ,@extra)))
- (SET! *LVALUES* (CONS ,result *LVALUES*))
- ,result)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(+ EXPRESSION) (cdr form))
+ (let ((tag (close-syntax (cadr form) environment))
+ (extra
+ (map (lambda (form) (close-syntax form environment))
+ (cddr form))))
+ `(LET ((LVALUE
+ ((ACCESS VECTOR ,system-global-environment)
+ ,tag #F '() '() '() '() '() '() 'NOT-CACHED
+ #F '() #F #F '() ,@extra)))
+ (SET! *LVALUES* (CONS LVALUE *LVALUES*))
+ LVALUE))
+ (ill-formed-syntax form)))))
(define-syntax define-rtl-expression
- (non-hygienic-macro-transformer
- (lambda (type prefix . components)
- (rtl-common type prefix components
- identity-procedure
- 'RTL:EXPRESSION-TYPES))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (define-rtl-common form environment
+ (lambda (expression) expression)
+ 'RTL:EXPRESSION-TYPES))))
(define-syntax define-rtl-statement
- (non-hygienic-macro-transformer
- (lambda (type prefix . components)
- (rtl-common type prefix components
- (lambda (expression) `(STATEMENT->SRTL ,expression))
- 'RTL:STATEMENT-TYPES))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (define-rtl-common form environment
+ (lambda (expression) `(STATEMENT->SRTL ,expression))
+ 'RTL:STATEMENT-TYPES))))
(define-syntax define-rtl-predicate
- (non-hygienic-macro-transformer
- (lambda (type prefix . components)
- (rtl-common type prefix components
- (lambda (expression) `(PREDICATE->PRTL ,expression))
- 'RTL:PREDICATE-TYPES))))
-
-(define (rtl-common type prefix components wrap-constructor types)
- `(BEGIN
- (SET! ,types (CONS ',type ,types))
- (DEFINE-INTEGRABLE
- (,(symbol-append prefix 'MAKE- type) ,@components)
- ,(wrap-constructor `(LIST ',type ,@components)))
- (DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION)
- (EQ? (CAR EXPRESSION) ',type))
- ,@(let loop ((components components)
- (ref-index 6)
- (set-index 2))
- (if (pair? components)
- (let* ((slot (car components))
- (name (symbol-append type '- slot)))
- `((DEFINE-INTEGRABLE (,(symbol-append 'RTL: name) ,type)
- (GENERAL-CAR-CDR ,type ,ref-index))
- ,(let ((slot (if (eq? slot type)
- (symbol-append slot '-VALUE)
- slot)))
- `(DEFINE-INTEGRABLE
- (,(symbol-append 'RTL:SET- name '!)
- ,type ,slot)
- (SET-CAR! (GENERAL-CAR-CDR ,type ,set-index)
- ,slot)))
- ,@(loop (cdr components)
- (* ref-index 2)
- (* set-index 2))))
- '()))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (define-rtl-common form environment
+ (lambda (expression) `(PREDICATE->PRTL ,expression))
+ 'RTL:PREDICATE-TYPES))))
-(define-syntax define-rule
- (non-hygienic-macro-transformer
- (lambda (type pattern . body)
- (parse-rule pattern body
- (lambda (pattern variables qualifier actions)
- `(,(case type
- ((STATEMENT) 'ADD-STATEMENT-RULE!)
- ((PREDICATE) 'ADD-STATEMENT-RULE!)
- ((REWRITING) 'ADD-REWRITING-RULE!)
- (else type))
- ',pattern
- ,(rule-result-expression variables qualifier
- `(BEGIN ,@actions))))))))
+(define (define-rtl-common form environment wrap-constructor types)
+ (if (syntax-match? '(SYMBOL SYMBOL * SYMBOL) (cdr form))
+ (let ((type (cadr form))
+ (prefix (caddr form))
+ (components (cdddr form)))
+ `(BEGIN
+ (SET! ,types (CONS ',type ,types))
+ ,(let ((parameters (map make-synthetic-identifier components)))
+ `(DEFINE-INTEGRABLE
+ (,(symbol-append prefix 'MAKE- type) ,@parameters)
+ ,(wrap-constructor `(LIST ',type ,@parameters))))
+ (DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION)
+ (EQ? (CAR EXPRESSION) ',type))
+ ,@(let loop ((components components) (ref-index 6) (set-index 2))
+ (if (pair? components)
+ (let ((name (symbol-append type '- (car components))))
+ `((DEFINE-INTEGRABLE
+ (,(symbol-append 'RTL: name) OBJECT)
+ (GENERAL-CAR-CDR OBJECT ,ref-index))
+ (DEFINE-INTEGRABLE
+ (,(symbol-append 'RTL:SET- name '!) OBJECT V)
+ (SET-CAR! (GENERAL-CAR-CDR OBJECT ,set-index) V))
+ ,@(loop (cdr components)
+ (* ref-index 2)
+ (* set-index 2))))
+ '()))))
+ (ill-formed-syntax form)))
-;;;; LAP instruction sequences.
+(define-syntax define-rule
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(IDENTIFIER DATUM + DATUM) (cdr form))
+ (let ((type (cadr form))
+ (pattern (caddr form))
+ (body (cdddr form)))
+ (parse-rule pattern body
+ (lambda (pattern variables qualifier actions)
+ `(,(case type
+ ((STATEMENT) 'ADD-STATEMENT-RULE!)
+ ((PREDICATE) 'ADD-STATEMENT-RULE!)
+ ((REWRITING) 'ADD-REWRITING-RULE!)
+ (else (close-syntax type environment)))
+ ',pattern
+ ,(rule-result-expression variables qualifier
+ `(BEGIN ,@actions))))))
+ (ill-formed-syntax form)))))
(define-syntax lap
- (non-hygienic-macro-transformer
- (lambda some-instructions
- (list 'QUASIQUOTE some-instructions))))
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(* DATUM) (cdr form))
+ `(,(close-syntax 'QUASIQUOTE environment) ,@(cdr form))
+ (ill-formed-syntax form)))))
(define-syntax inst-ea
- (non-hygienic-macro-transformer
+ (rsc-macro-transformer
(lambda (ea)
- (list 'QUASIQUOTE ea))))
-
+ (if (syntax-match? '(DATUM) (cdr form))
+ `(,(close-syntax 'QUASIQUOTE environment) ,(cadr form))
+ (ill-formed-syntax form)))))
+
(define-syntax define-enumeration
- (non-hygienic-macro-transformer
- (lambda (name elements)
- (let ((enumeration (symbol-append name 'S)))
- `(BEGIN (DEFINE ,enumeration
- (MAKE-ENUMERATION ',elements))
- ,@(map (lambda (element)
- `(DEFINE ,(symbol-append name '/ element)
- (ENUMERATION/NAME->INDEX ,enumeration ',element)))
- elements))))))
-
-(define (macros/case-macro expression clauses predicate default)
- (let ((need-temp? (not (symbol? expression))))
- (let ((expression*
- (if need-temp?
- (generate-uninterned-symbol)
- expression)))
- (let ((body
- `(COND
- ,@(let loop ((clauses clauses))
- (cond ((not (pair? clauses))
- (default expression*))
- ((eq? (caar clauses) 'ELSE)
- (if (pair? (cdr clauses))
- (error "ELSE clause not last" clauses))
- clauses)
- (else
- `(((OR ,@(map (lambda (element)
- (predicate expression* element))
- (caar clauses)))
- ,@(cdar clauses))
- ,@(loop (cdr clauses)))))))))
- (if need-temp?
- `(LET ((,expression* ,expression))
- ,body)
- body)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match '(SYMBOL * SYMBOL) (cdr form))
+ (let ((name (cadr form))
+ (elements (cddr form)))
+ (let ((enumeration (symbol-append name 'S)))
+ (let ((enum-ref (close-syntax enumeration environment)))
+ `(BEGIN
+ (DEFINE ,enumeration
+ (MAKE-ENUMERATION ',elements))
+ ,@(map (lambda (element)
+ `(DEFINE ,(symbol-append name '/ element)
+ (ENUMERATION/NAME->INDEX ,enum-ref ',element)))
+ elements)))))
+ (ill-formed-syntax form)))))
(define-syntax enumeration-case
- (non-hygienic-macro-transformer
- (lambda (name expression . clauses)
- (macros/case-macro expression
- clauses
- (lambda (expression element)
- `(EQ? ,expression ,(symbol-append name '/ element)))
- (lambda (expression)
- expression
- '())))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(SYMBOL EXPRESSION * (DATUM * EXPRESSION)) (cdr form))
+ (enumeration-case-1 (caddr form) (cdddr form) environment
+ (lambda (element)
+ (symbol-append (cadr form) '/ element))
+ (lambda (expression) expression '()))
+ (ill-formed-syntax form)))))
(define-syntax cfg-node-case
- (non-hygienic-macro-transformer
+ (sc-macro-transformer
(lambda (expression . clauses)
- (macros/case-macro expression
- clauses
- (lambda (expression element)
- `(EQ? ,expression ,(symbol-append element '-TAG)))
- (lambda (expression)
- `((ELSE
- (ERROR "Unknown node type" ,expression))))))))
\ No newline at end of file
+ (if (syntax-match? '(EXPRESSION * (DATUM * EXPRESSION)) (cdr form))
+ (enumeration-case-1 (cadr form) (cddr form) environment
+ (lambda (element) (symbol-append element '-TAG))
+ (lambda (expression)
+ `((ELSE
+ (ERROR "Unknown node type:" ,expression)))))
+ (ill-formed-syntax form)))))
+
+(define (enumeration-case-1 expression clauses environment map-element default)
+ (capture-syntactic-environment
+ (lambda (closing-environment)
+ (let ((expression (close-syntax expression environment))
+ (generate-body
+ (lambda (expression)
+ `(COND
+ ,@(let loop ((clauses clauses))
+ (if (pair? clauses)
+ (if (and (identifier? (caar clauses))
+ (identifier=? environment (caar clauses)
+ closing-environment 'ELSE))
+ (begin
+ (if (pair? (cdr clauses))
+ (error "ELSE clause not last:" clauses))
+ `((ELSE
+ ,@(map (lambda (expression)
+ (close-syntax expression
+ environment))
+ (cdar clauses)))))
+ `(((OR ,@(map (lambda (element)
+ `(EQ? ,expression
+ ,(close-syntax
+ (map-element element)
+ environment)))
+ (caar clauses)))
+ ,@(map (lambda (expression)
+ (close-syntax expression environment))
+ (cdar clauses)))
+ ,@(loop (cdr clauses))))
+ (default expression)))))))
+ (if (identifier? expression)
+ (generate-body expression)
+ `(LET ((TEMP ,expression))
+ (generate-body 'TEMP)))))))
\ No newline at end of file
diff --git a/v7/src/compiler/base/scode.scm b/v7/src/compiler/base/scode.scm
index 7ec7c092f..0c0aafff7 100644
--- a/v7/src/compiler/base/scode.scm
+++ b/v7/src/compiler/base/scode.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: scode.scm,v 4.13 2001/12/23 17:20:57 cph Exp $
+$Id: scode.scm,v 4.14 2002/02/08 03:07:07 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -24,48 +24,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
(declare (usual-integrations))
-(let-syntax ((define-scode-operators
- (non-hygienic-macro-transformer
- (lambda names
- `(BEGIN ,@(map (lambda (name)
- `(DEFINE ,(symbol-append 'SCODE/ name)
- (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT)))
- names))))))
- (define-scode-operators
- make-access access? access-components
- access-environment access-name
- make-assignment assignment? assignment-components
- assignment-name assignment-value
- make-combination combination? combination-components
- combination-operator combination-operands
- make-comment comment? comment-components
- comment-expression comment-text
- make-conditional conditional? conditional-components
- conditional-predicate conditional-consequent conditional-alternative
- make-declaration declaration? declaration-components
- declaration-expression declaration-text
- make-definition definition? definition-components
- definition-name definition-value
- make-delay delay? delay-components
- delay-expression
- make-disjunction disjunction? disjunction-components
- disjunction-predicate disjunction-alternative
- make-lambda lambda? lambda-components
- make-open-block open-block? open-block-components
- primitive-procedure? procedure?
- make-quotation quotation? quotation-expression
- make-sequence sequence? sequence-actions sequence-components
- symbol?
- make-the-environment the-environment?
- make-unassigned? unassigned?? unassigned?-name
- make-variable variable? variable-components variable-name
- ))
-
-(define-integrable (scode/make-constant value) value)
-(define-integrable (scode/constant-value constant) constant)
-(define scode/constant? (access scode-constant? system-global-environment))
-
-(define-integrable (scode/quotation-components quot recvr)
+(define (scode/make-constant value) value)
+(define (scode/constant-value constant) constant)
+
+(define (scode/quotation-components quot recvr)
(recvr (scode/quotation-expression quot)))
(define comment-tag:directive
@@ -100,27 +62,27 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;;;; Absolute variables and combinations
-(define-integrable (scode/make-absolute-reference variable-name)
- (scode/make-access '() variable-name))
+(define (scode/make-absolute-reference variable-name)
+ (scode/make-access system-global-environment variable-name))
(define (scode/absolute-reference? object)
(and (scode/access? object)
- (null? (scode/access-environment object))))
+ (eq? (scode/access-environment object) system-global-environment)))
-(define-integrable (scode/absolute-reference-name reference)
+(define (scode/absolute-reference-name reference)
(scode/access-name reference))
-(define-integrable (scode/make-absolute-combination name operands)
+(define (scode/make-absolute-combination name operands)
(scode/make-combination (scode/make-absolute-reference name) operands))
(define (scode/absolute-combination? object)
(and (scode/combination? object)
(scode/absolute-reference? (scode/combination-operator object))))
-(define-integrable (scode/absolute-combination-name combination)
+(define (scode/absolute-combination-name combination)
(scode/absolute-reference-name (scode/combination-operator combination)))
-(define-integrable (scode/absolute-combination-operands combination)
+(define (scode/absolute-combination-operands combination)
(scode/combination-operands combination))
(define (scode/absolute-combination-components combination receiver)
diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm
index 6d202fd81..4f341cddf 100644
--- a/v7/src/compiler/base/utils.scm
+++ b/v7/src/compiler/base/utils.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: utils.scm,v 4.23 2001/12/23 17:20:57 cph Exp $
+$Id: utils.scm,v 4.24 2002/02/08 03:07:11 cph Exp $
-Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1987-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -137,11 +137,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;;;; Type Codes
(let-syntax ((define-type-code
- (non-hygienic-macro-transformer
- (lambda (var-name #!optional type-name)
- (if (default-object? type-name) (set! type-name var-name))
- `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: var-name)
- ',(microcode-type type-name))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: (cadr form))
+ ',(microcode-type (cadr form)))))))
(define-type-code lambda)
(define-type-code extended-lambda)
(define-type-code procedure)
diff --git a/v7/src/compiler/etc/comcmp.scm b/v7/src/compiler/etc/comcmp.scm
index 232f70a46..51ca22893 100644
--- a/v7/src/compiler/etc/comcmp.scm
+++ b/v7/src/compiler/etc/comcmp.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: comcmp.scm,v 1.10 2001/12/24 04:15:36 cph Exp $
+$Id: comcmp.scm,v 1.11 2002/02/08 03:07:42 cph Exp $
-Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1989-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -25,9 +25,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
(declare (usual-integrations))
(define-syntax ucode-type
- (non-hygienic-macro-transformer
- (lambda (name)
- (microcode-type name))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (cdr form)))))
(define comcmp:ignore-debugging-info? #t)
(define comcmp:show-differing-blocks? #f)
diff --git a/v7/src/compiler/fggen/canon.scm b/v7/src/compiler/fggen/canon.scm
index bd4c38e6e..162b71249 100644
--- a/v7/src/compiler/fggen/canon.scm
+++ b/v7/src/compiler/fggen/canon.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: canon.scm,v 1.20 2001/12/23 17:20:57 cph Exp $
+$Id: canon.scm,v 1.21 2002/02/08 03:08:00 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -503,13 +503,15 @@ ARBITRARY: The expression may be executed more than once. It
;;;; Hairier expressions
-(let-syntax ((is-operator?
- (non-hygienic-macro-transformer
- (lambda (value name)
- `(or (eq? ,value (ucode-primitive ,name))
- (and (scode/absolute-reference? ,value)
- (eq? (scode/absolute-reference-name ,value)
- ',name)))))))
+(let-syntax
+ ((is-operator?
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((value (close-syntax (cadr form) environment))
+ (name (caddr form)))
+ `(OR (EQ? ,value (UCODE-PRIMITIVE ,name))
+ (AND (SCODE/ABSOLUTE-REFERENCE? ,value)
+ (EQ? (SCODE/ABSOLUTE-REFERENCE-NAME ,value) ',name))))))))
(define (canonicalize/combination expr bound context)
(scode/combination-components
@@ -517,11 +519,11 @@ ARBITRARY: The expression may be executed more than once. It
(lambda (operator operands)
(cond ((lambda? operator)
(canonicalize/let operator operands bound context))
- ((and (is-operator? operator LEXICAL-UNASSIGNED?)
+ ((and (is-operator? operator lexical-unassigned?)
(scode/the-environment? (car operands))
(symbol? (cadr operands)))
(canonicalize/unassigned? (cadr operands) expr bound context))
- ((and (is-operator? operator ERROR-PROCEDURE)
+ ((and (is-operator? operator error-procedure)
(scode/the-environment? (caddr operands)))
(canonicalize/error operator operands bound context))
(else
@@ -799,33 +801,45 @@ ARBITRARY: The expression may be executed more than once. It
(let-syntax
((dispatch-entry
- (non-hygienic-macro-transformer
- (lambda (type handler)
- `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type) ,handler))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type (cadr form))
+ ,(close-syntax (caddr form) environment)))))
(dispatch-entries
- (non-hygienic-macro-transformer
- (lambda (types handler)
- `(BEGIN ,@(map (lambda (type)
- `(DISPATCH-ENTRY ,type ,handler))
- types)))))
+ (c-macro-transformer
+ (lambda (form environment)
+ (let ((handler (close-syntax (caddr form) environment)))
+ `(BEGIN
+ ,@(map (lambda (type)
+ `(DISPATCH-ENTRY ,type ,handler))
+ (cadr form)))))))
(standard-entry
- (non-hygienic-macro-transformer
- (lambda (name)
- `(DISPATCH-ENTRY ,name ,(symbol-append 'CANONICALIZE/ name)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DISPATCH-ENTRY ,name
+ ,(close-syntax (symbol-append 'CANONICALIZE/
+ name)
+ environment))))))
(nary-entry
- (non-hygienic-macro-transformer
- (lambda (nary name)
- `(DISPATCH-ENTRY ,name
- (,(symbol-append 'CANONICALIZE/ nary)
- ,(symbol-append 'SCODE/ name '-COMPONENTS)
- ,(symbol-append 'SCODE/MAKE- name))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((nary (cadr form))
+ (name (caddr form)))
+ `(DISPATCH-ENTRY ,name
+ ,(close-syntax
+ `(,(symbol-append 'CANONICALIZE/ nary)
+ ,(symbol-append 'SCODE/ name '-COMPONENTS)
+ ,(symbol-append 'SCODE/MAKE- name))
+ environment))))))
(binary-entry
- (non-hygienic-macro-transformer
- (lambda (name)
- `(NARY-ENTRY binary ,name)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(NARY-ENTRY BINARY ,(cadr form))))))
;; quotations are treated as constants.
(binary-entry access)
diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm
index 27fb4ce8e..28be51fdd 100644
--- a/v7/src/compiler/fggen/fggen.scm
+++ b/v7/src/compiler/fggen/fggen.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: fggen.scm,v 4.35 2001/12/23 17:20:57 cph Exp $
+$Id: fggen.scm,v 4.36 2002/02/08 03:08:11 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -952,22 +952,28 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
(else
(generate/constant block continuation
context expression))))))
-
(let-syntax
((dispatch-entry
- (non-hygienic-macro-transformer
- (lambda (type handler)
- `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type) ,handler))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(VECTOR-SET! DISPATCH-VECTOR
+ ,(microcode-type (cadr form))
+ ,(close-syntax (caddr form) environment)))))
(dispatch-entries
- (non-hygienic-macro-transformer
- (lambda (types handler)
- `(BEGIN ,@(map (lambda (type)
- `(DISPATCH-ENTRY ,type ,handler))
- types)))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((handler (close-syntax (caddr form) environment)))
+ `(BEGIN
+ ,@(map (lambda (type)
+ `(DISPATCH-ENTRY ,type ,handler))
+ (cadr form)))))))
(standard-entry
- (non-hygienic-macro-transformer
- (lambda (name)
- `(DISPATCH-ENTRY ,name ,(symbol-append 'GENERATE/ name))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DISPATCH-ENTRY ,name
+ ,(close-syntax (symbol-append 'GENERATE/ name)
+ environment)))))))
(standard-entry access)
(standard-entry assignment)
(standard-entry conditional)
diff --git a/v7/src/compiler/machines/C/compiler.pkg b/v7/src/compiler/machines/C/compiler.pkg
index c01faf13d..800bf4d87 100644
--- a/v7/src/compiler/machines/C/compiler.pkg
+++ b/v7/src/compiler/machines/C/compiler.pkg
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.12 2001/12/20 03:04:02 cph Exp $
+$Id: compiler.pkg,v 1.13 2002/02/08 03:10:37 cph Exp $
-Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -89,7 +89,79 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
compiler:show-procedures?
compiler:show-subphases?
compiler:show-time-reports?
- compiler:use-multiclosures?))
+ compiler:use-multiclosures?)
+ (import ()
+ (scode/access-components access-components)
+ (scode/access-environment access-environment)
+ (scode/access-name access-name)
+ (scode/access? access?)
+ (scode/assignment-components assignment-components)
+ (scode/assignment-name assignment-name)
+ (scode/assignment-value assignment-value)
+ (scode/assignment? assignment?)
+ (scode/combination-components combination-components)
+ (scode/combination-operands combination-operands)
+ (scode/combination-operator combination-operator)
+ (scode/combination? combination?)
+ (scode/comment-components comment-components)
+ (scode/comment-expression comment-expression)
+ (scode/comment-text comment-text)
+ (scode/comment? comment?)
+ (scode/conditional-alternative conditional-alternative)
+ (scode/conditional-components conditional-components)
+ (scode/conditional-consequent conditional-consequent)
+ (scode/conditional-predicate conditional-predicate)
+ (scode/conditional? conditional?)
+ (scode/constant? scode-constant?)
+ (scode/declaration-components declaration-components)
+ (scode/declaration-expression declaration-expression)
+ (scode/declaration-text declaration-text)
+ (scode/declaration? declaration?)
+ (scode/definition-components definition-components)
+ (scode/definition-name definition-name)
+ (scode/definition-value definition-value)
+ (scode/definition? definition?)
+ (scode/delay-components delay-components)
+ (scode/delay-expression delay-expression)
+ (scode/delay? delay?)
+ (scode/disjunction-alternative disjunction-alternative)
+ (scode/disjunction-components disjunction-components)
+ (scode/disjunction-predicate disjunction-predicate)
+ (scode/disjunction? disjunction?)
+ (scode/lambda-components lambda-components)
+ (scode/lambda? lambda?)
+ (scode/make-access make-access)
+ (scode/make-assignment make-assignment)
+ (scode/make-combination make-combination)
+ (scode/make-comment make-comment)
+ (scode/make-conditional make-conditional)
+ (scode/make-declaration make-declaration)
+ (scode/make-definition make-definition)
+ (scode/make-delay make-delay)
+ (scode/make-disjunction make-disjunction)
+ (scode/make-lambda make-lambda)
+ (scode/make-open-block make-open-block)
+ (scode/make-quotation make-quotation)
+ (scode/make-sequence make-sequence)
+ (scode/make-the-environment make-the-environment)
+ (scode/make-unassigned? make-unassigned?)
+ (scode/make-variable make-variable)
+ (scode/open-block-components open-block-components)
+ (scode/open-block? open-block?)
+ (scode/primitive-procedure? primitive-procedure?)
+ (scode/procedure? procedure?)
+ (scode/quotation-expression quotation-expression)
+ (scode/quotation? quotation?)
+ (scode/sequence-actions sequence-actions)
+ (scode/sequence-components sequence-components)
+ (scode/sequence? sequence?)
+ (scode/symbol? symbol?)
+ (scode/the-environment? the-environment?)
+ (scode/unassigned?-name unassigned?-name)
+ (scode/unassigned?? unassigned??)
+ (scode/variable-components variable-components)
+ (scode/variable-name variable-name)
+ (scode/variable? variable?)))
(define-package (compiler reference-contexts)
(files "base/refctx")
diff --git a/v7/src/compiler/machines/alpha/compiler.pkg b/v7/src/compiler/machines/alpha/compiler.pkg
index d48aea70a..793c7b62f 100644
--- a/v7/src/compiler/machines/alpha/compiler.pkg
+++ b/v7/src/compiler/machines/alpha/compiler.pkg
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.15 2001/12/20 03:04:02 cph Exp $
+$Id: compiler.pkg,v 1.16 2002/02/08 03:10:57 cph Exp $
-Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -88,7 +88,79 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
compiler:show-procedures?
compiler:show-subphases?
compiler:show-time-reports?
- compiler:use-multiclosures?))
+ compiler:use-multiclosures?)
+ (import ()
+ (scode/access-components access-components)
+ (scode/access-environment access-environment)
+ (scode/access-name access-name)
+ (scode/access? access?)
+ (scode/assignment-components assignment-components)
+ (scode/assignment-name assignment-name)
+ (scode/assignment-value assignment-value)
+ (scode/assignment? assignment?)
+ (scode/combination-components combination-components)
+ (scode/combination-operands combination-operands)
+ (scode/combination-operator combination-operator)
+ (scode/combination? combination?)
+ (scode/comment-components comment-components)
+ (scode/comment-expression comment-expression)
+ (scode/comment-text comment-text)
+ (scode/comment? comment?)
+ (scode/conditional-alternative conditional-alternative)
+ (scode/conditional-components conditional-components)
+ (scode/conditional-consequent conditional-consequent)
+ (scode/conditional-predicate conditional-predicate)
+ (scode/conditional? conditional?)
+ (scode/constant? scode-constant?)
+ (scode/declaration-components declaration-components)
+ (scode/declaration-expression declaration-expression)
+ (scode/declaration-text declaration-text)
+ (scode/declaration? declaration?)
+ (scode/definition-components definition-components)
+ (scode/definition-name definition-name)
+ (scode/definition-value definition-value)
+ (scode/definition? definition?)
+ (scode/delay-components delay-components)
+ (scode/delay-expression delay-expression)
+ (scode/delay? delay?)
+ (scode/disjunction-alternative disjunction-alternative)
+ (scode/disjunction-components disjunction-components)
+ (scode/disjunction-predicate disjunction-predicate)
+ (scode/disjunction? disjunction?)
+ (scode/lambda-components lambda-components)
+ (scode/lambda? lambda?)
+ (scode/make-access make-access)
+ (scode/make-assignment make-assignment)
+ (scode/make-combination make-combination)
+ (scode/make-comment make-comment)
+ (scode/make-conditional make-conditional)
+ (scode/make-declaration make-declaration)
+ (scode/make-definition make-definition)
+ (scode/make-delay make-delay)
+ (scode/make-disjunction make-disjunction)
+ (scode/make-lambda make-lambda)
+ (scode/make-open-block make-open-block)
+ (scode/make-quotation make-quotation)
+ (scode/make-sequence make-sequence)
+ (scode/make-the-environment make-the-environment)
+ (scode/make-unassigned? make-unassigned?)
+ (scode/make-variable make-variable)
+ (scode/open-block-components open-block-components)
+ (scode/open-block? open-block?)
+ (scode/primitive-procedure? primitive-procedure?)
+ (scode/procedure? procedure?)
+ (scode/quotation-expression quotation-expression)
+ (scode/quotation? quotation?)
+ (scode/sequence-actions sequence-actions)
+ (scode/sequence-components sequence-components)
+ (scode/sequence? sequence?)
+ (scode/symbol? symbol?)
+ (scode/the-environment? the-environment?)
+ (scode/unassigned?-name unassigned?-name)
+ (scode/unassigned?? unassigned??)
+ (scode/variable-components variable-components)
+ (scode/variable-name variable-name)
+ (scode/variable? variable?)))
(define-package (compiler reference-contexts)
(files "base/refctx")
diff --git a/v7/src/compiler/machines/bobcat/compiler.pkg b/v7/src/compiler/machines/bobcat/compiler.pkg
index 9f3fb6a1a..797189611 100644
--- a/v7/src/compiler/machines/bobcat/compiler.pkg
+++ b/v7/src/compiler/machines/bobcat/compiler.pkg
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.52 2001/12/20 03:04:02 cph Exp $
+$Id: compiler.pkg,v 1.53 2002/02/08 03:11:18 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -89,7 +89,79 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
compiler:show-procedures?
compiler:show-subphases?
compiler:show-time-reports?
- compiler:use-multiclosures?))
+ compiler:use-multiclosures?)
+ (import ()
+ (scode/access-components access-components)
+ (scode/access-environment access-environment)
+ (scode/access-name access-name)
+ (scode/access? access?)
+ (scode/assignment-components assignment-components)
+ (scode/assignment-name assignment-name)
+ (scode/assignment-value assignment-value)
+ (scode/assignment? assignment?)
+ (scode/combination-components combination-components)
+ (scode/combination-operands combination-operands)
+ (scode/combination-operator combination-operator)
+ (scode/combination? combination?)
+ (scode/comment-components comment-components)
+ (scode/comment-expression comment-expression)
+ (scode/comment-text comment-text)
+ (scode/comment? comment?)
+ (scode/conditional-alternative conditional-alternative)
+ (scode/conditional-components conditional-components)
+ (scode/conditional-consequent conditional-consequent)
+ (scode/conditional-predicate conditional-predicate)
+ (scode/conditional? conditional?)
+ (scode/constant? scode-constant?)
+ (scode/declaration-components declaration-components)
+ (scode/declaration-expression declaration-expression)
+ (scode/declaration-text declaration-text)
+ (scode/declaration? declaration?)
+ (scode/definition-components definition-components)
+ (scode/definition-name definition-name)
+ (scode/definition-value definition-value)
+ (scode/definition? definition?)
+ (scode/delay-components delay-components)
+ (scode/delay-expression delay-expression)
+ (scode/delay? delay?)
+ (scode/disjunction-alternative disjunction-alternative)
+ (scode/disjunction-components disjunction-components)
+ (scode/disjunction-predicate disjunction-predicate)
+ (scode/disjunction? disjunction?)
+ (scode/lambda-components lambda-components)
+ (scode/lambda? lambda?)
+ (scode/make-access make-access)
+ (scode/make-assignment make-assignment)
+ (scode/make-combination make-combination)
+ (scode/make-comment make-comment)
+ (scode/make-conditional make-conditional)
+ (scode/make-declaration make-declaration)
+ (scode/make-definition make-definition)
+ (scode/make-delay make-delay)
+ (scode/make-disjunction make-disjunction)
+ (scode/make-lambda make-lambda)
+ (scode/make-open-block make-open-block)
+ (scode/make-quotation make-quotation)
+ (scode/make-sequence make-sequence)
+ (scode/make-the-environment make-the-environment)
+ (scode/make-unassigned? make-unassigned?)
+ (scode/make-variable make-variable)
+ (scode/open-block-components open-block-components)
+ (scode/open-block? open-block?)
+ (scode/primitive-procedure? primitive-procedure?)
+ (scode/procedure? procedure?)
+ (scode/quotation-expression quotation-expression)
+ (scode/quotation? quotation?)
+ (scode/sequence-actions sequence-actions)
+ (scode/sequence-components sequence-components)
+ (scode/sequence? sequence?)
+ (scode/symbol? symbol?)
+ (scode/the-environment? the-environment?)
+ (scode/unassigned?-name unassigned?-name)
+ (scode/unassigned?? unassigned??)
+ (scode/variable-components variable-components)
+ (scode/variable-name variable-name)
+ (scode/variable? variable?)))
(define-package (compiler reference-contexts)
(files "base/refctx")
diff --git a/v7/src/compiler/machines/i386/compiler.pkg b/v7/src/compiler/machines/i386/compiler.pkg
index 343d3bcdc..1d477d30e 100644
--- a/v7/src/compiler/machines/i386/compiler.pkg
+++ b/v7/src/compiler/machines/i386/compiler.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.28 2002/02/03 03:38:53 cph Exp $
+$Id: compiler.pkg,v 1.29 2002/02/08 03:09:41 cph Exp $
Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
@@ -93,7 +93,79 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
compiler:use-multiclosures?)
(import (runtime system-macros)
ucode-primitive
- ucode-type))
+ ucode-type)
+ (import ()
+ (scode/access-components access-components)
+ (scode/access-environment access-environment)
+ (scode/access-name access-name)
+ (scode/access? access?)
+ (scode/assignment-components assignment-components)
+ (scode/assignment-name assignment-name)
+ (scode/assignment-value assignment-value)
+ (scode/assignment? assignment?)
+ (scode/combination-components combination-components)
+ (scode/combination-operands combination-operands)
+ (scode/combination-operator combination-operator)
+ (scode/combination? combination?)
+ (scode/comment-components comment-components)
+ (scode/comment-expression comment-expression)
+ (scode/comment-text comment-text)
+ (scode/comment? comment?)
+ (scode/conditional-alternative conditional-alternative)
+ (scode/conditional-components conditional-components)
+ (scode/conditional-consequent conditional-consequent)
+ (scode/conditional-predicate conditional-predicate)
+ (scode/conditional? conditional?)
+ (scode/constant? scode-constant?)
+ (scode/declaration-components declaration-components)
+ (scode/declaration-expression declaration-expression)
+ (scode/declaration-text declaration-text)
+ (scode/declaration? declaration?)
+ (scode/definition-components definition-components)
+ (scode/definition-name definition-name)
+ (scode/definition-value definition-value)
+ (scode/definition? definition?)
+ (scode/delay-components delay-components)
+ (scode/delay-expression delay-expression)
+ (scode/delay? delay?)
+ (scode/disjunction-alternative disjunction-alternative)
+ (scode/disjunction-components disjunction-components)
+ (scode/disjunction-predicate disjunction-predicate)
+ (scode/disjunction? disjunction?)
+ (scode/lambda-components lambda-components)
+ (scode/lambda? lambda?)
+ (scode/make-access make-access)
+ (scode/make-assignment make-assignment)
+ (scode/make-combination make-combination)
+ (scode/make-comment make-comment)
+ (scode/make-conditional make-conditional)
+ (scode/make-declaration make-declaration)
+ (scode/make-definition make-definition)
+ (scode/make-delay make-delay)
+ (scode/make-disjunction make-disjunction)
+ (scode/make-lambda make-lambda)
+ (scode/make-open-block make-open-block)
+ (scode/make-quotation make-quotation)
+ (scode/make-sequence make-sequence)
+ (scode/make-the-environment make-the-environment)
+ (scode/make-unassigned? make-unassigned?)
+ (scode/make-variable make-variable)
+ (scode/open-block-components open-block-components)
+ (scode/open-block? open-block?)
+ (scode/primitive-procedure? primitive-procedure?)
+ (scode/procedure? procedure?)
+ (scode/quotation-expression quotation-expression)
+ (scode/quotation? quotation?)
+ (scode/sequence-actions sequence-actions)
+ (scode/sequence-components sequence-components)
+ (scode/sequence? sequence?)
+ (scode/symbol? symbol?)
+ (scode/the-environment? the-environment?)
+ (scode/unassigned?-name unassigned?-name)
+ (scode/unassigned?? unassigned??)
+ (scode/variable-components variable-components)
+ (scode/variable-name variable-name)
+ (scode/variable? variable?)))
(define-package (compiler reference-contexts)
(files "base/refctx")
diff --git a/v7/src/compiler/machines/mips/compiler.pkg b/v7/src/compiler/machines/mips/compiler.pkg
index 93760101c..9f060a458 100644
--- a/v7/src/compiler/machines/mips/compiler.pkg
+++ b/v7/src/compiler/machines/mips/compiler.pkg
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.22 2001/12/20 03:04:02 cph Exp $
+$Id: compiler.pkg,v 1.23 2002/02/08 03:11:37 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -89,7 +89,79 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
compiler:show-procedures?
compiler:show-subphases?
compiler:show-time-reports?
- compiler:use-multiclosures?))
+ compiler:use-multiclosures?)
+ (import ()
+ (scode/access-components access-components)
+ (scode/access-environment access-environment)
+ (scode/access-name access-name)
+ (scode/access? access?)
+ (scode/assignment-components assignment-components)
+ (scode/assignment-name assignment-name)
+ (scode/assignment-value assignment-value)
+ (scode/assignment? assignment?)
+ (scode/combination-components combination-components)
+ (scode/combination-operands combination-operands)
+ (scode/combination-operator combination-operator)
+ (scode/combination? combination?)
+ (scode/comment-components comment-components)
+ (scode/comment-expression comment-expression)
+ (scode/comment-text comment-text)
+ (scode/comment? comment?)
+ (scode/conditional-alternative conditional-alternative)
+ (scode/conditional-components conditional-components)
+ (scode/conditional-consequent conditional-consequent)
+ (scode/conditional-predicate conditional-predicate)
+ (scode/conditional? conditional?)
+ (scode/constant? scode-constant?)
+ (scode/declaration-components declaration-components)
+ (scode/declaration-expression declaration-expression)
+ (scode/declaration-text declaration-text)
+ (scode/declaration? declaration?)
+ (scode/definition-components definition-components)
+ (scode/definition-name definition-name)
+ (scode/definition-value definition-value)
+ (scode/definition? definition?)
+ (scode/delay-components delay-components)
+ (scode/delay-expression delay-expression)
+ (scode/delay? delay?)
+ (scode/disjunction-alternative disjunction-alternative)
+ (scode/disjunction-components disjunction-components)
+ (scode/disjunction-predicate disjunction-predicate)
+ (scode/disjunction? disjunction?)
+ (scode/lambda-components lambda-components)
+ (scode/lambda? lambda?)
+ (scode/make-access make-access)
+ (scode/make-assignment make-assignment)
+ (scode/make-combination make-combination)
+ (scode/make-comment make-comment)
+ (scode/make-conditional make-conditional)
+ (scode/make-declaration make-declaration)
+ (scode/make-definition make-definition)
+ (scode/make-delay make-delay)
+ (scode/make-disjunction make-disjunction)
+ (scode/make-lambda make-lambda)
+ (scode/make-open-block make-open-block)
+ (scode/make-quotation make-quotation)
+ (scode/make-sequence make-sequence)
+ (scode/make-the-environment make-the-environment)
+ (scode/make-unassigned? make-unassigned?)
+ (scode/make-variable make-variable)
+ (scode/open-block-components open-block-components)
+ (scode/open-block? open-block?)
+ (scode/primitive-procedure? primitive-procedure?)
+ (scode/procedure? procedure?)
+ (scode/quotation-expression quotation-expression)
+ (scode/quotation? quotation?)
+ (scode/sequence-actions sequence-actions)
+ (scode/sequence-components sequence-components)
+ (scode/sequence? sequence?)
+ (scode/symbol? symbol?)
+ (scode/the-environment? the-environment?)
+ (scode/unassigned?-name unassigned?-name)
+ (scode/unassigned?? unassigned??)
+ (scode/variable-components variable-components)
+ (scode/variable-name variable-name)
+ (scode/variable? variable?)))
(define-package (compiler reference-contexts)
(files "base/refctx")
diff --git a/v7/src/compiler/machines/spectrum/compiler.pkg b/v7/src/compiler/machines/spectrum/compiler.pkg
index 867f63346..5594407bc 100644
--- a/v7/src/compiler/machines/spectrum/compiler.pkg
+++ b/v7/src/compiler/machines/spectrum/compiler.pkg
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.52 2001/12/20 03:04:02 cph Exp $
+$Id: compiler.pkg,v 1.53 2002/02/08 03:12:45 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -89,7 +89,79 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
compiler:show-procedures?
compiler:show-subphases?
compiler:show-time-reports?
- compiler:use-multiclosures?))
+ compiler:use-multiclosures?)
+ (import ()
+ (scode/access-components access-components)
+ (scode/access-environment access-environment)
+ (scode/access-name access-name)
+ (scode/access? access?)
+ (scode/assignment-components assignment-components)
+ (scode/assignment-name assignment-name)
+ (scode/assignment-value assignment-value)
+ (scode/assignment? assignment?)
+ (scode/combination-components combination-components)
+ (scode/combination-operands combination-operands)
+ (scode/combination-operator combination-operator)
+ (scode/combination? combination?)
+ (scode/comment-components comment-components)
+ (scode/comment-expression comment-expression)
+ (scode/comment-text comment-text)
+ (scode/comment? comment?)
+ (scode/conditional-alternative conditional-alternative)
+ (scode/conditional-components conditional-components)
+ (scode/conditional-consequent conditional-consequent)
+ (scode/conditional-predicate conditional-predicate)
+ (scode/conditional? conditional?)
+ (scode/constant? scode-constant?)
+ (scode/declaration-components declaration-components)
+ (scode/declaration-expression declaration-expression)
+ (scode/declaration-text declaration-text)
+ (scode/declaration? declaration?)
+ (scode/definition-components definition-components)
+ (scode/definition-name definition-name)
+ (scode/definition-value definition-value)
+ (scode/definition? definition?)
+ (scode/delay-components delay-components)
+ (scode/delay-expression delay-expression)
+ (scode/delay? delay?)
+ (scode/disjunction-alternative disjunction-alternative)
+ (scode/disjunction-components disjunction-components)
+ (scode/disjunction-predicate disjunction-predicate)
+ (scode/disjunction? disjunction?)
+ (scode/lambda-components lambda-components)
+ (scode/lambda? lambda?)
+ (scode/make-access make-access)
+ (scode/make-assignment make-assignment)
+ (scode/make-combination make-combination)
+ (scode/make-comment make-comment)
+ (scode/make-conditional make-conditional)
+ (scode/make-declaration make-declaration)
+ (scode/make-definition make-definition)
+ (scode/make-delay make-delay)
+ (scode/make-disjunction make-disjunction)
+ (scode/make-lambda make-lambda)
+ (scode/make-open-block make-open-block)
+ (scode/make-quotation make-quotation)
+ (scode/make-sequence make-sequence)
+ (scode/make-the-environment make-the-environment)
+ (scode/make-unassigned? make-unassigned?)
+ (scode/make-variable make-variable)
+ (scode/open-block-components open-block-components)
+ (scode/open-block? open-block?)
+ (scode/primitive-procedure? primitive-procedure?)
+ (scode/procedure? procedure?)
+ (scode/quotation-expression quotation-expression)
+ (scode/quotation? quotation?)
+ (scode/sequence-actions sequence-actions)
+ (scode/sequence-components sequence-components)
+ (scode/sequence? sequence?)
+ (scode/symbol? symbol?)
+ (scode/the-environment? the-environment?)
+ (scode/unassigned?-name unassigned?-name)
+ (scode/unassigned?? unassigned??)
+ (scode/variable-components variable-components)
+ (scode/variable-name variable-name)
+ (scode/variable? variable?)))
(define-package (compiler reference-contexts)
(files "base/refctx")
diff --git a/v7/src/compiler/machines/vax/compiler.pkg b/v7/src/compiler/machines/vax/compiler.pkg
index 4c8a32069..37168e538 100644
--- a/v7/src/compiler/machines/vax/compiler.pkg
+++ b/v7/src/compiler/machines/vax/compiler.pkg
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.24 2001/12/20 03:04:02 cph Exp $
+$Id: compiler.pkg,v 1.25 2002/02/08 03:13:05 cph Exp $
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -89,7 +89,79 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
compiler:show-procedures?
compiler:show-subphases?
compiler:show-time-reports?
- compiler:use-multiclosures?))
+ compiler:use-multiclosures?)
+ (import ()
+ (scode/access-components access-components)
+ (scode/access-environment access-environment)
+ (scode/access-name access-name)
+ (scode/access? access?)
+ (scode/assignment-components assignment-components)
+ (scode/assignment-name assignment-name)
+ (scode/assignment-value assignment-value)
+ (scode/assignment? assignment?)
+ (scode/combination-components combination-components)
+ (scode/combination-operands combination-operands)
+ (scode/combination-operator combination-operator)
+ (scode/combination? combination?)
+ (scode/comment-components comment-components)
+ (scode/comment-expression comment-expression)
+ (scode/comment-text comment-text)
+ (scode/comment? comment?)
+ (scode/conditional-alternative conditional-alternative)
+ (scode/conditional-components conditional-components)
+ (scode/conditional-consequent conditional-consequent)
+ (scode/conditional-predicate conditional-predicate)
+ (scode/conditional? conditional?)
+ (scode/constant? scode-constant?)
+ (scode/declaration-components declaration-components)
+ (scode/declaration-expression declaration-expression)
+ (scode/declaration-text declaration-text)
+ (scode/declaration? declaration?)
+ (scode/definition-components definition-components)
+ (scode/definition-name definition-name)
+ (scode/definition-value definition-value)
+ (scode/definition? definition?)
+ (scode/delay-components delay-components)
+ (scode/delay-expression delay-expression)
+ (scode/delay? delay?)
+ (scode/disjunction-alternative disjunction-alternative)
+ (scode/disjunction-components disjunction-components)
+ (scode/disjunction-predicate disjunction-predicate)
+ (scode/disjunction? disjunction?)
+ (scode/lambda-components lambda-components)
+ (scode/lambda? lambda?)
+ (scode/make-access make-access)
+ (scode/make-assignment make-assignment)
+ (scode/make-combination make-combination)
+ (scode/make-comment make-comment)
+ (scode/make-conditional make-conditional)
+ (scode/make-declaration make-declaration)
+ (scode/make-definition make-definition)
+ (scode/make-delay make-delay)
+ (scode/make-disjunction make-disjunction)
+ (scode/make-lambda make-lambda)
+ (scode/make-open-block make-open-block)
+ (scode/make-quotation make-quotation)
+ (scode/make-sequence make-sequence)
+ (scode/make-the-environment make-the-environment)
+ (scode/make-unassigned? make-unassigned?)
+ (scode/make-variable make-variable)
+ (scode/open-block-components open-block-components)
+ (scode/open-block? open-block?)
+ (scode/primitive-procedure? primitive-procedure?)
+ (scode/procedure? procedure?)
+ (scode/quotation-expression quotation-expression)
+ (scode/quotation? quotation?)
+ (scode/sequence-actions sequence-actions)
+ (scode/sequence-components sequence-components)
+ (scode/sequence? sequence?)
+ (scode/symbol? symbol?)
+ (scode/the-environment? the-environment?)
+ (scode/unassigned?-name unassigned?-name)
+ (scode/unassigned?? unassigned??)
+ (scode/variable-components variable-components)
+ (scode/variable-name variable-name)
+ (scode/variable? variable?)))
(define-package (compiler reference-contexts)
(files "base/refctx")
diff --git a/v7/src/compiler/rtlbase/rtlcfg.scm b/v7/src/compiler/rtlbase/rtlcfg.scm
index ca79788bd..d9c64790c 100644
--- a/v7/src/compiler/rtlbase/rtlcfg.scm
+++ b/v7/src/compiler/rtlbase/rtlcfg.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: rtlcfg.scm,v 4.9 1999/01/02 06:06:43 cph Exp $
+$Id: rtlcfg.scm,v 4.10 2002/02/08 03:08:36 cph Exp $
-Copyright (c) 1987, 1988, 1989, 1999 Massachusetts Institute of Technology
+Copyright (c) 1987-1989, 1999, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -56,6 +56,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
(let ((bblock-describe
(lambda (bblock)
(descriptor-list bblock
+ bblock
instructions
live-at-entry
live-at-exit
@@ -68,6 +69,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
(append! ((vector-tag-description snode-tag) sblock)
(bblock-describe sblock)
(descriptor-list sblock
+ sblock
continuation))))
(set-vector-tag-description!
pblock-tag
@@ -75,6 +77,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
(append! ((vector-tag-description pnode-tag) pblock)
(bblock-describe pblock)
(descriptor-list pblock
+ pblock
consequent-lap-generator
alternative-lap-generator)))))
diff --git a/v7/src/compiler/rtlbase/rtlreg.scm b/v7/src/compiler/rtlbase/rtlreg.scm
index 850383254..1e8b97ae7 100644
--- a/v7/src/compiler/rtlbase/rtlreg.scm
+++ b/v7/src/compiler/rtlbase/rtlreg.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: rtlreg.scm,v 4.8 2001/12/23 17:20:58 cph Exp $
+$Id: rtlreg.scm,v 4.9 2002/02/08 03:08:47 cph Exp $
-Copyright (c) 1987, 1988, 1990, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -67,15 +67,20 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
(let-syntax
((define-register-references
- (non-hygienic-macro-transformer
- (lambda (slot)
- (let ((name (symbol-append 'REGISTER- slot)))
- (let ((vector `(,(symbol-append 'RGRAPH- name) *CURRENT-RGRAPH*)))
- `(BEGIN (DEFINE-INTEGRABLE (,name REGISTER)
- (VECTOR-REF ,vector REGISTER))
- (DEFINE-INTEGRABLE
- (,(symbol-append 'SET- name '!) REGISTER VALUE)
- (VECTOR-SET! ,vector REGISTER VALUE)))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((slot (cadr form)))
+ (let ((name (symbol-append 'REGISTER- slot)))
+ (let ((vector
+ `(,(close-syntax (symbol-append 'RGRAPH- name)
+ environment)
+ *CURRENT-RGRAPH*)))
+ `(BEGIN
+ (DEFINE-INTEGRABLE (,name REGISTER)
+ (VECTOR-REF ,vector REGISTER))
+ (DEFINE-INTEGRABLE
+ (,(symbol-append 'SET- name '!) REGISTER VALUE)
+ (VECTOR-SET! ,vector REGISTER VALUE))))))))))
(define-register-references bblock)
(define-register-references n-refs)
(define-register-references n-deaths)
diff --git a/v7/src/compiler/rtlbase/valclass.scm b/v7/src/compiler/rtlbase/valclass.scm
index c70a017f3..05fe6398f 100644
--- a/v7/src/compiler/rtlbase/valclass.scm
+++ b/v7/src/compiler/rtlbase/valclass.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: valclass.scm,v 1.4 2001/12/23 17:20:58 cph Exp $
+$Id: valclass.scm,v 1.5 2002/02/08 03:08:55 cph Exp $
-Copyright (c) 1989, 1990, 1999 Massachusetts Institute of Technology
+Copyright (c) 1989, 1990, 1999, 2002 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -75,34 +75,37 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
(let-syntax
((define-value-class
- (non-hygienic-macro-transformer
- (lambda (name parent-name)
- (let* ((name->variable
- (lambda (name) (symbol-append 'VALUE-CLASS= name)))
- (variable (name->variable name)))
- `(BEGIN
- (DEFINE ,variable
- (MAKE-VALUE-CLASS ',name
- ,(if parent-name
- (name->variable parent-name)
- `#F)))
- (DEFINE (,(symbol-append variable '?) CLASS)
- (VALUE-CLASS/ANCESTOR-OR-SELF? CLASS ,variable))
- (DEFINE
- (,(symbol-append 'REGISTER- variable '?) REGISTER)
- (VALUE-CLASS/ANCESTOR-OR-SELF? (REGISTER-VALUE-CLASS REGISTER)
- ,variable))))))))
-
-(define-value-class value #f)
-(define-value-class float value)
-(define-value-class word value)
-(define-value-class object word)
-(define-value-class unboxed word)
-(define-value-class address unboxed)
-(define-value-class immediate unboxed)
-(define-value-class ascii immediate)
-(define-value-class datum immediate)
-(define-value-class fixnum immediate)
-(define-value-class type immediate)
-
-)
\ No newline at end of file
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (parent-name (caddr form)))
+ (let* ((name->variable
+ (lambda (name)
+ (symbol-append 'VALUE-CLASS= name)))
+ (variable (name->variable name))
+ (var-ref (close-syntax variable environment)))
+ `(BEGIN
+ (DEFINE ,variable
+ (MAKE-VALUE-CLASS
+ ',name
+ ,(if parent-name
+ (close-syntax (name->variable parent-name)
+ environment)
+ `#F)))
+ (DEFINE (,(symbol-append variable '?) CLASS)
+ (VALUE-CLASS/ANCESTOR-OR-SELF? CLASS ,variable))
+ (DEFINE (,(symbol-append 'REGISTER- variable '?) REGISTER)
+ (VALUE-CLASS/ANCESTOR-OR-SELF?
+ (REGISTER-VALUE-CLASS REGISTER)
+ ,variable)))))))))
+ (define-value-class value #f)
+ (define-value-class float value)
+ (define-value-class word value)
+ (define-value-class object word)
+ (define-value-class unboxed word)
+ (define-value-class address unboxed)
+ (define-value-class immediate unboxed)
+ (define-value-class ascii immediate)
+ (define-value-class datum immediate)
+ (define-value-class fixnum immediate)
+ (define-value-class type immediate))
\ No newline at end of file
--
2.25.1