C311 Spring 97. Assignment 5 (solution). Procedures and Assignment

;;
;; C311 Assignment 5
;; Procedures and Assignment
;; Due F 10/11/96 @ 5:00pm
;;

(load "grammar.ss")

(define strange
  '(let ([seven  (lambda () (+ 3 4))]
	 [twelve (delta  () (* 3 4))])
     (let ([* +]
	   [+ *])
       (cons (twelve) (seven)))))


;;
;; -- 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)
(define args->1st  car)
(define args->2nd  cadr)


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

(define make-primitive
  (lambda (proc)
    (lambda (args env)
      (apply proc args))))

(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* (map make-primitive
			  (list
			    + - * add1 sub1 cons car cdr list my-null
			    my-equal my-zero my-greater my-less)))



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

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

(define make-aperture
  (lambda (formals body)
    (lambda (args env)
      (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
	      (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
    (cons 'emptylist *prim-op-names*)
    (cons '() *prim-op-procs*)
    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
	  (letrec (decls body)
	    (let* ([vars (map decl->var decls)]
		   [exps (map decl->exp decls)]
		   [new-env (extend-env vars exps env)])
	      (for-each	denoted-set!
		(map (lambda (var) (apply-env new-env var)) vars)
		(map (lambda (exp) (eval-exp  exp new-env)) exps))
	      (eval-exp body new-env)))
	  (lambda (formals body)
	    (make-closure formals body env))
	  (delta (formals body)
	    (make-aperture formals body))
	  (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 env))))))))

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

(define apply-proc
  (lambda (f args env)
    (f args env)))



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

(define expand
  (lambda (exp)
    (cond
      ((literal? exp) exp)
      ((variable? exp) exp)
      (else 
	(record-case exp
	  (letrec (decls body)
	    (list 'letrec (map list
			    (map decl->var decls)
			    (map expand (map decl->exp decls)))
	      (expand body)))
	  (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)))
	  (delta (formals body)
	    (list 'delta formals (expand body)))
	  (begin (first . rest)
	    (cond
	      [(null? rest)
	       (expand first)]
	      [else (list 'begin
		      (expand first)
		      (expand (cons 'begin rest)))]))
	  (else (map expand exp)))))))






;;
;; -- grammar procedures --
;;
(define exp?
  (let ([keywords '(quote if lambda delta let letrec set! begin)])
    (grammar expression
      (variable
	(predicate
	  (lambda (x)
	    (and (symbol? x)
		 (not (memq x keywords))))))
      (literal (predicate number?))
      (datum (predicate (lambda (x) #t)))
      (declaration (lst variable expression))
      (procedure-call
	(predicate;; this could have been (lst (plus expression))
	  (lambda (x);; but then a spurious bad keyword is reported
	    (and (pair? x)          
		 (not (and (symbol? (car x)) (not (variable x))))
		 ((seq (plus expression))
		  x)))))
      (expression
	(report-if-bad 'expression
	  (alt variable literal procedure-call
					;(lst 'quote datum)
	    (lst 'lambda (lst (star variable)) expression)
	    (lst 'delta (lst (star variable)) expression)
	    (lst 'if expression expression expression)
	    (lst 'set! variable expression)
	    (lst 'begin (plus expression))
	    (lst 'let (lst (star declaration)) expression)
	    (lst 'letrec (lst (star declaration)) expression)))))))



;;
;; -- read-eval-print-loop procedures --
;;
(define run
  (lambda (exp)
    (if (exp? 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))))