;;;; Modular interpreter, style 1

;; E = Env(V) -> S
;; S = Sto(V) -> V * Sto(V)
;; V = Val
;; Proc = V -> S

;;; Semantic ADT

(define ((unitSE s) env)
  s)

(define ((unitVS v) sto)
  (pair v sto))

(define (((unitVE v) env) sto)
  (pair v sto))

(define ((bindSE t f) env)
  ((f (t env)) env))

(define (((bindVE t f) env) sto)
  (let ((p ((t env) sto)))
    (let ((v (left p))
          (s (right p)))
      (((f v) env) s))))


;;; Language ADT

(define (%const v)
  (unitVE v))

(define ((%var name) env)
  (unitVS (env-lookup env name)))

(define ((%lambda name exp) env)
  (unitVS
    (lambda (val)
      (exp (env-extend env name val)))))

(define (%call e1 e2)
  (bindVE e1
    (lambda (v1)
      (bindVE e2
        (lambda (v2)
          (unitSE (v1 v2)))))))

(define (%if e1 e2 e3)
  (bindVE e1
    (lambda (v1)
      (if v1 e2 e3))))

(define ((make-op op) e1 e2)
  (bindVE e1
    (lambda (v1)
      (bindVE e2
        (lambda (v2)
          (unitVE (op v1 v2)))))))

(define %+ (make-op +))
(define %* (make-op *))

(define (%begin e1 e2)
  (bindVE e1
    (lambda (v1)
      e2)))

(define (%fetch loc)
  (unitSE
    (lambda (sto)
      (pair (store-fetch loc sto) sto))))

(define (%store loc exp)
  (bindVE exp
    (lambda (val)
      (unitSE
        (lambda (sto)
          (pair 'unit (store-store loc val sto)))))))


;;; Utilities

(define pair cons)
(define left car)
(define right cdr)

(define id identity-procedure)

(define (empty-env) '())

(define (env-lookup name env)
  (right (assq name env)))

(define (env-extend name val env)
  (pair (pair name val) env))

(define (empty-store) '())

(define (store-fetch loc sto)
  (right (assq loc sto)))

(define (store-store loc val sto)
  (pair (pair loc val) sto))