Skip to content

Instantly share code, notes, and snippets.

@smihica
Created May 24, 2012 14:39
Show Gist options
  • Save smihica/2781950 to your computer and use it in GitHub Desktop.
Save smihica/2781950 to your computer and use it in GitHub Desktop.
Meta scheme compiler and VM and interpreter.
;; 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment