[Initial checkin
pix@kepibu.org**20090717052452] {
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)))))
+
+
+
+(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))
}