; This file provides some concrete Lisp implementations for Tennent-style
; denotational definitions from Section 13.3.
;

; Here's a definition of a store as the kind of alist we used in Assignments
; 1 and 2.
;
(setq store-as-alist '( (x 10) (y 20) (z 30) ))


; Here's an equivalent definition of a store, Tennent-style as a function.
;
(defun store-as-function (ident)
    (cond ( (eq ident 'x) 10 )
	  ( (eq ident 'y) 20 )
	  ( (eq ident 'z) 30 )
	  ( t 'error )
    )
)


; Here's an equality check to demonstrate that the two stores are equivalent.
;
(eq (cadr (assoc 'y store-as-alist))
    (store-as-function 'y))

; In Lisp, the preceding definition of store-as-function cannot be "perturbed"
; to add new bindings, as Tennent does with his functions.  This is easy enough
; to fix, by defining the functional store as follows.
;
(setq store-as-perturbable-function
  '(lambda (ident)
    (cond ( (eq ident 'x) 10 )
	  ( (eq ident 'y) 20 )
	  ( (eq ident 'z) 30 )
	  ( t 'error )
    )
  )
)


; Here's another equality check to show that this perturbable function store is
; equivalent to the previous two store representations.  Notice that we must
; use Lisp apply, since Common Lisp does not allow us to apply a lambda form
; directly to its arguments.  This is just a syntactic weakness of Lisp.
;
(eq (cadr (assoc 'y store-as-alist))
    (apply store-as-perturbable-function '(y)))


; Now, here's a concrete implementation of Tennent's perturb operation.  Using
; this function, an application of Tennent's perturb function like this
;
;    s [ w |-> 40 ]
;
; looks like this in Lisp
;
;    (perturb s 'w 40).
;
(defun perturb (f arg val)
    (let ((arg-name (caadr f))
	  (func-body (cdaddr f)))
	(list 'lambda (list arg-name)
	      (cons 'cond
		    (cons (cons (list 'eq arg-name (list 'quote arg))
				(list val))
			  func-body
		    )
	      )
	)
    )
)

; Here's an equality check to show that looking up in a modified alist store is
; equivalent to applying a perturbed functional store.
;
(eq (cadr (assoc 'w (cons '(w 40) store-as-alist)))
    (apply (perturb store-as-perturbable-function 'w 40) '(w)))


; Based on the preceding definitions, here are partial definitions for
; Tennent's command execution (script C) and expression evaluation (script E)
; functions.  These definitions work for execution of assignment statements and
; evaluation of identifiers.  The Lisp definitions are pretty close
; transliterations of Tennent's definitions in Table 13.3 on Page 222.
;

; Here's script C for the assignment statement case.
;
(defun command-exec (cmd u s)
    (cond ((is-assmnt cmd)
	   (let ((d (apply u (list (car cmd))))
		 (e (expr-eval (caddr cmd) u s)))
	       (if (and (question-mark d 'L) (question-mark e 'R))
		   (perturb s (car d) (list 'quote e))
		   'error
	       )
	    ) )
	  (t 'whatever)
    )
)	 
		   
; Here's script E for the identifier case.
;
(defun expr-eval (expr u s)
    (cond ( (is-ident expr)
	    (let ((d (apply u (list expr))))
		(if (question-mark d 'L)
		    (apply s (list (car d)))
		    (if (question-mark d 'R)
			d
			'error
		    )
		 )
	     ) )
	  ( (is-basic-val expr)
	    (list expr 'R) )
	  (t 'whatever)
    )
)

; Here's the tag-checking question mark operator.
;
(defun question-mark (binding type)
    (eq (cadr binding) type)
)

; Here are a couple functions to do a little bit of what Tennent's' double
; bracket operators do.  We don't need much given the limited syntax we're
; dealing with.
;
(defun is-assmnt (cmd)
    (eq (cadr cmd) ':=)
)
(defun is-ident (expr)
    (symbolp expr)
)
(defun is-basic-val (expr)
    (or (numberp expr) (eq expr t) (eq expr nil))
)

; To test the preceding defs, here are sample environment and store values.
; They represent an environment with integer variables x, y, and z declared,
; and a store with x assigned the value 10, and y and z unused.
(setq env
  '(lambda (ident)
    (cond ( (eq ident 'x) '(loc-0 L) )
	  ( (eq ident 'y) '(loc-1 L) )
	  ( (eq ident 'z) '(loc-2 L) )
	  ( t 'error )
    )
  )
)

(setq store
  '(lambda (loc)
    (cond ( (eq loc 'loc-0) '(10 R) )
	  ( (eq loc 'loc-1) 'unused )
	  ( (eq loc 'loc-2) 'unused )
	  ( t 'error )
    )
  )
)


; Here's what the evaluation of "y := x" looks like.
;
(command-exec '(y := x) env store)


; Since (command-exec '(y := x) env store) returns a store, if we apply it
; to 'loc-1 as follows, we get (10 R).
;
(apply (command-exec '(y := x) env store) '(loc-1))