[git] CMU Common Lisp branch master updated. snapshot-2013-05-10-g9f62dcd
Raymond Toy
rtoy at common-lisp.net
Fri May 24 02:36:58 UTC 2013
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".
The branch, master has been updated
via 9f62dcdfab39ef03cf01969b6ea88b962073d09f (commit)
from b3b0725a647a3c59440cd6ffa8baa33f616c4479 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 9f62dcdfab39ef03cf01969b6ea88b962073d09f
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Thu May 23 19:36:45 2013 -0700
Update to ASDF 3.0.1.
diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp
index d3c63b2..88949ea 100644
--- a/src/contrib/asdf/asdf.lisp
+++ b/src/contrib/asdf/asdf.lisp
@@ -1,5 +1,5 @@
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.32: Another System Definition Facility.
+;;; This is ASDF 3.0.1: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel at common-lisp.net>.
@@ -71,10 +71,10 @@
(existing-version-number (and existing-version (read-from-string existing-major-minor)))
(away (format nil "~A-~A" :asdf existing-version)))
(when (and existing-version (< existing-version-number
- (or #+abcl 2.25 #+cmu 2.018 2.27)))
+ (or #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27)))
(rename-package :asdf away)
(when *load-verbose*
- (format t "; Renamed old ~A package away to ~A~%" :asdf away))))))
+ (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
;;;; ---------------------------------------------------------------------------
;;;; Handle ASDF package upgrade, including implementation-dependent magic.
@@ -1014,12 +1014,15 @@ or when loading the package is optional."
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
(:export
;; magic helper to define debugging functions:
- #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
+ #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
#:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
#:if-let ;; basic flow control
- #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
+ #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
+ #:remove-plist-keys #:remove-plist-key ;; plists
#:emptyp ;; sequences
- #:strcat #:first-char #:last-char #:split-string ;; strings
+ #:+non-base-chars-exist-p+ ;; characters
+ #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
+ #:first-char #:last-char #:split-string
#:string-prefix-p #:string-enclosed-p #:string-suffix-p
#:find-class* ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
@@ -1092,22 +1095,22 @@ or when loading the package is optional."
;;; Magic debugging help. See contrib/debug.lisp
(with-upgradability ()
- (defvar *asdf-debug-utility*
+ (defvar *uiop-debug-utility*
'(or (ignore-errors
- (symbol-call :asdf :system-relative-pathname :asdf "contrib/debug.lisp"))
- (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
+ (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))
+ (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp"))
"form that evaluates to the pathname to your favorite debugging utilities")
- (defmacro asdf-debug (&rest keys)
+ (defmacro uiop-debug (&rest keys)
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (load-asdf-debug-utility , at keys)))
+ (load-uiop-debug-utility , at keys)))
- (defun load-asdf-debug-utility (&key package utility-file)
+ (defun load-uiop-debug-utility (&key package utility-file)
(let* ((*package* (if package (find-package package) *package*))
(keyword (read-from-string
(format nil ":DBG-~:@(~A~)" (package-name *package*)))))
(unless (member keyword *features*)
- (let* ((utility-file (or utility-file *asdf-debug-utility*))
+ (let* ((utility-file (or utility-file *uiop-debug-utility*))
(file (ignore-errors (probe-file (eval utility-file)))))
(if file (load file)
(error "Failed to locate debug utility file: ~S" utility-file)))))))
@@ -1156,7 +1159,11 @@ Returns two values: \(A B C\) and \(1 2 3\)."
:for i :downfrom n :do
(cond
((zerop i) (return (null l)))
- ((not (consp l)) (return nil))))))
+ ((not (consp l)) (return nil)))))
+
+ (defun ensure-list (x)
+ (if (listp x) x (list x))))
+
;;; remove a key from a plist, i.e. for keyword argument cleanup
(with-upgradability ()
@@ -1180,10 +1187,42 @@ Returns two values: \(A B C\) and \(1 2 3\)."
(or (null x) (and (vectorp x) (zerop (length x))))))
+;;; Characters
+(with-upgradability ()
+ (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
+ (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
+
+
;;; Strings
(with-upgradability ()
+ (defun base-string-p (string)
+ (declare (ignorable string))
+ (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
+
+ (defun strings-common-element-type (strings)
+ (declare (ignorable strings))
+ #-non-base-chars-exist-p 'character
+ #+non-base-chars-exist-p
+ (if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s)))
+ 'base-char 'character))
+
+ (defun reduce/strcat (strings &key key start end)
+ "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
+NIL is interpreted as an empty string. A character is interpreted as a string of length one."
+ (when (or start end) (setf strings (subseq strings start end)))
+ (when key (setf strings (mapcar key strings)))
+ (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s)))
+ :element-type (strings-common-element-type strings))
+ :with pos = 0
+ :for input :in strings
+ :do (etypecase input
+ (null)
+ (character (setf (char output pos) input) (incf pos))
+ (string (replace output input :start1 pos) (incf pos (length input))))
+ :finally (return output)))
+
(defun strcat (&rest strings)
- (apply 'concatenate 'string strings))
+ (reduce/strcat strings))
(defun first-char (s)
(and (stringp s) (plusp (length s)) (char s 0)))
@@ -1204,12 +1243,11 @@ starting the separation from the end, e.g. when called with arguments
(loop
:for start = (if (and max (>= words (1- max)))
(done)
- (position-if #'separatorp string :end end :from-end t)) :do
- (when (null start)
- (done))
- (push (subseq string (1+ start) end) list)
- (incf words)
- (setf end start))))))
+ (position-if #'separatorp string :end end :from-end t))
+ :do (when (null start) (done))
+ (push (subseq string (1+ start) end) list)
+ (incf words)
+ (setf end start))))))
(defun string-prefix-p (prefix string)
"Does STRING begin with PREFIX?"
@@ -1419,7 +1457,8 @@ a simple vector of length 2, arguments to find-symbol* with result as above,
or a string describing the format-control of a simple-condition."
(etypecase x
(symbol (typep condition x))
- ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
+ ((simple-vector 2)
+ (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
(function (funcall x condition))
(string (and (typep condition 'simple-condition)
;; On SBCL, it's always set and the check triggers a warning
@@ -2427,8 +2466,14 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
(t
(translate-pathname path absolute-source destination))))
- (defvar *output-translation-function* 'identity)) ; Hook for output translations
+ (defvar *output-translation-function* 'identity
+ "Hook for output translations.
+This function needs to be idempotent, so that actions can work
+whether their inputs were translated or not,
+which they will be if we are composing operations. e.g. if some
+create-lisp-op creates a lisp file from some higher-level input,
+you need to still be able to use compile-op on that lisp file."))
;;;; -------------------------------------------------------------------------
;;;; Portability layer around Common Lisp filesystem access
@@ -2441,7 +2486,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
;; Native namestrings
#:native-namestring #:parse-native-namestring
;; Probing the filesystem
- #:truename* #:safe-file-write-date #:probe-file*
+ #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
#:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
#:collect-sub*directories
;; Resolving symlinks somewhat
@@ -2456,7 +2501,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
;; Simple filesystem operations
#:ensure-all-directories-exist
#:rename-file-overwriting-target
- #:delete-file-if-exists))
+ #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
(in-package :uiop/filesystem)
;;; Native namestrings, as seen by the operating system calls rather than Lisp
@@ -2564,10 +2609,18 @@ or the original (parsed) pathname if it is false (the default)."
(probe resolve)))))
(file-error () nil)))))))
+ (defun directory-exists-p (x)
+ (let ((p (probe-file* x :truename t)))
+ (and (directory-pathname-p p) p)))
+
+ (defun file-exists-p (x)
+ (let ((p (probe-file* x :truename t)))
+ (and (file-pathname-p p) p)))
+
(defun directory* (pathname-spec &rest keys &key &allow-other-keys)
(apply 'directory pathname-spec
(append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
- #+clozure '(:follow-links nil)
+ #+(or clozure digitool) '(:follow-links nil)
#+clisp '(:circle t :if-does-not-exist :ignore)
#+(or cmu scl) '(:follow-links nil :truenamep nil)
#+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
@@ -2602,7 +2655,11 @@ or the original (parsed) pathname if it is false (the default)."
(unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
(error "Invalid file pattern ~S for logical directory ~S" pattern directory))
(setf pattern (make-pathname-logical pattern (pathname-host dir))))
- (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
+ (let* ((pat (merge-pathnames* pattern dir))
+ (entries (append (ignore-errors (directory* pat))
+ #+clisp
+ (when (equal :wild (pathname-type pattern))
+ (ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
(filter-logical-directory-results
directory entries
#'(lambda (f)
@@ -2649,10 +2706,10 @@ or the original (parsed) pathname if it is false (the default)."
:directory (append prefix (make-pathname-component-logical (last dir)))))))))))
(defun collect-sub*directories (directory collectp recursep collector)
- (when (funcall collectp directory)
- (funcall collector directory))
+ (when (call-function collectp directory)
+ (call-function collector directory))
(dolist (subdir (subdirectories directory))
- (when (funcall recursep subdir)
+ (when (call-function recursep subdir)
(collect-sub*directories subdir collectp recursep collector)))))
;;; Resolving symlinks somewhat
@@ -2790,7 +2847,8 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
(check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
(check want-relative (relative-pathname-p p) "Expected a relative pathname")
(check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
- (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults))
+ (transform ensure-absolute (not (absolute-pathname-p p))
+ (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
(check ensure-absolute (absolute-pathname-p p)
"Could not make into an absolute pathname even after merging with ~S" defaults)
(check ensure-subpath (absolute-pathname-p defaults)
@@ -2850,8 +2908,10 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
(loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
:collect (apply 'parse-native-namestring namestring constraints)))
- (defun getenv-pathname (x &rest constraints &key on-error &allow-other-keys)
+ (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
+ ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
(apply 'parse-native-namestring (getenvp x)
+ :ensure-directory (or ensure-directory want-directory)
:on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
constraints))
@@ -2907,8 +2967,85 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
#+clozure :if-exists #+clozure :rename-and-delete))
(defun delete-file-if-exists (x)
- (when x (handler-case (delete-file x) (file-error () nil)))))
-
+ (when x (handler-case (delete-file x) (file-error () nil))))
+
+ (defun delete-empty-directory (directory-pathname)
+ "Delete an empty directory"
+ #+(or abcl digitool gcl) (delete-file directory-pathname)
+ #+allegro (excl:delete-directory directory-pathname)
+ #+clisp (ext:delete-directory directory-pathname)
+ #+clozure (ccl::delete-empty-directory directory-pathname)
+ #+(or cmu scl) (multiple-value-bind (ok errno)
+ (unix:unix-rmdir (native-namestring directory-pathname))
+ (unless ok
+ #+cmu (error "Error number ~A when trying to delete directory ~A"
+ errno directory-pathname)
+ #+scl (error "~@<Error deleting ~S: ~A~@:>"
+ directory-pathname (unix:get-unix-error-msg errno))))
+ #+cormanlisp (win32:delete-directory directory-pathname)
+ #+ecl (si:rmdir directory-pathname)
+ #+lispworks (lw:delete-directory directory-pathname)
+ #+mkcl (mkcl:rmdir directory-pathname)
+ #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
+ `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
+ `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
+ #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl)
+ (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera xcl
+
+ (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
+ "Delete a directory including all its recursive contents, aka rm -rf.
+
+To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
+a physical non-wildcard directory pathname (not namestring).
+
+If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
+if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
+
+Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
+the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
+which in practice is thus compulsory, and validates by returning a non-NIL result.
+If you're suicidal or extremely confident, just use :VALIDATE T."
+ (check-type if-does-not-exist (member :error :ignore))
+ (cond
+ ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname)
+ (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
+ (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
+ 'delete-filesystem-tree directory-pathname))
+ ((not validatep)
+ (error "~S was asked to delete ~S but was not provided a validation predicate"
+ 'delete-filesystem-tree directory-pathname))
+ ((not (call-function validate directory-pathname))
+ (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
+ 'delete-filesystem-tree directory-pathname validate))
+ ((not (directory-exists-p directory-pathname))
+ (ecase if-does-not-exist
+ (:error
+ (error "~S was asked to delete ~S but the directory does not exist"
+ 'delete-filesystem-tree directory-pathname))
+ (:ignore nil)))
+ #-(or allegro cmu clozure sbcl scl)
+ ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
+ ;; except on implementations where we can prevent DIRECTORY from following symlinks;
+ ;; instead spawn a standard external program to do the dirty work.
+ (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
+ (t
+ ;; On supported implementation, call supported system functions
+ #+allegro (symbol-call :excl.osi :delete-directory-and-files
+ directory-pathname :if-does-not-exist if-does-not-exist)
+ #+clozure (ccl:delete-directory directory-pathname)
+ #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type))
+ #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
+ `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
+ '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
+ ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
+ ;; do things the hard way.
+ #-(or allegro clozure genera sbcl)
+ (let ((sub*directories
+ (while-collecting (c)
+ (collect-sub*directories directory-pathname t t #'c))))
+ (dolist (d (nreverse sub*directories))
+ (map () 'delete-file (directory-files d))
+ (delete-empty-directory d)))))))
;;;; ---------------------------------------------------------------------------
;;;; Utilities related to streams
@@ -2924,9 +3061,9 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
#:*default-encoding* #:*utf-8-external-format*
#:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
#:with-output #:output-string #:with-input
- #:with-input-file #:call-with-input-file
+ #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
#:finish-outputs #:format! #:safe-format!
- #:copy-stream-to-stream #:concatenate-files
+ #:copy-stream-to-stream #:concatenate-files #:copy-file
#:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
#:slurp-stream-forms #:slurp-stream-form
#:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
@@ -3098,10 +3235,33 @@ Other keys are accepted but discarded."
:if-does-not-exist if-does-not-exist)
(funcall thunk s)))
- (defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
- (declare (ignore element-type external-format))
- `(call-with-input-file ,pathname #'(lambda (,var) , at body) , at keys)))
+ (defmacro with-input-file ((var pathname &rest keys
+ &key element-type external-format if-does-not-exist)
+ &body body)
+ (declare (ignore element-type external-format if-does-not-exist))
+ `(call-with-input-file ,pathname #'(lambda (,var) , at body) , at keys))
+
+ (defun call-with-output-file (pathname thunk
+ &key
+ (element-type *default-stream-element-type*)
+ (external-format *utf-8-external-format*)
+ (if-exists :error)
+ (if-does-not-exist :create))
+ "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
+Other keys are accepted but discarded."
+ #+gcl2.6 (declare (ignore external-format))
+ (with-open-file (s pathname :direction :output
+ :element-type element-type
+ #-gcl2.6 :external-format #-gcl2.6 external-format
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)
+ (funcall thunk s)))
+ (defmacro with-output-file ((var pathname &rest keys
+ &key element-type external-format if-exists if-does-not-exist)
+ &body body)
+ (declare (ignore element-type external-format if-exists if-does-not-exist))
+ `(call-with-output-file ,pathname #'(lambda (,var) , at body) , at keys)))
;;; Ensure output buffers are flushed
(with-upgradability ()
@@ -3158,6 +3318,10 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
:direction :input :if-does-not-exist :error)
(copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
+ (defun copy-file (input output)
+ ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
+ (concatenate-files (list input) output))
+
(defun slurp-stream-string (input &key (element-type 'character))
"Read the contents of the INPUT stream as a string"
(with-open-stream (input input)
@@ -3308,7 +3472,7 @@ If a string, repeatedly read and evaluate from it, returning the last values."
#+gcl2.6 (declare (ignorable external-format))
(check-type direction (member :output :io))
(loop
- :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
+ :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
:for counter :from (random (ash 1 32))
:for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
;; TODO: on Unix, do something about umask
@@ -3410,6 +3574,9 @@ For the latter case, we ought pick random suffix and atomically open it."
(defvar *image-restore-hook* nil
"Functions to call (in reverse order) when the image is restored")
+ (defvar *image-restored-p* nil
+ "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
+
(defvar *image-prelude* nil
"a form to evaluate, or string containing forms to read and evaluate
when the image is restarted, but before the entry point is called.")
@@ -3602,10 +3769,17 @@ if we are not called from a directly executable image."
((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
((:restore-hook *image-restore-hook*) *image-restore-hook*)
((:prelude *image-prelude*) *image-prelude*)
- ((:entry-point *image-entry-point*) *image-entry-point*))
+ ((:entry-point *image-entry-point*) *image-entry-point*)
+ (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
+ (when *image-restored-p*
+ (if if-already-restored
+ (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
+ (return-from restore-image)))
(with-fatal-condition-handler ()
+ (setf *image-restored-p* :in-progress)
(call-image-restore-hook)
(standard-eval-thunk *image-prelude*)
+ (setf *image-restored-p* t)
(let ((results (multiple-value-list
(if *image-entry-point*
(call-function *image-entry-point*)
@@ -3618,14 +3792,16 @@ if we are not called from a directly executable image."
;;; Dumping an image
(with-upgradability ()
- #-(or ecl mkcl)
(defun dump-image (filename &key output-name executable
((:postlude *image-postlude*) *image-postlude*)
- ((:dump-hook *image-dump-hook*) *image-dump-hook*))
+ ((:dump-hook *image-dump-hook*) *image-dump-hook*)
+ #+clozure prepend-symbols #+clozure (purify t))
(declare (ignorable filename output-name executable))
(setf *image-dumped-p* (if executable :executable t))
+ (setf *image-restored-p* :in-regress)
(standard-eval-thunk *image-postlude*)
(call-image-dump-hook)
+ (setf *image-restored-p* nil)
#-(or clisp clozure cmu lispworks sbcl scl)
(when executable
(error "Dumping an executable is not supported on this implementation! Aborting."))
@@ -3644,8 +3820,16 @@ if we are not called from a directly executable image."
;; :parse-options nil ;--- requires a non-standard patch to clisp.
:norc t :script nil :init-function #'restore-image)))
#+clozure
- (ccl:save-application filename :prepend-kernel t
- :toplevel-function (when executable #'restore-image))
+ (flet ((dump (prepend-kernel)
+ (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
+ :toplevel-function (when executable #'restore-image))))
+ ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
+ (if prepend-symbols
+ (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
+ (require 'elf)
+ (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
+ (dump path))
+ (dump t)))
#+(or cmu scl)
(progn
(ext:gc :full t)
@@ -3669,33 +3853,36 @@ if we are not called from a directly executable image."
:executable t ;--- always include the runtime that goes with the core
(when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
#-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
- (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
- filename (nth-value 1 (implementation-type))))
+ (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
+ 'dump-image filename (nth-value 1 (implementation-type))))
-
- #+ecl
(defun create-image (destination object-files
- &key kind output-name prologue-code epilogue-code
- (prelude () preludep) (entry-point () entry-point-p) build-args)
+ &key kind output-name prologue-code epilogue-code
+ (prelude () preludep) (postlude () postludep)
+ (entry-point () entry-point-p) build-args)
+ (declare (ignorable destination object-files kind output-name prologue-code epilogue-code
+ prelude preludep postlude postludep entry-point entry-point-p build-args))
;; Is it meaningful to run these in the current environment?
;; only if we also track the object files that constitute the "current" image,
;; and otherwise simulate dump-image, including quitting at the end.
- ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook)
- (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
- (apply 'c::builder
- kind (pathname destination)
- :lisp-files object-files
- :init-name (c::compute-init-name (or output-name destination) :kind kind)
- :prologue-code prologue-code
- :epilogue-code
- `(progn
- ,epilogue-code
- ,@(when (eq kind :program)
- `((setf *image-dumped-p* :executable)
- (restore-image ;; default behavior would be (si::top-level)
- ,@(when preludep `(:prelude ',prelude))
- ,@(when entry-point-p `(:entry-point ',entry-point))))))
- build-args)))
+ #-ecl (error "~S not implemented for your implementation (yet)" 'create-image)
+ #+ecl
+ (progn
+ (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
+ (apply 'c::builder
+ kind (pathname destination)
+ :lisp-files object-files
+ :init-name (c::compute-init-name (or output-name destination) :kind kind)
+ :prologue-code prologue-code
+ :epilogue-code
+ `(progn
+ ,epilogue-code
+ ,@(when (eq kind :program)
+ `((setf *image-dumped-p* :executable)
+ (restore-image ;; default behavior would be (si::top-level)
+ ,@(when preludep `(:prelude ',prelude))
+ ,@(when entry-point-p `(:entry-point ',entry-point))))))
+ build-args))))
;;; Some universal image restore hooks
@@ -3842,7 +4029,7 @@ by /bin/sh in POSIX"
;;;; Slurping a stream, typically the output of another program
(with-upgradability ()
(defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys))
-
+
#-(or gcl2.6 genera)
(defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
(funcall function input-stream))
@@ -3881,6 +4068,27 @@ by /bin/sh in POSIX"
(declare (ignorable x))
(slurp-stream-form stream :at at))
+ (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
+ (declare (ignorable x))
+ (apply 'slurp-input-stream *standard-output* stream keys))
+
+ (defmethod slurp-input-stream ((pathname pathname) input
+ &key
+ (element-type *default-stream-element-type*)
+ (external-format *utf-8-external-format*)
+ (if-exists :rename-and-delete)
+ (if-does-not-exist :create)
+ buffer-size
+ linewise)
+ (with-output-file (output pathname
+ :element-type element-type
+ :external-format external-format
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)
+ (copy-stream-to-stream
+ input output
+ :element-type element-type :buffer-size buffer-size :linewise linewise)))
+
(defmethod slurp-input-stream (x stream
&key linewise prefix (element-type 'character) buffer-size
&allow-other-keys)
@@ -3918,16 +4126,24 @@ by /bin/sh in POSIX"
&allow-other-keys)
"Run program specified by COMMAND,
either a list of strings specifying a program and list of arguments,
-or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
-have its output processed by the OUTPUT processor function
-as per SLURP-INPUT-STREAM,
-or merely output to the inherited standard output if it's NIL.
+or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
+
Always call a shell (rather than directly execute the command)
if FORCE-SHELL is specified.
-Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS
-is specified.
-Return the exit status code of the process that was called.
+
+Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
+unless IGNORE-ERROR-STATUS is specified.
+
+If OUTPUT is either NIL or :INTERACTIVE, then
+return the exit status code of the process that was called.
+if it was NIL, the output is discarded;
+if it was :INTERACTIVE, the output and the input are inherited from the current process.
+
+Otherwise, the output will be processed by SLURP-INPUT-STREAM,
+using OUTPUT as the first argument, and return whatever it returns,
+e.g. using :OUTPUT :STRING will have it return the entire output stream as a string.
Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
+ ;; TODO: specially recognize :output pathname ?
(declare (ignorable ignore-error-status element-type external-format))
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
(error "RUN-PROGRAM not implemented for this Lisp")
@@ -3969,7 +4185,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
#+os-unix (coerce (cons (first command) command) 'vector)
#+os-windows command
:input interactive :output (or (and pipe :stream) interactive) :wait wait
- #+os-windows :show-window #+os-windows (and pipe :hide))
+ #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide))
#+clisp
(flet ((run (f &rest args)
(apply f `(, at args :input ,(when interactive :terminal) :wait ,wait :output
@@ -3995,9 +4211,9 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
;; note: :external-format requires a recent SBCL
#+sbcl '(:search t :external-format external-format)))))
(process
- #+(or allegro lispworks) (if pipe (third process*) (first process*))
+ #+allegro (if pipe (third process*) (first process*))
#+ecl (third process*)
- #-(or allegro lispworks ecl) (first process*))
+ #-(or allegro ecl) (first process*))
(stream
(when pipe
#+(or allegro lispworks ecl) (first process*)
@@ -4020,7 +4236,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
#+clozure (nth-value 1 (ccl:external-process-status process))
#+(or cmu scl) (ext:process-exit-code process)
#+ecl (nth-value 1 (ext:external-process-status process))
- #+lispworks (if pipe (system:pid-exit-status process :wait t) process)
+ #+lispworks (if pipe (system:pipe-exit-status process :wait t) process)
#+sbcl (sb-ext:process-exit-code process))
(check-result (exit-code process)
#+clisp
@@ -4059,7 +4275,9 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
(declare (ignorable interactive))
#+(or abcl xcl) (ext:run-shell-command command)
#+allegro
- (excl:run-shell-command command :input interactive :output interactive :wait t)
+ (excl:run-shell-command
+ command :input interactive :output interactive :wait t
+ #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide))
#+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
(process-result (run-program command :pipe nil :interactive interactive) nil)
#+ecl (ext:system command)
@@ -4067,7 +4285,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
#+gcl (lisp:system command)
#+(and lispworks os-windows)
(system:call-system-showing-output
- command :show-cmd interactive :prefix "" :output-stream nil)
+ command :show-cmd (or interactive (eq output t)) :prefix "" :output-stream nil)
#+mcl (ccl::with-cstrs ((%command command)) (_system %command))
#+mkcl (nth-value 2
(mkcl:run-program #+windows command #+windows ()
@@ -4109,13 +4327,15 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
#:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
#:compile-warned-warning #:compile-failed-warning
#:check-lisp-compile-results #:check-lisp-compile-warnings
- #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
+ #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
+ ;; Types
+ #+sbcl #:sb-grovel-unknown-constant-condition
;; Functions & Macros
#:get-optimization-settings #:proclaim-optimization-settings
#:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
#:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
#:reify-simple-sexp #:unreify-simple-sexp
- #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings
+ #:reify-deferred-warnings #:unreify-deferred-warnings
#:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
#:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
#:enable-deferred-warnings-check #:disable-deferred-warnings-check
@@ -4146,15 +4366,16 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(defvar *previous-optimization-settings* nil)
(defun get-optimization-settings ()
"Get current compiler optimization settings, ready to PROCLAIM again"
+ #-(or clisp clozure cmu ecl sbcl scl)
+ (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type))
+ #+clozure (ccl:declaration-information 'optimize nil)
+ #+(or clisp cmu ecl sbcl scl)
(let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
- #-(or clisp clozure cmu ecl sbcl scl)
- (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
#.`(loop :for x :in settings
- ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
- #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
+ ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
#+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
:for y = (or #+clisp (gethash x system::*optimize*)
- #+(or clozure ecl) (symbol-value v)
+ #+(or ecl) (symbol-value v)
#+(or cmu scl) (funcall f c::*default-cookie*)
#+sbcl (cdr (assoc x sb-c::*policy*)))
:when y :collect (list x y))))
@@ -4179,7 +4400,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(deftype sb-grovel-unknown-constant-condition ()
'(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
- (defvar *uninteresting-compiler-conditions*
+ (defvar *usual-uninteresting-conditions*
(append
;;#+clozure '(ccl:compiler-warning)
#+cmu '("Deleting unreachable code.")
@@ -4188,38 +4409,42 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
#+sbcl
'(sb-c::simple-compiler-note
"&OPTIONAL and &KEY found in the same lambda list: ~S"
- sb-int:package-at-variance
- sb-kernel:uninteresting-redefinition
- sb-kernel:undefined-alien-style-warning
- ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default.
#+sb-eval sb-kernel:lexical-environment-too-complex
+ sb-kernel:undefined-alien-style-warning
sb-grovel-unknown-constant-condition ; defined above.
+ sb-ext:implicit-generic-function-warning ;; Controversial.
+ sb-int:package-at-variance
+ sb-kernel:uninteresting-redefinition
;; BEWARE: the below four are controversial to include here.
sb-kernel:redefinition-with-defun
sb-kernel:redefinition-with-defgeneric
sb-kernel:redefinition-with-defmethod
sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
'("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
- "Conditions that may be skipped while compiling")
+ "A suggested value to which to set or bind *uninteresting-conditions*.")
+ (defvar *uninteresting-conditions* '()
+ "Conditions that may be skipped while compiling or loading Lisp code.")
+ (defvar *uninteresting-compiler-conditions* '()
+ "Additional conditions that may be skipped while compiling Lisp code.")
(defvar *uninteresting-loader-conditions*
(append
'("Overwriting already existing readtable ~S." ;; from named-readtables
#(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
#+clisp '(clos::simple-gf-replacing-method-warning))
- "Additional conditions that may be skipped while loading"))
+ "Additional conditions that may be skipped while loading Lisp code."))
;;;; ----- Filtering conditions while building -----
(with-upgradability ()
(defun call-with-muffled-compiler-conditions (thunk)
(call-with-muffled-conditions
- thunk *uninteresting-compiler-conditions*))
+ thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
(defmacro with-muffled-compiler-conditions ((&optional) &body body)
"Run BODY where uninteresting compiler conditions are muffled"
`(call-with-muffled-compiler-conditions #'(lambda () , at body)))
(defun call-with-muffled-loader-conditions (thunk)
(call-with-muffled-conditions
- thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*)))
+ thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
(defmacro with-muffled-loader-conditions ((&optional) &body body)
"Run BODY where uninteresting compiler and additional loader conditions are muffled"
`(call-with-muffled-loader-conditions #'(lambda () , at body))))
@@ -4322,10 +4547,18 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
name))
(defun reify-function-name (function-name)
(let ((name (or (first function-name) ;; defun: extract the name
- (first (second function-name))))) ;; defmethod: keep gf name, drop method specializers
+ (let ((sec (second function-name)))
+ (or (and (atom sec) sec) ; scoped method: drop scope
+ (first sec)))))) ; method: keep gf name, drop method specializers
(list name)))
(defun unreify-function-name (function-name)
function-name)
+ (defun nullify-non-literals (sexp)
+ (typecase sexp
+ ((or number character simple-string symbol pathname) sexp)
+ (cons (cons (nullify-non-literals (car sexp))
+ (nullify-non-literals (cdr sexp))))
+ (t nil)))
(defun reify-deferred-warning (deferred-warning)
(with-accessors ((warning-type ccl::compiler-warning-warning-type)
(args ccl::compiler-warning-args)
@@ -4333,11 +4566,10 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(function-name ccl:compiler-warning-function-name)) deferred-warning
(list :warning-type warning-type :function-name (reify-function-name function-name)
:source-note (reify-source-note source-note)
- :args (destructuring-bind (fun formals env) args
- (declare (ignorable env))
- (list (unsymbolify-function-name fun)
- (mapcar (constantly nil) formals)
- nil)))))
+ :args (destructuring-bind (fun &rest more)
+ args
+ (cons (unsymbolify-function-name fun)
+ (nullify-non-literals more))))))
(defun unreify-deferred-warning (reified-deferred-warning)
(destructuring-bind (&key warning-type function-name source-note args)
reified-deferred-warning
@@ -4346,8 +4578,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
:function-name (unreify-function-name function-name)
:source-note (unreify-source-note source-note)
:warning-type warning-type
- :args (destructuring-bind (fun . formals) args
- (cons (symbolify-function-name fun) formals))))))
+ :args (destructuring-bind (fun . more) args
+ (cons (symbolify-function-name fun) more))))))
#+(or cmu scl)
(defun reify-undefined-warning (warning)
;; Extracting undefined-warnings from the compilation-unit
@@ -4753,11 +4985,12 @@ it will filter them appropriately."
;;; Links FASLs together
(with-upgradability ()
(defun combine-fasls (inputs output)
- #-(or allegro clisp clozure cmu lispworks sbcl scl xcl)
+ #-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl)
(error "~A does not support ~S~%inputs ~S~%output ~S"
(implementation-type) 'combine-fasls inputs output)
- #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
+ #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
#+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output)
+ #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
#+lispworks
(let (fasls)
(unwind-protect
@@ -4766,9 +4999,8 @@ it will filter them appropriately."
:for n :from 1
:for f = (add-pathname-suffix
output (format nil "-FASL~D" n))
- :do #-lispworks-personal-edition (lispworks:copy-file i f)
- #+lispworks-personal-edition (concatenate-files (list i) f)
- (push f fasls))
+ :do (copy-file i f)
+ (push f fasls))
(ignore-errors (lispworks:delete-system :fasls-to-concatenate))
(eval `(scm:defsystem :fasls-to-concatenate
(:default-pathname ,(pathname-directory-pathname output))
@@ -4786,7 +5018,7 @@ it will filter them appropriately."
(:nicknames :asdf/configuration)
(:recycle :uiop/configuration :asdf/configuration :asdf)
(:use :uiop/common-lisp :uiop/utility
- :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
+ :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
(:export
#:get-folder-path
#:user-configuration-directories #:system-configuration-directories
@@ -4794,7 +5026,7 @@ it will filter them appropriately."
#:in-user-configuration-directory #:in-system-configuration-directory
#:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
#:configuration-inheritance-directive-p
- #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form*
+ #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
#:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
#:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
#:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
@@ -5012,7 +5244,8 @@ directive.")
(if wilden (wilden p) p))))
((eql :home) (user-homedir-pathname))
((eql :here) (resolve-absolute-location
- *here-directory* :ensure-directory t :wilden nil))
+ (or *here-directory* (pathname-directory-pathname (load-pathname)))
+ :ensure-directory t :wilden nil))
((eql :user-cache) (resolve-absolute-location
*user-cache* :ensure-directory t :wilden nil)))
:wilden (and wilden (not (pathnamep x)))
@@ -5188,7 +5421,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
- (asdf-version "2.32")
+ (asdf-version "3.0.1")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
@@ -5205,7 +5438,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
#:find-system #:system-source-file #:system-relative-pathname ;; system
#:find-component ;; find-component
#:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
- #:component-depends-on #:component-self-dependencies #:operation-done-p
+ #:component-depends-on #:operation-done-p #:component-depends-on
#:traverse ;; plan
#:operate ;; operate
#:parse-component-form ;; defsystem
@@ -5219,15 +5452,17 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
(uninterned-symbols
'(#:*asdf-revision* #:around #:asdf-method-combination
#:split #:make-collector #:do-dep #:do-one-dep
+ #:component-self-dependencies
#:resolve-relative-location-component #:resolve-absolute-location-component
#:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
(declare (ignorable redefined-functions uninterned-symbols))
- (loop :for name :in (append #-(or ecl) redefined-functions)
+ (loop :for name :in (append redefined-functions)
:for sym = (find-symbol* name :asdf nil) :do
(when sym
- (fmakunbound sym)))
+ ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
+ #-clisp (fmakunbound sym)))
(loop :with asdf = (find-package :asdf)
- :for name :in (append #+(or ecl) redefined-functions uninterned-symbols) ;XXX
+ :for name :in uninterned-symbols
:for sym = (find-symbol* name :asdf nil)
:for base-pkg = (and sym (symbol-package sym)) :do
(when sym
@@ -5289,7 +5524,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
#:static-file #:doc-file #:html-file
#:file-type
#:source-file-type #:source-file-explicit-type ;; backward-compatibility
- #:component-in-order-to #:component-sibling-dependencies
+ #:component-in-order-to #:component-sideway-dependencies
#:component-if-feature #:around-compile-hook
#:component-description #:component-long-description
#:component-version #:version-satisfies
@@ -5308,7 +5543,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
#:components-by-name #:components
#:children #:children-by-name #:default-component-class
#:author #:maintainer #:licence #:source-file #:defsystem-depends-on
- #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
+ #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
#:relative-pathname #:absolute-pathname #:operation-times #:around-compile
#:%encoding #:properties #:component-properties #:parent))
(in-package :asdf/component)
@@ -5352,7 +5587,7 @@ another pathname in a degenerate way."))
(version :accessor component-version :initarg :version :initform nil)
(description :accessor component-description :initarg :description :initform nil)
(long-description :accessor component-long-description :initarg :long-description :initform nil)
- (sibling-dependencies :accessor component-sibling-dependencies :initform nil)
+ (sideway-dependencies :accessor component-sideway-dependencies :initform nil)
(if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
;; In the ASDF object model, dependencies exist between *actions*,
;; where an action is a pair of an operation and a component.
@@ -5547,7 +5782,7 @@ another pathname in a degenerate way."))
(version-satisfies (component-version c) version))
(defmethod version-satisfies ((cver string) version)
- (version-compatible-p cver version)))
+ (version<= version cver)))
;;; all sub-components (of a given type)
@@ -6288,7 +6523,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
(:export
#:operation
- #:operation-original-initargs ;; backward-compatibility only. DO NOT USE.
+ #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
#:build-op ;; THE generic operation
#:*operations* #:make-operation #:find-operation #:feature))
(in-package :asdf/operation)
@@ -6354,8 +6589,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(:export
#:action #:define-convenience-action-methods
#:explain #:action-description
- #:downward-operation #:upward-operation #:sibling-operation
- #:component-depends-on #:component-self-dependencies
+ #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
+ #:component-depends-on
#:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p
#:component-operation-time #:mark-operation-done #:compute-action-stamp
@@ -6433,7 +6668,7 @@ You can put together sentences using this phrase."))
;;;; Dependencies
(with-upgradability ()
- (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
+ (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies
(:documentation
"Returns a list of dependencies needed by the component to perform
the operation. A dependency has one of the following forms:
@@ -6451,19 +6686,15 @@ You can put together sentences using this phrase."))
Methods specialized on subclasses of existing component types
should usually append the results of CALL-NEXT-METHOD to the list."))
- (defgeneric component-self-dependencies (operation component))
(define-convenience-action-methods component-depends-on (operation component))
- (define-convenience-action-methods component-self-dependencies (operation component))
+
+ (defmethod component-depends-on :around ((o operation) (c component))
+ (do-asdf-cache `(component-depends-on ,o ,c)
+ (call-next-method)))
(defmethod component-depends-on ((o operation) (c component))
- (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
+ (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies
- (defmethod component-self-dependencies ((o operation) (c component))
- ;; NB: result in the same format as component-depends-on
- (loop* :for (o-spec . c-spec) :in (component-depends-on o c)
- :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature"
- :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep)))
- :collect (list o-spec c))))
;;;; upward-operation, downward-operation
;; These together handle actions that propagate along the component hierarchy.
@@ -6473,7 +6704,7 @@ You can put together sentences using this phrase."))
(with-upgradability ()
(defclass downward-operation (operation)
((downward-operation
- :initform nil :initarg :downward-operation :reader downward-operation)))
+ :initform nil :initarg :downward-operation :reader downward-operation :allocation :class)))
(defmethod component-depends-on ((o downward-operation) (c parent-component))
`((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
;; Upward operations like prepare-op propagate up the component hierarchy:
@@ -6481,7 +6712,7 @@ You can put together sentences using this phrase."))
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass upward-operation (operation)
((upward-operation
- :initform nil :initarg :downward-operation :reader upward-operation)))
+ :initform nil :initarg :downward-operation :reader upward-operation :allocation :class)))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF4: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component))
@@ -6490,13 +6721,22 @@ You can put together sentences using this phrase."))
;; Sibling operations propagate to siblings in the component hierarchy:
;; operation on a child depends-on operation on its parent.
;; By default, an operation propagates itself, but it may propagate another one instead.
- (defclass sibling-operation (operation)
- ((sibling-operation
- :initform nil :initarg :sibling-operation :reader sibling-operation)))
- (defmethod component-depends-on ((o sibling-operation) (c component))
- `((,(or (sibling-operation o) o)
- ,@(loop :for dep :in (component-sibling-dependencies c)
+ (defclass sideway-operation (operation)
+ ((sideway-operation
+ :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class)))
+ (defmethod component-depends-on ((o sideway-operation) (c component))
+ `((,(or (sideway-operation o) o)
+ ,@(loop :for dep :in (component-sideway-dependencies c)
:collect (resolve-dependency-spec c dep)))
+ ,@(call-next-method)))
+ ;; Selfward operations propagate to themselves a sub-operation:
+ ;; they depend on some other operation being acted on the same component.
+ (defclass selfward-operation (operation)
+ ((selfward-operation
+ :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class)))
+ (defmethod component-depends-on ((o selfward-operation) (c component))
+ `(,@(loop :for op :in (ensure-list (selfward-operation o))
+ :collect `(,op ,c))
,@(call-next-method))))
@@ -6546,17 +6786,16 @@ You can put together sentences using this phrase."))
(do-asdf-cache `(input-files ,operation ,component)
(call-next-method)))
- (defmethod input-files ((o operation) (c parent-component))
+ (defmethod input-files ((o operation) (c component))
(declare (ignorable o c))
nil)
- (defmethod input-files ((o operation) (c component))
- (or (loop* :for (dep-o) :in (component-self-dependencies o c)
- :append (or (output-files dep-o c) (input-files dep-o c)))
- ;; no non-trivial previous operations needed?
- ;; I guess we work with the original source file, then
- (if-let ((pathname (component-pathname c)))
- (and (file-pathname-p pathname) (list pathname))))))
+ (defmethod input-files ((o selfward-operation) (c component))
+ `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
+ :append (or (output-files dep-o c) (input-files dep-o c)))
+ (if-let ((pathname (component-pathname c)))
+ (and (file-pathname-p pathname) (list pathname))))
+ ,@(call-next-method))))
;;;; Done performing
@@ -6663,7 +6902,8 @@ in some previous image, or T if it needs to be done.")
#:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
#:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
#:call-with-around-compile-hook
- #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:flags))
+ #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source
+ #:lisp-compilation-output-files #:flags))
(in-package :asdf/lisp-action)
@@ -6687,17 +6927,23 @@ in some previous image, or T if it needs to be done.")
;;; Our default operations: loading into the current lisp image
(with-upgradability ()
- (defclass load-op (basic-load-op downward-operation sibling-operation) ())
- (defclass prepare-op (upward-operation sibling-operation)
- ((sibling-operation :initform 'load-op :allocation :class)))
- (defclass compile-op (basic-compile-op downward-operation)
- ((downward-operation :initform 'load-op :allocation :class)))
+ (defclass prepare-op (upward-operation sideway-operation)
+ ((sideway-operation :initform 'load-op)))
+ (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation)
+ ;; NB: even though compile-op depends-on on prepare-op it is not needed-in-image-p,
+ ;; so we need to directly depend on prepare-op for its side-effects in the current image.
+ ((selfward-operation :initform '(prepare-op compile-op))))
+ (defclass compile-op (basic-compile-op downward-operation selfward-operation)
+ ((selfward-operation :initform 'prepare-op)
+ (downward-operation :initform 'load-op)))
- (defclass load-source-op (basic-load-op downward-operation) ())
- (defclass prepare-source-op (upward-operation sibling-operation)
- ((sibling-operation :initform 'load-source-op :allocation :class)))
+ (defclass prepare-source-op (upward-operation sideway-operation)
+ ((sideway-operation :initform 'load-source-op)))
+ (defclass load-source-op (basic-load-op downward-operation selfward-operation)
+ ((selfward-operation :initform 'prepare-source-op)))
- (defclass test-op (operation) ()))
+ (defclass test-op (selfward-operation)
+ ((selfward-operation :initform 'load-op))))
;;;; prepare-op, compile-op and load-op
@@ -6773,8 +7019,7 @@ in some previous image, or T if it needs to be done.")
(format s ":success~%"))))))
(defmethod perform ((o compile-op) (c cl-source-file))
(perform-lisp-compilation o c))
- (defmethod output-files ((o compile-op) (c cl-source-file))
- (declare (ignorable o))
+ (defun lisp-compilation-output-files (o c)
(let* ((i (first (input-files o c)))
(f (compile-file-pathname
i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
@@ -6788,9 +7033,8 @@ in some previous image, or T if it needs to be done.")
,(compile-file-pathname i :fasl-p nil) ;; object file
,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c))))
`(,(make-pathname :type *warnings-file-type* :defaults f))))))
- (defmethod component-depends-on ((o compile-op) (c component))
- (declare (ignorable o))
- `((prepare-op ,c) ,@(call-next-method)))
+ (defmethod output-files ((o compile-op) (c cl-source-file))
+ (lisp-compilation-output-files o c))
(defmethod perform ((o compile-op) (c static-file))
(declare (ignorable o c))
nil)
@@ -6840,13 +7084,7 @@ in some previous image, or T if it needs to be done.")
(perform-lisp-load-fasl o c))
(defmethod perform ((o load-op) (c static-file))
(declare (ignorable o c))
- nil)
- (defmethod component-depends-on ((o load-op) (c component))
- (declare (ignorable o))
- ;; NB: even though compile-op depends-on on prepare-op,
- ;; it is not needed-in-image-p, whereas prepare-op is,
- ;; so better not omit prepare-op and think it will happen.
- `((prepare-op ,c) (compile-op ,c) ,@(call-next-method))))
+ nil))
;;;; prepare-source-op, load-source-op
@@ -6874,9 +7112,6 @@ in some previous image, or T if it needs to be done.")
(defmethod action-description ((o load-source-op) (c parent-component))
(declare (ignorable o))
(format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
- (defmethod component-depends-on ((o load-source-op) (c component))
- (declare (ignorable o))
- `((prepare-source-op ,c) ,@(call-next-method)))
(defun perform-lisp-load-source (o c)
(call-with-around-compile-hook
c #'(lambda ()
@@ -6902,11 +7137,7 @@ in some previous image, or T if it needs to be done.")
(defmethod operation-done-p ((o test-op) (c system))
"Testing a system is _never_ done."
(declare (ignorable o c))
- nil)
- (defmethod component-depends-on ((o test-op) (c system))
- (declare (ignorable o))
- `((load-op ,c) ,@(call-next-method))))
-
+ nil))
;;;; -------------------------------------------------------------------------
;;;; Plan
@@ -7151,9 +7382,9 @@ the action of OPERATION on COMPONENT in the PLAN"))
(and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c))))
(values done-stamp ;; return the hard-earned timestamp
(or just-done
- (or out-op ;; a file-creating op is done when all files are up to date
- ;; a image-effecting a placeholder op is done when it was actually run,
- (and op-time (eql op-time done-stamp))))) ;; with the matching stamp
+ out-op ;; a file-creating op is done when all files are up to date
+ ;; a image-effecting a placeholder op is done when it was actually run,
+ (and op-time (eql op-time done-stamp)))) ;; with the matching stamp
;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
(values t nil)))))
@@ -7280,7 +7511,7 @@ processed in order by OPERATE."))
(defgeneric perform-plan (plan &key))
(defgeneric plan-operates-on-p (plan component))
- (defparameter *default-plan-class* 'sequential-plan)
+ (defvar *default-plan-class* 'sequential-plan)
(defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
(let ((plan (apply 'make-instance
@@ -7296,9 +7527,10 @@ processed in order by OPERATE."))
(with-compilation-unit () ;; backward-compatibility.
(call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
- (defmethod perform-plan ((steps list) &key)
- (loop* :for (op . component) :in steps :do
- (perform-with-restarts op component)))
+ (defmethod perform-plan ((steps list) &key force &allow-other-keys)
+ (loop* :for (o . c) :in steps
+ :when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
+ :do (perform-with-restarts o c)))
(defmethod plan-operates-on-p ((plan list) (component-path list))
(find component-path (mapcar 'cdr plan)
@@ -7347,7 +7579,8 @@ processed in order by OPERATE."))
(defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
(remove-duplicates
- (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys))
+ (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system
+ (remove-plist-key :goal-operation keys)))
:from-end t)))
;;;; -------------------------------------------------------------------------
@@ -7440,7 +7673,7 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
(defmethod operate ((operation operation) (component component)
&rest keys &key &allow-other-keys)
(let ((plan (apply 'traverse operation component keys)))
- (perform-plan plan)
+ (apply 'perform-plan plan keys)
(values operation plan)))
(defun oos (operation component &rest args &key &allow-other-keys)
@@ -7563,1685 +7796,1705 @@ for how to load or compile stuff")
(register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
-;;;; ---------------------------------------------------------------------------
-;;;; asdf-output-translations
-
-(asdf/package:define-package :asdf/output-translations
- (:recycle :asdf/output-translations :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
- (:export
- #:*output-translations* #:*output-translations-parameter*
- #:invalid-output-translation
- #:output-translations #:output-translations-initialized-p
- #:initialize-output-translations #:clear-output-translations
- #:disable-output-translations #:ensure-output-translations
- #:apply-output-translations
- #:validate-output-translations-directive #:validate-output-translations-form
- #:validate-output-translations-file #:validate-output-translations-directory
- #:parse-output-translations-string #:wrapping-output-translations
- #:user-output-translations-pathname #:system-output-translations-pathname
- #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
- #:environment-output-translations #:process-output-translations
- #:compute-output-translations
- #+abcl #:translate-jar-pathname
- ))
-(in-package :asdf/output-translations)
+;;;; -------------------------------------------------------------------------
+;;; Internal hacks for backward-compatibility
-(when-upgrading () (undefine-function '(setf output-translations)))
+(asdf/package:define-package :asdf/backward-internals
+ (:recycle :asdf/backward-internals :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ :asdf/system :asdf/component :asdf/operation
+ :asdf/find-system :asdf/action :asdf/lisp-action)
+ (:export ;; for internal use
+ #:load-sysdef #:make-temporary-package
+ #:%refresh-component-inline-methods
+ #:%resolve-if-component-dep-fails
+ #:make-sub-operation
+ #:load-sysdef #:make-temporary-package))
+(in-package :asdf/backward-internals)
+;;;; Backward compatibility with "inline methods"
(with-upgradability ()
- (define-condition invalid-output-translation (invalid-configuration warning)
- ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-
- (defvar *output-translations* ()
- "Either NIL (for uninitialized), or a list of one element,
-said element itself being a sorted list of mappings.
-Each mapping is a pair of a source pathname and destination pathname,
-and the order is by decreasing length of namestring of the source pathname.")
+ (defparameter +asdf-methods+
+ '(perform-with-restarts perform explain output-files operation-done-p))
- (defun output-translations ()
- (car *output-translations*))
+ (defun %remove-component-inline-methods (component)
+ (dolist (name +asdf-methods+)
+ (map ()
+ ;; this is inefficient as most of the stored
+ ;; methods will not be for this particular gf
+ ;; But this is hardly performance-critical
+ #'(lambda (m)
+ (remove-method (symbol-function name) m))
+ (component-inline-methods component)))
+ (component-inline-methods component) nil)
- (defun set-output-translations (new-value)
- (setf *output-translations*
- (list
- (stable-sort (copy-list new-value) #'>
- :key #'(lambda (x)
- (etypecase (car x)
- ((eql t) -1)
- (pathname
- (let ((directory (pathname-directory (car x))))
- (if (listp directory) (length directory) 0))))))))
- new-value)
- (defsetf output-translations set-output-translations) ; works with gcl 2.6
+ (defun %define-component-inline-methods (ret rest)
+ (loop* :for (key value) :on rest :by #'cddr
+ :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
+ :when name :do
+ (destructuring-bind (op &rest body) value
+ (loop :for arg = (pop body)
+ :while (atom arg)
+ :collect arg :into qualifiers
+ :finally
+ (destructuring-bind (o c) arg
+ (pushnew
+ (eval `(defmethod ,name , at qualifiers ((,o ,op) (,c (eql ,ret))) , at body))
+ (component-inline-methods ret)))))))
- (defun output-translations-initialized-p ()
- (and *output-translations* t))
+ (defun %refresh-component-inline-methods (component rest)
+ ;; clear methods, then add the new ones
+ (%remove-component-inline-methods component)
+ (%define-component-inline-methods component rest)))
- (defun clear-output-translations ()
- "Undoes any initialization of the output translations."
- (setf *output-translations* '())
- (values))
- (register-clear-configuration-hook 'clear-output-translations)
+;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
+;; and the companion asdf:feature pseudo-dependency.
+;; This won't recurse into dependencies to accumulate feature conditions.
+;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
+;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
+(with-upgradability ()
+ (defun %resolve-if-component-dep-fails (if-component-dep-fails component)
+ (asdf-message "The system definition for ~S uses deprecated ~
+ ASDF option :IF-COMPONENT-DEP-DAILS. ~
+ Starting with ASDF 3, please use :IF-FEATURE instead"
+ (coerce-name (component-system component)))
+ ;; This only supports the pattern of use of the "feature" seen in the wild
+ (check-type component parent-component)
+ (check-type if-component-dep-fails (member :fail :ignore :try-next))
+ (unless (eq if-component-dep-fails :fail)
+ (loop :with o = (make-operation 'compile-op)
+ :for c :in (component-children component) :do
+ (loop* :for (feature? feature) :in (component-depends-on o c)
+ :when (eq feature? 'feature) :do
+ (setf (component-if-feature c) feature))))))
- (defun validate-output-translations-directive (directive)
- (or (member directive '(:enable-user-cache :disable-cache nil))
- (and (consp directive)
- (or (and (length=n-p directive 2)
- (or (and (eq (first directive) :include)
- (typep (second directive) '(or string pathname null)))
- (and (location-designator-p (first directive))
- (or (location-designator-p (second directive))
- (location-function-p (second directive))))))
- (and (length=n-p directive 1)
- (location-designator-p (first directive)))))))
+(when-upgrading (:when (fboundp 'make-sub-operation))
+ (defun make-sub-operation (c o dep-c dep-o)
+ (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
- (defun validate-output-translations-form (form &key location)
- (validate-configuration-form
- form
- :output-translations
- 'validate-output-translations-directive
- :location location :invalid-form-reporter 'invalid-output-translation))
- (defun validate-output-translations-file (file)
- (validate-configuration-file
- file 'validate-output-translations-form :description "output translations"))
+;;;; load-sysdef
+(with-upgradability ()
+ (defun load-sysdef (name pathname)
+ (load-asd pathname :name name))
- (defun validate-output-translations-directory (directory)
- (validate-configuration-directory
- directory :output-translations 'validate-output-translations-directive
- :invalid-form-reporter 'invalid-output-translation))
+ (defun make-temporary-package ()
+ ;; For loading a .asd file, we dont't make a temporary package anymore,
+ ;; but use ASDF-USER. I'd like to have this function do this,
+ ;; but since whoever uses it is likely to delete-package the result afterwards,
+ ;; this would be a bad idea, so preserve the old behavior.
+ (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
- (defun parse-output-translations-string (string &key location)
- (cond
- ((or (null string) (equal string ""))
- '(:output-translations :inherit-configuration))
- ((not (stringp string))
- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
- ((eql (char string 0) #\")
- (parse-output-translations-string (read-from-string string) :location location))
- ((eql (char string 0) #\()
- (validate-output-translations-form (read-from-string string) :location location))
- (t
- (loop
- :with inherit = nil
- :with directives = ()
- :with start = 0
- :with end = (length string)
- :with source = nil
- :with separator = (inter-directory-separator)
- :for i = (or (position separator string :start start) end) :do
- (let ((s (subseq string start i)))
- (cond
- (source
- (push (list source (if (equal "" s) nil s)) directives)
- (setf source nil))
- ((equal "" s)
- (when inherit
- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
- string))
- (setf inherit t)
- (push :inherit-configuration directives))
- (t
- (setf source s)))
- (setf start (1+ i))
- (when (> start end)
- (when source
- (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
- string))
- (unless inherit
- (push :ignore-inherited-configuration directives))
- (return `(:output-translations ,@(nreverse directives)))))))))
- (defparameter *default-output-translations*
- '(environment-output-translations
- user-output-translations-pathname
- user-output-translations-directory-pathname
- system-output-translations-pathname
- system-output-translations-directory-pathname))
+;;;; -------------------------------------------------------------------------
+;;;; Defsystem
- (defun wrapping-output-translations ()
- `(:output-translations
- ;; Some implementations have precompiled ASDF systems,
- ;; so we must disable translations for implementation paths.
- #+(or #|clozure|# ecl mkcl sbcl)
- ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
- (when h `(((,h ,*wild-path*) ()))))
- #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
- ;; All-import, here is where we want user stuff to be:
- :inherit-configuration
- ;; These are for convenience, and can be overridden by the user:
- #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
- #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
- ;; We enable the user cache by default, and here is the place we do:
- :enable-user-cache))
-
- (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
- (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
+(asdf/package:define-package :asdf/defsystem
+ (:recycle :asdf/defsystem :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ :asdf/component :asdf/system :asdf/cache
+ :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
+ :asdf/backward-internals)
+ (:export
+ #:defsystem #:register-system-definition
+ #:class-for-type #:*default-component-class*
+ #:determine-system-directory #:parse-component-form
+ #:duplicate-names #:non-toplevel-system #:non-system-system
+ #:sysdef-error-component #:check-component-input))
+(in-package :asdf/defsystem)
- (defun user-output-translations-pathname (&key (direction :input))
- (in-user-configuration-directory *output-translations-file* :direction direction))
- (defun system-output-translations-pathname (&key (direction :input))
- (in-system-configuration-directory *output-translations-file* :direction direction))
- (defun user-output-translations-directory-pathname (&key (direction :input))
- (in-user-configuration-directory *output-translations-directory* :direction direction))
- (defun system-output-translations-directory-pathname (&key (direction :input))
- (in-system-configuration-directory *output-translations-directory* :direction direction))
- (defun environment-output-translations ()
- (getenv "ASDF_OUTPUT_TRANSLATIONS"))
+;;; Pathname
+(with-upgradability ()
+ (defun determine-system-directory (pathname)
+ ;; The defsystem macro calls this function to determine
+ ;; the pathname of a system as follows:
+ ;; 1. if the pathname argument is an pathname object (NOT a namestring),
+ ;; that is already an absolute pathname, return it.
+ ;; 2. otherwise, the directory containing the LOAD-PATHNAME
+ ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
+ ;; if it is indeed available and an absolute pathname, then
+ ;; the PATHNAME argument is normalized to a relative pathname
+ ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
+ ;; and merged into that DIRECTORY as per SUBPATHNAME.
+ ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
+ ;; and may be from within the EVAL-WHEN of a file compilation.
+ ;; If no absolute pathname was found, we return NIL.
+ (check-type pathname (or null string pathname))
+ (pathname-directory-pathname
+ (resolve-symlinks*
+ (ensure-absolute-pathname
+ (parse-unix-namestring pathname :type :directory)
+ #'(lambda () (ensure-absolute-pathname
+ (load-pathname) 'get-pathname-defaults nil))
+ nil)))))
- (defgeneric process-output-translations (spec &key inherit collect))
- (defun inherit-output-translations (inherit &key collect)
- (when inherit
- (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
+;;; Component class
+(with-upgradability ()
+ (defvar *default-component-class* 'cl-source-file)
- (defun* (process-output-translations-directive) (directive &key inherit collect)
- (if (atom directive)
- (ecase directive
- ((:enable-user-cache)
- (process-output-translations-directive '(t :user-cache) :collect collect))
- ((:disable-cache)
- (process-output-translations-directive '(t t) :collect collect))
- ((:inherit-configuration)
- (inherit-output-translations inherit :collect collect))
- ((:ignore-inherited-configuration :ignore-invalid-entries nil)
- nil))
- (let ((src (first directive))
- (dst (second directive)))
- (if (eq src :include)
- (when dst
- (process-output-translations (pathname dst) :inherit nil :collect collect))
- (when src
- (let ((trusrc (or (eql src t)
- (let ((loc (resolve-location src :ensure-directory t :wilden t)))
- (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
- (cond
- ((location-function-p dst)
- (funcall collect
- (list trusrc
- (if (symbolp (second dst))
- (fdefinition (second dst))
- (eval (second dst))))))
- ((eq dst t)
- (funcall collect (list trusrc t)))
- (t
- (let* ((trudst (if dst
- (resolve-location dst :ensure-directory t :wilden t)
- trusrc)))
- (funcall collect (list trudst t))
- (funcall collect (list trusrc trudst)))))))))))
+ (defun class-for-type (parent type)
+ (or (loop :for symbol :in (list
+ type
+ (find-symbol* type *package* nil)
+ (find-symbol* type :asdf/interface nil)
+ (and (stringp type) (safe-read-from-string type :package :asdf/interface)))
+ :for class = (and symbol (symbolp symbol) (find-class* symbol nil))
+ :when (and class
+ (#-cormanlisp subtypep #+cormanlisp cl::subclassp
+ class (find-class* 'component)))
+ :return class)
+ (and (eq type :file)
+ (find-class*
+ (or (loop :for p = parent :then (component-parent p) :while p
+ :thereis (module-default-component-class p))
+ *default-component-class*) nil))
+ (sysdef-error "don't recognize component type ~A" type))))
- (defmethod process-output-translations ((x symbol) &key
- (inherit *default-output-translations*)
- collect)
- (process-output-translations (funcall x) :inherit inherit :collect collect))
- (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
- (cond
- ((directory-pathname-p pathname)
- (process-output-translations (validate-output-translations-directory pathname)
- :inherit inherit :collect collect))
- ((probe-file* pathname :truename *resolve-symlinks*)
- (process-output-translations (validate-output-translations-file pathname)
- :inherit inherit :collect collect))
- (t
- (inherit-output-translations inherit :collect collect))))
- (defmethod process-output-translations ((string string) &key inherit collect)
- (process-output-translations (parse-output-translations-string string)
- :inherit inherit :collect collect))
- (defmethod process-output-translations ((x null) &key inherit collect)
- (declare (ignorable x))
- (inherit-output-translations inherit :collect collect))
- (defmethod process-output-translations ((form cons) &key inherit collect)
- (dolist (directive (cdr (validate-output-translations-form form)))
- (process-output-translations-directive directive :inherit inherit :collect collect)))
- (defun compute-output-translations (&optional parameter)
- "read the configuration, return it"
- (remove-duplicates
- (while-collecting (c)
- (inherit-output-translations
- `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
- :test 'equal :from-end t))
+;;; Check inputs
+(with-upgradability ()
+ (define-condition duplicate-names (system-definition-error)
+ ((name :initarg :name :reader duplicate-names-name))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
+ (duplicate-names-name c)))))
- (defvar *output-translations-parameter* nil)
+ (define-condition non-system-system (system-definition-error)
+ ((name :initarg :name :reader non-system-system-name)
+ (class-name :initarg :class-name :reader non-system-system-class-name))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
+ (non-system-system-name c) (non-system-system-class-name c) 'system))))
- (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
- "read the configuration, initialize the internal configuration variable,
-return the configuration"
- (setf *output-translations-parameter* parameter
- (output-translations) (compute-output-translations parameter)))
+ (define-condition non-toplevel-system (system-definition-error)
+ ((parent :initarg :parent :reader non-toplevel-system-parent)
+ (name :initarg :name :reader non-toplevel-system-name))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
+ (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
- (defun disable-output-translations ()
- "Initialize output translations in a way that maps every file to itself,
-effectively disabling the output translation facility."
- (initialize-output-translations
- '(:output-translations :disable-cache :ignore-inherited-configuration)))
+ (defun sysdef-error-component (msg type name value)
+ (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
+ type name value))
- ;; checks an initial variable to see whether the state is initialized
- ;; or cleared. In the former case, return current configuration; in
- ;; the latter, initialize. ASDF will call this function at the start
- ;; of (asdf:find-system).
- (defun ensure-output-translations ()
- (if (output-translations-initialized-p)
- (output-translations)
- (initialize-output-translations)))
+ (defun check-component-input (type name weakly-depends-on
+ depends-on components)
+ "A partial test of the values of a component."
+ (unless (listp depends-on)
+ (sysdef-error-component ":depends-on must be a list."
+ type name depends-on))
+ (unless (listp weakly-depends-on)
+ (sysdef-error-component ":weakly-depends-on must be a list."
+ type name weakly-depends-on))
+ (unless (listp components)
+ (sysdef-error-component ":components must be NIL or a list of components."
+ type name components)))
- (defun* (apply-output-translations) (path)
- (etypecase path
- (logical-pathname
- path)
- ((or pathname string)
- (ensure-output-translations)
- (loop* :with p = (resolve-symlinks* path)
- :for (source destination) :in (car *output-translations*)
- :for root = (when (or (eq source t)
- (and (pathnamep source)
- (not (absolute-pathname-p source))))
- (pathname-root p))
- :for absolute-source = (cond
- ((eq source t) (wilden root))
- (root (merge-pathnames* source root))
- (t source))
- :when (or (eq source t) (pathname-match-p p absolute-source))
- :return (translate-pathname* p absolute-source destination root source)
- :finally (return p)))))
+ (defun* (normalize-version) (form &key pathname component parent)
+ (labels ((invalid (&optional (continuation "using NIL instead"))
+ (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
+ form component parent pathname continuation))
+ (invalid-parse (control &rest args)
+ (unless (builtin-system-p (find-component parent component))
+ (apply 'warn control args)
+ (invalid))))
+ (if-let (v (typecase form
+ ((or string null) form)
+ (real
+ (invalid "Substituting a string")
+ (format nil "~D" form)) ;; 1.0 becomes "1.0"
+ (cons
+ (case (first form)
+ ((:read-file-form)
+ (destructuring-bind (subpath &key (at 0)) (rest form)
+ (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user)))
+ ((:read-file-line)
+ (destructuring-bind (subpath &key (at 0)) (rest form)
+ (read-file-lines (subpathname pathname subpath) :at at)))
+ (otherwise
+ (invalid))))
+ (t
+ (invalid))))
+ (if-let (pv (parse-version v #'invalid-parse))
+ (unparse-version pv)
+ (invalid))))))
- ;; Hook into asdf/driver's output-translation mechanism
- #-cormanlisp
- (setf *output-translation-function* 'apply-output-translations)
-
- #+abcl
- (defun translate-jar-pathname (source wildcard)
- (declare (ignore wildcard))
- (flet ((normalize-device (pathname)
- (if (find :windows *features*)
- pathname
- (make-pathname :defaults pathname :device :unspecific))))
- (let* ((jar
- (pathname (first (pathname-device source))))
- (target-root-directory-namestring
- (format nil "/___jar___file___root___/~@[~A/~]"
- (and (find :windows *features*)
- (pathname-device jar))))
- (relative-source
- (relativize-pathname-directory source))
- (relative-jar
- (relativize-pathname-directory (ensure-directory-pathname jar)))
- (target-root-directory
- (normalize-device
- (pathname-directory-pathname
- (parse-namestring target-root-directory-namestring))))
- (target-root
- (merge-pathnames* relative-jar target-root-directory))
- (target
- (merge-pathnames* relative-source target-root)))
- (normalize-device (apply-output-translations target))))))
-
-;;;; -----------------------------------------------------------------
-;;;; Source Registry Configuration, by Francois-Rene Rideau
-;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
-
-(asdf/package:define-package :asdf/source-registry
- (:recycle :asdf/source-registry :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
- (:export
- #:*source-registry-parameter* #:*default-source-registries*
- #:invalid-source-registry
- #:source-registry-initialized-p
- #:initialize-source-registry #:clear-source-registry #:*source-registry*
- #:ensure-source-registry #:*source-registry-parameter*
- #:*default-source-registry-exclusions* #:*source-registry-exclusions*
- #:*wild-asd* #:directory-asd-files #:register-asd-directory
- #:collect-asds-in-directory #:collect-sub*directories-asd-files
- #:validate-source-registry-directive #:validate-source-registry-form
- #:validate-source-registry-file #:validate-source-registry-directory
- #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
- #:user-source-registry #:system-source-registry
- #:user-source-registry-directory #:system-source-registry-directory
- #:environment-source-registry #:process-source-registry
- #:compute-source-registry #:flatten-source-registry
- #:sysdef-source-registry-search))
-(in-package :asdf/source-registry)
+;;; Main parsing function
(with-upgradability ()
- (define-condition invalid-source-registry (invalid-configuration warning)
- ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-
- ;; Using ack 1.2 exclusions
- (defvar *default-source-registry-exclusions*
- '(".bzr" ".cdv"
- ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
- ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
- "_sgbak" "autom4te.cache" "cover_db" "_build"
- "debian")) ;; debian often builds stuff under the debian directory... BAD.
-
- (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
-
- (defvar *source-registry* nil
- "Either NIL (for uninitialized), or an equal hash-table, mapping
-system names to pathnames of .asd files")
-
- (defun source-registry-initialized-p ()
- (typep *source-registry* 'hash-table))
-
- (defun clear-source-registry ()
- "Undoes any initialization of the source registry."
- (setf *source-registry* nil)
- (values))
- (register-clear-configuration-hook 'clear-source-registry)
-
- (defparameter *wild-asd*
- (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
-
- (defun directory-asd-files (directory)
- (directory-files directory *wild-asd*))
-
- (defun collect-asds-in-directory (directory collect)
- (map () collect (directory-asd-files directory)))
-
- (defun collect-sub*directories-asd-files
- (directory &key (exclude *default-source-registry-exclusions*) collect)
- (collect-sub*directories
- directory
- (constantly t)
- #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
- #'(lambda (dir) (collect-asds-in-directory dir collect))))
-
- (defun validate-source-registry-directive (directive)
- (or (member directive '(:default-registry))
- (and (consp directive)
- (let ((rest (rest directive)))
- (case (first directive)
- ((:include :directory :tree)
- (and (length=n-p rest 1)
- (location-designator-p (first rest))))
- ((:exclude :also-exclude)
- (every #'stringp rest))
- ((:default-registry)
- (null rest)))))))
-
- (defun validate-source-registry-form (form &key location)
- (validate-configuration-form
- form :source-registry 'validate-source-registry-directive
- :location location :invalid-form-reporter 'invalid-source-registry))
-
- (defun validate-source-registry-file (file)
- (validate-configuration-file
- file 'validate-source-registry-form :description "a source registry"))
-
- (defun validate-source-registry-directory (directory)
- (validate-configuration-directory
- directory :source-registry 'validate-source-registry-directive
- :invalid-form-reporter 'invalid-source-registry))
-
- (defun parse-source-registry-string (string &key location)
- (cond
- ((or (null string) (equal string ""))
- '(:source-registry :inherit-configuration))
- ((not (stringp string))
- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
- ((find (char string 0) "\"(")
- (validate-source-registry-form (read-from-string string) :location location))
- (t
- (loop
- :with inherit = nil
- :with directives = ()
- :with start = 0
- :with end = (length string)
- :with separator = (inter-directory-separator)
- :for pos = (position separator string :start start) :do
- (let ((s (subseq string start (or pos end))))
- (flet ((check (dir)
- (unless (absolute-pathname-p dir)
- (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
- dir))
- (cond
- ((equal "" s) ; empty element: inherit
- (when inherit
- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
- string))
- (setf inherit t)
- (push ':inherit-configuration directives))
- ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
- (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
- (t
- (push `(:directory ,(check s)) directives))))
- (cond
- (pos
- (setf start (1+ pos)))
- (t
- (unless inherit
- (push '(:ignore-inherited-configuration) directives))
- (return `(:source-registry ,@(nreverse directives))))))))))
-
- (defun register-asd-directory (directory &key recurse exclude collect)
- (if (not recurse)
- (collect-asds-in-directory directory collect)
- (collect-sub*directories-asd-files
- directory :exclude exclude :collect collect)))
-
- (defparameter *default-source-registries*
- '(environment-source-registry
- user-source-registry
- user-source-registry-directory
- system-source-registry
- system-source-registry-directory
- default-source-registry))
-
- (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
- (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
-
- (defun wrapping-source-registry ()
- `(:source-registry
- #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
- #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
- :inherit-configuration
- #+cmu (:tree #p"modules:")
- #+scl (:tree #p"file://modules/")))
- (defun default-source-registry ()
- `(:source-registry
- #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
- ,@(loop :for dir :in
- `(,@(when (os-unix-p)
- `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
- (subpathname (user-homedir-pathname) ".local/share/"))
- ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
- '("/usr/local/share" "/usr/share"))))
- ,@(when (os-windows-p)
- (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
- :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
- :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
- :inherit-configuration))
- (defun user-source-registry (&key (direction :input))
- (in-user-configuration-directory *source-registry-file* :direction direction))
- (defun system-source-registry (&key (direction :input))
- (in-system-configuration-directory *source-registry-file* :direction direction))
- (defun user-source-registry-directory (&key (direction :input))
- (in-user-configuration-directory *source-registry-directory* :direction direction))
- (defun system-source-registry-directory (&key (direction :input))
- (in-system-configuration-directory *source-registry-directory* :direction direction))
- (defun environment-source-registry ()
- (getenv "CL_SOURCE_REGISTRY"))
+ (defun* (parse-component-form) (parent options &key previous-serial-component)
+ (destructuring-bind
+ (type name &rest rest &key
+ (builtin-system-p () bspp)
+ ;; the following list of keywords is reproduced below in the
+ ;; remove-plist-keys form. important to keep them in sync
+ components pathname perform explain output-files operation-done-p
+ weakly-depends-on depends-on serial
+ do-first if-component-dep-fails version
+ ;; list ends
+ &allow-other-keys) options
+ (declare (ignorable perform explain output-files operation-done-p builtin-system-p))
+ (check-component-input type name weakly-depends-on depends-on components)
+ (when (and parent
+ (find-component parent name)
+ (not ;; ignore the same object when rereading the defsystem
+ (typep (find-component parent name)
+ (class-for-type parent type))))
+ (error 'duplicate-names :name name))
+ (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
+ (let* ((name (coerce-name name))
+ (args `(:name ,name
+ :pathname ,pathname
+ ,@(when parent `(:parent ,parent))
+ ,@(remove-plist-keys
+ '(:components :pathname :if-component-dep-fails :version
+ :perform :explain :output-files :operation-done-p
+ :weakly-depends-on :depends-on :serial)
+ rest)))
+ (component (find-component parent name))
+ (class (class-for-type parent type)))
+ (when (and parent (subtypep class 'system))
+ (error 'non-toplevel-system :parent parent :name name))
+ (if component ; preserve identity
+ (apply 'reinitialize-instance component args)
+ (setf component (apply 'make-instance class args)))
+ (component-pathname component) ; eagerly compute the absolute pathname
+ (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
+ (when (and (typep component 'system) (not bspp))
+ (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
+ (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
+ ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
+ ;; A better fix is required.
+ (setf (slot-value component 'version) version)
+ (when (typep component 'parent-component)
+ (setf (component-children component)
+ (loop
+ :with previous-component = nil
+ :for c-form :in components
+ :for c = (parse-component-form component c-form
+ :previous-serial-component previous-component)
+ :for name = (component-name c)
+ :collect c
+ :when serial :do (setf previous-component name)))
+ (compute-children-by-name component))
+ (when previous-serial-component
+ (push previous-serial-component depends-on))
+ (when weakly-depends-on
+ ;; ASDF4: deprecate this feature and remove it.
+ (appendf depends-on
+ (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
+ ;; Used by POIU. ASDF4: rename to component-depends-on?
+ (setf (component-sideway-dependencies component) depends-on)
+ (%refresh-component-inline-methods component rest)
+ (when if-component-dep-fails
+ (%resolve-if-component-dep-fails if-component-dep-fails component))
+ component)))
- (defgeneric* (process-source-registry) (spec &key inherit register))
+ (defun register-system-definition
+ (name &rest options &key pathname (class 'system) (source-file () sfp)
+ defsystem-depends-on &allow-other-keys)
+ ;; The system must be registered before we parse the body,
+ ;; otherwise we recur when trying to find an existing system
+ ;; of the same name to reuse options (e.g. pathname) from.
+ ;; To avoid infinite recursion in cases where you defsystem a system
+ ;; that is registered to a different location to find-system,
+ ;; we also need to remember it in a special variable *systems-being-defined*.
+ (with-system-definitions ()
+ (let* ((name (coerce-name name))
+ (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
+ (registered (system-registered-p name))
+ (registered! (if registered
+ (rplaca registered (get-file-stamp source-file))
+ (register-system
+ (make-instance 'system :name name :source-file source-file))))
+ (system (reset-system (cdr registered!)
+ :name name :source-file source-file))
+ (component-options (remove-plist-key :class options))
+ (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
+ (resolve-dependency-spec nil spec))))
+ (setf (gethash name *systems-being-defined*) system)
+ (apply 'load-systems defsystem-dependencies)
+ ;; We change-class AFTER we loaded the defsystem-depends-on
+ ;; since the class might be defined as part of those.
+ (let ((class (class-for-type nil class)))
+ (unless (subtypep class 'system)
+ (error 'non-system-system :name name :class-name (class-name class)))
+ (unless (eq (type-of system) class)
+ (change-class system class)))
+ (parse-component-form
+ nil (list*
+ :module name
+ :pathname (determine-system-directory pathname)
+ component-options)))))
- (defun* (inherit-source-registry) (inherit &key register)
- (when inherit
- (process-source-registry (first inherit) :register register :inherit (rest inherit))))
+ (defmacro defsystem (name &body options)
+ `(apply 'register-system-definition ',name ',options)))
+;;;; -------------------------------------------------------------------------
+;;;; ASDF-Bundle
- (defun* (process-source-registry-directive) (directive &key inherit register)
- (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
- (ecase kw
- ((:include)
- (destructuring-bind (pathname) rest
- (process-source-registry (resolve-location pathname) :inherit nil :register register)))
- ((:directory)
- (destructuring-bind (pathname) rest
- (when pathname
- (funcall register (resolve-location pathname :ensure-directory t)))))
- ((:tree)
- (destructuring-bind (pathname) rest
- (when pathname
- (funcall register (resolve-location pathname :ensure-directory t)
- :recurse t :exclude *source-registry-exclusions*))))
- ((:exclude)
- (setf *source-registry-exclusions* rest))
- ((:also-exclude)
- (appendf *source-registry-exclusions* rest))
- ((:default-registry)
- (inherit-source-registry '(default-source-registry) :register register))
- ((:inherit-configuration)
- (inherit-source-registry inherit :register register))
- ((:ignore-inherited-configuration)
- nil)))
- nil)
+(asdf/package:define-package :asdf/bundle
+ (:recycle :asdf/bundle :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
+ :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
+ (:export
+ #:bundle-op #:bundle-op-build-args #:bundle-type
+ #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
+ #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
+ #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
+ #:lib-op #:monolithic-lib-op
+ #:dll-op #:monolithic-dll-op
+ #:binary-op #:monolithic-binary-op
+ #:program-op #:compiled-file #:precompiled-system #:prebuilt-system
+ #:user-system-p #:user-system #:trivial-system-p
+ #+ecl #:make-build
+ #:register-pre-built-system
+ #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
+(in-package :asdf/bundle)
- (defmethod process-source-registry ((x symbol) &key inherit register)
- (process-source-registry (funcall x) :inherit inherit :register register))
- (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
- (cond
- ((directory-pathname-p pathname)
- (let ((*here-directory* (resolve-symlinks* pathname)))
- (process-source-registry (validate-source-registry-directory pathname)
- :inherit inherit :register register)))
- ((probe-file* pathname :truename *resolve-symlinks*)
- (let ((*here-directory* (pathname-directory-pathname pathname)))
- (process-source-registry (validate-source-registry-file pathname)
- :inherit inherit :register register)))
- (t
- (inherit-source-registry inherit :register register))))
- (defmethod process-source-registry ((string string) &key inherit register)
- (process-source-registry (parse-source-registry-string string)
- :inherit inherit :register register))
- (defmethod process-source-registry ((x null) &key inherit register)
- (declare (ignorable x))
- (inherit-source-registry inherit :register register))
- (defmethod process-source-registry ((form cons) &key inherit register)
- (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
- (dolist (directive (cdr (validate-source-registry-form form)))
- (process-source-registry-directive directive :inherit inherit :register register))))
+(with-upgradability ()
+ (defclass bundle-op (operation)
+ ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
+ (name-suffix :initarg :name-suffix :initform nil)
+ (bundle-type :initform :no-output-file :reader bundle-type)
+ #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
+ #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
+ #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
- (defun flatten-source-registry (&optional parameter)
- (remove-duplicates
- (while-collecting (collect)
- (with-pathname-defaults () ;; be location-independent
- (inherit-source-registry
- `(wrapping-source-registry
- ,parameter
- ,@*default-source-registries*)
- :register #'(lambda (directory &key recurse exclude)
- (collect (list directory :recurse recurse :exclude exclude))))))
- :test 'equal :from-end t))
+ (defclass bundle-compile-op (bundle-op basic-compile-op)
+ ()
+ (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files"))
- ;; Will read the configuration and initialize all internal variables.
- (defun compute-source-registry (&optional parameter (registry *source-registry*))
- (dolist (entry (flatten-source-registry parameter))
- (destructuring-bind (directory &key recurse exclude) entry
- (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
- (register-asd-directory
- directory :recurse recurse :exclude exclude :collect
- #'(lambda (asd)
- (let* ((name (pathname-name asd))
- (name (if (typep asd 'logical-pathname)
- ;; logical pathnames are upper-case,
- ;; at least in the CLHS and on SBCL,
- ;; yet (coerce-name :foo) is lower-case.
- ;; won't work well with (load-system "Foo")
- ;; instead of (load-system 'foo)
- (string-downcase name)
- name)))
- (cond
- ((gethash name registry) ; already shadowed by something else
- nil)
- ((gethash name h) ; conflict at current level
- (when *verbose-out*
- (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
- found several entries for ~A - picking ~S over ~S~:>")
- directory recurse name (gethash name h) asd)))
- (t
- (setf (gethash name registry) asd)
- (setf (gethash name h) asd))))))
- h)))
- (values))
+ ;; create a single fasl for the entire library
+ (defclass basic-fasl-op (bundle-compile-op)
+ ((bundle-type :initform :fasl)))
+ (defclass prepare-fasl-op (sideway-operation)
+ ((sideway-operation :initform 'load-fasl-op)))
+ (defclass fasl-op (basic-fasl-op selfward-operation)
+ ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op))))
+ (defclass load-fasl-op (basic-load-op selfward-operation)
+ ((selfward-operation :initform '(prepare-op fasl-op))))
+
+ ;; NB: since the monolithic-op's can't be sideway-operation's,
+ ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's,
+ ;; we'd have to have the monolithic-op not inherit from the main op,
+ ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
+
+ (defclass lib-op (bundle-compile-op)
+ ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
+ (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it."
+ #-(or ecl mkcl) "just compile the system"))
+
+ (defclass dll-op (bundle-op basic-compile-op)
+ ((bundle-type :initform :dll))
+ (:documentation "Link together all the dynamic library used by this system into a single one."))
+
+ (defclass binary-op (basic-compile-op selfward-operation)
+ ((selfward-operation :initform '(fasl-op lib-op)))
+ (:documentation "produce fasl and asd files for the system"))
- (defvar *source-registry-parameter* nil)
+ (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
- (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
- ;; Record the parameter used to configure the registry
- (setf *source-registry-parameter* parameter)
- ;; Clear the previous registry database:
- (setf *source-registry* (make-hash-table :test 'equal))
- ;; Do it!
- (compute-source-registry parameter))
+ (defclass monolithic-bundle-op (monolithic-op bundle-op)
+ ((prologue-code :accessor monolithic-op-prologue-code)
+ (epilogue-code :accessor monolithic-op-epilogue-code)))
- ;; Checks an initial variable to see whether the state is initialized
- ;; or cleared. In the former case, return current configuration; in
- ;; the latter, initialize. ASDF will call this function at the start
- ;; of (asdf:find-system) to make sure the source registry is initialized.
- ;; However, it will do so *without* a parameter, at which point it
- ;; will be too late to provide a parameter to this function, though
- ;; you may override the configuration explicitly by calling
- ;; initialize-source-registry directly with your parameter.
- (defun ensure-source-registry (&optional parameter)
- (unless (source-registry-initialized-p)
- (initialize-source-registry parameter))
- (values))
+ (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op)
+ ()
+ (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems"))
- (defun sysdef-source-registry-search (system)
- (ensure-source-registry)
- (values (gethash (primary-system-name system) *source-registry*))))
+ (defclass monolithic-binary-op (monolithic-op binary-op)
+ ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op)))
+ (:documentation "produce fasl and asd files for combined system and dependencies."))
+ (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) ()
+ (:documentation "Create a single fasl for the system and its dependencies."))
-;;;; -------------------------------------------------------------------------
-;;; Internal hacks for backward-compatibility
+ (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op)
+ ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
+ (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies."
+ #-(or ecl mkcl) "Compile a system and its dependencies."))
-(asdf/package:define-package :asdf/backward-internals
- (:recycle :asdf/backward-internals :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/system :asdf/component :asdf/operation
- :asdf/find-system :asdf/action :asdf/lisp-action)
- (:export ;; for internal use
- #:load-sysdef #:make-temporary-package
- #:%refresh-component-inline-methods
- #:%resolve-if-component-dep-fails
- #:make-sub-operation
- #:load-sysdef #:make-temporary-package))
-(in-package :asdf/backward-internals)
+ (defclass monolithic-dll-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation)
+ ((bundle-type :initform :dll)
+ (selfward-operation :initform 'dll-op)
+ (sideway-operation :initform 'dll-op)))
-;;;; Backward compatibility with "inline methods"
-(with-upgradability ()
- (defparameter +asdf-methods+
- '(perform-with-restarts perform explain output-files operation-done-p))
+ (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op)
+ #-(or mkcl ecl) (monolithic-bundle-op selfward-operation)
+ ((bundle-type :initform :program)
+ #-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op))
+ (:documentation "create an executable file from the system and its dependencies"))
- (defun %remove-component-inline-methods (component)
- (dolist (name +asdf-methods+)
- (map ()
- ;; this is inefficient as most of the stored
- ;; methods will not be for this particular gf
- ;; But this is hardly performance-critical
- #'(lambda (m)
- (remove-method (symbol-function name) m))
- (component-inline-methods component)))
- (component-inline-methods component) nil)
+ (defun bundle-pathname-type (bundle-type)
+ (etypecase bundle-type
+ ((eql :no-output-file) nil) ;; should we error out instead?
+ ((or null string) bundle-type)
+ ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
+ #+ecl
+ ((member :binary :dll :lib :static-library :program :object :program)
+ (compile-file-type :type bundle-type))
+ ((eql :binary) "image")
+ ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
+ ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
+ ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
- (defun %define-component-inline-methods (ret rest)
- (dolist (name +asdf-methods+)
- (let ((keyword (intern (symbol-name name) :keyword)))
- (loop :for data = rest :then (cddr data)
- :for key = (first data)
- :for value = (second data)
- :while data
- :when (eq key keyword) :do
- (destructuring-bind (op qual? &rest rest) value
- (multiple-value-bind (qual args-and-body)
- (if (symbolp qual?)
- (values (list qual?) rest)
- (values nil (cons qual? rest)))
- (destructuring-bind ((o c) &body body) args-and-body
- (pushnew
- (eval `(defmethod ,name , at qual ((,o ,op) (,c (eql ,ret)))
- , at body))
- (component-inline-methods ret)))))))))
+ (defun bundle-output-files (o c)
+ (when (input-files o c)
+ (let ((bundle-type (bundle-type o)))
+ (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
+ (let ((name (or (component-build-pathname c)
+ (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
+ (type (bundle-pathname-type bundle-type)))
+ (values (list (subpathname (component-pathname c) name :type type))
+ (eq (type-of o) (component-build-operation c))))))))
- (defun %refresh-component-inline-methods (component rest)
- ;; clear methods, then add the new ones
- (%remove-component-inline-methods component)
- (%define-component-inline-methods component rest)))
+ (defmethod output-files ((o bundle-op) (c system))
+ (bundle-output-files o c))
-;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
-;; and the companion asdf:feature pseudo-dependency.
-;; This won't recurse into dependencies to accumulate feature conditions.
-;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
-;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
+ #-(or ecl mkcl)
+ (defmethod perform ((o program-op) (c system))
+ (let ((output-file (output-file o c)))
+ (setf *image-entry-point* (ensure-function (component-entry-point c)))
+ (dump-image output-file :executable t)))
+
+ (defclass compiled-file (file-component)
+ ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
+
+ (defclass precompiled-system (system)
+ ((build-pathname :initarg :fasl)))
+
+ (defclass prebuilt-system (system)
+ ((build-pathname :initarg :static-library :initarg :lib
+ :accessor prebuilt-system-static-library))))
+
+
+;;;
+;;; BUNDLE-OP
+;;;
+;;; This operation takes all components from one or more systems and
+;;; creates a single output file, which may be
+;;; a FASL, a statically linked library, a shared library, etc.
+;;; The different targets are defined by specialization.
+;;;
(with-upgradability ()
- (defun %resolve-if-component-dep-fails (if-component-dep-fails component)
- (asdf-message "The system definition for ~S uses deprecated ~
- ASDF option :IF-COMPONENT-DEP-DAILS. ~
- Starting with ASDF 3, please use :IF-FEATURE instead"
- (coerce-name (component-system component)))
- ;; This only supports the pattern of use of the "feature" seen in the wild
- (check-type component parent-component)
- (check-type if-component-dep-fails (member :fail :ignore :try-next))
- (unless (eq if-component-dep-fails :fail)
- (loop :with o = (make-operation 'compile-op)
- :for c :in (component-children component) :do
- (loop* :for (feature? feature) :in (component-depends-on o c)
- :when (eq feature? 'feature) :do
- (setf (component-if-feature c) feature))))))
+ (defun operation-monolithic-p (op)
+ (typep op 'monolithic-op))
-(when-upgrading (:when (fboundp 'make-sub-operation))
- (defun make-sub-operation (c o dep-c dep-o)
- (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
+ (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
+ &key (name-suffix nil name-suffix-p)
+ &allow-other-keys)
+ (declare (ignorable initargs name-suffix))
+ (unless name-suffix-p
+ (setf (slot-value instance 'name-suffix)
+ (unless (typep instance 'program-op)
+ (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames
+ (when (typep instance 'monolithic-bundle-op)
+ (destructuring-bind (&rest original-initargs
+ &key lisp-files prologue-code epilogue-code
+ &allow-other-keys)
+ (operation-original-initargs instance)
+ (setf (operation-original-initargs instance)
+ (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
+ (monolithic-op-prologue-code instance) prologue-code
+ (monolithic-op-epilogue-code instance) epilogue-code)
+ #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
+ #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
+ (setf (bundle-op-build-args instance)
+ (remove-plist-keys '(:type :monolithic :name-suffix)
+ (operation-original-initargs instance))))
+
+ (defmethod bundle-op-build-args :around ((o lib-op))
+ (declare (ignorable o))
+ (let ((args (call-next-method)))
+ (remf args :ld-flags)
+ args))
+
+ (defun bundlable-file-p (pathname)
+ (let ((type (pathname-type pathname)))
+ (declare (ignorable type))
+ (or #+ecl (or (equalp type (compile-file-type :type :object))
+ (equalp type (compile-file-type :type :static-library)))
+ #+mkcl (equalp type (compile-file-type :fasl-p nil))
+ #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
+ (defgeneric* (trivial-system-p) (component))
-;;;; load-sysdef
+ (defun user-system-p (s)
+ (and (typep s 'system)
+ (not (builtin-system-p s))
+ (not (trivial-system-p s)))))
+
+(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
+ (deftype user-system () '(and system (satisfies user-system-p))))
+
+;;;
+;;; First we handle monolithic bundles.
+;;; These are standalone systems which contain everything,
+;;; including other ASDF systems required by the current one.
+;;; A PROGRAM is always monolithic.
+;;;
+;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
+;;;
(with-upgradability ()
- (defun load-sysdef (name pathname)
- (load-asd pathname :name name))
+ (defmethod component-depends-on ((o bundle-compile-op) (c system))
+ `(,(if (operation-monolithic-p o)
+ `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op
+ ,@(required-components c :other-systems t :component-type 'system
+ :goal-operation (find-operation o 'load-op)
+ :keep-operation 'compile-op))
+ `(compile-op
+ ,@(required-components c :other-systems nil :component-type '(not system)
+ :goal-operation (find-operation o 'load-op)
+ :keep-operation 'compile-op)))
+ ,@(call-next-method)))
- (defun make-temporary-package ()
- ;; For loading a .asd file, we dont't make a temporary package anymore,
- ;; but use ASDF-USER. I'd like to have this function do this,
- ;; but since whoever uses it is likely to delete-package the result afterwards,
- ;; this would be a bad idea, so preserve the old behavior.
- (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
+ (defmethod component-depends-on :around ((o bundle-op) (c component))
+ (declare (ignorable o c))
+ (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
+ `((,op ,c))
+ (call-next-method)))
+
+ (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
+ ;; This file selects output files from direct dependencies;
+ ;; your component-depends-on method better gathered the correct dependencies in the correct order.
+ (while-collecting (collect)
+ (map-direct-dependencies
+ o c #'(lambda (sub-o sub-c)
+ (loop :for f :in (funcall key sub-o sub-c)
+ :when (funcall test f) :do (collect f))))))
+ (defmethod input-files ((o bundle-compile-op) (c system))
+ (unless (eq (bundle-type o) :no-output-file)
+ (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)))
-;;;; -------------------------------------------------------------------------
-;;;; Defsystem
+ (defun select-bundle-operation (type &optional monolithic)
+ (ecase type
+ ((:binary)
+ (if monolithic 'monolithic-binary-op 'binary-op))
+ ((:dll :shared-library)
+ (if monolithic 'monolithic-dll-op 'dll-op))
+ ((:lib :static-library)
+ (if monolithic 'monolithic-lib-op 'lib-op))
+ ((:fasl)
+ (if monolithic 'monolithic-fasl-op 'fasl-op))
+ ((:program)
+ 'program-op)))
-(asdf/package:define-package :asdf/defsystem
- (:recycle :asdf/defsystem :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/system :asdf/cache
- :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
- :asdf/backward-internals)
- (:export
- #:defsystem #:register-system-definition
- #:class-for-type #:*default-component-class*
- #:determine-system-directory #:parse-component-form
- #:duplicate-names #:sysdef-error-component #:check-component-input))
-(in-package :asdf/defsystem)
+ (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
+ (move-here nil move-here-p)
+ &allow-other-keys)
+ (let* ((operation-name (select-bundle-operation type monolithic))
+ (move-here-path (if (and move-here
+ (typep move-here '(or pathname string)))
+ (pathname move-here)
+ (system-relative-pathname system "asdf-output/")))
+ (operation (apply #'operate operation-name
+ system
+ (remove-plist-keys '(:monolithic :type :move-here) args)))
+ (system (find-system system))
+ (files (and system (output-files operation system))))
+ (if (or move-here (and (null move-here-p)
+ (member operation-name '(:program :binary))))
+ (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
+ :for f :in files
+ :for new-f = (make-pathname :name (pathname-name f)
+ :type (pathname-type f)
+ :defaults dest-path)
+ :do (rename-file-overwriting-target f new-f)
+ :collect new-f)
+ files))))
+
+;;;
+;;; LOAD-FASL-OP
+;;;
+;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
+;;;
+(with-upgradability ()
+ (defmethod component-depends-on ((o load-fasl-op) (c system))
+ (declare (ignorable o))
+ `((,o ,@(loop :for dep :in (component-sideway-dependencies c)
+ :collect (resolve-dependency-spec c dep)))
+ (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
+ ,@(call-next-method)))
+
+ (defmethod input-files ((o load-fasl-op) (c system))
+ (when (user-system-p c)
+ (output-files (find-operation o 'fasl-op) c)))
-;;; Pathname
-(with-upgradability ()
- (defun determine-system-directory (pathname)
- ;; The defsystem macro calls this function to determine
- ;; the pathname of a system as follows:
- ;; 1. if the pathname argument is an pathname object (NOT a namestring),
- ;; that is already an absolute pathname, return it.
- ;; 2. otherwise, the directory containing the LOAD-PATHNAME
- ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
- ;; if it is indeed available and an absolute pathname, then
- ;; the PATHNAME argument is normalized to a relative pathname
- ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
- ;; and merged into that DIRECTORY as per SUBPATHNAME.
- ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
- ;; and may be from within the EVAL-WHEN of a file compilation.
- ;; If no absolute pathname was found, we return NIL.
- (check-type pathname (or null string pathname))
- (pathname-directory-pathname
- (resolve-symlinks*
- (ensure-absolute-pathname
- (parse-unix-namestring pathname :type :directory)
- #'(lambda () (ensure-absolute-pathname
- (load-pathname) 'get-pathname-defaults nil))
- nil)))))
+ (defmethod perform ((o load-fasl-op) c)
+ (declare (ignorable o c))
+ nil)
+ (defmethod perform ((o load-fasl-op) (c system))
+ (when (input-files o c)
+ (perform-lisp-load-fasl o c)))
-;;; Component class
-(with-upgradability ()
- (defvar *default-component-class* 'cl-source-file)
+ (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
+ (mark-operation-done (find-operation o 'load-op) c)))
- (defun class-for-type (parent type)
- (or (loop :for symbol :in (list
- type
- (find-symbol* type *package* nil)
- (find-symbol* type :asdf/interface nil)
- (and (stringp type) (safe-read-from-string type :package :asdf/interface)))
- :for class = (and symbol (symbolp symbol) (find-class* symbol nil))
- :when (and class
- (#-cormanlisp subtypep #+cormanlisp cl::subclassp
- class (find-class* 'component)))
- :return class)
- (and (eq type :file)
- (find-class*
- (or (loop :for p = parent :then (component-parent p) :while p
- :thereis (module-default-component-class p))
- *default-component-class*) nil))
- (sysdef-error "don't recognize component type ~A" type))))
+;;;
+;;; PRECOMPILED FILES
+;;;
+;;; This component can be used to distribute ASDF systems in precompiled form.
+;;; Only useful when the dependencies have also been precompiled.
+;;;
+(with-upgradability ()
+ (defmethod trivial-system-p ((s system))
+ (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
+ (defmethod output-files (o (c compiled-file))
+ (declare (ignorable o c))
+ nil)
+ (defmethod input-files (o (c compiled-file))
+ (declare (ignorable o))
+ (component-pathname c))
+ (defmethod perform ((o load-op) (c compiled-file))
+ (perform-lisp-load-fasl o c))
+ (defmethod perform ((o load-source-op) (c compiled-file))
+ (perform (find-operation o 'load-op) c))
+ (defmethod perform ((o load-fasl-op) (c compiled-file))
+ (perform (find-operation o 'load-op) c))
+ (defmethod perform ((o operation) (c compiled-file))
+ (declare (ignorable o c))
+ nil))
-;;; Check inputs
+;;;
+;;; Pre-built systems
+;;;
(with-upgradability ()
- (define-condition duplicate-names (system-definition-error)
- ((name :initarg :name :reader duplicate-names-name))
- (:report (lambda (c s)
- (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
- (duplicate-names-name c)))))
+ (defmethod trivial-system-p ((s prebuilt-system))
+ (declare (ignorable s))
+ t)
- (defun sysdef-error-component (msg type name value)
- (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
- type name value))
+ (defmethod perform ((o lib-op) (c prebuilt-system))
+ (declare (ignorable o c))
+ nil)
- (defun check-component-input (type name weakly-depends-on
- depends-on components)
- "A partial test of the values of a component."
- (unless (listp depends-on)
- (sysdef-error-component ":depends-on must be a list."
- type name depends-on))
- (unless (listp weakly-depends-on)
- (sysdef-error-component ":weakly-depends-on must be a list."
- type name weakly-depends-on))
- (unless (listp components)
- (sysdef-error-component ":components must be NIL or a list of components."
- type name components)))
+ (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
+ (declare (ignorable o c))
+ nil)
- (defun* (normalize-version) (form &key pathname component parent)
- (labels ((invalid (&optional (continuation "using NIL instead"))
- (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
- form component parent pathname continuation))
- (invalid-parse (control &rest args)
- (unless (builtin-system-p (find-component parent component))
- (apply 'warn control args)
- (invalid))))
- (if-let (v (typecase form
- ((or string null) form)
- (real
- (invalid "Substituting a string")
- (format nil "~D" form)) ;; 1.0 becomes "1.0"
- (cons
- (case (first form)
- ((:read-file-form)
- (destructuring-bind (subpath &key (at 0)) (rest form)
- (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user)))
- ((:read-file-line)
- (destructuring-bind (subpath &key (at 0)) (rest form)
- (read-file-lines (subpathname pathname subpath) :at at)))
- (otherwise
- (invalid))))
- (t
- (invalid))))
- (if-let (pv (parse-version v #'invalid-parse))
- (unparse-version pv)
- (invalid))))))
+ (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
+ (declare (ignorable o))
+ nil))
-;;; Main parsing function
+;;;
+;;; PREBUILT SYSTEM CREATOR
+;;;
(with-upgradability ()
- (defun* (parse-component-form) (parent options &key previous-serial-component)
- (destructuring-bind
- (type name &rest rest &key
- (builtin-system-p () bspp)
- ;; the following list of keywords is reproduced below in the
- ;; remove-plist-keys form. important to keep them in sync
- components pathname perform explain output-files operation-done-p
- weakly-depends-on depends-on serial
- do-first if-component-dep-fails version
- ;; list ends
- &allow-other-keys) options
- (declare (ignorable perform explain output-files operation-done-p builtin-system-p))
- (check-component-input type name weakly-depends-on depends-on components)
- (when (and parent
- (find-component parent name)
- (not ;; ignore the same object when rereading the defsystem
- (typep (find-component parent name)
- (class-for-type parent type))))
- (error 'duplicate-names :name name))
- (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
- (let* ((args `(:name ,(coerce-name name)
- :pathname ,pathname
- ,@(when parent `(:parent ,parent))
- ,@(remove-plist-keys
- '(:components :pathname :if-component-dep-fails :version
- :perform :explain :output-files :operation-done-p
- :weakly-depends-on :depends-on :serial)
- rest)))
- (component (find-component parent name)))
- (when weakly-depends-on
- ;; ASDF4: deprecate this feature and remove it.
- (appendf depends-on
- (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
- (when previous-serial-component
- (push previous-serial-component depends-on))
- (if component ; preserve identity
- (apply 'reinitialize-instance component args)
- (setf component (apply 'make-instance (class-for-type parent type) args)))
- (component-pathname component) ; eagerly compute the absolute pathname
- (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
- (when (and (typep component 'system) (not bspp))
- (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
- (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
- ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
- ;; A better fix is required.
- (setf (slot-value component 'version) version)
- (when (typep component 'parent-component)
- (setf (component-children component)
- (loop
- :with previous-component = nil
- :for c-form :in components
- :for c = (parse-component-form component c-form
- :previous-serial-component previous-component)
- :for name = (component-name c)
- :collect c
- :when serial :do (setf previous-component name)))
- (compute-children-by-name component))
- ;; Used by POIU. ASDF4: rename to component-depends-on?
- (setf (component-sibling-dependencies component) depends-on)
- (%refresh-component-inline-methods component rest)
- (when if-component-dep-fails
- (%resolve-if-component-dep-fails if-component-dep-fails component))
- component)))
-
- (defun register-system-definition
- (name &rest options &key pathname (class 'system) (source-file () sfp)
- defsystem-depends-on &allow-other-keys)
- ;; The system must be registered before we parse the body,
- ;; otherwise we recur when trying to find an existing system
- ;; of the same name to reuse options (e.g. pathname) from.
- ;; To avoid infinite recursion in cases where you defsystem a system
- ;; that is registered to a different location to find-system,
- ;; we also need to remember it in a special variable *systems-being-defined*.
- (with-system-definitions ()
- (let* ((name (coerce-name name))
- (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
- (registered (system-registered-p name))
- (registered! (if registered
- (rplaca registered (get-file-stamp source-file))
- (register-system
- (make-instance 'system :name name :source-file source-file))))
- (system (reset-system (cdr registered!)
- :name name :source-file source-file))
- (component-options (remove-plist-key :class options))
- (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
- (resolve-dependency-spec nil spec))))
- (setf (gethash name *systems-being-defined*) system)
- (apply 'load-systems defsystem-dependencies)
- ;; We change-class AFTER we loaded the defsystem-depends-on
- ;; since the class might be defined as part of those.
- (let ((class (class-for-type nil class)))
- (unless (eq (type-of system) class)
- (change-class system class)))
- (parse-component-form
- nil (list*
- :module name
- :pathname (determine-system-directory pathname)
- component-options)))))
+ (defmethod output-files ((o binary-op) (s system))
+ (list (make-pathname :name (component-name s) :type "asd"
+ :defaults (component-pathname s))))
- (defmacro defsystem (name &body options)
- `(apply 'register-system-definition ',name ',options)))
-;;;; -------------------------------------------------------------------------
-;;;; ASDF-Bundle
+ (defmethod perform ((o binary-op) (s system))
+ (let* ((inputs (input-files o s))
+ (fasl (first inputs))
+ (library (second inputs))
+ (asd (first (output-files o s)))
+ (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
+ (dependencies
+ (if (operation-monolithic-p o)
+ (remove-if-not 'builtin-system-p
+ (required-components s :component-type 'system
+ :keep-operation 'load-op))
+ (while-collecting (x) ;; resolve the sideway-dependencies of s
+ (map-direct-dependencies
+ 'load-op s
+ #'(lambda (o c)
+ (when (and (typep o 'load-op) (typep c 'system))
+ (x c)))))))
+ (depends-on (mapcar 'coerce-name dependencies)))
+ (when (pathname-equal asd (system-source-file s))
+ (cerror "overwrite the asd file"
+ "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
+ (cons o s) asd))
+ (with-open-file (s asd :direction :output :if-exists :supersede
+ :if-does-not-exist :create)
+ (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
+ (operation-monolithic-p o) name)
+ (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
+ (lisp-implementation-type)
+ (lisp-implementation-version)
+ (software-type)
+ (machine-type)
+ (software-version))
+ (let ((*package* (find-package :asdf-user)))
+ (pprint `(defsystem ,name
+ :class prebuilt-system
+ :depends-on ,depends-on
+ :components ((:compiled-file ,(pathname-name fasl)))
+ ,@(when library `(:lib ,(file-namestring library))))
+ s)
+ (terpri s)))))
-(asdf/package:define-package :asdf/bundle
- (:recycle :asdf/bundle :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
- :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
- (:export
- #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type
- #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
- #:monolithic-op #:monolithic-bundle-op #:bundlable-file-p #:direct-dependency-files
- #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
- #:program-op
- #:compiled-file #:precompiled-system #:prebuilt-system
- #:operation-monolithic-p
- #:user-system-p #:user-system #:trivial-system-p
- #+ecl #:make-build
- #:register-pre-built-system
- #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
-(in-package :asdf/bundle)
+ #-(or ecl mkcl)
+ (defmethod perform ((o bundle-compile-op) (c system))
+ (let* ((input-files (input-files o c))
+ (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
+ (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
+ (output-files (output-files o c))
+ (output-file (first output-files)))
+ (assert (eq (not input-files) (not output-files)))
+ (when input-files
+ (when non-fasl-files
+ (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
+ (implementation-type) non-fasl-files))
+ (when (and (typep o 'monolithic-bundle-op)
+ (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
+ (error "prologue-code and epilogue-code are not supported on ~A"
+ (implementation-type)))
+ (with-staging-pathname (output-file)
+ (combine-fasls fasl-files output-file)))))
-(with-upgradability ()
- (defclass bundle-op (operation)
- ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
- (name-suffix :initarg :name-suffix :initform nil)
- (bundle-type :initform :no-output-file :reader bundle-type)
- #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
- #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
- #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
+ (defmethod input-files ((o load-op) (s precompiled-system))
+ (declare (ignorable o))
+ (bundle-output-files (find-operation o 'fasl-op) s))
- (defclass fasl-op (bundle-op)
- ;; create a single fasl for the entire library
- ((bundle-type :initform :fasl)))
+ (defmethod perform ((o load-op) (s precompiled-system))
+ (perform-lisp-load-fasl o s))
- (defclass load-fasl-op (basic-load-op)
- ;; load a single fasl for the entire library
- ())
+ (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
+ (declare (ignorable o))
+ `((load-op ,s) ,@(call-next-method))))
- (defclass lib-op (bundle-op)
- ;; On ECL: compile the system and produce linkable .a library for it.
- ;; On others: just compile the system.
- ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)))
+ #| ;; Example use:
+(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
+(asdf:load-system :precompiled-asdf-utils)
+|#
- (defclass dll-op (bundle-op)
- ;; Link together all the dynamic library used by this system into a single one.
- ((bundle-type :initform :dll)))
+#+(or ecl mkcl)
+(with-upgradability ()
+ (defun uiop-library-file ()
+ (or (and (find-system :uiop nil)
+ (system-source-directory :uiop)
+ (progn
+ (operate 'lib-op :uiop)
+ (output-file 'lib-op :uiop)))
+ (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib))))
+ (defmethod input-files :around ((o program-op) (c system))
+ (let ((files (call-next-method))
+ (plan (traverse-sub-actions o c :plan-class 'sequential-plan)))
+ (unless (or (and (find-system :uiop nil)
+ (system-source-directory :uiop)
+ (plan-operates-on-p plan '("uiop")))
+ (and (system-source-directory :asdf)
+ (plan-operates-on-p plan '("asdf"))))
+ (pushnew (uiop-library-file) files :test 'pathname-equal))
+ files))
- (defclass binary-op (bundle-op)
- ;; On ECL: produce lib and fasl for the system.
- ;; On "normal" Lisps: produce just the fasl.
- ())
+ (defun register-pre-built-system (name)
+ (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
- (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
+#+ecl
+(with-upgradability ()
+ (defmethod perform ((o bundle-compile-op) (c system))
+ (let* ((object-files (input-files o c))
+ (output (output-files o c))
+ (bundle (first output))
+ (kind (bundle-type o)))
+ (when output
+ (create-image
+ bundle (append object-files (bundle-op-lisp-files o))
+ :kind kind
+ :entry-point (component-entry-point c)
+ :prologue-code
+ (when (typep o 'monolithic-bundle-op)
+ (monolithic-op-prologue-code o))
+ :epilogue-code
+ (when (typep o 'monolithic-bundle-op)
+ (monolithic-op-epilogue-code o))
+ :build-args (bundle-op-build-args o))))))
- (defclass monolithic-bundle-op (monolithic-op bundle-op)
- ((prologue-code :accessor monolithic-op-prologue-code)
- (epilogue-code :accessor monolithic-op-epilogue-code)))
+#+mkcl
+(with-upgradability ()
+ (defmethod perform ((o lib-op) (s system))
+ (apply #'compiler::build-static-library (output-file o c)
+ :lisp-object-files (input-files o s) (bundle-op-build-args o)))
- (defclass monolithic-binary-op (binary-op monolithic-bundle-op)
- ;; On ECL: produce lib and fasl for combined system and dependencies.
- ;; On "normal" Lisps: produce an image file from system and dependencies.
- ())
+ (defmethod perform ((o basic-fasl-op) (s system))
+ (apply #'compiler::build-bundle (output-file o c) ;; second???
+ :lisp-object-files (input-files o s) (bundle-op-build-args o)))
- (defclass monolithic-fasl-op (monolithic-bundle-op fasl-op)
- ;; Create a single fasl for the system and its dependencies.
- ())
+ (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
+ (declare (ignore force verbose version))
+ (apply #'operate 'binary-op system args)))
+;;;; -------------------------------------------------------------------------
+;;;; Concatenate-source
+
+(asdf/package:define-package :asdf/concatenate-source
+ (:recycle :asdf/concatenate-source :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ :asdf/component :asdf/operation
+ :asdf/system :asdf/find-system :asdf/defsystem
+ :asdf/action :asdf/lisp-action :asdf/bundle)
+ (:export
+ #:concatenate-source-op
+ #:load-concatenated-source-op
+ #:compile-concatenated-source-op
+ #:load-compiled-concatenated-source-op
+ #:monolithic-concatenate-source-op
+ #:monolithic-load-concatenated-source-op
+ #:monolithic-compile-concatenated-source-op
+ #:monolithic-load-compiled-concatenated-source-op))
+(in-package :asdf/concatenate-source)
- (defclass monolithic-lib-op (monolithic-bundle-op lib-op)
- ;; ECL: Create a single linkable library for the system and its dependencies.
- ((bundle-type :initform :lib)))
+;;;
+;;; Concatenate sources
+;;;
+(with-upgradability ()
+ (defclass basic-concatenate-source-op (bundle-op)
+ ((bundle-type :initform "lisp")))
+ (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
+ (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
+ (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
+
+ (defclass concatenate-source-op (basic-concatenate-source-op) ())
+ (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
+ ((selfward-operation :initform '(prepare-op concatenate-source-op))))
+ (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
+ ((selfward-operation :initform '(prepare-op concatenate-source-op))))
+ (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
+ ((selfward-operation :initform '(prepare-op compile-concatenated-source-op))))
+
+ (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ())
+ (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
+ ((selfward-operation :initform 'monolithic-concatenate-source-op)))
+ (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
+ ((selfward-operation :initform 'monolithic-concatenate-source-op)))
+ (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
+ ((selfward-operation :initform 'monolithic-compile-concatenated-source-op)))
+
+ (defmethod input-files ((operation basic-concatenate-source-op) (s system))
+ (loop :with encoding = (or (component-encoding s) *default-encoding*)
+ :with other-encodings = '()
+ :with around-compile = (around-compile-hook s)
+ :with other-around-compile = '()
+ :for c :in (required-components
+ s :goal-operation 'compile-op
+ :keep-operation 'compile-op
+ :other-systems (operation-monolithic-p operation))
+ :append
+ (when (typep c 'cl-source-file)
+ (let ((e (component-encoding c)))
+ (unless (equal e encoding)
+ (pushnew e other-encodings :test 'equal)))
+ (let ((a (around-compile-hook c)))
+ (unless (equal a around-compile)
+ (pushnew a other-around-compile :test 'equal)))
+ (input-files (make-operation 'compile-op) c)) :into inputs
+ :finally
+ (when other-encodings
+ (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
+ operation encoding other-encodings))
+ (when other-around-compile
+ (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
+ operation around-compile other-around-compile))
+ (return inputs)))
+ (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
+ (lisp-compilation-output-files o s))
- (defclass monolithic-dll-op (monolithic-bundle-op dll-op)
- ((bundle-type :initform :dll)))
+ (defmethod perform ((o basic-concatenate-source-op) (s system))
+ (let ((inputs (input-files o s))
+ (output (output-file o s)))
+ (concatenate-files inputs output)))
+ (defmethod perform ((o basic-load-concatenated-source-op) (s system))
+ (perform-lisp-load-source o s))
+ (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
+ (perform-lisp-compilation o s))
+ (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
+ (perform-lisp-load-fasl o s)))
- (defclass program-op (monolithic-bundle-op)
- ;; All: create an executable file from the system and its dependencies
- ((bundle-type :initform :program)))
+;;;; ---------------------------------------------------------------------------
+;;;; asdf-output-translations
- (defun bundle-pathname-type (bundle-type)
- (etypecase bundle-type
- ((eql :no-output-file) nil) ;; should we error out instead?
- ((or null string) bundle-type)
- ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
- #+ecl
- ((member :binary :dll :lib :static-library :program :object :program)
- (compile-file-type :type bundle-type))
- ((eql :binary) "image")
- ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
- ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
- ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
+(asdf/package:define-package :asdf/output-translations
+ (:recycle :asdf/output-translations :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+ (:export
+ #:*output-translations* #:*output-translations-parameter*
+ #:invalid-output-translation
+ #:output-translations #:output-translations-initialized-p
+ #:initialize-output-translations #:clear-output-translations
+ #:disable-output-translations #:ensure-output-translations
+ #:apply-output-translations
+ #:validate-output-translations-directive #:validate-output-translations-form
+ #:validate-output-translations-file #:validate-output-translations-directory
+ #:parse-output-translations-string #:wrapping-output-translations
+ #:user-output-translations-pathname #:system-output-translations-pathname
+ #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
+ #:environment-output-translations #:process-output-translations
+ #:compute-output-translations
+ #+abcl #:translate-jar-pathname
+ ))
+(in-package :asdf/output-translations)
- (defun bundle-output-files (o c)
- (let ((bundle-type (bundle-type o)))
- (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
- (let ((name (or (component-build-pathname c)
- (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
- (type (bundle-pathname-type bundle-type)))
- (values (list (subpathname (component-pathname c) name :type type))
- (eq (type-of o) (component-build-operation c)))))))
+(when-upgrading () (undefine-function '(setf output-translations)))
- (defmethod output-files ((o bundle-op) (c system))
- (bundle-output-files o c))
+(with-upgradability ()
+ (define-condition invalid-output-translation (invalid-configuration warning)
+ ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
- #-(or ecl mkcl)
- (progn
- (defmethod perform ((o program-op) (c system))
- (let ((output-file (output-file o c)))
- (setf *image-entry-point* (ensure-function (component-entry-point c)))
- (dump-image output-file :executable t)))
+ (defvar *output-translations* ()
+ "Either NIL (for uninitialized), or a list of one element,
+said element itself being a sorted list of mappings.
+Each mapping is a pair of a source pathname and destination pathname,
+and the order is by decreasing length of namestring of the source pathname.")
- (defmethod perform ((o monolithic-binary-op) (c system))
- (let ((output-file (output-file o c)))
- (dump-image output-file))))
+ (defun output-translations ()
+ (car *output-translations*))
- (defclass compiled-file (file-component)
- ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
+ (defun set-output-translations (new-value)
+ (setf *output-translations*
+ (list
+ (stable-sort (copy-list new-value) #'>
+ :key #'(lambda (x)
+ (etypecase (car x)
+ ((eql t) -1)
+ (pathname
+ (let ((directory (pathname-directory (car x))))
+ (if (listp directory) (length directory) 0))))))))
+ new-value)
+ #-gcl2.6
+ (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
+ #+gcl2.6
+ (defsetf output-translations set-output-translations)
- (defclass precompiled-system (system)
- ((build-pathname :initarg :fasl)))
+ (defun output-translations-initialized-p ()
+ (and *output-translations* t))
- (defclass prebuilt-system (system)
- ((build-pathname :initarg :static-library :initarg :lib
- :accessor prebuilt-system-static-library))))
+ (defun clear-output-translations ()
+ "Undoes any initialization of the output translations."
+ (setf *output-translations* '())
+ (values))
+ (register-clear-configuration-hook 'clear-output-translations)
+ (defun validate-output-translations-directive (directive)
+ (or (member directive '(:enable-user-cache :disable-cache nil))
+ (and (consp directive)
+ (or (and (length=n-p directive 2)
+ (or (and (eq (first directive) :include)
+ (typep (second directive) '(or string pathname null)))
+ (and (location-designator-p (first directive))
+ (or (location-designator-p (second directive))
+ (location-function-p (second directive))))))
+ (and (length=n-p directive 1)
+ (location-designator-p (first directive)))))))
-;;;
-;;; BUNDLE-OP
-;;;
-;;; This operation takes all components from one or more systems and
-;;; creates a single output file, which may be
-;;; a FASL, a statically linked library, a shared library, etc.
-;;; The different targets are defined by specialization.
-;;;
-(with-upgradability ()
- (defun operation-monolithic-p (op)
- (typep op 'monolithic-op))
+ (defun validate-output-translations-form (form &key location)
+ (validate-configuration-form
+ form
+ :output-translations
+ 'validate-output-translations-directive
+ :location location :invalid-form-reporter 'invalid-output-translation))
- (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
- &key (name-suffix nil name-suffix-p)
- &allow-other-keys)
- (declare (ignorable initargs name-suffix))
- (unless name-suffix-p
- (setf (slot-value instance 'name-suffix)
- (unless (typep instance 'program-op)
- (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames
- (when (typep instance 'monolithic-bundle-op)
- (destructuring-bind (&rest original-initargs
- &key lisp-files prologue-code epilogue-code
- &allow-other-keys)
- (operation-original-initargs instance)
- (setf (operation-original-initargs instance)
- (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
- (monolithic-op-prologue-code instance) prologue-code
- (monolithic-op-epilogue-code instance) epilogue-code)
- #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
- #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
- (setf (bundle-op-build-args instance)
- (remove-plist-keys '(:type :monolithic :name-suffix)
- (operation-original-initargs instance))))
+ (defun validate-output-translations-file (file)
+ (validate-configuration-file
+ file 'validate-output-translations-form :description "output translations"))
- (defmethod bundle-op-build-args :around ((o lib-op))
- (declare (ignorable o))
- (let ((args (call-next-method)))
- (remf args :ld-flags)
- args))
+ (defun validate-output-translations-directory (directory)
+ (validate-configuration-directory
+ directory :output-translations 'validate-output-translations-directive
+ :invalid-form-reporter 'invalid-output-translation))
- (defun bundlable-file-p (pathname)
- (let ((type (pathname-type pathname)))
- (declare (ignorable type))
- (or #+ecl (or (equalp type (compile-file-type :type :object))
- (equalp type (compile-file-type :type :static-library)))
- #+mkcl (equalp type (compile-file-type :fasl-p nil))
- #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
+ (defun parse-output-translations-string (string &key location)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:output-translations :inherit-configuration))
+ ((not (stringp string))
+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
+ ((eql (char string 0) #\")
+ (parse-output-translations-string (read-from-string string) :location location))
+ ((eql (char string 0) #\()
+ (validate-output-translations-form (read-from-string string) :location location))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :with source = nil
+ :with separator = (inter-directory-separator)
+ :for i = (or (position separator string :start start) end) :do
+ (let ((s (subseq string start i)))
+ (cond
+ (source
+ (push (list source (if (equal "" s) nil s)) directives)
+ (setf source nil))
+ ((equal "" s)
+ (when inherit
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
+ (setf inherit t)
+ (push :inherit-configuration directives))
+ (t
+ (setf source s)))
+ (setf start (1+ i))
+ (when (> start end)
+ (when source
+ (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
+ string))
+ (unless inherit
+ (push :ignore-inherited-configuration directives))
+ (return `(:output-translations ,@(nreverse directives)))))))))
- (defgeneric* (trivial-system-p) (component))
+ (defparameter *default-output-translations*
+ '(environment-output-translations
+ user-output-translations-pathname
+ user-output-translations-directory-pathname
+ system-output-translations-pathname
+ system-output-translations-directory-pathname))
- (defun user-system-p (s)
- (and (typep s 'system)
- (not (builtin-system-p s))
- (not (trivial-system-p s)))))
+ (defun wrapping-output-translations ()
+ `(:output-translations
+ ;; Some implementations have precompiled ASDF systems,
+ ;; so we must disable translations for implementation paths.
+ #+(or #|clozure|# ecl mkcl sbcl)
+ ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
+ (when h `(((,h ,*wild-path*) ()))))
+ #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
+ ;; All-import, here is where we want user stuff to be:
+ :inherit-configuration
+ ;; These are for convenience, and can be overridden by the user:
+ #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
+ #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
+ ;; We enable the user cache by default, and here is the place we do:
+ :enable-user-cache))
-(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
- (deftype user-system () '(and system (satisfies user-system-p))))
+ (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
+ (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
-;;;
-;;; First we handle monolithic bundles.
-;;; These are standalone systems which contain everything,
-;;; including other ASDF systems required by the current one.
-;;; A PROGRAM is always monolithic.
-;;;
-;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
-;;;
-(with-upgradability ()
- (defmethod component-depends-on ((o monolithic-lib-op) (c system))
- (declare (ignorable o))
- `((lib-op ,@(required-components c :other-systems t :component-type 'system
- :goal-operation 'load-op
- :keep-operation 'compile-op))))
+ (defun user-output-translations-pathname (&key (direction :input))
+ (in-user-configuration-directory *output-translations-file* :direction direction))
+ (defun system-output-translations-pathname (&key (direction :input))
+ (in-system-configuration-directory *output-translations-file* :direction direction))
+ (defun user-output-translations-directory-pathname (&key (direction :input))
+ (in-user-configuration-directory *output-translations-directory* :direction direction))
+ (defun system-output-translations-directory-pathname (&key (direction :input))
+ (in-system-configuration-directory *output-translations-directory* :direction direction))
+ (defun environment-output-translations ()
+ (getenv "ASDF_OUTPUT_TRANSLATIONS"))
- (defmethod component-depends-on ((o monolithic-fasl-op) (c system))
- (declare (ignorable o))
- `((fasl-op ,@(required-components c :other-systems t :component-type 'system
- :goal-operation 'load-fasl-op
- :keep-operation 'fasl-op))))
+ (defgeneric process-output-translations (spec &key inherit collect))
- (defmethod component-depends-on ((o program-op) (c system))
- (declare (ignorable o))
- #+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op) c)
- #-(or ecl mkcl) `((load-op ,c)))
+ (defun inherit-output-translations (inherit &key collect)
+ (when inherit
+ (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
- (defmethod component-depends-on ((o binary-op) (c system))
- (declare (ignorable o))
- `((fasl-op ,c)
- (lib-op ,c)))
+ (defun* (process-output-translations-directive) (directive &key inherit collect)
+ (if (atom directive)
+ (ecase directive
+ ((:enable-user-cache)
+ (process-output-translations-directive '(t :user-cache) :collect collect))
+ ((:disable-cache)
+ (process-output-translations-directive '(t t) :collect collect))
+ ((:inherit-configuration)
+ (inherit-output-translations inherit :collect collect))
+ ((:ignore-inherited-configuration :ignore-invalid-entries nil)
+ nil))
+ (let ((src (first directive))
+ (dst (second directive)))
+ (if (eq src :include)
+ (when dst
+ (process-output-translations (pathname dst) :inherit nil :collect collect))
+ (when src
+ (let ((trusrc (or (eql src t)
+ (let ((loc (resolve-location src :ensure-directory t :wilden t)))
+ (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
+ (cond
+ ((location-function-p dst)
+ (funcall collect
+ (list trusrc
+ (if (symbolp (second dst))
+ (fdefinition (second dst))
+ (eval (second dst))))))
+ ((eq dst t)
+ (funcall collect (list trusrc t)))
+ (t
+ (let* ((trudst (if dst
+ (resolve-location dst :ensure-directory t :wilden t)
+ trusrc)))
+ (funcall collect (list trudst t))
+ (funcall collect (list trusrc trudst)))))))))))
- (defmethod component-depends-on ((o monolithic-binary-op) (c system))
- `((,(find-operation o 'monolithic-fasl-op) ,c)
- (,(find-operation o 'monolithic-lib-op) ,c)))
+ (defmethod process-output-translations ((x symbol) &key
+ (inherit *default-output-translations*)
+ collect)
+ (process-output-translations (funcall x) :inherit inherit :collect collect))
+ (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
+ (cond
+ ((directory-pathname-p pathname)
+ (process-output-translations (validate-output-translations-directory pathname)
+ :inherit inherit :collect collect))
+ ((probe-file* pathname :truename *resolve-symlinks*)
+ (process-output-translations (validate-output-translations-file pathname)
+ :inherit inherit :collect collect))
+ (t
+ (inherit-output-translations inherit :collect collect))))
+ (defmethod process-output-translations ((string string) &key inherit collect)
+ (process-output-translations (parse-output-translations-string string)
+ :inherit inherit :collect collect))
+ (defmethod process-output-translations ((x null) &key inherit collect)
+ (declare (ignorable x))
+ (inherit-output-translations inherit :collect collect))
+ (defmethod process-output-translations ((form cons) &key inherit collect)
+ (dolist (directive (cdr (validate-output-translations-form form)))
+ (process-output-translations-directive directive :inherit inherit :collect collect)))
- (defmethod component-depends-on ((o lib-op) (c system))
- (declare (ignorable o))
- `((compile-op ,@(required-components c :other-systems nil :component-type '(not system)
- :goal-operation 'load-op
- :keep-operation 'compile-op))))
+ (defun compute-output-translations (&optional parameter)
+ "read the configuration, return it"
+ (remove-duplicates
+ (while-collecting (c)
+ (inherit-output-translations
+ `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
+ :test 'equal :from-end t))
- (defmethod component-depends-on ((o fasl-op) (c system))
- (declare (ignorable o))
- #+ecl `((lib-op ,c))
- #-ecl
- (component-depends-on (find-operation o 'lib-op) c))
+ (defvar *output-translations-parameter* nil)
- (defmethod component-depends-on ((o dll-op) c)
- (component-depends-on (find-operation o 'lib-op) c))
+ (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
+ "read the configuration, initialize the internal configuration variable,
+return the configuration"
+ (setf *output-translations-parameter* parameter
+ (output-translations) (compute-output-translations parameter)))
- (defmethod component-depends-on ((o bundle-op) c)
- (declare (ignorable o c))
- nil)
+ (defun disable-output-translations ()
+ "Initialize output translations in a way that maps every file to itself,
+effectively disabling the output translation facility."
+ (initialize-output-translations
+ '(:output-translations :disable-cache :ignore-inherited-configuration)))
- (defmethod component-depends-on :around ((o bundle-op) (c component))
- (declare (ignorable o c))
- (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
- `((,op ,c))
- (call-next-method)))
+ ;; checks an initial variable to see whether the state is initialized
+ ;; or cleared. In the former case, return current configuration; in
+ ;; the latter, initialize. ASDF will call this function at the start
+ ;; of (asdf:find-system).
+ (defun ensure-output-translations ()
+ (if (output-translations-initialized-p)
+ (output-translations)
+ (initialize-output-translations)))
- (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
- (while-collecting (collect)
- (map-direct-dependencies
- o c #'(lambda (sub-o sub-c)
- (loop :for f :in (funcall key sub-o sub-c)
- :when (funcall test f) :do (collect f))))))
+ (defun* (apply-output-translations) (path)
+ (etypecase path
+ (logical-pathname
+ path)
+ ((or pathname string)
+ (ensure-output-translations)
+ (loop* :with p = (resolve-symlinks* path)
+ :for (source destination) :in (car *output-translations*)
+ :for root = (when (or (eq source t)
+ (and (pathnamep source)
+ (not (absolute-pathname-p source))))
+ (pathname-root p))
+ :for absolute-source = (cond
+ ((eq source t) (wilden root))
+ (root (merge-pathnames* source root))
+ (t source))
+ :when (or (eq source t) (pathname-match-p p absolute-source))
+ :return (translate-pathname* p absolute-source destination root source)
+ :finally (return p)))))
+
+ ;; Hook into asdf/driver's output-translation mechanism
+ #-cormanlisp
+ (setf *output-translation-function* 'apply-output-translations)
- (defmethod input-files ((o bundle-op) (c system))
- (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))
+ #+abcl
+ (defun translate-jar-pathname (source wildcard)
+ (declare (ignore wildcard))
+ (flet ((normalize-device (pathname)
+ (if (find :windows *features*)
+ pathname
+ (make-pathname :defaults pathname :device :unspecific))))
+ (let* ((jar
+ (pathname (first (pathname-device source))))
+ (target-root-directory-namestring
+ (format nil "/___jar___file___root___/~@[~A/~]"
+ (and (find :windows *features*)
+ (pathname-device jar))))
+ (relative-source
+ (relativize-pathname-directory source))
+ (relative-jar
+ (relativize-pathname-directory (ensure-directory-pathname jar)))
+ (target-root-directory
+ (normalize-device
+ (pathname-directory-pathname
+ (parse-namestring target-root-directory-namestring))))
+ (target-root
+ (merge-pathnames* relative-jar target-root-directory))
+ (target
+ (merge-pathnames* relative-source target-root)))
+ (normalize-device (apply-output-translations target))))))
- (defun select-bundle-operation (type &optional monolithic)
- (ecase type
- ((:binary)
- (if monolithic 'monolithic-binary-op 'binary-op))
- ((:dll :shared-library)
- (if monolithic 'monolithic-dll-op 'dll-op))
- ((:lib :static-library)
- (if monolithic 'monolithic-lib-op 'lib-op))
- ((:fasl)
- (if monolithic 'monolithic-fasl-op 'fasl-op))
- ((:program)
- 'program-op)))
+;;;; -------------------------------------------------------------------------
+;;; Backward-compatible interfaces
- (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
- (move-here nil move-here-p)
- &allow-other-keys)
- (let* ((operation-name (select-bundle-operation type monolithic))
- (move-here-path (if (and move-here
- (typep move-here '(or pathname string)))
- (pathname move-here)
- (system-relative-pathname system "asdf-output/")))
- (operation (apply #'operate operation-name
- system
- (remove-plist-keys '(:monolithic :type :move-here) args)))
- (system (find-system system))
- (files (and system (output-files operation system))))
- (if (or move-here (and (null move-here-p)
- (member operation-name '(:program :binary))))
- (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
- :for f :in files
- :for new-f = (make-pathname :name (pathname-name f)
- :type (pathname-type f)
- :defaults dest-path)
- :do (rename-file-overwriting-target f new-f)
- :collect new-f)
- files))))
+(asdf/package:define-package :asdf/backward-interface
+ (:recycle :asdf/backward-interface :asdf)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade
+ :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
+ :asdf/lisp-action :asdf/operate :asdf/output-translations)
+ (:export
+ #:*asdf-verbose*
+ #:operation-error #:compile-error #:compile-failed #:compile-warned
+ #:error-component #:error-operation
+ #:component-load-dependencies
+ #:enable-asdf-binary-locations-compatibility
+ #:operation-forced
+ #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
+ #:component-property
+ #:run-shell-command
+ #:system-definition-pathname))
+(in-package :asdf/backward-interface)
-;;;
-;;; LOAD-FASL-OP
-;;;
-;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
-;;;
(with-upgradability ()
- (defmethod component-depends-on ((o load-fasl-op) (c system))
- (declare (ignorable o))
- `((,o ,@(loop :for dep :in (component-sibling-dependencies c)
- :collect (resolve-dependency-spec c dep)))
- (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
- ,@(call-next-method)))
-
- (defmethod input-files ((o load-fasl-op) (c system))
- (when (user-system-p c)
- (output-files (find-operation o 'fasl-op) c)))
+ (define-condition operation-error (error) ;; Bad, backward-compatible name
+ ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
+ ((component :reader error-component :initarg :component)
+ (operation :reader error-operation :initarg :operation))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
+ (type-of c) (error-operation c) (error-component c)))))
+ (define-condition compile-error (operation-error) ())
+ (define-condition compile-failed (compile-error) ())
+ (define-condition compile-warned (compile-error) ())
- (defmethod perform ((o load-fasl-op) c)
- (declare (ignorable o c))
- nil)
+ (defun component-load-dependencies (component)
+ ;; Old deprecated name for the same thing. Please update your software.
+ (component-sideway-dependencies component))
- (defmethod perform ((o load-fasl-op) (c system))
- (perform-lisp-load-fasl o c))
+ (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
+ (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
- (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
- (mark-operation-done (find-operation o 'load-op) c)))
+ (defgeneric operation-on-warnings (operation))
+ (defgeneric operation-on-failure (operation))
+ #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
+ #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
+ (defmethod operation-on-warnings ((o operation))
+ (declare (ignorable o)) *compile-file-warnings-behaviour*)
+ (defmethod operation-on-failure ((o operation))
+ (declare (ignorable o)) *compile-file-failure-behaviour*)
+ (defmethod (setf operation-on-warnings) (x (o operation))
+ (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
+ (defmethod (setf operation-on-failure) (x (o operation))
+ (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
-;;;
-;;; PRECOMPILED FILES
-;;;
-;;; This component can be used to distribute ASDF systems in precompiled form.
-;;; Only useful when the dependencies have also been precompiled.
-;;;
-(with-upgradability ()
- (defmethod trivial-system-p ((s system))
- (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
+ (defun system-definition-pathname (x)
+ ;; As of 2.014.8, we mean to make this function obsolete,
+ ;; but that won't happen until all clients have been updated.
+ ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
+ "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
+It used to expose ASDF internals with subtle differences with respect to
+user expectations, that have been refactored away since.
+We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
+for a mostly compatible replacement that we're supporting,
+or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
+if that's whay you mean." ;;)
+ (system-source-file x)))
- (defmethod output-files (o (c compiled-file))
- (declare (ignorable o c))
- nil)
- (defmethod input-files (o (c compiled-file))
- (declare (ignorable o))
- (component-pathname c))
- (defmethod perform ((o load-op) (c compiled-file))
- (perform-lisp-load-fasl o c))
- (defmethod perform ((o load-source-op) (c compiled-file))
- (perform (find-operation o 'load-op) c))
- (defmethod perform ((o load-fasl-op) (c compiled-file))
- (perform (find-operation o 'load-op) c))
- (defmethod perform ((o operation) (c compiled-file))
- (declare (ignorable o c))
- nil))
-;;;
-;;; Pre-built systems
-;;;
+;;;; ASDF-Binary-Locations compatibility
+;; This remains supported for legacy user, but not recommended for new users.
(with-upgradability ()
- (defmethod trivial-system-p ((s prebuilt-system))
- (declare (ignorable s))
- t)
-
- (defmethod perform ((o lib-op) (c prebuilt-system))
- (declare (ignorable o c))
- nil)
-
- (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
- (declare (ignorable o c))
- nil)
+ (defun enable-asdf-binary-locations-compatibility
+ (&key
+ (centralize-lisp-binaries nil)
+ (default-toplevel-directory
+ (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
+ (include-per-user-information nil)
+ (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
+ (source-to-target-mappings nil)
+ (file-types `(,(compile-file-type)
+ "build-report"
+ #+ecl (compile-file-type :type :object)
+ #+mkcl (compile-file-type :fasl-p nil)
+ #+clisp "lib" #+sbcl "cfasl"
+ #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
+ #+(or clisp ecl mkcl)
+ (when (null map-all-source-files)
+ (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
+ (let* ((patterns (if map-all-source-files (list *wild-file*)
+ (loop :for type :in file-types
+ :collect (make-pathname :type type :defaults *wild-file*))))
+ (destination-directory
+ (if centralize-lisp-binaries
+ `(,default-toplevel-directory
+ ,@(when include-per-user-information
+ (cdr (pathname-directory (user-homedir-pathname))))
+ :implementation ,*wild-inferiors*)
+ `(:root ,*wild-inferiors* :implementation))))
+ (initialize-output-translations
+ `(:output-translations
+ , at source-to-target-mappings
+ #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
+ #+abcl (#p"/___jar___file___root___/**/*.*" (, at destination-directory))
+ ,@(loop :for pattern :in patterns
+ :collect `((:root ,*wild-inferiors* ,pattern)
+ (, at destination-directory ,pattern)))
+ (t t)
+ :ignore-inherited-configuration))))
- (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
- (declare (ignorable o))
- nil))
+ (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
+ (declare (ignorable operation-class system args))
+ (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
+ (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
+ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
+which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
+and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
+In case you insist on preserving your previous A-B-L configuration, but
+do not know how to achieve the same effect with A-O-T, you may use function
+ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
+call that function where you would otherwise have loaded and configured A-B-L."))))
-;;;
-;;; PREBUILT SYSTEM CREATOR
-;;;
+;;; run-shell-command
+;; WARNING! The function below is not just deprecated but also dysfunctional.
+;; Please use asdf/run-program:run-program instead.
(with-upgradability ()
- (defmethod output-files ((o binary-op) (s system))
- (list (make-pathname :name (component-name s) :type "asd"
- :defaults (component-pathname s))))
+ (defun run-shell-command (control-string &rest args)
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *VERBOSE-OUT*. Returns the shell's exit code.
- (defmethod perform ((o binary-op) (s system))
- (let* ((dependencies (component-depends-on o s))
- (fasl (first (apply #'output-files (first dependencies))))
- (library (first (apply #'output-files (second dependencies))))
- (asd (first (output-files o s)))
- (name (pathname-name asd))
- (name-keyword (intern (string name) (find-package :keyword))))
- (with-open-file (s asd :direction :output :if-exists :supersede
- :if-does-not-exist :create)
- (format s ";;; Prebuilt ASDF definition for system ~A" name)
- (format s ";;; Built for ~A ~A on a ~A/~A ~A"
- (lisp-implementation-type)
- (lisp-implementation-version)
- (software-type)
- (machine-type)
- (software-version))
- (let ((*package* (find-package :keyword)))
- (pprint `(defsystem ,name-keyword
- :class prebuilt-system
- :components ((:compiled-file ,(pathname-name fasl)))
- :lib ,(and library (file-namestring library)))
- s)))))
+PLEASE DO NOT USE.
+Deprecated function, for backward-compatibility only.
+Please use UIOP:RUN-PROGRAM instead."
+ (let ((command (apply 'format nil control-string args)))
+ (asdf-message "; $ ~A~%" command)
+ (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))
- #-(or ecl mkcl)
- (defmethod perform ((o fasl-op) (c system))
- (let* ((input-files (input-files o c))
- (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
- (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
- (output-files (output-files o c))
- (output-file (first output-files)))
- (unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
- (when input-files
- (assert output-files)
- (when non-fasl-files
- (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
- (implementation-type) non-fasl-files))
- (when (and (typep o 'monolithic-bundle-op)
- (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
- (error "prologue-code and epilogue-code are not supported on ~A"
- (implementation-type)))
- (with-staging-pathname (output-file)
- (combine-fasls fasl-files output-file)))))
+(with-upgradability ()
+ (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
- (defmethod input-files ((o load-op) (s precompiled-system))
- (declare (ignorable o))
- (bundle-output-files (find-operation o 'fasl-op) s))
+;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
+(with-upgradability ()
+ (defgeneric component-property (component property))
+ (defgeneric (setf component-property) (new-value component property))
- (defmethod perform ((o load-op) (s precompiled-system))
- (perform-lisp-load-fasl o s))
+ (defmethod component-property ((c component) property)
+ (cdr (assoc property (slot-value c 'properties) :test #'equal)))
- (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
- (declare (ignorable o))
- `((load-op ,s) ,@(call-next-method))))
+ (defmethod (setf component-property) (new-value (c component) property)
+ (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
+ (if a
+ (setf (cdr a) new-value)
+ (setf (slot-value c 'properties)
+ (acons property new-value (slot-value c 'properties)))))
+ new-value))
+;;;; -----------------------------------------------------------------
+;;;; Source Registry Configuration, by Francois-Rene Rideau
+;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
- #| ;; Example use:
-(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
-(asdf:load-system :precompiled-asdf-utils)
-|#
+(asdf/package:define-package :asdf/source-registry
+ (:recycle :asdf/source-registry :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
+ (:export
+ #:*source-registry-parameter* #:*default-source-registries*
+ #:invalid-source-registry
+ #:source-registry-initialized-p
+ #:initialize-source-registry #:clear-source-registry #:*source-registry*
+ #:ensure-source-registry #:*source-registry-parameter*
+ #:*default-source-registry-exclusions* #:*source-registry-exclusions*
+ #:*wild-asd* #:directory-asd-files #:register-asd-directory
+ #:collect-asds-in-directory #:collect-sub*directories-asd-files
+ #:validate-source-registry-directive #:validate-source-registry-form
+ #:validate-source-registry-file #:validate-source-registry-directory
+ #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
+ #:user-source-registry #:system-source-registry
+ #:user-source-registry-directory #:system-source-registry-directory
+ #:environment-source-registry #:process-source-registry
+ #:compute-source-registry #:flatten-source-registry
+ #:sysdef-source-registry-search))
+(in-package :asdf/source-registry)
-#+ecl
(with-upgradability ()
- (defmethod perform ((o bundle-op) (c system))
- (let* ((object-files (input-files o c))
- (output (output-files o c))
- (bundle (first output))
- (kind (bundle-type o)))
- (create-image
- bundle (append object-files (bundle-op-lisp-files o))
- :kind kind
- :entry-point (component-entry-point c)
- :prologue-code
- (when (typep o 'monolithic-bundle-op)
- (monolithic-op-prologue-code o))
- :epilogue-code
- (when (typep o 'monolithic-bundle-op)
- (monolithic-op-epilogue-code o))
- :build-args (bundle-op-build-args o)))))
+ (define-condition invalid-source-registry (invalid-configuration warning)
+ ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-#+mkcl
-(with-upgradability ()
- (defmethod perform ((o lib-op) (s system))
- (apply #'compiler::build-static-library (first output)
- :lisp-object-files (input-files o s) (bundle-op-build-args o)))
+ ;; Using ack 1.2 exclusions
+ (defvar *default-source-registry-exclusions*
+ '(".bzr" ".cdv"
+ ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
+ ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
+ "_sgbak" "autom4te.cache" "cover_db" "_build"
+ "debian")) ;; debian often builds stuff under the debian directory... BAD.
- (defmethod perform ((o fasl-op) (s system))
- (apply #'compiler::build-bundle (second output)
- :lisp-object-files (input-files o s) (bundle-op-build-args o)))
+ (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
- (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
- (declare (ignore force verbose version))
- (apply #'operate 'binary-op system args)))
+ (defvar *source-registry* nil
+ "Either NIL (for uninitialized), or an equal hash-table, mapping
+system names to pathnames of .asd files")
-#+(or ecl mkcl)
-(with-upgradability ()
- (defun register-pre-built-system (name)
- (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
+ (defun source-registry-initialized-p ()
+ (typep *source-registry* 'hash-table))
-;;;; -------------------------------------------------------------------------
-;;;; Concatenate-source
+ (defun clear-source-registry ()
+ "Undoes any initialization of the source registry."
+ (setf *source-registry* nil)
+ (values))
+ (register-clear-configuration-hook 'clear-source-registry)
-(asdf/package:define-package :asdf/concatenate-source
- (:recycle :asdf/concatenate-source :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/operation
- :asdf/system :asdf/find-system :asdf/defsystem
- :asdf/action :asdf/lisp-action :asdf/bundle)
- (:export
- #:concatenate-source-op
- #:load-concatenated-source-op
- #:compile-concatenated-source-op
- #:load-compiled-concatenated-source-op
- #:monolithic-concatenate-source-op
- #:monolithic-load-concatenated-source-op
- #:monolithic-compile-concatenated-source-op
- #:monolithic-load-compiled-concatenated-source-op))
-(in-package :asdf/concatenate-source)
+ (defparameter *wild-asd*
+ (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
-;;;
-;;; Concatenate sources
-;;;
-(with-upgradability ()
- (defclass concatenate-source-op (bundle-op)
- ((bundle-type :initform "lisp")))
- (defclass load-concatenated-source-op (basic-load-op operation)
- ((bundle-type :initform :no-output-file)))
- (defclass compile-concatenated-source-op (basic-compile-op bundle-op)
- ((bundle-type :initform :fasl)))
- (defclass load-compiled-concatenated-source-op (basic-load-op operation)
- ((bundle-type :initform :no-output-file)))
+ (defun directory-asd-files (directory)
+ (directory-files directory *wild-asd*))
- (defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ())
- (defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ())
- (defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
- (defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
+ (defun collect-asds-in-directory (directory collect)
+ (map () collect (directory-asd-files directory)))
- (defmethod input-files ((operation concatenate-source-op) (s system))
- (loop :with encoding = (or (component-encoding s) *default-encoding*)
- :with other-encodings = '()
- :with around-compile = (around-compile-hook s)
- :with other-around-compile = '()
- :for c :in (required-components
- s :goal-operation 'compile-op
- :keep-operation 'compile-op
- :other-systems (operation-monolithic-p operation))
- :append
- (when (typep c 'cl-source-file)
- (let ((e (component-encoding c)))
- (unless (equal e encoding)
- (pushnew e other-encodings :test 'equal)))
- (let ((a (around-compile-hook c)))
- (unless (equal a around-compile)
- (pushnew a other-around-compile :test 'equal)))
- (input-files (make-operation 'compile-op) c)) :into inputs
- :finally
- (when other-encodings
- (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
- operation encoding other-encodings))
- (when other-around-compile
- (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
- operation around-compile other-around-compile))
- (return inputs)))
+ (defun collect-sub*directories-asd-files
+ (directory &key (exclude *default-source-registry-exclusions*) collect)
+ (collect-sub*directories
+ directory
+ (constantly t)
+ #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
+ #'(lambda (dir) (collect-asds-in-directory dir collect))))
- (defmethod input-files ((o load-concatenated-source-op) (s system))
- (direct-dependency-files o s))
- (defmethod input-files ((o compile-concatenated-source-op) (s system))
- (direct-dependency-files o s))
- (defmethod output-files ((o compile-concatenated-source-op) (s system))
- (let ((input (first (input-files o s))))
- (list (compile-file-pathname input))))
- (defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
- (direct-dependency-files o s))
-
- (defmethod perform ((o concatenate-source-op) (s system))
- (let ((inputs (input-files o s))
- (output (output-file o s)))
- (concatenate-files inputs output)))
- (defmethod perform ((o load-concatenated-source-op) (s system))
- (perform-lisp-load-source o s))
- (defmethod perform ((o compile-concatenated-source-op) (s system))
- (perform-lisp-compilation o s))
- (defmethod perform ((o load-compiled-concatenated-source-op) (s system))
- (perform-lisp-load-fasl o s))
+ (defun validate-source-registry-directive (directive)
+ (or (member directive '(:default-registry))
+ (and (consp directive)
+ (let ((rest (rest directive)))
+ (case (first directive)
+ ((:include :directory :tree)
+ (and (length=n-p rest 1)
+ (location-designator-p (first rest))))
+ ((:exclude :also-exclude)
+ (every #'stringp rest))
+ ((:default-registry)
+ (null rest)))))))
- (defmethod component-depends-on ((o concatenate-source-op) (s system))
- (declare (ignorable o s)) nil)
- (defmethod component-depends-on ((o load-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s)))
- (defmethod component-depends-on ((o compile-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((concatenate-source-op ,s)))
- (defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((compile-concatenated-source-op ,s)))
-
- (defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system))
- (declare (ignorable o s)) nil)
- (defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
- (defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
- (defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s))))
+ (defun validate-source-registry-form (form &key location)
+ (validate-configuration-form
+ form :source-registry 'validate-source-registry-directive
+ :location location :invalid-form-reporter 'invalid-source-registry))
-;;;; -------------------------------------------------------------------------
-;;; Backward-compatible interfaces
+ (defun validate-source-registry-file (file)
+ (validate-configuration-file
+ file 'validate-source-registry-form :description "a source registry"))
-(asdf/package:define-package :asdf/backward-interface
- (:recycle :asdf/backward-interface :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
- :asdf/lisp-build :asdf/operate :asdf/output-translations)
- (:export
- #:*asdf-verbose*
- #:operation-error #:compile-error #:compile-failed #:compile-warned
- #:error-component #:error-operation
- #:component-load-dependencies
- #:enable-asdf-binary-locations-compatibility
- #:operation-forced
- #:operation-on-failure
- #:operation-on-warnings
- #:component-property
- #:run-shell-command
- #:system-definition-pathname))
-(in-package :asdf/backward-interface)
+ (defun validate-source-registry-directory (directory)
+ (validate-configuration-directory
+ directory :source-registry 'validate-source-registry-directive
+ :invalid-form-reporter 'invalid-source-registry))
-(with-upgradability ()
- (define-condition operation-error (error) ;; Bad, backward-compatible name
- ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
- ((component :reader error-component :initarg :component)
- (operation :reader error-operation :initarg :operation))
- (:report (lambda (c s)
- (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
- (type-of c) (error-operation c) (error-component c)))))
- (define-condition compile-error (operation-error) ())
- (define-condition compile-failed (compile-error) ())
- (define-condition compile-warned (compile-error) ())
+ (defun parse-source-registry-string (string &key location)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:source-registry :inherit-configuration))
+ ((not (stringp string))
+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
+ ((find (char string 0) "\"(")
+ (validate-source-registry-form (read-from-string string) :location location))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :with separator = (inter-directory-separator)
+ :for pos = (position separator string :start start) :do
+ (let ((s (subseq string start (or pos end))))
+ (flet ((check (dir)
+ (unless (absolute-pathname-p dir)
+ (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
+ dir))
+ (cond
+ ((equal "" s) ; empty element: inherit
+ (when inherit
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
+ (setf inherit t)
+ (push ':inherit-configuration directives))
+ ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
+ (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
+ (t
+ (push `(:directory ,(check s)) directives))))
+ (cond
+ (pos
+ (setf start (1+ pos)))
+ (t
+ (unless inherit
+ (push '(:ignore-inherited-configuration) directives))
+ (return `(:source-registry ,@(nreverse directives))))))))))
- (defun component-load-dependencies (component)
- ;; Old deprecated name for the same thing. Please update your software.
- (component-sibling-dependencies component))
+ (defun register-asd-directory (directory &key recurse exclude collect)
+ (if (not recurse)
+ (collect-asds-in-directory directory collect)
+ (collect-sub*directories-asd-files
+ directory :exclude exclude :collect collect)))
+
+ (defparameter *default-source-registries*
+ '(environment-source-registry
+ user-source-registry
+ user-source-registry-directory
+ system-source-registry
+ system-source-registry-directory
+ default-source-registry))
+
+ (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
+ (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
- (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
- (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
+ (defun wrapping-source-registry ()
+ `(:source-registry
+ #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
+ #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
+ :inherit-configuration
+ #+cmu (:tree #p"modules:")
+ #+scl (:tree #p"file://modules/")))
+ (defun default-source-registry ()
+ `(:source-registry
+ #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
+ ,@(loop :for dir :in
+ `(,@(when (os-unix-p)
+ `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
+ (subpathname (user-homedir-pathname) ".local/share/"))
+ ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
+ '("/usr/local/share" "/usr/share"))))
+ ,@(when (os-windows-p)
+ (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
+ :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+ :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+ :inherit-configuration))
+ (defun user-source-registry (&key (direction :input))
+ (in-user-configuration-directory *source-registry-file* :direction direction))
+ (defun system-source-registry (&key (direction :input))
+ (in-system-configuration-directory *source-registry-file* :direction direction))
+ (defun user-source-registry-directory (&key (direction :input))
+ (in-user-configuration-directory *source-registry-directory* :direction direction))
+ (defun system-source-registry-directory (&key (direction :input))
+ (in-system-configuration-directory *source-registry-directory* :direction direction))
+ (defun environment-source-registry ()
+ (getenv "CL_SOURCE_REGISTRY"))
- (defgeneric operation-on-warnings (operation))
- (defgeneric operation-on-failure (operation))
- #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
- #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
- (defmethod operation-on-warnings ((o operation))
- (declare (ignorable o)) *compile-file-warnings-behaviour*)
- (defmethod operation-on-failure ((o operation))
- (declare (ignorable o)) *compile-file-failure-behaviour*)
- (defmethod (setf operation-on-warnings) (x (o operation))
- (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
- (defmethod (setf operation-on-failure) (x (o operation))
- (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
+ (defgeneric* (process-source-registry) (spec &key inherit register))
- (defun system-definition-pathname (x)
- ;; As of 2.014.8, we mean to make this function obsolete,
- ;; but that won't happen until all clients have been updated.
- ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
- "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
-It used to expose ASDF internals with subtle differences with respect to
-user expectations, that have been refactored away since.
-We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
-for a mostly compatible replacement that we're supporting,
-or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
-if that's whay you mean." ;;)
- (system-source-file x)))
+ (defun* (inherit-source-registry) (inherit &key register)
+ (when inherit
+ (process-source-registry (first inherit) :register register :inherit (rest inherit))))
+ (defun* (process-source-registry-directive) (directive &key inherit register)
+ (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
+ (ecase kw
+ ((:include)
+ (destructuring-bind (pathname) rest
+ (process-source-registry (resolve-location pathname) :inherit nil :register register)))
+ ((:directory)
+ (destructuring-bind (pathname) rest
+ (when pathname
+ (funcall register (resolve-location pathname :ensure-directory t)))))
+ ((:tree)
+ (destructuring-bind (pathname) rest
+ (when pathname
+ (funcall register (resolve-location pathname :ensure-directory t)
+ :recurse t :exclude *source-registry-exclusions*))))
+ ((:exclude)
+ (setf *source-registry-exclusions* rest))
+ ((:also-exclude)
+ (appendf *source-registry-exclusions* rest))
+ ((:default-registry)
+ (inherit-source-registry '(default-source-registry) :register register))
+ ((:inherit-configuration)
+ (inherit-source-registry inherit :register register))
+ ((:ignore-inherited-configuration)
+ nil)))
+ nil)
-;;;; ASDF-Binary-Locations compatibility
-;; This remains supported for legacy user, but not recommended for new users.
-(with-upgradability ()
- (defun enable-asdf-binary-locations-compatibility
- (&key
- (centralize-lisp-binaries nil)
- (default-toplevel-directory
- (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
- (include-per-user-information nil)
- (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
- (source-to-target-mappings nil)
- (file-types `(,(compile-file-type)
- "build-report"
- #+ecl (compile-file-type :type :object)
- #+mkcl (compile-file-type :fasl-p nil)
- #+clisp "lib" #+sbcl "cfasl"
- #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
- #+(or clisp ecl mkcl)
- (when (null map-all-source-files)
- (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
- (let* ((patterns (if map-all-source-files (list *wild-file*)
- (loop :for type :in file-types
- :collect (make-pathname :type type :defaults *wild-file*))))
- (destination-directory
- (if centralize-lisp-binaries
- `(,default-toplevel-directory
- ,@(when include-per-user-information
- (cdr (pathname-directory (user-homedir-pathname))))
- :implementation ,*wild-inferiors*)
- `(:root ,*wild-inferiors* :implementation))))
- (initialize-output-translations
- `(:output-translations
- , at source-to-target-mappings
- #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
- #+abcl (#p"/___jar___file___root___/**/*.*" (, at destination-directory))
- ,@(loop :for pattern :in patterns
- :collect `((:root ,*wild-inferiors* ,pattern)
- (, at destination-directory ,pattern)))
- (t t)
- :ignore-inherited-configuration))))
+ (defmethod process-source-registry ((x symbol) &key inherit register)
+ (process-source-registry (funcall x) :inherit inherit :register register))
+ (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
+ (cond
+ ((directory-pathname-p pathname)
+ (let ((*here-directory* (resolve-symlinks* pathname)))
+ (process-source-registry (validate-source-registry-directory pathname)
+ :inherit inherit :register register)))
+ ((probe-file* pathname :truename *resolve-symlinks*)
+ (let ((*here-directory* (pathname-directory-pathname pathname)))
+ (process-source-registry (validate-source-registry-file pathname)
+ :inherit inherit :register register)))
+ (t
+ (inherit-source-registry inherit :register register))))
+ (defmethod process-source-registry ((string string) &key inherit register)
+ (process-source-registry (parse-source-registry-string string)
+ :inherit inherit :register register))
+ (defmethod process-source-registry ((x null) &key inherit register)
+ (declare (ignorable x))
+ (inherit-source-registry inherit :register register))
+ (defmethod process-source-registry ((form cons) &key inherit register)
+ (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
+ (dolist (directive (cdr (validate-source-registry-form form)))
+ (process-source-registry-directive directive :inherit inherit :register register))))
- (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
- (declare (ignorable operation-class system args))
- (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
- (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
-ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
-which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
-and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
-In case you insist on preserving your previous A-B-L configuration, but
-do not know how to achieve the same effect with A-O-T, you may use function
-ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
-call that function where you would otherwise have loaded and configured A-B-L."))))
+ (defun flatten-source-registry (&optional parameter)
+ (remove-duplicates
+ (while-collecting (collect)
+ (with-pathname-defaults () ;; be location-independent
+ (inherit-source-registry
+ `(wrapping-source-registry
+ ,parameter
+ ,@*default-source-registries*)
+ :register #'(lambda (directory &key recurse exclude)
+ (collect (list directory :recurse recurse :exclude exclude))))))
+ :test 'equal :from-end t))
+ ;; Will read the configuration and initialize all internal variables.
+ (defun compute-source-registry (&optional parameter (registry *source-registry*))
+ (dolist (entry (flatten-source-registry parameter))
+ (destructuring-bind (directory &key recurse exclude) entry
+ (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
+ (register-asd-directory
+ directory :recurse recurse :exclude exclude :collect
+ #'(lambda (asd)
+ (let* ((name (pathname-name asd))
+ (name (if (typep asd 'logical-pathname)
+ ;; logical pathnames are upper-case,
+ ;; at least in the CLHS and on SBCL,
+ ;; yet (coerce-name :foo) is lower-case.
+ ;; won't work well with (load-system "Foo")
+ ;; instead of (load-system 'foo)
+ (string-downcase name)
+ name)))
+ (cond
+ ((gethash name registry) ; already shadowed by something else
+ nil)
+ ((gethash name h) ; conflict at current level
+ (when *verbose-out*
+ (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
+ found several entries for ~A - picking ~S over ~S~:>")
+ directory recurse name (gethash name h) asd)))
+ (t
+ (setf (gethash name registry) asd)
+ (setf (gethash name h) asd))))))
+ h)))
+ (values))
-;;; run-shell-command
-;; WARNING! The function below is not just deprecated but also dysfunctional.
-;; Please use asdf/run-program:run-program instead.
-(with-upgradability ()
- (defun run-shell-command (control-string &rest args)
- "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
-synchronously execute the result using a Bourne-compatible shell, with
-output to *VERBOSE-OUT*. Returns the shell's exit code.
+ (defvar *source-registry-parameter* nil)
-PLEASE DO NOT USE.
-Deprecated function, for backward-compatibility only.
-Please use ASDF-DRIVER:RUN-PROGRAM instead."
- (let ((command (apply 'format nil control-string args)))
- (asdf-message "; $ ~A~%" command)
- (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))
+ (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
+ ;; Record the parameter used to configure the registry
+ (setf *source-registry-parameter* parameter)
+ ;; Clear the previous registry database:
+ (setf *source-registry* (make-hash-table :test 'equal))
+ ;; Do it!
+ (compute-source-registry parameter))
-(with-upgradability ()
- (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
+ ;; Checks an initial variable to see whether the state is initialized
+ ;; or cleared. In the former case, return current configuration; in
+ ;; the latter, initialize. ASDF will call this function at the start
+ ;; of (asdf:find-system) to make sure the source registry is initialized.
+ ;; However, it will do so *without* a parameter, at which point it
+ ;; will be too late to provide a parameter to this function, though
+ ;; you may override the configuration explicitly by calling
+ ;; initialize-source-registry directly with your parameter.
+ (defun ensure-source-registry (&optional parameter)
+ (unless (source-registry-initialized-p)
+ (initialize-source-registry parameter))
+ (values))
-;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
-(with-upgradability ()
- (defgeneric component-property (component property))
- (defgeneric (setf component-property) (new-value component property))
+ (defun sysdef-source-registry-search (system)
+ (ensure-source-registry)
+ (values (gethash (primary-system-name system) *source-registry*))))
- (defmethod component-property ((c component) property)
- (cdr (assoc property (slot-value c 'properties) :test #'equal)))
- (defmethod (setf component-property) (new-value (c component) property)
- (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
- (if a
- (setf (cdr a) new-value)
- (setf (slot-value c 'properties)
- (acons property new-value (slot-value c 'properties)))))
- new-value))
;;;; ---------------------------------------------------------------------------
;;;; Handle ASDF package upgrade, including implementation-dependent magic.
@@ -9263,25 +9516,28 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead."
;; TODO: automatically generate interface with reexport?
(:export
#:defsystem #:find-system #:locate-system #:coerce-name
- #:oos #:operate #:traverse #:perform-plan
+ #:oos #:operate #:traverse #:perform-plan #:sequential-plan
#:system-definition-pathname #:with-system-definitions
#:search-for-system-definition #:find-component #:component-find-path
#:compile-system #:load-system #:load-systems
#:require-system #:test-system #:clear-system
- #:operation #:upward-operation #:downward-operation #:make-operation
+ #:operation #:make-operation #:find-operation
+ #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation
#:build-system #:build-op
#:load-op #:prepare-op #:compile-op
#:prepare-source-op #:load-source-op #:test-op
#:feature #:version #:version-satisfies #:upgrade-asdf
#:implementation-identifier #:implementation-type #:hostname
#:input-files #:output-files #:output-file #:perform
- #:operation-done-p #:explain #:action-description #:component-sibling-dependencies
+ #:operation-done-p #:explain #:action-description #:component-sideway-dependencies
#:needed-in-image-p
;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT.
#:component-load-dependencies #:run-shell-command ; deprecated, do not use
- #:bundle-op #:precompiled-system #:compiled-file #:bundle-system
+ #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
#+ecl #:make-build
- #:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op
+ #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
+ #:lib-op #:dll-op #:binary-op #:program-op
+ #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op
#:concatenate-source-op
#:load-concatenated-source-op
#:compile-concatenated-source-op
@@ -9357,7 +9613,7 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead."
#:missing-dependency
#:missing-dependency-of-version
#:circular-dependency ; errors
- #:duplicate-names
+ #:duplicate-names #:non-toplevel-system #:non-system-system
#:try-recompiling
#:retry
@@ -9391,6 +9647,7 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead."
#:system-registered-p #:registered-systems #:already-loaded-systems
#:resolve-location
#:asdf-message
+ #:*user-cache*
#:user-output-translations-pathname
#:system-output-translations-pathname
#:user-output-translations-directory-pathname
diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt
index f36f6d0..90df1d4 100644
--- a/src/general-info/release-20e.txt
+++ b/src/general-info/release-20e.txt
@@ -23,7 +23,7 @@ New in this release:
* Feature enhancements
* Changes
- * ASDF2 updated to version 2.32.
+ * ASDF2 updated to version 3.0.1..
* DEFINE-COMPILER-MACRO now has source-location information for
the macro definition.
* :ALIEN-CALLBACK added to *FEATURES* for platforms that support
-----------------------------------------------------------------------
Summary of changes:
src/contrib/asdf/asdf.lisp | 3683 ++++++++++++++++++++------------------
src/general-info/release-20e.txt | 2 +-
2 files changed, 1971 insertions(+), 1714 deletions(-)
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list