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))))

な、長ひ。(とほほ
何となくイケてる模様に見えるんですが明日再度確認してみます。