;;; Numbers in Emacs Lisp are always decimal.

(defvar mem (make-vector 10 0)
  "Vector where the compiled code is placed.")
(setq mem (make-vector 100 0))

(defvar f (length mem)
  "Compiled code array pointer; it works its way down from the top.")
(setq f (length mem))

(defun gen (obj)
  ;;; place one character "obj" into the stream.
  (setq f (1- f))
  (aset mem f obj)
  f)

(defun testp (e)
  ;;; predicate to tell whether "e" is a test.
  (and (symbolp e) (get e 'test)))

(defun actionp (e)
  ;;; predicate to tell whether "e" is an action.
  (and (symbolp e) (not (get e 'test))))

(defun jumpp (e)
  ;;; predicate to tell whether "e" is a jump-type action.
  (and (symbolp e) (get e 'jump)))

(defun macrop (x)
  (and (symbolp x) (get x 'cmacro)))

(defun compile (e win lose)
  ;;; compile expression e with success continuation "win" and
  ;;; failure continuation "lose".
  ;;; "win" an "lose" are both addresses of stuff higher in memory.
  (cond ((numberp e) (gen e))               ; allow constants.
	((macrop e)
	 (compile (apply (get e 'cmacro) (list e)) win lose))
	((jumpp e) (gen (get e 'jump)))      ; must be return or resume.
	((actionp e) (emit e win))           ; single byte instruction.
	((eq (car e) 'not) (compile (cadr e) lose win))
	((eq (car e) 'seq)
	 (cond ((null (cdr e)) win)
	       (t (compile (cadr e)
			   (compile (cons 'seq (cddr e)) win lose)
			   lose))))
	((eq (car e) 'loop)
	 (let* ((l (genbr 0))
		(r (compile (cadr e) l lose)))
	   (ra l r)
	   r))
	((numberp (car e))                  ; duplicate n times.
	 (cond ((zerop (car e)) win)
	       (t (compile (cons (1- (car e)) (cdr e))
			   (compile (cadr e) win lose)
			   lose))))
	((eq (car e) 'if)                   ; if-then-else.
	 (compile (cadr e)
		  (compile (caddr e) win lose)
		  (compile (cadddr e) win lose)))
	((eq (car e) 'while)                ; do-while.
	 (let (l) ((genbr 0))
	      (let (r) ((compile (cadr e)
				 (compile (caddr e) l lose)
				 win))
		   (ra l r)
		   r)))
	;;; allow for COMFY macros !
	((macrop (car e))
	 (compile (apply (get (car e) 'CMACRO) (list e)) win lose))
	(t (emit e win))))

(defprop alt
  (lambda (e)
    ;;; define the dual of "seq" using DeMorgan's law.
    (list 'not
	  (cons 'seq
		(mapcar (function (lambda (e) (list 'not e)))
			(cdr e)))))
  CMACRO)

(defprop call
  (lambda (e)
    (let (p pl) ((cadr e) (cddr e))
	 (sublis (list (cons 'pushes (genpush pl))
		       (cons 'p p)
		       (cons 'n (length pl)))
		 '(seq (seq . pushes)
		       (p)
		       (li s)
		       (n ii)
		       (sti s)))))
  CMACRO)

(defprop lambda
  (lambda (e)
    (let (pl body) ((cadr e) (cddr e))
	 (sublis (list (cons 'body body)
		       (cons 'xchs (genxchs pl))
		       (cons 'moves (genmoves pl)))
		 '(seq (li s)
		       (seq . xchs)
		       (seq . body)
		       (li s)
		       (seq . moves)
		       (return)))))
  CMACRO)

(defun genschs (pl)
  (cond ((null pl) nil)
	(t (cons (list 'xch (list 'i (+ 258. (length pl))) (list (car pl)))
		 (genschs (cdr pl))))))

(defun genmoves (pl)
  (cond ((null pl) nil)
	(t (cons (list 'move (list 'i (+ 258. (length pl))) (list (car pl)))
		 (genmoves (cdr pl))))))

(defun genbr (win)
  ;;; generate an unconditional jump to "win".
  (gen 0) (gen 0) (gen jmp) (ra f win))

(defun emit (i win)
  ;;; place the unconditional instruction "i" into the stream with
  ;;; success continuation "win".
  (cond ((not (= win f)) (emit i (genbr win)))
	;;; atom is a single character instruction.
	((atom i) (gen (get i 'skeleton)))
	;;; no op code indicates a subroutine call.
	((null (cdr i))
	 (gen 0) (gen 0) (gen jsr) (ra f (eval (car i))))
	;;; "A" indicates the accumulator.
	((eq (cadr i) 'A) (emit (car i) win))
	;;; "S" indicates the stack.
	((eq (cadr i) 'S)
	 (gen (+ (skeleton (car i)) 24.)))
	;;; length=2 indicates absolute addressing.
	((= (length i) 2)
	 (ogen (+ (skeleton (car i)) 4.)
	       (eval (cadr i))))
	;;; "I" indicates absolute indexed by i.
	((eq (cadr i) 'I)
	 (ogen (+ (skeleton (car i)) 20.) (eval (cadr i))))
	;;; "J" indicates absolute indexed by j.
	;;; this cannot be optimized for page zero addresses.
	((eq (cadr i) 'J)
	 (gen 0) (gen 0) (gen (+ (skeleton (car i)) 24.))
	 (ra f (eval (caddr i))))
	;;; "#" indicates immediate operand.
	((eq (cadr i) '#)
	 (ogen (- (get (car i) 'skeleton) 8.)
	       (\ (eval (caddr i)) 256.)))
	;;; "i@" indicates index by i, the indirect.
	((eq (cadr i) 'i@)
	 (ogen (skeleton (car i)) (\ (eval (caddr i)) 256.)))
	;;; "@j" indicates indirect, then index by j.
	((eq (cadr i) '@j)
	 (ogen (+ (skeleton (car i)) 16.) (\ (eval (caddr i)) 256.)))))

(defun ogen (op a)
  ;;; put out address and op code into stream.
  ;;; put out only one byte address, if possible.
  (let (ha la) ((// a 256.) (\ a 256.))
       (cond ((= ha 0) (gen la) (gen op))
	     (t (gen ha) (gen la) (gen (+ op 8.))))))

(defun skeleton (op)
  ;;; return the skeleton of the op code "op".
  ;;; the "skeleton" property of op contains either
  ;;; the code for "accumulator" (groups 0,2) or "immediate" (1) addressing.
  (boole 1 (get op 'skeleton) 227.))

(defun ra (b a)
  ;;; replace the absolute address at the instruction "b"
  ;;; by the address "a".
  (let (ha la) ((quotient a 256) (remainder a 256))
       (store (mem (1+ b)) la)
       (store (mem (+ b 2)) ha))
  b)

(defun inv (c)
  ;;; invert the condition for a branch.
  ;;; invert bit 5 (counting from the right).
  (boole 6 c 32.))

;;; Below are the 6502 op codes.

;;; Allow hexidecimal numbers and set input base to hexadecimal.
(sstatus + t) (setq ibase 16.)

;;; These are the basic test instructions.

(defprop carry +80 test)                     ;;; carry set.
(defprop ~carry +90 test)                    ;;; no carry.
(defprop cc +90 test)                        ;;; carry clear.
(defprop cs +B0 test)                        ;;; carry set.
(defprop L< +90 test)                        ;;; logically less than.
(defprop llt +90 test)                       ;;; logically less than.
(defprop l>= +B0 test)                       ;;; logically greater than or equal to.
(defprop lge +B0 test)                       ;;; logically greater than or equal to.
(defprop = +F0 test)                         ;;; equal.
(defprop ~= +D0 test)                        ;;; not equal.
(defprop =0 +F0 test)                        ;;; equals zero.
(defprop ~=0 +D0 test)                       ;;; not equal to zero.
(defprop ne +D0 test)                        ;;; not equal.
(defprop eq +F0 test)                        ;;; equal.
(defprop overflow +70 test)                  ;;; overflow set.
(defprop ~overflow +50 test)                 ;;; no overflow.
(defprop vc +50 test)                        ;;; overflow clear.
(defprop vs +70 test)                        ;;; overflow set.
(defprop < +30 test)                         ;;; less than.
(defprop >= +10 test)                        ;;; greater than or equal to.
(defprop <0 +30 test)                        ;;; greater than or equal to zero.
(defprop >=0 +10 test)                       ;;; greater than or equal to zero.
(defprop nn +10 test)                        ;;; non-negative.
(defprop mi +30 test)                        ;;; minus (negative).

(setq jmp +4C)                               ;;; jump to new location.
(setq jsr +20)                               ;;; jump to subroutine.

;;; define the skeletons for instructions with operands.
;;; group 0.
(defprop t +20 skeleton)                     ;;; test.
(defprop ? +20 skeleton)                     ;;; test.
(defprop stj +98 skeleton)                   ;;; store j.
(defprop lj +A8 skeleton)                    ;;; load j.
(defprop cj +C8 skeleton)                    ;;; compare j.
(defprop ci +E8 skeleton)                    ;;; compare i.
;;; group 1.
(defprop o +11 skeleton)                     ;;; logical or.
(defprop ^ +31 skeleton)                     ;;; logical and.
(defprop x +51 skeleton)                     ;;; logical xor.
(defprop a +71 skeleton)                     ;;; add with carry.
(defprop + +71 skeleton)                     ;;; add with carry.
(defprop st +91 skeleton)                    ;;; store accumulator.
(defprop l +B1 skeleton)                     ;;; load accumulator.
(defprop c +D1 skeleton)                     ;;; compare accumulator.
(defprop s +F1 skeleton)                     ;;; subtract with borrow.
(defprop - +F1 skeleton)                     ;;; subtract with borrow.
;;; group 2.
(defprop 2* +0A skeleton)                    ;;; arithmetic shift left.
(defprop rl +2A skeleton)                    ;;; rotate left.
(defprop 2/ +4A skeleton)                    ;;; logical shift right.
(defprop rr +6A skeleton)                    ;;; rotate right.
(defprop sti +8A skeleton)                   ;;; store i.
(defprop li +AA skeleton)                    ;;; load i.
(defprop 1- +C2 skeleton)                    ;;; decrement.
(defprop 1+ +E2 skeleton)                    ;;; increment.

;;; define skeletons for random instructions.
(defprop trap +00 skeleton)                  ;;; programmed break.
(defprop save +08 skeleton)                  ;;; push processor state onto stack.
(defprop restore +28 skeleton)               ;;; restore processor state from stack.
(defprop push +48 skeleton)                  ;;; push accumulator onto stack.
(defprop pop +68 skeleton)                   ;;; pop accumulator from stack.
(defprop clc +18 skeleton)                   ;;; clear carry.
(defprop sec +38 skeleton)                   ;;; set carry.
(defprop seb +18 skeleton)                   ;;; set borrow.
(defprop clb +38 skeleton)                   ;;; clear borrow.  Ex: clb; (s # 3).
(defprop clv +B8 skeleton)                   ;;; clear overflow.
(defprop enable +58 skeleton)                ;;; enable interrupts.
(defprop disable +78 skeleton)               ;;; disable interrupts.
(defprop binary +D8 skeleton)                ;;; set binary mode.
(defprop decimal +F8 skeleton)               ;;; set decimal mode.
(defprop i+1 +E8 skeleton)                   ;;; increment i.
(defprop j+1 +C8 skeleton)                   ;;; increment j.
(defprop i-1 +CA skeleton)                   ;;; decrement i.
(defprop j-1 +88 skeleton)                   ;;; decrement j.
(defprop nop +EA skeleton)                   ;;; no operation.

;;; define instructions which ignore both their win & lose continuations.
(defprop resume +40 jump)                    ;;; return from interrupt.
(defprop return +60 jump)                    ;;; return from subroutine.

;;; define some useful macros.

;;; Kleene's closure operator.
(define cmacro (star . ,body)
  $(not (loop (seq :body))))

;;; increment 2 byte address.
(define cmacro (i2 ,p)
  $(seq (i ,p) (if zero (i (1+ ,p)) (seq))))

;;; decrement 2 byte address.
(define cmacro (d2 ,p)
  $(seq (t ,p)
	(if zero (d (1+ ,p)) (seq))
	(d ,p)))

;;; exchange 2 bytes.
(define cmacro (xch ,x ,y)
  $(seq (l :x)
	push
	(l :y) (st :x)
	pop
	(st :y)))

;;; move a byte.
(define cmacro (move ,x ,y)
  $(seq (l :x) (st :y)))

;;; LISP-like prog.
(define cmacro (prog (,v) . ,body)
  $(seq push
	(li s)
	(move (,v) (i 257.))
	(seq :body)
	(li s)
	(move (i 257.) (,v))
	di (sti s)))

;;; Algol-like for-loops.
(define cmacro (fori ,from ,to . ,body)
  $(seq (li :from)
	(while (seq (ci :to) lge)
	  (seq (seq :body) ii))))

(define cmacro (forj ,from ,to . ,body)
  $(seq (lj :from)
	(while (seq (cj :to) lge)
	  (seq (seq :body) ij))))

(define cmacro (for ,v ,from ,to . ,body)
  $(seq (l :from) (st :v)
	(while (seq (c :to) lge)
	  (seq (seq :body) (i :v) (l :v)))))