; nut compiler  in nut       18 June 2006

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

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

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

(enum 127 EOF)
(enum 0 NIL)
(enum 3000 MAXNAMES)
(enum 3000 MAXSTR)
(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)
(enum 2
  tyVAR tyFUN tyOP tyOPX tySYS tyUD tyGVAR tyXX tyENUM)

(let tok LP RP startHeap)

(def init () ()
  (do
  (set LP "(")
  (set RP ")")))

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

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

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

(def strlen2 s (a n)
  (do
  (set n 0)
  (set a (vec s 0))
  (while a
    (do
    (set n (+ n 1))
    (set s (+ s 1))
    (set a (vec s 0))))
  n))

(def strlen s ()			; version recursive
  (if (vec s 0)
    (+ 1 (strlen (+ s 1)))
    0))

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

(def isNumber s a
  (do
  (set a (vec s 0))
  (while (and (> a 47) (< a 58))	; isdigit a
    (do
    (set s (+ s 1))
    (set a (vec s 0))))
  (= a 0)))					; true if reach end

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

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

(enum 5 esize)		; size of each element

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

(let symtab symstr symp numNames numLocal)

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

; allocate new string from symstr[]
(def newName nm (k v)
  (do
  (set k (+ (strlen nm) 1))
  (set v (+ symstr symp))
  (set symp (+ symp k))
  (if (> symp MAXSTR)
    (error "symbol string full"))
  (strcpy v nm)
  v))

(def install nm (i flag end)
  (do
  (set i 0)
  (set flag 1)
  (set end (* esize numNames))
  (while (and flag (< i end))
    (if (str= (getName i) nm)	; sequential search
      (set flag 0)
      ; else
      (set i (+ i esize))))
  (if flag 						; not found
    (do
    (if (> i MAXNAMES)
      (error "symtab overflow"))
    (setName i (newName nm))
    (setType i tyUD)
    (set numNames (+ numNames 1))))
  i))

(def installLocal nm idx
  (do
  (set numLocal (+ numLocal 1))
  (set idx (install nm))
  (setType idx tyVAR)
  (setVal idx numLocal)))

(def dumpsym () (i end)
  (do
  (print (- numNames 15)) (nl)
  (set i 75)				; 15 keywords
  (set end (* esize numNames))
  (while (< i end)
    (do
    (prstr (getName i)) (space)
    (print (getType i)) (space)
    (print (getVal i)) (space)
    (print (getArity i)) (space)
    (print (getLv i)) (nl)
    (set i (+ i esize))))))

(def insertsym (nm ty op) (idx)
  (do
  (set idx (install nm))
  (setType idx ty)
  (setVal idx op)))

(def initsym () ()
  (do
  (set symtab (new MAXNAMES))
  (set symstr (new MAXSTR))		; symbol string
  (set symp 0)					; symstr pointer
  (set numNames 0)
  (set numLocal 0)
  (insertsym "if" tyOP xIF)
  (insertsym "while" tyOP xWHILE)
  (insertsym "set" tyOPX xSET)
  (insertsym "setv" tyOPX xSETV)
  (insertsym "do" tyOP xDO)
  (insertsym "new" tyOP xNEW)
  (insertsym "+" tyOP xADD)
  (insertsym "-" tyOP xSUB)
  (insertsym "=" tyOP xEQ)
  (insertsym "<" tyOP xLT)
  (insertsym ">" tyOP xGT)
  (insertsym "vec" tyOPX xVEC)
  (insertsym "sys" tySYS xSYS)
  (insertsym "&" tyOP xBAND)
  (insertsym ">>" tyOP xSHR)))

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

(def cons (e list) h
  (do
  (set h (new 2))
  (setv h 0 e)		; set head
  (setv h 1 list)	; set tail
  h))

(def isATOM e () (< e 0))	; MSB bit 1
(def mkATOM (op arg) () (sys 11 op arg))

; --------- parser ----------

(def tokenise () ()
  (do
  (set tok (sys 3))))
;  (prstr tok)
;  (space)))

(def expect s ()
  (if (not (str= tok s))
    (do
    (prstr "expect ")
    (error s))))

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

; NL can be singleton or list
(def parseNL () ()
  (do
  (tokenise)
  (if (str= tok LP)
    (do
    (tokenise)
    (while (not (str= tok RP))
      (do
      (installLocal tok)
      (tokenise))))
    ; else
    (installLocal tok))))

(def parseName () (idx n n2 ty v)
  (do
  (set idx (install tok))
  (set n (getVal idx))
  (set ty (getType idx))
  (if (= ty tyOP) (set v (mkATOM n 0))
  (if (= ty tyVAR) (set v (mkATOM xGET n))
  (if (= ty tyFUN) (set v (mkATOM xCALL idx))
  (if (= ty tyOPX)
    (do
    (tokenise)		; get var name
    (set idx (install tok))
    (set n2 (getVal idx))
    (if (= (getType idx) tyVAR)
      (if (= n xSET) (set v (mkATOM xPUT n2))
      (if (= n xSETV) (set v (mkATOM xSTX n2))
      (if (= n xVEC) (set v (mkATOM xLDX n2))
      ; else
      (error "unknown op"))))))
  (if (= ty tySYS)
    (do
    (tokenise)		; get sys num
    (set v (mkATOM xSYS (atoi tok)))))))))
  v))

(def parseExp () () 0)		; forward declaration

(def parseEL () v
  (do
  (tokenise)
  (if (str= tok RP)
    (set v NIL)
    ; else
    (set v (cons (parseExp) (parseEL))))
  v))

(def parseExp () v
  (do
  (if (str= tok LP)			; it is a list
    (do
    (tokenise)
    (set v (cons (parseName) (parseEL))))
  (if (isNumber tok)		; it is a number
    (set v (mkATOM xLIT (atoi tok)))
  (set v (parseName))))
  v))

(def parseDef () (idx arity e k)
  (do
  (tokenise)
  (set idx (install tok))
  (setType idx tyFUN)
  (set numLocal 0)
  (parseNL)
  (set arity numLocal)
  (parseNL)
  (tokenise)
  (set e (parseExp))
  (tokenise)			 ; skip RP
  (if (isATOM e)
    (set e (cons e NIL))) ; body must be list
  (setArity idx arity)
  (setLv idx numLocal)
  (set k (+ (* arity 256) (& numLocal 255)))
  (setVal idx (cons (mkATOM xFUN k) (cons e NIL)))
  idx))

(def prName idx () (prstr (getName idx)))

(def parse () (idx)
  (do
  (tokenise)
  (while (!= (vec tok 0) EOF)
    (do
    (expect LP)
    (tokenise)
    (if (str= tok "def")
      (do
      (set idx (parseDef))
      (prName idx) (nl)
      (prList (getVal idx)) (nl))
      ; else
      (error "unknown keyword"))
    (tokenise)))))

; ------- rename ---------

(let LV)

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

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

; get/put/ldx/stx rename 1..n to n..1
; call instantiate ref
(def reATOM e (op arg)
  (do
  (set op (de_op (head e)))
  (set arg (de_arg (head e)))
  (if (= op xFUN)
    (set LV (& arg 255))
  (if (or (= op xGET) (= op xPUT))
    (sethead e (mkATOM op (+ (- LV arg) 1)))
  (if (or (= op xLDX) (= op xSTX))
    (sethead e (mkATOM op (+ (- LV arg) 1)))
  (if (= op xCALL)
    (sethead e (mkATOM op (getVal arg)))))))))

(def reName e ()
  (if (!= e NIL)
	(if (isATOM (head e))
	  (do
	  (reATOM e)
	  (reName (tail e)))
	  ; else
	  (do
	  (reName (head e))
	  (reName (tail e))))))

(def resolve () (i end e)
  (do
  (set i 75)
  (set end (* esize numNames))
  (while (< i end)				; scan symtab
    (do
    (if (= (getType i) tyFUN)
	  (do
	  (set e (getVal i))		; body
	  (reName e)))
	(set i (+ i esize))))))

(def outobj () (i end a ty)
  (do
  (set i (install "main"))
  (set a (getVal i))
  (set end (sys 9))
  (print a) (space)
  (print (- end 2)) (nl)
  (set i startHeap)
  (while (< i end)		; code segment
    (do
	(set a (head i))
	(set ty 0)
	(if (isATOM a) (set ty 1))
	(print i) (space)
	(print ty) (space)
	(print (de_op a)) (space)
	(print (de_arg a)) (space)
	(print (tail i)) (nl)
	(set i (+ i 2))))
  (print 0) (nl)		; data segment
  (dumpsym)))

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

(def testsym () (idx)
  (do
  (install "abc")
  (install "def")
  (install "123")
  (set idx (install "abc"))
  (prstr (getName idx)) (nl)
  (dumpsym)))

(def testparsedef () (idx)
  (do
  (tokenise)	; LP
  (tokenise)	; def
  (set idx (parseDef))
  (nl)
  (prList (getVal idx))))

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

(def testlist () (one two three a b)
  (do
  (set one (mkATOM xLIT 1))
  (set two (mkATOM xLIT 2))
  (set three (mkATOM xLIT 3))
  (set b (cons two (cons three NIL)))
  (set a (cons b (cons one NIL)))
  (prList a) (nl)
;  (prList (head a)) (nl)
;  (prList (tail a)) (nl)
;  (prList (tail (tail a))) (nl)
;  (sethead a two)
  (reName a)
  (prList a) (nl)))

(def main () ()
  (do
  (init)
  (initsym)
  (set startHeap (sys 9))
  (parse)
  (resolve)
  (outobj)
  (nop)))