[armedbear-cvs] r14461 - in trunk/abcl: doc/asdf src/org/armedbear/lisp
mevenson at common-lisp.net
mevenson at common-lisp.net
Thu Apr 4 13:57:21 UTC 2013
Author: mevenson
Date: Thu Apr 4 06:57:20 2013
New Revision: 14461
Log:
Update to asdf-2.33.
Modified:
trunk/abcl/doc/asdf/asdf.texinfo
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
Modified: trunk/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- trunk/abcl/doc/asdf/asdf.texinfo Wed Apr 3 14:34:53 2013 (r14460)
+++ trunk/abcl/doc/asdf/asdf.texinfo Thu Apr 4 06:57:20 2013 (r14461)
@@ -993,7 +993,7 @@
component-def := ( component-type simple-component-name @var{option}* )
-component-type := :system | :module | :file | :static-file | other-component-type
+component-type := :module | :file | :static-file | other-component-type
other-component-type := symbol-by-name (@pxref{The defsystem grammar,,Component types})
@@ -1035,10 +1035,15 @@
the current package @code{my-system-asd} can be specified as
@code{:my-component-type}, or @code{my-component-type}.
+ at code{system} and its subclasses are @emph{not}
+allowed as component types for such children components.
+
@subsection System class names
-A system class name will be looked up in the same way as a Component
-type (see above). Typically, one will not need to specify a system
+A system class name will be looked up
+in the same way as a Component type (see above),
+except that only @code{system} and its subclasses are allowed.
+Typically, one will not need to specify a system
class name, unless using a non-standard system class defined in some
ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON},
see below. For such class names in the ASDF package, we recommend that
Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Wed Apr 3 14:34:53 2013 (r14460)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Thu Apr 4 06:57:20 2013 (r14461)
@@ -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 2.33: 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 @@
#+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 @@
;;; 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 @@
: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 @@
(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 @@
(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?"
@@ -2427,8 +2465,14 @@
(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 +2485,7 @@
;; 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 +2500,7 @@
;; 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 +2608,18 @@
(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 +2654,11 @@
(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 +2705,10 @@
: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 +2846,8 @@
(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 +2907,10 @@
(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 +2966,85 @@
#+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
@@ -2926,7 +3062,7 @@
#:with-output #:output-string #:with-input
#:with-input-file #:call-with-input-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
@@ -3158,6 +3294,10 @@
: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 +3448,7 @@
#+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 +3550,9 @@
(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 +3745,17 @@
((: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 +3768,16 @@
;;; 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 +3796,16 @@
;; :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 +3829,36 @@
: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
@@ -3969,7 +4132,7 @@
#+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 +4158,9 @@
;; 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 +4183,7 @@
#+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 +4222,9 @@
(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 +4232,7 @@
#+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 +4274,15 @@
#: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 +4313,16 @@
(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 +4347,7 @@
(deftype sb-grovel-unknown-constant-condition ()
'(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
- (defvar *uninteresting-compiler-conditions*
+ (defvar *uninteresting-conditions*
(append
;;#+clozure '(ccl:compiler-warning)
#+cmu '("Deleting unreachable code.")
@@ -4188,38 +4356,39 @@
#+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. Let's allow it by default.
+ 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")
-
+ "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 +4491,18 @@
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 +4510,10 @@
(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 +4522,8 @@
: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 +4929,12 @@
;;; 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 +4943,8 @@
: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))
@@ -4794,7 +4970,7 @@
#: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))
@@ -5188,7 +5364,7 @@
;; "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 "2.33")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
@@ -5205,7 +5381,7 @@
#: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 +5395,17 @@
(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 +5467,7 @@
#: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 +5486,7 @@
#: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 +5530,7 @@
(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.
@@ -6354,8 +6532,8 @@
(: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 +6611,7 @@
;;;; 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 +6629,15 @@
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 +6647,7 @@
(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 +6655,7 @@
;; 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 +6664,22 @@
;; 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 +6729,16 @@
(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 +6845,8 @@
#: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 +6870,23 @@
;;; 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 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-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 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 +6962,7 @@
(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 +6976,8 @@
,(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 +7027,7 @@
(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 +7055,6 @@
(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 +7080,7 @@
(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
@@ -7296,9 +7470,10 @@
(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 +7522,8 @@
(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 +7616,7 @@
(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)
@@ -7613,7 +7789,10 @@
(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
+ #-gcl2.6
+ (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
+ #+gcl2.6
+ (defsetf output-translations set-output-translations)
(defun output-translations-initialized-p ()
(and *output-translations* t))
@@ -8226,23 +8405,18 @@
(component-inline-methods component) nil)
(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)))))))))
+ (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 %refresh-component-inline-methods (component rest)
;; clear methods, then add the new ones
@@ -8301,7 +8475,8 @@
#:defsystem #:register-system-definition
#:class-for-type #:*default-component-class*
#:determine-system-directory #:parse-component-form
- #:duplicate-names #:sysdef-error-component #:check-component-input))
+ #:duplicate-names #:non-toplevel-system #:non-system-system
+ #:sysdef-error-component #:check-component-input))
(in-package :asdf/defsystem)
;;; Pathname
@@ -8361,6 +8536,20 @@
(format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
(duplicate-names-name c)))))
+ (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))))
+
+ (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 sysdef-error-component (msg type name value)
(sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
type name value))
@@ -8430,7 +8619,8 @@
(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)
+ (let* ((name (coerce-name name))
+ (args `(:name ,name
:pathname ,pathname
,@(when parent `(:parent ,parent))
,@(remove-plist-keys
@@ -8438,16 +8628,13 @@
: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))
+ (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-for-type parent type) 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))
@@ -8467,8 +8654,14 @@
: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-sibling-dependencies 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))
@@ -8501,6 +8694,8 @@
;; 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
@@ -8520,13 +8715,14 @@
: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
+ #: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
@@ -8542,27 +8738,37 @@
#+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)))
- (defclass fasl-op (bundle-op)
- ;; create a single fasl for the entire library
- ((bundle-type :initform :fasl)))
-
- (defclass load-fasl-op (basic-load-op)
- ;; load a single fasl for the entire library
- ())
+ (defclass bundle-compile-op (bundle-op basic-compile-op)
+ ()
+ (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files"))
- (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)))
-
- (defclass dll-op (bundle-op)
- ;; Link together all the dynamic library used by this system into a single one.
- ((bundle-type :initform :dll)))
-
- (defclass binary-op (bundle-op)
- ;; On ECL: produce lib and fasl for the system.
- ;; On "normal" Lisps: produce just the fasl.
- ())
+ ;; 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"))
(defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
@@ -8570,29 +8776,36 @@
((prologue-code :accessor monolithic-op-prologue-code)
(epilogue-code :accessor monolithic-op-epilogue-code)))
- (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.
- ())
-
- (defclass monolithic-fasl-op (monolithic-bundle-op fasl-op)
- ;; Create a single fasl for the system and its dependencies.
- ())
-
- (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)))
-
- (defclass monolithic-dll-op (monolithic-bundle-op dll-op)
- ((bundle-type :initform :dll)))
-
- (defclass program-op (monolithic-bundle-op)
- ;; All: create an executable file from the system and its dependencies
- ((bundle-type :initform :program)))
+ (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"))
+
+ (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."))
+
+ (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."))
+
+ (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)))
+
+ (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 bundle-pathname-type (bundle-type)
(etypecase bundle-type
- ((eql :no-output-file) nil) ;; should we error out instead?
+ ((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
@@ -8604,27 +8817,23 @@
((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
(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 (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))))))))
(defmethod output-files ((o bundle-op) (c system))
(bundle-output-files o c))
#-(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)))
-
- (defmethod perform ((o monolithic-binary-op) (c system))
- (let ((output-file (output-file o c)))
- (dump-image output-file))))
+ (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")))
@@ -8684,7 +8893,7 @@
(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)))))
+ #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
(defgeneric* (trivial-system-p) (component))
@@ -8705,50 +8914,17 @@
;;; 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))))
-
- (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))))
-
- (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)))
-
- (defmethod component-depends-on ((o binary-op) (c system))
- (declare (ignorable o))
- `((fasl-op ,c)
- (lib-op ,c)))
-
- (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 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))))
-
- (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))
-
- (defmethod component-depends-on ((o dll-op) c)
- (component-depends-on (find-operation o 'lib-op) c))
-
- (defmethod component-depends-on ((o bundle-op) c)
- (declare (ignorable o c))
- nil)
+ (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)))
(defmethod component-depends-on :around ((o bundle-op) (c component))
(declare (ignorable o c))
@@ -8757,14 +8933,17 @@
(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-op) (c system))
- (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))
+ (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)))
(defun select-bundle-operation (type &optional monolithic)
(ecase type
@@ -8811,7 +8990,7 @@
(with-upgradability ()
(defmethod component-depends-on ((o load-fasl-op) (c system))
(declare (ignorable o))
- `((,o ,@(loop :for dep :in (component-sibling-dependencies c)
+ `((,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)))
@@ -8825,7 +9004,8 @@
nil)
(defmethod perform ((o load-fasl-op) (c system))
- (perform-lisp-load-fasl o c))
+ (when (input-files o c)
+ (perform-lisp-load-fasl o c)))
(defmethod mark-operation-done :after ((o load-fasl-op) (c system))
(mark-operation-done (find-operation o 'load-op) c)))
@@ -8886,38 +9066,55 @@
:defaults (component-pathname s))))
(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))))
+ (let* ((inputs (input-files o s))
+ (fasl (first inputs))
+ (library (second inputs))
(asd (first (output-files o s)))
- (name (pathname-name asd))
- (name-keyword (intern (string name) (find-package :keyword))))
+ (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 ASDF definition for system ~A" name)
- (format s ";;; Built for ~A ~A on a ~A/~A ~A"
+ (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 :keyword)))
- (pprint `(defsystem ,name-keyword
+ (let ((*package* (find-package :asdf-user)))
+ (pprint `(defsystem ,name
:class prebuilt-system
+ :depends-on ,depends-on
:components ((:compiled-file ,(pathname-name fasl)))
- :lib ,(and library (file-namestring library)))
- s)))))
+ ,@(when library `(:lib ,(file-namestring library))))
+ s)
+ (terpri s)))))
#-(or ecl mkcl)
- (defmethod perform ((o fasl-op) (c system))
+ (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)))
- (unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
+ (assert (eq (not input-files) (not output-files)))
(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))
@@ -8946,31 +9143,32 @@
#+ecl
(with-upgradability ()
- (defmethod perform ((o bundle-op) (c system))
+ (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)))
- (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)))))
+ (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))))))
#+mkcl
(with-upgradability ()
(defmethod perform ((o lib-op) (s system))
- (apply #'compiler::build-static-library (first output)
+ (apply #'compiler::build-static-library (output-file o c)
:lisp-object-files (input-files o s) (bundle-op-build-args o)))
- (defmethod perform ((o fasl-op) (s system))
- (apply #'compiler::build-bundle (second output)
+ (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)))
(defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
@@ -9006,21 +9204,29 @@
;;; Concatenate sources
;;;
(with-upgradability ()
- (defclass concatenate-source-op (bundle-op)
+ (defclass basic-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)))
-
- (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) ())
+ (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 concatenate-source-op) (s system))
+ (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)
@@ -9046,45 +9252,19 @@
(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))
- (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))
+ (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 load-concatenated-source-op) (s system))
+ (defmethod perform ((o basic-load-concatenated-source-op) (s system))
(perform-lisp-load-source o s))
- (defmethod perform ((o compile-concatenated-source-op) (s system))
+ (defmethod perform ((o basic-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))
-
- (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))))
+ (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
+ (perform-lisp-load-fasl o s)))
;;;; -------------------------------------------------------------------------
;;; Backward-compatible interfaces
@@ -9122,7 +9302,7 @@
(defun component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software.
- (component-sibling-dependencies component))
+ (component-sideway-dependencies component))
(defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
@@ -9268,20 +9448,23 @@
#: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 +9540,7 @@
#:missing-dependency
#:missing-dependency-of-version
#:circular-dependency ; errors
- #:duplicate-names
+ #:duplicate-names #:non-toplevel-system #:non-system-system
#:try-recompiling
#:retry
@@ -9391,6 +9574,7 @@
#: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
More information about the armedbear-cvs
mailing list