; gen2.txt   n-code to s-code generator
;   eval in nut          26 June 2006
;   extend to full set   1 July 2006
;   output symtab        14 July 2006
;   redo for "run" add symtab    15 Aug 2006
;   modify to teach "programming language principle"
;     accept n-obj file from nut32 compiler
;     rename the file to gen21.txt      11 Aug 2009

; ------- lib ------------

(def != (a b) () (if (= a b) 0 1))
(def >= (a b) () (if (< a b) 0 1))
(def <= (a b) () (if (> a b) 0 1))
(def and (a b) ()(if a b 0))
(def or (a b) () (if a 1 b))
(def not a () (if a 0 1))
(def nop () () 0)
(def print a () (sys 1 a))
(def printc c () (sys 2 c))
(def space () () (sys 2 32))
(def nl () () (sys 2 10))
(def exit () () (sys 13))

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

(enum 127 EOF)
(enum 0 NIL)
(enum 2000 MAXSYS)		; start of DS for s-code
(enum 2000 MEMMAX)
(enum 300 MAXNAMES)		; max no. of symbol
(enum 3 tyFUN)

; 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 symtab numNames) 	; symbol table
; (let Runidx)			; idx of "run" function

(def init () ()
  (do
  (set XS (new MEMMAX)) ; s-code
  (set XP 3)			; s-code pointer
  (set symtab (new (* MAXNAMES 6)))
  (set numNames 0)))

; --------- string ----------

(def prstr s ()
  (while (vec s 0)
    (do
    (printc (vec s 0))
    (set s (+ s 1)))))

(def atoi s (a v)		; string to num, no sign
  (do
  (set v 0)
  (set a (vec s 0))
  (while a
    (do
    (set v (- (+ (* v 10) a) 48))
    (set s (+ s 1))
    (set a (vec s 0))))
  v))

; test string equal
(def str= (s1 s2) (flag i c1 c2)
  (do
  (set flag 1)
  (set i 0)
  (while flag
    (do
    (set c1 (vec s1 i))
    (set c2 (vec s2 i))
    (if (!= c1 c2) (set flag 0)
    (if (= c1 0)   (set flag 0)
    (if (= c2 0)   (set flag 0))))
    (set i (+ i 1))))
  (and (= c1 0) (= c2 0))))

; find string length, recursive version
(def strlen s ()
  (if (vec s 0)
    (+ 1 (strlen (+ s 1)))
    0))

; copy string
(def strcpy (s1 s2) a
  (do
  (set a (vec s2 0))
  (while a
    (do
    (setv s1 0 a)
    (set s1 (+ s1 1))
    (set s2 (+ s2 1))
    (set a (vec s2 0))))
  (setv s1 0 0)))

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

(def error s ()
  (do
  (prstr s)
  (sys 12)			; line no
  (sys 13)))		; exit

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

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

(def head e () (vec e 0))
(def tail e () (vec e 1))
(def sethead (e v) () (setv e 0 v))
(def settail (e v) () (setv e 1 v))

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

; ---------- data ---------

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

; ------- symbol table --------

; symbol table is an array
; each item has six elements: name, type, val, arity, lv, sref
; name pointed to a string which is allocated separately

(enum 6 esizeS)		; size of each element

; symtab -- symbol table
; numNames -- number of symbol in symtab

; access functions

(def getName idx () (vec symtab idx))
(def getType idx () (vec symtab (+ idx 1)))
(def getVal idx () (vec symtab (+ idx 2)))
(def getArity idx () (vec symtab (+ idx 3)))
(def getLv idx () (vec symtab (+ idx 4)))
(def getSref idx () (vec symtab (+ idx 5)))
(def setName (idx nm) () (setv symtab idx nm))
(def setType (idx ty) () (setv symtab (+ idx 1) ty))
(def setVal (idx v) () (setv symtab (+ idx 2) v))
(def setArity (idx v) () (setv symtab (+ idx 3) v))
(def setLv (idx v) () (setv symtab (+ idx 4) v))
(def setSref (idx v) () (setv symtab (+ idx 5) v))

; allocate new string
(def newName nm (k)
  (do
  (set k (new (+ (strlen nm) 1)))
  (strcpy k nm)
  k))

(def readsym () (i end)
  (do
  (set numNames (read))
  (set end (* numNames esizeS))
  (set i esizeS)
  (while (<= i end)
    (do
    (read)                      ; throw away address
    (tokenise)                  ; symbol name
    (setName i (newName tok))
    (setType i (read))
    (if (= (getType i) tyFUN)
      (setVal i (shift (read) CS))
      ; else
      (setVal i (read)))
    (setArity i (read))
    (setLv i (read))
    (set i (+ i esizeS))))))

; search symtab for nm
; if found, return its index, else 0
(def searchSym nm (i flag end)
  (do
  (set i esizeS)
  (set flag 1)
  (set end (* esizeS numNames))
  (while (and flag (<= i end))
    (if (str= (getName i) nm)	; sequential search
      (set flag 0)
      ; else
      (set i (+ i esizeS))))
  (if flag (set i 0))           ; not found
  i))

; search symtab for ref
; if found, return its index, else 0
(def searchRef ref (i flag end)
  (do
  (set i esizeS)
  (set flag 1)
  (set end (* esizeS numNames))
  (while (and flag (<= i end))
    (if (= (getVal i) ref)	   ; sequential search
      (set flag 0)
      ; else
      (set i (+ i esizeS))))
  (if flag (set i 0))           ; not found
  i))

(def dumpsym () (i end)
  (do
  (set i esizeS)
  (set end (* esizeS numNames))
  (print numNames) (nl)
  (while (<= i end)
    (do
    (prstr (getName i)) (space)
    (print (getType i)) (space)
    (if (= (getType i) tyFUN)
      (print (getSref i))
      ; else
      (print (+ (getVal i) MAXSYS)))
    (space)
    (print (getArity i)) (space)
    (print (getLv i)) (nl)
    (set i (+ i esizeS))))))

; -------- 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 arg1 e () (head e))
(def arg2 e () (head (tail e)))
(def arg3 e () (head (tail (tail e))))

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

(def genwhile e ads
  (do
  (outa icJmp 0)
  (set ads (- XP 1))
  (eval (arg2 e))			; gen body
  (patch ads (- XP ads))
  (eval (head e))			; gen cond
  (outa icJt (- (+ ads 1) XP))))

; convert arg to index to symtab
; e is arglist
(def gencall (arg e) (idx a)
  (do
  (set idx (searchRef arg))
  (if (= idx Runidx)		; is "run"
    (do
    (outa icLit (+ XP 3))  	; point to code of process
    (outa icCall idx)		; call run
    (set a XP)
    (outa icJmp 0)
    (eval (head e))
    (outs icEnd)
    (patch a (- XP a)))		; jump over
    ; else
    (do						; normal call
    (while e
      (do
      (eval (head e))
      (set e (tail e))))
    (outa icCall idx)))))

(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 xNEW)
      (do
      (eval (head e1))
      (outs icArray))
    (if (= op xADD) (genbop icAdd (head e1) (arg2 e1))
    (if (= op xSUB) (genbop icSub (head e1) (arg2 e1))
    (if (= op xMUL) (genbop icMul (head e1) (arg2 e1))
    (if (= op xDIV) (genbop icDiv (head e1) (arg2 e1))
    (if (= op xBAND) (genbop icBand (head e1) (arg2 e1))
    (if (= op xSHR) (genbop icShr (head e1) (arg2 e1))
    (if (= op xSHL) (genbop icShl (head e1) (arg2 e1))
    (if (= op xEQ) (genbop icEq (head e1) (arg2 e1))
    (if (= op xLT) (genbop icLt (head e1) (arg2 e1))
    (if (= op xGT) (genbop icGt (head e1) (arg2 e1))
    (if (= op xCALL) (gencall arg e1)
    (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 xSTX)			; base idx val
      (do
      (outa icGet arg)
      (eval (head e1))
      (eval (arg2 e1))
      (outs icStx))
    (if (= op xLDY)
      (do
      (outa icLd arg)
      (eval (head e1))
      (outs icLdx))
    (if (= op xSTY)			; base idx val
      (do
      (outa icLd arg)
      (eval (head e1))
      (eval (arg2 e1))
      (outs icStx))
    (if (= op xFUN)
      (do
      (setSref (searchRef 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
    (error "unknown op"))))))))))))))))))))))))))))
    )))

(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)
  (dumpsym)))

(def genall () (i op end)
  (do
  (set i esizeS)
  (set end (* numNames esizeS))
  (while (<= i end)
    (do
    (if (= (getType i) tyFUN) (eval (getVal i)))
    (set i (+ i esizeS))))
  (set end XP)
  (set XP 1)
  (outa icCall (searchRef (shift Start CS)))
  (outs icEnd)
  (set XP end)))

(def resolve (start end) (i op arg c)
  (do
  (set i start)
  (while (< i end)
    (do
    (set c (vec XS i))
    (set op (& c 255))
    (set arg (>> c 8))
    (if (= op icCall)
      (patch i (getSref arg)))
    (set i (+ i 1))))))

; -------- test --------

;(def testtok () ()
;  (do
;  (tokenise)
;  (while (!= (vec tok 0) EOF)
;    (do
;    (prstr tok)
;    (space)
;    (tokenise)))))

(def main () ()
  (do
  (sys 11)		; readinfile
  (loadobj)
  (init)
  (readsym)
;  (dumpsym)
;  (set Runidx (searchSym "run"))
  (genall)
  (resolve 1 XP)
  (outsobj)
  ))