<<>>
<<;;; Hobbit.scheme>>
<<;;; Copyright Ó 1989, 1991 by Xerox Corporation.  All rights reserved.>>
<<;;; Last changed by Pavel on April 2, 1990 6:19 pm PDT>>
<<;;; Michael Plass, December 27, 1990 1:06 pm PST>>

<<;;; Fast compilation into bytecodes; a "hasty halfling" compiler.>>

(export (*system-compiler* hobbit-file)

(define (*system-compiler* expr env)
"This is what Scheme.Compile calls"
(%byte-code-template->procedure (assemble (compile expr)) env))

(define (hobbit-file file-name-root)
"writes a bytecode-compiled file"
(let* ((input-file-name (string-append file-name-root ".scheme"))
    (output-file-name (string-append file-name-root ".$cheme"))
 (in (open-input-file input-file-name))
 (out (open-output-file output-file-name)))
(let loop ((form (read in)))
(unless (eof-object? form)
(print-top-level-form form)
(let ((xform (assemble (compile (expand form)))))
(binary-write xform out)
(newline out)
(loop (read in)))))
(close-input-port in)
(close-output-port out)))

(define (compile expr)
(compile-lambda "Interpreted Code" '() (list expr) '() '()))

(define (assemble acode) (%assembly-code->byte-code-template acode))

(define (print-top-level-form form)
(change-looks "f")
(display "   ")
(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))

(define (compile-lambda name params body env code)
(define (inner name-list nargs dotted?)
(dynamic-bind ((*next-label* 0)
            (*max-depth* 0)
         (*name-list* name-list))
(let ((code (compile-expression `(#!begin ,@body)
                             (nest-env env name-list)
                          'return
                       1
                    '()))
(doc (if (and (string? (car body))
           (not (null? (cdr body))))
  (car body)
  "")))
`(,name
  ,nargs
  ,nargs
  ,dotted?
  ,(list->vector (dynamic-ref *name-list*))
  ,(if (eqv? doc "")
   (format #f "~S" params)
(if (char=? #\( (string-ref doc 0)) ; )
doc
(format #f "~S ~A" params doc)))
  ,(dynamic-ref *next-label*)
  (enter ,(dynamic-ref *max-depth*))
  ,@(reverse code)))))

(let loop ((name-list '())
        (params params)
     (nargs 0))
(cond
((null? params)
(inner (reverse name-list) nargs #f))
((symbol? params)
(inner (reverse (cons params name-list)) nargs #t))
(else
(loop (cons (car params) name-list)
   (cdr params)
(+ nargs 1))))))

(define (lambda-expr? expr)
(and (pair? expr) (eq? (car expr) '#!lambda)))

(define (name-lambda name expr)
(if (and (symbol? name) (lambda-expr? expr))
`(%%lambda-with-name%% ,name ,(cadr expr) ,@(cddr expr))
expr))

(define (compile-expression expr env ctxt depth code)
;; CTXT is one of VALUE, RETURN, or EFFECT
(if (pair? expr)
(case (car expr)
((#!define)
(if (equal? env '((0)))    ; "Top-level" form
(let ((name (cadr expr))
   (expr (caddr expr)))
(compile-expression
`(#!begin
(#!set! ,name ,expr)
(#!quote ,name))
env ctxt depth code))
(error '*system-compiler* expr "Misplaced definition")))
((#!if)
(if (eq? ctxt 'return)
(let ((else-label (next-label!)))
(compile-expression (cadddr expr) env ctxt depth
(cons `(label ,else-label)
(compile-expression (caddr expr) env ctxt depth
(cons `(fjump ,else-label)
(compile-expression (cadr expr) env 'value depth code))))))
(let ((else-label (next-label!))
    (after-label (next-label!)))
(cons `(label ,after-label)
(compile-expression (cadddr expr) env ctxt depth
(cons `(label ,else-label)
(cons `(jump ,after-label)
(compile-expression (caddr expr) env ctxt depth
(cons `(fjump ,else-label)
(compile-expression (cadr expr) env 'value depth code))))))))))
((#!set!)
(let ((code
    (cons (lookup (cadr expr) env 'pop-global 'pop-local)
       (compile-expression
      (name-lambda (cadr expr) (caddr expr))
      env 'value depth code))))
(if (eq? ctxt 'effect)
code
(compile-expression '(#!quote #!unspecified) env ctxt depth code))))
((#!lambda)
(compile-push
`(close ,(compile-lambda "Anonymous function" (cadr expr) (cddr expr) env '()))
ctxt depth code))
((%%lambda-with-name%%)
(compile-push
`(close ,(compile-lambda (cadr expr) (caddr expr) (cdddr expr) env '()))
ctxt depth code))
((#!begin)
(if (null? (cdr expr))
(compile-expression '(#!quote #!unspecified) env ctxt depth code)
(let loop ((tail (cdr expr))
         (code code))
(if (null? (cdr tail))
(compile-expression (car tail) env ctxt depth code)
(loop (cdr tail)
(compile-expression (car tail) env 'effect depth code))))))
((#!quote)
(compile-push `(push-literal ,(cadr expr)) ctxt depth code))
(else
(let ((fn (car expr)))
(if (and (pair? fn)
      (eq? (car fn) '#!lambda)
   (or (null? (cadr fn))
    (null? (cdr (last-pair (cadr fn))))))
<<;; It's a LET>>
(let ((body-env (extend-env env (cadr fn))))
(let loop ((params (cadr fn))
        (args (cdr expr))
     (code code))
(cond
((null? params)
(unless (null? args)
(error '*system-compiler*
    args
 "Extra arguments to inline LAMBDA"))
(compile-expression `(#!begin ,@(cddr fn)) body-env ctxt depth code))
((null? args)
(error '*system-compiler*
    params
    "Too few arguments to inline LAMBDA"))
(else
(loop (cdr params)
   (cdr args)
(cons
(lookup (car params) body-env 'nonsense 'pop-local)
(compile-expression (car args) env 'value depth code)))))))
<<;; It's a normal application>>
(let loop ((exprs expr)
        (code code)
     (depth depth))
(if (null? exprs)
(let ((nargs (length (cdr expr))))
(case ctxt
((return)
`((tail-call ,nargs)
  ,@code))
((effect)
`((pop)
  (call ,nargs)
  ,@code))
((value)
`((call ,nargs)
  ,@code))))
(loop (cdr exprs)
   (compile-expression (car exprs) env 'value depth code)
(+ depth 1))))))))

;; EXPR is not a pair
(cond
((symbol? expr)
(compile-push (lookup expr env 'push-global 'push-local) ctxt depth code))
((or (number? expr)
   (boolean? expr)
 (char? expr)
 (string? expr))
(compile-push `(push-literal ,expr) ctxt depth code))
(else
(error '*system-compiler* expr "Unevaluable expression")))))

(define (compile-push inst ctxt depth code)
(case ctxt
((effect)
code)
((value)
(try-depth! depth)
(cons inst code))
((return)
(try-depth! depth)
(cons '(return) (cons inst code)))))

(define *next-label* (make-dynamic 0))

(define (next-label!)
(let ((x (dynamic-ref *next-label*)))
(dynamic-set! *next-label* (+ x 1))
x))

(define *max-depth* (make-dynamic 0))

(define (try-depth! depth)
(dynamic-set! *max-depth* (max depth (dynamic-ref *max-depth*))))

(define (nest-env env names)
(cons (cons 0 names) env))

(define *name-list* (make-dynamic '()))

(define (extend-env env names)
(let ((index (length (dynamic-ref *name-list*))))
(dynamic-set! *name-list* (append (dynamic-ref *name-list*) names))
(cons (append (cons index names) (car env))
   (cdr env))))

(define (lookup id env global-inst local-inst)
(let outer ((env env)
         (up 0))
(if (null? env)
`(,global-inst ,id)
(let inner ((frame (car env))
         (over 0))
(cond
((null? frame)
(outer (cdr env) (+ up 1)))
((eq? id (car frame))
`(,local-inst ,up ,over))
((integer? (car frame))
(inner (cdr frame) (car frame)))
(else
(inner (cdr frame) (+ over 1))))))))

) ; end export