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