SICP 問題 5.38d

+と*について任意個の被演算子の式が使えるように拡張する．
　
ここに書いた手続きを変更もしくは追加する．
３つ以上の引数の時は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が３つ以上なら
(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                           ;引数が３つ以上ならこちらで処理
         (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))
  ))

おかしいところはなく動いている．