#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.58 1987/05/21 14:55:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.59 1987/07/08 21:52:32 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define assembler-syntax-table
(make-syntax-table compiler-syntax-table))
+(define early-syntax-table
+ (make-syntax-table compiler-syntax-table))
+
(syntax-table-define compiler-syntax-table 'PACKAGE
(in-package system-global-environment
(declare (usual-integrations))
(define enable-integration-declarations
true)
+(define enable-expansion-declarations
+ true)
+
(let ()
(define (parse-define-syntax pattern body if-variable if-lambda)
(syntax-table-define lap-generator-syntax-table 'DEFINE-RULE
(macro (type pattern . body)
(parse-rule pattern body
- (lambda (pattern names transformer qualifier actions)
+ (lambda (pattern variables qualifier actions)
`(,(case type
((STATEMENT) 'ADD-STATEMENT-RULE!)
((PREDICATE) 'ADD-STATEMENT-RULE!)
(else (error "Unknown rule type" type)))
',pattern
- ,(rule-result-expression names transformer qualifier
- `(BEGIN ,@actions)))))))
\ No newline at end of file
+ ,(rule-result-expression variables qualifier
+ `(BEGIN ,@actions)))))))
+\f
+;;;; Lap instruction sequences.
+
+;; The effect of unquote and unquote-splicing is the same since
+;; syntax-instruction actually returns a bit-level instruction sequence.
+;; Kept separate for clarity and because it does not have to be like that.
+
+(syntax-table-define compiler-syntax-table 'LAP
+ (macro some-instructions
+ (define (handle current remaining)
+ (let ((processed
+ (cond ((eq? (car current) 'UNQUOTE)
+ (cadr current))
+ ((eq? (car current) 'UNQUOTE-SPLICING)
+ (cadr current))
+ (else `(INST ,current)))))
+ (if (null? remaining)
+ processed
+ `(APPEND-INSTRUCTION-SEQUENCES!
+ ,processed
+ ,(handle (car remaining) (cdr remaining))))))
+ (if (null? some-instructions)
+ `EMPTY-INSTRUCTION-SEQUENCE
+ (handle (car some-instructions) (cdr some-instructions)))))
+
+(syntax-table-define compiler-syntax-table 'INST
+ (macro (the-instruction)
+ `(LAP:SYNTAX-INSTRUCTION
+ ,(list 'QUASIQUOTE the-instruction))))
+
+;; This is a NOP for now.
+
+(syntax-table-define compiler-syntax-table 'INST-EA
+ (macro (ea)
+ (list 'QUASIQUOTE ea)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmlook.scm,v 1.4 1987/05/07 00:09:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmlook.scm,v 1.5 1987/07/08 21:53:09 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define pattern-lookup)
(define pattern-variables)
(define make-pattern-variable)
+(define pattern-variable?)
+(define pattern-variable-name)
+
(let ((pattern-variable-tag (make-named-tag "Pattern Variable")))
;;; PATTERN-LOOKUP returns either false or a pair whose car is the
(named-lambda (make-pattern-variable name)
(cons pattern-variable-tag name)))
+(set! pattern-variable?
+ (named-lambda (pattern-variable? obj)
+ (and (pair? obj) (eq? (car obj) pattern-variable-tag))))
+
+(set! pattern-variable-name
+ (named-lambda (pattern-variable-name var)
+ (cdr var)))
+
)
;;; ALL-TRUE? is used to determine if splicing variables with
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmpars.scm,v 1.1.1.1 1987/06/10 21:22:36 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmpars.scm,v 1.2 1987/07/08 21:53:25 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(caddr var)))))))))))
;; End of PARSE-RULE environment.
-)
)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.89 1987/06/24 04:51:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.90 1987/07/08 21:54:59 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
'FLUID-LET)
(else prefix)))
"-"
- (write-to-string (generate-label-number)))))
+ (number->string (generate-label-number)))))
(define *current-label-number*)
(define-scode-operator make-combination)
(define-scode-operator make-comment)
(define-scode-operator make-conditional)
+ (define-scode-operator make-declaration)
(define-scode-operator make-definition)
+ (define-scode-operator make-disjunction)
(define-scode-operator make-lambda)
(define-scode-operator make-quotation)
(define-scode-operator make-sequence)
+ (define-scode-operator make-the-environment)
(define-scode-operator make-variable)
+ (define-scode-operator make-unassigned-object)
(define-scode-operator open-block-components)
(define-scode-operator open-block?)
(define-scode-operator primitive-procedure?)
(define-scode-operator unbound?-name)
(define-scode-operator variable-name)
(define-scode-operator variable?))
+\f
+;;; Scode constants
+
+(define scode/constant?
+ (access scode-constant? system-global-environment))
(define scode/constant?
(access scode-constant? system-global-environment))
+
+(define-integrable (scode/constant-value const)
+ const)
+
+(define-integrable (scode/make-constant const)
+ const)
+
+;;; Abolute variables and combinations
+
+(define (scode/make-absolute-reference variable-name)
+ (scode/make-access '() variable-name))
+
+(define (scode/absolute-reference? obj)
+ (and (scode/access? obj)
+ (scode/access-components
+ obj
+ (lambda (environment name)
+ (null? environment)))))
+
+(define (scode/absolute-reference-name obj)
+ (scode/access-components obj (lambda (ignore name) name)))
+
+(define (scode/make-absolute-combination name operands)
+ (scode/make-combination (scode/make-absolute-reference name) operands))
+
+(define (scode/absolute-combination? obj)
+ (and (scode/combination? obj)
+ (scode/combination-components
+ obj
+ (lambda (op ops)
+ (scode/absolute-reference? obj)))))
+
+(define (scode/absolute-combination-components obj receiver)
+ (scode/combination-components
+ obj
+ (lambda (op ops)
+ (receiver (scode/absolute-reference-name op) ops))))
\f
(define (scode/error-combination-components combination receiver)
(scode/combination-components combination
(receiver (car operands)
(let ((irritant (cadr operands)))
(cond ((scode/access? irritant) '())
- ((scode/combination? irritant)
- (scode/combination-components irritant
- (lambda (operator operands)
- (if (and (scode/access? operator)
- (scode/access-components operator
- (lambda (environment name)
- (and (null? environment)
- (eq? name 'LIST)))))
+ ((scode/absolute-combination? irritant)
+ (scode/absolute-combination-components irritant
+ (lambda (name operands)
+ (if (eq? name 'LIST)
operands
(list irritant)))))
(else (list irritant))))))))
+(define (scode/make-error-combination message operand)
+ (scode/make-absolute-combination
+ 'ERROR-PROCEDURE
+ (list message operand (scode/make-the-environment))))
+
(define (scode/procedure-type-code *lambda)
(cond ((primitive-type? type-code:lambda *lambda)
type-code:procedure)
\f
;;;; Type Codes
-(define type-code:lambda
- (microcode-type 'LAMBDA))
-
-(define type-code:extended-lambda
- (microcode-type 'EXTENDED-LAMBDA))
-
-(define type-code:procedure
- (microcode-type 'PROCEDURE))
-
-(define type-code:extended-procedure
- (microcode-type 'EXTENDED-PROCEDURE))
-
-(define type-code:cell
- (microcode-type 'CELL))
-
-(define type-code:compiled-expression
- (microcode-type 'COMPILED-EXPRESSION))
-
-(define type-code:compiler-link
- (microcode-type 'COMPILER-LINK))
-
-(define type-code:compiled-procedure
- (microcode-type 'COMPILED-PROCEDURE))
-
-(define type-code:environment
- (microcode-type 'ENVIRONMENT))
-
-(define type-code:stack-environment
- (microcode-type 'STACK-ENVIRONMENT))
-
-(define type-code:return-address
- (microcode-type 'COMPILER-RETURN-ADDRESS))
-
-(define type-code:unassigned
- (microcode-type 'UNASSIGNED))
+(let-syntax ((define-type-code
+ (macro (var-name type-name)
+ `(define-integrable ,var-name ',(microcode-type type-name)))))
+
+(define-type-code type-code:lambda LAMBDA)
+(define-type-code type-code:extended-lambda EXTENDED-LAMBDA)
+(define-type-code type-code:procedure PROCEDURE)
+(define-type-code type-code:extended-procedure EXTENDED-PROCEDURE)
+(define-type-code type-code:cell CELL)
+(define-type-code type-code:compiled-expression COMPILED-EXPRESSION)
+(define-type-code type-code:compiler-link COMPILER-LINK)
+(define-type-code type-code:compiled-procedure COMPILED-PROCEDURE)
+(define-type-code type-code:environment ENVIRONMENT)
+(define-type-code type-code:stack-environment STACK-ENVIRONMENT)
+(define-type-code type-code:return-address COMPILER-RETURN-ADDRESS)
+(define-type-code type-code:unassigned UNASSIGNED)
+)
\f
;;; Disgusting hack to replace microcode implementation.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.15 1987/07/02 20:54:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.16 1987/07/08 21:54:41 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(pathname->absolute-pathname (->pathname dependency)))
dependencies))))))
+(define (file-dependency/expansion/join filenames expansions)
+ (for-each (lambda (filename)
+ (file-dependency/expansion/make filename expansions))
+ filenames))
+
+(define (file-dependency/expansion/make filename expansions)
+ (if enable-expansion-declarations
+ (sf/add-file-declarations! filename `((EXPAND-OPERATOR ,@expansions)))))
+
(define (filename/append directory . names)
(map (lambda (name)
(string-append directory "/" name))
(sf/set-file-syntax-table! filename dependency))
filenames))
\f
+;;;; Integration and expansion dependencies
+
(define filenames/dependency-chain/base
(filename/append "base"
"object" "cfg1" "cfg2" "cfg3" "ctypes" "dtype1" "dtype2"
(append filenames/dependency-chain/base
filenames/dependency-chain/rcse)))
+(file-dependency/integration/join
+ (filename/append "back-end" "laptop")
+ (filename/append "back-end" "symtab" "block"))
+
(file-dependency/integration/join filenames/dependency-group/base
filenames/dependency-chain/base)
+\f
+;;;; Lap level integration and expansion dependencies
-(file-dependency/integration/join
- (filename/append "machines/bobcat" "instr2" "instr3")
- (filename/append "machines/bobcat" "instr1"))
+(define filenames/dependency-group/lap
+ (filename/append "machines/bobcat" "instr1" "instr2" "instr3"))
-(file-dependency/integration/join
- (filename/append "back-end" "laptop")
- (filename/append "back-end" "symtab" "block"))
+(define filenames/dependency-group/lap-syn1
+ (append (filename/append "back-end" "lapgn1" "lapgn2" "lapgn3" "regmap")
+ (filename/append "base" "linear")))
+
+(define filenames/dependency-group/lap-syn2
+ (filename/append "machines/bobcat" "lapgen"))
+
+(define filenames/dependency-group/lap-syn3
+ (filename/append "machines/bobcat" "rules1" "rules2" "rules3" "rules4"))
+
+(define filenames/dependency-group/lap-syn4
+ (append filenames/dependency-group/lap-syn2 filenames/dependency-group/lap-syn3))
+
+(file-dependency/integration/join filenames/dependency-group/lap-syn3
+ filenames/dependency-group/lap-syn2)
+
+(file-dependency/integration/join filenames/dependency-group/lap-syn4
+ (append
+ (filename/append "machines/bobcat" "machin")
+ (filename/append "base" "utils")))
+
+(file-dependency/integration/join (append filenames/dependency-group/lap-syn1
+ filenames/dependency-group/lap-syn4)
+ (filename/append "back-end" "insseq"))
+
+(file-dependency/integration/join (append filenames/dependency-group/lap
+ filenames/dependency-group/lap-syn4)
+ (filename/append "machines/bobcat" "insutl"))
\f
+(file-dependency/expansion/join filenames/dependency-group/lap-syn4
+ '((LAP:SYNTAX-INSTRUCTION
+ (ACCESS LAP:SYNTAX-INSTRUCTION-EXPANDER
+ LAP-SYNTAX-PACKAGE
+ COMPILER-PACKAGE))
+ (INSTRUCTION->INSTRUCTION-SEQUENCE
+ (ACCESS INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER
+ LAP-SYNTAX-PACKAGE
+ COMPILER-PACKAGE))
+ (SYNTAX-EVALUATION
+ (ACCESS SYNTAX-EVALUATION-EXPANDER
+ LAP-SYNTAX-PACKAGE
+ COMPILER-PACKAGE))
+ (CONS-SYNTAX
+ (ACCESS CONS-SYNTAX-EXPANDER
+ LAP-SYNTAX-PACKAGE
+ COMPILER-PACKAGE))
+ (OPTIMIZE-GROUP-EARLY
+ (ACCESS OPTIMIZE-GROUP-EXPANDER
+ LAP-SYNTAX-PACKAGE
+ COMPILER-PACKAGE))
+ (EA-KEYWORD-EARLY
+ (ACCESS EA-KEYWORD-EXPANDER
+ LAP-SYNTAX-PACKAGE
+ COMPILER-PACKAGE))
+ (EA-MODE-EARLY
+ (ACCESS EA-MODE-EXPANDER
+ LAP-SYNTAX-PACKAGE
+ COMPILER-PACKAGE))
+ (EA-REGISTER-EARLY
+ (ACCESS EA-REGISTER-EXPANDER
+ LAP-SYNTAX-PACKAGE
+ COMPILER-PACKAGE))
+ (EA-EXTENSION-EARLY
+ (ACCESS EA-EXTENSION-EXPANDER
+ LAP-SYNTAX-PACKAGE
+ COMPILER-PACKAGE))
+ (EA-CATEGORIES-EARLY
+ (ACCESS EA-CATEGORIES-EXPANDER
+ LAP-SYNTAX-PACKAGE
+ COMPILER-PACKAGE))))
+\f
+;;;; Syntax dependencies
+
(file-dependency/syntax/join
(append (filename/append "base"
"bblock" "cfg1" "cfg2" "cfg3" "ctypes" "dfg" "dtype1"
- "dtype2" "dtype3" "emodel" "linear" "object" "queue"
- "regset" "rtlcfg" "rtlcon" "rtlexp" "rtlreg" "rtlty1"
- "rtlty2" "rtypes" "sets" "toplv1" "toplv2" "toplv3"
- "utils")
+ "dtype2" "dtype3" "emodel" "linear" "object" "pmerly"
+ "queue" "regset" "rtlcfg" "rtlcon" "rtlexp" "rtlreg"
+ "rtlty1" "rtlty2" "rtypes" "sets" "toplv1" "toplv2"
+ "toplv3" "utils")
(filename/append "alpha" "declar" "dflow1" "dflow2" "dflow3" "dflow4"
"dflow5" "dflow6" "fggen1" "fggen2")
(filename/append "front-end"
"rcsesa" "rdeath" "rdebug" "rgcomb" "rgpcom" "rgpred"
"rgproc" "rgrval" "rgstmt" "rlife" "rtlgen")
(filename/append "back-end"
- "asmmac" "block" "lapgn1" "lapgn2" "lapgn3" "laptop"
- "regmap" "symtab")
+ "asmmac" "block" "insseq" "lapgn1" "lapgn2" "lapgn3"
+ "laptop" "regmap" "symtab" "syntax")
(filename/append "machines/bobcat" "insmac" "machin"))
compiler-syntax-table)
(file-dependency/syntax/join
- (append (filename/append "machines/bobcat"
- "lapgen" "rules1" "rules2" "rules3" "rules4")
- (filename/append "machines/spectrum" "lapgen"))
+ (append (filename/append "machines/spectrum" "lapgen")
+ filenames/dependency-group/lap-syn4)
lap-generator-syntax-table)
(file-dependency/syntax/join
- (append (filename/append "machines/bobcat" "instr1" "instr2" "instr3")
+ (append (filename/append "machines/bobcat" "insutl" "instr1" "instr2" "instr3")
(filename/append "machines/spectrum" "instrs"))
assembler-syntax-table)
\ No newline at end of file
projects / mit-scheme.git / commitdiff