something to chew on

:MADEIRA-PORT and FEATURE-EVAL

;;;; By Nikodemus Siivola <[email protected]>, 2012.
;;;;
;;;; 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.

(defpackage :madeira-port
  (:use :cl :asdf)
  (:export #:madeira-port))

(in-package :madeira-port)

;;;; FEATURE-EVAL

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *feature-evaluators* (make-hash-table)))

;;; This is to be exported from MADEIRA, I think. Keeping MADEIRA-PORT
;;; as small as possible.
;;;
;;; FIXME: booleans, generalized booleans, or useful values?
(defun feature-eval (expr)
  "Returns the result of evaluating the feature expression EXPR using
extended feature evaluation rules:

Symbols evaluate to T if they are present in *FEATURES*, and NIL
otherwise.

Non-symbol atoms evaluate to themselves. (Standard feature expressions
do no accept non-symbol atoms at all.)

Conses evaluate depending on the operator in the CAR:

  :AND &rest expressions

    Evaluates to true if all EXPRESSIONS evaluate to true using
    extended feature evaluation rules, NIL otherwise.

  :OR &rest expressions

    Evaluates to true if at least one of EXPRESSIONS evaluates to
    true using extended feature evaluation rules, NIL otherwise.

  :NOT expression

    Evaluates to T if EXPRESSION evaluates to NIL using
    extended feature evaluation rules, NIL otherwise.

  :FIND-PACKAGE package-name

    Evaluates to the designated package if it exists, NIL otherwise.

  :FIND-SYMBOL symbol-name package-name &optional allow-internal

    Evaluates to true if the named package exits, and the symbol named
    by the string designator SYMBOL-NAME is an external (or accessible,
    if ALLOW-INTERNAL is true) symbol in it. Otherwise evaluates to NIL.

  :FIND-FUNCTION symbol-name package-name &optional allow-internal

    Evaluates to true if the named package exits, the symbol named by
    the string designator SYMBOL-NAME is an external (or accessible,
    if ALLOW-INTERNAL is true) symbol in it that is bound to a
    function and is not a macro or a special operator. Otherwise
    evaluates to NIL.

  :FIND-MACRO symbol-name package-name &optional allow-internal

    Evaluates to true if the named package exits, the symbol named by
    the string designator SYMBOL-NAME is an external (or accessible,
    if ALLOW-INTERNAL is true) symbol in it that is bound to a global
    macro. Otherwise evaluates to NIL.

  :FIND-VARIABLE symbol-name package-name &optional allow-internal

    Evaluates to true if the named package exits, the symbol named by
    the string designator SYMBOL-NAME is an external (or accessible,
    if ALLOW-INTERNAL is true) symbol in it that is bound to a value.
    Otherwise evaluates to NIL.

  :FIND-CLASS symbol-name package-name &optional allow-internal

    Evaluates to true if the named package exits, the symbol named by
    the string designator SYMBOL-NAME is an external (or accessible,
    if ALLOW-INTERNAL is true) symbol in it that has an associated
    class definition. Otherwise evaluates to NIL.
"
  (typecase expr
    (cons
     (let ((fname (gethash (car expr) *feature-evaluators*)))
       (if fname
           (apply fname (cdr expr))
           (error "Invalid expression in ~S: ~S" 'featurep expr))))
    (symbol
     (not (null (member expr *features* :test #'eq))))
    (otherwise
     expr)))

(defmacro defeature (name lambda-list &body body)
  (let ((fname (intern (format nil "~A-FEATUREP" name))))
    `(progn
       (defun ,fname ,lambda-list
         ,@body)
       (setf (gethash ',name *feature-evaluators*) ',fname))))

(defeature :and (&rest features)
  "Evaluates to true if all FEATURES evaluate to true under FEATURE-EVAL."
  (when (every #'feature-eval features)
    t))

(defeature :or (&rest features)
  "Evaluates to true if at least one of FEATURES evaluates to true under
FEATURE-EVAL."
  (when (some #'feature-eval features)
    t))

(defeature :not (feature)
  "Evaluates to true if FEATURE evaluates to false under FEATURE-EVAL."
  (not (feature-eval feature)))

(defeature :find-package (name)
  "Evaluates to the named package if it exists, and NIL otherwise."
  (when (find-package name)
    t))

(defun get-symbol (symbol-name package-name &optional allow-internal)
  (let ((pkg (find-package package-name)))
    (when pkg
      (multiple-value-bind (sym state)
          (find-symbol (string symbol-name) pkg)
        (when (or allow-internal (eq :external state))
          (values sym t))))))

(defeature :find-symbol (symbol-name package-name &optional allow-internal)
  (when (get-symbol symbol-name package-name allow-internal)
    t))

(defeature :find-function (symbol-name package-name &optional allow-internal)
  (let ((symbol (get-symbol symbol-name package-name allow-internal)))
    (when (fboundp symbol)
      (unless (or (special-operator-p symbol)
                  (macro-function symbol))
        t))))

(defeature :find-macro (symbol-name package-name &optional allow-internal)
  (let ((symbol (get-symbol symbol-name package-name allow-internal)))
    (when (macro-function symbol)
      t)))

(defeature :find-variable (symbol-name package-name &optional allow-internal)
  (let ((symbol (get-symbol symbol-name package-name allow-internal)))
    (when (boundp symbol)
      t)))

(defeature :find-class (symbol-name package-name &optional allow-internal)
  (let ((symbol (get-symbol symbol-name package-name allow-internal)))
    (when (and symbol (find-class symbol))
      t)))

#+nil
(progn
  ;; These would allow (:eql 64 (:find-variable #:n-word-bits :sb-vm))
  ;; style stuff, but would also encourage more complex feature tests.
  ;;
  ;; Good or bad?
  (defeature :eq (feature1 feature2)
    "Evaluates to T if FEATURE1 and FEATURE2 evaluate to EQ values under
FEATURE-EVAL."
    (eq (feature-eval feature1) (feature-eval feature2)))

  (defeature :eql (feature1 feature2)
    "Evaluates to T if FEATURE1 and FEATURE2 evaluate to EQL values under
FEATURE-EVAL."
    (eql (feature-eval feature1) (feature-eval feature2)))

  (defeature :equal (feature1 feature2)
    "Evaluates to T if FEATURE1 and FEATURE2 evaluate to EQUAL values under
FEATURE-EVAL."
    (equal (feature-eval feature1) (feature-eval feature2)))

  (defeature :equalp (feature1 feature2)
    "Evaluates to T if FEATURE1 and FEATURE2 evaluate to EQUALP values under
FEATURE-EVAL."
    (equalp (feature-eval feature1) (feature-eval feature2))))

;;;; ASDF EXTENSION: Selecting files based on features

(defclass madeira-port (cl-source-file)
  ((test :initform nil)))

(defmethod shared-initialize :after ((port madeira-port) slots &key when unless)
  (setf (slot-value port 'test)
        (cond ((and when unless)
               `(:and ,when (:not ,unless)))
              (when when)
              (unless `(:not ,unless))
              (t
               (error "~S has no feature conditionals." port)))))

(defmethod perform :around ((op load-op) (port madeira-port))
  (when (feature-eval (slot-value port 'test))
    (call-next-method)))

(defmethod perform :around ((op load-source-op) (port madeira-port))
  (when (feature-eval (slot-value port 'test))
    (call-next-method)))

(defmethod perform :around ((op compile-op) (port madeira-port))
  (when (feature-eval (slot-value port 'test))
    (call-next-method)))

;;; Switch package to circumvent package locks on implementations supporting
;;; them -- not that ASDF currently locked, but it might be in the future.
;;;
;;; Importing MADEIRA-PORT to ASDF is necessary for
;;;
;;;  (:MADEIRA-PORT ...)
;;;
;;; syntax to work in defsystems -- which is also the reason we call it
;;; :MADEIRA-PORT, and not just a :PORT-FILE or something nice and short.

(in-package :asdf)

(import 'madeira-port:madeira-port :asdf)

Here's the SB-CGA defsystem using :MADEIRA-PORT:

   (defsystem :sb-cga
     :description "Computer graphic algebra for SBCL."
     :depends-on (:alexandria)
     :defsystem-depends-on (:madeira-port)
     :serial t
     :components
     ((:file "package")
      (:file "types")
      (:file "fndb")
      (:module "ports"
       :components ((:madeira-port "sbcl" :when :sbcl)
                    (:madeira-port "ccl" :when :ccl)
                    (:madeira-port "abcl" :when :abcl)
                    (:madeira-port "acl" :when :allegro)
                    (:madeira-port "ecl" :when :ecl)
                    (:madeira-port "ansi"
                     :unless (:or :sbcl :ccl :abcl :allegro :ecl))))
      (:file "vm")
      (:file "vec")
      (:file "matrix")
      (:file "roots")))