(* Filed on: {phylum}<desrivieres>nlisp>beaver-compiler *)
(* Beaver - #2 compiler for 2-LISP. *)
(* Last modified: Dec. 14th, 1983 by Jim des Rivieres. *)
(* Mode: InTeRlIsP *)
(constants *return-opcode* *const-opcode* *var-opcode*
*pcheck-opcode* *call-opcode* *start-opcode*
*tstart-opcode* *ostart-opcode* *tostart-opcode*
*lambda-opcode* *if-opcode* *primitive-opcode*
*gset-opcode* *halt-opcode*)
(defun initialise-opcodes ()
(setq *return-opcode* 0)
(setq *const-opcode* 1)
(setq *var-opcode* 2)
(setq *pcheck-opcode* 3)
(setq *call-opcode* 4)
(setq *start-opcode* 5)
(setq *tstart-opcode* 6)
(setq *ostart-opcode* 7)
(setq *tostart-opcode* 8)
(setq *lambda-opcode* 9)
(setq *if-opcode* 10)
(setq *primitive-opcode* 11)
(setq *gset-opcode* 12)
(setq *halt-opcode* 13))
(initialise-opcodes) (* Since they are constants. *)
(defun b-prettycode (code)
(for x in code collect
(cons (b-opcode (car x))
(if (equal (car x) *if-opcode*) then
(cons
(b-prettycode (cadr x))
(cons
(b-prettycode (caddr x))
(cdddr x)))
else
(if (equal (car x) *lambda-opcode*) then
(cons
(make-skeleton
(reflective? (cadr x))
(spread? (cadr x))
(nexpected (cadr x))
(variable-list (cadr x))
(b-prettycode (start-address (cadr x)))
(comment (cadr x))
(export (source-exp (cadr x)))))
else
(cdr x))))))
(defun b-opcode (n)
(select n
(*return-opcode* 'return)
(*const-opcode* 'const)
(*var-opcode* 'var)
(*pcheck-opcode* 'pcheck)
(*call-opcode* 'call)
(*start-opcode* 'start)
(*tstart-opcode* 'tstart)
(*ostart-opcode* 'ostart)
(*tostart-opcode* 'tostart)
(*lambda-opcode* 'lambda)
(*if-opcode* 'if)
(*primitive-opcode* 'primitive)
(*gset-opcode* 'gset)
(*halt-opcode* 'halt)
(list '**bad-opcode** n)))
(defun bc (x)
(b-prettycode (beaver (import x) global-env)))
(defun beaver (exp env)
(b-compile exp env ()))
(defun b-compile (exp env code)
(cond ((atom? exp)
(b-compile-variable exp env code))
((rail? exp)
(b-compile-rail exp env code))
((pair? exp)
(b-compile-pair exp env code))
(t (b-compile-constant exp env code))
))
(defun b-compilation-error (message exp)
(error message (export exp)))
(defun b-terminate (code)
(if (null code) then
(list (list *return-opcode*))
else
code))
(defun b-compile-constant (exp env code)
(cons (list *const-opcode* exp) (b-terminate code)))
(defun b-compile-variable (exp env code)
(cons (list *var-opcode* exp) (b-terminate code)))
(defun b-binding (var env)
(if (null env) then
(nlisp-global-binding var)
else
(if (fmemb var (car env)) then
'local.variable
else
(b-binding var (cdr env)))))
(defun b-compile-pair (exp env code)
(let ((proc (pcar exp)))
(if (and (not (atom? proc)) (not (closure? proc))) then
(b-compile-application exp env code)
else
(let ((expectation
(if (atom? proc) then
(b-binding proc env)
else
proc)))
(cond ((lambda? expectation)
(b-compile-lambda exp env code))
((if? expectation)
(b-compile-if exp env code))
((gset? expectation)
(b-compile-gset exp env code))
((let? expectation)
(b-compile-let exp env code))
(t (b-compile-application exp env code)))))))
(defun b-compile-application (exp env code)
(let ((proc (pcar exp))
(args (pcdr exp)))
(if (rail? args) then
(cons (list
(if (null code) then
*tstart-opcode*
else *start-opcode*)
(rlength args))
(b-compile proc env
(cons (list *pcheck-opcode*)
(b-compile-tail args env
(cons (list *call-opcode*) code)))))
else
(cons (list
(if (null code) then
*tostart-opcode*
else *ostart-opcode*))
(b-compile proc env
(cons (list *pcheck-opcode*)
(b-compile args env
(cons (list *call-opcode*) code))))))))
(defun b-compile-tail (exp env code)
(if (empty? exp) then
code
else
(b-compile (first exp) env
(b-compile-tail (rest exp) env code))))
(defun b-compile-rail (exp env code)
(b-compile
(pcons sequence-closure exp)
env
code))
(defun b-compile-lambda (exp env code)
(let ((args (pcdr exp)))
(if (or (not (rail? args)) (not (equal (rlength args) 2))) then
(b-compilation-error "Mangled LAMBDA" exp))
(let ((pattern-info (b-analyze-pattern (first args)))
(body (second args)))
(let ((code-for-body
(b-compile body
(cons (variable-list pattern-info) env)
(list))))
(cons (list *lambda-opcode*
(make-skeleton nil
(car pattern-info)
(cadr pattern-info)
(caddr pattern-info)
code-for-body
"User-defined."
exp))
(b-terminate code))))))
(defun b-analyze-pattern (pat)
(cond ((atom? pat)
(list nil 1 (list (extract-atom pat))))
((rail? pat)
(let ((var-list (rail-to-list pat)))
(if (every var-list
(function (lambda (x) (atom? x)))) then
(list t (length var-list) var-list)
else
(b-compilation-error
"Mangled LAMBDA pattern" pat))))
(t (b-compilation-error
"Mangled LAMBDA pattern" pat))))
(defun b-compile-if (exp env code)
(let ((args (pcdr exp)))
(if (or (not (rail? args)) (not (equal (rlength args) 3))) then
(b-compilation-error "Mangled IF" exp))
(let ((premise (first args))
(consequent (second args))
(alternate (third args)))
(b-compile premise env
(list (list *if-opcode*
(b-compile consequent env code)
(b-compile alternate env code)))))))
(defun b-compile-gset (exp env code)
(let ((args (pcdr exp)))
(if (or (not (rail? args))
(not (equal (rlength args) 2))
(not (atom? (first args)))) then
(b-compilation-error "Mangled GSET" exp))
(let ((variable (first args))
(rhs (second args)))
(b-compile rhs env
(cons (list *gset-opcode* variable)
(b-terminate code))))))
(defun b-compile-let (exp env code)
(let ((arguments (pcdr exp)))
(if (or (not (rail? arguments))
(not (equal (rlength arguments) 2))
(not (rail? (first arguments)))) then
(b-compilation-error "Mangled LET" exp))
(let ((body (second arguments))
(binding-pairs
(for x in (rail-to-list (first arguments)) collect
(if (or (not (rail? x))
(not (equal (rlength x) 2))
(not (atom? (first x)))) then
(b-compilation-error "Mangled LET" exp))
(list (first x) (second x))) ))
(b-compile
(pcons
(pcons lambda-closure
(prep
(list-to-rail
(mapcar binding-pairs (function car)))
(prep body
(rcons0))))
(list-to-rail (mapcar binding-pairs (function cadr))))
env
code))))
STOP