From 66ca9f2d15eb65b3a576abae5fc137c342f14a93 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Fri, 19 Apr 2024 10:33:20 -0700
Subject: added :slots=

---
 obwyn.asd  |  13 +++++++
 obwyn.lisp | 125 +++++++++++++++++++++++++++++++++++++++----------------------
 2 files changed, 93 insertions(+), 45 deletions(-)
 create mode 100644 obwyn.asd

diff --git a/obwyn.asd b/obwyn.asd
new file mode 100644
index 0000000..1aa0693
--- /dev/null
+++ b/obwyn.asd
@@ -0,0 +1,13 @@
+;;;; obwyn.asd
+
+(asdf:defsystem #:obwyn
+  :description "Only Bind When You Need"
+  :author "Colin <colin@cicadas.surf>"
+  :license  "Unlicense"
+  :version "0.0.1"
+  :serial t
+  :depends-on (#:argot #:alexandria #:testiere)
+  :components ((:file "obwyn")))
+
+
+
diff --git a/obwyn.lisp b/obwyn.lisp
index 2fddfca..e9f8c33 100644
--- a/obwyn.lisp
+++ b/obwyn.lisp
@@ -6,6 +6,9 @@
 
 (in-package :obwyn)
 
+(defun variablep (thing)
+  (and (symbolp thing) (not (keywordp thing))))
+
 (defun values-binding-p (form)
   #+testiere
   (:tests
@@ -38,48 +41,68 @@
           (declare (ignorable required optional rest kwargs keyp))
           (not (or allow-other aux))))))
 
+(defun slot-value-list-p (form)
+  #+testiere
+  (:tests
+   (:is (slot-value-list-p '(a b c)))
+   (:is (slot-value-list-p '((a slot-a))))
+   (:is (slot-value-list-p '()))
+   (:is (not (slot-value-list-p '(1 2))))
+   (:is (not (slot-value-list-p '(:x)))))
+  (and (listp form)
+       (loop :for thing :in form
+             :always (or (variablep thing)
+                         (and (listp thing)
+                              (= 2 (length thing))
+                              (variablep (first thing))
+                              (variablep (second thing)))))))
+
+
+
 (defun expand-clauses (clauses)
-  (loop :with expanded := nil
-        :for (tag bindings form) :in (nreverse clauses)
-        :do
-           (setf expanded 
-                 (ecase tag
-                   (:simple
-                    (cond ((null expanded) form)
-                          ((eq 'cl:progn (first expanded))
-                           `(progn ,form ,@(rest expanded)))
-                          (t
-                           `(progn ,form ,expanded))))
-
-                   (:when
-                    (cond ((null expanded) form)
-                          ((eq 'cl:progn (first expanded))
-                           `(when ,form ,@(rest expanded)))
-                          (t
-                           `(when ,form ,expanded))))
-
-                   (:mvbind
-                    `(multiple-value-bind
-                           ,(if (listp bindings) bindings (list bindings))
-                         ,form
-                       ,@(if (and (listp expanded) (eq 'cl:progn (first expanded)))
-                             (rest expanded)
-                             (list expanded))))
-                   (:bindif
-                    `(a:when-let (,bindings ,form) 
-                       ,@(if (and (listp expanded) (eq 'cl:progn (first expanded)))
-                             (rest expanded)
-                             (list expanded))))
-                   
-                   (:dsbind
-                    `(destructuring-bind ,bindings ,form
-                       ,@(if (and (listp expanded) (eq 'cl:progn (first expanded))) 
-                             (rest expanded)
-                             (list expanded))))))
-        :finally (return
-                   (if (and (listp expanded) (eq 'cl:progn (first expanded)))
-                       `(block nil ,@(rest expanded))
-                       `(block nil ,expanded)))))
+  (flet ((collapse-progn (expanded)
+           (if (and (listp expanded) (eq 'cl:progn (first expanded)))
+               (rest expanded)
+               (list expanded)))) 
+    (loop :with expanded := nil
+          :for (tag bindings form) :in (nreverse clauses)
+          :do
+             (setf expanded 
+                   (ecase tag
+                     (:simple
+                      (cond ((null expanded) form)
+                            ((eq 'cl:progn (first expanded))
+                             `(progn ,form ,@(rest expanded)))
+                            (t
+                             `(progn ,form ,expanded))))
+
+                     (:when
+                         (cond ((null expanded) form)
+                               ((eq 'cl:progn (first expanded))
+                                `(when ,form ,@(rest expanded)))
+                               (t
+                                `(when ,form ,expanded))))
+
+                     (:=
+                      `(multiple-value-bind
+                             ,(if (listp bindings) bindings (list bindings))
+                           ,form
+                         ,@(collapse-progn expanded)))
+                     (:when=
+                      `(a:when-let (,bindings ,form) 
+                         ,@(collapse-progn expanded)))
+
+                     (:slots=
+                      `(with-slots ,bindings ,form
+                         ,@(collapse-progn expanded)))
+                     
+                     (:match=
+                      `(destructuring-bind ,bindings ,form
+                         ,@(collapse-progn expanded)))))
+          :finally (return
+                     (if (and (listp expanded) (eq 'cl:progn (first expanded)))
+                         `(block nil ,@(rest expanded))
+                         `(block nil ,expanded))))))
 
 
 (defun literals-equal (a b)
@@ -93,6 +116,7 @@
   (<clause>
    :match (:or <binding-clause>
                <destructuring-clause>
+               <with-slots-clause>
                <predicate-binding-clause>
                <predicate-clause>
                <simple-clause>)) 
@@ -101,12 +125,12 @@
    :match (:seq <values-bind> (:= :=) (:item))
    :then (destructuring-bind (bindings _ form) <binding-clause>
            (declare (ignore _))
-           (list :mvbind bindings form)))
+           (list := bindings form)))
 
   (<predicate-binding-clause>
    :match (:seq (:@ var (:item)) (:= :when=) (:@ form (:item)))
    :if (and (symbolp var) (not (keywordp var)))
-   :then (list :bindif var form)
+   :then (list :when= var form)
    :note "Bind variable to form, exit early if form evaluated to nil.")
   
   (<values-bind>
@@ -118,15 +142,26 @@
    :match (:seq <destructuring-list> (:= :match=) (:item))
    :then (destructuring-bind (bindings _ form) <destructuring-clause>
            (declare (ignore _))
-           (list :dsbind bindings form)))
+           (list :match= bindings form)))
 
   (<destructuring-list>
    :match (:item)
    :if destructuring-bind-list-p
    :note "An list that might be passed as the first argument to DESTRUCTURING-BIND.")  
 
+  (<with-slots-clause>
+   :match (:seq <slot-value-list> (:= :slots=) (:item))
+   :then (destructuring-bind (bindings _ form) <with-slots-clause>
+           (declare (ignore _))
+           (list :slots= bindings form)))
+
+  (<slot-value-list>
+   :match (:item)
+   :if slot-value-list-p
+   :note "A list that is suitable for passing to with-slots.")
+
   (<predicate-clause>
-   :match (:seq (:or= :when :?) (:item))
+   :match (:seq (:= :when) (:item))
    :then (list :when nil (second <predicate-clause>)))
   
   (<simple-clause>
-- 
cgit v1.2.3