<<>>
<<;;; TidbitTop.scheme>>
<<;;; Copyright Ó 1989, 1991, 1992 by Xerox Corporation.  All rights reserved.>>
<<;;; Last changed by Pavel on August 11, 1989 6:24:25 pm PDT>>
<<;;; Michael Plass, February 26, 1992 12:10 pm PST>>

(export (tidbit-file check-for-new-code-proc emit emit-newline emit-nest emit-unnest unnest *code-proc-name* *return-exit-used* 
*tail-call-exit-used* *fall-thru-code-used*)

<<;;; The top-level interface>>

(define (tidbit-file file-name-root)
(let* ((input-file-name (string-append file-name-root ".scheme"))
    (in (open-input-file input-file-name))
 (module-name (string-append file-name-root "SchemeCode"))
 (output-file-name (string-append module-name ".mesa"))
 (out (open-output-file output-file-name)))

(format #t "~LCompiling source file ~A:~L~%" "i" input-file-name "I")
(compile-port in out file-name-root module-name)
(close-input-port in)
(close-output-port out)
(call-with-output-file (string-append module-name ".install")
(lambda (port)
(format port "Run ~A~%" module-name)))
(call-with-output-file (string-append file-name-root ".$cheme")
(lambda (port)
(format port "(reinstall ~S)~%" module-name)))
(unless (do-command (string-append "RCompile " module-name))
(do-command "GetFromRelease")
(do-command (string-append "RCompile " module-name)))
'#!unspecified))

(define *new-globals* (make-dynamic '()))
(define *code-proc-name* (make-dynamic "Code0"))
(define *return-exit-used* (make-dynamic #f))
(define *tail-call-exit-used* (make-dynamic #f))
(define *fall-thru-code-used* (make-dynamic #f))
(define *code-proc-index* (make-dynamic 0))
(define *start-proc-maker-index* (make-dynamic 0))

(define (compile-port in out file-name-root module-name)
(dynamic-bind ((*cedar-output* out)
            (*cedar-indent* "")
         (*all-literals* (make-table))
      (*literals* '())
   (*literal-count* 0)
(*globals* '())
(*global-count* 0)
(*last-env-slot* -1)
(*env-names* '())
(*max-top* 0)
(*last-pc* -1)
(*code-proc-index* 0)
(*code-proc-name* "Code0")
(*tail-call-exit-used* #f)
(*return-exit-used* #f)
(*fall-thru-code-used* #f)
(*start-proc-maker-index* 0)
(*name* (list file-name-root))
(*last-name-index* -1)
(*new-globals* '()))
(output-cedar-boilerplate file-name-root module-name)

(let loop ((form (read in))
        (code '()))
(cond
((eof-object? form)
<<;; Finish off the intermediate code with an expression>>
<<;; in return context.>>
(compile-expr '(#!quote #!unspecified) '() 'return 0 code
(lambda (xx code yy)
(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)
(format #t "~LFinishing off ~A.mesa ..."
"i" module-name)
(output-final-cedar-code (dynamic-ref *new-globals*)
(make-tidbit-fn
file-name-root
(reverse (dynamic-ref *env-names*))
#f
0
(finalize-globals)
(finalize-literals)
(dynamic-ref *code-proc-name*)
initial-pc
"No documentation"))
(format #t " done.~L~%" "I")))))
(else
(print-top-level-form "    " form)
(loop (read in)
   (compile-form form '() code "    ")))))))

(define (compile-form form env code indent)
(let ((form (expand-syntax* form env)))
(if (pair? form)
(case (car form)
((#!begin)
(let ((indent (string-append indent "    ")))
(let loop ((forms (cdr form))
        (code code))
(cond
((null? forms)
code)
(else
(print-top-level-form indent (car forms))
(loop
(cdr forms)
(compile-form (car forms) env code indent)))))))
((#!define)
(dynamic-set! *new-globals*
           (cons (cadr form) (dynamic-ref *new-globals*)))
(let ((name (cadr form))
   (expr (expand-syntax* (caddr form) env)))
(if (and (pair? expr)
      (eq? (car expr) '#!lambda))
(dynamic-bind ((*name* '())
            (*last-name-index* -1))
(compile-form
`(#!set! ,name
(%%lambda-with-name%% ,name ,(cadr expr)
,@(cddr expr)))
env code indent))
(compile-form
`(#!set! ,name ,expr)
env code indent))))
((primitive-let-syntax)
(let ((bindings (cadr form))
   (body (cddr form)))
(compile-form
`(#!begin ,@body)
(extend-env-with-syntax env (map car bindings)
(map (lambda (binding) (eval (cadr binding) user))
  bindings))
code indent)))
(else
(compile-expr form '() 'effect 0 code
(lambda (name code calls?)
code))))
code)))

(define (output-cedar-boilerplate file-name-root module-name)
(emit (format #f "-- ~A.mesa" module-name))
(emit (format #f "-- Tidbit compiler output for ~A.scheme" file-name-root))
(emit-newline)
(emit "DIRECTORY Scheme, SchemePrivate;")
(emit-newline)
(emit (format #f "~A: CEDAR PROGRAM" module-name))
(emit "IMPORTS Scheme, SchemePrivate")
(emit-nest "~ BEGIN")
(emit "OPEN Scheme, SchemePrivate;")
(start-code-proc))

(define (start-code-proc)
(emit-newline)
(emit-nest (format #f "~A: PROC [a: Activation] ~~ {"
                   (dynamic-ref *code-proc-name*)))
(emit "g: PairSeq ~ a.code.globalBindings;")
(emit "env: Environment ~ a.env;")
(emit "c: SimpleVector ~ a.code.literals;")
(emit "s: Stack ~ a.s;")
(emit "temp: Any _ NIL;")
(emit "pc: INTEGER _ a.pc;")
(emit "bottom: INTEGER _ 0;")
(emit "n: INTEGER _ 2;")
(emit-newline)
(emit-nest "DO")
(emit "a.pc _ pc;")
(emit "pc _ pc + 1;")
(emit-nest "SELECT a.pc FROM"))

(define (end-code-proc)
(emit-unnest "ENDCASE => ERROR;")
(when (dynamic-ref *fall-thru-code-used*)
(emit "a.pc _ pc;")
(emit "a.n _ n;")
(emit "a.bottom _ bottom;")
(emit "RETURN;"))
(when (or (dynamic-ref *return-exit-used*)
       (dynamic-ref *tail-call-exit-used*))
(emit-newline)
(emit-nest "REPEAT")
(when (dynamic-ref *return-exit-used*)
(emit "returnExit => { a.pc _ -1; a.n _ 0; };"))
(when (dynamic-ref *tail-call-exit-used*)
(emit "tailExit => {a.pc _ -1; a.n _ n; a.bottom _ bottom; };"))
(unnest))
(emit-unnest "ENDLOOP;")
(emit-unnest "};"))

(define (new-code-proc!)
(end-code-proc)
(dynamic-set! *code-proc-index* (+ (dynamic-ref *code-proc-index*) 1))
(dynamic-set! *code-proc-name*
(format #f "Code~S" (dynamic-ref *code-proc-index*)))
(dynamic-set! *last-pc* -1)
(dynamic-set! *return-exit-used* #f)
(dynamic-set! *tail-call-exit-used* #f)
(dynamic-set! *fall-thru-code-used* #f)
(start-code-proc))

(define pc-threshhold 35)
(define make-tidbit-fn-threshhold 5)

(define (check-for-new-code-proc)
(when (> (dynamic-ref *last-pc*) pc-threshhold)
(new-code-proc!)))

(define (output-final-cedar-code new-globals start-proc)
(end-code-proc)
(emit-newline)
(emit-nest "Register: PROC [env: Environment] ~ {")
(emit "startProc: TidbitProcedure;")
(unless (zero? (table-size (dynamic-ref *all-literals*)))
(let ((v (make-vector (table-size (dynamic-ref *all-literals*)))))
(table-walk (lambda (value index) (vector-set! v index value))
         (dynamic-ref *all-literals*))
(emit (format #f "literals: SimpleVector ~~ ReadRopeVector[~S];"
              (value->binary-string v)))))
(unless (null? new-globals)
(emit (format #f "newGlobals: SimpleVector ~~ ReadRopeVector[~S];"
              (value->string (list->vector new-globals)))))
(emit-newline)
(unless (null? new-globals)
(emit-nest "FOR i:INT IN [0..newGlobals.length-1] DO")
(emit "DefineVariable[newGlobals[i], undefined, env];")
(emit-unnest "ENDLOOP;"))
(create-start-proc start-proc)
(emit "[] _ Apply[startProc, NIL];")
(emit-unnest "};")
(emit-newline)
(emit-unnest "RegisterInit[Register];")
(emit "END."))

(define (create-start-proc start-proc)
(define (compute-proc proc)
(emit-nest "MakeTidbitCode[")
(emit (format #f "~S,"
              (string-append
              (value->string (tidbit-fn-name proc)) " "
           (value->string (tidbit-fn-env-names proc)) " "
        (value->string (tidbit-fn-globals proc)))))
(emit (format #f "env, ~S, ~A,"
              (if (tidbit-fn-dotted? proc)
              (- (+ 1 (tidbit-fn-required-args proc)))
           (tidbit-fn-required-args proc))
     (tidbit-fn-code-proc proc)))

(let ((len (length (tidbit-fn-literals proc))))
(define (output-literals)
(let loop ((literals (tidbit-fn-literals proc)))
(unless (null? literals)
(cond
((tidbit-fn? (car literals))
(compute-proc (car literals))
(unless (null? (cdr literals))
(emit ",")))
((string? (car literals))
(emit (format #f "~A[]~A"
              (car literals)
           (if (null? (cdr literals))
           ""
        ","))))
(else
(emit (format #f "literals[~S]~A"
              (car literals)
           (if (null? (cdr literals))
           ""
        ",")))))
(loop (cdr literals)))))

(cond
((zero? len)
(emit "NIL,"))
((<= 1 len 7)
(emit-nest (format #f "SV~S[" len))
(output-literals)
(emit-unnest "],"))
(else
(emit-nest "LIST[")
(output-literals)
(emit-unnest "],"))))

(emit-unnest (format #f "~S, ~S, NIL]"
                  (tidbit-fn-initial-pc proc)
               (tidbit-fn-doc proc))))

(define (parcel-out-proc proc)
<<;; Walk PROC emitting a new function every so many levels, to keep>>
<<;;  the complexity of the emitted Cedar code down.  Return the depth>>
<<;;  of tidbit-fn-nesting within this proc or a string, giving the name>>
<<;;  of the Cedar function computing this much of the tree.>>
(define (make-cedar-auxilliary-fn)
(dynamic-set! *start-proc-maker-index*
           (+ (dynamic-ref *start-proc-maker-index*) 1))
(emit-nest
(format #f "MakeStartProc~S: PROC RETURNS [TidbitCode] ~~ {"
        (dynamic-ref *start-proc-maker-index*)))
(emit-nest "RETURN[")
(compute-proc proc)
(emit-unnest "];")
(emit-unnest "};")
(emit-newline)
(format #f "MakeStartProc~S"
        (dynamic-ref *start-proc-maker-index*)))

(let loop ((literals (tidbit-fn-literals proc))
        (max-depth 0))
(if (null? literals)
(if (= max-depth make-tidbit-fn-threshhold)
(make-cedar-auxilliary-fn)
(+ 1 max-depth))
(if (tidbit-fn? (car literals))
(let ((result (parcel-out-proc (car literals))))
(cond 
((string? result)
(set-car! literals result)
(loop (cdr literals) max-depth))
(else
(loop (cdr literals) (max result max-depth)))))
(loop (cdr literals) max-depth)))))

(emit-newline)
(emit-nest "{")
(let ((depth-or-fn (parcel-out-proc start-proc)))
(emit-nest "startProc _ NEW[TidbitProcedureRep _ [env: NIL, code:")
(if (string? depth-or-fn)
(emit (format #f "~A[]" depth-or-fn))
(compute-proc start-proc)))
(emit-unnest "]];")
(emit-unnest "};"))

(define (value->binary-string value)
(let ((p (open-output-string)))
(binary-write value p)
(get-output-string p)))

(define (value->string value)
(let ((p (open-output-string)))
(write value p)
(get-output-string p)))
<<>>
<<;;; Noise management>>
<<>>
(define (print-top-level-form indent form)
(display indent)
(change-looks "f")
(let loop ((form form)
        (length 2)
        (in-list? #f))
(cond
((null? form)
(if in-list?         ; ( for paren-matching
(display ")")
(display "()")))
((pair? form)
(cond
((memq (car form) '(quote #!quote))
(display "'")
(loop (cadr form) length #f))
(else
(unless in-list?
(display "("))    ; ) for paren-matching
(cond
((zero? length)   ; ( for paren-matching
(display "...)"))
(else
(loop (car form) 1 #f)
(unless (null? (cdr form))
(display " "))
(loop (cdr form) (- length 1) #t))))))
(in-list?        ; dotted list
(display ". ")
(loop form length #f)    ; ( for paren-matching
(display ")"))
((primitive-syntax-marker? form)
(write (primitive-syntax-marker->symbol form)))
(else
(write form))))
(change-looks "F")
(newline))

<<;;; Output file management>>

(define *cedar-output* (make-dynamic (current-output-port)))

(define *cedar-indent* (make-dynamic ""))

(define (emit string)
(format (dynamic-ref *cedar-output*) "~A~A~%"
(dynamic-ref *cedar-indent*) string))

(define (emit-newline)
(display (dynamic-ref *cedar-indent*) (dynamic-ref *cedar-output*))
(newline (dynamic-ref *cedar-output*)))

(define (emit-nest string)
(emit string)
(dynamic-set! *cedar-indent*
           (string-append (dynamic-ref *cedar-indent*) "    ")))

(define (emit-unnest string)
(emit string)
(unnest))

(define (unnest)
(dynamic-set! *cedar-indent*
           (substring (dynamic-ref *cedar-indent*)
                   4
                (string-length (dynamic-ref *cedar-indent*)))))

) ; end export