control-flow.lisp
Changes to control-flow.lisp:
Fri Jul 17 05:24:52 UTC 2009 pix@kepibu.org
* Initial checkin
{
addfile ./asdf-components.lisp
hunk ./asdf-components.lisp 1
+(in-package #:portaCL)
+
+(defclass port-mixin ()
+ ((format-name :initform ""
+ :initarg :format-name
+ :accessor format-name)
+ (alternate-file :initform nil
+ :initarg :alternate-file
+ :accessor alternate-file)
+ (not-found-condition :initform 'not-implemented
+ :initarg :not-found-condition
+ :accessor not-found-condition))
+ (:documentation "Like cl-source-file, but offers the ability to splice the
+ implementation type into the name."))
+
+(defclass port-file (port-mixin asdf:cl-source-file) ())
+(defclass port-module (port-mixin asdf:module) ())
+
+;; ASDF does instantiation kinda funky.
+(defmethod reinitialize-instance :after ((port-component port-mixin) &key name alternate-file &allow-other-keys)
+ (when name
+ (setf (format-name port-component)
+ name))
+ (when alternate-file
+ (setf (alternate-file port-component)
+ (merge-pathnames alternate-file (asdf::component-parent-pathname port-component)))))
+
+;; SPOOKY! component-pathname defaults to using the component-name. We take
+;; advantage of that to provide an implementation-dependent pathname while
+;; leaving the component name as the original format string.
+(defmethod asdf:component-name ((port port-mixin))
+ (if *implementation*
+ (format nil (format-name port) *implementation*)
+ (format-name port)))
+
+;; Beware the nearly duplicate code in the following two methods. It's not
+;; really worth factoring out, so be sure to make changes in both.
+(defmethod asdf:component-pathname ((port port-module))
+ (or (first (some #'directory
+ (loop :for *implementation* :in (lisp-implementation-names)
+ :collect (call-next-method))))
+ (and (alternate-file port)
+ (directory (alternate-file port)))
+ (error (not-found-condition port))))
+
+(defmethod asdf:component-pathname ((port port-file))
+ (or (some #'probe-file
+ (loop :for *implementation* :in (lisp-implementation-names)
+ :collect (call-next-method)))
+ (and (alternate-file port)
+ (probe-file (alternate-file port)))
+ (error (not-found-condition port))))
+
+;; If the component is unnecessary, then no worries mate. And yes, both of
+;; these methods are necessary.
+(defmethod asdf:operation-done-p :around ((o asdf:operation) (component port-mixin))
+ (handler-case (call-next-method)
+ (not-necessary () t)))
+(defmethod asdf:perform :around ((operation asdf:operation) (component port-mixin))
+ (handler-case (call-next-method)
+ (not-necessary () t)))
+
+;; Make :port-file work in system definitions
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import 'port-file :asdf)
+ (import 'port-module :asdf))
+
+;; testing examples
+#+nil (pushnew #p"l:/clbuild/source/portaCL/examples/" asdf::*subdir-search-registry*)
addfile ./conditions.lisp
hunk ./conditions.lisp 1
+(in-package #:portaCL)
+
+(define-condition not-implemented (error) ()
+ (:documentation "Condition for when an implementation has not been written,
+ but not deliberately excluded. This is generally the default."))
+
+(define-condition not-supported (error) ()
+ (:documentation "Condition for when something is deliberately not
+ supported."))
+
+(define-condition not-necessary () ()
+ (:documentation "Condition for when something is not necessary. E.g., setting
+ this in an .ASD file will cause that particular component to load only if it
+ exists, while preventing failure if it does not."))
addfile ./control-flow.lisp
hunk ./control-flow.lisp 1
-
+(in-package #:portaCL)
+
+(defmacro feature-cond (&body clauses)
+ "Some things are best shown by example. Suppose you have:
+ #+clisp (do-clisp-thing-1)
+ #+clisp (do-clisp-thing-2)
+ #+sbcl (do-sbcl-thing)
+ #-(or clisp sbcl) (error \"not implemented\")
+Using feature-cond, that would be:
+ (feature-cond
+ (:clisp (do-clisp-thing-1)
+ (do-clisp-thing-2))
+ (:sbcl (do-sbcl-thing))
+ (t (error \"not implemented\")))
+
+Accordingly, putting cl:t into *features* is not recommended.
+
+In general, this probably won't be very useful: read-time conditionals are
+often used to read symbols from packages which may not exist across
+implementations. And, of course, because this is a macro, it cannot appear
+in places where it won't be macroexpanded (e.g., the conditions of case).
+
+By the time you're in a position where this is actually useful,
+ #-(or a b c) (otherwise-clause)
+doesn't seem so bad. At least it'll look the same as your other feature
+conditionals!
+
+Note also that this does NOT provide a run-time check of *features*, but is
+instead a macroexpansion-time check."
+ (let* ((last-clause (car (last clauses)))
+ (otherwise-clause (when (member (car last-clause) '(t otherwise) :test #'eq)
+ last-clause)))
+ (when otherwise-clause (setf clauses (butlast clauses)))
+ `(progn
+ ,@(or (loop :for (cond . body) :in clauses
+ :when (featurep cond)
+ :return body)
+ (cdr otherwise-clause)))))
+
+(defmacro feature-econd (&body clauses)
+ "Like feature-cond, but automatically adds a final clause issuing a
+not-implemented error."
+ `(feature-cond ,@clauses (t (error 'not-implemented))))
+
+(defmacro feature-if (feature-expression true-form &optional else-form)
+ `(if (featurep ,feature-expression)
+ ,true-form
+ ,else-form))
+
+(defmacro feature-when (feature-expression &body body)
+ `(when (featurep ,feature-expression) ,@body))
+
+(defmacro feature-unless (feature-expression &body body)
+ `(unless (featurep ,feature-expression) ,@body))
+
+#+nil
+(feature-cond
+ (:clisp (do-clisp-thing-1)
+ (do-clisp-thing-2))
+ (:sbcl (do-sbcl-thing))
+ (t (error "not implemented")))
+
+#+nil
+(feature-cond
+ ((not :clisp) (do-clisp-thing-1)
+ (do-clisp-thing-2))
+ (:sbcl (do-sbcl-thing))
+ (t (error "not implemented")))
+
+#+nil
+(feature-cond
+ ((or :sbcl :clisp) (do-clisp-thing-1)
+ (do-clisp-thing-2))
+ (:clisp (do-sbcl-thing))
+ (t (error "not implemented")))
+
+#+nil
+(feature-cond
+ ((and (not :windows) :sbcl)
+ (do-sbcl-thing))
+ ((and (or :windows :win32) :clisp)
+ (do-clisp-thing-1)
+ (do-clisp-thing-2))
+ (t (error "not implemented")))
+
+#+nil
+(feature-econd
+ (:sbcl (do-sbcl-thing))
+ (:posix (do-posix-thing)))
addfile ./feature-tests.lisp
hunk ./feature-tests.lisp 1
+(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: ~a"
+ :format-arguments (list feature))
+ (treat-as-true ()
+ :report "Pretend this feature-form were true."
+ t)
+ (treat-as-nil ()
+ :report "Pretend this feature-form were false."
+ nil)))))
+ (if (listp 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)))))
+
+[_^L_][_$_]
+
+(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))
+
+||#
addfile ./name-parts.lisp
hunk ./name-parts.lisp 1
+(in-package #:portaCL)
+
+(defvar *implementation* nil)
+
+(defun lisp-implementation-names ()
+ "Returns a list of names likely to be used in the name of port files."
+ (feature-cond
+ (:allegro '("allegro"))
+ (:clisp '("clisp"))
+ (:cmu '("cmucl" "cmu"))
+ (:cormanlisp '("corman" "cormanlisp"))
+ (:ecl '("ecl"))
+ (:lispworks '("lispworks" "lw"))
+ (:mcl '("mcl"))
+ (:openmcl '("clozure" "openmcl" "mcl"))
+ (:sbcl '("sbcl"))
+ (:scl '("scl"))
+ (:abcl '("abcl" "armedbear"))
+ (t (restart-case (error 'not-implemented)
+ (use-value (value) value)))))
+
+(defun cl-user::implementation (stream object &optional colon-p at-p)
+ (declare (ignore object colon-p at-p))
+ (write-string *implementation* stream))
addfile ./notes.org
hunk ./notes.org 1
+PortaCL: Easing the Creation of CL Portability Libraries
+
+* Rationale
+
+Sometimes you want to do something based upon *features*. Often, that results
+in lots of reader conditions, and a final reader conditional duplicating and
+negating all previous conditions. Ew!
+
+* API
+
+** ASDF Components: port-file, port-module
+
+It's not uncommon for a portability library to include something like:
+ :(:file
+ : #+sbcl "port-sbcl"
+ : #+clisp "port-clisp"
+ : #-(or sbcl clisp) (error "not supported"))
+port-file and port-modules allow you to specify things more like so:
+ :(:port-file "port-~A")
+or, less positionally,
+ :(:port-file "port-~/implementation/")
+
+Whether such magical divinations are a good thing is left to you to decide.
+
+port-file and port-module both also support specification of an :alternate-file,
+which if specified will be used in place of throwing a not-implemented error.
+E.g., for use if only one or two implementations need special behavior.
+
+You can also specify :not-found-condition, the condition type which will be
+thrown if no applicable file is found. (e.g., you might prefer 'not-supported
+instead, or 'not-necessary if a missing component is okay).
+
+** Condition: not-implemented
+
+Useful for indicating a particular thing is not implemented.
+
+This is the default condition thrown when an implementation-specific ASDF
+component is not found.
+
+** Condition: not-supported
+
+A particular thing is not implemented and won't be. E.g., because the lisp
+implementation lacks the necessary features.
+
+** Condition: not-necessary
+
+If this thing is not implemented, it didn't need to be.
+
+When specified as the :not-found-condition in a defsystem form, will cause
+operations on the component to be considered successful even if the component
+could not be found.
+
+** Function: featurep feature-expression
+
+Given a feature expression, returns true if that expression is true.
+
+see CLHS 24.1.2.1 for details. http://www.lispworks.com/documentation/HyperSpec/Body/24_aba.htm
+
+** Macro: define-feature-test test-name-or-names lambda-list [documentation] &body
+
+Defines a feature test which shall return true if the given feature expressions apply.
+
+see feature-tests.lisp for usage examples.
+
+** Macro: feature-cond ([feature-conditional] [clause]+)*
+
+A macro version of #+foo (thing) #+bar (thing2) #-(or foo bar) (no-thing), with
+all the caveats and shortcomings that implies.
+
+** Macro: feature-ecase ([[feature-conditional] [clause]+]+)
+
+feature-case, except always includes a final (error 'not-implemented).
+
+* Future Ideas
+
+** ASDF component enhancements
+*** platform / operating system
+
+It might be useful to also offer up the operating system for interpolation into
+port-files. (e.g., via ~/platform/ or ~/operating-system/).
+
+*** shared-implementation support
+
+It might also be useful to offer a way to specify that certain implementations
+should be treated just like another implementation. E.g.,
+ :(:port-file "port-~a" :treat-as (:ecl :sbcl))
+could be used by usocket, instead of futzing with :alternate-file.
+
+** Other porting styles?
+
+Per-file implementation is not the only possible or used porting approach.
+Perhaps some others should also be supported?
+
+ * SLIME's defimplementation
+ * Xach's CLOS-based approach
+ * Any others?
+
+* Bugs
+
+ASDF systems sometimes try to recursively load themselves a couple hundred
+times. (Though I've seen that even without loading portaCL, so may not be
+entirely my bug...)
+
+* see also
+trivial-features -- smooths out the unnecessary differences between
+ implementation *features*
+alexandria -- implements a #'featurep which exactly matches that used by the
+ standard's #+/#- readmacros.
addfile ./package.lisp
hunk ./package.lisp 1
+(defpackage #:portaCL
+ (:use #:cl)
+ (:export ;; working with feature expressions
+ #:define-feature-test
+ #:featurep
+
+ ;; feature-expression-based control flow
+ #:feature-if
+ #:feature-when
+ #:feature-unless
+ #:feature-cond
+ #:feature-econd
+
+ ;; failure modes
+ #:not-implemented
+ #:not-supported
+ #:not-necessary
+
+ ;; ASDF support
+ #:port-file
+ #:port-module
+
+ ;; Enhanced feature reader support
+ #:install-feature-readers))
addfile ./portacl.asd
hunk ./portacl.asd 1
+
+(asdf:defsystem portaCL
+ :version "0.1"
+ :description "Eases the creation of portability libraries."
+ :maintainer " <pix@kepibu.org>"
+ :author " <pixel@kepibu.org>"
+ :licence "BSD-style"
+ :depends-on ()
+ :serial t
+ :components ((:file "package")
+ (:file "feature-tests")
+ (:file "conditions")
+ (:file "control-flow")
+ (:file "name-parts")
+ (:file "asdf-components")
+ (:file "reader")))
addfile ./reader.lisp
hunk ./reader.lisp 1
+(in-package #:portaCL)
+
+;; see CLHS 2.4.8.17 <http://www.lispworks.com/documentation/HyperSpec/Body/02_dhq.htm>
+(defun feature-reader (stream subchar arg)
+ "Reader for enhanced #+/#- feature conditionals."
+ (declare (ignore arg))
+ (flet ((feature-truth (form)
+ (ecase subchar
+ (#\+ (featurep form))
+ (#\- (not (featurep form)))))
+ (read-form (stream)
+ (read stream t nil t)))
+ (cond
+ ((feature-truth
+ (let ((*package* (find-package :keyword)))
+ (read-form stream)))
+ (values (read-form stream)))
+ (t
+ (let ((*read-suppress* t)) (read-form stream))
+ (values)))))
+
+(defun install-feature-readers (&optional (*readtable* *readtable*))
+ (set-dispatch-macro-character #\# #\+ #'feature-reader)
+ (set-dispatch-macro-character #\# #\- #'feature-reader))
}