Commit 61776f29 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

This system is now just a stub.

parent 9e1d75d1
@section The package-inferred-system extension
asdf-package-system is not supported anymore.
Starting with ASDF 3.1.1,
ASDF supports a one-package-per-file style of programming,
whereby each file is its own system,
and dependencies are deduced from the @code{defpackage} form.
In this style, packages referring to a same-named system (downcased);
and if a system is defined with @code{:class package-inferred-system},
then system names that start with that name
(using the slash @code{/} separator)
refer to files under the filesystem hierarchy where the system is defined.
For instance, if system @code{my-lib} is defined in
@file{/foo/bar/my-lib/my-lib.asd}, then system @code{my-lib/src/utility}
will be found in file @file{/foo/bar/my-lib/src/utility.lisp}.
This style was made popular by @code{faslpath} and @code{quick-build} before,
and at the cost of a stricter package discipline,
seems to make for more maintainable code.
It is used by ASDF itself (starting with ASDF 3) and by @code{lisp-interface-library}.
To use this style, choose a toplevel system name, e.g. @code{my-lib},
and create a file @file{my-lib.asd}
with the @code{:class :package-inferred-system} option in its @code{defsystem}.
For instance:
@example
#-asdf (error "my-lib requires ASDF 3")
(defsystem my-lib
:class :package-inferred-system
:defsystem-depends-on (:asdf-package-system)
:depends-on (:my-lib/src/all)
:in-order-to ((test-op (load-op :my-lib/test/all)))
:perform (test-op (o c) (symbol-call :my-lib/test/all :test-suite)))
(register-system-packages :closer-mop
'(:c2mop :closer-common-lisp :c2cl :closer-common-lisp-user :c2cl-user))
@end example
In the code above, the
@code{:defsystem-depends-on (:asdf-package-system)} is
for compatibility with older versions of ASDF 3 (ASDF 2 is not supported),
and requires the @code{asdf-package-system} library to be present
(it is implicitly provided by ASDF starting with ASDF 3.1.1).
The function @code{register-system-packages} has to be called to register
packages used or provided by your system and its components
where the name of the system that provides the package
is not the downcase of the package name.
File @file{my-lib/src/utility.lisp} might start with:
@example
(defpackage :my-lib/src/utility
(:use :closer-common-lisp :my-lib/src/macros :my-lib/src/variables)
(:import-from :cl-ppcre #:register-groups-bind)
(:export #:foo #:bar))
@end example
And from the @code{:use} and @code{:import-from} clauses,
ASDF could tell that you depend on systems @code{closer-mop} (registered above),
@code{cl-ppcre} (package and system names match), and
@code{my-lib/src/macros} and @code{my-lib/src/variables}
(package and system names match, and they will be looked up hierarchically).
The form @code{uiop:define-package} is supported as well as @code{defpackage},
and has many options that prove useful in this context,
such as @code{:use-reexport} and @code{:mix-reexport}
that allow for ``inheritance'' of symbols being exported.
Please just use ASDF 3.1 or later, that comes with this feature builtin.
See the ASDF manual for documentation of the package-inferred-system feature.
(defsystem asdf-package-system
:description "ASDF extension for a style where each file's dependencies are deduced from its defpackage"
:long-description "asdf-package-system extends ASDF3 with support for quick-build style of systems
whereby each file starts with a defpackage form, from which dependencies are deduced."
:defsystem-depends-on (:asdf) ;; vain attempt to upgrade on time from ASDF2 to ASDF3 if installed
:depends-on ((:version :asdf "3")) ;; trying to work on ASDF2 is just not worth it
(defsystem "asdf-package-system"
:description "Backward-compatible stub for ASDF 3.1's package-inferred-system feature"
:long-description "ASDF 3.1 now include package-inferred-system which supports
quick-build and faslpath style of systems whereby each file starts with a defpackage form,
from which dependencies are deduced. This stub is present for backward compatibility with
systems that were trying to use this feature with ASDF 3.0"
:depends-on ((:version :asdf "3.1.2"))
:licence "MIT"
:version "3.1.0.116"
:components
#.(unless (find-class 'asdf::package-inferred-system nil)
'((:file "header")
(:file "package-inferred-system" :depends-on ("header"))
(:file "footer" :depends-on ("package-inferred-system")))))
:version "3.1.2")
(in-package :asdf/package-inferred-system)
(with-upgradability ()
(use-package :asdf/package-inferred-system :asdf)
(dolist (s '(package-system register-system-packages))
(uiop/package::ensure-exported (string s) s (find-package :asdf))))
;;;; -------------------------------------------------------------------------
;;;; Package-inferred systems in the style of quick-build or faslpath
;; This file is a footer to package-inferred-system in a recent ASDF:
;; * override parse-define-package-form in older versions of UIOP.
;; NB: There is no support for ASDF2.
(in-package :uiop)
;;; If asdf/package-system exists, assume mix-reexport and use-reexport already exist
(unless (if-let (s (find-symbol* :package-system :asdf/package-system nil))
(find-class s nil))
(defun parse-define-package-form (package clauses)
(loop
:with use-p = nil :with recycle-p = nil
:with documentation = nil
:for (kw . args) :in clauses
:when (eq kw :nicknames) :append args :into nicknames :else
:when (eq kw :documentation)
:do (cond
(documentation (error "define-package: can't define documentation twice"))
((or (atom args) (cdr args)) (error "define-package: bad documentation"))
(t (setf documentation (car args)))) :else
:when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
:when (eq kw :shadow) :append args :into shadow :else
:when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
:when (eq kw :import-from) :collect args :into import-from :else
:when (eq kw :export) :append args :into export :else
:when (eq kw :intern) :append args :into intern :else
:when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
:when (eq kw :mix) :append args :into mix :else
:when (eq kw :reexport) :append args :into reexport :else
:when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
:and :do (setf use-p t) :else
:when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
:and :do (setf use-p t) :else
:when (eq kw :unintern) :append args :into unintern :else
:do (error "unrecognized define-package keyword ~S" kw)
:finally (return `(,package
:nicknames ,nicknames :documentation ,documentation
:use ,(if use-p use '(:common-lisp))
:shadow ,shadow :shadowing-import-from ,shadowing-import-from
:import-from ,import-from :export ,export :intern ,intern
:recycle ,(if recycle-p recycle (cons package nicknames))
:mix ,mix :reexport ,reexport :unintern ,unintern)))))
;;;; -------------------------------------------------------------------------
;;;; Package systems in the style of quick-build or faslpath
(uiop:define-package :asdf/package-inferred-system
(:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
(:use :uiop/common-lisp :uiop
:asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
:asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
(:export
#:package-inferred-system #:sysdef-package-inferred-system-search
#:package-system ;; backward compatibility only. To be removed.
#:register-system-packages
#:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
(in-package :asdf/package-inferred-system)
(with-upgradability ()
(defparameter *defpackage-forms* '(cl:defpackage uiop:define-package))
(defun initial-package-inferred-systems-table ()
(let ((h (make-hash-table :test 'equal)))
(dolist (p (list-all-packages))
(dolist (n (package-names p))
(setf (gethash n h) t)))
h))
(defvar *package-inferred-systems* (initial-package-inferred-systems-table))
(defclass package-inferred-system (system)
())
;; For backward compatibility only. To be removed in an upcoming release:
(defclass package-system (package-inferred-system) ())
(defun defpackage-form-p (form)
(and (consp form)
(member (car form) *defpackage-forms*)))
(defun stream-defpackage-form (stream)
(loop :for form = (read stream nil nil) :while form
:when (defpackage-form-p form) :return form))
(defun file-defpackage-form (file)
"Return the first DEFPACKAGE form in FILE."
(with-input-file (f file)
(stream-defpackage-form f)))
(define-condition package-inferred-system-missing-package-error (system-definition-error)
((system :initarg :system :reader error-system)
(pathname :initarg :pathname :reader error-pathname))
(:report (lambda (c s)
(format s (compatfmt "~@<No package form found while ~
trying to define package-inferred-system ~A from file ~A~>")
(error-system c) (error-pathname c)))))
(defun package-dependencies (defpackage-form)
"Return a list of packages depended on by the package
defined in DEFPACKAGE-FORM. A package is depended upon if
the DEFPACKAGE-FORM uses it or imports a symbol from it."
(assert (defpackage-form-p defpackage-form))
(remove-duplicates
(while-collecting (dep)
(loop* :for (option . arguments) :in (cddr defpackage-form) :do
(ecase option
((:use :mix :reexport :use-reexport :mix-reexport)
(dolist (p arguments) (dep (string p))))
((:import-from :shadowing-import-from)
(dep (string (first arguments))))
((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
:from-end t :test 'equal))
(defun package-designator-name (package)
(etypecase package
(package (package-name package))
(string package)
(symbol (string package))))
(defun register-system-packages (system packages)
"Register SYSTEM as providing PACKAGES."
(let ((name (or (eq system t) (coerce-name system))))
(dolist (p (ensure-list packages))
(setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
(defun package-name-system (package-name)
"Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
otherwise return a default system name computed from PACKAGE-NAME."
(check-type package-name string)
(if-let ((system-name (gethash package-name *package-inferred-systems*)))
system-name
(string-downcase package-name)))
(defun package-inferred-system-file-dependencies (file &optional system)
(if-let (defpackage-form (file-defpackage-form file))
(remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
(error 'package-inferred-system-missing-package-error :system system :pathname file)))
(defun same-package-inferred-system-p (system name directory subpath dependencies)
(and (eq (type-of system) 'package-inferred-system)
(equal (component-name system) name)
(pathname-equal directory (component-pathname system))
(equal dependencies (component-sideway-dependencies system))
(let ((children (component-children system)))
(and (length=n-p children 1)
(let ((child (first children)))
(and (eq (type-of child) 'cl-source-file)
(equal (component-name child) "lisp")
(and (slot-boundp child 'relative-pathname)
(equal (slot-value child 'relative-pathname) subpath))))))))
(defun sysdef-package-inferred-system-search (system)
(let ((primary (primary-system-name system)))
(unless (equal primary system)
(let ((top (find-system primary nil)))
(when (typep top 'package-inferred-system)
(if-let (dir (system-source-directory top))
(let* ((sub (subseq system (1+ (length primary))))
(f (probe-file* (subpathname dir sub :type "lisp")
:truename *resolve-symlinks*)))
(when (file-pathname-p f)
(let ((dependencies (package-inferred-system-file-dependencies f system))
(previous (cdr (system-registered-p system))))
(if (same-package-inferred-system-p previous system dir sub dependencies)
previous
(eval `(defsystem ,system
:class package-inferred-system
:source-file nil
:pathname ,dir
:depends-on ,dependencies
:components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
(with-upgradability ()
(pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
(setf *system-definition-search-functions*
(remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
*system-definition-search-functions*)))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment