MENU

SICP 习题解答记录(第 4-5 章)

本来是想全放在一篇文章里的,但是 Typecho 有字数限制,就分篇了

Chapter4

4.1

(define (list-of-value-left-to-right exps env)
  (if (no-operands? exps)
      '()
      (let ((first-operand-result (eval (first-operand exps) env)))
        (cons first-operand-result
              (list-of-value-left-to-right (rest-operands exps) env)))))

4.2

a) 考虑 application? 的实现仅为判断 exp 是否为一个序对,所以几乎所有的表达式都会通过检查,从而进入 apply 进行过程应用的操作。

b) 只需要修改应用过程相关的选择函数

(define (application? exp)
  (tagged-list? exp 'call))

(define (operator exp) (cadr exp))

(define (operands exp) (cddr exp))

4.3

(define *op-table* (make-table))

(define (put type op) (insert! type op *op-table*))

(define (get type op) (lookup type *op-table*))

(define (eval-quote exp env)
  (text-of-quotation exp))

(define (eval-lambda exp env)
  (make-procedure (lambda-parameters exp)
                  (lambda-body exp)
                  env))

(define (eval-begin exp env)
  (eval-sequence (begin-actions exp) env))

(define (eval-cond exp env)
  (eval (cond->if exp) env))

(put 'quote eval-quote)
(put 'set! eval-assignment)
(put 'define eval-definition)
(put 'if eval-if)
(put 'lambda eval-lambda)
(put 'begin eval-begin)
(put 'cond eval-cond)

(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((get (car exp)) ((get (car exp) exp env)))
        ((application? exp)
         (apply (eval (operator exp) env)
                (list-of-values (operands exp) env)))
        (else
         (error "Unkown expression type -- EVAL" exp))))

这里用到了在第三章中介绍的 make-table 过程

4.4

(define (eval-and exp env)
  (let ((first (first-exp (operands exp)))
        (rest (rest-exps (operands exp))))
    (cond ((null? first) true)
          ((eval first env) (eval-and rest env))
          (else false))))

(define (eval-or exp env)
  (let ((first (first-exp (operands exp)))
        (rest (rest-exp (operands exp))))
    (cond ((null? first) false)
          ((not (eval first env)) (eval-or rest env))
          (else true))))

(put 'and eval-and)
(put 'or eval-or)

可以使用用 if 来构造 cond 的类似的方法来构造 andor

4.5

(define (cond-=>ex? clause) (eq? '=> (cadr clause)))

(define (cond-=>ex-action clause) (caddr clause))

(define (expand-clauses clauses)
  ((if (null? clauses)
       'false
       (let ((first (car clauses))
             (rest (cdr clauses)))
         (if (cond-else-clause? first)
             (if (null? rest)
                 (sequence->exp (cond-actions first))
                 (error "ELSE clause isn't last -- COND->IF" clauses))
             (if (cond-=>ex? first)
                 (make-if (cond-predicate first)
                          (apply (cond-=>ex-action first) (cond-predicate first))
                          (make-if (cond-predicate first)
                                   (sequence->exp (cond-actions first))
                                   (expand-clauses rest)))))))))

4.6

(define (let? exp) (tagged-list? exp 'let))

(define (let-parms-args-list exp) (cadr exp))

(define (let-parameters list)
  (if (null? list)
      '()
      (cons (caar list)
            (let-formal-parameters (cdr list)))))

(define (let-args list)
  (if (null? list)
      '()
      (cons (cadar list)
            (let-args list))))

(define (let-body exp) (cddr exp))

(define (let->combination exp)
  (cons (make-lambda
         (let-parameters (let-parms-args-list exp))
         (let-body exp))
        (let-args)))

evalcond 选择语句中加入

((let? exp) (eval (let->lambda-and-args exp) env)

4.7

(define (make-let parms-args-list body)
  (cons 'let (cons parms-args-list body)))

(define (let-first-parms-args list) (car list))

(define (let-rest-parms-args list) (cdr list))

(define (let*->nested-lets exp)
  (expand-parms-args-list (let-parms-args-list exp) (let-body exp)))

(define (expand-parms-args-list l body)
  (if (null? (first-parms-args-list l))
      body
      (make-let
       (list (first-parms-args-list l))
       (expand-parms-args-list
        (rest-parms-args-list l)
        body))))

4.8

(define (let->combination exp)
  (if (named-let? exp)
      (sequence->exp
       (list
        (list 'define
              (cons (named-let-name exp) (named-let-parms exp))
              (named-let-body exp))
        (cons (named-let-name exp)
              (named-let-args exp))))
      (cons (make-lambda
             (let-parameters (let-parms-args-list exp))
             (let-body exp))
            (let-args))))

(define (named-let-name exp) (cadr exp))

(define (named-let-body exp) (cdddr exp))

(define (named-let-args exp) (let-args (caddr exp)))

(define (named-let-parms exp) (let-parms (caddr exp)))

4.9

跳过

4.10

跳过

4.11

必须说这是重复而无用的工作..跳过

4.12

(define (scan-and-op var env . op)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (if (null? cdr op)
                 (scan-and-op var (enclosing-environment env) op)
                 ((cdr op)))
            ((eq? var (car vars))
             ((car op) vals))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (scan (frame-variables frame)
              (frame-values frame)))))

(define (lookup-variable-value var env)
  (scan-and-op var env car))

(define (set-variable-value! var val env)
  (scan-and-op
   var
   env
   (lambda (x) (set-car! x val))))

(define (define-variable! var val env)
  (scan-and-op
   var
   env
   (lambda (x) (set-car! x val))
   (lambda () (add-binding-to-frame! var val (first-frame env)))))

4.13

在我看来这个过程实际上根本不应该存在,其存在的意义微乎其微,而如果使用它的话将会造成很大程度上的混乱。不论是只删除环境中第一个框架里的约束,还是可以一直向外查找去删除约束,都会使得中间引用这一约束的过程无法确定其存在性,而为了确认这一点,将会引入更多的时序问题。

4.14

考虑 map 过程实际在做什么:

将一个过程 apply 给整个表

  • 当完全定义在元循环求值器中的时候,整个体系是完备的,map 会正确地调用元循环求值器中的 apply 去处理我们在求值器里构造的过程对象
  • 当将 map 安装为基本过程的时候,此时的 map 会调用 Lisp 自己的基本过程 apply 来执行我们所构造的过程对象,显然,Lisp 版本的 apply 无法处理它

4.15

  • 假如 trytry 终止
    • 将触发 run-forever 过程,实际结果为 trytry 不终止
  • 加入 trytry 不终止
    • 将返回一个 'halted 符号数据,实际结果为 trytry 终止

让我想起以前的段子,也是一样的道理:

一台可以准确无误地告知被给予叙述对错的机器,将无法回答“你的下一个判断是错”

4.16

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (ensloing-environment env)))
            ((eq? var (car vars))
             (if (eq? (car vals) '*unassigned*)
                 (error "Unassigned variable" var)
                 (car vals)))
            (else (scan (cdr vars) cdr (vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (let ((frame (first-frame env)))
            (scan (frame-variables frame)
                  (frame-values frame))))))
  (env-loop env))

(define (scan-out-defines body)
  (define (scan body parms-args-list set!-seq normal-body)
    (let ((first-exp (car body))
          (rest-exps (cdr body)))
      (cond ((null? body)
             (make-let parms-args-list
                       (append set!-seq normal-body)))
            ((definition? first-exp)
             (let ((def-var (definition-variable first-exp))
                   (def-val (definition-value first-exp)))
               (scan rest-exps
                     (cons (list def-var '*unassigned)
                           parms-args-list)
                     (cons (list 'set! def-var def-val)
                           set!-seq)
                     normal-body)))
            (else
             (scan rest-exps
                   parms-args-list
                   set!-seq
                   (append normal-body first-exp))))))
  (scan body '() '() '()))

我认为应该安装在 procedure-body 中,在这里转化过程体是比较合理的。

4.17

这里多出来的一个框架是因为 let 所内含的一个 lambda 所创造的,程序会在外部环境中正确的找到这些内部定义,所以不会出现错误。

如果要不使用额外的框架,那么就只能将所有非值表达式的内部定义扫描后调换顺序,放到过程体的最开始。

4.18

这将无法工作。注意到 dy 被定义成的表达式中引用了 y ,但此时 y 还没有被定义,y 的定义还被放在 a 中。

而用上文所述的扫描的方法,就可以工作,因为它不需要经过一个中间变量 a ,直接就可以被引用到。

4.19

我支持 Eva 的观点,因为已经规定了定义只对环境的框架序列中的第一个框架有效,所以考虑同时性作用原则的话,第一个框架就应该拥有 a 的值为 5。

但就像脚注中说的,很难实现这样一种同时性作用。但可以考虑采用某种算法(某种我现在还没学习到的算法)来排序内部定义,让顺序作用可以正常的处理成 Eva 所希望的那样。

4.20

a) 偷懒了

b) 考虑 let 的实现,实际上是将 let 转化成 lambda ,而将其中的 <exp> 作为参数传递给 lambda 。如果只用 let ,那么两个作为参数的 even?odd? 的过程定义,将无法互相看到彼此,比如:

((lambda (even? odd?) <body>)
 (lambda (n) (if (= n 0) true (odd? (- n 1))))
 (lambda (n) (if (= n 0) false (even? (- n 1)))))

假设我们是在全局环境中运行这一表达式,两个作为参数的 lambda 过程是在全局环境中定义的,然后作为参数传入 lambda (even? odd?) <body> 并运行后,建立了一个新环境 E1 ,其中存在约束 even?odd? 。但是全局环境中并没有 even?odd? 的约束,所以两个作为参数的 lambda 过程没法找到过程体所引用的 even?odd? ,将造成错误。

4.21

a)

((lambda (n)
   ((lambda (fib)
      (fib fib n))
    (lambda (f x)
      (cond ((= x 0) 0)
            ((= x 1) 1)
            (else
             (+ (f f (- x 1))
                (f f (- x 2))))))))
 5)

这可太秀了,利用两个 lambda 来传递过程实现递归

b)

(define (f x)
  ((lambda (even? odd?)
     (even? even? odd? x))
   (lambda (ev? od? n)
     (if (= n 0) true (od? ev? od? (- n 1))))
   (lambda (ev? od? n)
     (if (= n 0) false (ev? ev? od? (- n 1))))))

4.22

(define (analyze-let exp)
  (let ((llist (let-parms-args-list exp)))
    (let ((parms (let-parameters llist))
          (args (let-args llist))
          (body (let-body exp)))
      (analyze (cons (make-lambda parms body)
                     args)))))

4.23

我个人认为这里书中版本的处理是保持一致性:analyze 对一个 sequence 作为一个整体进行分析,也输出一个只需要 env 来运行的过程。

考虑 Alyssa 的版本,她只是将 excecute-sequence 这个过程推迟到了运行时去运行,实际上并没有输出一个将整个序列作为一个整体分析完后输出的一个过程。

但看起来两种版本从效果上来看实际上并没有太大的区别。

4.24

没有测试用的环境..不知道怎么做,而且有一个问题我没能理解..analyze 的过程似乎没有做记忆处理,岂不是每一次都要重新 analyze

4.25

这题真是让人感觉梦回第一章..答案显然是程序会显然因无限递归调用 factorial 的假死。在正则序中可以工作。

4.26

实现 unless 非常简单,考虑已经有一个构造函数 make-if ,只要把 predicate 的部分取非即可。

无法举出反例。

4.27

(define count 0)

(define (id x)
  (set! count (+ count 1))
  x)

(define w (id (id 10)))

;;; L-Eval input:
count
;;; L-Eval value:
1

;;; L-Eval input:
w
;;; L-Eval value:
10

;;; L-Eval input:
count
;;; L-Eval value:
2

在这一节开头有提到,有以下三种情况需要强迫槽进行求值:

  • 作为参数被基本过程应用时
  • 作为谓词被 if 应用时
  • 作为操作符被应用时

所以在 w 的定义中, (id 10) 作为复合过程参数被传入,不会被强迫求值,在 w 执行过程中先为 count 的值加一,然后直接返回参数 (id 10) 的槽

而在驱动循环中直接输入 w 将调用 actual-valuew 求值,从而进行将 (id 10) 的槽强迫取得值 10 ,并且 count 加一

4.28

对于任何一个直接用 lambda 表达式来进行操作的语句都会报错,这样会直接把一个包含 lambda 表达式的 thunk 传给 apply ,而 apply 无法对一个 thunk 来判断其类型

4.29

考虑最简单的阶乘程序:

(define (fact n)
  (if (= n 0)
      1
      (* n (fact (- n 1)))))

(- n 1) 作为操作数,被 delay-it 变成槽传入下一级的复合过程 fact ,在下一级的每一次对 n 的引用中,都会强迫槽求值一次,然后再将 (- n 1) 传入下一级的 fact,注意此时 (- n 1) 中的 n 仍然是一个槽,也就是说槽会在调用过程中不断嵌套,在每一次引用 n 的值的时候再逐层强迫得到槽的值,会造成非常严重的性能损失。

(define (square x)
  (* x x))

;;; L-Eval input:
(square (id 10))
;;; L-Eval value:
100 ; with / without memoization

;;; L-eval input:
count
;;; L-eval calue:
1 ; with memoization
2 ; without memoization

4.30

a) 在 begin 中的 (proc (car items)) ,后来给的实际调用的例子中,proc 是一个 lambda 表达式,item 被传入后,由于 lambda 中的 newlinedisplay 是基本过程,所以会产生效果

b)

由于 set! 是基本过程,所以不论是原来的还是修改后的 (p1 1) 的值都是 (1 2)

而对于 (p2 1) ,原来的 eval-sequence 不会求值 e ,所以输出是 1 ,修改后的会求值 e ,所以输出是 (1 2)

c) 我认为这是显然的

d) 我认为 Cy 的方法显然更加有效

4.31

打扰了..跳过

4.32

惰性表中,carcdr 都将被惰性求值,所以可以利用这个特性构造一个惰性的无限树

4.33

(define (quotation->cons exp)
  (define (expand-quotation exp)
    (if (null? exp)
        (quote '())
        (if (not (pair? exp))
            exp
            (list 'cons (car exp) (expand-quotation (cadr exp))))))
  (expand-quotation (text-of-quotation exp)))

((quoted? exp) (eval (quotation->cons exp) env)) ; change the clause in eval

4.34

告辞,跳过

4.35

(define (an-integer-between low high)
  (require (<= low high))
  (amb low (an-integer-between (+ low 1) high)))

4.36

如果直接用 an-integer-starting-from 代替 an-integer-between ,由于回溯只能回溯最下一级的 amb ,所以 ij 都将为初值,只有 k 不断增大(考虑在流中是利用交错的方式合并了流来避免这一问题)

(define (a-pythagorean-triple)
  (let ((k (an-integer-starting-from 3)))
    (let ((j (an-integer-between 1 k)))
      (let ((i (an-integer-between 1 j)))
        (require (= (+ (* i i) (* j j)) (* k k)))
        (list i j k)))))

4.37

  • 当取值范围很小的时候,4.35 的方法效率更高,因为 sqrtinteger? 的效率并不高
  • 当取值范围很大的时候,4.37 的方法效率更高,因为它跳过了很多不相关的枚举

4.38

这里应该出现了翻译错误..“增加”应该改成“去掉”

4.39

首先,可以肯定的是,不论怎么调换顺序,amb 都可以枚举出所有的结果,最后的结果不会改变;但判断结果是否可行的时间会影响运行时间

  1. 显而易见的,将 distinct? 放到约束条件的最后,将毫无疑问地提高运行速度,因为 distinct? 是一个相当慢的过程

  2. 事件的判断是顺序进行的,如果把前四个条件:

    (require (not (= baker 5)))    ; A
    (require (not (= cooper 1)))   ; B
    (require (not (= fletcher 5))) ; C
    (require (not (= fletcher 1))) ; D

    其中 not 之后的描述(比如 = baker 5 )从上到下分别记作事件 $A, B, C, D$ ,而一次判断算作一次操作,那么对于枚举出来的所有情况,应该有
    $$
    C = N(A) + 2 \times N(\bar A \cap B) + 3 \times N(\bar A \cap \bar B \cap C) + 4 \times N(\bar A \cap \bar B \cap \bar C \cap D)
    $$
    其中 $C$ 是总操作数, $N(X)$ 则代表对应事件的这个古典概型问题的结果数,由于这其中的四项的结果数显然不同,改变 $A, B, C, D$ 的排列顺序,是可以改变 $C$ 的值的,这里就不花时间把公式打上来了..手算相当快

4.40

(define (multiple-dwelling)
  (let ((cooper (amb 1 2 3 4 5)))
    (require (not (= cooper 1)))
    (let ((miller (amb 1 2 3 4 5)))
      (require (not (= miller 1)))
      (require (not (= miller 2)))
      (require (> miller cooper))
      (let ((fletcher (amb 1 2 3 4 5))
            (require (not (= fletcher 1)))
            (require (not (= fletcher 5)))
            (require (not (= fletcher cooper)))
            (require (not (= fletcher miller)))
            (require (not (= (abs (- fletcher cooper 1)))))
            (let (smith (amb 1 2 3 4 5))
              (require (not (= smith cooper)))
              (require (not (= smith miller)))
              (require (not (= smith fletcher)))
              (require (not (= (abs (- fletcher smith 1)))))
              (let ((baker (amb 1 2 3 4 5)))
                (require (not (= baker 5)))
                (require (not (= baker cooper)))
                (require (not (= baker miller)))
                (require (not (= baker fletcher)))
                (require (not (= baker smith)))
                (list (list 'baker baker)
                      (list 'cooper cooper)
                      (list 'fletcher fletcher)
                      (list 'miller miller)
                      (list 'smith smith)))))))))

原本这题的答案我没想写这么长的,上面大段的约束条件,比如说 (= baker 1) ,本来可以通过直接在用于生成 bakeramb 的列表里直接删掉 1 来实现的,但我写完之后看了一下某 scheme 社区对这题的解答,里面有这样一段话我甚为认同:

the exercise asks for a nondeterministic program, which means that you can only rule out possibilities using require, and not manually exclude them, even if they are trivial. (If you were allowed to manually exclude outcomes, there would be nothing stopping us from writing a trivial function that just directly outputs the single answer).

所以就把程序改成了上面这样冗长的样子..

4.41

(define (distinct? items)
  (cond ((null? items) true)
        ((null? (cdr items)) true)
        ((member (car items) (cdr items)) false)
        (else (distinct? (cdr items)))))

(define (accumulate op initial seq)
  (if (null? seq)
      initial
      (op (car seq)
          (accumulate op initial (cdr seq)))))

(define (flatmap proc seq)
  (accumulate append '() (map proc seq)))

(define (permutation lists)
  (if (null? lists)
      '(())
      (flatmap (lambda (x)
                 (map (lambda (y) (cons x y))
                      (permutation (cdr lists))))
               (car lists))))

(define (filter predicate seq)
  (cond ((null? seq) '())
        ((predicate (car seq))
         (cons (car seq) (filter predicate (cdr seq))))
        (else (filter predicate (cdr seq)))))

(define (restriction l)
  (apply
   (lambda (baker cooper fletcher miller smith)
     (and (not (= (abs (- fletcher smith)) 1))
          (not (= (abs (- fletcher cooper)) 1))
          (> miller cooper)
          (distinct? (list baker cooper fletcher miller smith))))
   l))

(define (multiple-dwelling-scheme)
  (let ((baker '(1 2 3 4))
        (cooper '(2 3 4 5))
        (fletcher '(2 3 4))
        (miller '(3 4 5))
        (smith '(1 2 3 4 5)))
    (filter restriction (permutation (list baker cooper fletcher miller smith)))))

这里用到了在第二章里嵌套映射部分的内容

4.42

Betty - 3
Aysel - 5
Joan  - 2
Kitty - 1
Mary  - 4

4.43

(define (yacht)
  (let ((mellisa 'hood))
    (let ((mary 'moore))
      (let ((rosalind (amb 'downing 'parker)))
        (let ((gabrielle (amb 'downing 'hall)))
          (require (not (= gabrielle rosalind)))
          (let ((lorna (amb 'downing 'hall 'parker)))
            (require (not (= lorna rosalind)))
            (require (not (= lorna gabrielle)))
            (require (and (= garbrielle 'downing)
                          (= melissa 'parker)))
            (require (and (= gabrieelle 'hall)
                          (= rosalind 'parker)))
            (list (list 'mary mary)
                  (list 'lorna lorna)
                  (list 'melissa melissa)
                  (list 'rosalind rosalind)
                  (list 'gabrielle gabrielle))))))))

4.44

(define (queens board-size)
  (define (queen-cols k)
    (if (= k 0)
        (list empty-board)
        (let ((new-row (an-integer-between 1 board-size)))
          (let ((rest-queens (queen-cols (- k 1))))
            (let ((new-queens (append rest-queens new-row)))
              (require (safe? new-queens))
              new-queens))))))

4.45

由于没有实际可以运行的求值器,而手打分析结果又未免太反人类,这里直接给出汉语翻译

  1. 教授带着猫在教室里,给学生上课
  2. 教授在一个有猫的教室里,给学生上课
  3. 教授带着猫,给在教室里的学生上课
  4. 教授给在一个有猫的教室里的学生上课
  5. 教授给带着猫的在教室里的学生上课

4.46

这题不是很理解,以下为社区答案摘录:

That's because function parse-word handles \unparsed\ from left to right. If evaluation has other order, it will conflict with parse-word.

4.47

我认为两种情况下都将导致无限循环的出现。

4.48

(define (adjectives '(adjectives red yellow green)))

(define (parse-simple-noun-phrase)
  (amb (list 'sentence
             (parse-word articles)
             (parse-word nouns))
       (list 'sentence
             (parse-word articles)
             (parse-word adjectives)
             (parse-word nouns))))

4.49

(define (parse-word word-list)
  (require (not (null? *unparsed*)))
  (let ((found-word (apply amb (cdr word-list))))
    (set! *unparsed* (cdr *unparsed*))
    (list (car word-list) found-word)))

4.50

这个问题的基本思路是将 amb 表达式的选择乱序

(define (shuffle-list list)
  (define (iter seq result)
    (if (null? seq)
        result
        (let* ((l (length seq))
               (idx (random l))
               (ele (list-ref seq idx)))
          (remove seq ele)
          (iter seq (cons ele result)))))
  (iter list '()))

(define (analyze-ramb exp)
  (let ((cprocs (shuffle-list (map analyze (amb-choices exp)))))
    (lambda (env succeed fail)
      (define (try-next choices)
        (if (null? choices)
            (fail)
            ((car choices) env
                           succeed
                           (lambda ()
                             (try-next (cdr choices))))))
      (try-next cprocs))))

4.51

去掉过程中对失败继续过程的拦截即可

(define (permanent-assignment? exp)
  (tagged-list? exp 'permanent-set!))

; add to analyze
((permanent-assignment? exp) (analyze-assignment-permanent exp)

(define (analyze-assignment-permanent exp)
  (let ((var (assignment-variable exp))
        (vproc (analyze (assignment-value exp))))
    (lambda (env succeed fail)
      (vproc env
             (lambda (val fail2)
               (set-variable-value! var val env)
               (succeed 'ok fail2)))
      fail)))

4.52

((if-fail? exp) (analyze-if-fail exp))

(define (if-fail-pred exp) (cadr exp))

(define (if-fail-fproc exp) (caddr exp))

(define (analyze-if-fail exp)
  (let ((pproc (analyze (if-fail-pred exp)))
        (fproc (analyze (if-fail-fproc exp))))
    (lambda (env succeed fail)
      (pproc env
             (lambda (pred-value fail2)
               (succeed pred-value fail2))
             (lambda ()
               (fproc env succeed fail))))))

4.53

((8 35) (3 110) (3 20))

4.54

(define (analyze-require exp)
  (let ((pproc (analyze (require-predicate exp))))
    (lambda (env succeed fail)
      (pproc env
             (lambda (pred-value faile2)
               (if (not (true? pred-value))
                   (fail2)
                   (succeed 'ok fail2)))
             fail))))

4.55

a)

(supervisor ?x (ben bitdiddle))

b)

(job ?x (accounting ?y))

c)

(address ?x (slumeriville . ?y))

4.56

a)

(and (supervisor ?person (ben bitdiddle))
     (address ?person ?where))

b)

(and (salary ?person ?amount)
     (salary (ben bitdiddle) ?ben-salary)
     (lisp-value > ?amount ?ben-salary))

c)

(and (not (job ?person (computer ?x)))
     (supervisor ?person-1 ?person-2)
     (job ?person-1 ?job))

4.57

(rule (can-replace ?person-1 ?person-2)
      (and (or (and (job ?person-1 ?job)
                    (job ?person-2 ?job))
               (and (job ?person-1 ?job-1)
                    (job ?person-2 ?job-2)
                    (can-do-job ?job-1 ?job-2)))
           (not (same person-1 person-2))))

由于没有可运行的环境..就不测试了

4.58

(rule (bigshot ?person ?department)
      (and (job ?person (?department . ?rest))
           (or (not (supervisor ?person ?boss))
               (and (supervisor ?person ?boss)
                    (not (job ?boss (?department . ?rest-2)))))))

4.59

a)

(meeting ?mt (Friday . ?time))

b)

(rule (meeting-time ?person ?day-and-time)
      (or (meeting whole-company ?day-and-time)
          (and (job ?person (?department . ?rest))
               (meeting ?department ?day-and-time))))

c)

(metting-time alyssa (Wednesday . ?time))

4.60

两种情况虽然只有顺序的不同,但都满足规则的定义

至于解决方案,以我目前掌握的知识我给不出来..

4.61

;;; Query input:
(?x next-to ?y in (1 (2 3) 4))
;;; Query results:
(1 next-to (2 3) in (1 (2 3) 4))
((2 3) next-to 4 in (1 (2 3) 4))

;;; Query input:
(?x next-to 1 in (2 1 3 1))
;;; Query results:
(2 next-to 1 in (2 1 3 1))
(3 next-to 1 in (2 1 3 1))

4.62

(rule (last-pair (?x) (?x)))

(rule (last-pair (?u . ?v) (?x))
      (last-pair ?v (?x))

并不能对 (last-pair ?x (3)) 给出结果

4.63

(rule (grandson ?grandpa ?person)
      (and (son ?grandpa ?dad)
           (son ?dad ?person)))

(rule (son ?person ?mom)
      (and (wife ?mom ?dad)
           (son ?person ?dad)))

4.64

  • or 的第一个子句在数据库里找到了 Ben 的直接上级是 Warbucks 的断言
  • or 第二个子句中的 and 的第一个子句 outranked 再次匹配了模式 outranked ,进入无限循环

4.65

注意到 Warbucks 手下的 Ben 管理三个人, Scrooge 管理一个人,共匹配了规则的体四次,所以最终 Warbucks 的名字会出现四次

4.66

Ben 的简单实现涉及到了练习 4.65 的同一个规则对同一个人的多次匹配的问题

可以设法实现一种过滤流中的重复元素的过程来解决这个问题

4.67

设计的话我觉得题目的提示已经够明显的了..但实际实现等我读到后面再来补上(也可能不补)

4.68

(aseert! (rule (reverse () ())))

(assert! (rule (reverse (?u . ?v) ?x)
               (and (reverse ?v ?y)
                    (append-to-form ?y (?u) ?x))))

对于 (reverse (1 2 3) ?x) 将能够正常工作,而对于 (reverse ?x (1 2 3)) 将陷入无限循环,但如果调换子句顺序将能够防止这一问题:

(assert! (rule (reverse (?u . ?v) ?x)
               (and (append-to-form ?y (?u) ?x))
                    (reverse ?v ?y)))

4.69

用到了练习 4.62 的 last-pair

(assert! (rule ((great grandson) ?x ?y)
               (and (son ?x ?middle-person-1)
                    (son ?middle-person-2 ?middle-person-3)
                    (son ?middle-person-3 ?y))))

(assert! (rule (end-with-grandson ?x)
               (and (last-pair ?x (?y))
                    (same ?y 'grandson))))

(assert! (rule ((great . ?rel) ?x ?y)
               (and (?rel ?x ?z)
                    (son ?y ?z))))

4.70

提示给的非常明显了,会产生出一个前端包含 assertion 的无穷流,由于流 cdr 的延迟效果,直接使用 (set! THE-ASSERTIONS (cons-stream ssertion THE-ASSERTIONS))THE-ASSERTIONScdr 在被 set! 赋值时被 delay ,而之后这个 cdr 要被运算时就会在环境里找 THE-ASSERTIONS ,从而形成无穷流,使用 let 可以强制 cdr 为原来的那个流,避免“自我引用”形成无穷流

4.71

使用 delay 可以使一些无限循环出现之前仍然可以得到一些有意义的结果,比如之前 married 规则的例子,使用 delay 可以在程序陷入无限循环之前先给出一些结果(直接匹配断言的子句的结果),而处理规则匹配的子句如果不使用 delay ,将无法获得任何结果,直接进入无限循环

4.72

和之前第三章之所以要用 interleave 的原因一样,这里可能出现无穷流

4.73

显然,interleave 作为复合过程,每个操作数会在应用过程前先被求值,所以必须显式的应用 delay 来延迟

4.74

(define (simple-stream-flatmap proc s)
  (simple-flatten (stream-map proc s)))

(define (simple-flatten stream)
  (stream-map stream-car
              (stream-filter (lambda (s)
                               (not (stream-null? s)))
                             stream)))

如果说可能改变程序的行为..应该也只会出现在结果出现无穷流的情况里?不是很确定

4.75

(define (uniquely-asserted operands frame-stream)
  (stream-flatmap
   (lambda (frame)
     (let ((new-frame-stream (qeval (negated-query operands)
                                    (singleton-stream frame))))
       (if (and (not (stream-null? new-frame-stream))
                (stream-null? (stream-cdr new-frame-stream)))
           new-frame-stream
           the-empty-stream)))
   frame-stream))

4.76-4.79

对我来说太难了,跳了

Chapter 5

5.1

画图题

5.2

(controller
 test-c
   (test (op >) c n)
   (branch (label factorial-done))
   (assign p (op multiply) (reg p) (reg c))
   (assign c (op add) (reg c) (const 1))
   (goto (label test-c))
 factorial-done)

5.3

假设 improvegood-enough? 都是基本操作:

(controller
 test-good
   (test (op good-enough?) (reg guess) (reg x))
   (branch (label done))
   (assign t (op improve) (reg guess) (reg x))
   (assign guess (reg t))
   (goto (label test-good))
 done)

对基本操作进行展开:

(controller
 test-good
   (assign squ (op square) (reg guess))
   (assign diff (op minus) (reg x) (reg squ))
   (test (op >) (reg diff) 0)
   (branch (label improve))
   (assign diff (op multiply) (reg t) (const -1))
   (test (op <) (reg diff) (const 0.0001))
   (branch (label done))
 improve
   (assign quotient (op divide) (reg x) (reg guess))
   (assign sum (op add) (reg guess) (reg quotient))
   (assign quotient2 (op divide) (reg sum) (const 2))
   (assign guess (reg quotient2))
   (goto (label test-good))
 done)

5.4

a)

(controller
   (assign continue (label expt-done))
 expt-loop
   (test (op =) (reg n) (const 0))
   (branch (label base-case))
   (save continue)
   (assign continue (label after-fact))
   (assign n (op minus) (reg n) (const 1))
   (goto expt-loop)
 after-fact
   (retore cotinue)
   (assign val (reg val) (reg b))
   (goto (reg continue))
 base-case
   (assign val (const 1))
   (goto (reg continue))
 expt-done)

b)

(controller
 test-counter
   (test (op =) (reg counter) (const 0))
   (branch (label expt-done))
   (assign product (reg product) (reg b))
   (assign counter (op minus) (reg counter) (const 1))
   (goto (label test-counter))
 expt-done)

5.5

一个过程解释的题,在草稿纸上简单写了一下示意图

5.6

afterfib-n-1 标签后的 (restore continue)(save continue)

5.7

懒得写!

5.8

由于 lookup-label 中使用 assoc 来从 labels 列表里,从左到右遍历,找到 label 对应的 insts ,所以会先到达第一个 here ,因而最后的值是 3

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
                      (lambda (insts labels)
                        (let ((next-inst (car text)))
                          (if (symbol? next-inst)
                              (if (assoc next-inst labels)             ; changed
                                  (error "Duplicate labels" next-inst)
                                  (receive insts
                                           (cons (make-label-entry next-inst insts)
                                                 labels)))
                              (receive (cons (make-instructions next-inst) insts)
                                       labels)))))))

5.9

(define (make-operation-exp exp machine labels operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
                (if (label-exp? e) ; changed
                    (error "Operation cannot apply to labels -- ASSEMBLE" exp)
                    (make-primitive-exp e machine labels)))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (map (lambda (p) (p)) aprocs)))))

5.10

不做了!

5.11

a)

可以删去 afterfib-n-2 后的 (assign n (reg val)) ,将下一行的 (restore val) 改为 (restore n)

b)

(define (make-save inst machine stack pc)
  (let* ((reg-name (stack-inst-reg-name inst))
         (reg (get-register machine reg-name)))
    (lambda ()
      (push stack (cons reg-name (get-contents reg)))
      (advance-pc pc))))

(define (make-restore inst machine stack pc)
  (let* ((reg-name (stack-inst-reg-name inst))
         (reg (get-register machine reg-name))
    (lambda ()
      (let* ((item (pop stack))
             (item-name (car item))
             (item-content (cadr item))
        (if (eq? reg-name item-name)
            (begin
             (set-contents! reg item-content)    
             (advance-pc pc))
            (error "Inconsistent register name -- ASSEMBLE" inst)))))))

c)

这题如果按照题目提示中的方法来写的话将会比较繁琐,如果直接修改 register 的数据结构,为每个 register 都提供一个 stack 会更加简单:

(define (make-register name)
  (let ((contents '*unassigned*)
        (stack '()))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set)
             (lambda (value) (set! contents value)))
            ((eq? message 'push) ; changed
             (lambda (x) (set! stack (cons x stack))))
            ((eq? message 'pop) ; changed
             (if (null? stack)
                 (error "Stack is null -- REG" reg)
                 (lambda ()
                   (let ((top (car stack)))
                     (set! stack (cdr stack))
                     top))))
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))

(define (push register x)
  ((register 'push) x))

(define (pop register)
  (register 'pop)

(define (make-save inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (push reg (get-contents reg))
      (advance-pc pc))))

(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (set-contents! reg (pop reg))    
      (advance-pc pc))))

5.12

这题有点烦人..主要是没什么意思..

5.13

(define (allocate-regs inst machine)
  (define (tree-walk inst)
    (if (pair? inst)
        (cond ((tagged-list? inst 'reg)
               (if (not ((machine 'check-register) (cadr inst)))
                    ((machine 'allocate-register) (cadr inst))))
              ((tagged-list? inst 'assign)
               (begin
                (if (not ((machine 'check-register) (cadr inst)))
                    ((machine 'allocate-register) (cadr inst)))
                (tree-walk (car inst))
                (tree-walk (cdr inst))))
              (else (begin (tree-walk (car inst)) (tree-walk (cdr inst)))))))
  (tree-walk inst))

然后把上面这个函数的调用加到 make-execution-procedure 的最顶端即可,但是问题在于这样的方法太过低效,其实也可以考虑把这个检测加到各个分派过程中去,但是不管怎样都不可避免的在每一次遇到寄存器的时候都要遍历机器的寄存器表,所以还是一开始就给这个表效率更高

5.14

(define factorial-machine
  (make-machine
   '(n val continue)
   (list (list '* *)
         (list '= =)
         (list '- -)
         (list 'read read)
         (list 'print display))
'(controller
 fact-top
   (perform (op initialize-stack))
   (assign n (op read))
   (assign continue (label fact-done))
 fact-loop
   (test (op =) (reg n) (const 1))
   (branch (label base-case))
   (save continue)
   (save n)
   (assign n (op -) (reg n) (const 1))
   (assign continue (label after-fact))
   (goto (label fact-loop))
 after-fact
   (restore n)
   (restore continue)
   (assign val (op *) (reg n) (reg val))
   (goto (reg continue))
 base-case
   (assign val (const 1))
   (goto (reg continue))
 fact-done
   (perform (op print-stack-statistics))
   (perform (op print) (reg val))
   (goto (label fact-top)))))

5.15

make-new-machine 中多加入一个变量 insts-counter ,然后在内部改变 execute 并加入 print-insts-counter

(define (execute)
  (let ((insts (get-contents pc)))
    (if (null? insts)
        'done
        (begin
         (set! insts-counter (+ insts-counter 1))
         ((instruction-execution-proc (car insts)))
         (execute)))))

(define (print-insts-counter)
  (print insts-counter)
  (set! insts-counter 0))

并增加分派子句:

((eq? message 'print-insts-counter) (print-insts-counter))

顺带一提,这里以及下面用到的 print 过程是:

(define (print x) (newline) (display x))

5.16

execute 过程中加入:

(if track-mode
    (print (instruction-text (car insts))))

增加分派子句:

((eq? message 'track-on) (set! track-mode true))
((eq? message 'track-off) (set! track-mode false))

make-new-machine 的定义中的 let 加入子句:

(track-mode false)

5.17

首先需要在 make-new-machine 中加入 labels 用于存放标签的表,并且加入相应的分派子句使得可以设置这个表:

((eq? message 'install-labels)
               (lambda (seq) (set! labels seq)))

上一个练习在 execute 中加入的表达式,加入寻找当前执行的指令是否存在在 labels 表中的逻辑:

(if track-mode
    (let ((label (find-label (instruction-text (car insts)) labels)))
      (if label
          (begin (print label)
                 (print (instruction-text (car insts))))
          (print (instruction-text (car insts))))))

其中用到的 find-label 过程:

(define (find-label inst labels)
  (if (null? labels)
      false
      (let ((label-name (caar labels))
            (label-inst (caadar labels)))
        (if (eq? inst label-inst)
            label-name
            (find-label inst (cdr labels))))))

5.18

相对来说是比较简单的:

(define (make-register name)
  (let ((contents '*unassigned*)
        (track-mode false))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set)
             (lambda (value)
               (if track-mode
                   (begin
                    (newline)
                    (display name)
                    (display ":")
                    (display contents)
                    (display " => ")
                    (display value)))
               (set! contents value)))
            ((eq? message 'track-on) (set! track-mode true))
            ((eq? message 'track-off) (set! track-mode false))
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))

make-new-machine 中加入分派子句:

((eq? message 'register-track-on)
 (lambda (name) ((lookup-register name) 'track-on)))
((eq? message 'register-track-off)
 (lambda (name) ((lookup-register name) 'track-off)))
(else (error "Unknown request -- MACHINE" message))))

这次测试结果比较短,就贴上来吧:

> ((factorial-machine 'register-track-on) 'val)
> (start factorial-machine)
5
val:*unassigned* => 1
val:1 => 2
val:2 => 6
val:6 => 24
val:24 => 120
(total-pushes = 8 maximum-depth = 8)
120

5.19

我完全没有看懂题目表达的设置断点其中关于具体位置的需求..跳过了

5.20

画图题

5.21

a)

完全类似于书中的递归的斐波那契机器:

(define count-machine
  (make-machine
  '(tree val tmp continue)
  (list (list 'null? null?)
        (list 'pair? pair?)
        (list '+ +)
        (list 'car car)
        (list 'cdr cdr)
        (list 'not not))
  '(controller
      (assign continue (label count-done))
    count-loop
      (test (op null?) (reg tree))
      (branch (label null-case))
      (test (op pair?) (reg tree))
      (test (op not) (reg flag))
      (branch (label leave-case))
      ;; set up to compute (car tree)
      (save continue)
      (assign continue (label after-car-tree))
      (save tree)
      (assign tree (op car) (reg tree))
      (goto (label count-loop))
    after-car-tree
      (restore tree)
      (assign tree (op cdr) (reg tree))
      (assign continue (label after-cdr-tree))
      (save val)
      (goto (label count-loop))
    after-cdr-tree
      (assign tmp (reg val))
      (restore val)
      (restore continue)
      (assign val
              (op +) (reg val) (reg tmp))
      (goto (reg continue))
    null-case
      (assign val (const 0))
      (goto (reg continue))
    leave-case
      (assign val (const 1))
      (goto (reg continue))
    count-done)))

b)

说老实话..不会

5.22

(define append-machine
  (make-machine
   '(x y tmp continue)
   (list (list 'car car)
         (list 'cdr cdr)
         (list 'cons cons)
         (list 'null? null?))
   '(controller
       (assign continue (label append-done))
     append-loop
       (test (op null?) (reg x))
       (branch (label null-case))
       (assign tmp (op car) (reg x))
       (save tmp)
       (save continue)
       (assign continue (label after))
       (assign x (op cdr) (reg x))
       (goto (label append-loop))
     after
       (restore continue)
       (restore x)
       (assign y (op cons) (reg x) (reg y))
       (goto (reg continue))
     null-case
       (goto (reg continue))
     append-done)))

(define append!-machine
  (make-machine
   '(x y tmp iter)
   (list (list 'cdr cdr)
         (list 'set-cdr! set-cdr!)
         (list 'null? null?))
   '(controller
       (assign iter (reg x))
     append-loop
       (assign tmp (op cdr) (reg iter))
       (test (op null?) (reg tmp))
       (branch (label null-case))
       (assign iter (op cdr) (reg iter))
       (goto (label append-loop))
     null-case
       (perform (op set-cdr!) (reg iter) (reg y))
     append-done)))

5.23

ev-cond
  (assign exp (op cond->if) (reg exp))
  (goto (label eval-dispatch))

ev-let
  (assign exp (op let->combinition) (reg exp))
  (goto (label eval-dispatch))

5.24

ev-cond
  (assign unev (op cond-clauses) (reg exp))
ev-loop
  (assign exp (op car) (reg unev))
  (test (op cond-else-clause?) (reg exp))
  (branch (label ev-else))
  (save exp)
  (assign exp (op cond-predicate) (reg exp))
  (save continue)
  (assign continue (label ev-cond-predicate))
  (save env)
  (save unev)
  (goto (label eval-dispatch))
ev-cond-predicate
  (restore unev)
  (restore env)
  (restore continue)
  (restore exp)
  (test (op true?) (reg val))
  (branch (label ev-cond-actions))
  (assign unev (op cdr) (reg unev))
  (goto (label ev-loop))
ev-cond-actions
  (assign exp (op cond-actions) (reg exp))
  (goto (label eval-dispatch))
ev-else
  (assign exp (op cond-actions) (reg exp))
  (goto (label eval-dispatch))

5.25

这题的工作量实在是太大了..社区里都没人做这道题

5.26

a) 最大深度为 10

b) 压栈次数为 $\mathrm{times} = 35n + 29$

5.27

a) 最大深度为 $\mathrm{depth} = 5n + 3$

b) 压栈次数为 $\mathrm{times} = 32n - 16$

5.28

这个很明显了..不贴了

5.29

a) 最大深度为 $\mathrm{depth} = 5n + 3$

b) 压栈次数为..为..打扰了

5.30

打扰了,工作量太大

5.31

(f 'x 'y)
不需要任何 save 和 restore 操作

((f) 'x 'y)
不需要任何 save 和 restore 操作,尽管 (f) 是一个复合过程调用,
但它将把环境寄存器的值改为定义 f 的环境,不会影响 'x 和 'y 的求值

(f (g 'x) y)
需要对 argl 和 proc 进行操作,在 (g 'x) 求值前后需要对 env 进行操作
因为这将改变 env 的值,从而影响到 y 的求值

(f (g 'x) 'y)
需要对 argl 和 proc 进行操作,但在 (g 'x) 求值前后不需要操作
因为 env 的改变不会影响 y 的求值

5.32

 ev-application 
   (save continue) 
   (assign unev (op operands) (reg exp)) 
   (assign exp (op operator) (reg exp)) 
   (test (op symbol?) (reg exp))
   (branch (label ev-appl-operator-symbol)) 
   (save env) 
   (save unev) 
   (assign continue (label ev-appl-did-operator)) 
   (goto (label eval-dispatch)) 
 ev-appl-operator-symbol 
   (assign continue (label ev-appl-did-operator-no-restore)) 
   (goto (label eval-dispatch)) 
 ev-appl-did-operator 
   (restore unev)             
   (restore env) 
 ev-appl-did-operator-no-restore 
   (assign argl (op empty-arglist)) 
   (assign proc (reg val))
   (test (op no-operands?) (reg unev)) 
   (branch (label apply-dispatch)) 
   (save proc) 

意义不大,因为解释器仍然需要在运行的过程中不断地对表达式进行解释,而编译器则不需要,而且过多的分派会使得解释器变得比现在复杂得多

5.33

写了一个过程来友好输出编译结果:

(define (display-code list)
  (define (display-code-seq seq)
    (if (not (null? seq))
        (let ((next-line (car seq)))
          (newline)
          (if (not (symbol? next-line))
              (display "  "))
          (display next-line)
          (display-code-seq (cdr seq)))))
  (let ((code-seq (caddr list)))
    (display-code-seq code-seq)))

代码如下,依我看没有性能差异

  (assign val (op make-compiled-procedure) (label entry1) (reg env))
  (goto (label after-lambda2))
entry1
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (n)) (reg argl) (reg env))
  (save continue)
  (save env)
  (assign proc (op lookup-variable-value) (const =) (reg env))
  (assign val (const 1))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const n) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch6))
compiled-branch7
  (assign continue (label after-call8))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch6
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call8
  (restore env)
  (restore continue)
  (test (op false?) (reg val))
  (branch (label false-branch4))
true-branch3
  (assign val (const 1))
  (goto (reg continue))
false-branch4
  (assign proc (op lookup-variable-value) (const *) (reg env))
  (save continue)
  (save proc)
  (save env)
  (assign proc (op lookup-variable-value) (const factorial-alt) (reg env))
  (save proc)
  (assign proc (op lookup-variable-value) (const -) (reg env))
  (assign val (const 1))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const n) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch9))
compiled-branch10
  (assign continue (label after-call11))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch9
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call11
  (assign argl (op list) (reg val))
  (restore proc)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch12))
compiled-branch13
  (assign continue (label after-call14))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch12
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call14
  (assign argl (op list) (reg val))
  (restore env)
  (assign val (op lookup-variable-value) (const n) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (restore proc)
  (restore continue)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch15))
compiled-branch16
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch15
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
after-call17
after-if5
after-lambda2
  (perform (op define-variable!) (const factorial-alt) (reg val) (reg env))
  (assign val (const ok))

5.34

  (assign val (op make-compiled-procedure) (label entry1) (reg env))
  (goto (label after-lambda2))
entry1
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (n)) (reg argl) (reg env))
  (assign val (op make-compiled-procedure) (label entry3) (reg env))
  (goto (label after-lambda4))
entry3
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (product counter)) (reg argl) (reg env))
  (save continue)
  (save env)
  (assign proc (op lookup-variable-value) (const >) (reg env))
  (assign val (op lookup-variable-value) (const n) (reg env))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const counter) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch8))
compiled-branch9
  (assign continue (label after-call10))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch8
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call10
  (restore env)
  (restore continue)
  (test (op false?) (reg val))
  (branch (label false-branch6))
true-branch5
  (assign val (op lookup-variable-value) (const product) (reg env))
  (goto (reg continue))
false-branch6
  (assign proc (op lookup-variable-value) (const iter) (reg env))
  (save continue)
  (save proc)
  (save env)
  (assign proc (op lookup-variable-value) (const +) (reg env))
  (assign val (const 1))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const counter) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch14))
compiled-branch15
  (assign continue (label after-call16))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch14
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call16
  (assign argl (op list) (reg val))
  (restore env)
  (save argl)
  (assign proc (op lookup-variable-value) (const *) (reg env))
  (assign val (op lookup-variable-value) (const product) (reg env))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const counter) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch11))
compiled-branch12
  (assign continue (label after-call13))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch11
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call13
  (restore argl)
  (assign argl (op cons) (reg val) (reg argl))
  (restore proc)
  (restore continue)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch17))
compiled-branch18
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch17
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
after-call19
after-if7
after-lambda4
  (perform (op define-variable!) (const iter) (reg val) (reg env))
  (assign val (const ok))
  (assign proc (op lookup-variable-value) (const iter) (reg env))
  (assign val (const 1))
  (assign argl (op list) (reg val))
  (assign val (const 1))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch20))
compiled-branch21
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch20
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
after-call22
after-lambda2
  (perform (op define-variable!) (const factorial) (reg val) (reg env))
  (assign val (const ok))

这题如果一点点去加注释的话是很显而易见的..我就不多废话了

5.35

(define (f x) (+ x (g (+ x 2))))

5.36

从右到左。

编译器为了产生在 argl 寄存器中存储一个正向的参数列表,首先使用 reverse 反转了运算对象的表,然后逐个产生代码计算其值并 consargl

5.37

不需要比较了..我最开始看的时候没有看清楚 preserving 的描述是“将寄存器列表中第二个序列需要而第一个序列修改了的寄存器 save / restore”,误以为是所有在寄存器列表里的都会产生 save / restore 操作..懵逼了好久,到后来才反应过来

5.38

打扰了..可能第二次看的时候再来做这题吧

5.39

(define (lexical-address-lookup address env)
  (define (jump-frame frame-addr env)
    (if (= frame-addr 0)
        (car env)
        (jump-frame (- frame-addr 1) (cdr env))))
  (define (jump-var var-addr vars vals)
    (if (= var-addr 0)
        (if (eq? (car vals) '*unassigned*)
            (error "Unassigned variable" (car vars))
            (car vals))
        (jump-var (- var-addr 1) (cdr vars) (cdr vals))))
  (let ((frame-addr (car address))
        (var-addr (cadr address)))
    (let ((frame (jump-frame frame-addr env)))
      (let ((vars (frame-variables frame))
            (vals (frame-values frame)))
        (jump-var var-addr vars vals)))))

5.40

(define (compile-lambda-body exp proc-entry ct-env) 
   (let ((formals (lambda-parameters exp))) 
     (append-instruction-sequences 
       (make-instruction-sequence '(env proc argl) '(env) 
         `(,proc-entry 
           (assign env (op compiled-procedure-env) (reg proc)) 
           (assign env 
                   (op extend-environment) 
                   (const ,formals) 
                   (reg argl) 
                   (reg env)))) 
       (compile-sequence 
         (lambda-body exp) 
         'val 'return 
         (extend-ct-env ct-env formals))))) 
 (define (extend-ct-env env frame) 
   (cons frame env)) 

5.41

把原有的 lookup-variable-value 过程稍加改动就可以实现 find-variable

(define (find-variable var env)
  (let ((frame-addr 0)
        (var-addr 0))
    (define (env-loop env)
      (define (scan vars vals)
        (cond ((null? vars)
               (set! var-addr 0)
               (set! frame-addr (+ frame-addr 1))
               (env-loop (enclosing-environment env)))
              ((eq? var (car vars))
               (list frame-addr var-addr))
              (else
               (set! var-addr (+ var-addr 1))
               (scan (cdr vars) (cdr vals)))))
      (if (eq? env the-empty-environment)
          'not-found
          (let ((frame (first-frame env)))
            (scan (frame-variables frame)
                  (frame-values frame)))))
    (env-loop env)))

5.42

跳过了..

5.43

只需要使用 scan-out-defineslambda 的体进行变换即可

 (define (compile-lambda-body exp proc-entry ct-env) 
   (let ((formals (lambda-parameters exp))) 
     (append-instruction-sequences 
       (make-instruction-sequence '(env proc argl) '(env) 
         `(,proc-entry 
           (assign env (op compiled-procedure-env) (reg proc)) 
           (assign env 
                   (op extend-environment) 
                   (const ,formals) 
                   (reg argl) 
                   (reg env)))) 
       (compile-sequence 
         (scan-out-defines (lambda-body exp)) 
         'val 'return 
         (extend-ct-env ct-env formals))))) 

5.44

(define (overwrite? operator ct-env) 
  (let ((r (find-variable operator ct-env))) 
    (eq? r 'not-found))) 
(define (open-code? exp ct-env) 
  (and (memq (car exp) '(+ - * /)) 
       (overwrite? (car exp) ct-env)))

5.45-5.52

跳过了

Archives QR Code
QR Code for this page
Tipping QR Code
Leave a Comment

已有 3 条评论
  1. 迷妹 迷妹

    @(啊)大。。。大佬

  2. 迷弟 迷弟

    @(啊)大。。。大佬

  3. 迷儿 迷儿

    @(啊)大。。。大佬