(in-package #:portaCL)

(defvar *feature-tests* (make-hash-table :test #'eq))

(define-condition undefined-feature-test (simple-error) ())

(defun featurep (feature)
  "Returns true if the feature is in *features*, or it is a feature
expression which is true.  Signals 'undefined-feature-test if the feature
test is not recognized."
  (let ((no-such-test (lambda (&rest _)
                        (declare (ignore _))
                        (restart-case
                            (error 'undefined-feature-test
                                   :format-control "Unknown feature test: ~s"
                                   :format-arguments (list (car feature)))
                          (treat-as-true ()
                            :report "Pretend this feature-form were true."
                            t)
                          (treat-as-nil ()
                            :report "Pretend this feature-form were false."
                            nil)))))
    (if (consp feature)
        (apply (gethash (car feature) *feature-tests* no-such-test)
               (cdr feature))
        (member feature *features* :test #'eq))))

(defmacro define-feature-test (names lambda-list &body body)
  "Defines a feature test.  E.g., like the standard AND, OR, and NOT.

The features provided /may/ be feature expressions, but it is left up to
individual feature-test implementors to decide if such things make sense.
In other words, feature-tests are FEXPRs, not macros or functions."
  (when (stringp (first body)) (pop body))
  (unless (listp names) (setf names (list names)))
  (let ((lambda `(lambda ,lambda-list ,@body)))
    `(eval-when (:load-toplevel :execute)
       ,@(loop :for name :in names
               :collect `(setf (gethash ',name *feature-tests*) ,lambda)))))



(define-feature-test (and :and) (&rest rest)
  "The standard AND feature test."
  (every #'featurep rest))

(define-feature-test (or :or) (&rest rest)
  "The standard OR feature test."
  (some #'featurep rest))

(define-feature-test (not :not) (feature)
  "The standard NOT feature test."
  (not (featurep feature)))

#||

Examples:

 (define-feature-test (never :never) ()
   "What #+nil often gets used for."
   nil)

 (define-feature-test (fixme :fixme) (&rest references)
   "Mark some code as to-be-fixed."
   (declare (ignore references))
   nil)

  (define-feature-test (bug) (&rest bug-ids)
    "Sometimes you can work around a bug if you know about it."
    (some #'check-bug-applies bug-ids))

||#