Pasted

#lang racket
 
;; This will not run due to undefined terms.
 
;;;;;;;;;
;; 4.2 ;;
;;;;;;;;;
 
;; a.  Since the predicate for recognizing procedure applications was 'any compound
;; expression not already parsed', the repl will mistake any compound expression with
;; a lower clause as a procedure application.  For example, upon encountering
;; (define x 3), the repl will search the environment for a procedure named define.
 
;; b.  The predicate and selectors for procedure applications must change to:
 
(define (application? expr) (tagged-list? expr 'call))
(define (operator expr) (second expr))
(define (operands expr) (rest (rest expr)))
 
;;;;;;;;;
;; 4.3 ;;
;;;;;;;;;
 
;; Assume we have all the selectors and constructors, as in the book.
;; Assume also that procedure applications are tagged lists beginning with 'call.
;; Then the data-directed version of my-eval looks like this:
 
(define eval-table (make-hash))
(define (put type item) (hash-set! eval-table type item))
(define (get type) (hash-ref eval-table type))
 
(define (type expr)
  (and (pair? expr)
       (symbol? (first expr))
       (first expr)))
 
(define (my-eval expr env) ; data-directed style
  (cond [(self-evaluating? expr) expr] 
        [(variable? expr) (lookup-variable-value expr env)]
        [else ((get (type expr)) expr env)]))
 
(define (install-evaluation-rules)
  (define (quote-rule expr env)
    (text-of-quotation expr))
  (define (assignment-rule expr env)
    (eval-assignment expr env))
  (define (definition-rule expr env)
    (eval-definition expr env))
  (define (lambda-rule expr env)
    (make-procedure (lambda-parameters expr)
                    (lambda-body expr)
                    env))
  (define (conditional-rule expr env)
    (eval-if expr env))
  (define (begin-rule expr env)
    (eval-sequence (begin-actions expr) env))
  (define (application-rule expr env)
    (my-apply (my-eval (operator expr) env)
              (list-of-values (operands expr) env)))
  (define (cond-rule expr env)
    (my-eval (cond->if expr) env))
  (put 'quote quote-rule)
  (put 'set! assignment-rule)
  (put 'define definition-rule)
  (put 'lambda lambda-rule)
  (put 'if conditional-rule)
  (put 'begin begin-rule)
  (put 'call application-rule)
  (put 'cond cond-rule)
  )
 
;;;;;;;;;
;; 4.4 ;;
;;;;;;;;;
 
;; AND
 
;; Add this clause to my-eval:
    [(and? expr) (eval-and expr env)]
 
(define (and? expr) (tagged-list? expr 'and))
(define (and-operands expr) (rest expr))
(define (make-and sequence) (cons 'and sequence))
(define (eval-and expr env)
  (define ops (and-operands expr))
  (cond [(empty? ops) 'true] ; (and) should be true
        [else
          (define val (my-eval (first ops) env))
          (define rest-ops (rest ops))
          (cond [(empty? rest-ops) val] ; (and x) should be x
                [(eq? val 'false) 'false]
                [else
                  (eval-and (make-and rest-ops) env)])]))
 
;; OR
 
;; Add this clause to my-eval:
    [(or? expr) (eval-or expr env)]
 
(define (or? expr) (tagged-list? expr 'or))
(define (or-operands expr) (rest expr))
(define (make-or sequence) (cons 'or sequence))
(define (eval-or expr env)
  (define ops (or-operands expr))
  (cond [(empty? ops) 'false] ; (or) should be false
        [else
          (define val (my-eval (first ops) env))
          (define rest-ops (rest first-ops))
          (cond [(empty? rest-ops) val] ; (or x) should be x
                [(not (eq? val 'false)) val]
                [else
                  (eval-or (make-or rest-ops) env)])]))
 
;; AND AS A DERIVED EXPRESSION
 
(define (and->if expr)
  (expand-and-operands (and-operands expr)))
(define (expand-and-operands ops)
  (cond [(empty? ops) 'true]
        [else
          (define first-op (first ops))
          (define rest-ops (rest ops))
          (cond [(empty? rest-ops) first-op]
                [else
                  (make-if first-op
                           (and->if (make-and rest-ops))
                           'false)])]))
 
;; test
 
(and->if '(and x1 x2 x3))
;; '(if x1 (if x2 x3 false) false)
 
;; OR AS A DERIVED EXPRESSION
 
(define (or->if expr)
  (expand-or-operands (or-operands expr)))
(define (expand-or-operands ops)
  (cond [(empty? ops) 'false] ; (or) should return false
        [else
          (define first-op (first ops))
          (define rest-ops (rest ops))
          (cond [(empty? rest-ops) first-op] ; (or x) should return x
                [else
                  (make-if first-op
                           first-op ; inefficient second evaluation
                           (or->if (make-or rest-ops)))])]))
 
;; test
 
(or->if '(or y1 y2 y3))
;; '(if y1 y1 (if y2 y2 y3))
 
;; OR AS A DERIVED EXPRESSION, WITH ACCESS TO THE ENVIRONMENT
 
(define (or->if2 expr env)
  (expand-or-operands2 (or-operands expr) env))
(define (expand-or-operands2 ops env)
  (cond [(empty? ops) 'false]
        [else
          (define val (my-eval (first ops) env))
          (define rest-ops (rest ops))
          (cond [(empty? rest-ops) val]
                [else
                  (make-if val ; no inefficient second evaluation
                           val
                           (or->if2 (make-or rest-ops)))])]))
 
;;;;;;;;;
;; 4.5 ;;
;;;;;;;;;
 
(define (cond? expr) (tagged-list? expr 'cond))
(define (cond-clauses expr) (rest expr))
; regular cond clause
(define (cond-predicate clause) (first clause))
(define (cond-actions clause) (rest clause))
; alternate test clause
(define (cond-alternate-clause? clause)
  (eq? (second clause) '=>))
(define (cond-test clause) (first clause))
(define (cond-recipient clause) (third clause))
; else clause
(define (cond-else-clause? clause)
  (eq? (cond-predicate clause) 'else))
; derive cond from if, needs access to the environment
(define (cond->if expr)
  (expand-clauses (cond-clauses expr)))
(define (expand-clauses clauses)
  (cond [(empty? clauses) 'false] ; no else clause
        [else
          (define first-clause (first clauses))
          (define rest-clauses (rest clauses))
          (cond [(cond-else-clause? first-clause)
                 (if (empty? rest-clauses)
                   (sequence->exp (cond-actions first-clause))
                   (error "ELSE clause isn't last -- COND->IF" clauses))]
                [(cond-alternate-clause? first-clause)
                 (define test (cond-test first-clause))
                 (define recipient (cond-recipient first-clause))
                 (make-if test
                          (list recipient test)
                          (expand-clauses rest-clauses))]
                [else
                  (make-if (cond-predicate first-clause)
                           (sequence->exp (cond-actions first-clause))
                           (expand-clauses rest-clauses))])]))
 
;; tests
 
(cond->if '(cond [a 1] [b 2] [else 3]))
;; '(if a 1 (if b 2 3))
 
(cond->if '(cond [a 1] [(list 1 2) => car] [else 3]))
;; '(if a 1 (if (list 1 2) (car (list 1 2)) 3))
 
;;;;;;;;;
;; 4.6 ;;
;;;;;;;;;
 
;; Add this clause to my-eval:
    [(let? expr) (my-eval (let->combination expr) env)]
 
(define (let? expr) (tagged-list? expr 'let))
(define (let-bindings expr) (second expr))
(define (let-parameters expr) (map first (let-bindings expr)))
(define (let-expressions expr) (map second (let-bindings expr)))
(define (let-body expr)
  (sequence->exp (rest (rest expr))))
(define (let->combination expr)
  (cond [(empty? (let-bindings expr)) ; do not unnecessarily lambda wrap
         (let-body expr)]
        [else
          (cons (make-lambda (let-parameters expr)
                             (let-body expr))
                (let-expressions expr))]))
(define (make-let bindings body)
  (cons 'let (list bindings body)))
 
;; test
 
(let->combination '(let () (+ 1 2)))
;; '(+ 1 2)
 
(let->combination '(let ((a 1) (b 2)) (+ a b)))
;; '((lambda (a b) (+ a b)) 1 2)
 
;;;;;;;;;
;; 4.7 ;;
;;;;;;;;;
 
;; I think it's fine to implement let* as a derived form.  my-eval will have to be
;; called recursively to evaluate the inner let's, but that's fine, my-eval is meant
;; to be recursive.
 
;; Add this clause to my-eval:
    [(let*? expr) (my-eval (let*->nested-lets expr) env)]
 
(define (let*? expr) (tagged-list? expr 'let*))
(define (let*-bindings expr) (second expr))
(define (let*-body expr)
  (sequence->exp (rest (rest (expr)))))
(define (make-let* bindings body)
  (cons 'let* (list bindings body)))
 
(define (let*->nested-lets expr)
  (define bindings (let*-bindings expr))
  (cond [(empty? bindings)
         (let-body expr)]
        [else
          (make-let
            (list (first bindings))
            (let*->nested-lets
              (make-let* (rest bindings)
                         (let-body expr))))]))
 
;; test
 
(let*->nested-lets '(let* () (+ 1 2)))
;; '(+ 1 2)
 
(let*->nested-lets '(let* ((a 1) (b (+ a 1))) (+ a b)))
;; '(let ((a 1)) (let ((b (+ a 1))) (+ a b)))
 
(let->combination (let*->nested-lets '(let* ((a 1) (b (+ a 1))) (+ a b))))
;; '((lambda (a) (let ((b (+ a 1))) (+ a b))) 1)
 
;;;;;;;;;
;; 4.8 ;;
;;;;;;;;;
 
;; Add this clause to my-eval:
    [(named-let? expr) (my-eval (named-let->sequence expr) env)]
 
(define (named-let? expr)
  (and (let? expr)
       (not (list? (second expr)))))
(define (named-let-name expr) (second expr))
(define (named-let-bindings expr) (third expr))
(define (named-let-parameters expr) (map first (named-let-bindings expr)))
(define (named-let-expressions expr) (map second (named-let-bindings expr)))
(define (named-let-body expr)
  (sequence->exp (rest (rest (rest expr)))))
 
;; At first I tried converting the named let to a regular let by adding the name-body
;; pair as a new let-binding, but that did not work.
 
;; For example, my original wrong named-let->sequence took the expression below,
;; which, when unquoted, evaluates to (fib 10) = 55;  and produced an expression
;; that, when unquoted, produced a 'fib-iter undefined' error:
 
'(let fib-iter ((a 1)
                (b 0)
                (count 10))
   (if (zero? count)
     b
     (fib-iter (+ a b) a (sub1 count))))
;; '((lambda (fib-iter a b count)
    ;; (if (zero? count) b (fib-iter (+ a b) a (sub1 count))))
  ;; (lambda (a b count) (if (zero? count) b (fib-iter (+ a b) a (sub1 count))))
  ;; 1
  ;; 0
  ;; 10)
 
((lambda (fib-iter a b count)
   (if (zero? count) b (fib-iter (+ a b) a (sub1 count))))
 (lambda (a b count) (if (zero? count) b (fib-iter (+ a b) a (sub1 count))))
 1
 0
 10)
;; . . fib-iter: undefined;
 ;; cannot reference undefined identifier
 
;; So this version of named-let->sequence creates a sequence of two expressions,
;; one to define the named function, and the second to apply it to the named-let
;; expressions.
 
(define (named-let->sequence expr)
  (define bindings (named-let-bindings expr))
  (cond [(empty? bindings)
         (named-let-body expr)]
        [else
          (list 'begin
                (list 'define ; first define the named function
                      (cons (named-let-name expr)
                            (named-let-parameters expr))
                      (named-let-body expr))
                (cons (named-let-name expr) ; then apply it to the expressions
                      (named-let-expressions expr)))]))
 
;; test
 
(named-let->sequence '(let f () (+ 1 2)))
;; '(+ 1 2)
 
(named-let->sequence
  '(let fib-iter ((a 1)
                  (b 0)
                  (count 10))
     (if (zero? count)
       b
       (fib-iter (+ a b) a (sub1 count)))))
;; '(begin
   ;; (define (fib-iter a b count)
     ;; (if (zero? count) b (fib-iter (+ a b) a (sub1 count))))
   ;; (fib-iter 1 0 10))
 
(begin
  (define (fib-iter a b count)
    (if (zero? count) b (fib-iter (+ a b) a (sub1 count))))
  (fib-iter 1 0 10))
;; 55
 
;;;;;;;;;
;; 4.9 ;;
;;;;;;;;;
 
;; THE WHILE LOOP
 
'(while <test> do <body>)
 
;; is a derived form for:
 
'(if <test>
   (begin <body>
          (while <test> do <body>))
   done)
 
;; Add this clause to my-eval:
    [(while? expr) (my-eval (while->if expr) env)]
 
(define (while? expr) (tagged-list? expr 'while))
(define (while-test expr) (second expr))
(define (while-body expr) (fourth expr))
(define (make-while test body) (list 'while test 'do body))
(define (while->if expr)
  (make-if (while-test expr)
           (list 'begin
                 (while-body expr)
                 (make-while (while-test expr)
                             (while-body expr)))
           'done))
 
;; test
 
(while->if '(while (positive? x) do (begin (log! x) (set! x (sub1 x)))))
;; '(if (positive? x)
   ;; (begin
     ;; (begin (log! x) (set! x (sub1 x)))
     ;; (while (positive? x) do (begin (log! x) (set! x (sub1 x)))))
   ;; done)
 
;;;;;;;;;;
;; 4.10 ;;
;;;;;;;;;;
 
;; For example we could change the syntax for assignment from:
 
(set! <var> <value>)
 
;; to:
 
(set! <value> <var>)
 
;; simply by changing the following procedures:
 
(define (assignment-variable expr) (third expr))
(define (assignment-value expr) (second expr))