wsgen.lisp

; (push n) (dup) (swap) (pop)
; (add) (sub) (mul) (div) (mod)
; (sto) (rtrv)
; (label n) (gosub n) (goto n) (jz n) (jb n) (ret) (end)
; (putch) (putn) (getch) (getn)

(defun number-to-ws (n)
  (labels ((bit-to-ws (b)
             (ecase b
               (0 'space)
               (1 'tab)))
           (helper (acc n)
             (if (zerop n)
                 acc
                 (helper (cons (bit-to-ws (mod n 2)) acc)
                         (floor n 2))))
           (sign-to-ws (n)
             (if (minusp n)
                 'tab
                 'space)))
    (cons (sign-to-ws n)
          (helper '(ret) (abs n)))))

(defun argument-count (instr)
  (case instr
    ((push label gosub goto jz jb) 1)
    (t 0)))

(defun instr-to-ws (instr)
  (ecase instr
    (push '(space space))
    (dup '(space ret space))
    (swap '(space ret tab))
    (pop '(space ret ret))
    (add '(tab space space space))
    (sub '(tab space space tab))
    (mul '(tab space space ret))
    (div '(tab space tab space))
    (mod '(tab space tab tab))
    (sto '(tab tab space))
    (rtrv '(tab tab tab))
    (label '(ret space space))
    (gosub '(ret space tab))
    (goto '(ret space ret))
    (jz '(ret tab space))
    (jb '(ret tab tab))
    (ret '(ret tab ret))
    (end '(ret ret ret))
    (putch '(tab ret space space))
    (putn '(tab ret space tab))
    (getch '(tab ret tab space))
    (getn '(tab ret tab tab))))

(defun stmt-to-ws (stmt)
  (unless (= (argument-count (first stmt)) (length (rest stmt)))
    (error "Wrong number of arguments to ~S in ~S" (first stmt) stmt))
  (append (instr-to-ws (first stmt))
          (mapcan #'number-to-ws (rest stmt))
          ()))

(defun program-to-ws (stmts)
  (mapcan #'stmt-to-ws stmts))

(defun translate-chars (intmd)
  (map 'string
       (lambda (elem) (ecase elem
                        (space #\SPACE)
                        (tab #\TAB)
                        (ret #\NEWLINE)))
       intmd))

(defun run ()
  (let ((is-prime 1)
        (main 2)
        (prime-loop 3)
        (prime-temp 4)
        (prime-end-true 5)
        (prime-end-false 6)
        (main-loop 7)
        (no-prime 9)
        (end 10))
    (translate-chars
     (program-to-ws `((goto ,main)
                      (label ,is-prime) ; Uses top of stack
                      (push ,prime-temp)
                      (push 3) ; We're not considering 2 so don't worry about it
                      (sto)
                      (label ,prime-loop)
                      (dup)
                      (push ,prime-temp)
                      (rtrv)
                      (dup)
                      (mul)
                      (sub)
                      (jb ,prime-end-true)
                      (dup)
                      (dup)
                      (push ,prime-temp)
                      (rtrv)
                      (div)
                      (push ,prime-temp)
                      (rtrv)
                      (mul)
                      (sub)
                      (jz ,prime-end-false)
                      (push ,prime-temp)
                      (push ,prime-temp)
                      (rtrv)
                      (push 1)
                      (add)
                      (sto)
                      (goto ,prime-loop)
                      (label ,prime-end-true)
                      (pop)
                      (push 1)
                      (ret)
                      (label ,prime-end-false)
                      (pop)
                      (push 0)
                      (ret)
                      (label ,main)
                      (push 1) ; 2 is definitely a prime number; don't test it
                      (push 3)
                      (label ,main-loop)
                      (dup)
                      (gosub ,is-prime)
                      (jz ,no-prime)
                      (swap)
                      (push 1)
                      (add)
                      (dup)
                      (push 10001)
                      (sub)
                      (jz ,end)
                      (swap)
                      (label ,no-prime)
                      (push 2) ; Even numbers greater than 2 are not prime; skip them
                      (add)
                      (goto ,main-loop)
                      (label ,end)
                      (pop)
                      (putn)
                      (end))))))