Scheme - レジスタ計算機での計算(翻訳系(翻訳したコードの例(反復的階乗手続きの定義)))

計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著)ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著)Julie Sussman (原著)
Gerald Jay Sussman (原著)和田 英一 (翻訳)

開発環境

• OS X Yosemite - Apple (OS)
• Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
• Scheme (プログラミング言語)
• Gauche (処理系)

計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の5(レジスタ計算機での計算)、5.5(翻訳系)、5.5.5(翻訳したコードの例)、問題 5.34.を解いてみる。

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
• プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
• Scheme手習い

問題 5.34.

コード(BBEdit, Emacs)

sample34.scm

#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-

(load "./compiler.scm")

(print  (compile
         '(define (factorial n)
            (define (iter product counter)
              (if (> counter n)
                  product
                  (iter (* counter product)
                        (+ counter 1))))
            (iter 1 1))
         'val
         'next))

入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))

$ ./sample34.scm
((env val) (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 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))))
$

見やすくするため、改行を挿入して修正。

レジスタ計算機。

;;手続きfactorialを構成し、手続き本体のコードを飛び越す
(assign val (op make-compiled-procedure) (label entry1) (reg env)) 
(goto (label after-lambda2))
entry1 ;factorialの呼び出しはここから始まる
(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))
;; 手続きiterを構成し、手続き本体のコードを飛び越す
(goto (label after-lambda4))
entry3 ;iterの呼び出しはここから始まる
(assign env (op compiled-procedure-env) (reg proc)) 
(assign env (op extend-environment) (const (product counter)) (reg argl) (reg env))
;; 手続きiter本体の開始
(save continue) 
(save env)
;; (> counter n)の計算
(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 ;valには(> counter n)の結果がある
(restore env) 
(restore continue) 
(test (op false?) (reg val)) 
(branch (label false-branch6))
true-branch5 ; productを返す
(assign val (op lookup-variable-value) (const product) (reg env)) 
(goto (reg continue))
false-branch6
;;(iter (* counter product) (+ counter 1))を計算し返す
(assign proc (op lookup-variable-value) (const iter) (reg env)) 
(save continue) 
(save proc) ;iter手続きを退避
(save env)
;;iterの引数(+ counter 1)の計算
(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) ;iterの部分引数リストを退避
;; iterの引数(* counter product)の計算
(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　;valには(* counte product)の結果がある
(restore argl) ;iterの部分引数リストを回復
(assign argl (op cons) (reg val) (reg argl)) 
(restore proc) ;iterを回復
(restore continue)
;; iterを作用させる
(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
;; 手続きをiterに代入
(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
;; 手続きを変数factorialに代入
(perform (op define-variable!) (const factorial) (reg val) (reg env)) 
(assign val (const ok))