--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.1 1987/06/13 21:18:05 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generator
+
+(declare (usual-integrations))
+\f
+(define *register-map*)
+(define *prefix-instructions*)
+(define *needed-registers*)
+
+(define-integrable (prefix-instructions! instructions)
+ (set! *prefix-instructions* (append! *prefix-instructions* instructions)))
+
+(define-integrable (need-register! register)
+ (set! *needed-registers* (cons register *needed-registers*)))
+
+(define-integrable (need-registers! registers)
+ ;; **** Assume EQ? works on registers here. ****
+ (set! *needed-registers* (eq-set-union registers *needed-registers*)))
+
+(define (maybe-need-register! register)
+ (if register (need-register! register))
+ register)
+
+(define (register-has-alias? register type)
+ (if (machine-register? register)
+ (register-type? register type)
+ (pseudo-register-alias *register-map* type register)))
+
+(define-integrable (register-alias register type)
+ (maybe-need-register! (pseudo-register-alias *register-map* type register)))
+
+(define-integrable (register-alias-alternate register type)
+ (maybe-need-register! (machine-register-alias *register-map* type register)))
+
+(define-integrable (register-type? register type)
+ (or (not type)
+ (eq? (register-type register) type)))
+
+(define ((register-type-predicate type) register)
+ (register-type? register type))
+
+(define-integrable (dead-register? register)
+ (memv register *dead-registers*))
+\f
+(define (guarantee-machine-register! register type)
+ (if (and (machine-register? register)
+ (register-type? register type))
+ register
+ (load-alias-register! register type)))
+
+(define (load-alias-register! register type)
+ (bind-allocator-values (load-alias-register *register-map* type
+ *needed-registers* register)
+ store-allocator-values!))
+
+(define (allocate-alias-register! register type)
+ (bind-allocator-values (allocate-alias-register *register-map* type
+ *needed-registers* register)
+ (lambda (alias map instructions)
+ (store-allocator-values! alias
+ (delete-other-locations map alias)
+ instructions))))
+
+(define (allocate-assignment-alias! target type)
+ (let ((target (allocate-alias-register! target type)))
+ (delete-dead-registers!)
+ target))
+
+(define (allocate-temporary-register! type)
+ (bind-allocator-values (allocate-temporary-register *register-map* type
+ *needed-registers*)
+ store-allocator-values!))
+
+(define (store-allocator-values! alias map instructions)
+ (need-register! alias)
+ (set! *register-map* map)
+ (prefix-instructions! instructions)
+ alias)
+
+(define-integrable (reference-alias-register! register type)
+ (register-reference (allocate-alias-register! register type)))
+
+(define-integrable (reference-assignment-alias! register type)
+ (register-reference (allocate-assignment-alias! register type)))
+
+(define-integrable (reference-temporary-register! type)
+ (register-reference (allocate-temporary-register! type)))
+\f
+(define (move-to-alias-register! source type target)
+ (reuse-pseudo-register-alias! source type
+ (lambda (reusable-alias)
+ (add-pseudo-register-alias! target reusable-alias false))
+ (lambda ()
+ (allocate-alias-register! target type))))
+
+(define (move-to-temporary-register! source type)
+ (reuse-pseudo-register-alias! source type
+ need-register!
+ (lambda ()
+ (allocate-temporary-register! type))))
+
+(define (reuse-pseudo-register-alias! source type if-reusable if-not)
+ ;; IF-NOT is assumed to return a machine register.
+ (let ((reusable-alias
+ (and (dead-register? source)
+ (register-alias source type))))
+ (if reusable-alias
+ (begin (delete-dead-registers!)
+ (if-reusable reusable-alias)
+ (register-reference reusable-alias))
+ (let ((alias (if (machine-register? source)
+ source
+ (register-alias source false))))
+ (delete-dead-registers!)
+ (let ((target (if-not)))
+ (prefix-instructions!
+ (cond ((not alias) (home->register-transfer source target))
+ ((= alias target) '())
+ (else (register->register-transfer alias target))))
+ (register-reference target))))))
+\f
+(define (add-pseudo-register-alias! register alias saved-into-home?)
+ (set! *register-map*
+ (add-pseudo-register-alias *register-map* register alias
+ saved-into-home?))
+ (need-register! alias))
+
+(define (clear-map!)
+ (delete-dead-registers!)
+ (let ((instructions (clear-map)))
+ (set! *register-map* (empty-register-map))
+ (set! *needed-registers* '())
+ instructions))
+
+(define-integrable (clear-map)
+ (clear-map-instructions *register-map*))
+
+(define (clear-registers! . registers)
+ (if (null? registers)
+ '()
+ (let loop ((map *register-map*) (registers registers))
+ (save-machine-register map (car registers)
+ (lambda (map instructions)
+ (let ((map (delete-machine-register map (car registers))))
+ (if (null? (cdr registers))
+ (begin (set! *register-map* map)
+ instructions)
+ (append! instructions (loop map (cdr registers))))))))))
+
+(define (save-machine-register! register)
+ (let ((contents (machine-register-contents *register-map* register)))
+ (if contents
+ (save-pseudo-register! contents))))
+
+(define (save-pseudo-register! register)
+ (if (not (dead-register? register))
+ (save-pseudo-register *register-map* register
+ (lambda (map instructions)
+ (set! *register-map* map)
+ (prefix-instructions! instructions)))))
+
+(define (delete-machine-register! register)
+ (set! *register-map* (delete-machine-register *register-map* register))
+ (set! *needed-registers* (eqv-set-delete *needed-registers* register)))
+
+(package (delete-pseudo-register! delete-dead-registers!)
+ (define-export (delete-pseudo-register! register)
+ (delete-pseudo-register *register-map* register delete-registers!))
+ (define-export (delete-dead-registers!)
+ (delete-pseudo-registers *register-map* *dead-registers* delete-registers!)
+ (set! *dead-registers* '()))
+ (define (delete-registers! map aliases)
+ (set! *register-map* map)
+ (set! *needed-registers* (eqv-set-difference *needed-registers* aliases))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 1.1 1987/06/13 21:18:20 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; LAP Generator
+
+(declare (usual-integrations))
+\f
+;;;; Constants
+
+(define *next-constant*)
+(define *interned-constants*)
+(define *interned-variables*)
+(define *interned-uuo-links*)
+
+(define (allocate-constant-label)
+ (let ((label
+ (string->symbol
+ (string-append "CONSTANT-" (write-to-string *next-constant*)))))
+ (set! *next-constant* (1+ *next-constant*))
+ label))
+
+(define (constant->label constant)
+ (let ((entry (assv constant *interned-constants*)))
+ (if entry
+ (cdr entry)
+ (let ((label (allocate-constant-label)))
+ (set! *interned-constants*
+ (cons (cons constant label)
+ *interned-constants*))
+ label))))
+
+(define (free-reference-label name)
+ (let ((entry (assq name *interned-variables*)))
+ (if entry
+ (cdr entry)
+ (let ((label (allocate-constant-label)))
+ (set! *interned-variables*
+ (cons (cons name label)
+ *interned-variables*))
+ label))))
+
+(define (free-uuo-link-label name)
+ (let ((entry (assq name *interned-uuo-links*)))
+ (if entry
+ (cdr entry)
+ (let ((label (allocate-constant-label)))
+ (set! *interned-uuo-links*
+ (cons (cons name label)
+ *interned-uuo-links*))
+ label))))
+
+(define-integrable (set-current-branches! consequent alternative)
+ (set-rtl-pnode-consequent-lap-generator! *current-rnode* consequent)
+ (set-rtl-pnode-alternative-lap-generator! *current-rnode* alternative))
+\f
+;;;; Frame Pointer
+
+(define *frame-pointer-offset*)
+
+(define (disable-frame-pointer-offset! instructions)
+ (set! *frame-pointer-offset* false)
+ instructions)
+
+(define (enable-frame-pointer-offset! offset)
+ (if (not offset) (error "Null frame-pointer offset"))
+ (set! *frame-pointer-offset* offset))
+
+(define (record-push! instructions)
+ (if *frame-pointer-offset*
+ (set! *frame-pointer-offset* (1+ *frame-pointer-offset*)))
+ instructions)
+
+(define (record-pop!)
+ (if *frame-pointer-offset*
+ (set! *frame-pointer-offset* (-1+ *frame-pointer-offset*))))
+
+(define (decrement-frame-pointer-offset! n instructions)
+ (if *frame-pointer-offset*
+ (set! *frame-pointer-offset*
+ (and (<= n *frame-pointer-offset*) (- *frame-pointer-offset* n))))
+ instructions)
+
+(define (guarantee-frame-pointer-offset!)
+ (if (not *frame-pointer-offset*) (error "Frame pointer not initialized")))
+
+(define (increment-frame-pointer-offset! n instructions)
+ (guarantee-frame-pointer-offset!)
+ (set! *frame-pointer-offset* (+ *frame-pointer-offset* n))
+ instructions)
+
+(define (frame-pointer-offset)
+ (guarantee-frame-pointer-offset!)
+ *frame-pointer-offset*)
+
+(define (record-continuation-frame-pointer-offset! label)
+ (let ((continuation (label->continuation label)))
+ (guarantee-frame-pointer-offset!)
+ (if (continuation-frame-pointer-offset continuation)
+ (if (not (= (continuation-frame-pointer-offset continuation)
+ *frame-pointer-offset*))
+ (error "Continuation frame-pointer offset mismatch" continuation
+ *frame-pointer-offset*))
+ (set-continuation-frame-pointer-offset! continuation
+ *frame-pointer-offset*))
+ (enqueue! *continuation-queue* continuation)))
+
+(define (record-rnode-frame-pointer-offset! rnode offset)
+ (if (rnode-frame-pointer-offset rnode)
+ (if (not (and offset (= (rnode-frame-pointer-offset rnode) offset)))
+ (error "RNode frame-pointer offset mismatch" rnode offset))
+ (set-rnode-frame-pointer-offset! rnode offset)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 1.1 1987/06/13 21:16:51 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Control Flow Graph Abstraction
+
+(declare (usual-integrations))
+\f
+;;;; Editing
+
+;;; BBlock information is preserved only for deletions. Doing the
+;;; same for insertions is more difficult and not currently needed.
+
+(define (snode-delete! snode)
+ (let ((bblock (node-bblock snode)))
+ (if (and bblock
+ (eq? snode (bblock-exit bblock))
+ (not (eq? snode (bblock-entry bblock))))
+ (set-bblock-exit! bblock (node-previous-first snode))))
+ (let ((previous-edges (node-previous-edges snode))
+ (next-edge (snode-next-edge snode)))
+ (let ((node (edge-right-node next-edge)))
+ (edges-disconnect-right! previous-edges)
+ (edge-disconnect! next-edge)
+ (edges-connect-right! previous-edges node))))
+
+(define (edge-insert-snode! edge snode)
+ (let ((next (edge-right-node edge)))
+ (edge-disconnect-right! edge)
+ (edge-connect-right! edge snode)
+ (create-edge! snode set-snode-next-edge! next)))
+
+(define (node-insert-snode! node snode)
+ (let ((previous-edges (node-previous-edges node)))
+ (edges-disconnect-right! previous-edges)
+ (edges-connect-right! previous-edges snode)
+ (create-edge! snode set-snode-next-edge! node)))
+
+(define (node->edge node)
+ (let ((edge (make-edge false false false)))
+ (edge-connect-right! edge node)
+ edge))
+
+(define-integrable (cfg-entry-edge cfg)
+ (node->edge (cfg-entry-node cfg)))\f
+;;;; Previous Connections
+
+(define-integrable (node-previous=0? node)
+ (edges=0? (node-previous-edges node)))
+
+(define (edges=0? edges)
+ (cond ((null? edges) true)
+ ((edge-left-node (car edges)) false)
+ (else (edges=0? (cdr edges)))))
+
+(define-integrable (node-previous>0? node)
+ (edges>0? (node-previous-edges node)))
+
+(define (edges>0? edges)
+ (cond ((null? edges) false)
+ ((edge-left-node (car edges)) true)
+ (else (edges>0? (cdr edges)))))
+
+(define-integrable (node-previous=1? node)
+ (edges=1? (node-previous-edges node)))
+
+(define (edges=1? edges)
+ (if (null? edges)
+ false
+ ((if (edge-left-node (car edges)) edges=0? edges=1?) (cdr edges))))
+
+(define-integrable (node-previous>1? node)
+ (edges>1? (node-previous-edges node)))
+
+(define (edges>1? edges)
+ (if (null? edges)
+ false
+ ((if (edge-left-node (car edges)) edges>0? edges>1?) (cdr edges))))
+
+(define-integrable (node-previous-first node)
+ (edges-first-node (node-previous-edges node)))
+
+(define (edges-first-node edges)
+ (if (null? edges)
+ (error "No first hook")
+ (or (edge-left-node (car edges))
+ (edges-first-node (cdr edges)))))
+
+(define (for-each-previous-node node procedure)
+ (for-each (lambda (edge)
+ (let ((node (edge-left-node edge)))
+ (if node
+ (procedure node))))
+ (node-previous-edges node)))
+\f
+;;;; Noops
+
+(define noop-node-tag (make-vector-tag snode-tag 'NOOP))
+(define *noop-nodes*)
+
+(define-integrable (make-noop-node)
+ (let ((node (make-snode noop-node-tag)))
+ (set! *noop-nodes* (cons node *noop-nodes*))
+ node))
+
+(define (delete-noop-nodes!)
+ (for-each snode-delete! *noop-nodes*)
+ (set! *noop-nodes* '()))
+
+(define (constant->pcfg value)
+ ((if value make-true-pcfg make-false-pcfg)))
+
+(define (make-false-pcfg)
+ (let ((node (make-noop-node)))
+ (make-pcfg node
+ '()
+ (list (make-hook node set-snode-next-edge!)))))
+
+(define (make-true-pcfg)
+ (let ((node (make-noop-node)))
+ (make-pcfg node
+ (list (make-hook node set-snode-next-edge!))
+ '())))
+\f
+;;;; Miscellaneous
+
+(package (with-new-node-marks
+ node-marked?
+ node-mark!)
+
+(define *generation*)
+
+(define-export (with-new-node-marks thunk)
+ (fluid-let ((*generation* (make-generation)))
+ (thunk)))
+
+(define make-generation
+ (let ((generation 0))
+ (named-lambda (make-generation)
+ (let ((value generation))
+ (set! generation (1+ generation))
+ value))))
+
+(define-export (node-marked? node)
+ (eq? (node-generation node) *generation*))
+
+(define-export (node-mark! node)
+ (set-node-generation! node *generation*))
+
+)
+
+(define (node-property-get node key)
+ (let ((entry (assq key (node-alist node))))
+ (and entry (cdr entry))))
+
+(define (node-property-put! node key item)
+ (let ((entry (assq key (node-alist node))))
+ (if entry
+ (set-cdr! entry item)
+ (set-node-alist! node (cons (cons key item) (node-alist node))))))
+
+(define (node-property-remove! node key)
+ (set-node-alist! node (del-assq! key (node-alist node))))
+
+(define (node-label node)
+ (or (node-labelled? node)
+ (let ((label (generate-label)))
+ (set-node-label! node label)
+ label)))
+
+(define-integrable (node-labelled? node)
+ (node-property-get node node-label))
+
+(define-integrable (set-node-label! node label)
+ (node-property-put! node node-label label))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 1.1 1987/06/13 21:16:37 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Control Flow Graph Abstraction
+
+(declare (usual-integrations))
+\f
+;;;; CFG Datatypes
+
+;;; A CFG is a compound CFG-node, so there are different types of CFG
+;;; corresponding to the (connective-wise) different types of
+;;; CFG-node. One may insert a particular type of CFG anywhere in a
+;;; graph that its corresponding node may be inserted.
+
+(define-integrable (make-scfg node next-hooks)
+ (vector 'SNODE-CFG node next-hooks))
+
+(define-integrable (make-scfg* node consequent-hooks alternative-hooks)
+ (make-scfg node (hooks-union consequent-hooks alternative-hooks)))
+
+(define-integrable (make-pcfg node consequent-hooks alternative-hooks)
+ (vector 'PNODE-CFG node consequent-hooks alternative-hooks))
+
+(define-integrable (cfg-tag cfg)
+ (vector-ref cfg 0))
+
+(define-integrable (cfg-entry-node cfg)
+ (vector-ref cfg 1))
+
+(define-integrable (scfg-next-hooks scfg)
+ (vector-ref scfg 2))
+
+(define-integrable (pcfg-consequent-hooks pcfg)
+ (vector-ref pcfg 2))
+
+(define-integrable (pcfg-alternative-hooks pcfg)
+ (vector-ref pcfg 3))
+
+(define-integrable (make-null-cfg) false)
+(define-integrable cfg-null? false?)
+(define-integrable (snode->scfg snode)
+ (node->scfg snode set-snode-next-edge!))
+
+(define (node->scfg node set-node-next!)
+ (make-scfg node
+ (list (make-hook node set-node-next!))))
+
+(define-integrable (pnode->pcfg pnode)
+ (node->pcfg pnode
+ set-pnode-consequent-edge!
+ set-pnode-alternative-edge!))
+
+(define (node->pcfg node set-node-consequent! set-node-alternative!)
+ (make-pcfg node
+ (list (make-hook node set-node-consequent!))
+ (list (make-hook node set-node-alternative!))))
+\f
+;;;; Hook Datatype
+
+(define-integrable make-hook cons)
+(define-integrable hook-node car)
+(define-integrable hook-connect cdr)
+
+(define (hook=? x y)
+ (and (eq? (hook-node x) (hook-node y))
+ (eq? (hook-connect x) (hook-connect y))))
+
+(define hook-member?
+ (member-procedure hook=?))
+
+(define (hooks-union x y)
+ (let loop ((x x))
+ (cond ((null? x) y)
+ ((hook-member? (car x) y) (loop (cdr x)))
+ (else (cons (car x) (loop (cdr x)))))))
+
+(define (hooks-connect! hooks node)
+ (for-each (lambda (hook)
+ (hook-connect! hook node))
+ hooks))
+
+(define (hook-connect! hook node)
+ (create-edge! (hook-node hook) (hook-connect hook) node))
+
+(define (scfg*node->node! scfg next-node)
+ (if (cfg-null? scfg)
+ next-node
+ (begin (if next-node
+ (hooks-connect! (scfg-next-hooks scfg) next-node))
+ (cfg-entry-node scfg))))
+
+(define (pcfg*node->node! pcfg consequent-node alternative-node)
+ (if (cfg-null? pcfg)
+ (error "PCFG*NODE->NODE!: Can't have null predicate"))
+ (if consequent-node
+ (hooks-connect! (pcfg-consequent-hooks pcfg) consequent-node))
+ (if alternative-node
+ (hooks-connect! (pcfg-alternative-hooks pcfg) alternative-node))
+ (cfg-entry-node pcfg))
+\f
+;;;; CFG Construction
+
+(define-integrable (scfg-next-connect! scfg cfg)
+ (hooks-connect! (scfg-next-hooks scfg) (cfg-entry-node cfg)))
+
+(define-integrable (pcfg-consequent-connect! pcfg cfg)
+ (hooks-connect! (pcfg-consequent-hooks pcfg) (cfg-entry-node cfg)))
+
+(define-integrable (pcfg-alternative-connect! pcfg cfg)
+ (hooks-connect! (pcfg-alternative-hooks pcfg) (cfg-entry-node cfg)))
+
+(define (scfg*scfg->scfg! scfg scfg*)
+ (cond ((not scfg) scfg*)
+ ((not scfg*) scfg)
+ (else
+ (scfg-next-connect! scfg scfg*)
+ (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*)))))
+
+(define (scfg-append! . scfgs)
+ (scfg*->scfg! scfgs))
+
+(define scfg*->scfg!
+ (let ()
+ (define (loop first second rest)
+ (scfg-next-connect! first second)
+ (if (null? rest)
+ second
+ (loop second (car rest) (find-non-null (cdr rest)))))
+
+ (define (find-non-null scfgs)
+ (if (or (null? scfgs)
+ (car scfgs))
+ scfgs
+ (find-non-null (cdr scfgs))))
+
+ (named-lambda (scfg*->scfg! scfgs)
+ (let ((first (find-non-null scfgs)))
+ (and (not (null? first))
+ (let ((second (find-non-null (cdr first))))
+ (if (null? second)
+ (car first)
+ (make-scfg (cfg-entry-node (car first))
+ (scfg-next-hooks
+ (loop (car first)
+ (car second)
+ (find-non-null (cdr second))))))))))))
+\f
+(define (pcfg->scfg! pcfg)
+ (make-scfg* (cfg-entry-node pcfg)
+ (pcfg-consequent-hooks pcfg)
+ (pcfg-alternative-hooks pcfg)))
+
+(package (scfg*pcfg->pcfg! scfg*pcfg->scfg!)
+
+(define ((scfg*pcfg->cfg! transformer constructor) scfg pcfg)
+ (cond ((not pcfg) (error "SCFG*PCFG->CFG!: Can't have null predicate"))
+ ((not scfg) (transformer pcfg))
+ (else
+ (scfg-next-connect! scfg pcfg)
+ (constructor (cfg-entry-node scfg)
+ (pcfg-consequent-hooks pcfg)
+ (pcfg-alternative-hooks pcfg)))))
+
+(define scfg*pcfg->pcfg!
+ (scfg*pcfg->cfg! identity-procedure make-pcfg))
+
+(define scfg*pcfg->scfg!
+ (scfg*pcfg->cfg! pcfg->scfg! make-scfg*))
+
+)
+
+(package (pcfg*scfg->pcfg! pcfg*scfg->scfg!)
+
+(define ((pcfg*scfg->cfg! transformer constructor) pcfg consequent alternative)
+ (cond ((not pcfg) (error "PCFG*SCFG->CFG!: Can't have null predicate"))
+ ((not consequent)
+ (if (not alternative)
+ (transformer pcfg)
+ (begin (pcfg-alternative-connect! pcfg alternative)
+ (constructor (cfg-entry-node pcfg)
+ (pcfg-consequent-hooks pcfg)
+ (scfg-next-hooks alternative)))))
+ ((not alternative)
+ (pcfg-consequent-connect! pcfg consequent)
+ (constructor (cfg-entry-node pcfg)
+ (scfg-next-hooks consequent)
+ (pcfg-alternative-hooks pcfg)))
+ (else
+ (pcfg-consequent-connect! pcfg consequent)
+ (pcfg-alternative-connect! pcfg alternative)
+ (constructor (cfg-entry-node pcfg)
+ (scfg-next-hooks consequent)
+ (scfg-next-hooks alternative)))))
+
+(define pcfg*scfg->pcfg!
+ (pcfg*scfg->cfg! identity-procedure make-pcfg))
+
+(define pcfg*scfg->scfg!
+ (pcfg*scfg->cfg! pcfg->scfg! make-scfg*))
+
+)
+\f
+(package (pcfg*pcfg->pcfg! pcfg*pcfg->scfg!)
+
+(define ((pcfg*pcfg->cfg! transformer constructor) pcfg consequent alternative)
+ (cond ((not pcfg)
+ (error "PCFG*PCFG->CFG!: Can't have null predicate"))
+ ((not consequent)
+ (if (not alternative)
+ (transformer pcfg)
+ (begin (pcfg-alternative-connect! pcfg alternative)
+ (constructor
+ (cfg-entry-node pcfg)
+ (hooks-union (pcfg-consequent-hooks pcfg)
+ (pcfg-consequent-hooks alternative))
+ (pcfg-alternative-hooks alternative)))))
+ ((not alternative)
+ (pcfg-consequent-connect! pcfg consequent)
+ (constructor (cfg-entry-node pcfg)
+ (pcfg-consequent-hooks consequent)
+ (hooks-union (pcfg-alternative-hooks consequent)
+ (pcfg-alternative-hooks pcfg))))
+ (else
+ (pcfg-consequent-connect! pcfg consequent)
+ (pcfg-alternative-connect! pcfg alternative)
+ (constructor (cfg-entry-node pcfg)
+ (hooks-union (pcfg-consequent-hooks consequent)
+ (pcfg-consequent-hooks alternative))
+ (hooks-union (pcfg-alternative-hooks consequent)
+ (pcfg-alternative-hooks alternative))))))
+
+(define pcfg*pcfg->pcfg!
+ (pcfg*pcfg->cfg! identity-procedure make-pcfg))
+
+(define pcfg*pcfg->scfg!
+ (pcfg*pcfg->cfg! pcfg->scfg! make-scfg*))
+
+)
+\f
+(define (scfg*cfg->cfg! scfg cfg)
+ (if (not scfg)
+ cfg
+ (begin (scfg-next-connect! scfg cfg)
+ (case (cfg-tag cfg)
+ ((SNODE-CFG)
+ (make-scfg (cfg-entry-node scfg) (scfg-next-hooks cfg)))
+ ((PNODE-CFG)
+ (make-pcfg (cfg-entry-node scfg)
+ (pcfg-consequent-hooks cfg)
+ (pcfg-alternative-hooks cfg)))
+ (else
+ (error "Unknown CFG tag" cfg))))))
+
+(define (pcfg*cfg->pcfg! pcfg consequent alternative)
+ (pcfg-consequent-connect! pcfg consequent)
+ (pcfg-alternative-connect! pcfg alternative)
+ (case (cfg-tag consequent)
+ ((SNODE-CFG)
+ (case (cfg-tag alternative)
+ ((SNODE-CFG)
+ (make-pcfg (cfg-entry-node pcfg)
+ (scfg-next-hooks consequent)
+ (scfg-next-hooks alternative)))
+ ((PNODE-CFG)
+ (make-pcfg (cfg-entry-node pcfg)
+ (hooks-union (scfg-next-hooks consequent)
+ (pcfg-consequent-hooks alternative))
+ (pcfg-alternative-hooks alternative)))
+ (else
+ (error "Unknown CFG tag" alternative))))
+ ((PNODE-CFG)
+ (case (cfg-tag alternative)
+ ((SNODE-CFG)
+ (make-pcfg (cfg-entry-node pcfg)
+ (pcfg-consequent-hooks consequent)
+ (hooks-union (pcfg-alternative-hooks consequent)
+ (scfg-next-hooks alternative))))
+ ((PNODE-CFG)
+ (make-pcfg (cfg-entry-node pcfg)
+ (hooks-union (pcfg-consequent-hooks consequent)
+ (pcfg-consequent-hooks alternative))
+ (hooks-union (pcfg-alternative-hooks consequent)
+ (pcfg-alternative-hooks alternative))))
+ (else
+ (error "Unknown CFG tag" alternative))))
+ (else
+ (error "Unknown CFG tag" consequent))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff