1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
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)))
|
