; gen.txt   n-code to s-code generator
;   gen completion kit
;   edit evalx, genwhile

; include lib.txt

; -------- header ----------

(enum 127 EOF)
(enum 0 NIL)
(enum 1000 MAXSYS)		; start of DS for s-code
(enum 3000 MEMMAX)

; n-code
(enum 1
  xIF xWHILE xDO xUD1 xNEW xADD xSUB xMUL xDIV
  xEQ xLT xGT xCALL xGET xPUT xLIT xLDX xSTX xFUN
  xSYS xSET xSETV xVEC xUD2 xLD xST xLDY xSTY xUD3
  xUD4 xUD5 xSTR xBAND xSHR xSHL)

; s-code used with som-v2
(enum 1
  icAdd icSub icMul icDiv icBand icBor icBxor icNot icEq
  icNe icLt icLe icGe icGt icShl icShr icMod icLdx icStx
  icRet icRetv icArray icEnd icGet icPut icLd icSt icJmp icJt
  icJf icLit icCall icUd1 icInc icDec icSys icUd2 icFun)

(enum 5678920 magic) ; header of s-code v2 object

(let tok DP Dend CS)
(let XS XP)			; s-code area, pointer
(let atab numLab)	; assoc table

(def init () ()
  (do
  (set XS (new MEMMAX)) ; s-code
  (set XP 3)			; s-code pointer
  (set atab (new 1000)) ; assoc table, max 490 labels
  (set numLab 0)))

; ----- system --------

(def tokenise () ()
  (set tok (sys 3)))

(def prList e () (sys 10 e))

(def de_op x () (& (>> x 24) 127))
(def de_arg x () (& x 16777215))	; x & 0x0ffffff

(def isATOM e () (< e 0))	; MSB bit 1
(def mkATOM (op arg) ()
  (+ (<< (+ (& op 127) 128) 24) (& arg 16777215)))

; ------- load object -----------

(let Start)

(def read () ()
  (do
  (tokenise)
  (atoi tok)))

(def shift (a disp) ()
  (if a
    (- (+ a disp) 2)
    0))

(def reName (op arg) (v v2)
  (do
  (set v2 (+ arg MAXSYS))	; for DS
  (if (= op xCALL) (set v (shift arg CS))
  (if (= op xLD) (set v v2)
  (if (= op xST) (set v v2)
  (if (= op xLDY) (set v v2)
  (if (= op xSTY) (set v v2)
  (if (= op xSTR) (set v v2)
  ; else
  (set v arg)))))))
  (mkATOM op v)))

(def loadobj () (flag end a a2 ads ty op arg next)
  (do
  (set CS (sys 9))		; start of code segment
  (set Start (read))
  (set end (read))
  (set DP (+ CS end))
  (set flag 1)
  (while flag
    (do
    (set ads (read))
    (set ty (read))
    (set op (read))
    (set arg (read))
    (set next (read))
    (if ty
      (set a (reName op arg))
      ; else dot-pair
      (set a (shift (+ (<< op 24) arg) CS)))
    (set a2 (new 2))
    (sethead a2 a)
    (settail a2 (shift next CS))
    (if (= ads end) (set flag 0))))

    ; load data segment
    (set a 0)
    (set Dend (read))
    (while (< a Dend)
      (do
      (set a2 (new 1))
      (setv a2 0 (read))
      (set a (+ a 1))))))

; ---- assoc table for label -----

(enum 2 esize)
(enum 490 MAXLAB)		; max no of label

; search assoc for n1
; if found, return n2, else 0
(def assoc n1 (i flag end)
  (do
  (set i 2)				; start at 2
  (set flag 1)
  (set end (+ (* esize numLab) 2))
  (while (and flag (< i end))
    (if (= (vec atab i) n1)		; sequential search
      (set flag 0)
      ; else
      (set i (+ i esize))))
  (if flag
    0							; not found
    (vec atab (+ i 1)))))		; found, return n2

(def insertLab (n1 n2) (i)
  (do
  (set i (+ (* numLab esize) 2)) ; start at 2
  (setv atab i n1)
  (setv atab (+ i 1) n2)
  (set numLab (+ numLab 1))
  (if (> numLab MAXLAB)
    (error "label table full"))))

(def dumpassoc () (i end)
  (do
  (set i 2)
  (set end (+ (* numLab esize) 2))
  (while (< i end)
    (do
    (print (vec atab i)) (space)
    (print (vec atab (+ i 1))) (nl)
    (set i (+ i esize))))))

; -------- icode -------------

(def outa (op arg) ()
  (do
  (setv XS XP (+ (<< arg 8) op))
  (set XP (+ XP 1))))

(def outs op ()
  (do
  (setv XS XP op)
  (set XP (+ XP 1))))

; change arg, preserve op
(def patch (ads v) ()
  (setv XS ads (+ (<< v 8) (& (vec XS ads) 255))))

; --------- eval ----------

(def eval e () 0) 	; forward declaration

(def genbop (op e1 e2) ()
  (do
  (eval e1)
  (eval e2)
  (outs op)))

(def genuop (op arg e) ()
  (do
  (eval e)
  (outa op arg)))

; e = (cond true false)
(def genif e (ads e3)
  (do
  (eval (head e))			; gen cond
  (outa icJf 0)
  (set ads (- XP 1))
  (eval (arg2 e))			; gen if-true
  (set e3 (arg3 e))
  (if (= e3 NIL)
    (patch ads (- XP ads))
    ; else
    (do					; else
    (outa icJmp 0)
    (patch ads (- XP ads))
    (set ads (- XP 1))
    (eval e3)				; gen else
    (patch ads (- XP ads))))))

; stub definition
(def genwhile (e) (ads) 0)

; stub definition, edit at 0
(def evalx (op arg e) ()	; e is arg-list
  (if (= op xNEW) 0
  (if (= op xSUB) 0
  (if (= op xMUL) 0
  (if (= op xDIV) 0
  (if (= op xBAND) 0
  (if (= op xSHR) 0
  (if (= op xSHL) 0
  (if (= op xEQ) 0
  (if (= op xLT) 0
  (if (= op xGT) 0
  (if (= op xSTX) 0
  (if (= op xLDY) 0
  (if (= op xSTY) 0
  ; else
  (error "unknown op")))))))))))))))

(def eval e (ads e1 op arg lv arity)
  (if (= e NIL)
    NIL
    ; else
    (do
    (set ads e)
    (if (not (isATOM e))
      (do
      (set e1 (tail e))
      (set e (head e))))
    (set op (de_op e))
    (set arg (de_arg e))
;	(prList e)
    (if (= op xIF) (genif e1)
    (if (= op xWHILE) (genwhile e1)
    (if (= op xDO)
      (while e1
        (do
        (eval (head e1))
        (set e1 (tail e1))))
    (if (= op xADD)
      (genbop icAdd (head e1) (arg2 e1))
    (if (= op xCALL)
      (do
      (while e1
        (do
        (eval (head e1))
        (set e1 (tail e1))))
      (outa icCall (assoc arg)))
    (if (= op xLIT) (outa icLit arg)
    (if (= op xSTR) (outa icLit arg)
    (if (= op xGET) (outa icGet arg)
    (if (= op xPUT) (genuop icPut arg (head e1))
    (if (= op xLD) (outa icLd arg)
    (if (= op xST) (genuop icSt arg (head e1))
    (if (= op xLDX)
      (do
      (outa icGet arg)
      (eval (head e1))
      (outs icLdx))
    (if (= op xFUN)
       (do
       (insertLab ads XP)
       (set lv (& arg 255))
       (set arity (>> arg 8))
       (outa icFun (+ (- lv arity) 1))
       (eval (head e1))
       (outa icRet (+ lv 1)))
    (if (= op xSYS) (genuop icSys arg (head e1))
    ; else
    (evalx op arg e1)))))))))))))))
    )))

(def outsobj () (i end)
  (do
  (print magic) (nl)
  (print 1) (space)
  (print (- XP 1)) (nl)
  (set i 1)
  (while (< i XP)
    (do
    (print (vec XS i)) (space)
    (if (= (& i 7) 0) (nl))
    (set i (+ i 1))))
  (nl)
  (print MAXSYS) (space)		; data segment
  (print (+ MAXSYS (- Dend 1))) (nl)
  (set i DP)
  (set end (+ DP Dend))
  (while (< i end)
    (do
    (print (vec i 0)) (space)
    (if (= (& i 7) 0) (nl))
    (set i (+ i 1))))
  (nl)))

(def genall () (i op end)
  (do
  (set i CS)
  (set end DP)
  (while (< i end)
    (do
    (set op (de_op (vec i 0)))
    (if (= op xFUN) (eval i))
    (set i (+ i 2))))
  (set i XP)
  (set XP 1)
  (outa icCall (assoc (shift Start CS)))
  (outs icEnd)
  (set XP i)))

(def main () ()
  (do
  (sys 11)		; readinfile
  (loadobj)
  (init)
  (genall)
  (outsobj)))

; End