#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/insseq.scm,v 1.1 1987/06/25 10:48:10 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/insseq.scm,v 1.2 1987/07/01 20:48:04 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define-integrable empty-lap-instructions '())
+(define lap:syntax-instruction)
-(define (lap-instructions->directives insts)
- (car insts))
+(define (instruction-sequence->directives insts)
+ (if (null? insts)
+ '()
+ (car insts)))
-(define (->instruction-sequence bits)
- (if (null? bits)
- empty-lap-instructions
- (cons bits (last-pair bits))))
+;; instruction->instruction-sequence is expanded.
-(define (->lap-instructions pattern)
- (->instruction-sequence ((access syntax-instruction lap-syntax-package)
- pattern)))
+(declare (integrate empty-instruction-sequence)
+ (integrate-operator directive->instruction-sequence))
-(define (append-lap-instructions! directives directives*)
- (cond ((null? directives) directives*)
- ((null? directives*) directives)
+(define empty-instruction-sequence '())
+
+(define (directive->instruction-sequence directive)
+ (declare (integrate directive))
+ (let ((pair (cons directive '())))
+ (cons pair pair)))
+
+(define (instruction->instruction-sequence inst)
+ (cons inst (last-pair inst)))
+
+(define (copy-instruction-sequence seq)
+ (define (with-last-pair l receiver)
+ (if (null? (cdr l))
+ (receiver l l)
+ (with-last-pair (cdr l)
+ (lambda (rest last)
+ (receiver (cons (car l) rest)
+ last)))))
+
+ (if (null? seq)
+ '()
+ (with-last-pair (car seq) cons)))
+
+(define (append-instruction-sequences! seq1 seq2)
+ (cond ((null? seq1) seq2)
+ ((null? seq2) seq1)
(else
- (if (and (bit-string? (cadr directives))
- (bit-string? (caar directives*)))
- (let ((result (bit-string-append (caar directives*)
- (cadr directives))))
- (set-car! (cdr directives) result)
- (if (not (eq? (car directives*) (cdr directives*)))
- (begin (set-cdr! (cdr directives) (cdr (car directives*)))
- (set-cdr! directives (cdr directives*)))))
- (begin (set-cdr! (cdr directives) (car directives*))
- (set-cdr! directives (cdr directives*))))
- directives)))
\ No newline at end of file
+ (if (and (bit-string? (cadr seq1))
+ (bit-string? (caar seq2)))
+ (let ((result (bit-string-append (caar seq2)
+ (cadr seq1))))
+ (set-car! (cdr seq1) result)
+ (if (not (eq? (car seq2) (cdr seq2)))
+ (begin (set-cdr! (cdr seq1) (cdr (car seq2)))
+ (set-cdr! seq1 (cdr seq2)))))
+ (begin (set-cdr! (cdr seq1) (car seq2))
+ (set-cdr! seq1 (cdr seq2))))
+ seq1)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.1 1987/06/25 10:56:09 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.2 1987/07/01 20:47:29 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define ->lap-instructions-expander
+;;;; Early instruction assembly
+
+(define lap:syntax-instruction-expander
((access scode->scode-expander package/expansion package/scode-optimizer)
(lambda (operands if-expanded if-not-expanded)
- (define (wrap expression)
- (if-expanded
- (scode/make-combination
- (scode/make-variable '->INSTRUCTION-SEQUENCE)
- (list expression))))
-
- (define (kernel instruction rules)
+ (define (kernel opcode instruction rules)
(early-pattern-lookup
rules
instruction
+ early-transformers
+ (scode/make-constant opcode)
(lambda (mode result)
(cond ((false? mode)
- (error "->lap-instruction-expander: unknown instruction"
+ (error "lap:syntax-instruction-expander: unknown instruction"
instruction))
((eq? mode 'TOO-MANY)
(if-not-expanded))
- (else (wrap result))))
+ (else (if-expanded result))))
1))
(let ((instruction (scode/unquasiquote (car operands))))
(cond ((not (pair? instruction))
- (error "->lap-instruction-expander: bad instruction" instruction))
- ((eq? (car instruction) 'EVALUATE)
+ (error "lap:syntax-instruction-expander: bad instruction" instruction))
+ ((eq? (car instruction) 'UNQUOTE)
(if-not-expanded))
((memq (car instruction)
'(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL))
- (wrap (scode/make-absolute-combination 'LIST operands)))
+ (if-expanded
+ (scode/make-combination
+ (scode/make-variable 'DIRECTIVE->INSTRUCTION-SEQUENCE)
+ operands)))
(else
(let ((place (assq (car instruction) early-instructions)))
(if (null? place)
- (error "->lap-instruction-expander: unknown opcode"
+ (error "lap:syntax-instruction-expander: unknown opcode"
(car instruction))
- (kernel (cdr instruction) (cdr place))))))))))
+ (kernel (car instruction) (cdr instruction) (cdr place))))))))))
+\f
+;;;; Quasiquote unsyntaxing
(define (scode/unquasiquote exp)
(cond ((scode/combination? exp)
(mapcan (lambda (component)
(if (scode/constant? component)
(scode/constant-value component)
- (list (list 'EVALUATE-SPLICE component))))
+ (list (list 'UNQUOTE-SPLICING component))))
operands))
- (else (list 'EVALUATE exp))))
+ (else (list 'UNQUOTE exp))))
(cond ((eq? operator cons)
;; integrations
(kernel 'CONS))
((scode/absolute-reference? operator)
(kernel (scode/absolute-reference-name operator)))
- (else (list 'EVALUATE exp))))))
+ (else (list 'UNQUOTE exp))))))
((scode/constant? exp)
(scode/constant-value exp))
- (else (list 'EVALUATE exp))))
-
+ (else (list 'UNQUOTE exp))))
+\f
+;;;; Bit compression expanders
+
+;;; SYNTAX-EVALUATION and OPTIMIZE-GROUP expanders
+
+(define syntax-evaluation-expander
+ ((access scode->scode-expander package/expansion package/scode-optimizer)
+ (lambda (operands if-expanded if-not-expanded)
+ (if (and (scode/constant? (car operands))
+ (scode/variable? (cadr operands))
+ (not (lexical-unreferenceable?
+ (access lap-syntax-package compiler-package)
+ (scode/variable-name (cadr operands)))))
+ (if-expanded
+ (scode/make-constant
+ ((lexical-reference (access lap-syntax-package compiler-package)
+ (scode/variable-name (cadr operands)))
+ (scode/constant-value (car operands)))))
+ (if-not-expanded)))))
+
+;; This relies on the fact that scode/constant-value = identity-procedure.
+
+(define optimize-group-expander
+ ((access scode->scode-expander package/expansion package/scode-optimizer)
+ (lambda (operands if-expanded if-not-expanded)
+ (optimize-group-internal
+ operands
+ (lambda (result make-group?)
+ (if make-group?
+ (if-expanded
+ (scode/make-combination (scode/make-variable 'OPTIMIZE-GROUP)
+ result))
+ (if-expanded
+ (scode/make-constant result))))))))
+\f
+;;;; CONS-SYNTAX expander
+
+(define (is-operator? expr name primitive)
+ (or (and primitive
+ (scode/constant? expr)
+ (eq? (scode/constant-value expr) primitive))
+ (and (scode/variable? expr)
+ (eq? (scode/variable-name expr) name))
+ (and (scode/absolute-reference? expr)
+ (eq? (scode/absolute-reference-name expr) name))))
+
+(define cons-syntax-expander
+ ((access scode->scode-expander package/expansion package/scode-optimizer)
+ (lambda (operands if-expanded if-not-expanded)
+ (define (default)
+ (cond ((not (scode/constant? (cadr operands)))
+ (if-not-expanded))
+ ((not (null? (scode/constant-value (cadr operands))))
+ (error "cons-syntax-expander: bad tail" (cadr operands)))
+ (else
+ (if-expanded
+ (scode/make-absolute-combination 'CONS
+ operands)))))
+
+ (if (and (scode/constant? (car operands))
+ (bit-string? (scode/constant-value (car operands)))
+ (scode/combination? (cadr operands)))
+ (scode/combination-components
+ (cadr operands)
+ (lambda (operator inner-operands)
+ (if (and (or (is-operator? operator 'CONS-SYNTAX false)
+ (is-operator? operator 'CONS cons))
+ (scode/constant? (car inner-operands))
+ (bit-string? (scode/constant-value (car inner-operands))))
+ (if-expanded
+ (scode/make-combination
+ (if (scode/constant? (cadr inner-operands))
+ (scode/make-absolute-reference 'CONS)
+ operator)
+ (cons (bit-string-append
+ (scode/constant-value (car inner-operands))
+ (scode/constant-value (car operands)))
+ (cdr inner-operands))))
+ (default))))
+ (default)))))
+\f
+;;;; INSTRUCTION->INSTRUCTION-SEQUENCE expander
+
+(define instruction->instruction-sequence-expander
+ (let ()
+ (define (parse expression receiver)
+ (if (not (scode/combination? expression))
+ (receiver false false false)
+ (scode/combination-components
+ expression
+ (lambda (operator operands)
+ (cond ((and (not (is-operator? operator 'CONS cons))
+ (not (is-operator? operator 'CONS-SYNTAX false)))
+ (receiver false false false))
+ ((scode/constant? (cadr operands))
+ (if (not (null? (scode/constant-value (cadr operands))))
+ (error "inst->inst-seq-expander: bad CONS-SYNTAX tail"
+ (scode/constant-value (cadr operands)))
+ (let ((name
+ (generate-uninterned-symbol
+ 'INSTRUCTION-TAIL-)))
+ (receiver true
+ (cons name expression)
+ (scode/make-variable name)))))
+ (else
+ (parse (cadr operands)
+ (lambda (mode info rest)
+ (if (not mode)
+ (receiver false false false)
+ (receiver true info
+ (scode/make-combination
+ operator
+ (list (car operands)
+ rest))))))))))))
+
+ ((access scode->scode-expander package/expansion package/scode-optimizer)
+ (lambda (operands if-expanded if-not-expanded)
+ (if (not (scode/combination? (car operands)))
+ (if-not-expanded)
+ (parse (car operands)
+ (lambda (mode binding rest)
+ (if (not mode)
+ (if-not-expanded)
+ (if-expanded
+ (scode/make-let
+ (list (car binding))
+ (list (cdr binding))
+ (scode/make-absolute-combination
+ 'CONS
+ (list rest
+ (scode/make-variable
+ (car binding))))))))))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmerly.scm,v 1.1 1987/06/25 10:51:09 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmerly.scm,v 1.2 1987/07/01 20:51:29 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define early-parse-rule)
(define early-pattern-lookup)
-(define define-transformer)
+(define early-make-rule)
(define make-database-transformer)
(define make-symbol-transformer)
(define make-bit-mask-transformer)
\f
;;;; Database construction
-(define-export (early-parse-rule pattern expression)
- (extract-variables pattern
- (lambda (pattern variables)
- `(,pattern ,variables ,expression))))
+(define-export (early-make-rule pattern variables body)
+ (list pattern variables body))
+
+(define-export (early-parse-rule pattern receiver)
+ (extract-variables pattern receiver))
(define (extract-variables pattern receiver)
(cond ((not (pair? pattern))
(receiver pattern '()))
((eq? (car pattern) '@)
- (error "unify-parse-rule: ?@ is not an implemented pattern"
+ (error "early-parse-rule: ?@ is not an implemented pattern"
pattern))
((eq? (car pattern) '?)
(receiver (make-pattern-variable (cadr pattern))
(merge-variables-lists (cdr x)
(delq! entry y)))
|#
- (error "unify-parse-rule: repeated variables not supported"
+ (error "early-parse-rule: repeated variables not supported"
(list (caar x) entry))
(cons (car x)
(merge-variables-lists (cdr x)
\f
;;;; Early rule processing and code compilation
-(define *rule-limit* '())
-
-(define-export (early-pattern-lookup rules unparsed #!optional receiver limit)
+(define-export (early-pattern-lookup
+ rules instance #!optional transformers unparsed receiver limit)
(if (unassigned? limit) (set! limit *rule-limit*))
- (if (unassigned? receiver)
+ (if (or (unassigned? receiver) (null? receiver))
(set! receiver
(lambda (result code)
(cond ((false? result)
(error "early-pattern-lookup: No pattern matches"
- unparsed))
+ instance))
((eq? result 'TOO-MANY)
(error "early-pattern-lookup: Too many patterns match"
- limit))
+ limit instance))
(else code)))))
-
- (parse-instance unparsed
+ (parse-instance instance
(lambda (expression bindings)
- (apply
- (lambda (result program)
- (receiver result
- (if (or (eq? result true) (eq? result 'MAYBE))
- (scode/make-block bindings '() program)
- false)))
- (fluid-let ((*rule-limit* limit))
- (try-rules rules
- expression
- (scode/make-error-combination
- "early-pattern-lookup: No pattern matches"
- (scode/make-constant unparsed))
- list))))))
+ (apply (lambda (result program)
+ (receiver result
+ (if (or (eq? result true) (eq? result 'MAYBE))
+ (scode/make-block bindings '() program)
+ false)))
+ (fluid-let ((*rule-limit* limit)
+ (*transformers* (if (unassigned? transformers)
+ '()
+ transformers)))
+ (try-rules rules expression
+ (scode/make-error-combination
+ "early-pattern-lookup: No pattern matches"
+ (if (or (unassigned? unparsed) (null? unparsed))
+ (scode/make-constant instance)
+ unparsed))
+ list))))))
(define (parse-instance instance receiver)
(cond ((not (pair? instance))
(receiver instance '()))
- ((eq? (car instance) 'EVALUATE)
+ ((eq? (car instance) 'UNQUOTE)
;; Shadowing may not permit the optimization below.
- ;; I think the code is being careful about uses of
- ;; the expressions, but...
+ ;; I think the code is being careful, but...
(let ((expression (cadr instance)))
(if (scode/variable? expression)
- (receiver (make-evaluation expression)
- '())
+ (receiver (make-evaluation expression) '())
(let ((var (make-variable-name 'RESULT)))
(receiver (make-evaluation (scode/make-variable var))
(list (scode/make-binding var expression)))))))
- (else
- (parse-instance (car instance)
- (lambda (instance-car car-bindings)
- (parse-instance (cdr instance)
- (lambda (instance-cdr cdr-bindings)
- (receiver (cons instance-car instance-cdr)
- (append car-bindings cdr-bindings)))))))))
+ ((eq? (car instance) 'UNQUOTE-SPLICING)
+ (error "parse-instance: unquote-splicing not supported" instance))
+ (else (parse-instance (car instance)
+ (lambda (instance-car car-bindings)
+ (parse-instance (cdr instance)
+ (lambda (instance-cdr cdr-bindings)
+ (receiver (cons instance-car instance-cdr)
+ (append car-bindings cdr-bindings)))))))))
\f
;;;; Find matching rules and collect them
+(define *rule-limit* '())
+
(define (try-rules rules expression null-form receiver)
(define (loop rules null-form bindings nrules)
(cond ((and (not (null? *rule-limit*))
(apply-transformer trans-exp name rename exp receiver))))
(define (apply-transformer transformer name rename exp receiver)
- (receiver name
+ (receiver (scode/make-variable name)
(transformer-bindings name rename (unevaluate exp)
(lambda (exp)
(scode/make-combination (scode/make-variable transformer)
(list (make-outer-binding rename expression)
(make-late-binding name (mapper (scode/make-variable rename))))))
-(define *transformers* '())
-
-(define-export (define-transformer name transformer)
- (set! *transformers*
- `((,name . ,transformer) ,@*transformers*))
- name)
+(define *transformers*)
(define (find-transformer expression)
(and (symbol? expression)
(scode/make-constant (generate-uninterned-symbol 'NOT-FOUND-))))
(try-rules database exp null-form
(lambda (result code)
- (define (possible test)
+ (define (possible test make-binding)
(receiver test
- (cons (make-outer-binding rename code)
+ (cons (make-binding rename code)
(if (eq? name rename)
'()
- (list (make-outer-binding name
- (unevaluate exp)))))))
+ (list (make-binding name
+ (unevaluate exp)))))))
(cond ((false? result)
(transformer-fail receiver))
((eq? result 'TOO-MANY)
(apply-transformer texp name rename exp receiver))
((eq? result 'MAYBE)
- (possible (make-simple-transformer-test name null-form)))
- (else (possible true))))))))
+ (possible (make-simple-transformer-test name null-form)
+ make-outer-binding))
+ (else (possible true make-early-binding))))))))
(define-integrable (make-simple-transformer-test name tag)
(scode/make-absolute-combination 'NOT
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.1 1987/06/25 10:35:23 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.2 1987/07/01 20:53:42 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
\f
;;;; Effective Addressing
+;;; *** NOTE: If this format changes, inerly.scm must also be changed! ***
+
+(define ea-tag
+ "Effective-Address")
+
(define (make-effective-address keyword mode register extension categories)
(vector ea-tag keyword mode register extension categories))
(not (zero? (vector-length object)))
(eq? (vector-ref object 0) ea-tag)))
-(define ea-tag
- "Effective-Address")
-
(define-integrable (ea-keyword ea)
(vector-ref ea 1))
(define-integrable (ea-categories ea)
(vector-ref ea 5))
+
+(define-integrable (with-ea ea receiver)
+ (receiver (ea-keyword ea)
+ (ea-mode ea)
+ (ea-register ea)
+ (ea-extension ea)
+ (ea-categories ea)))
+
+;; For completeness
+
+(define (ea-keyword-early ea)
+ (vector-ref ea 1))
+
+(define (ea-mode-early ea)
+ (vector-ref ea 2))
+
+(define (ea-register-early ea)
+ (vector-ref ea 3))
+
+(define (ea-extension-early ea)
+ (vector-ref ea 4))
+
+(define (ea-categories-early ea)
+ (vector-ref ea 5))
\f
;;;; Effective Address Extensions
projects / mit-scheme.git / commitdiff