Skip to content

Instantly share code, notes, and snippets.

@nikodemus

nikodemus/:MADEIRA-PORT and FEATURE-EVAL

Created May 7, 2012 05:36
Show Gist options
  • Save nikodemus/2626117 to your computer and use it in GitHub Desktop.
Save nikodemus/2626117 to your computer and use it in GitHub Desktop.
Download ZIP
something to chew on
Raw
:MADEIRA-PORT and FEATURE-EVAL
;;;; By Nikodemus Siivola <nikodemus@random-state.net>, 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)
@nikodemus
Copy link
Author

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")))

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment