elisp kernel

kernel.el

;; -*- lexical-binding: true; -*-

(defun kernel--make-vau (params env body-exprs)
  (list '%Vau params env body-exprs))

(defun kernel--vau-params (vau) (nth 1 vau))
(defun kernel--vau-env (vau) (nth 2 vau))
(defun kernel--vau-body (vau) (nth 3 vau))

(defun kernel--type (thing)
  (nth 0 thing))

(defun kernel--vau? (thing)
  (and (listp thing)
       (equal (kernel--type thing) '%Vau)))

(defun kernel--wrapped? (thing)
  (and (listp thing)
       (equal (kernel--type thing) '%wrapped)))

(defun kernel--make-wrap (body)
  (list '%wrapped body))

(defun kernel-eval (ast &optional env)
  (let ((env (or env (kernel--base-env))))
    (kernel--eval-body ast env)))

(defun kernel--eval-exprs (exprs env)
  (mapcar (lambda (param) (kernel--eval-expr param env)) exprs))

(defun kernel--eval-body (exprs env)
  (car (last (kernel--eval-exprs exprs env))))

(defun kernel--eval-expr (expr env)
  (cond ((symbolp expr)
         (kernel--env-lookup expr env))
        ((or (numberp expr)
             (stringp expr))
         expr)
        ((listp expr)
         (let
             ((combiner (kernel--eval-expr (car expr) env)))
           (kernel--combine combiner (cdr expr) env)))))



(defun kernel--native-proc? (thing)
  (functionp thing))

(defun kernel--combine (combiner ptree env)
  (cond ((kernel--native-proc? combiner)
         (kernel--native-apply combiner ptree env))
        ((kernel--wrapped? combiner)
         (kernel--vau-invoke
          (kernel--unwrap combiner)
          (kernel--eval-ptree ptree env)
          env))
        (t (kernel--vau-invoke combiner
                               ptree
                               env))))

(defun kernel--vau-invoke (vau-expr args env)
  (let ((body-env
         (kernel--apply-args-to-values-in-env (kernel--vau-params vau-expr)
                                              args
                                              env)))
    (kernel--eval-body (kernel--vau-body vau-expr) body-env)))

(defun kernel--native-apply (combiner args env)
  (apply combiner args env))

(defun kernel--apply-args-to-values-in-env (args values env)
  (append (kernel--zip args values) env))

(defun kernel--zip (a b)
  (if (or a b)
      (cons (cons (car a)
                  (car b))
            (kernel--zip (cdr a)
                         (cdr b)))
    nil))

(defun kernel--eval-ptree (ptree env)
  (mapcar (lambda (param) (kernel--eval-expr param env)) ptree))


;; (kernel-eval '(
;;                ((Vau (x) env
;;                      x
;;                      ) 11)
;;                ))


;;; environments

(defun kernel--base-env ()
  '((Vau . kernel--parse-vau)))

(defun kernel--empty-env () nil)

(defun kernel--env-set (name value env)
  (cons (cons name value) env))

(defun kernel--env-set-many (pairs env)
  (append pairs env))

(defun kernel--env-lookup (symbol env)
  (cdr (assoc symbol env)))

;;;

(defun kernel--eval-$vau (ast)
  (let ((args (cadr ast))
        (env (caddr ast))
        (body (cdddr ast)))
    (kernel--eval-body body env)))

(defun kernel--parse-vau (ast env)
  (let ((params (car ast))
        (env (cadr ast))
        (body (cddr ast)))
    (kernel--make-vau params env body)))


(require 'ert)

(ert-deftest evaluates-numbers ()
  :tags '(kernel)
  (should (equal (kernel-eval 1)
                 1)))

(ert-deftest evaluates-vau ()
  :tags '(kernel)
  (let ((vau-results (kernel--eval-expr '($vau (x) $env 10))))
    (should (equal
             10))))



(ert-deftest env-actions ()
  "actions that deal with manipulating environments."
  :tags '(kernel)

  (let ((basic-env (kernel--base-env))
        (empty-env (kernel--empty-env)))
    (should (equal (kernel--env-lookup 'foo )
                   10
                   ))
    ))