
(export (generate!)


(define (generate! code initial-pc continuation-pc)
(generate-tails code continuation-pc)
(generate-head code initial-pc continuation-pc))

(define (generate-tails code continuation-pc)
(unless (null? code)
(let ((inst (car code)))
(case (car inst)
((_)
(generate-tails (cdr code) continuation-pc))
((tail-call return)
(unless (null? (cdr code))
(error 'generate! code "BUG: Code after RETURN or TAIL-CALL")))
((call)
(if (null? (cdr code))
(set-cdr! (cddr inst) continuation-pc)
(let ((new-pc (next-pc!)))
(generate! (cdr code) new-pc continuation-pc)
(set-cdr! (cddr inst) new-pc))))
((if)
(if (cadr inst)
;; Complex IF (contains CALL instructions)
(cond
((null? (cdr code))	; Nothing after this CALL
(set-car! (cdr inst) continuation-pc)
(generate-tails (cadddr inst) continuation-pc)
(generate-tails (car (cddddr inst)) continuation-pc))
(else
(let ((new-pc (next-pc!)))
(set-car! (cdr inst) new-pc)
(generate-tails (cadddr inst) new-pc)
(generate-tails (car (cddddr inst)) new-pc)
(generate! (cdr code) new-pc continuation-pc))))
;; Simple IF (no CALL instructions)
(generate-tails (cdr code) continuation-pc)))))))

(define *current-pc* (make-dynamic 0))

(define (generate-head code initial-pc continuation-pc)
(emit-nest (format #f "~S => {" initial-pc))
(dynamic-bind ((*current-pc* initial-pc))
(generate-seq code continuation-pc))
(emit-unnest "};"))

(define (generate-seq code continuation-pc)
(if (null? code)
(generate-goto continuation-pc)
(generate-nonempty-seq code continuation-pc)))

(define (generate-nonempty-seq code continuation-pc)
(generate-inst (car code) continuation-pc (null? (cdr code)))
(unless (or (null? (cdr code))
         (eq? (caar code) 'call)
      (and (eq? (caar code) 'if)
        (cadar code)))
(generate-nonempty-seq (cdr code) continuation-pc)))

(define (generate-goto pc)
(generate-pc pc)
(emit "LOOP;"))

(define (generate-pc pc)
(unless (= pc (+ (dynamic-ref *current-pc*) 1))
(emit (format #f "pc _ ~S;" pc))))

(define (generate-bottom bottom)
(unless (= bottom 0)
(emit (format #f "bottom _ ~S;" bottom))))

(define (generate-n n)
(unless (= n 2)
(emit (format #f "n _ ~S;" n))))

(define (generate-inst inst continuation-pc at-end?)
(case (car inst)
((_)			; (_ sname name)
(if (string? (caddr inst))
(emit (format #f "~A _ ~A;" (cadr inst) (caddr inst)))
(emit (format #f "~A _ CloseProcedure[~A, env];"
              (cadr inst)
           (cadr (caddr inst)))))
(when (and continuation-pc at-end?)
(generate-goto continuation-pc)))
((return)		; (return)
(dynamic-set! *return-exit-used* #t)
(emit "GOTO returnExit;"))
((tail-call)		; (tail-call n bottom)
(dynamic-set! *tail-call-exit-used* #t)
(generate-n (cadr inst))
(generate-bottom (caddr inst))
(emit "GOTO tailExit;"))
((call)			; (call n bottom . return-pc)
(dynamic-set! *fall-thru-code-used* #t)
(generate-pc (cdddr inst))
(generate-n (cadr inst))
(generate-bottom (caddr inst)))
((if)			; (if cont-pc sname then-seq else-seq)
(let ((cont-pc (cadr inst))
   (test (caddr inst))
(then-seq (cadddr inst))
(else-seq (car (cddddr inst))))

(define (doit label seq)
(emit-nest (format #f "~A => {" label))
(generate-seq seq cont-pc)
(emit-unnest "};"))

(unless (and (null? then-seq) (null? else-seq))
(emit-nest (format #f "SELECT ~A FROM" test))
(doit "false, NIL" else-seq)
(doit "ENDCASE" then-seq)
(unnest))
(when (and (not cont-pc)
        at-end?
     continuation-pc)
(generate-goto continuation-pc))))))

) ; end export
   Â  
;;; TidbitCedar.scheme
;;; Copyright Ó 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.
;;; Last changed by Pavel on August 11, 1989 6:25:38 pm PDT
;;; Cedar code generation
 Êø  –(cedarcode) style•NewlineDelimiter
™ ™JšœÐetœ=™LJ™;—J˜ J˜J˜ ™J˜ ˜3J˜%J˜0—J˜ ˜-˜˜˜˜J˜,—˜˜J˜?——˜˜J˜&˜J˜-J˜ ———˜˜J˜*˜˜-J˜%J˜.J˜5—˜˜J˜J˜%J˜+J˜0———J˜#J˜1——————J˜ J˜&J˜ ˜7J˜,˜)J˜$—J˜—J˜ ˜+˜J˜J˜.——J˜ ˜4J˜=˜˜ ˜ J˜——J˜4——J˜ ˜J˜J˜—J˜ ˜˜/J˜"——J˜ ˜ ˜J˜*——J˜ ˜˜J˜ ——J˜ ˜4˜˜˜J˜6˜0˜J˜!———˜#J˜!——˜J˜$J˜—˜$J˜'J˜J˜J˜—˜'J˜'J˜J˜J˜—˜.˜˜J˜J˜—J˜ ˜J˜'J˜J˜—J˜ ˜/J˜-J˜J˜J˜	—˜˜J˜—J˜$—————J˜ J˜—— …—    ˆ  B  