(wat-aro)

生きてます

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))
  ))