1 files changed, 84 insertions, 0 deletions
diff --git a/src/util.lisp b/src/util.lisp
new file mode 100644
index 0000000..5899b36
--- /dev/null
+++ b/src/util.lisp
@@ -0,0 +1,84 @@
+(defpackage #:sarcasm.util
+  (:use #:cl)
+  (:export
+   #:take-until
+   #:def/class))
+
+(in-package #:sarcasm.util)
+
+(defun take-until (pred list)
+  "Returns two values: FRONT BACK.
+
+FRONT contains the first N members X of LIST for which (PRED X) is NIL.
+BACK contains everything after the members of FRONT.
+
+(EQUALP LIST
+       (MULTIPLE-VALUE-BIND (FRONT BACK) (TAKE-UNTIL PRED LIST)
+           (APPEND FRONT BACK))
+
+Is always T."
+  (loop :for (x . back) :on list
+        :for fx? := (funcall pred x)
+        :until fx?
+        :collect x :into front
+        :finally (return (values front (if fx? (cons x back) nil)))))
+
+(defun partition (pred list)
+  "Returns two list values: YES NO.
+
+YES is everything for which PRED is T, NO is everything else."
+  (loop :for e :in list
+        :when (funcall pred e)
+          :collect e :into yes
+        :else
+          :collect e :into no
+        :finally (return (values yes no))))
+
+(defmacro def/class (name (&rest supers) &body slots-and-options)
+  "Define a class. 
+
+SLOTS-AND-OPTIONS := (SLOT-SPEC1 ... SLOT-SPECN . CLASS-OPTIONS)
+
+Each SLOT-SPEC is a list of slot names followed by keyword slot
+options, E.g:
+
+(X Y Z :type integer :initarg 0)
+
+Would expand into three slot definitions 
+(X :accessor X :initarg :X :type integer :initarg 0)
+(Y :accessor Y :initarg :Y :type integer :initarg 0)
+(Z :accessor Z :initarg :Z :type integer :initarg 0)
+
+CLASS-OPTIONS is a PLIST of class options."
+  (labels
+      ((make-accessor-name (slot &optional prefix?)
+         (if prefix?
+             (intern (format nil "~a-~a" name slot))
+             slot))
+       (singlep (x)
+         (find x '(:prefix) :test #'eq))
+       (parse-slot-spec-expr (expr)
+         " (names ... &key kwargs)"
+         (multiple-value-bind (slot-names kwargs) (take-until #'keywordp expr)
+           (multiple-value-bind (kwargs singles) (partition #'singlep kwargs)
+             (loop
+               :with prefix-accessor? := (find ':prefix singles :test #'eq)
+               :for slot :in slot-names
+               :collect `(,slot
+                          :accessor ,(make-accessor-name slot prefix-accessor?)
+                          :initarg ,(alexandria:make-keyword slot)
+                          ,@kwargs)))))
+
+       (parse-class-options (kwargs)
+         (loop :for (key val . more) :on kwargs :by #'cddr
+               :collect (list key val))))
+
+    (let* ((slot-defs (loop :for expr :in slots-and-options
+                            :while (listp expr)
+                            :append (parse-slot-spec-expr expr)))
+           (options (parse-class-options
+                     (nth-value 1 (take-until #'keywordp slots-and-options)))))
+
+      `(defclass ,name ,supers
+         (,@slot-defs)
+         ,@options))))