;; -*- Mode: Lisp; -*-

;; I believe we should make all numbers signed.

(defun putchar (c)
  (setq (* #x01000000) c))

(defun getchar ()
  (* #x01000000))

(defun puts (s)
  (var c)
  (while (/= 0 (setq c (* s)))
    (putchar c)
    (setq s (+ s 1))))

(defun putw (w)
  ;; Prints the word w in hex
  (let ((table "0123456789ABCDEF")
        (c0) (c1) (c2) (c3) c4 c5 c6 c7)
    (setq c7 (aref table (logand w #xF)))
    (setq w (shr (shr (shr (shr w)))))
    (setq c6 (aref table (logand w #xF)))
    (setq w (shr (shr (shr (shr w)))))
    (setq c5 (aref table (logand w #xF)))
    (setq w (shr (shr (shr (shr w)))))
    (setq c4 (aref table (logand w #xF)))
    (setq w (shr (shr (shr (shr w)))))
    (setq c3 (aref table (logand w #xF)))
    (setq w (shr (shr (shr (shr w)))))
    (setq c2 (aref table (logand w #xF)))
    (setq w (shr (shr (shr (shr w)))))
    (setq c1 (aref table (logand w #xF)))
    (setq w (shr (shr (shr (shr w)))))
    (setq c0 (aref table (logand w #xF)))
    (putchar c0)
    (putchar c1)
    (putchar c2)
    (putchar c3)
    (putchar c4)
    (putchar c5)
    (putchar c6)
    (putchar c7)))

(defun * (a b)
  (var i 32)
  (var r 0)
  (while i
    (when (logand a 1)
      (setq r (+ r b)))
    (setq b (+ b b))
    (setq a (shr a))
    (setq i (- i 1)))
  r)

(defun / (a b)
  ;; ### THIS ROUTINE IS BUGGY! ###
  (cond ((< b 0)
         (- 0 (u/ a (- 0 b))))
        (1
         (u/ a b))))

(defun u/ (a b)
  (let ((m 1)
        (r 0))
    ;; we only need to shift until b is >= a.
    (until (logand b #x80000000)
      (setq b (+ b b)) 
      (setq m (+ m m)))
    (while m
      (when (>= a b)
        (setq r (+ r m))
        (setq a (- a b)))
      (setq m (shr m))
      (setq b (shr b)))
    r))

;; (mod #xf00ba8 #x4711)

(defun mod (a b)
  (let ((m 1)
        (r 0))
    ;; we only need to shift until b is >= a.
    (until (logand b #x80000000)
      (setq b (+ b b)) 
      (setq m (+ m m)))
    (while m
      (when (>= a b)
        (setq r (+ r m))
        (setq a (- a b)))
      (setq m (shr m))
      (setq b (shr b)))
    a))

(defun gets (s)
  (var c)
  (until (= 10 (setq c (getchar)))
    (setq (* s) c)
    (setq s (+ s 1))))

(defun putu (u)
  (var (buf 11))
  (var p (+ buf 10))
  (setq (* p) 0)
  (tag loop)
  (setq p (- p 1))
  (setq (* p) (+ #.(char-code #\0) (mod u 10)))
  (when (setq u (/ u 10)) (go loop))
  (puts p))

(defun putd (u)
  (if (logand #x80000000 u)
      (progn (putchar #\-)
             (putu (- u)))                      ;hmm
      (putu u)))

(defun* printf (format a1 a2 a3 a4 a5 a6 a7 a8 a9)
  (var ap (& a1))
  (var s format)
  (var c)
  (while (setq c (* s))
    (setq s (+ s 1))
    (cond ((= c #.(char-code #\%))
           (setq c (* s))
           (setq s (+ s 1))
           (cond ((= c #\d) (putd (* ap)))
                 ((= c #\u) (putu (* ap)))
                 ((= c #\x) (putw (* ap)))
                 ((= c #\s) (puts (* ap)))
                 ((= c #\~)
                  (putchar 10)
                  (setq ap (- ap 1)))
                 (1
                  (putchar c)
                  (setq ap (- ap 1))))
           (setq ap (+ ap 1)))
          (1
           (putchar c)))))

(defun dis (s e)
  (while (< s e)
    (let ((w (* s)))
      (printf "%x: %s %x '%x%~"
              s
              (opstring (opcode w))
              (logand #x0FFFFFFF w)
              (* (logand #x0FFFFFFF w))))
    (setq s (+ s 1))))

(defun opcode (x)
  (var i 28)
  (while i
    (setq i (- i 1))
    (setq x (shr x)))
  x)

(defun opstring (x)
  (var (a 16)
       "add" "adc" "sub" "sbb"
       "and" "ior" "xor" "shr"
       "jmp" "jnz" "jz " "jc "
       "lod" "sto" "ill" "ill")
  (aref a x))

(defun* fib (n)
  (if (<= n 1)
      1
      (+ (fib (- n 1)) (fib (- n 2)))))

(var $sp #xF000)

(defun save (p n)
  (setq $sp (- $sp n))
  (var d $sp)
  (while n
    (setq (* d) (* p))
    (setq p (+ p 1))
    (setq d (+ d 1))
    (setq n (- n 1))))

(defun restore (p n)
  (while n
    (setq (* p) (* $sp))
    (setq p (+ p 1))
    (setq $sp (+ $sp 1))
    (setq n (- n 1))))

;;;; ------------------------------------------------------------------------------------------

(defun testmul (a b)
  (printf "(%d * %d) = %d" a b (* a b))
  (putchar 10))

(defun testdiv (a b)
  (printf "(%d / %d) = %d" a b (/ a b))
  (putchar 10))

(defun test< (a b)
  (printf "(%d < %d) = %d" a b (< a b))
  (putchar 10))

(defun main ()
  (puts "Hi, there.")
  (putchar 10)
  (putchar 10)
  (puts "* ")
  (putchar 10)
  (test< 10 20)
  (test< 20 10)
  (test< 10 10)
  (putchar 10)
  (testmul 3 4)
  (testmul -3 4)
  (testmul 3 -4)
  (testmul -3 -4)
  (testdiv 12 4)
  (testdiv -12 4)
  (testdiv 12 -4)
  (testdiv -12 -4)
  (while 1)
  (putw (/ #xB09171A6 #xdead))(putchar 10)
  (putw (/ #xB09171A6 #xcafe))(putchar 10)
  (putw (mod #xf00ba8 #x4711))(putchar 10)
  (printf "x = %u%~" (< #xB09171A6 0))
  (printf "a = %u, b = %x%~" #xB09171A6 10)
  (printf "a = %d, b = %x%~" #xB09171A6 10)
  (printf "b = %u%~" (< -1 0))
  (printf "b = %u%~" (< 0 -1))
  (printf "b = %u%~" (<= 100 100))
  (printf "b = %u%~" (<= 100 200))
  (printf "b = %u%~" (<= 200 100))
  (printf "b = %u%~" (< 100 100))
  (printf "b = %u%~" (< 100 200))
  (printf "b = %u%~" (< 200 100))
  (dis 0 #x10)
  (var i 0)
  (while (< i 30)
    (printf "fib (%d) = %d%~" i (fib i))
    (setq i (+ i 1)))
  (printf "Done.%~")
  (var (buf 80))
  #+NIL (gets buf)
  (puts "Got: ")
  (puts buf)
  (putchar 10))