(export (compile-expr)

(define (compile-if condition then-expr else-expr env ctxt top code k)
(compile-expr condition env 'value top code
(lambda (cname ccode ccalls?)
(compile-expr then-expr env ctxt top '()
(lambda (tname tcode tcalls?)
(compile-expr else-expr env ctxt top '()
(lambda (ename ecode ecalls?)
(let ((my-name #f))
(when (eq? ctxt 'value)
(cond
((name=? tname ename)
(set! my-name ename))
(else
(unless (name=? tname temp-name)
(set! tcode
`((_ ,temp-name ,tname)
  ,@tcode)))
(unless (name=? ename temp-name)
(set! ecode
`((_ ,temp-name ,ename)
  ,@ecode)))
(set! my-name temp-name))))
(k my-name
`((if ,(or tcalls? ecalls?)
   ,cname
,(reverse tcode)
,(reverse ecode))
  ,@ccode)
(or ccalls? tcalls? ecalls?))))))))))

(define (compile-begin body env ctxt top code k)
(cond
((null? body)
(when (or (eq? ctxt 'value) (eq? ctxt 'push))
(cerror "Using #!unspecified as the value."
"Program uses unspecified value of (begin)."))
(compile-expr '(#!quote #!unspecified) env ctxt top code k))
(else
(let loop ((code code)
        (tail body)
     (my-calls? #f))
(if (null? (cdr tail))
(compile-expr (car tail) env ctxt top code
(lambda (name code calls?)
(k name code (or calls? my-calls?))))
(compile-expr (car tail) env 'effect top code 
(lambda (name code calls?)
(loop code
   (cdr tail)
(or calls? my-calls?)))))))))

(define (compile-atom name ctxt top code k)
(case ctxt
((effect)
(k #f code #f))
((value)
(k name code #f))
((push)
(k #f
`((_ ,(stack-name top) ,name)
  ,@code)
#f))
((return)
(k #f
`((return)
  (_ ,result-name ,name)
  ,@code)
#f))
(else
(error 'compile-expr ctxt "BUG: Unrecognized context"))))

(define (compile-assignment target expr env ctxt top code k)
(compile-expr expr env 'value top code
(lambda (name code calls?)
(let ((code `((_ ,(id->name target env) ,name)
           ,@code)))
(cond
((eq? ctxt 'effect)
(k #f code calls?))
(else
(when (or (eq? ctxt 'value) (eq? ctxt 'push))
(cerror "Using #!unspecified as the value."
     "Program uses unspecified value of (set! ~S ...)."
  (cadr expr)))
(compile-expr '(#!quote #!unspecified) env ctxt top code
(lambda (name code ignore)
(k name code calls?)))))))))

(define (compile-lambda name params body env ctxt top code k)
(define (inner)
(dynamic-bind ((*literals* '())
            (*literal-count* 0)
         (*globals* '())
      (*global-count* 0)
   (*last-env-slot* -1)
(*env-names* '())
(*max-top* 0)
(*name* (cons (or name (next-name-index!))
           (dynamic-ref *name*)))
(*last-name-index* -1))
(let* ((doc #f)
    (name-list (gathering ((names (collecting)))
               (let loop ((params params))
               (define (check-param param)
               (if (symbol? param)
               (gather param names)
            (cerror "Ignore the offending name"
                 "~S is an illegal identifier"
              param)))
(cond
((pair? params)
(check-param (car params))
(loop (cdr params)))
((not (null? params))
(check-param params))))))
 (dotted? (or (symbol? params)
           (and (pair? params)
             (symbol? (cdr (last-pair params))))))
 (required-args
 (if dotted? (- (length name-list) 1) (length name-list))))

(cond
((and (string? (car body))
   (not (null? (cdr body))))
(set! doc (car body))
(set! body (cdr body))
(unless (char=? (string-ref doc 0) #\()
			; ) for paren-matching
(set! doc (format #f "~S ~A" params doc))))
(else
(set! doc (format #f "~S" params))))

(compile-expr `(#!begin ,@body)
           (nest-env env name-list)
        'return
     0
  '()
(lambda (name code calls?)
(check-for-new-code-proc)
(let ((initial-pc (next-pc!)))
(generate!
(if (>= (dynamic-ref *max-top*) stack-limit)
`((_ "a.sEx"
  ,(format #f "NEW[SimpleVectorRep[~S]]"
           (- (dynamic-ref *max-top*)
           (- stack-limit 1))))
  ,@(reverse code))
(reverse code))
initial-pc
#f)
(make-tidbit-fn (if (null? (cdr (dynamic-ref *name*)))
                (car (dynamic-ref *name*))
             (reverse (dynamic-ref *name*)))
       (reverse (dynamic-ref *env-names*))
    dotted?
 required-args
 (finalize-globals)
 (finalize-literals)
 (dynamic-ref *code-proc-name*)
 initial-pc
 doc)))))))

(if (eq? ctxt 'effect)
(k #f code #f)
(let* ((fn (inner))
    (name (new-literal fn)))
(case ctxt
((value)
(k `(close ,name) code #f))
((push)
(k #f
`((_ ,(stack-name top) (close ,name))
  ,@code)
#f))
((return)
(k #f
`((return)
  (_ ,result-name (close ,name))
  ,@code)
#f))))))

(define (compile-let params args body env ctxt top code k)
(let ((body-env (extend-env env params)))
(let loop ((params params)
        (args args)
     (code code)
  (calls? #f))
(cond
((null? params)
(unless (null? args)
(cerror "Ignore the extra arguments"
     "Extra arguments to inline LAMBDA: ~S"
  args))
(compile-expr `(#!begin ,@body) body-env ctxt top code
(lambda (name code bcalls?)
(k name code (or calls? bcalls?)))))
((null? args)
(cerror "Supply '#!unspecified for the missing arguments"
     "Too few arguments to inline LAMBDA")
(loop params
   (map (lambda (ignore)
        '(#!quote #!unspecified))
  params)
code
calls?))
(else
(compile-expr (car args) env 'value top code
(lambda (name code acalls?)
(loop
(cdr params)
(cdr args)
`((_ ,(id->name (car params)
              body-env)
  ,name)
  ,@code)
(or calls? acalls?)))))))))

(define (compile-application expr env ctxt top code k)
(let loop ((exprs expr)
        (cur-top top)
     (code code)
  (calls? (not (eq? ctxt 'return))))
(if (null? exprs)
(k (stack-name top)
`((,(if (eq? ctxt 'return) 'tail-call 'call)
,(length expr)
,top)
  ,@code)
calls?)
(compile-expr (car exprs) env 'push (try-top cur-top) code
(lambda (name code ecalls?)
(loop (cdr exprs)
   (+ cur-top 1)
code
(or calls? ecalls?)))))))

(define (compile-letrec bindings body env ctxt top code k)
(let* ((ids (map (lambda (binding)
                 (cond
                 ((symbol? (car binding))
                 (car binding))
           (else
           (cerror "Use FOO instead."
           "Illegal identifier: ~S"
        (car binding))
  'foo)))
  bindings))
 (body-env (extend-env env ids)))

(define (possibly-name-lambda id expr)
(let ((expr (expand-syntax* expr body-env)))
(if (and (pair? expr)
      (eq? '#!lambda (car expr)))
`(%%lambda-with-name%% ,id ,(cadr expr) (let () ,@(cddr expr)))
expr)))

(let loop ((ids ids)
        (exprs (map cadr bindings))
     (code code)
  (calls? #f))
(cond
((null? ids)
(compile-expr `(let () ,@body) body-env ctxt top code
(lambda (name code bcalls?)
(k name code (or calls? bcalls?)))))
(else
(compile-expr
(possibly-name-lambda (car ids) (car exprs))
body-env 'value top code
(lambda (name code acalls?)
(loop
(cdr ids)
(cdr exprs)
`((_ ,(id->name (car ids)
             body-env)
  ,name)
  ,@code)
(or calls? acalls?)))))))))

(define (compile-expr expr env ctxt top code k)
(let ((expr (expand-syntax* expr env)))
(if (pair? expr)
(case (car expr)
((#!if)
(compile-if (cadr expr) (caddr expr) (cadddr expr)
env ctxt top code k))
((#!begin)
(compile-begin (cdr expr) env ctxt top code k))
((#!quote)
(compile-atom (new-literal (cadr expr)) ctxt top code k))
((#!set!)
(compile-assignment (cadr expr) (caddr expr) env ctxt top code k))
((#!lambda)
(compile-lambda #f (cadr expr) (cddr expr) env ctxt top code k))
((%%lambda-with-name%%)
(compile-lambda (cadr expr) (caddr expr) (cdddr expr) env ctxt top code k))
((letrec)
(compile-letrec (cadr expr) (cddr expr) env ctxt top code k))
((primitive-let-syntax)
(let ((bindings (cadr expr))
   (body (cddr expr)))
(compile-expr
`(#!begin ,@body)
(extend-env-with-syntax env (map car bindings)
(map (lambda (binding) (eval (cadr binding) user))
  bindings))
ctxt top code k)))
((#!define)
(cerror "Using '#!unspecified as the expression."
     "Misplaced (define ~S ...)."
  (cadr expr))
(compile-expr '(#!quote #!unspecified) env ctxt top code k))
(else
(let ((fn (expand-syntax* (car expr) env)))
(if (and (pair? fn)
      (eq? (car fn) '#!lambda)
   (or (null? (cadr fn))
    (null? (cdr (last-pair (cadr fn))))))
(compile-let (cadr fn) (cdr expr) (cddr fn) env ctxt top code k)
(compile-application expr env ctxt top code k)))))

(cond
((symbol? expr)
(compile-atom (id->name expr env) ctxt top code k))
(else
(unless (or (char? expr)
         (number? expr)
      (string? expr)
   (boolean? expr))
(cerror "Quote the value"
     "~S cannot be evaluated"
  expr))
(compile-expr `(#!quote ,expr) env ctxt top code k))))))

) ; end export

R
;;; TidbitIntCode.scheme
;;; Copyright Σ 1989, 1991 by Xerox Corporation.  All rights reserved.
;;; Last changed by Pavel on August 11, 1989 6:26:54 pm PDT
;;; Translation to intermediate code
;; Get the name right
;; Is it a LET?  It is if the FN is a LAMBDA expression
;;  with an undotted parameter list.
;; EXPR is not a pair
Κ–
(cedarcode) style•NewlineDelimiter

™™JšœΠet
œ7™FJ™;—J˜J™$J˜˜J˜˜F˜+˜˜(˜˜(˜˜J™˜˜˜J˜—˜˜ ˜J˜J˜——˜ ˜J˜J˜——J˜———˜
˜˜	J˜J˜——J˜
J˜%—————————J˜˜0˜˜
˜-˜+J˜.——J˜<—˜˜˜J˜—˜˜*˜J˜%——˜.˜˜
˜
J˜—————————J˜˜+˜
˜	J˜—˜J˜—˜˜J˜J˜	J˜——˜	˜J˜
J˜J˜	J˜——˜J˜9———J˜˜<˜&˜˜.J˜˜˜J˜—˜˜-˜+˜7J˜———˜8˜J˜————————J˜˜=˜˜˜˜˜˜J˜J˜
˜*J˜!—J˜————˜˜0˜*˜*˜"˜#˜/˜.J˜˜˜J˜J˜—˜J˜————————˜˜J˜2——˜J˜;—J˜—˜˜J˜J˜J˜˜AJ˜+——˜J˜$J˜——˜˜#˜˜J˜———˜J˜˜˜
˜,˜˜(˜%J˜———J˜J˜—J˜
J˜—˜6˜*˜,˜*˜J˜J˜J˜J˜J˜J˜——————————J˜—˜J˜˜J˜˜
˜J˜—˜˜J˜%J˜	J˜——˜	˜J˜
J˜ J˜	J˜——————J˜˜:˜)˜˜˜J˜——˜˜˜˜$˜+J˜———˜6˜J˜$———˜
˜9J˜*—˜˜˜!J˜	—J˜J˜———˜˜,˜˜J˜J˜
˜J˜J˜—J˜	J˜————————J˜˜6˜˜˜J˜$——˜˜˜,J˜J˜—J˜	J˜—˜:˜˜˜J˜J˜———————J˜˜:˜"˜˜)˜˜˜%˜#˜J˜	———J˜———J˜!—J˜˜&˜,˜J˜!J˜?J˜———J˜˜˜#˜J˜——˜˜˜5˜J˜$———˜˜
J˜,J˜˜˜J˜	J˜˜J˜J˜—J˜	J˜————————J˜˜/˜'˜˜˜J˜H—˜
J˜/—˜
J˜9—˜	J˜B—˜J˜@—˜J˜K—˜	J˜=—˜˜J˜˜
J˜˜.˜2J˜——J˜———˜˜1˜!J˜——J˜<—˜˜+J™7J™$˜˜˜J˜)——J˜@J˜2————J˜J™˜˜J˜3—˜˜˜˜J˜——˜˜J˜———J˜8—————J˜J˜——…— ή'J