[_CDCSL_93-16_]<1>Cedar>release>Scheme>TidbitTop.scheme

;;; TidbitTop.scheme

;;; 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*))

(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*)

(string-length (dynamic-ref *cedar-indent*)))))

) ; end export