SICP 読み (344) 5.5 翻訳系
微妙な方面にハマりかけるも検討着手。エントリを改めて投入。
問題 5.43
そろそろ終わりにせいよ、と自分でも思うな。とりあえずこれまでの問題は踏まえない形で試してみます。まず let の盛り込み。compile に以下を追加。
((let? exp) (compile (let->combination exp) target linkage))
あと、以下を 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))))
これらを盛り込んだソレを試してみる。出力は整形済み。
gosh> (add-load-path ".") ("." "/usr/share/gauche/site/lib" "/usr/share/gauche/0.8.7/lib") gosh> (load "load-eceval-compiler") #t gosh> (load "ch5-compiler") #t gosh> (define true #t) true gosh> (define false #f) false gosh> (compile '(let ((a 1)) (+ a 1)) 'val 'return) ((env continue) (env proc argl continue val) ((assign proc (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 (a)) (reg argl) (reg 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 a) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch3)) compiled-branch4 (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch3 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (goto (reg continue)) after-call5 after-lambda2 (assign val (const 1)) (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch6)) compiled-branch7 (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch6 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (goto (reg continue)) after-call8)) gosh>
一応、以下なソレになってる模様。
((lambda (a) (+ a 1)) 1)
次は scan-out-defines の盛り込み。その前に評価器に吸わせて簡単に試験。出力は整形済みです。
gosh> (scan-out-defines '(define (factorial n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1))) ((let ((iter '*unassigned*)) (set! iter (lambda (product counter) (if (> counter n) product (iter (* counter product) (+ counter 1))))) define (factorial n) (iter 1 1))) gosh>
しまった。間違えた。吸わせるのは以下のリストか。
(lambda (n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1))
再度評価。
gosh> (scan-out-defines '(lambda (n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1))) ((let ((iter '*unassigned*)) (set! iter (lambda (product counter) (if (> counter n) product (iter (* counter product) (+ counter 1))))) lambda (n) (iter 1 1))) gosh>
あわわ。駄目じゃん。手を入れたソレが駄目な模様。ちょっと時間下さひ (汗
再開
直前エントリを見直してみるに lambda-body が scan-out-defines に渡されるので正しくは以下か (とほほ
gosh> (lambda-body '(lambda (n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1))) ((define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1)) gosh> (scan-out-defines '((define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1)) ) ((let ((iter '*unassigned*)) (set! iter (lambda (product counter) (if (> counter n) product (iter (* counter product) (+ counter 1))))) (iter 1 1))) gosh>
やれやれ。イケてるみたいなので盛り込んでみる。以下を ch5-compiler に
(define (scan-out-defines exp) (define (make-set init set exp) (if (null? exp) (if (null? init) '() (append (list 'let init) set)) (if (definition? (car exp)) (make-set (append init (list (list (definition-variable (car exp)) ''*unassigned*))) (append set (list (list 'set! (definition-variable (car exp)) (definition-value (car exp))))) (cdr exp)) (make-set init set (cdr exp))))) (define (remove-define l exp) (cond ((null? exp) l) ((definition? (car exp)) (remove-define l (cdr exp))) (else (remove-define (append l (list (car exp))) (cdr exp))))) (let ((result (make-set '() '() exp))) (if (null? result) exp (list (append result (remove-define '() exp))))))
あと、compiler-lambda-body 手続きの末端を以下に修正
(compile-sequence (scan-out-defines (lambda-body exp)) 'val 'return)))) ;; (compile-sequence (lambda-body exp) 'val 'return))))
で、それを load して compile に吸わせたのが以下。整形してます。
gosh> (compile '(define (factorial n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1)) 'val 'return) ((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 (n)) (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 (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 (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-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 product) (reg env)) (goto (reg continue)) false-branch8 (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-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 *) (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-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 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-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 factorial) (reg val) (reg env)) (assign val (const ok)) (goto (reg continue))))
な、長ひ。(とほほ
何となくイケてる模様に見えるんですが明日再度確認してみます。