2016/02/08
SICP 問題 5.38d
+と*について任意個の被演算子の式が使えるように拡張する.
ここに書いた手続きを変更もしくは追加する.
3つ以上の引数の時はarg1に畳み込んで計算していく.
(define (compile-open-code exp target linkage ct-env)
(cond ((= (length exp) 3)
(compile-open-code-operand exp target linkage ct-env))
((or (tagged-list? exp '+)
(tagged-list? exp '*))
(compile-open-code-operand-2
(operator exp env) (operands exp) target linkage ct-env))
(error "invalid application: " exp)))
(define (compile-open-code-operand exp target linkage ct-env)
(let ((proc (operator exp))
(args (spread-arguments (operands exp) ct-env)))
(end-with-linkage linkage
(preserving
'(env)
(car args)
;; co-arg2がopen-code式だった場合にarg1が上書きされるので退避させる.
(preserving
'(arg1 env)
(cadr args)
(make-instruction-sequence
'(arg1 arg2 env)
(list target)
`((assign ,target (op ,proc) (reg arg1) (reg arg2)))))))))
;;; operandが無くてprocが+なら1を,*なら0をtargetに代入.
;;; operandが一つだけならそのままの値をtargetに入れる.
;;; operandが3つ以上なら
(define (compile-open-code-operand-2 proc operands target linkage ct-env)
(cond ((null? operands)
(if (eq? proc '+)
(compile-self-evaluating 0 target linkage) ;+なら0
(compile-self-evaluating 1 target linkage))) ;*なら1
((null? (cdr operands))
(end-with-linkage linkage
(compile (car operand) target 'next ct-env)))
(else ;引数が3つ以上ならこちらで処理
(let ((operand (spread-arguments operands ct-env)))
(end-with-linkage
linkage
(append-instruction-sequences
(car operand)
(compile-open-code-operand-3 proc (cdr operand) target)))))))
;;; ここに渡されるseqはコンパイルされた引数のリスト.
;;; last-seqだとarg1を保護しながら最後の引数をarg2に代入して
;;; 最後にarg1, arg2をprocした結果をvalに代入する.
;;; まだ残っているときはarg1を保護しながら引数をarg2に代入して
;;; arg1とarg2をprocした結果をarg1に代入する
(define (compile-open-code-operand-3 proc seq target)
(if (last-seq? seq)
(preserving
'(arg1 env)
(car seq)
(make-instruction-sequence
'(arg1 arg2 env)
(list target)
`((assin ,target (op ,proc) (reg arg1) (reg arg2)))))
(append-instruction-sequences
(preserving
'(arg1 env)
(car seq)
(make-instruction-sequence '(arg1 arg2 env) '(arg1)
`((assign arg1 (op ,proc) (reg arg1) (reg arg2)))))
(compile-open-code-operand-3 proc (cdr seq) target))))
;;; operandが0または1以外の時はここでcompileする.
;;; 一つ目だけarg1に代入し,残りはarg2に代入する.
(define (spread-arguments operand ct-env)
(let iter ((operand (cdr operand))
(result (list (compile (car operand) 'arg1 'next ct-env))))
(if (null? operand)
(reverse result)
(iter (cdr operand)
(cons (compile (car operand) 'arg2 'next ct-env) result)))))
(define (last-seq? seq)
(null? (cdr seq)))
test
gosh> (compile '(+) 'val 'next)
(() (val) ((assign val (const 0))))
gosh> (compile '(*) 'val 'next)
(() (val) ((assign val (const 1))))
gosh> (compile '(+ 1) 'val 'next)
((arg1) (val) ((assign val (cont 1))))
gosh> (compile '(* 1) 'val 'next)
((arg1) (val) ((assign val (cont 1))))
gosh> (compile '(+ 1 2) 'val 'next)
(()
(arg1 arg2 val)
((assign arg1 (const 1))
(assign arg2 (const 2))
(assign val (op +) (reg arg1) (reg arg2)))
)
gosh> (compile '(* 1 2) 'val 'next)
(()
(arg1 arg2 val)
((assign arg1 (const 1))
(assign arg2 (const 2))
(assign val (op *) (reg arg1) (reg arg2))
))
gosh> (compile '(+ 1 2 3) 'val 'next)
(()
(arg1 arg2 val)
((assign arg1 (const 1))
(assign arg2 (const 2))
(assign arg1 (op +) (reg arg1) (reg arg2))
(assign arg2 (const 3))
(assin target (op +) (reg arg1) (reg arg2))
))
gosh> (compile '(+ 1 2 3) 'val 'next)
(()
(arg1 arg2 val)
((assign arg1 (const 1))
(assign arg2 (const 2))
(assign arg1 (op +) (reg arg1) (reg arg2))
(assign arg2 (const 3))
(assin target (op +) (reg arg1) (reg arg2))
))
gosh> (compile '(+ 1 (+ 2 3) (* 4 5)) 'val 'next)
(()
(arg1 arg2 val)
((assign arg1 (const 1))
(save arg1)
(assign arg1 (const 2))
(assign arg2 (const 3))
(assign arg2 (op +) (reg arg1) (reg arg2))
(restore arg1)
(assign arg1 (op +) (reg arg1) (reg arg2))
(save arg1)
(assign arg1 (const 4))
(assign arg2 (const 5))
(assign arg2 (op *) (reg arg1) (reg arg2))
(restore arg1)
(assin target (op +) (reg arg1) (reg arg2))
))
gosh> (compile '(* (* 2 3) (+ 1 4) (* 3 4)) 'val 'next)
(()
(arg1 arg2 val)
((assign arg1 (const 2))
(assign arg2 (const 3))
(assign arg1 (op *) (reg arg1) (reg arg2))
(save arg1)
(assign arg1 (const 1))
(assign arg2 (const 4))
(assign arg2 (op +) (reg arg1) (reg arg2))
(restore arg1)
(assign arg1 (op *) (reg arg1) (reg arg2))
(save arg1)
(assign arg1 (const 3))
(assign arg2 (const 4))
(assign arg2 (op *) (reg arg1) (reg arg2))
(restore arg1)
(assin target (op *) (reg arg1) (reg arg2))
))
おかしいところはなく動いている.