;; This is a denotational interpreter for PostFix
;; Built on Wed Sep  7 12:45:14 EDT 1994
;; Includes:
;;    pf-syntax.scm
;;    repl.scm
;;    pf-den-interp.scm
 
;;---------------------------------------------------
;; pf-syntax.scm
;;;----------------------------------------------------------------------------
;;; PF-SYNTAX.SCM
;;;
;;; Postfix syntax and parsing
;;;----------------------------------------------------------------------------

;;;---------------------------------------------------------------------------
;;; Datatypes

(define-datatype program
  ($prog (listof command)))

(define-datatype command
  ($int int)
  ($seq (listof command))
  ($pop)
  ($swap)
  ($dup)
  ($sel)
  ($exec)
  ($arithop (-> (int int) int))
  ($relop   (-> (int int) bool))
  )

;;;----------------------------------------------------------------------------
;;; Parsing

(define (pf-program sexp)
  (match sexp
    ((list->sexp lst) ($prog (pf-sequence lst)))
    (_ (error "Ill-formed program"))))

(define (pf-sequence lst)
  (map pf-command lst))

(define (pf-command sexp)
  (match sexp
    ( (int->sexp n)      ($int n)                        )
    ( (list->sexp lst)   ($seq (pf-sequence lst))        )
    ( 'pop               ($pop)                          )
    ( 'swap              ($swap)                         )
    ( 'exec              ($exec)                         )
    ( 'sel               ($sel)                          )
    ( 'dup               ($dup)                          )
    ;; Below, arithop and relop operations are functions, not symbols!
    ( 'add               ($arithop +)                    ) 
    ( 'sub               ($arithop -)                    )
    ( 'mul               ($arithop *)                    )
    ( 'div               ($arithop quotient)             ) ; integer division
    ( 'lt                ($relop   <)                    )
    ( 'eq                ($relop   =)                    )
    ( 'gt                ($relop   >)                    )
    ( _                  (error "Unrecognized command"
                                sexp)                    )
    ))

 
;;---------------------------------------------------
;; repl.scm
(define (make-repl evaluator prompt parser unparser)
  (lambda () 
    (let loop ()
      (display "\n\n")
      (display prompt)
      (display " ")
      (let ((sexp (read)))
	(if (eq? sexp 'quit)
	    (display "\nGoodbye!\n")
	    (begin 
	      (display "\n")
	      (display (unparser (evaluator (parser sexp))))
	      (loop)))))))




 
;;---------------------------------------------------
;; pf-den-interp.scm
;;;----------------------------------------------------------------------------
;;; PF-DEN-INTERP.SCM
;;;
;;; A PostFix interpreter based on the denotational semantics for PostFix.
;;; This is a "curried version" in which stacks are passed in a curried 
;;; style. This corresponds directly to the denotational semantics.
;;; Uses Scheme's ERROR instead of error-stack to model errors.
;;; 
;;; EXERCISES:
;;; * Model errors explicitly (don't forget divide-by-zero).
;;; * Write in terms of WITH-INT&STACK; WITH-ERROR
;;; * Add DUP.
;;; * Modify so that EVAL-COMMAND and EVAL-COMMANDS are take stack in 
;;;   uncurried fashion.
;;;
;;;----------------------------------------------------------------------------

;;;---------------------------------------------------------------------------
;;; Evaluation

(define-datatype den-val
  (int->den-val int)
  (xform->den-val (-> (stack) stack)))

;; eval-program: (-> (program) den-val)
(define (eval-program pgm)
  (match pgm
    (($prog seq) (top ((eval-commands seq) (empty-stack))))
    ))

;; eval-commands: (-> ((listof command)) (-> (stack) stack))
(define (eval-commands seq)
  (match seq
    ((null) identity)
    ((cons com coms) (o (eval-commands coms) (eval-command com)))
    ))

;; eval-command: (-> (command) (-> (stack) stack))
(define (eval-command cmd)
  (match cmd
    ( ($int i)      (push (int->den-val i))                             )
    ( ($seq s)      (push (xform->den-val (eval-commands s)))           )
    ( ($pop)        pop                                                 )
    ( ($swap)       (with-value
		     (lambda (v1) 
		       (with-value 
			(lambda (v2)
			  (o (push v2) (push v1))))))                   )
    ( ($sel)        (with-value
		     (lambda (else)
		       (with-value
			(lambda (then)
			  (with-integer
			   (lambda (test)
			     (if (= test 0) 
				 (push else) 
				 (push then))))))))                     )
    ( ($exec)       (with-transform identity)                           )
    ( ($arithop op) (with-integer
		     (lambda (i1)
		       (with-integer
			(lambda (i2)
			  (push (int->den-val (op i2 i1)))))))          )
    ( ($relop op)   (with-integer
		     (lambda (i1)
		       (with-integer
			(lambda (i2)
			  (push (int->den-val (if (op i2 i1) 1 0))))))) )
    ))
      

;;;-------------------------------------------------------------------------
;;; Auxiliary Functions

(define (empty-stack) '())

(define (push val)
  (lambda (stack) 
    (cons val stack)))

(define (with-value proc)
  (lambda (stack)
    (match stack
      ((null) (error "Empty stack"))
      ((cons v s) ((proc v) s)))))

(define top (with-value (lambda (top) (lambda (rest) top))))
(define pop (with-value (lambda (top) (lambda (rest) rest))))

(define (with-integer proc)
  (with-value
   (lambda (v)
     (match v
       ((int->den-val i) (proc i))
       (_ (error "Transform where integer expected"))))))

(define (with-transform proc)
  (with-value
   (lambda (v)
     (match v
       ((xform->den-val t) (proc t))
       (_ (error "Integer where transform expected"))))))

(define (identity x) x)

(define (o f g)
  ;; Function composition
  (lambda (x) 
    (f (g x))))


;;;---------------------------------------------------------------------------
;;; Top-level

(define (unparse-value value)
  (match value
    ((int->den-val i) (int->sexp i))
    ((xform->den-val s) 'executable)
    ))

(define pf-den-repl (make-repl eval-program
			       'pf-den> 
			       pf-program 
			       unparse-value))