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)) ))
おかしいところはなく動いている.