-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathetc.lisp
473 lines (419 loc) · 17.1 KB
/
etc.lisp
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
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
;;; Copyright 2020 Google LLC
;;;
;;; Use of this source code is governed by an MIT-style
;;; license that can be found in the LICENSE file or at
;;; https://opensource.org/licenses/MIT.
;;; Provides common macros and functions that do not have a dedicated package.
;;;
(defpackage #:ace.core.etc
(:use #:common-lisp
#:ace.core
#:ace.core.macro
#:ace.core.once-only)
(:import-from #:ace.core.type #:variable-information)
(:export
#:one-of
#:orf #:andf
#:define-constant
#:define-numerals
#:defglobal* #:defglobal!
#:clet
#:reader-value-bind
#:with-readers))
(in-package #:ace.core.etc)
(defmacro define-constant (name value &key (test '#'equal) documentation)
"Defines a constant NAME with the VALUE.
When the constant NAME is redefined, the TEST predicate is used to compare
the new VALUE with the previous one for changes. An error is signaled
if the TEST does not return true for both values.
Unlike DEFCONSTANT, this allows to define constants using different
equality predicates than EQL. This allows lists and other objects
to be regarded as constants.
Parameters:
NAME - the name of the new constant.
VALUE - the value for the constant.
TEST - test predicate function to compare the old and new values
in case the constant is redefined. Default is #'EQUAL.
DOCUMENTATION - attaches a documentation string the constant name.
Example:
(define-constant +fields+ '(a b c)
:test #'equalp :documentation 'Fields used in...')
Related:
cl:defconstant
alexandria:define-constant
qpx:defconstant-*
sb-int:defconstant-eqx"
;; This one does not warn twice on a changed value.
;; Also, it sets the constant value to the NEW value when TEST passes.
`(defconstant ,name (%set-constant-value ',name ,value ,test) ; NOLINT
,@(when documentation (list documentation))))
(defvar *constant-name* nil "Used to pass constant name to functions.")
(defun %set-constant-value (name value &optional (test #'eql) (env (lexenv)))
;; This functions tries to circumvent some compiler checks
;; in order to extend the definition of a constant wrt. TEST predicate.
;; TODO(czak): Add support for more than SBCL, CLISP, or ECL.
(let ((*constant-name* name))
(cond
((not (boundp name)))
((not (constantp name env))
;; Maybe warn about changing a non-constant symbol
;; for the implementations that would not.
)
((or (null test) (funcall test (symbol-value name) value))
;; Assure that if it passes the test, the constant has the value.
;; This reduces the number of complaints from the compiler.
#-(or clisp)
(ignore-errors
(handler-bind ((warning #'muffle-warning)
(error #'continue))
;; The CL standard defines this as undefined behavior
;; if the symbol is a constant. E.g. SBCL will signal an error.
(set name value)))
;; CLISP needs to call an internal function.
#+clisp (sys::%proclaim-constant name value))
(t
;; ECL would happily assign any value.
;; So, warn the user that the constant value changed.
#+(or ecl)
(warn "New value ~A for constant ~S unequal to the old ~A" ; NOLINT
value name (symbol-value name)))))
value)
#+sbcl
(defmacro defglobal* (name init-form &optional doc)
"Defines a global variable that is always bound and cannot be proclaimed special.
The INIT-FORM is evaluated at load/execute time.
Arguments:
NAME - the symbol for the global variable.
INIT-FORM - used to initialize the variable.
DOC - documentation.
Related:
sb-ext:defglobal"
`(#+sbcl sb-ext:define-load-time-global
#-sbcl defvar
,name ,init-form ,@(when doc `(,doc))))
(defmacro defglobal! (name init-form &optional doc)
"Defines a global variable that is always bound and cannot be proclaimed special.
The INIT-FORM is evaluated at compile and load/execute time.
Arguments:
NAME - the symbol for the global variable.
INIT-FORM - used to initialize the variable.
DOC - documentation.
Related:
sb-ext:defglobal"
#+sbcl
`(sb-ext:defglobal ,name ,init-form ,@(when doc `(,doc)))
#-sbcl
`(eval-always (defvar ,name ,init-form ,@(when doc `(,doc)))))
(defun %numeral-eq (old new)
"Returns always true even if OLD and NEW values differ."
(or (eql old new)
(warn "Numeral~@[ '~S'~] redefined (~D -> ~D)." *constant-name* old new) ; NOLINT
t))
(defmacro define-numerals (&rest names)
"Defines constants using NAMES assigning them numbers starting at 0."
`(progn
,@(loop :for (n . rest) :on names
:for o :from 0
:do (when (find n rest :test #'eq)
(warn "Numeral '~S' found twice in the list of names." n)) ; NOLINT
:collect
`(defconstant ,n (%set-constant-value ',n ,o #'%numeral-eq)))))
;;;
;;; one-of shortcut
(defmacro one-of (e &rest members)
"True if element E compares EQL with at least one of the MEMBERS."
(once-only (e)
`(or ,@(lmap (m members) `(eql ,e ,m)))))
;;;
;;; SETF forms for OR and AND.
;;; TODO(czak): Move to an own module.
;;;
(defmacro orf (place &rest rest &environment env)
"The ORF modifying macro has a similar short-cut semantics as OR.
It will return the first set of values that starts with non-NIL one
from the list taken from the PLACE and the REST of arguments.
E.g.
(let ((a 2))
(orf a 3 4))
=>
2
;; 'a' retains its value.
(let (a)
(orf a 3 4))
=>
3
;; 'a' is set to 3.
(let ((a 1) (b 2) (c nil))
(orf (values a b c) (values 4 5 6)))
=>
1
2
NIL
;; a, b, and c retain their values.
The behavior of ORF for setting a multiple-value PLACE is similar to
that of the SETF operator. It always returns the set of values for the PLACE.
E.g.:
(let ((a nil) (b 2) (c 3))
(orf (values a b c) (values 4 5 6 7)))
=>
4
5
6
;; a, b, and c are set to 4, 5, and 6 respectively.
(let ((a nil) (b 2) (c 3))
(orf (values a b c) (values 4 5)))
=>
4
5
NIL
;; a, b, and c are set to 4, 5, and NIL respectively.
This behavior is different from OR, where only the multiple-values
for the last sub-form are returned, and the first value only otherwise.
In addition if the first value of PLACE is NIL,
it will be set to the values returned by the first sub-form
for which the first value is non-NIL.
If none of the sub-forms return non-NIL as the first value
and the PLACE consists of multiple-values,
then the PLACE will be set to the values returned by the last sub-form.
This is different from a potential DEFINE-MODIFY-MACRO operator which
would always set the place even in the case where its first value is non-NIL."
(multiple-value-bind (vars vals places setter getter)
(get-setf-expansion place env)
`(let* (,@(mapcar #'list vars vals)
,@places)
,(if (cdr places)
;; multiple value places
(let ((store-vars `(values ,@places)))
`(cond ((setf ,store-vars ,getter)
,store-vars)
(t
(or ,@(lmap (form rest) `(setf ,store-vars ,form)))
,setter)))
;; single value place
`(or ,getter
(progn
(setf ,(car places) (or ,@rest))
,setter))))))
(defmacro andf (place &rest rest &environment env)
"The ANDF modifying macro has a similar short-cut semantics as AND.
It will return the first set of values that starts with NIL from the list
generated by the PLACE and the REST of arguments.
E.g.
(let ((a 1))
(andf a 3 4))
=>
4
;; 'a' retains its value.
(let ((a 1))
(andf a 3 4 nil))
=>
nil
;; 'a' is set to NIL.
(let ((a nil) (b 2) (c 3))
(andf (values a b c) (values 4 5 6)))
=>
NIL
2
3
;; a, b, and c retain their values.
The behavior of ANDF for setting a multiple-value PLACE is similar to
that of the SETF operator. It always returns the set of values for the PLACE.
E.g.:
(let ((a 1) (b 2) (c nil))
(andf (values a b c) (values nil 5 6 7)))
=>
NIL
5
6
;; a, b, and c are set to NIL, 5, and 6 respectively.
(let ((a 1) (b 2) (c nil))
(andf (values a b c) (values nil 5)))
=>
NIL
5
NIL
;; a, b, and c are set to NIL, 5, and NIL respectively.
This behavior is different from AND, where only the multiple-values
for the last sub-form are returned, and the first value only otherwise.
In addition, if the first value of PLACE is non-NIL,
it will be set to the values returned by the first sub-form
for which the first value is NIL. If none of the sub-forms return NIL
as the first value, then the PLACE will be set to the values
returned by the last sub-form.
This is different from a potential DEFINE-MODIFY-MACRO operator which
would always set the place even in the case where its first value is NIL."
(multiple-value-bind (vars vals places setter getter)
(get-setf-expansion place env)
(let* ((place (if (cdr places) `(values ,@places) (car places)))
(setfs (lmap (form rest) `(setf ,place ,form))))
`(let* (,@(mapcar #'list vars vals)
,@places)
(cond ((setf ,place ,getter)
(and ,@setfs)
,setter)
(t
,place))))))
;;;
;;; Variation on LET.
;;;
(defmacro clet ((&rest clauses) &body body)
"Binds variables defined in CLAUSES and when one is NIL, it stops.
CLAUSES have the form (VARS . FORMS).
The last form of the FORMS is the INIT-FORM providing values for the bindings.
Each clause creates a binding in succession similar to LET*.
The FORMS of later clauses can thus refer to previous bindings.
Example:
(CLET ((sum (and a b (+ a b)))
(c (format t \"SUM: ~A~%\" sum)
(unless (zerop sum)
(/ (- a b) sum))))
;; Evaluates the body only if A and B are non-NIL
;; and when the SUM is non-zero.
;; Second clause will output the SUM unless A or B is NIL.
...)
VARS can be a symbol. In this case the first value is assigned and checked.
If this value is NIL, the clause fails and the whole CLET form returns NIL.
VARS can be a list of symbols. In this case the values returned by
the INIT-FORM are used to bind to the VARS. If all the bound values are NIL,
the clause fails and CLET returns NIL.
Example:
(CLET ((key (make-key x y z))
((value have) (gethash key table)))
;; Evaluates the body when KEY is non-NIL
;; and when either the VALUE or HAVE binding is non-NIL.
...)
Thus CLET has an implicit AND-OR schema,
with clauses in an AND-relation, and with the values of
multiple-value binding clauses in an OR-relation.
If a clause is just a variable name - i.e. not a CONS -
then the variable is bound to NIL and the evaluation continues.
"
(unless clauses
(return-from clet `(locally ,@body)))
(let ((block (gensym* :block))
bindings ignored)
(dolist (clause clauses)
(etypecase clause
(cons
(destructuring-bind (vars &rest init) clause
(setf init (if (cdr init) `(progn ,@init) (car init)))
(etypecase vars
(atom
(push `(,vars (or ,init (return-from ,block))) bindings))
((cons t null)
(push `(,(car vars) (or ,init (return-from ,block))) bindings))
((cons t cons)
(let (syms)
(dolist (v vars)
(let ((g (gensym* v)))
(push g syms)
(push g bindings)))
(setf syms (nreverse syms))
(push `(,(car vars) (multiple-value-setq ,syms ,init))
bindings)
(push `(,(car syms) (or ,@syms (return-from ,block))) bindings)
(push (car syms) ignored)
(loop :for s :in (rest syms)
:for v :in (rest vars)
:do (push `(,v ,s) bindings)))))))
(atom
(push clause bindings))))
`(block ,block
(let* ,(nreverse bindings)
,@(and ignored `((declare (ignore ,@ignored))))
,@body))))
;;;
;;; Accessor macros for structured objects.
;;;
(defun! parse-object-spec (object-spec &optional environment)
"Parses the OBJECT-SPEC for the type of object given the lexical ENVIRONMENT.
Returns TYPE and OBJECT or signals an error when the type is not found or is not a symbol."
(cond ((and (consp object-spec)
(eq (first object-spec) 'the)
(second object-spec)
(third object-spec))
(values (second object-spec) (third object-spec)))
((symbolp object-spec)
(multiple-value-bind (binding local info) (variable-information object-spec environment)
(declare (ignore local))
(unless (member binding '(:special :lexical :constant))
(error "Cannot derive the type for: ~S." object-spec))
(let ((type (cdr (assoc 'type info))))
(when (and (typep type '(cons symbol list)) (eq (first type) 'or))
(let ((%types (remove 'null (rest type))))
(when (= 1 (length %types))
(setf type (first %types)))))
(unless (and type (symbolp type) (symbol-package type))
(error "Cannot derive the type for: ~S." object-spec))
(values type object-spec))))
(t
(error "Cannot derive the type for: ~S." object-spec))))
(defun! parse-slot-spec (slot-spec object-type)
"Parses a SLOT-SPEC for a slot in OBJECT-TYPE.
Returns a VARIABLE name and ACCESSOR symbol or signals an error if the symbol is not accessible."
(let* ((variable (if (consp slot-spec) (first slot-spec) slot-spec))
(slot (if (consp slot-spec) (second slot-spec) slot-spec))
(package (symbol-package object-type))
(accessor-name (format nil "~A-~A" object-type slot)))
(multiple-value-bind (accessor status) (find-symbol accessor-name package)
(ecase status
((nil)
(error "Could not find symbol ~S in: ~S." accessor-name (package-name package)))
((:internal :inherited)
(unless (eq slot (find-symbol (symbol-name slot) package))
(error "The symbol ~S is not external in: ~S." accessor-name (package-name package))))
(:external))
(values variable accessor))))
(defmacro reader-value-bind (&environment env (&rest slots) object-spec &body body)
"Executes the BODY in a lexical environment where the names of SLOTS have been
bound to values read by readers from an OBJECT of a TYPE specified in OBJECT-SPEC.
The OBJECT-SPEC can have the form (the TYPE OBJECT) to explicitly specify the type of object.
If OBJECT-SPEC has no (the TYPE OBJECT) form, the OBJECT for equals the OBJECT-SPEC form and
the lexical environment is consulted to derive the type of the OBJECT.
The readers are found using the TYPE-SLOT name.
It is an error if the reader is not an accessible symbol in the current package.
Compared to WITH-READERS this macro will bind all the variables to the values returned
by the readers. Those bindings can than be modified like normal lexical bindings.
All the readers are called exactly once when using this form.
See also: WITH-READERS, WITH-ACCESSORS."
(if slots
(multiple-value-bind (type object) (parse-object-spec object-spec env)
(assert (and type (symbolp type) (symbol-package type)))
(let (bindings)
(once-only (object)
(dolist (slot-spec slots)
(multiple-value-bind (variable reader) (parse-slot-spec slot-spec type)
(push `(,variable (,reader ,object)) bindings)))
`(let (,@(nreverse bindings))
,@body))))
body))
(defmacro with-readers (&environment env (&rest slots) object-spec &body body)
"Executes the BODY in a lexical environment where the names of SLOTS are a symbol-macrolet
to local functions that call the corresponding readers on the OBJECT of a TYPE that
specified by the OBJECT-SPEC. The OBJECT-SPEC can have the form (the TYPE OBJECT)
to explicitly specify the type of object. If OBJECT-SPEC has no (the TYPE OBJECT) form,
the OBJECT form equals the OBJECT-SPEC form and the lexical environment is consulted
to derive the type of the OBJECT.
The reader names are created using <TYPE>-<SLOT> pattern.
The SLOTS may have two patterns: SLOT and (VARIABLE SLOT).
It is an error if the reader is not an accessible symbol in the current package.
Compared to READER-VALUE-BIND using this macro the readers are only called at the
place when the corresponding symbols are accessed. The readers can be called multiple times
or not at all when using this form.
See also: READER-VALUE-BIND, WITH-ACCESSORS"
(if slots
(multiple-value-bind (type object) (parse-object-spec object-spec env)
(assert (and type (symbolp type) (symbol-package type)))
(let* ((bindings '())
(macros '()))
(once-only (object)
(dolist (slot-spec slots)
(multiple-value-bind (variable reader) (parse-slot-spec slot-spec type)
#-opt (push `(,reader (*) (,reader *)) bindings)
(push `(,variable (,reader ,object)) macros)))
(setf bindings (nreverse bindings))
`(flet (,@bindings)
,@(when bindings `((declare (inline ,@(mapcar #'first bindings)))))
(symbol-macrolet ,(nreverse macros)
,@body)))))
body))