2016/02/08
SICP 問題 5.38ab
+ - * = はopen-codeとして (reg val (op +) (reg arg1) (reg arg2)) の形で処理できるようにする.
(define (open-code? exp)
(memq (car exp) '(= * - +)))
(define (compile exp target linkage)
(cond ((self-evaluating? exp)
(compile-self-evaluating exp target linkage))
((quoted? exp) (compile-quoted exp target linkage))
((variable? exp)
(compile-variable exp target linkage))
((assignment? exp)
(compile-assignment exp target linkage))
((definition? exp)
(compile-definition exp target linkage))
((if? exp) (compile-if exp target linkage))
((lambda? exp) (compile-lambda exp target linkage))
((begin? exp)
(compile-sequence (begin-actions exp)
target linkage))
((cond? exp) (compile (cond->if exp) target linkage))
((open-code? exp) ;open-code?でdispatch
(compile-open-code exp target linkage))
((application? exp)
(compile-application exp target linkage))
(else
(error "Unknown expression type -- COMPILE" exp))))
(define (spread-arguments operand) ;それぞれコンパイルしてリストにして返す
(let ((co-arg1 (compile (car operand) 'arg1 'next))
(co-arg2 (compile (cadr operand) 'arg2 'next)))
(list co-arg1 co-arg2)))
(define (compile-open-code exp target linkage)
(if (= (length exp) 3)
(let ((proc (operator exp))
(args (spread-arguments (operands exp))))
(end-with-linkage linkage
(append-instruction-sequences
(car args)
;; co-arg2がopen-code式だった場合にarg1が上書きされるので退避させる.
(preserving
'(arg1)
(cadr args)
(make-instruction-sequence
'(arg1 arg2)
(list target)
`((assign ,target (op ,proc) (reg arg1) (reg arg2))))))))
(error "require 2 operand" exp)))
test
gosh> (compile '(+ 1 2) 'val 'next)
(()
(arg1 arg2 val)
((assign arg1 (const 1))
(assign arg2 (const 2))
(assign val (op +) (reg arg1) (reg arg2))
))
(()
(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 val (op +) (reg arg1) (reg arg2))
))