uDiary

◆ [Scheme][3imp] 3imp 写経: 3.5 変数アクセスの改善

コード

record-case.scm, rec-recur.scm は昨日のをそのまま。

compiler2.scm:

;; compiler2.scm
; Translater shown in 3.5.1 of 3imp.

(load "record-case")
(load "rec-recur")

; tail: 3imp p.59
(define tail?
  (lambda (next)
    (eq? (car next) 'return)))

; extend: p.65
(define extend
  (lambda (e r)
    (cons r e)))

; extend: p.65
(define compile-lookup
  (lambda (var e)
    (recur nxtrib ((e e) (rib 0))
       (recur nxtelt ((vars (car e)) (elt 0))
	  (cond
	   ((null? vars) (nxtrib (cdr e) (+ rib 1)))
	   ((eq? (car vars) var) (cons rib elt))
	   (else (nxtelt (cdr vars) (+ elt 1))))))))

; compile: p.64
(define compile
  (lambda (x e next)
    (cond
     ((symbol? x)
      (list 'refer (compile-lookup x e) next))
     ((pair? x)
      (record-case x
         (quote (obj)
	  (list 'constant obj next))
	 (lambda (vars body)
	  (list 'close
		(compile body (extend e vars) '(return))
		next))
	 (if (test then else)
	  (let ((thenc (compile then e next))
		(elsec (compile else e next)))
	    (compile test e (list 'test thenc elsec))))
	 (set! (var x)
	  (let ((access (compile-lookup var e)))
	    (compile x e (list 'assign access next))))
	 (call/cc (x)
	  (let ((c (list 'conti
			 (list 'argument
			       (compile x e '(apply))))))
	    (if (tail? next)
		c
		(list 'frame next c))))
	 (else
	  (recur loop ((args (cdr x))
		       (c (compile (car x) e '(apply))))
		 (if (null? args)
		     (if (tail? next)
			 c
			 (list 'frame next c))
		     (loop (cdr args)
			   (compile (car args)
				    e
				    (list 'argument c))))))))
     (else
      (list 'constant x next)))))

vm2.scm:

;; vm2.scm
; 3imp 3.5.2 Evaluation

(load "record-case")
(load "rec-recur")
(load "compiler2")

(define call-frame
  (lambda (x e r s)
    (list x e r s)))

(define closure
  (lambda (body e)
    (list body e)))

(define continuation
  (lambda (s)
    (closure (list 'nuate s '(0 . 0)) '())))

(define lookup
  (lambda (access e)
    (recur nxtrib ((e e) (rib (car access)))
       (if (= rib 0)
	   (recur nxtelt ((r (car e)) (elt (cdr access)))
              (if (= elt 0)
		  r
		  (nxtelt (cdr r) (- elt 1))))
	   (nxtrib (cdr e) (- rib 1))))))

(define VM
  (lambda (a x e r s)
    (record-case x
       (halt () a)
       (refer (var x)
	(VM (car (lookup var e)) x e r s))
       (constant (obj x)
        (VM obj x e r s))
       (close (body x)
	(VM (closure body e) x e r s))
       (test (then else)
	(VM a (if a then else) e r s))
       (assign (var x)
	(set-car! (lookup var e) a)
	(VM a x e r s))
       (conti (x)
	(VM (continuation s) x e r s))
       (nuate (s var)
	(VM (car (lookup var e)) '(return) e r s))
       (frame (ret x)
	(VM a x e '() (call-frame ret e r s)))
       (argument (x)
	(VM a x e (cons a r) s))
       (apply ()
	(record (body e) a
	   (VM a body (extend e r) '() s)))
       (return ()
	(record (x e r s) s
	   (VM a x e r s))))))

repl2.scm:

#!/usr/local/bin/gosh

(add-load-path ".")
(load "vm2")

(define banner
  (lambda ()
    (display "3imp Heap-Based Compiler and VM")))

(define evaluate
  (lambda (x)
    (VM '() (compile x '() '(halt)) '() '() '())))

(define (repl)
  (let loop ((s '()))
    (display "\n>>> ")
    (set! s (read))
    (display (compile s '() '(halt)))
    (newline)

    (display "\n==> ")
    (display (evaluate s))
    (newline)
    (loop '())))

(define (main args)
  (banner)
  (repl))

実行結果

% ./repl2.scm
3imp Heap-Based Compiler and VM
>>> 100
(constant 100 (halt))

==> 100

>>> ((lambda (x) x) 1)
(frame (halt) (constant 1 (argument (close (refer (0 . 0) (return)) (apply)))))

==> 1

>>> (if #f 1 2)
(constant #f (test (constant 1 (halt)) (constant 2 (halt))))

==> 2

>>> ((lambda (x) (set! x (call/cc (lambda (cont) (cont 20))))) '())
(frame (halt) (constant () (argument (close (frame (assign (0 . 0) (return)) (conti (argument (close (constant 20 (argument (refer (0 . 0) (apply)))) (apply))))) (apply)))))

==> 20

拡張したりするのは、Stack-Based のやつを元にしたいので、ささーと逃げるように 4 章にすすむよ！