;;; stack machine,  taking input from a stream

;;; list-of-frames representation

;;; 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*

;;; list-of-frames representation of actions

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

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

;;; instruction builders:

;; builder for instruction streams
(define make-action
  (lambda (instruction action)
      (cons instruction action)))

(define halt-instruction
  (lambda ()
    (make-action '(halt-opcode) '())))

(define incr-instruction
  (lambda (action)
    (make-action '(incr-opcode) action)))

(define read-instruction 
  (lambda (action)
    (make-action '(read-opcode) action)))

(define add-instruction 
  (lambda (action)
    (make-action '(add-opcode) action)))

(define push-instruction 
  (lambda (val action)
    (make-action (list 'push-opcode val) action)))

(define zero?-instruction 
  (lambda (true-action false-action)
    (make-action 
      (cons 'zero?-opcode true-action)
      false-action)))

(define apply-action
  (lambda (action stack)
    (let ((instruction (car action))
          (action (cdr action)))
      (case (car instruction)
        ((halt-opcode)
         (car stack))
        ((incr-opcode)
         (apply-action action
           (cons (+ (car stack) 1)
                 (cdr stack))))
        ((read-opcode)
         (let ((val (prompt-read "machine>")))
           (apply-action action
             (cons val stack))))
        ((push-opcode)
         (let ((v (cadr instruction)))
           (apply-action action
             (cons v stack))))
        ((add-opcode)
         (apply-action action 
           (cons
             (+ (car stack) (cadr stack))
             (cddr stack))))
        ((zero?-opcode)
         (let ((true-action (cdr instruction))
               (false-action 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))))

; > (load "machine-lof.s")
; > (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
; >