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

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

;; Get the name right

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

;; Is it a LET? It is if the FN is a LAMBDA expression

;; with an undotted parameter list.

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

;; EXPR is not a pair

(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