; code.txt   n-code prefix format
;
;   eval in nut          24 June 2006
;   partially imoplement only 12 operators
;   to run the test program "t2.txt"
;   modify from sim.txt to run "t2.obj"    5 July 2007

; ------- 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 0 NIL)
(enum 3000 STKMAX)		; run-time stack

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

(let tok DP CS M)		; data pointer, code segment
(let SS SP FP)			; stack, stk pointer, frame pointer

(def init () ()
  (do
  (set M 0)				; base ads, absolute
  (set SS (new STKMAX))
  (set FP SS)
  (set SP SS)))

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

; ----- 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

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

; ------- load oject -----------

(let Start)		; ads of "main"

; read a token from stdin
; and convert it to a number
(def read () ()
  (do
  (tokenise)
  (atoi tok)))

; offset a by disp, code segment started at 2
(def shift (a disp) ()
  (if a
    (- (+ a disp) 2)
    0))

; relocate arg of an op
(def reName (op arg) ()
  (do
  (if (= op xCALL)
    (set arg (shift arg CS))
  (if (or (= op xLD) (= op xST))
    (set arg (shift arg DP))
  (if (or (= op xLDY) (= op STY))
    (set arg (shift arg DP))
  (if (= op xSTR)
    (set arg (shift arg DP))))))
  (mkATOM op arg)))

; load object, code segment, data segment
(def loadobj () (flag end a a2 ads ty op arg next)
  (do
  (set CS (sys 9))			; start of code segment
  (set Start (read))		; ads of "main"
  (set end (read))
  (set DP (+ (+ CS end) 2)) ;  start of data segment
  (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 end (read))
    (set a2 (new end))	; alloc the whole block
    (while (< a end)
      (do
      (setv a2 a (read))
      (set a (+ a 1))))))

(def listall () (i a op end)
  (do
  (set i CS)
  (set end (sys 9))
  (while (< i end)
    (do
    (set a (head i))
    (set op (de_op a))
    (if (= op xFUN)
      (do
      (print i) (space)
      (prList i) (nl)))
    (set i (+ i 2))))))

; --------- prefix object writer --------

(def len e ()
  (if (= e NIL) 0
  (+ 1 (len (tail e)))))

(def outATOM e ()
  (do
  (print 0) (space)
  (print (de_op e)) (space)
  (print (de_arg e)) (nl)))

(def outList e () 0)    ; forward declare

(def outL2 e ()
  (if (= e NIL) 0
  (if (isATOM e) (outATOM e)
  ; else
  (do
  (outList (head e))
  (outL2 (tail e))))))

(def outList e ()
  (if (= e NIL) 0
  (if (isATOM e) (outATOM e)
  ; else
  (do
  (print (len e)) (nl)
  (outL2 e)))))

(def outall () (i a op end)   ; similar to (listall)
  (do
  (set i CS)
  (set end (sys 9))
  (while (< i end)
    (do
    (set a (head i))
    (set op (de_op a))
    (if (= op xFUN)
      (do
      (print i) (space)
      (outList i) (nl)))
    (set i (+ i 2))))))

; ------ prefix object reader ----------

(def readobj () (flag k)
  (do
  (set flag 1)
  (while flag
    (do
    (set k (read))
    (nop)))))

(def main () ()
  (do
  (sys 11)		; readinfile
  (loadobj)
;  (listall)
  (outall)
  ))

; End