(* Filed on: {phylum}<desrivieres>nlisp>aardvark *)
(* Aardvark - #1 compiler for 2-LISP. *)
(* Last modified: Nov. 8th, 1983 by Jim des Rivieres. *)
(* Mode: InTeRlIsP *)
(globalvars *return-opcode* *const-opcode* *var-opcode*
*pcheck-opcode* *call-opcode* *tail-call-opcode*
*call-objectified-opcode* *tail-call-objectified-opcode*
*lambda-opcode* *if-opcode* *primitive-opcode*
*gset-opcode* *rcons-opcode* *halt-opcode*)
(defun initialise-aardvark ()
(setq *return-opcode* 0)
(setq *const-opcode* 1)
(setq *var-opcode* 2)
(setq *pcheck-opcode* 3)
(setq *call-opcode* 4)
(setq *tail-call-opcode* 5)
(setq *call-objectified-opcode* 6)
(setq *tail-call-objectified-opcode* 7)
(setq *lambda-opcode* 8)
(setq *if-opcode* 9)
(setq *primitive-opcode* 10)
(setq *gset-opcode* 11)
(setq *rcons-opcode* 12)
(setq *halt-opcode* 13))
(defun a-prettycode (code)
(for x in code collect
(cons (a-opcode (car x))
(if (equal (car x) *if-opcode*) then
(cons
(a-prettycode (cadr x))
(cons
(a-prettycode (caddr x))
(cdddr x)))
else if (equal (car x) *lambda-opcode*) then
(cons
(cadr x)
(cons
(a-prettycode (caddr x))
(cdddr x)))
else
(cdr x)))))
(defun a-opcode (n)
(select n
(*return-opcode* 'return)
(*const-opcode* 'const)
(*var-opcode* 'var)
(*pcheck-opcode* 'pcheck)
(*call-opcode* 'call)
(*tail-call-opcode* 'tail-call)
(*call-objectified-opcode* 'call-objectified)
(*tail-call-objectified-opcode* 'tail-call-objectified)
(*lambda-opcode* 'lambda)
(*if-opcode* 'if)
(*primitive-opcode* 'primitive)
(*gset-opcode* 'gset)
(*rcons-opcode* 'rcons)
(*halt-opcode* 'halt)
(list '**bad-opcode** n)))
(defun ac (x)
(a-prettycode (aardvark (import x) global-env)))
(defun aardvark (exp env)
(a-compile exp env ()))
(defun a-compile (exp env code)
(cond ((atom? exp)
(a-compile-variable exp env code))
((rail? exp)
(a-compile-rail exp env code))
((pair? exp)
(a-compile-pair exp env code))
(t (a-compile-constant exp env code))
))
(defun a-terminate (code)
(if (null code) then
(list (list *return-opcode*))
else
code))
(defun a-compile-constant (exp env code)
(cons (list *const-opcode* exp) (a-terminate code)))
(defun a-compile-variable (exp env code)
(cons (list *var-opcode* exp) (a-terminate code)))
(defun a-binding (var env)
(if (null env) then
(let ((val (gethash var global-env-hash-array)))
(if (eq val 'nil.surrogate) then
nil
else if (null val) then
'not.found
else
val))
else
(if (member var (car env)) then
'local.variable
else
(a-binding var (cdr env)))))
(defun a-compile-pair (exp env code)
(let ((proc (pcar exp)))
(if (and (not (atom? proc)) (not (closure? proc))) then
(a-compile-application exp env code)
else
(let ((expectation
(if (atom? proc) then
(a-binding proc env)
else
proc)))
(cond ((lambda? expectation)
(a-compile-lambda exp env code))
((if? expectation)
(a-compile-if exp env code))
((gset? expectation)
(a-compile-gset exp env code))
((let? expectation)
(a-compile-let exp env code))
(t (a-compile-application exp env code)))))))
(defun a-compile-application (exp env code)
(let ((proc (pcar exp))
(args (pcdr exp)))
(a-compile proc env
(cons (list *pcheck-opcode*)
(if (rail? args) then
(a-compile-tail args env
(if (not (null code)) then
(cons
(list *call-opcode*
(rlength args))
code)
else
(list
(list *tail-call-opcode*
(rlength args)))))
else
(a-compile args env
(if (not (null code)) then
(cons
(list *call-objectified-opcode*)
code)
else
(list
(list *tail-call-objectified-opcode*)))))))))
(defun a-compile-tail (exp env code)
(if (empty? exp) then
code
else
(a-compile (first exp) env
(a-compile-tail (rest exp) env code))))
(defun a-compile-rail (exp env code)
(a-compile-tail exp env
(cons (list *rcons-opcode* (rlength exp))
(a-terminate code))))
(defun a-compile-lambda (exp env code)
(let ((args (pcdr exp)))
(if (or (not (rail? args)) (not (equal (rlength args) 2))) then
(a-compilation-error "Mangled LAMBDA" exp))
(let ((pattern-info (a-analyze-pattern (first args)))
(body (second args)))
(let ((compiled-body
(a-compile body
(cons (cadr pattern-info) env)
(list))))
(cons (list *lambda-opcode*
pattern-info
compiled-body)
(a-terminate code))))))
(defun a-analyze-pattern (pat)
(cond ((atom? pat)
(list -1 (extract-atom pat)))
((rail? pat)
(let ((var-list (rail-to-list pat)))
(if (every var-list 'atom?) then
(cons (length var-list) (reverse var-list))
else
(a-compilation-error
"Mangled LAMBDA pattern" pat))))
(t (a-compilation-error
"Mangled LAMBDA pattern" pat))))
(defun a-compile-if (exp env code)
(let ((args (pcdr exp)))
(if (or (not (rail? args)) (not (equal (rlength args) 3))) then
(a-compilation-error "Mangled IF" exp))
(let ((premise (first args))
(consequent (second args))
(alternate (third args)))
(a-compile premise env
(list (list *if-opcode*
(a-compile consequent env code)
(a-compile alternate env code)))))))
(defun a-compile-gset (exp env code)
(let ((args (pcdr exp)))
(if (or (not (rail? args))
(not (equal (rlength args) 2))
(not (atom? (first args)))) then
(a-compilation-error "Mangled GSET" exp))
(let ((variable (first args))
(rhs (second args)))
(a-compile rhs env
(cons (list *gset-opcode* variable)
(a-terminate code))))))
(defun a-compile-let (exp env code)
(let ((args (pcdr exp)))
(if (or (not (rail? args))
(not (equal (rlength args) 2))
(not (rail? (first args)))) then
(a-compilation-error "Mangled LET" exp))
(let ((body (second args))
(binding-pairs
(for x in (rail-to-list (first args)) collect
(if (or (not (rail? x))
(not (equal (rlength x) 2))
(not (atom? (first x)))) then
(a-compilation-error "Mangled LET" exp))
(list (first x) (second x))) ))
(a-compile
(pcons
(pcons lambda-closure
(prep
(list-to-rail
(mapcar binding-pairs 'car))
(prep body
(rcons0))))
(list-to-rail (mapcar binding-pairs 'cadr)))
env
code))))
STOP