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

;;; Hobbit.scheme

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

'()))

(doc (if (and (string? (car body))

(not (null? (cdr body))))

(car body)

"")))

`(,name

,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