initial commit

1 files changed, 109 insertions, 0 deletions

diff --git a/obwyn.lisp b/obwyn.lisp
new file mode 100644
index 0000000..db2f778
--- /dev/null
+++ b/obwyn.lisp
@@ -0,0 +1,109 @@
+(defpackage #:obwyn
+  (:use #:cl)
+  (:local-nicknames
+   (#:a #:alexandria-2)))
+
+(in-package :obwyn)
+
+(defun values-binding-p (form)
+  #+testiere
+  (:tests
+   (:is (values-binding-p 'a))
+   (:is (values-binding-p '(a b)))
+   (:is (values-binding-p '()))
+   (:is (not (values-binding-p :x)))
+   (:is (not (values-binding-p '(a b 4))))
+   (:is (not (values-binding-p '(a :b 4)))))
+  (or (and (symbolp form)
+           (not (keywordp form)))
+      (and (listp form)
+           (every (a:conjoin #'symbolp (complement #'keywordp)) form))))
+
+(defun destructuring-bind-list-p (form)
+  #+testiere
+  (:tests
+   (:is (destructuring-bind-list-p '()))
+   (:is (destructuring-bind-list-p '(a b)))
+   (:is (destructuring-bind-list-p '(a &rest b)))
+   (:is (destructuring-bind-list-p '(a &rest b &key (x 10) y)))
+   (:is (destructuring-bind-list-p '(&optional a b)))
+   (:is (not (destructuring-bind-list-p 'x)))
+   (:is (not (destructuring-bind-list-p '(&rest x &optional y))))
+   (:is (not (destructuring-bind-list-p '(&rest 10 &optional y)))))
+  (and (listp form)
+       (ignore-errors
+        (multiple-value-bind (required optional rest kwargs allow-other aux keyp)
+            (alexandria:parse-ordinary-lambda-list form)
+          (declare (ignorable required optional rest kwargs keyp))
+          (not (or allow-other aux))))))
+
+(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))))
+                   (:multiple-value-bind
+                         `(multiple-value-bind
+                                ,(if (listp bindings) bindings (list bindings))
+                              ,form
+                            ,@(if (and (listp expanded) (eq 'cl:progn (first expanded)))
+                                  (rest expanded)
+                                  (list expanded))))
+                   (:destructuring-bind
+                       `(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)))))
+
+
+(defun literals-equal (a b)
+  (and (symbolp a) (symbolp b) (string-equal a b)))
+
+(argot:deflanguage >>> (:literals= #'literals-equal)
+  (<start>
+   :match (:seq (:* <clause>) (:eof))
+   :then (expand-clauses (first <start>)))
+  
+  (<clause>
+   :match (:or <binding-clause>
+               <destructuring-clause>
+               <simple-clause>)) 
+  
+  (<binding-clause>
+   :match (:seq <values-bind> (:= :<-) (:item))
+   :then (destructuring-bind (bindings _ form) <binding-clause>
+           (declare (ignore _))
+           (list :multiple-value-bind bindings form)))
+
+  (<values-bind>
+   :match (:item)
+   :if values-binding-p
+   :note "Either a symbol or a list suitable for passing to MULTIPLE-VALUE-BIND")
+
+  (<destructuring-clause>
+   :match (:seq <destructuring-list> (:= :<~) (:item))
+   :then (destructuring-bind (bindings _ form) <destructuring-clause>
+           (declare (ignore _))
+           (list :destructuring-bind 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.")  
+  
+  (<simple-clause>
+   :match (:@ simple (:item))
+   :if (not (member simple '(:<~ :<-)))
+   :then (list :simple nil simple)))
+