;;; simple stack machine

;;; interface simple-stack-machine
;;;
;;;    type action
;;;
;;;    halt-instruction    : () -> action
;;;    incr-instruction    : action -> action
;;;    read-instruction    : action -> action
;;;    push-instruction    : value * action -> action
;;;    add-instruction     : action -> action
;;;    zero?-instruction   : action * action -> action
;;;
;;;    apply-action        : action * stack -> value
;;;

;;; stack = value*

;;; abstract syntax tree representation of actions

;;; action ::= (halt-opcode) 
;;;        |   (incr-opcode action)
;;;        |   (read-opcode action)
;;;        |   (push-opcode value action)
;;;        |   (add-opcode action)
;;;        |   (zero?-opcode action action)

;;; record definitions:

(define-record halt-opcode ())
(define-record incr-opcode (action))
(define-record read-opcode (action))
(define-record push-opcode (value action))
(define-record add-opcode (action))
(define-record zero?-opcode (true-action false-action))

;;; instruction builders:

(define halt-instruction make-halt-opcode)
(define incr-instruction make-incr-opcode)
(define read-instruction make-read-opcode)
(define push-instruction make-push-opcode)
(define add-instruction make-add-opcode)
(define zero?-instruction make-zero?-opcode)


;;; apply-action:

(define apply-action
  (lambda (action stack)
    (record-case action
      (halt-opcode ()
        (car stack))
      (incr-opcode (action)
        (apply-action action
          (cons (+ (car stack) 1)
                (cdr stack))))
      (read-opcode (action)
        (let ((val (prompt-read "machine>")))
               (apply-action action
                 (cons val stack))))
      (push-opcode (v action)
        (apply-action action
          (cons v stack)))
      (add-opcode (action)
        (apply-action action 
          (cons
            (+ (car stack) (cadr stack))
            (cddr stack))))
      (zero?-opcode (true-action false-action)
        (apply-action
          (if (zero? (car stack))
            true-action false-action)
          stack))
      (else (error 'apply-action
              "unknown action ~s~%" action)))))

(define prompt-read
  (lambda (prompt)
    (printf "~d " prompt)
    (read)))

(define start
  (lambda (action)
    (apply-action action '())))

(define test1
  (lambda ()
    (start (read-instruction (incr-instruction (halt-instruction))))))

(define test2
  (lambda ()
    (let ((prog (read-instruction
                  (read-instruction
                    (add-instruction
                      (halt-instruction))))))
      (pretty-print prog)
      (start prog))))


(define test3
  (lambda ()
    (let ((prog (read-instruction
                  (zero?-instruction
                    (halt-instruction)
                    (read-instruction
                      (add-instruction
                        (halt-instruction)))))))
      (pretty-print prog)
      (start prog))))

; > (test1)
; machine> 3
; 4
; > (test2)
; (read-opcode (read-opcode (add-opcode (halt-opcode))))
; machine> 3
; machine> 4
; 7
; > (test3)
; (read-opcode
;    (zero?-opcode
;       (halt-opcode)
;       (read-opcode (add-opcode (halt-opcode)))))
; machine> 2
; machine> 3
; 5
; > (test3)
; (read-opcode
;    (zero?-opcode
;       (halt-opcode)
;       (read-opcode (add-opcode (halt-opcode)))))
; machine> 0
; 0