[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 " " + :author " " + :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 +(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)) }