SICP 読み (346) 5.5 翻訳系 - yamanetoshi's diary

問題もラスト 10 を切ってるらしい。ハードル高すぎて途切れ気味な今日この頃ッス。
がしかし負けずに続行。

問題 5.44

とは言え、一旦リターンしないと駄目なんだった。問題 5.43 では問題 5.42 で完結したと思われる lexical address なソレを盛り込んだ試験をしておりませんのでこれをマージせんと駄目。これが最初のステップになる。
diff とってみたら 5.42 の方ががちゃがちゃした修正入ってるみたいなのでこっちを元にして 5.43 な差分を盛り込む方針で修正。できればさくっと済ませて guile のドキュメント方面に (を

盛り込み

上記の通り、5.42 なディレクトリをコピーして ch5-syntax.scm に

(define (let? exp) (tagged-list? exp 'let))
(define (let->combination exp)
  (append (list (make-lambda (map car (cadr exp)) (cddr exp)))
          (map cadr (cadr exp))))

を追加。そして ch5-compiler に

scan-out-defines 手続きの追加
compile に let なソレを追加
compile-lambda-body の修正

なんですか、cenv がある分、若干の微妙さがナニ。
で、盛り込み中に一瞬 cenv なソレが心配になったんですが、scan-out-defines については問題ナシ、な模様。で盛り込んでみたんですが、factorial なソレは確認が面倒なので

(define (length items)
  (define (length-iter a count)
    (if (null? a)
	count
	(length-iter (cdr a) (+ 1 count))))
  (length-iter items 0))

で試験してみます。

$ gosh
> (compile '(define (length items)
  (define (length-iter a count)
    (if (null? a)
	count
	(length-iter (cdr a) (+ 1 count))))
  (length-iter items 0)) 'val 'return '())

ハマり

let な分岐の compile に cenv な引数が入ってなかった。ハマりました。ようやく出力できたので以下に。

((env continue) (val) 
 ((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 (items)) (reg argl) (reg env)) 
  (assign proc (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 (length-iter)) (reg argl) (reg env)) 
  (assign val (op make-compiled-procedure) (label entry5) (reg env)) 
  (goto (label after-lambda6)) 
  entry5 
  (assign env (op compiled-procedure-env) (reg proc)) 
  (assign env (op extend-environment) (const (a count)) (reg argl) (reg env)) 
  (save continue) 
  (save env) 
  (assign proc (op lookup-variable-value) (const null?) (op get-global-environment))) 
  (assign val (op lookup-variable-value) (const a) (op get-global-environment)) 
  (assign argl (op list) (reg val)) 
  (test (op primitive-procedure?) (reg proc)) 
  (branch (label primitive-branch10)) 
  compiled-branch11 
  (assign continue (label after-call12)) 
  (assign val (op compiled-procedure-entry) (reg proc)) 
  (goto (reg val)) 
  primitive-branch10 
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  after-call12 
  (restore env) 
  (restore continue) 
  (test (op false?) (reg val)) 
  (branch (label false-branch8)) 
  true-branch7 
  (assign val (op lookup-variable-value) (const count) (op get-global-environment)) 
  (goto (reg continue)) 
  false-branch8 
  (assign proc (op lookup-variable-value) (const length-iter) (op get-global-environment)) 
  (save continue) 
  (save proc) 
  (save env) 
  (assign proc (op lookup-variable-value) (const +) (op get-global-environment)) 
  (assign val (op lookup-variable-value) (const count) (op get-global-environment)) 
  (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-branch16)) 
  compiled-branch17 
  (assign continue (label after-call18)) 
  (assign val (op compiled-procedure-entry) (reg proc)) 
  (goto (reg val)) 
  primitive-branch16 
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) 
  after-call18 
  (assign argl (op list) (reg val)) 
  (restore env) 
  (save argl) 
  (assign proc (op lookup-variable-value) (const cdr) (op get-global-environment)) 
  (assign val (op lookup-variable-value) (const a) (op get-global-environment)) 
  (assign argl (op list) (reg val)) 
  (test (op primitive-procedure?) (reg proc)) 
  (branch (label primitive-branch13)) 
  compiled-branch14 
  (assign continue (label after-call15)) 
  (assign val (op compiled-procedure-entry) (reg proc)) 
  (goto (reg val)) 
  primitive-branch13 
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) 
  after-call15 
  (restore argl) 
  (assign argl (op cons) (reg val) (reg argl))
  (restore proc) 
  (restore continue) 
  (test (op primitive-procedure?) (reg proc)) 
  (branch (label primitive-branch19)) 
  compiled-branch20 
  (assign val (op compiled-procedure-entry) (reg proc)) 
  (goto (reg val)) 
  primitive-branch19 
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) 
  (goto (reg continue))
  after-call21 
  after-if9 
  after-lambda6 
  (perform (op set-variable-value!) (const length-iter) (reg val) (reg env)) 
  (assign val (const ok)) 
  (assign proc (op lookup-variable-value) (const length-iter) (op get-global-environment)) 
  (assign val (const 0)) 
  (assign argl (op list) (reg val)) 
  (assign val (op lookup-variable-value) (const items) (op get-global-environment)) 
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc)) 
  (branch (label primitive-branch22)) 
  compiled-branch23 
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val)) 
  primitive-branch22 
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) 
  (goto (reg continue)) 
  after-call24 
  after-lambda4 
  (assign val (const *unassigned*)) 
  (assign argl (op list) (reg val)) 
  (test (op primitive-procedure?) (reg proc)) 
  (branch (label primitive-branch25)) 
  compiled-branch26 
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val)) 
  primitive-branch25 
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) 
  (goto (reg continue)) 
  after-call27 
  after-lambda2 
  (perform (op define-variable!) (const length) (reg val) (reg env)) 
  (assign val (const ok)) 
  (goto (reg continue))))

長い。しかも手動翻訳が微妙。やり方的に微妙ですがエントリ投入後に確認してみます。 (を