(defun clone-code (code-array)
   (prog (clone)
      (if (not (ccodep code-array)) then
          (error "compiled code expected" code-array))
      (setq clone (\codearray (arraysize code-array) 8))
      (for i from 0 to (sub1 (arraysize code-array)) do
         (seta clone i (elt code-array i)))
      (return clone)))

(defun last-used-code-byte (code-array)
   (if (not (ccodep code-array)) then
       (error "compiled code expected" code-array))
   (for i from (sub1 (arraysize code-array)) to 0 by -1
          until (not (zerop (elt code-array i))) 
     finally (return i)))

(defun 3-lisp-dummy ()
   nil)

(defun c3 (3-code)
  (prog ()
     (setq \fccodearray (clone-code (getd '3-lisp-dummy)))
     (setq \fccodesize (arraysize \fccodearray)) 
     (cbyte0 0
        (cbyte0 (op# return)
           (compile-to-bytecode 3-code 
              (last-used-code-byte \fccodearray))))
     (cbyte0 100 1)  (* Increase STKMIN *)
     (printcode \fccodearray)
     (putd 'try \fccodearray)
     (return \fccodearray)))

(defun compile-to-bytecode (3-code pc)
   (prog ((npc pc))
      (for instr in 3-code do
         (setq npc (compile-3-code-instruction instr npc)))
      (return npc)))

(defun declare-3codes ()
   (setq \opcodes (append \opcodes
     '((60q 3var 2 atom 0 nil 3var.ufn)
       (61q 3const 0 t -1 nil 3const.ufn)
       (62q 3pcheck 0 t 0 nil 3pcheck.ufn)
       (63q 3return 0 t 0 nil 3return.ufn)
       (64q 3call 1 t 0 nil 3call.ufn)
       (65q 3tcall 1 t 0 nil 3tcall.ufn)
       (66q 3ocall 0 t 0 nil 3ocall.ufn)
       (67q 3tocall 0 t 0 nil 3tocall.ufn)
       (70q 3lambda 0 t -1 nil 3lambda.ufn)
       (71q 3if 0 t 1 nil 3if.ufn)
       (72q 3primitive 0 atom -1 nil 3primitive.ufn)
       (73q 3gset 0 t -1 nil 3gset.ufn)
       (347q 3rcons 1 t 0 nil 3rcons.ufn))))
   (setq \opcodearray nil) (* Force it to be rebuilt. *)
   nil)


(defun compile-3-code-instruction (instruction pc)
  (prog (opcode new-pc d)
     (setq opcode (car instruction))
     (select opcode
       (*return-opcode*
         (setq new-pc 
           (cbyte0 (op# 3return) pc)))
       (*var-opcode*
         (setq d (\loloc (cadr instruction))) 
         (setq new-pc
            (cbyte0 (logand d 377q)
              (cbyte0 (lrsh d 10q)          
                (cbyte0 (op# 3var) pc)))))
       (*const-opcode* 
         (setq new-pc
            (cbyte0 (op# 3const)
               (ccon0 (cadr instruction) pc))))
       (*pcheck-opcode*
         (setq new-pc 
           (cbyte0 (op# 3pcheck) pc)))
       (*call-opcode*
         (setq new-pc 
           (cbyte0 (cadr instruction)
             (cbyte0 (op# 3call) pc))))
       (*tail-call-opcode*
         (setq new-pc 
           (cbyte0 (cadr instruction)
             (cbyte0 (op# 3tcall) pc))))
       (*call-objectified-opcode*
         (setq new-pc
           (cbyte0 (op# 3ocall) pc)))
       (*tail-call-objectified-opcode*
         (setq new-pc 
           (cbyte0 (op# 3tocall) pc)))
       (*lambda-opcode* 
         (setq new-pc
            (compile-3lambda-instruction (cadr instruction)
                (caddr instruction)
                pc)))
       (*primitive-opcode*
         (setq new-pc
             (cbyte0 (op# 3primitive) 
               (ccon0 (cadr instruction) pc))))
       (*gset-opcode*
         (setq new-pc
             (cbyte0 (op# 3gset) 
               (ccon0 (cadr instruction) pc))))
       (*halt-opcode*
         (setq new-pc 
           (cbyte0 (op# return) pc)))
       (*if-opcode* 
         (setq new-pc
            (compile-3if-instruction (cadr instruction)
                (caddr instruction)
                pc)))
       (*rcons-opcode*
         (setq new-pc
             (cbyte0 (cadr instruction) 
               (cbyte0 (op# 3rcons) pc))))
       (shouldnt "opcode not handled (yet)"))
   (return new-pc)))

(defun compile-3lambda-instruction (pattern body pc)
  (prog ((new-pc pc) temp-label)
    (setq new-pc (cjumpx new-pc))
    (setq temp-label new-pc) 
    (setq new-pc 
       (compile-to-bytecode body new-pc))
    (jfix0 (list temp-label) new-pc)  
    (setq new-pc
      (cbyte0 (op# 3lambda) 
        (ccon0 (list pattern temp-label) new-pc)))
    (return new-pc)))


(defun compile-3if-instruction (true-fork false-fork pc)
  (prog ((new-pc pc) else-patch-address endif-patch-address 
          tail-result then-part else-part common-part)
    (setq tail-result (strip-common-tail true-fork false-fork))
    (setq then-part (car tail-result))
    (setq else-part (cadr tail-result))
    (setq common-part (caddr tail-result))
    (setq new-pc
      (cbyte0 (op# 3if) new-pc)) 
    (setq new-pc    
       (cbyte0 (iplus 2 (op# tjump)) new-pc)) 
    (setq new-pc
        (cjumpx new-pc))
    (setq else-patch-address new-pc) 
    (setq new-pc 
       (compile-to-bytecode then-part new-pc))
    (if (not (null else-part)) then
        (setq new-pc
            (cjumpx new-pc))
        (setq endif-patch-address new-pc) 
        (jfix0 (list else-patch-address) new-pc) 
        (setq new-pc 
           (compile-to-bytecode else-part new-pc)) 
        (jfix0 (list endif-patch-address) new-pc)) 
    (setq new-pc 
       (compile-to-bytecode common-part new-pc))  
    (return new-pc)))

(defun strip-common-tail (s1 s2)
   (prog (r1 r2)
      (setq r1 (reverse s1))
      (setq r2 (reverse s2))
      (setq tail ())
   loop
      (if (and (not (null r1))
               (not (null r2))
               (equal (car r1) (car r2))) then
          (setq tail (cons (car r1) tail))
          (setq r1 (cdr r1))
          (setq r2 (cdr r2))
          (go loop))
      (if (null tail) then
          (return (list s1 s2 nil))
       else
          (return (list (reverse r1) (reverse r2) tail)))))

(defun 3RETURN.UFN (top)
   (add (fetch (fx pc) of (\myalink)) 1) -2)top)
(defun 3PCHECK.UFN ()
   100)

   



STOP