alpha compiler in emacs lisp

compile.el

;; This buffer is for text that is not saved, and for Lisp evaluation.
;; To create a file, visit it with C-x C-f and enter text in its buffer.
;;
;; arithmetic expression compiler for elisp stack machine (and more)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Tree -> Stack

(defun left (a)
  (cadr a))

(defun right (a)
  (caddr a))

(defun op (a)
  (car a))

(defun leaf? (a)
  (atom a))

(defun compile (e)
  (cond ((leaf? e) (list (list :push e))) 
	(t (let ((l (compile (left e)))
		 (r (compile (right e))))
	     (append l r (list (list :call (op e))))))))

(compile '(+ 1 2))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Stack -> Value

(defun kall (o a b)
  (case o
    ((+) (+ a b))
    ((-) (- a b))
    ((*) (* a b))
    ((/) (/ a b))
    (t (throw :unknown-operation))))

(defun compute (s i)
  (case (car i)
    ((:push) (cons (cadr i) s))
    ((:call) (let ((a (car s))
		   (b (cadr s))
		   (S (cddr s))
		   (o (cadr i)))
	       (cons (kall o a b) S)))
    (t :error)))

(-reduce-from #'compute '() (compile '(+ (+ 1 1) (+ 2 2))))

(defun empty-stack () '())

(defun process (i)
  (-reduce-from #'compute (empty-stack) i))

(defun run (e)
  (let* ((n (empty-stack))
	 (c (compile e))
	 (o (process c)))
    (car o)))

(defmacro Run (e)
  `(run ,e))

(Run (+ (+ 1 10) (* 2 20)))
(Run (+ (+ 1 10) (* 2 20) (/ 1000 33) (- 84 (/ 84 2))))

;;; treegen

(defun randomly (s)
  (nth (random (length s)) s))

(randomly '(1 2 3 4 5))

(defun treegen (d)
  (cond ((zerop d) (random 999))
	(t (list (randomly '(+ - * /))
		 (treegen (1- d))
		 (treegen (1- d))))))

(treegen 3)
(setq t0 '(- (- (+ 25 821) (+ 675 667)) (+ (/ 705 574) (- 914 472))))
(run t0)

;; ((:push 25)
;;  (:push 821)
;;  (:call +)
;;  (:push 675)
;;  (:push 667)
;;  (:call +)
;;  (:call -)
;;  (:push 705)
;;  (:push 574)
;;  (:call /)
;;  (:push 914)
;;  (:push 472)
;;  (:call -)
;;  (:call +)
;;  (:call -))

(compile t0)

(process '((:push 25) (:push 821) (:call +) (:push 675) (:push 667) (:call +) (:call -) (:push 705) (:push 574) (:call /) (:push 914) (:push 472) (:call -) (:call +) (:call -)))

(compile (cadr t0))
(process '((:push 25) (:push 821) (:call +) (:push 675) (:push 667) (:call +) (:call -)))
(496)

(compile (caddr t0))
(process '((:push 705) (:push 574) (:call /) (:push 914) (:push 472) (:call -) (:call +)))
(-442)

(- -442 496)

;; run Tree(o, l, r) = (exec o) (run l) (run r)

;;; x86 syntax ?
;;; source: https://www.cs.virginia.edu/~evans/cs216/guides/x86.html @https://archive.fo/ygJHW
;;; source: https://stackoverflow.com/questions/26026174/how-does-push-and-pop-work-in-assembly @https://archive.fo/Ul7yX

(defun emit/x86 (i)
  (case (car i)
    ((:push) (format "push %d" (cadr i)))
    ((:call) (mapconcat
	      #'identity
	      (list (format "pop ax")
		    (format "pop bx")
		    (case (cadr i)
		      ((+) "add ax, bx")
		      ((-) "sub ax, bx")
		      ((*) "mul ax, bx")
		      ((/) "div ax, bx")
		      (t (throw 'unknown-arithmetic-operation)))
		    (format "push ax"))
	      "\n"))
    (t (throw 'unknown-instruction))))

(mapconcat #'emit/x86 (compile t0) "\n")

(setq t0/x86
      "push 25
push 821
pop ax
pop bx
add ax, bx
push ax
push 675
push 667
pop ax
pop bx
add ax, bx
push ax
pop ax
pop bx
sub ax, bx
push ax
push 705
push 574
pop ax
pop bx
add ax, bx
push ax
push 914
push 472
pop ax
pop bx
sub ax, bx
push ax
pop ax
pop bx
add ax, bx
push ax
pop ax
pop bx
sub ax, bx
push ax")


(defun parse/x86 (i)
  (split-string i "[ ,]"))

(parse/x86 "add ax,bx")

(mapcar #'parse/x86 (split-string t0/x86 "\n"))

(defun process/x86 (i)
  (let ((is (split-string i "\n"))
	(ax 0)
	(bx 0)
	(s '()))
    (progn
      (throw 'dummy :to-finish)
      (dolist (i is)
	(cond ((string-prefix-p "push " i) (set! s (cons (v i) s)))
	      ((string-prefix-p "pop " i) (progn
					    (set! (r i) (car s))
					    (set! s (cdr s))))
	      ((string-prefix-p "add " i) (set! (r i) (+ (r i) (rr i))))
	      ((string-prefix-p "sub " i) (set! (r i) (- (r i) (rr i))))
	      ((string-prefix-p "mul " i) (set! (r i) (* (r i) (rr i))))
	      ((string-prefix-p "div " i) (set! (r i) (/ (r i) (rr i))))
	      (t (throw x86/unkown-instruction))))
      (list :ax ax
	    :bx bx
	    :s s))))

(defun reg (r) (intern r))
(defun i (s) (symbol-value (intern s)))

(defun process/x86 (i)
  (let ((is (split-string i "\n"))
	(ax 0)
	(bx 0)
	(s '()))
    (progn
      (dolist (i is)
	(let ((p (parse/x86 i)))
	  (cond
	   ((equal "push" (car p)) (setq s (cons (string-to-number (cadr p)) s)))
	   ((equal "pop" (car p)) (progn
				    (set (reg (cadr p)) (car s))
				    (setq s (cdr s))))
	   ((equal "add" (car p)) (set (reg (cadr p)) (+ (i (cadr p)) (i (cadddr p)))))
	   ((equal "sub" (car p)) (set (reg (cadr p)) (- (i (cadr p)) (i (cadddr p)))))
	   ((equal "mul" (car p)) (set (reg (cadr p)) (* (i (cadr p)) (i (cadddr p)))))
	   ((equal "div" (car p)) (set (reg (cadr p)) (/ (i (cadr p)) (i (cadddr p)))))
	   (t (throw 'x86/unkown-instruction p)))))
      (list :ax ax
	    :bx bx
	    :s s))))

(let ((ax 0)
      (bx 0)
      (n "ax"))
  (set (if (equal n "ax") 'ax 'bx) 10)
  (list ax bx))

(let ((n 0))
  (symbol-value (intern "n")))

(process/x86 "push 1\npush 2\npop ax\npop bx\nadd ax, bx\nadd ax, bx\nadd ax, bx\nadd bx, ax\nmul ax, bx\nsub ax, bx\npush 10\npush 20\npush 30")
(process/x86 t0/x86)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; DFA Matrix

(defun M (v e)
  "node -> Maybe node"
  (lambda (n)
    (quote todo)))