From: Chris Hanson Date: Fri, 8 Feb 2002 03:13:05 +0000 (+0000) Subject: Eliminate non-hygienic macros. X-Git-Tag: 20090517-FFI~2267 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ea3b462e8e1a3af8933304a72a3a565cc7900a22;p=mit-scheme.git Eliminate non-hygienic macros. --- 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