gistfile1.txt

(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)
             (values
              (loop
                for f in forms
                collect (multiple-value-bind (v e) (interpret walker f env)
                          (prog1 v
                            (setf env e))))
              env))
           (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)
       (loop
         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
         finally
            (return
              (multiple-value-bind (value env)
                  (interpret walker
                             (cons 'progn body)
                             (bind walker
                                   :variable
                                   env
                                   alist))
                (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))
                   env
                   fresh-alist)
  (loop
    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)
                        env))))

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

;; (interpret :type
;;            '(let ((x 3) (y 2))
;;              (setq x (:+ y 20 x)))
;;            nil)
;; NUMBER

;; (interpret :type
;;            '(let ((x 3) (y 2.5))
;;              (setq x (:+ y 20 x)))
;;            nil)
;; (OR SINGLE-FLOAT FIXNUM)