322 lines
12 KiB
Scheme
322 lines
12 KiB
Scheme
; Exercise 4.11
|
|
(define (make-frame bindings) (cons '*frame* bindings))
|
|
(define (lookup-within-frame var frame) (assoc var (cdr frame)))
|
|
(define (add-binding-to-frame! var val frame)
|
|
(set-cdr! frame (cons (cons var val) (cdr frame))))
|
|
|
|
(define the-empty-environment '())
|
|
(define (extend-environment bindings base-env)
|
|
(cons (make-frame bindings) base-env))
|
|
(define (enclosing-environment env) (cdr env))
|
|
(define (first-frame env) (car env))
|
|
|
|
(define (define-variable! var val env)
|
|
(let* ((frame (first-frame env))
|
|
(binding (lookup-within-frame var frame)))
|
|
(if binding
|
|
(set-cdr! binding val)
|
|
(add-binding-to-frame! var val frame))))
|
|
; Exercise 4.12
|
|
(define (lookup-binding variable environment)
|
|
(let loop ((env environment))
|
|
(if (eq? env the-empty-environment)
|
|
#f
|
|
(cond ((lookup-within-frame variable (first-frame env)))
|
|
(else (loop (enclosing-environment env)))))))
|
|
(define (set-variable-value! var val env)
|
|
(cond ((lookup-binding var env) => (lambda (b) (set-cdr! b val)))
|
|
(else (error "Unbound variable: SET!" var))))
|
|
; Exercise 4.16.a
|
|
(define (lookup-variable-value var env)
|
|
(let ((value (cond ((lookup-binding var env) => cdr)
|
|
(else '*unassigned*))))
|
|
(if (eq? value '*unassigned*)
|
|
(error "Unbound variable" var)
|
|
value)))
|
|
|
|
; Exercise 4.3
|
|
(define (make-table)
|
|
(let ((local-table (list '*table*)))
|
|
(define (lookup key)
|
|
(let ((record (assoc key (cdr local-table))))
|
|
(if record (cdr record) #f)))
|
|
(define (insert! key value)
|
|
(let ((record (assoc key (cdr local-table))))
|
|
(if record
|
|
(set-cdr! record value)
|
|
(set-cdr! (let tail ((table local-table))
|
|
(if (null? (cdr table)) table (tail (cdr table))))
|
|
(list (cons key value)))))
|
|
'ok)
|
|
(define (dispatch m)
|
|
(cond ((eq? m 'lookup-proc) lookup)
|
|
((eq? m 'insert-proc!) insert!)
|
|
(else (error "Unknown operation: TABLE" m))))
|
|
dispatch))
|
|
(define anal-table (make-table))
|
|
(define (get-analyzer exp)
|
|
(if (list? exp)
|
|
((anal-table 'lookup-proc) (car exp))
|
|
#f))
|
|
(define (analyze exp)
|
|
(cond ((get-analyzer exp) => (lambda (analyzer) (analyzer exp)))
|
|
((or (number? exp) (string? exp)) (lambda (env) exp))
|
|
((symbol? exp) (lambda (env) (lookup-variable-value exp env)))
|
|
((pair? exp) (analyze-application (cons 'call exp)))
|
|
(else (error "Unknown expression type: ANALYZE" exp))))
|
|
|
|
(define (definition? exp) (and (list? exp) (eq? (car exp) 'define)))
|
|
(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 (analyze-definition exp)
|
|
(let ((var (definition-variable exp))
|
|
(vproc (analyze (definition-value exp))))
|
|
(lambda (env)
|
|
(define-variable! var (vproc env) env)
|
|
'ok)))
|
|
|
|
(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))
|
|
; Exercise 4.16
|
|
(define (define->set! exp)
|
|
(if (definition? exp)
|
|
(list 'set! (definition-variable exp) (definition-value exp))
|
|
exp))
|
|
(define (analyze-sequence exps)
|
|
(let ((vars (map definition-variable (filter definition? exps))))
|
|
(if (null? vars)
|
|
(let ((procs (map analyze exps)))
|
|
(if (null? procs)
|
|
(error "Empty sequence: ANALYZE")
|
|
(let loop ((first-proc (car procs))
|
|
(rest-procs (cdr procs)))
|
|
(if (null? rest-procs)
|
|
first-proc
|
|
(loop (lambda (env) (first-proc env) ((car rest-procs) env))
|
|
(cdr rest-procs))))))
|
|
(analyze (list* (list* 'lambda vars (map define->set! exps))
|
|
(map (lambda (var) ''*unassigned*) vars))))))
|
|
(define (analyze-begin exp) (analyze-sequence (begin-actions exp)))
|
|
|
|
(define (primitive-procedure? p) (and (pair? p) (eq? (car p) 'primitive)))
|
|
(define (primitive-implementation p) (cadr p))
|
|
|
|
(define (make-procedure parameters body env)
|
|
(list 'procedure parameters body env))
|
|
(define (compound-procedure? p) (and (pair? p) (eq? (car p) 'procedure)))
|
|
(define (procedure-parameters p) (cadr p))
|
|
(define (procedure-body p) (caddr p))
|
|
(define (procedure-environment p) (cadddr p))
|
|
|
|
(define (execute-application proc args)
|
|
(cond ((primitive-procedure? proc)
|
|
(apply (primitive-implementation proc) args))
|
|
((compound-procedure? proc)
|
|
((procedure-body proc)
|
|
(extend-environment (map cons (procedure-parameters proc) args)
|
|
(procedure-environment proc))))
|
|
(else (error "Unknown procedure type: EXECUTE-APPLICATION" proc))))
|
|
|
|
(define (operator exp) (cadr exp))
|
|
(define (operands exp) (cddr exp))
|
|
(define (no-operands? ops) (null? ops))
|
|
(define (first-operand ops) (car ops))
|
|
(define (rest-operands ops) (cdr ops))
|
|
(define (analyze-application exp)
|
|
(let ((fproc (analyze (operator exp)))
|
|
(aprocs (map analyze (operands exp))))
|
|
(lambda (env)
|
|
(execute-application (fproc env)
|
|
(map (lambda (aproc) (aproc env)) aprocs)))))
|
|
|
|
(define (analyze-quoted exp)
|
|
(let ((qval (cadr exp)))
|
|
(lambda (env) qval)))
|
|
|
|
(define (assignment-variable exp) (cadr exp))
|
|
(define (assignment-value exp) (caddr exp))
|
|
(define (analyze-assignment exp)
|
|
(let ((var (assignment-variable exp))
|
|
(vproc (analyze (assignment-value exp))))
|
|
(lambda (env)
|
|
(set-variable-value! var (vproc env) env)
|
|
'ok)))
|
|
|
|
(define (make-lambda parameters body)
|
|
(cons 'lambda (cons parameters body)))
|
|
(define (lambda-parameters exp) (cadr exp))
|
|
(define (lambda-body exp) (cddr exp))
|
|
(define (analyze-lambda exp)
|
|
(let ((vars (lambda-parameters exp))
|
|
(bproc (analyze-sequence (lambda-body exp))))
|
|
(lambda (env) (make-procedure vars bproc env))))
|
|
|
|
(define analyzed-true (lambda (env) (lookup-variable-value 'true env)))
|
|
(define analyzed-false (lambda (env) (lookup-variable-value 'false env)))
|
|
(define (false? evaluated-exp env) (eq? evaluated-exp (analyzed-false env)))
|
|
(define (true? evaluated-exp env) (not (false? evaluated-exp env)))
|
|
(define (if-predicate exp) (cadr exp))
|
|
(define (if-consequent exp) (caddr exp))
|
|
(define (if-alternative exp)
|
|
(if (null? (cdddr exp))
|
|
'false
|
|
(cadddr exp)))
|
|
(define (analyze-if exp)
|
|
(let ((pproc (analyze (if-predicate exp)))
|
|
(cproc (analyze (if-consequent exp)))
|
|
(aproc (analyze (if-alternative exp))))
|
|
(lambda (env) ((if (true? (pproc env) env) cproc aproc) env))))
|
|
|
|
; Exercise 4.4
|
|
(define (analyze-and exp)
|
|
(let loop ((first-exp analyzed-true)
|
|
(rest-exps (map analyze (cdr exp))))
|
|
(if (null? rest-exps)
|
|
first-exp
|
|
(loop (lambda (env)
|
|
(let ((pred (first-exp env)))
|
|
(if (false? pred env) pred ((car rest-exps) env))))
|
|
(cdr rest-exps)))))
|
|
(define (analyze-or-exps analyzed-exps)
|
|
(let loop ((first-exp analyzed-false) (rest-exps analyzed-exps))
|
|
(if (null? rest-exps)
|
|
first-exp
|
|
(loop (lambda (env)
|
|
(let ((pred (first-exp env)))
|
|
(if (false? pred env) ((car rest-exps) env) pred)))
|
|
(cdr rest-exps)))))
|
|
(define (analyze-or exp) (analyze-or-exps (map analyze (cdr exp))))
|
|
|
|
; Exercise 4.5
|
|
(define (cond-clauses exp) (cdr exp))
|
|
(define (cond-predicate clause) (car clause))
|
|
(define (cond-actions clause) (cdr clause))
|
|
(define (analyze-cond-clause clause)
|
|
(let ((pproc (analyze (cond-predicate clause)))
|
|
(bproc (let ((actions (cond-actions clause)))
|
|
(cond ((null? actions) (lambda (pred env) pred))
|
|
((eq? (car actions) '=>)
|
|
(let ((fproc (analyze (cadr actions))))
|
|
(lambda (pred env)
|
|
(execute-application (fproc env) (list pred)))))
|
|
(else (let ((consequences (analyze-sequence actions)))
|
|
(lambda (pred env) (consequences env))))))))
|
|
(lambda (env)
|
|
(let ((pred (pproc env)))
|
|
(if (true? pred env) (bproc pred env) (analyzed-false env))))))
|
|
(define (analyze-cond exp)
|
|
(analyze-or-exps (map analyze-cond-clause (cond-clauses exp))))
|
|
|
|
; Exercise 4.6
|
|
(define (let->combination exp)
|
|
(let ((ad (cadr exp))
|
|
(dd (cddr exp)))
|
|
(if (list? ad)
|
|
(list* (list* 'lambda (map car ad) dd)
|
|
(map cadr ad))
|
|
; Exercise 4.8
|
|
`((lambda (,ad)
|
|
(set! ,ad (lambda ,(map car (car dd)) ,@(cdr dd)))
|
|
(,ad ,@(map cadr (car dd))))
|
|
'*unassigned*))))
|
|
; Exercise 4.22
|
|
(define (analyze-let exp) (analyze (let->combination exp)))
|
|
|
|
; Exercise 4.7
|
|
(define (let*->nested-lets exp)
|
|
(let ((body (cddr exp)))
|
|
(let loop ((bindings (cadr exp)))
|
|
(if (or (null? bindings) (last-exp? bindings))
|
|
(list* 'let bindings body)
|
|
(list 'let (list (car bindings)) (loop (cdr bindings)))))))
|
|
(define (analyze-let* exp) (analyze (let*->nested-lets exp)))
|
|
|
|
; Exercise 4.9
|
|
(define (analyze-while exp) ; (while pred body)
|
|
(let ((pproc (analyze (cadr exp)))
|
|
(bproc (analyze-sequence (cddr exp))))
|
|
(lambda (env)
|
|
(let loop ((pred (pproc env)))
|
|
(if (true? pred env)
|
|
(begin (bproc env)
|
|
(loop (pproc env))))))))
|
|
(define (analyze-for exp) ; (for init pred body)
|
|
(analyze (list 'let (cadr exp) (cons 'while (cddr exp)))))
|
|
|
|
; Exercise 4.2
|
|
(define (add-analyzer! tag analyzer)
|
|
((anal-table 'insert-proc!) tag analyzer))
|
|
(add-analyzer! 'call analyze-application)
|
|
(add-analyzer! 'quote analyze-quoted)
|
|
(add-analyzer! 'set! analyze-assignment)
|
|
(add-analyzer! 'define analyze-definition)
|
|
(add-analyzer! 'if analyze-if)
|
|
(add-analyzer! 'lambda analyze-lambda)
|
|
(add-analyzer! 'begin analyze-begin)
|
|
(add-analyzer! 'cond analyze-cond)
|
|
(add-analyzer! 'and analyze-and)
|
|
(add-analyzer! 'or analyze-or)
|
|
(add-analyzer! 'let analyze-let)
|
|
(add-analyzer! 'let* analyze-let*)
|
|
(add-analyzer! 'while analyze-while)
|
|
(add-analyzer! 'for analyze-for)
|
|
|
|
(define primitive-procedures
|
|
(let ((procedures (list (cons 'first car)
|
|
(cons 'rest cdr)
|
|
(cons 'cons cons)
|
|
(cons 'null? null?)
|
|
(cons 'assoc assoc)
|
|
(cons 'display display)
|
|
(cons 'newline newline)
|
|
(cons '= =)
|
|
(cons '< <)
|
|
(cons '> >)
|
|
(cons '+ +)
|
|
(cons '- -)
|
|
(cons '* *)
|
|
(cons '/ /))))
|
|
(map (lambda (p) (cons (car p) (list 'primitive (cdr p)))) procedures)))
|
|
(define (make-environment . environments)
|
|
(if (null? environments)
|
|
the-empty-environment
|
|
(extend-environment (car environments)
|
|
(apply make-environment (cdr environments)))))
|
|
(define (mk-init-env)
|
|
(make-environment primitive-procedures
|
|
(list (cons 'false #f) (cons 'true #t) (cons 'else #t))))
|
|
|
|
(define (evaluator-loop)
|
|
(let loop ((environment (mk-init-env)))
|
|
(display "> ")
|
|
(let ((input (read)))
|
|
(if (not (eq? input 'quit))
|
|
(let ((output ((analyze input) environment)))
|
|
(display output)
|
|
(newline)
|
|
(loop environment))))))
|
|
|
|
; Exercise 4.21
|
|
(define (factorial n)
|
|
((lambda (fact) (fact fact n))
|
|
(lambda (ft k) (if (= k 1) 1 (* k (ft ft (1- k)))))))
|
|
(define (fibonacci n)
|
|
((lambda (fib) (fib fib n))
|
|
(lambda (f k)
|
|
(if (or (= k 0) (= k 1))
|
|
k
|
|
(+ (f f (1- k))
|
|
(f f (- k 2)))))))
|
|
(define (f x)
|
|
((lambda (even? odd?) (even? even? odd? x))
|
|
(lambda (ev? od? n) (if (= n 0) #t (od? ev? od? (1- n))))
|
|
(lambda (ev? od? n) (if (= n 0) #f (ev? ev? od? (1- n))))))
|