Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
(defpackage :ev (:use :cl :optima :alexandria))
(in-package :ev)
(defstruct (meta (:constructor meta (form))) form)
(defun alist/augment (env namespace key value)
(acons namespace (acons key value (cdr (assoc namespace env))) env))
(defun alist/augment* (env namespace fresh-alist)
(acons namespace (nconc fresh-alist (cdr (assoc namespace env))) env))
(defun alist/resolve (env namespace key)
(let ((entry (assoc key (cdr (assoc namespace env)))))
(if entry
(cdr entry)
(meta `(:unbound ,key ,namespace ,env)))))
(defgeneric bind (walker namespace env fresh-alist)
(:method (_w namespace env fresh-alist)
(alist/augment* env namespace fresh-alist)))
(defgeneric assign (walker namespace env fresh-alist)
(:method (w n e a) (bind w n e a)))
(defgeneric resolve (walker namespace env name)
(:method (_w namespace env name)
(alist/resolve env namespace name)))
(defgeneric leaf (walker env leaf)
(:method (walker env value)
(values value env))
(:method (walker env (variable symbol))
(values (resolve walker :variable env variable) env)))
(defgeneric discard-value (walker env form value)
(:method (w env f v) env))
(defgeneric application (walker env fn arguments)
(:method (w e f a) (apply f a)))
(defmethod resolve (walker (namespace (eql :function)) env (name (eql :+)))
(function +))
(defun interpret (walker form env)
(labels ((binding (entry)
(destructuring-bind (var value) (ensure-list entry)
(unless (variablep walker var env)
(error "Not a variable: ~a" var))
(list var value)))
(reduce* (forms env)
(reduce #'env-reducer forms :initial-value env))
(collect* (forms env)
for f in forms
collect (multiple-value-bind (v e) (interpret walker f env)
(prog1 v
(setf env e))))
(env-reducer (env form)
(multiple-value-bind (val env) (interpret walker form env)
(discard-value walker env form val))))
(ematch form
((list* 'progn forms)
(interpret walker
(lastcar forms)
(reduce* (butlast forms) env)))
((list 'setq var form)
(let ((binding (resolve walker :variable env var)))
(if (meta-p binding)
(values binding env)
(multiple-value-bind (v e) (interpret walker form env)
(values v (assign walker :variable e (acons var v ())))))))
((list* 'let (list* bindings) body)
for (v e) in (mapcar #'binding bindings)
collect (cons v (interpret walker e env)) into alist
collect (cons v (resolve walker :variable env v)) into previous
(multiple-value-bind (value env)
(interpret walker
(cons 'progn body)
(bind walker
(values value
(bind walker :variable env previous))))))
((list* op args)
(let ((fn (resolve walker :function env op)))
(multiple-value-bind (list env) (collect* args env)
(application walker env fn list))))
(_ (leaf walker env form)))))
;; (interpret nil
;; '(let ((x 3) (y 2))
;; (setq x (:+ y 20 x)))
;; nil)
;; 25
(defmethod leaf ((walker (eql :type)) env leaf)
(values (class-name (class-of leaf)) env))
(defmethod leaf ((walker (eql :type)) env (leaf symbol))
(values (resolve walker :variable env leaf) env))
(defmethod assign ((walker (eql :type))
(ns (eql :variable))
for (v . w) in fresh-alist
for r = (resolve walker ns env v)
for new = (if (subtypep w r) nil w)
when new
collect (cons v w) into bindings
finally (return (if bindings
(bind walker :variable env bindings)
(defmethod application ((walker (eql :type)) env (fn (eql #'+)) arguments)
(let ((types (remove-duplicates arguments)))
(values (if (every (lambda (a) (subtypep a 'number)) types)
(if (rest types) `(or ,@types) (first types))
;; (interpret :type
;; '(let ((x 3) (y 2))
;; (setq x (:+ y 20 x)))
;; nil)
;; (interpret :type
;; '(let ((x 3) (y 2.5))
;; (setq x (:+ y 20 x)))
;; nil)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.