diff options
Diffstat (limited to 'obwyn.lisp')
-rw-r--r-- | obwyn.lisp | 168 |
1 files changed, 0 insertions, 168 deletions
diff --git a/obwyn.lisp b/obwyn.lisp deleted file mode 100644 index 70a1772..0000000 --- a/obwyn.lisp +++ /dev/null @@ -1,168 +0,0 @@ -(defpackage #:obwyn - (:use #:cl) - (:local-nicknames - (#:a #:alexandria-2)) - (:export #:do>)) - -(in-package :obwyn) - -(defun variablep (thing) - (and (symbolp thing) (not (keywordp thing)))) - -(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 (variablep form) - (and (listp form) - (every #'variablep 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 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) - (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) - (and (symbolp a) (symbolp b) (string-equal a b))) - -(argot:deflanguage do> (:literals= #'literals-equal) - (<start> - :match (:seq (:* <clause>) (:eof)) - :then (expand-clauses (first <start>))) - - (<clause> - :match (:or <binding-clause> - <destructuring-clause> - <with-slots-clause> - <predicate-binding-clause> - <predicate-clause> - <simple-clause>)) - - (<binding-clause> - :match (:seq <values-bind> (:= :=) (:item)) - :then (destructuring-bind (bindings _ form) <binding-clause> - (declare (ignore _)) - (list := 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> (:= :match=) (:item)) - :then (destructuring-bind (bindings _ form) <destructuring-clause> - (declare (ignore _)) - (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-binding-clause> - :match (:seq (:@ var (:item)) (:= :when=) (:@ form (:item))) - :if (variablep var) - :then (list :when= var form) - :note "Bind variable to form, exit early if form evaluated to nil.") - - (<predicate-clause> - :match (:seq (:= :when) (:item)) - :then (list :when nil (second <predicate-clause>))) - - (<simple-clause> - :match (:@ simple (:item)) - :if (not (member simple '(:when= :match= :when := :slots=) :test #'literals-equal)) - :then (list :simple nil simple))) - |