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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
|
;;;; Copyright (c) 2007-2013 Nikodemus Siivola <nikodemus@random-state.net>
;;;; Copyright (c) 2012-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
;;;;
;;;; Permission is hereby granted, free of charge, to any person
;;;; obtaining a copy of this software and associated documentation files
;;;; (the "Software"), to deal in the Software without restriction,
;;;; including without limitation the rights to use, copy, modify, merge,
;;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;;; and to permit persons to whom the Software is furnished to do so,
;;;; subject to the following conditions:
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
(cl:in-package #:esrap)
;;; Miscellany
(defun text (&rest arguments)
"Arguments must be strings, or lists whose leaves are strings.
Catenates all the strings in arguments into a single string."
(with-output-to-string (s)
(labels ((cat-list (list)
(dolist (elt list)
(etypecase elt
(string (write-string elt s))
(character (write-char elt s))
(list (cat-list elt))))))
(cat-list arguments))))
(defun singleton-option (context form keyword type &key default)
(let ((value default)
(value-seen nil))
(lambda (&optional (new-value nil new-value-p))
(cond
((not new-value-p)
value)
((not (typep new-value type))
(error 'simple-type-error
:datum new-value
:expected-type type
:format-control "~@<The value ~S is not a valid ~
argument to the ~S ~S option.~@:>"
:format-arguments (list new-value keyword context)))
(value-seen
(error "~@<Multiple ~S options in ~S form:~@:_~@:_~
~2@T~S.~@:>"
keyword context form))
(t
(setf value-seen t
value new-value))))))
;;; DEFRULE support functions
(defun parse-lambda-list-maybe-containing-&bounds (lambda-list)
"Parse &BOUNDS section in LAMBDA-LIST and return three values:
1. The standard lambda list sublist of LAMBDA-LIST
2. A symbol that should be bound to the start of a matching substring
3. A symbol that should be bound to the end of a matching substring
4. A list containing symbols that were GENSYM'ed.
The second and/or third values are GENSYMS if LAMBDA-LIST contains a
partial or no &BOUNDS section, in which case fourth value contains them
for use with IGNORE."
(let ((length (length lambda-list))
(index (position '&bounds lambda-list)))
(multiple-value-bind (lambda-list start end gensyms)
(cond
;; Look for &BOUNDS START END.
((eql index (- length 3))
(values (subseq lambda-list 0 index)
(nth (+ index 1) lambda-list)
(nth (+ index 2) lambda-list)
'()))
;; Look for &BOUNDS START.
((eql index (- length 2))
(let ((end (gensym "END")))
(values (subseq lambda-list 0 index)
(nth (+ index 1) lambda-list)
end
(list end))))
;; &BOUNDS is present but not followed by either one or two
;; names.
(index
(error "~@<Expected ~S START END or ~:*~S START but got ~:S.~@:>"
'&bounds (subseq lambda-list index)))
;; No &BOUNDS section.
(t
(let ((start (gensym "START"))
(end (gensym "END")))
(values lambda-list
start
end
(list start end)))))
(check-type start symbol)
(check-type end symbol)
(values lambda-list start end gensyms))))
(defun check-lambda-list (lambda-list spec
&key
(report-lambda-list lambda-list))
(multiple-value-bind
(required* optional* rest* keyword* allow-other-keys-p auxp keyp)
(parse-ordinary-lambda-list lambda-list)
(labels ((fail (expected actual)
(let ((expected (ensure-list expected))
(actual (ensure-list actual)))
(error "~@<Expected a lambda-list ~?, but ~:S ~?.~@:>"
(first expected) (rest expected)
report-lambda-list
(first actual) (rest actual))))
(check-section (section expected actual)
(typecase expected
((eql nil)
(when actual
(fail (list "without ~A parameters" section)
(list "has ~A parameters" section))))
((eql t)
(unless actual
(fail (list "with ~A parameters" section)
(list "has no ~A parameters" section))))
(integer
(unless (length= expected actual)
(fail (list "with ~D ~A parameter~:*~:P" expected section)
(list "has ~D ~A parameter~:*~:P"
(length actual) section))))))
(check-binary (name expected actual)
(when (member expected '(t nil))
(unless (eq expected (when actual t))
(fail (list "~:[without~;with~] ~A" expected name)
(list "~:[has no~;has~] ~A" actual name)))))
(check-simple-spec (&key required optional rest
keyword allow-other-keys aux key)
(check-section "required" required required*)
(check-section "optional" optional optional*)
(check-binary '&rest rest rest*)
(check-section "keyword" keyword keyword*)
(check-binary '&allow-other-keys allow-other-keys allow-other-keys-p)
(check-section "aux" aux auxp)
(check-binary '&key key keyp))
(check-spec (spec)
(typecase spec
((cons (eql or))
(loop :with errors = ()
:for sub-spec :in (rest spec)
:do (handler-case
(progn
(check-spec sub-spec)
(return))
(error (condition)
(push condition errors)))
:finally (error "~@<~{~A~^~@:_~}~@:>" errors)))
(list
(apply #'check-simple-spec spec)))))
(check-spec spec))))
(defun parse-defrule-options (options form)
(let ((when (singleton-option 'defrule form :when t :default '(t . t)))
(transform nil)
(around nil)
(error-report (singleton-option 'defrule form :error-report
'rule-error-report :default t))
(use-cache (singleton-option 'defrule form :use-cache
'cache-policy :default :unless-trivial)))
(dolist (option options)
(destructuring-ecase option
((:when expr &rest rest)
(when rest
(error "~@<Multiple expressions in a ~S:~@:_~2@T~S~@:>"
:when form))
(funcall when (cons (cond
((not (constantp expr))
`(lambda () ,expr))
((eval expr)
t))
expr)))
((:constant value)
(declare (ignore value))
(push option transform))
((:text value)
(when value
(push option transform)))
((:identity value)
(when value
(push option transform)))
((:lambda lambda-list &body forms)
(multiple-value-bind (lambda-list* start-var end-var ignore)
(parse-lambda-list-maybe-containing-&bounds lambda-list)
(check-lambda-list lambda-list*
'(or (:required 1) (:optional 1))
:report-lambda-list lambda-list)
(push (list :lambda lambda-list* start-var end-var ignore forms)
transform)))
((:function designator)
(declare (ignore designator))
(push option transform))
((:destructure lambda-list &body forms)
(multiple-value-bind (lambda-list* start-var end-var ignore)
(parse-lambda-list-maybe-containing-&bounds lambda-list)
(push (list :destructure lambda-list* start-var end-var ignore forms)
transform)))
((:around lambda-list &body forms)
(multiple-value-bind (lambda-list* start end ignore)
(parse-lambda-list-maybe-containing-&bounds lambda-list)
(check-lambda-list
lambda-list* '() :report-lambda-list lambda-list)
(setf around `(lambda (,start ,end transform)
(declare (ignore ,@ignore)
(function transform))
(flet ((call-transform ()
(funcall transform)))
,@forms)))))
((:use-cache value)
(funcall use-cache value))
((:error-report behavior)
(funcall error-report behavior))))
(values transform around (funcall when)
(funcall error-report) (funcall use-cache))))
(defun expand-transforms (transforms)
(let ((production-used-p t)
(identityp t)
(constantp nil)
(textp nil))
(labels
((make-transform-body (start end start-var end-var ignore body)
(let* ((start-end-vars (list start-var end-var))
(other-ignore (set-difference ignore start-end-vars)))
(values
`(,@(when other-ignore `((declare (ignore ,@other-ignore))))
,@body)
`(,@(unless (member start-var ignore :test #'eq)
`((,start-var ,start)))
,@(unless (member end-var ignore :test #'eq)
`((,end-var ,end)))))))
(process-option (options start end production)
(destructuring-bind (&optional option &rest rest) options
(unless option
(return-from process-option production))
(destructuring-ecase option
((:constant value)
(setf production-used-p nil identityp nil constantp t)
(process-option rest start end value))
((:identity value)
(declare (ignore value))
(process-option rest start end production))
((:text value)
(setf textp (and value identityp)
identityp nil)
(process-option rest start end `(text ,production)))
((:function designator) ; TODO resolve-function?
(setf identityp nil constantp nil)
(process-option rest start end `(,designator ,production)))
((:lambda lambda-list start-var end-var ignore forms)
(setf identityp nil constantp nil)
(multiple-value-bind (body bindings)
(make-transform-body
start end start-var end-var ignore forms)
(process-option
rest start end
`((lambda (,@lambda-list &aux ,@bindings)
,@body)
,production))))
((:destructure lambda-list start-var end-var ignore forms)
(setf identityp nil constantp nil)
(multiple-value-bind (body bindings)
(make-transform-body
start end start-var end-var ignore forms)
(process-option
rest start end
`(destructuring-bind (,@lambda-list &aux ,@bindings)
,production
,@body))))))))
(with-gensyms (production start end)
(let ((form (process-option (reverse transforms) start end production)))
(values
`(lambda (,production ,start ,end)
(declare ,@(unless production-used-p `((ignore ,production)))
(ignorable ,start ,end))
,form)
identityp
constantp
textp))))))
|
