; sim.txt   n-code simulator
;
;   eval in nut          24 June 2006
;   partially imoplement only 12 operators
;   to run the test program "t2.txt"

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

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

; push a value to run-time stack
(def push e ()
  (do
  (set SP (+ SP 1))
  (if (> SP (+ SS STKMAX))
    (error "stack overflow"))
  (setv M SP e)))

(def arg1 e () (head e))
(def arg2 e () (head (tail e)))
(def arg3 e () (head (tail (tail e))))

(def eval e () 0) 	; forward declaration

; system call, implement print, printc
(def syscall (arg e) (v a1)
  (do
  (set v NIL)
  (set a1 (eval (arg1 e)))
  (if (= arg 1) (sys 1 a1)
  (if (= arg 2) (sys 2 a1)
  ; else
  (error "undef sys")))
  v))

; fun.a.v no recode
(def funcall (arg e) (k v a)
  (do
  (set v (& arg 255))		; decode a, v
  (set a (>> arg 8))
  (set k (+ (- v a) 1))
  (setv M (+ SP k) FP)		; save old FP
  (set FP (+ SP k))			; new frame
  (set SP FP)
  (set v (eval (arg1 e)))	; eval body
  (set SP (- (- FP v) 1))	; delete frame
  (set FP (vec M FP))		; restore FP
  v))

; the main interpreter for n-code
; partially implement only 12 operators
(def eval e (e1 op arg v idx)
  (if (= e NIL)
    NIL
    ; else
    (do
    (if (not (isATOM e))	; if it is a list
      (do					; set e1 to arglist
      (set e1 (tail e))		; and e to operator
      (set e (head e))))
    (set op (de_op e))
    (set arg (de_arg e))	; decode operator
    (if (= op xIF)
      (if (eval (arg1 e1))
        (set v (eval (arg2 e1)))
        ; else
        (set v (eval (arg3 e1))))
    (if (= op xDO)
      (while e1
        (do
        (set v (eval (head e1)))
        (set e1 (tail e1))))
    (if (= op xADD)
      (set v (+ (eval (arg1 e1)) (eval (arg2 e1))))
    (if (= op xCALL)
      (do
      (while e1				; eval all arg
        (do					; and push it to stack
        (push (eval (head e1)))
        (set e1 (tail e1))))
      (set v (eval arg)))	; eval body of fun
    (if (= op xLIT)
      (set v arg)
    (if (= op xSTR)
      (set v arg)
    (if (= op xGET)
      (set v (vec M (- FP arg)))
    (if (= op xLD)
      (set v (vec M arg))
    (if (= op xST)
      (do
      (set v (eval (arg1 e1)))
      (setv M arg v))
    (if (= op xLDX)
      (do
      (set idx (eval (arg1 e1)))
      (set v (vec M (+ (vec M (- FP arg)) idx))))
    (if (= op xFUN)
      (set v (funcall arg e1))
    (if (= op xSYS)
      (set v (syscall arg e1))
    ; else
    (error "unknown op")))))))))))))
    v)))

(def main () ()
  (do
  (sys 11)		; readinfile
  (loadobj)
;  (listall)
  (init)
  (eval (shift Start CS))
  ))

; End of sim.txt