Meta scheme compiler and VM and interpreter.

3imp_pdf-HeapBasedModel.scm

;; Working in mzscheme 372 (NOT working in GaucheScheme 0.9.2)
;; Refered to 3imp.pdf (http://www.cs.indiana.edu/~dyb/papers/3imp.pdf) Chapter 2 Heap Based Model.
;; I added two new assembly-operators 'beg' and 'appen' to support syntaxes 'begin' and 'define'.

(require (lib "defmacro.ss"))

;; utils

(define-macro (record vars val . exps)
  `(apply (lambda ,vars ,@exps) ,val))

(define-macro (record-case target . conds)
  (let ((target-s (gensym)))
    `(let ((,target-s ,target))
       (cond
        ,@(map (lambda (c)
                 (let ((top (car c)))
                   (if (eq? top 'else) c
                       `((eq? (car ,target-s) ',top)
                         (record ,(cadr c) (cdr ,target-s) ,@(cddr c))))))
               conds)))))

(define last-pair
  (lambda (ls)
    (if (pair? (cdr ls))
        (last-pair (cdr ls))
        ls)))

(define concat!
  (lambda (ls ls2)
    (set-cdr! (last-pair ls) ls2)))

;; compiler

(define tail?
  (lambda (next)
    (eq? (car next) 'return)))

(define extend
  (lambda (e r)
    (cons r e)))

(define compile-lookup
  (lambda (var e)
    (let nxtrib ((e e) (rib 0))
      (if (null? e)
          (error "ERROR: NotFound the var" var)
          (let 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)))))))))


(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 (append '(begin) body) (extend e vars) '(return))
                next))

        (begin body
               (let begin-iter ((body body) (nx '()))
                 (if (null? body)
                     (let begin-iter2 ((compiled (reverse nx)))
                       (if (null? compiled)
                           next
                           `(beg (frame (halt) ,(car compiled))
                                 ,(begin-iter2 (cdr compiled)))))
                     (begin-iter (cdr body) (cons (compile (car body) e next) nx)))))

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

        (define (var x)
                (begin
                  (concat! (car e) (list var))
                  (compile x e (list 'appen next))))

        (call/cc (x)
                 (let ((c (list 'conti
                                (list 'argument
                                      (compile x e '(apply))))))
                   (if (tail? next)
                       c
                       (list 'frame next c))))

        (else
         (let 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)))))

;; virtual machine
(define closure
  (lambda (bod e)
    (list bod e)))

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

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

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

(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 (bod x) (VM (closure bod 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))

     (appen (x)
            (concat! (car e) (list 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))

     (beg  (exp x) (VM (VM a exp e r s) x e r s))

     (apply ()
            (if (pair? a)
                (record (body e) a
                        (VM a body (extend e r) '() s))
                (let ((rt (apply (eval a) r)))
                  (VM rt '(return) e r s))))

     (return ()
             (record (x e r s) s
                     (VM a x e r s))))))

(define evaluate
  (lambda (x e)
    (VM '()
        (compile x (map car e) '(halt))
        (map cdr e)
        '()
        '())))


(define *g '(((+ - * /) . (+ - * /))))


(define repl
  (lambda ()
    (define repl-iter
      (lambda ()
        (let ((x (read)))
          (when (not (eq? x 'quit-repl))
            (display (evaluate x *g))
            (repl-iter)))))
    (repl-iter)))


(repl)