C311 Assignment 3 (Simple Interpreter)

;;
;; C311 Assignment 3
;; Simple Interpreter
;; Due T 02/11/97 @ 11:59pm
;;


;;
;; -- data access procedures --
;;
(define variable? symbol?)
(define literal? number?)
(define app->rator car)
(define app->rands cdr)
(define args->1st  car)
(define args->2nd  cadr)
(define args->all  (lambda (x) x))



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

; old definition.  Not needed anymore.
'(define apply-prim-op
  (lambda (prim-op args)
    (case prim-op
      ((+)    (+    (args->1st args) (args->2nd args)))
      ((-)    (-    (args->1st args) (args->2nd args)))
      ((*)    (*    (args->1st args) (args->2nd args)))
      ((add1) (+    (args->1st args) 1))
      ((sub1) (-    (args->1st args) 1))
      ((cons) (cons (args->1st args) (args->2nd args)))
      ((car)  (car  (args->1st args)))
      ((cdr)  (cdr  (args->1st args)))
      ((list)       (args->all args))
      (else (error 'apply-prim-op "Invalid prim-op name: ~s" prim-op)))))

; old definition.  Not neeeded any more.
'(define make-prim-proc
  (lambda (prim-op-name)
    (list 'prim-proc prim-op-name)))




;;
;; -- 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)))
	    (apply-env env symbol))))
      (else (error 'apply-env "Invalid finite function: ~s" env)))))

(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)
    (cond
      ((literal? exp) exp)
      ((variable? exp) (apply-env init-env exp))
      (else
	(record-case exp
	  (if (test then else)
	      (if (true-value? (eval-exp test))
		  (eval-exp then)
		  (eval-exp else)))
	  (else
	    (let ((proc (eval-exp (app->rator exp)))
		  (args (eval-rands (app->rands exp))))
	      (apply-proc proc args))))))))

(define eval-rands
  (lambda (rands)
    (map eval-exp 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)


;;
;; -- read-eval-print-loop procedures --
;;
(define run eval-exp)

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



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