Selected Solutions to Homework #10                                         

Solution 10.1

;; unchanged: enclosing-environment, first-frame, the-empty-environment
;; and extend-environment

;; new
(define (make-binding var val) (list var val))
(define (binding-var binding) (car binding))
(define (binding-val binding) (cadr binding))
(define (set-binding-val! binding val) (set-cdr! (car binding) val))

(define (bindings frame) (cdr frame))

;; changed
;; caller already made sure 2 args are same-length lists
(define (make-frame vars vals)
  (cons 'frame (make-binding-list vars vals)))

(define (make-binding-list vars vals)
  (if (null? vars)
      '()
      (cons (make-binding (car vars) (car vals))
	    (make-binding-list (cdr vars) (cdr vals)))))

;; not needed any more -- frame-variables, frame-values

;; changed
(define (add-binding-to-frame! var val frame)
  (set-cdr! frame (cons (make-binding var val) (cdr frame))))

;; NOTE: the following procedures know that a frame is a list of bindings.

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan bindings)		;***
      (cond ((null? bindings)		;***
             (env-loop (enclosing-environment env)))
            ((eq? var (binding-var (car bindings))) ;***
             (binding-val (car bindings))) ;***
            (else (scan (cdr bindings))))) ;***
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan (cdr frame)))))		;***
  (env-loop env))

(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan bindings)		;***
      (cond ((null? bindings)		;***
             (env-loop (enclosing-environment env)))
            ((eq? var (binding-var (car bindings))) ;***
             (set-binding-val! (car bindings) val)) ;***
            (else (scan (cdr bindings))))) ;***
    (if (eq? env the-empty-environment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan (cdr frame)))))		;***
  (env-loop env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan bindings)		;***
      (cond ((null? bindings)		;***
	     (add-binding-to-frame! var val frame))
            ((eq? var (binding-var (car bindings))) ;***
             (set-binding-val! (car bindings) val)) ;***
            (else (scan (cdr bindings))))) ;***
    (scan (cdr frame))))			;***


Solution 10.2
Need to change the following procedures:
(define (assignment? exp)
  (and (pair? exp) (pair? (cdr exp)) (eq? (cadr exp) '<-)))

(define (assignment-variable exp) (car exp))
;; assignment-value unchanged


Solution 10.3

;; Syntax
(define (and? exp) (tagged-list? exp 'and))
(define (and-exps exp) (cdr exp))

(define (or? exp) (tagged-list? exp 'or))
(define (or-exps exp) (cdr exp))

;; Use abstraction for expression sequences (as sequences + no-exps)
(define (no-exp? exps) (null? exps)))
;; (define (last-exp? exps) (null? (cdr exps)))
;; (define (first-exp exps) (car exps))
;; (define (rest-exps exps) (cdr exps))


;; Add clause to mc-eval:
((and? exp) (eval-and (and-exps exp) env))
((or? exp) (eval-or (or-exps exp) env))

(define (eval-and exps env)
  (if (no-exp? exps)
      true				;only if no exps to start with
      (let ((first (eval (first-exp exps) env)))
	(if (true? first)
	    (if (last-exp? exps)
		first			;down to last exp
		(eval-and (rest-exps exps) env))
	    false))))

(define (eval-or exps env)
  (if (no-exp? exps)
      false				;no exps at all, or run out
      (let ((first (eval (first-exp exps) env)))
	(if (true? first)
	    first
	    (eval-or (rest-exps exps) env)))))


Solution 10.4

;; add to Eval 
((and? exp) (eval (and->if exp) env))
((or? exp) (eval (or->if exp) env))

;; (and ) --> true
;; (and <exp> ) --> exp
;; (and <e1> ... <ei> ) --> (if <e1> (and <e2> ... <ei>) <e1>)

;; (or ) --> false
;; (or <exp> ) --> exp
;; (or <e1> ... <ei> ) --> (if <e1> <e1> (or <e2> ... <ei>))

(define (and->if exp)
  (define (expand exps)
    (if (null? exps)
	'true
	(let ((first (car exps))
	      (rest (cdr exps)))
	  (if (no-exp? rest)
	      first
	      (make-if first (expand rest) first)))))
  (expand (and-exps exp)))

(define (or->if exp)
  (define (expand exps)
    (if (no-exp? exps)
	'false
	(let ((first (car exps))
	      (rest (cdr exps)))
	  (if (null? rest)
	      first
	      (make-if first first (expand rest))))))
  (expand (or-exps exp)))


Solution 10.5

If the clause for the new special form appears after the one for
application, the special form will be incorrectly handled as an
application, because application?
just tests for pair?.  In order to recognize a pair that is not any of
the other compound expression types, application? must be tried after
all the others.


Solution 10.6

==> (driver-loop)

;;; M-Eval input:
(define (foo cond else)
  (cond ((= cond 4) 0)
        (else (else cond))))


;;; M-Eval value:
OK

;;; M-Eval input:
(define cond 2)


;;; M-Eval value:
OK

;;; M-Eval input:
(define (else x) (* x x))


;;; M-Eval value:
OK

;;; M-Eval input:
(define (square x) (* x x))


;;; M-Eval value:
OK

;;; M-Eval input:
(foo 4 square)


;;; M-Eval value:
0

;;; M-Eval input:
(foo 2 square)


;;; M-Eval value:
4

;;; M-Eval input:
(cond ((= cond 4) 0)
      (else (else 5)))

;;; M-Eval value:
25


Solution 10.7

;; Add clause to mc-eval:
        ((let? exp) (eval (let->combination exp) env))

(define (let? exp) (tagged-list? exp 'let))
(define (let-bindings exp)
  (define (let-b lst)
    (if (last-exp? lst)
        nil
        (cons (list (car lst) (caddr lst))
              (let-b (cddddr lst)))))
  (let-b (rest-exps exp)))
(define (let-body exp) (list (last exp)))

(define (let-var binding) (car binding))
(define (let-val binding) (cadr binding))

(define (make-combination operator operands) (cons operator operands))

(define (let->combination exp)
  (let ((bindings (let-bindings exp)))
    (make-combination (make-lambda (map let-var bindings)
				   (let-body exp))
		      (map let-val bindings))))
		     
(define (last lst)
  (if (null? (cdr lst)) 
      (car lst)
      (last (cdr lst))))


Solution 10.8
;; Add clause to mc-eval:
        ((repeat? exp) (mc-eval (repeat->sequence exp) env))
;; and add all this:

(define (repeat? exp) (tagged-list? exp 'repeat))
(define (repeat-counter exp) (cadr exp))
(define (repeat-body exp) (caddr exp))

(define (repeat->sequence exp)
  (let ((c (repeat-counter exp))
        (b (repeat-body exp)))
  (list 'begin
        (list 'define 'nnn c)
        (list 'define
              (list 'fff)
              (list 'cond
                    (list (list '> 'nnn 0)
                          b
                         (list 'set! 'nnn (list '- 'nnn 1))
                         (list 'fff))
                    (list 'else (list 'quote 'ok))))                       
        (list 'fff))))

;; Problem in this solution - need to generate unique new names instead
;; of the use of nnn and fff. This can be done by calling a special
;; procedure that returns a fresh new name.

;; Alternative solution:
;; Add clause to mc-eval:
        ((repeat? exp) (eval-repeat exp env)) 
;; and add all this:

(define (repeat? exp) (tagged-list? exp 'repeat))
(define (repeat-counter exp) (cadr exp))
(define (repeat-body exp) (caddr exp))

(define (eval-repeat exp env) 
  (do1 (mc-eval (repeat-counter exp) env)
       (repeat-body exp)
       env))

(define (do1 n pro env)
  (if (= n 0)
      'ok
      (begin (mc-eval pro env) (do1 (-1+ n) pro env))))