repos
/
portaCL
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Better reporting of undefined-feature-tests.
Annotate for file /feature-tests.lisp
2009-07-17 pix
1
(in-package #:portaCL)
05:24:52 '
2
'
3
(defvar *feature-tests* (make-hash-table :test #'eq))
'
4
'
5
(define-condition undefined-feature-test (simple-error) ())
'
6
'
7
(defun featurep (feature)
'
8
"Returns true if the feature is in *features*, or it is a feature
'
9
expression which is true. Signals 'undefined-feature-test if the feature
'
10
test is not recognized."
'
11
(let ((no-such-test (lambda (&rest _)
'
12
(declare (ignore _))
'
13
(restart-case
'
14
(error 'undefined-feature-test
2009-07-20 pix
15
:format-control "Unknown feature test: ~s"
01:09:25 '
16
:format-arguments (list (car feature)))
2009-07-17 pix
17
(treat-as-true ()
05:24:52 '
18
:report "Pretend this feature-form were true."
'
19
t)
'
20
(treat-as-nil ()
'
21
:report "Pretend this feature-form were false."
'
22
nil)))))
2009-07-19 pix
23
(if (consp feature)
2009-07-17 pix
24
(apply (gethash (car feature) *feature-tests* no-such-test)
05:24:52 '
25
(cdr feature))
'
26
(member feature *features* :test #'eq))))
'
27
'
28
(defmacro define-feature-test (names lambda-list &body body)
'
29
"Defines a feature test. E.g., like the standard AND, OR, and NOT.
'
30
'
31
The features provided /may/ be feature expressions, but it is left up to
'
32
individual feature-test implementors to decide if such things make sense.
'
33
In other words, feature-tests are FEXPRs, not macros or functions."
'
34
(when (stringp (first body)) (pop body))
'
35
(unless (listp names) (setf names (list names)))
'
36
(let ((lambda `(lambda ,lambda-list ,@body)))
'
37
`(eval-when (:load-toplevel :execute)
'
38
,@(loop :for name :in names
'
39
:collect `(setf (gethash ',name *feature-tests*) ,lambda)))))
'
40
'
41
^L
'
42
'
43
(define-feature-test (and :and) (&rest rest)
'
44
"The standard AND feature test."
'
45
(every #'featurep rest))
'
46
'
47
(define-feature-test (or :or) (&rest rest)
'
48
"The standard OR feature test."
'
49
(some #'featurep rest))
'
50
'
51
(define-feature-test (not :not) (feature)
'
52
"The standard NOT feature test."
'
53
(not (featurep feature)))
'
54
'
55
#||
'
56
'
57
Examples:
'
58
'
59
(define-feature-test (never :never) ()
'
60
"What #+nil often gets used for."
'
61
nil)
'
62
'
63
(define-feature-test (fixme :fixme) (&rest references)
'
64
"Mark some code as to-be-fixed."
'
65
(declare (ignore references))
'
66
nil)
'
67
'
68
(define-feature-test (bug) (&rest bug-ids)
'
69
"Sometimes you can work around a bug if you know about it."
'
70
(some #'check-bug-applies bug-ids))
'
71
'
72
||#