481 lines
15 KiB
Racket
481 lines
15 KiB
Racket
#lang sicp
|
|
|
|
(#%provide (all-defined))
|
|
(#%require racket/trace
|
|
rackunit
|
|
(only racket/base module+))
|
|
|
|
(define (self-evaluating? exp)
|
|
(cond ((number? exp) true)
|
|
((string? exp) true)
|
|
((eq? exp '*unassigned*) true) ; Special symbol that can
|
|
; never be a variable.
|
|
(else false)))
|
|
|
|
(define (quoted? exp)
|
|
(tagged-list? exp 'quote))
|
|
(define (text-of-quotation exp) (cadr exp))
|
|
|
|
;; Exercise 4.33
|
|
;; Transform quoted list to (cons a (cons b ...)). This will be
|
|
;; evaluated by whichever version of cons (lazy or strict) is in scope
|
|
;; in the evaluator.
|
|
|
|
|
|
;; (quote (a b c)) -> (cons (quote a) (cons (quote b) (cons (quote c) (quote ()))))
|
|
|
|
;; (eval 'a) -> a
|
|
;; (eval '(a))
|
|
;; -> (eval `(cons ,(car '(a)) ,(cdr '(a))))
|
|
;; -> (eval (cons 'a '()))
|
|
|
|
;; (eval '(a . b))
|
|
;; -> (eval `(cons ,(car '(a . b)) ,(cdr '(a . b))))
|
|
;; -> (eval `(cons 'a 'b))
|
|
|
|
;; (eval '(a b))
|
|
;; -> (eval `(cons ,(car '(a b)) (cons ,(cadr '(a b)) ,(cdr (cdr '(a
|
|
;; b))))))
|
|
;; -> (eval `(cons 'a (cons 'b ())))
|
|
|
|
;; (eval '(a b))
|
|
;; -> (eval (eval-quoted '(a b)))
|
|
;; -> (eval `(cons 'a ,(eval-quoted '(b))))
|
|
;; -> (eval `(cons 'a (cons 'b ,eval-quoted('()))))
|
|
;; -> (eval `(cons 'a (cons 'b '())))
|
|
|
|
(define (quoted-exp->cons-quoted exp)
|
|
(cond ((null? exp) (list 'quote '()))
|
|
((pair? exp)
|
|
(list 'cons
|
|
(cond ((pair? (car exp))
|
|
(quoted-exp->cons-quoted (car exp)))
|
|
(else
|
|
(list 'quote (car exp))))
|
|
(quoted-exp->cons-quoted (cdr exp))))
|
|
(else (list 'quote exp))))
|
|
|
|
(module+ test
|
|
(check-equal? (quoted-exp->cons-quoted '(a b))
|
|
'(cons 'a (cons 'b '())))
|
|
(check-equal? (quoted-exp->cons-quoted '(a (b c) d))
|
|
'(cons 'a
|
|
(cons (cons 'b (cons 'c '()))
|
|
(cons 'd '()))))
|
|
(check-equal? (quoted-exp->cons-quoted '(a . b))
|
|
'(cons 'a 'b))
|
|
(check-equal? (quoted-exp->cons-quoted '((a . b) c))
|
|
'(cons (cons 'a 'b) (cons 'c '())))
|
|
(check-equal? (quoted-exp->cons-quoted '((a . b) . c))
|
|
'(cons (cons 'a 'b) 'c))
|
|
(check-equal? (quoted-exp->cons-quoted 'a)
|
|
(list 'quote 'a))
|
|
(check-equal? (quoted-exp->cons-quoted '1)
|
|
(list 'quote 1)))
|
|
|
|
(define (tagged-list? exp tag)
|
|
(if (pair? exp)
|
|
(eq? (car exp) tag)
|
|
false))
|
|
|
|
(define (variable? exp) (symbol? exp))
|
|
|
|
;; Assignment
|
|
(define (assignment? exp)
|
|
(tagged-list? exp 'set!))
|
|
(define (assignment-variable exp) (cadr exp))
|
|
(define (assignment-value exp) (caddr exp))
|
|
(define (make-assignment variable value)
|
|
(list 'set! variable value))
|
|
|
|
;; Definition
|
|
(define (definition-variable exp)
|
|
(if (symbol? (cadr exp))
|
|
(cadr exp)
|
|
(caadr exp)))
|
|
(define (definition-value exp)
|
|
(if (symbol? (cadr exp))
|
|
(caddr exp)
|
|
(make-lambda (cdadr exp)
|
|
(cddr exp))))
|
|
(define (definition? exp)
|
|
(tagged-list? exp 'define))
|
|
|
|
;; Unbinding
|
|
(define (make-unbound? exp) (tagged-list? exp 'make-unbound!))
|
|
(define (unbound-variable exp) (cadr exp))
|
|
|
|
;; Lambda
|
|
(define (lambda? exp) (tagged-list? exp 'lambda))
|
|
(define (lambda-parameters exp) (cadr exp))
|
|
(define (lambda-body exp) (cddr exp))
|
|
(define (make-lambda parameters body)
|
|
(cons 'lambda (cons parameters body)))
|
|
|
|
;; Lazy-pair lambda is used to model lazy pairs
|
|
(define (lazy-pair-lambda? exp) (tagged-list? exp 'lazy-pair-lambda))
|
|
|
|
;; if
|
|
(define (if? exp) (tagged-list? exp 'if))
|
|
(define (if-predicate exp) (cadr exp))
|
|
(define (if-consequent exp) (caddr exp))
|
|
(define (if-alternative exp)
|
|
(if (not (null? (cdddr exp)))
|
|
(cadddr exp)
|
|
'false))
|
|
(define (make-if predicate consequent alternative)
|
|
(list 'if predicate consequent alternative))
|
|
|
|
;; Sequence
|
|
(define (begin? exp) (tagged-list? exp 'begin))
|
|
(define (begin-actions exp) (cdr exp))
|
|
|
|
(define (last-exp? seq) (null? (cdr seq)))
|
|
(define (first-exp seq) (car seq))
|
|
(define (rest-exps seq) (cdr seq))
|
|
|
|
(define (sequence->exp seq)
|
|
(cond ((null? seq) seq)
|
|
((last-exp? seq) (first-exp seq))
|
|
(else (make-begin seq))))
|
|
|
|
(define (make-begin seq) (cons 'begin seq))
|
|
|
|
;; Application
|
|
(define (application? exp) (pair? exp))
|
|
(define (operator exp) (car exp))
|
|
(define (operands exp) (cdr exp))
|
|
(define (make-application operator operands)
|
|
(cons operator operands))
|
|
|
|
(define (no-operands? ops) (null? ops))
|
|
(define (first-operand ops) (car ops))
|
|
(define (rest-operands ops) (cdr ops))
|
|
(define (last-operand? ops) (null? (rest-operands ops)))
|
|
|
|
;; cond (including recipient clause for exercise 4.5)
|
|
(define (cond? exp) (tagged-list? exp 'cond))
|
|
(define (cond-clauses exp) (cdr exp))
|
|
(define (cond-else-clause? clause)
|
|
(eq? (cond-predicate clause) 'else))
|
|
(define (cond-recipient-clause? clause)
|
|
(eq? (cond-infix-op clause) '=>))
|
|
(define (cond-predicate clause) (car clause))
|
|
(define (cond-infix-op clause) (cadr clause))
|
|
(define (cond-recipient clause) (caddr clause))
|
|
(define (cond-actions clause) (cdr clause))
|
|
|
|
(define (cond->if exp)
|
|
(expand-clauses (cond-clauses exp)))
|
|
|
|
(define (expand-clauses clauses)
|
|
(if (null? clauses)
|
|
'false ; no else clause
|
|
(let ((first (car clauses))
|
|
(rest (cdr clauses)))
|
|
(cond ((cond-else-clause? first)
|
|
(if (null? rest)
|
|
(sequence->exp (cond-actions first))
|
|
(error "ELSE clause isn't last -- COND->IF"
|
|
clauses)))
|
|
((cond-recipient-clause? first)
|
|
(let ((test (cond-predicate first))
|
|
(proc (cond-recipient first)))
|
|
(if proc
|
|
(make-if test
|
|
(make-application proc test)
|
|
(expand-clauses rest))
|
|
(error "RECIPIENT clause missing -- COND->IF"))))
|
|
(else (make-if (cond-predicate first)
|
|
(sequence->exp (cond-actions first))
|
|
(expand-clauses rest)))))))
|
|
|
|
|
|
;; Exercise 4.4
|
|
;; and / or
|
|
;; Truth expressions are a list whose car is 'and or 'or and where
|
|
;; the rest of the list is the expressions to evaluate.
|
|
(define (first-conjunct conjuncts) (cadr conjuncts))
|
|
(define (rest-conjuncts conjuncts) (cddr conjuncts))
|
|
(define (last-conjunct? conjuncts) (null? (rest-conjuncts conjuncts)))
|
|
|
|
(define (make-and conjuncts) (cons 'and conjuncts))
|
|
|
|
(define (first-disjunct disjuncts) (cadr disjuncts))
|
|
(define (rest-disjuncts disjuncts) (cddr disjuncts))
|
|
(define (last-disjunct? disjuncts) (null? (rest-disjuncts disjuncts)))
|
|
|
|
(define (make-or disjuncts) (cons 'or disjuncts))
|
|
|
|
(define (let? exp) (tagged-list? exp 'let))
|
|
(define (named-let? exp) (and (let? exp) (symbol? (cadr exp))))
|
|
|
|
(define (named-let-var exp) (cadr exp))
|
|
(define (let-clauses exp) (if (named-let? exp) (caddr exp) (cadr exp)))
|
|
(define (let-body exp) (if (named-let? exp) (cdddr exp) (cddr exp)))
|
|
(define (let-clauses-first clauses) (car clauses))
|
|
(define (let-clauses-rest clauses) (cdr clauses))
|
|
(define (let-clause-last? clauses) (null? (let-clauses-rest clauses)))
|
|
(define (let-clause-var clause) (car clause))
|
|
(define (let-clause-exp clause) (cadr clause))
|
|
(define make-body list)
|
|
(define (make-let clauses body)
|
|
(cons 'let (cons clauses body)))
|
|
(define (make-named-let var clauses body)
|
|
(cons 'let (cons var (cons clauses body))))
|
|
|
|
(define (let->combination exp)
|
|
(let ((clauses (let-clauses exp))
|
|
(body (let-body exp)))
|
|
(let ((clause-vars (map let-clause-var clauses))
|
|
(clause-exps (map let-clause-exp clauses)))
|
|
(if (named-let? exp)
|
|
(let ((named-proc (let-clause-exp exp)))
|
|
(make-application
|
|
(make-lambda
|
|
`(,named-proc)
|
|
(make-body
|
|
(make-application
|
|
(make-lambda
|
|
'(proc)
|
|
(make-body
|
|
(make-assignment named-proc 'proc)
|
|
(make-application named-proc clause-exps)))
|
|
(make-body (make-lambda ; Passed in as an argument to
|
|
; the previous lambda to
|
|
; prevent capture of clause-vars
|
|
clause-vars
|
|
body)))))
|
|
(make-body 0)))
|
|
(make-application
|
|
(make-lambda clause-vars body)
|
|
clause-exps)))))
|
|
|
|
|
|
|
|
;; Exercise 4.8:
|
|
;; Named let: to make the binding of the named procedure in scope
|
|
;; during the definition, create a place for it and bind its name to
|
|
;; that place. This is before the procedure is defined, so set it 0
|
|
;; and use set! inside the body to set it to the required procedure.
|
|
;; Putting it in the lambda parameters ensures it is in the
|
|
;; environment. set! sets its required value (i.e the procedure whose
|
|
;; body is that of the let body) once this is known. Note that the
|
|
;; procedure is constructed outside the inner lambda scope to avoid
|
|
;; capturing the let parameters.
|
|
|
|
;; Worked example: fact
|
|
|
|
;; (let fact ((n 5))
|
|
;; (if (= n 1) 1
|
|
;; (* n (fact (- n 1)))))
|
|
|
|
;; ((lambda (fact)
|
|
;; ((lambda (proc)
|
|
;; (set! fact proc)
|
|
;; (fact 5))
|
|
;; (lambda (n) ; Let body
|
|
;; (if (= n 1) 1
|
|
;; (* n (fact (- n 1))))))
|
|
;; 0)) ; Placeholder value, reset by set!
|
|
|
|
;; Exercise 4.7
|
|
;; (let* ((var1 exp1) (var2 exp2) (var3 exp3)) <body>) ->
|
|
;; (let ((var1 exp1)) (let ((var2 exp2)) (let ((var3 exp3)) body)))
|
|
|
|
(define (let*->nested-let exp)
|
|
(let ((clauses (let-clauses exp))
|
|
(body (let-body exp)))
|
|
(define (nested-let-from-clauses clauses)
|
|
(make-let
|
|
(list (let-clauses-first clauses))
|
|
(if (let-clause-last? clauses)
|
|
body
|
|
(make-body (nested-let-from-clauses
|
|
(let-clauses-rest clauses))))))
|
|
(nested-let-from-clauses clauses)))
|
|
|
|
|
|
|
|
;; It is sufficient to add this derived form into the interpreter to
|
|
;; transform let* into let. This transformed expression is then
|
|
;; evaluated and transformed in turn to a combination, which is then evaluated.
|
|
|
|
;; Exercise 4.9
|
|
|
|
;; for loop
|
|
;; (for ((var1 init1 step1)
|
|
;; (var2 init2 step2) ... )
|
|
;; (test expression)
|
|
;; body)
|
|
;;
|
|
;; Initialise var1 to init1, var2 to init2, ...
|
|
;; If test is true, execute body and increment init1 with step1, init2
|
|
;; with step2, ... Otherwise return the result of evaluating expression.
|
|
|
|
(define (for? exp) (tagged-list? exp 'for))
|
|
(define (for-clauses exp) (and (for? exp) (cadr exp)))
|
|
(define for-clause-var car)
|
|
(define for-clause-init cadr)
|
|
(define for-clause-step caddr)
|
|
(define (for-test exp) (and (for? exp) (caddr exp)))
|
|
(define for-test-pred car)
|
|
(define for-test-exp cadr)
|
|
(define (for-body exp) (and (for? exp) (cdddr exp)))
|
|
|
|
(define (for->named-let exp)
|
|
(let ((clauses (for-clauses exp))
|
|
(test (for-test exp))
|
|
(body (for-body exp)))
|
|
(make-named-let
|
|
'loop
|
|
(map (lambda (clause)
|
|
(list
|
|
(for-clause-var clause)
|
|
(for-clause-init clause)))
|
|
clauses)
|
|
(make-body
|
|
(make-if (for-test-pred test)
|
|
(make-begin
|
|
(append body
|
|
(make-body
|
|
(make-application
|
|
'loop
|
|
(map for-clause-step clauses)))))
|
|
(for-test-exp test))))))
|
|
|
|
;; Exercise 4.20
|
|
(define (letrec? exp) (tagged-list? exp 'letrec))
|
|
(define (letrec-clauses exp) (cadr exp))
|
|
(define (letrec-body exp) (cddr exp))
|
|
(define (letrec-clauses-first clauses) (car clauses))
|
|
(define (letrec-clauses-rest clauses) (cdr clauses))
|
|
(define (letrec-clause-var clause) (car clause))
|
|
(define (letrec-clause-exp clause) (cadr clause))
|
|
(define (make-letrec clauses body)
|
|
(cons 'letrec (cons clauses body)))
|
|
|
|
(define (letrec->let exp)
|
|
(let* ((letrec-clauses (letrec-clauses exp))
|
|
(letrec-body (letrec-body exp))
|
|
(clause-vars (map let-clause-var letrec-clauses))
|
|
(clause-exps (map let-clause-exp letrec-clauses))
|
|
(let-clauses
|
|
(map (lambda (var) (list var '*unassigned*))
|
|
clause-vars))
|
|
(assignments
|
|
(map (lambda (var exp) (make-assignment var exp))
|
|
clause-vars
|
|
clause-exps))
|
|
(let-body (append assignments letrec-body)))
|
|
(make-let let-clauses let-body)))
|
|
|
|
;; Exercise 4.26: unless
|
|
(define (unless? exp) (tagged-list? exp 'unless))
|
|
(define (unless-predicate exp) (cadr exp))
|
|
(define (unless-alternative exp) (caddr exp))
|
|
(define (unless-consequent exp) (cadddr exp))
|
|
|
|
(define (unless->if exp)
|
|
(make-if (unless-predicate exp)
|
|
(unless-consequent exp)
|
|
(unless-alternative exp)))
|
|
|
|
(define (make-procedure parameters body env)
|
|
(list 'procedure parameters body env))
|
|
|
|
(define (compound-procedure? p)
|
|
(tagged-list? p 'procedure))
|
|
|
|
;; Lazy-pair procedure is a normal procedure tagged with lazy-pair to
|
|
;; distinguish lazy pairs from procedures
|
|
(define (make-lazy-pair-procedure parameters body env)
|
|
(make-lazy-pair (make-procedure parameters body env)))
|
|
|
|
(define (procedure-parameters p) (cadr p))
|
|
(define (procedure-body p) (caddr p))
|
|
(define (procedure-environment p) (cadddr p))
|
|
|
|
;; Exercise 4.16: transform the body to scan out internal
|
|
;; definitions. Variables will be created unassigned by a let and
|
|
;; then initialised by a set! inside the let body. Perhaps it is
|
|
;; possible to do this in one pass while still keeping the clean
|
|
;; recursive structure (ie not resorting to append or set! at each
|
|
;; iteration), but this is probably good enough, given that the size
|
|
;; of the body is likely to be quite small.
|
|
(define (scan-out-defines body)
|
|
;; Get a list of defined variables in the body
|
|
(define (scan-vars body)
|
|
(if (null? body)
|
|
'()
|
|
(let ((exp (first-exp body)))
|
|
(if (definition? exp)
|
|
(cons (definition-variable exp)
|
|
(scan-vars (rest-exps body)))
|
|
(scan-vars (rest-exps body))))))
|
|
;; Convert all definitions to assignments
|
|
(define (definition->assignment body)
|
|
(if (null? body)
|
|
'()
|
|
(let ((exp (first-exp body)))
|
|
(cons
|
|
(if (definition? exp)
|
|
(make-assignment (definition-variable exp)
|
|
(definition-value exp))
|
|
exp)
|
|
(definition->assignment (rest-exps body))))))
|
|
(define (make-unassigned-let vars body)
|
|
(make-let
|
|
(map (lambda (var)
|
|
(list var '*unassigned*))
|
|
vars)
|
|
body))
|
|
(let ((vars (scan-vars body)))
|
|
(if (null? vars)
|
|
body
|
|
(make-body
|
|
(make-unassigned-let vars
|
|
(definition->assignment body))))))
|
|
|
|
|
|
;;;SECTION 4.1.4
|
|
|
|
(define (primitive-procedure? proc)
|
|
(tagged-list? proc 'primitive))
|
|
|
|
(define (primitive-implementation proc) (cadr proc))
|
|
|
|
;;;; Thunks
|
|
|
|
(define (make-thunk exp env)
|
|
(list 'thunk exp env))
|
|
|
|
(define (thunk? obj)
|
|
(tagged-list? obj 'thunk))
|
|
|
|
(define (thunk-exp thunk) (cadr thunk))
|
|
(define (thunk-env thunk) (caddr thunk))
|
|
|
|
;; "thunk" that has been forced and is storing its (memoized) value
|
|
(define (evaluated-thunk? obj)
|
|
(tagged-list? obj 'evaluated-thunk))
|
|
|
|
(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
|
|
|
|
;; Lazy lists (exercise 4.34)
|
|
(define (make-lazy-pair exp)
|
|
(list 'lazy-pair exp))
|
|
|
|
(define (lazy-pair? obj)
|
|
(tagged-list? obj 'lazy-pair))
|
|
|
|
(define (lazy-pair-proc lazy-pair)
|
|
(cadr lazy-pair))
|
|
|
|
(define (cons? exp)
|
|
(tagged-list? exp 'cons))
|
|
(define (cons-first-exp exp)
|
|
(cadr exp))
|
|
(define (cons-second-exp exp)
|
|
(caddr exp))
|