C311 Assignment 4 (Procedures and Assignment)

;;
;; C311 Assignment 4
;; Procedures and Assignment
;; Due T 02/18/97 $ 11:59pm
;;


;;
;; -- data access procedures --
;;
(define variable? symbol?)
(define literal? number?)
(define app->rator car)
(define app->rands cdr)
(define decl->var  car)
(define decl->exp  cadr)


;;
;; -- primitive procedures --
;;

(define my-equal
  (lambda (x y)
    (if (= x y) 1 0)))

(define my-zero
  (lambda (x)
    (if (zero? x) 1 0)))

(define my-greater
  (lambda (x y)
    (if (> x y) 1 0)))

(define my-less
  (lambda (x y)
    (if (< x y) 1 0)))

(define my-null
  (lambda (ls)
    (if (null? ls) 1 0)))

(define *prim-op-names* '(+ - * add1 sub1 cons car cdr list null
			   equal zero greater less))
(define *prim-op-procs* (list
			  + - * add1 sub1 cons car cdr list my-null
			  my-equal my-zero my-greater my-less))




;;
;; -- closure procedures --
;;

; old definition.
'(define make-closure
  (lambda (formals body env)
    (list 'closure formals body env)))

(define make-closure
  (lambda (formals body env)
    (lambda args
      (eval-exp body (extend-env formals args env)))))



;;
;; -- environment procedures --
;;
(define the-empty-env
  (list 'empty-env))

(define extend-env
  (lambda (sym-list val-list env)
    (list 'extended-env sym-list (list->vector val-list) env)))

(define apply-env
  (lambda (env symbol)
    (record-case env
      (empty-env ()
	(error 'empty-env "no association for symbol: ~s" symbol))
      (extended-env (sym-list val-vector env)
	(let ((x (memq symbol sym-list)))
	  (if x
	      ;(vector-ref val-vector (- (length sym-list) (length x)))
	      (make-dvalue val-vector (- (length sym-list) (length x)))
	      (apply-env env symbol))))
      (else (error 'apply-env "Invalid finite function: ~s" env)))))

(define make-dvalue cons)

(define denoted-set!
  (lambda (denoted-value new-value)
    (vector-set! (car denoted-value) (cdr denoted-value) new-value)))

(define denoted->expressed
  (lambda (dvalue)
    (vector-ref (car dvalue) (cdr dvalue))))

(define init-env
  (extend-env
    '(emptylist)
    '(())
    (extend-env
      *prim-op-names*
      *prim-op-procs*	; was: (map make-prim-proc *prim-op-names*)
      the-empty-env)))



;;
;; -- interpreter procedures --
;;
(define eval-exp
  (lambda (exp env)
    (cond
      ((literal? exp) exp)
      ((variable? exp) (denoted->expressed (apply-env env exp)))
      (else
	(record-case exp
	  (lambda (formals body)
	    (make-closure formals body env))
	  (if (test then else)
	      (if (true-value? (eval-exp test env))
		  (eval-exp then env)
		  (eval-exp else env)))
	  (set! (var exp)
		(let ([binding (apply-env env var)]
		      [value   (eval-exp exp env)])
		  (denoted-set! binding value)))
	  (begin (exp1 exp2)
	    (eval-exp exp1 env)
	    (eval-exp exp2 env))
	  (else
	    (let ((proc (eval-exp (app->rator exp) env))
		  (args (eval-rands (app->rands exp) env)))
	      (apply-proc proc args))))))))

(define eval-rands
  (lambda (rands env)
    (map (lambda (exp) (eval-exp exp env))
      rands)))

; old definition.
'(define apply-proc
  (lambda (proc args)
    (if (pair? proc)
	(record-case proc
	  (prim-proc (prim-op) (apply-prim-op prim-op args))
	  (else (error 'apply-proc "Invalid procedure: ~s" proc)))
	(error 'apply-proc "Invalid procedure: ~s" proc))))

(define apply-proc apply)



;;
;; -- expander procedures --
;;

(define expand
  (lambda (exp)
    (cond
      ((literal? exp) exp)
      ((variable? exp) exp)
      (else 
	(record-case exp
	  (let (decls body)
	    (let ((vars (map decl->var decls))
		  (exps (map decl->exp decls)))
	      (cons (list 'lambda vars (expand body))
		(map expand exps))))
	  (lambda (formals body)
	    (list 'lambda formals (expand body)))
	  (begin list-of-expr
	    (cond
	      [(null? list-of-expr) (error 'expand "invalid syntax: (begin)")]
	      [(null? (cdr list-of-expr))
	       (expand (car list-of-expr))]
	      [else (list 'begin
		      (expand (car list-of-expr))
		      (expand (cons 'begin (cdr list-of-expr))))]))
	  (else (map expand exp)))))))



;;
;; -- read-eval-print-loop procedures --
;;
(define run
  (lambda (exp)
    (eval-exp (expand exp) init-env)))

(define repl ; read-eval-print loop
  (lambda ()
    (display "--> ")
    (write (run (read)))
    (newline)
    (repl)))



;;
;; -- helper procedures --
;;
(define true-value?
  (lambda (x)
    (not (zero? x))))