Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #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))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement