1 (in-package #:portaCL)
 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
15                                    :format-control "Unknown feature test: ~s"
16                                    :format-arguments (list (car feature)))
17                           (treat-as-true ()
18                             :report "Pretend this feature-form were true."
19                             t)
20                           (treat-as-nil ()
21                             :report "Pretend this feature-form were false."
22                             nil)))))
23     (if (consp feature)
24         (apply (gethash (car feature) *feature-tests* no-such-test)
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 
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 ||#