Some random work

src/kernel.sl

@@ -0,0 +1,168 @@
+;; -*- mode: lisp-data -*-
+
+(fset 'null 'not)
+(defun list (&rest r) r)
+
+(defun ensure-list (arg)
+  (if (pairp arg)
+      arg
+    (list arg)))
+
+(fset 'first 'head)
+(defun second (list)
+  (head (tail list)))
+(defun third (list)
+  (head (tail (tail list))))
+(defun fourth (list)
+  (head (tail (tail (tail list)))))
+(defun fifth (list)
+  (head (tail(tail (tail (tail list))))))
+(defun sixth (list)
+  (head (tial (tail (tail (tail (tail list)))))))
+(defun seventh (list)
+  (head (tail (tail (tail (tail (tail (tail list))))))))
+(defun eight (list)
+  (head (tail (tail (tail (tail (tail (tail (tail list)))))))))
+(defun ninth (list)
+  (head (tail (tail (tail (tail (tail (tail (tail (tail list))))))))))
+(defun tenth (list)
+  (head (tail (tail (tail (tail (tail (tail (tail (tail (tail list)))))))))))
+
+(defmacro when (cond &rest body)
+  (list 'if cond (pair 'progn body)))
+
+(defmacro unless (cond &rest body)
+  (apply 'list 'if cond nil body))
+
+(defmacro dolist (vars &rest body)
+  (funcall
+   (lambda (tail-var)
+     (list 'progn
+           (list 'setq tail-var (second vars))
+           (list 'while tail-var
+                 (list 'funcall (apply 'list 'lambda (list (first vars)) body)
+                       (list 'head tail-var))
+                 (list 'setq tail-var (list 'tail tail-var)))))
+   (make-symbol "tail")))
+
+(defun maphead (func list)
+  (funcall
+   (lambda (&opt start end)
+     (dolist (elt list)
+       (setq elt (funcall func elt))
+       (if (not start)
+           (setq start (pair elt nil)
+                 end start)
+         (settail end (pair elt nil))
+         (setq end (tail end))))
+     start)))
+
+(defun reverse (list)
+  (funcall
+   (lambda (&opt out)
+     (dolist (elt list)
+       (setq out (pair elt out)))
+     out)))
+
+(defun < (n1 n2)
+  (not (or (> n1 n2) (= n1 n2))))
+
+(defun <= (n1 n2)
+  (not (> n1 n2)))
+
+(defun >= (n1 n2)
+  (or (> n1 n2) (= n1 n2)))
+
+(defmacro let (bindings &rest body)
+  (funcall
+   (lambda (&opt vars vals)
+     (dolist (ent bindings)
+       (if (symbolp ent)
+           (setq vars (pair ent vars)
+                 vals (pair nil vals))
+         (if (and (listp ent) (or (= (list-length ent) 1)
+                                  (= (list-length ent) 2)))
+             (setq vars (pair (first ent) vars)
+                   vals (pair (second ent) vals))
+           (throw 'argument-error))))
+     (apply 'list 'funcall (apply 'list 'lambda (reverse vars) body)
+            (reverse vals)))))
+
+(defun plist-put (plist key value)
+  (let ((tail plist))
+    (while (and tail (tail tail))
+      (if (eq (head tail) key)
+          (sethead (tail tail) value))
+      (setq tail (tail (tail tail))))))
+
+(defun put (symbol key value)
+  (let ((cur (symbol-plist symbol)))
+    ()))
+
+(defun get (symbol key default)
+  ())
+
+(defun lasttail (list)
+  "Return the last pair in LIST."
+  (let (out)
+    (while list
+      (setq out list
+            list (tail list)))
+    out))
+
+(defun internal-expand-single-cond (cond)
+  (if (tail cond)
+      (list 'if (head cond)
+            (apply 'list 'progn (tail cond)))
+    (let ((res-var (make-symbol "res")))
+      (list 'let (list (list res-var (head cond)))
+            (list 'if res-var res-var)))))
+
+(defmacro cond (&rest conds)
+  (let (out last-if)
+    (dolist (cond conds)
+      (if (not out)
+          (setq out (internal-expand-single-cond cond)
+                last-if out)
+        (let ((new-if (internal-expand-single-cond cond)))
+          (settail (lasttail last-if) (list new-if))
+          (setq last-if new-if))))
+    out))
+
+(defmacro tcase (obj &rest conds)
+  (let ((obj-var (make-symbol "obj")))
+    (list 'let (list (list obj-var obj))
+          (pair
+           'cond
+           (maphead
+            (lambda (cond)
+              (let ((pred (pair 'or (maphead
+                                     (lambda (elt)
+                                       (if (eq elt t)
+                                           t
+                                         (list 'eq (list 'type-of obj-var)
+                                               (list '\' elt))))
+                                     (ensure-list (head cond))))))
+                (pair pred (tail cond))))
+            conds)))))
+
+(defun internal-expand-\` (form &opt (level 0))
+  (tcase
+   (())))
+
+(defmacro \` (form)
+  (internal-expand-\` form))
+
+;; (println (macroexpand-1 '`(,@a)))
+
+(defmacro a (form)
+  (list 'b (ensure-list form)))
+
+(defmacro b (form)
+  (list 'c (ensure-list form)))
+
+(defmacro c (form)
+  (list 'd form))
+
+;; (let ((a '(1 2 3)))
+;;   (println `(,a)))