Skip to content
Snippets Groups Projects
Commit a90ddc62 authored by Raymond Toy's avatar Raymond Toy
Browse files

Update to asdf 3.0.2.

parent d2e0e8e2
Branches
Tags
No related merge requests found
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 3.0.1: Another System Definition Facility. ;;; This is ASDF 3.0.2: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
...@@ -70,8 +70,8 @@ ...@@ -70,8 +70,8 @@
(existing-major-minor (subseq existing-version 0 second-dot)) (existing-major-minor (subseq existing-version 0 second-dot))
(existing-version-number (and existing-version (read-from-string existing-major-minor))) (existing-version-number (and existing-version (read-from-string existing-major-minor)))
(away (format nil "~A-~A" :asdf existing-version))) (away (format nil "~A-~A" :asdf existing-version)))
(when (and existing-version (< existing-version-number (when (and existing-version
(or #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27))) (< existing-version-number #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27))
(rename-package :asdf away) (rename-package :asdf away)
(when *load-verbose* (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))))))
...@@ -1514,20 +1514,23 @@ or a string describing the format-control of a simple-condition." ...@@ -1514,20 +1514,23 @@ or a string describing the format-control of a simple-condition."
(defun os-windows-p () (defun os-windows-p ()
(or #+abcl (featurep :windows) (or #+abcl (featurep :windows)
#+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t)) #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
(defun os-genera-p () (defun os-genera-p ()
(or #+genera t)) (or #+genera t))
(defun os-oldmac-p ()
(or #+mcl t))
(defun detect-os () (defun detect-os ()
(flet ((yes (yes) (pushnew yes *features*)) (loop* :with o
(no (no) (setf *features* (remove no *features*)))) :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p)
(cond (:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera)) :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*)
((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera)) :else :do (setf *features* (remove feature *features*))
((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera)) :finally
(t (error "Congratulations for trying XCVB on an operating system~%~ (return (or o (error "Congratulations for trying ASDF on an operating system~%~
that is neither Unix, nor Windows, nor even Genera.~%Now you port it."))))) that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
(detect-os)) (detect-os))
...@@ -1911,6 +1914,7 @@ then returning the non-empty string value of the variable" ...@@ -1911,6 +1914,7 @@ then returning the non-empty string value of the variable"
"Takes arguments like CL:MAKE-PATHNAME in the CLHS, and "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
tries hard to make a pathname that will actually behave as documented, tries hard to make a pathname that will actually behave as documented,
despite the peculiarities of each implementation" despite the peculiarities of each implementation"
;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults.
(declare (ignorable host device directory name type version defaults)) (declare (ignorable host device directory name type version defaults))
(apply 'make-pathname (apply 'make-pathname
(append (append
...@@ -1986,12 +1990,14 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." ...@@ -1986,12 +1990,14 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
;; see also "valid physical pathname host" in the CLHS glossary, that suggests ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
;; strings and lists of strings or :unspecific ;; strings and lists of strings or :unspecific
;; But CMUCL decides to die on NIL. ;; But CMUCL decides to die on NIL.
;; MCL has issues with make-pathname, nil and defaulting
(declare (ignorable defaults))
#.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
:host (or #+cmu lisp::*unix-host*) :host (or #+cmu lisp::*unix-host*)
#+scl ,@'(:scheme nil :scheme-specific-part nil #+scl ,@'(:scheme nil :scheme-specific-part nil
:username nil :password nil :parameters nil :query nil :fragment nil) :username nil :password nil :parameters nil :query nil :fragment nil)
;; the default shouldn't matter, but we really want something physical ;; the default shouldn't matter, but we really want something physical
:defaults defaults)) #-mcl ,@'(:defaults defaults)))
(defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname)))) (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
...@@ -2259,7 +2265,7 @@ to throw an error if the pathname is absolute" ...@@ -2259,7 +2265,7 @@ to throw an error if the pathname is absolute"
(make-pathname* (make-pathname*
:directory (unless file-only (cons relative path)) :directory (unless file-only (cons relative path))
:name name :type type :name name :type type
:defaults (or defaults *nil-pathname*)) :defaults (or #-mcl defaults *nil-pathname*))
(remove-plist-keys '(:type :dot-dot :defaults) keys)))))) (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
(defun unix-namestring (pathname) (defun unix-namestring (pathname)
...@@ -3143,7 +3149,7 @@ hopefully, if done consistently, that won't affect program behavior too much.") ...@@ -3143,7 +3149,7 @@ hopefully, if done consistently, that won't affect program behavior too much.")
and implementation-defined external-format's") and implementation-defined external-format's")
(defun encoding-external-format (encoding) (defun encoding-external-format (encoding)
(funcall *encoding-external-format-hook* encoding))) (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
;;; Safe syntax ;;; Safe syntax
...@@ -3613,7 +3619,7 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -3613,7 +3619,7 @@ This is designed to abstract away the implementation specific quit forms."
#+gcl (lisp:quit code) #+gcl (lisp:quit code)
#+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
#+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
#+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
#+mkcl (mk-ext:quit :exit-code code) #+mkcl (mk-ext:quit :exit-code code)
#+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil)) #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
(quit (find-symbol* :quit :sb-ext nil))) (quit (find-symbol* :quit :sb-ext nil)))
...@@ -3627,9 +3633,7 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -3627,9 +3633,7 @@ This is designed to abstract away the implementation specific quit forms."
"Die in error with some error message" "Die in error with some error message"
(with-safe-io-syntax () (with-safe-io-syntax ()
(ignore-errors (ignore-errors
(fresh-line *stderr*) (format! *stderr* "~&~?~&" format arguments)))
(apply #'format *stderr* format arguments)
(format! *stderr* "~&")))
(quit code)) (quit code))
(defun raw-print-backtrace (&key (stream *debug-io*) count) (defun raw-print-backtrace (&key (stream *debug-io*) count)
...@@ -3651,7 +3655,8 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -3651,7 +3655,8 @@ This is designed to abstract away the implementation specific quit forms."
(system::print-backtrace :out stream :limit count) (system::print-backtrace :out stream :limit count)
#+(or clozure mcl) #+(or clozure mcl)
(let ((*debug-io* stream)) (let ((*debug-io* stream))
(ccl:print-call-history :count count :start-frame-number 1) #+clozure (ccl:print-call-history :count count :start-frame-number 1)
#+mcl (ccl:print-call-history :detailed-p nil)
(finish-output stream)) (finish-output stream))
#+(or cmu scl) #+(or cmu scl)
(let ((debug:*debug-print-level* *print-level*) (let ((debug:*debug-print-level* *print-level*)
...@@ -3742,11 +3747,11 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -3742,11 +3747,11 @@ This is designed to abstract away the implementation specific quit forms."
#+(or cmu scl) extensions:*command-line-strings* #+(or cmu scl) extensions:*command-line-strings*
#+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
#+gcl si:*command-args* #+gcl si:*command-args*
#+genera nil #+(or genera mcl) nil
#+lispworks sys:*line-arguments-list* #+lispworks sys:*line-arguments-list*
#+sbcl sb-ext:*posix-argv* #+sbcl sb-ext:*posix-argv*
#+xcl system:*argv* #+xcl system:*argv*
#-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl) #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl)
(error "raw-command-line-arguments not implemented yet")) (error "raw-command-line-arguments not implemented yet"))
(defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
...@@ -4139,10 +4144,22 @@ return the exit status code of the process that was called. ...@@ -4139,10 +4144,22 @@ return the exit status code of the process that was called.
if it was NIL, the output is discarded; if it was NIL, the output is discarded;
if it was :INTERACTIVE, the output and the input are inherited from the current process. 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, Otherwise, OUTPUT should be a value that is a suitable first argument to
using OUTPUT as the first argument, and return whatever it returns, SLURP-INPUT-STREAM. In this case, RUN-PROGRAM will create a temporary stream
e.g. using :OUTPUT :STRING will have it return the entire output stream as a string. for the program output. The program output, in that stream, will be processed
Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor." by SLURP-INPUT-STREAM, according to the using OUTPUT as the first argument.
RUN-PROGRAM will return whatever SLURP-INPUT-STREAM 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: The current version does not honor :OUTPUT NIL on Allegro. Setting
;; the :INPUT and :OUTPUT arguments to RUN-SHELL-COMMAND on ACL actually do
;; what :OUTPUT :INTERACTIVE is advertised to do here. To get the behavior
;; specified for :OUTPUT NIL, one would have to grab up the process output
;; into a stream and then throw it on the floor. The consequences of
;; getting this wrong seemed so much worse than having excess output that it
;; is not currently implemented.
;; TODO: specially recognize :output pathname ? ;; TODO: specially recognize :output pathname ?
(declare (ignorable ignore-error-status element-type external-format)) (declare (ignorable ignore-error-status element-type external-format))
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
...@@ -4184,7 +4201,8 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process ...@@ -4184,7 +4201,8 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
(excl:run-shell-command (excl:run-shell-command
#+os-unix (coerce (cons (first command) command) 'vector) #+os-unix (coerce (cons (first command) command) 'vector)
#+os-windows command #+os-windows command
:input interactive :output (or (and pipe :stream) interactive) :wait wait :input nil
:output (and pipe :stream) :wait wait
#+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide)) #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide))
#+clisp #+clisp
(flet ((run (f &rest args) (flet ((run (f &rest args)
...@@ -4276,8 +4294,12 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process ...@@ -4276,8 +4294,12 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
#+(or abcl xcl) (ext:run-shell-command command) #+(or abcl xcl) (ext:run-shell-command command)
#+allegro #+allegro
(excl:run-shell-command (excl:run-shell-command
command :input interactive :output interactive :wait t command
#+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide)) :input nil
:output nil
:error-output :output ; write STDERR to output, too
: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) #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
(process-result (run-program command :pipe nil :interactive interactive) nil) (process-result (run-program command :pipe nil :interactive interactive) nil)
#+ecl (ext:system command) #+ecl (ext:system command)
...@@ -4626,7 +4648,7 @@ using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently ...@@ -4626,7 +4648,7 @@ using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently
WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
#+allegro #+allegro
(list :functions-defined excl::.functions-defined. (list :functions-defined excl::.functions-defined.
:functions-called excl::.functions-called.) :functions-called excl::.functions-called.)
#+clozure #+clozure
(mapcar 'reify-deferred-warning (mapcar 'reify-deferred-warning
(if-let (dw ccl::*outstanding-deferred-warnings*) (if-let (dw ccl::*outstanding-deferred-warnings*)
...@@ -4668,7 +4690,7 @@ One of three functions required for deferred-warnings support in ASDF." ...@@ -4668,7 +4690,7 @@ One of three functions required for deferred-warnings support in ASDF."
(declare (ignorable reified-deferred-warnings)) (declare (ignorable reified-deferred-warnings))
#+allegro #+allegro
(destructuring-bind (&key functions-defined functions-called) (destructuring-bind (&key functions-defined functions-called)
reified-deferred-warnings reified-deferred-warnings
(setf excl::.functions-defined. (setf excl::.functions-defined.
(append functions-defined excl::.functions-defined.) (append functions-defined excl::.functions-defined.)
excl::.functions-called. excl::.functions-called.
...@@ -4883,7 +4905,7 @@ possibly in a different process. Otherwise just run the BODY." ...@@ -4883,7 +4905,7 @@ possibly in a different process. Otherwise just run the BODY."
(defun* (compile-file*) (input-file &rest keys (defun* (compile-file*) (input-file &rest keys
&key compile-check output-file warnings-file &key compile-check output-file warnings-file
#+clisp lib-file #+(or ecl mkcl) object-file #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
&allow-other-keys) &allow-other-keys)
"This function provides a portable wrapper around COMPILE-FILE. "This function provides a portable wrapper around COMPILE-FILE.
It ensures that the OUTPUT-FILE value is only returned and It ensures that the OUTPUT-FILE value is only returned and
...@@ -4924,12 +4946,23 @@ it will filter them appropriately." ...@@ -4924,12 +4946,23 @@ it will filter them appropriately."
(or object-file (or object-file
(compile-file-pathname output-file :fasl-p nil))) (compile-file-pathname output-file :fasl-p nil)))
(tmp-file (tmpize-pathname output-file)) (tmp-file (tmpize-pathname output-file))
#+sbcl
(cfasl-file (etypecase emit-cfasl
(null nil)
((eql t) (make-pathname :type "cfasl" :defaults output-file))
(string (parse-namestring emit-cfasl))
(pathname emit-cfasl)))
#+sbcl
(tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
#+clisp #+clisp
(tmp-lib (make-pathname :type "lib" :defaults tmp-file))) (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
(multiple-value-bind (output-truename warnings-p failure-p) (multiple-value-bind (output-truename warnings-p failure-p)
(with-saved-deferred-warnings (warnings-file) (with-saved-deferred-warnings (warnings-file)
(with-muffled-compiler-conditions () (with-muffled-compiler-conditions ()
(or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords) (or #-(or ecl mkcl)
(apply 'compile-file input-file :output-file tmp-file
#+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
#-sbcl keywords)
#+ecl (apply 'compile-file input-file :output-file #+ecl (apply 'compile-file input-file :output-file
(if object-file (if object-file
(list* object-file :system-p t keywords) (list* object-file :system-p t keywords)
...@@ -4954,11 +4987,14 @@ it will filter them appropriately." ...@@ -4954,11 +4987,14 @@ it will filter them appropriately."
(delete-file-if-exists output-file) (delete-file-if-exists output-file)
(when output-truename (when output-truename
#+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file)) #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
#+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
(rename-file-overwriting-target output-truename output-file) (rename-file-overwriting-target output-truename output-file)
(setf output-truename (truename output-file))) (setf output-truename (truename output-file)))
#+clisp (delete-file-if-exists tmp-lib)) #+clisp (delete-file-if-exists tmp-lib))
(t ;; error or failed check (t ;; error or failed check
(delete-file-if-exists output-truename) (delete-file-if-exists output-truename)
#+clisp (delete-file-if-exists tmp-lib)
#+sbcl (delete-file-if-exists tmp-cfasl)
(setf output-truename nil))) (setf output-truename nil)))
(values output-truename warnings-p failure-p)))) (values output-truename warnings-p failure-p))))
...@@ -5421,7 +5457,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -5421,7 +5457,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.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.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 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(asdf-version "3.0.1") (asdf-version "3.0.2")
(existing-version (asdf-version))) (existing-version (asdf-version)))
(setf *asdf-version* asdf-version) (setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version))) (when (and existing-version (not (equal asdf-version existing-version)))
...@@ -5439,7 +5475,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -5439,7 +5475,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
#:find-component ;; find-component #:find-component ;; find-component
#:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
#:component-depends-on #:operation-done-p #:component-depends-on #:component-depends-on #:operation-done-p #:component-depends-on
#:traverse ;; plan #:traverse ;; backward-interface
#:operate ;; operate #:operate ;; operate
#:parse-component-form ;; defsystem #:parse-component-form ;; defsystem
#:apply-output-translations ;; output-translations #:apply-output-translations ;; output-translations
...@@ -6618,17 +6654,26 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -6618,17 +6654,26 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
;;;; Convenience methods ;;;; Convenience methods
(with-upgradability () (with-upgradability ()
(defmacro define-convenience-action-methods (defmacro define-convenience-action-methods
(function (operation component &optional keyp) (function formals &key if-no-operation if-no-component operation-initargs)
&key if-no-operation if-no-component operation-initargs)
(let* ((rest (gensym "REST")) (let* ((rest (gensym "REST"))
(found (gensym "FOUND")) (found (gensym "FOUND"))
(keyp (equal (last formals) '(&key)))
(formals-no-key (if keyp (butlast formals) formals))
(len (length formals-no-key))
(operation 'operation)
(component 'component)
(opix (position operation formals))
(coix (position component formals))
(prefix (subseq formals 0 opix))
(suffix (subseq formals (1+ coix) len))
(more-args (when keyp `(&rest ,rest &key &allow-other-keys)))) (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
(assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
(flet ((next-method (o c) (flet ((next-method (o c)
(if keyp (if keyp
`(apply ',function ,o ,c ,rest) `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
`(,function ,o ,c)))) `(,function ,@prefix ,o ,c ,@suffix))))
`(progn `(progn
(defmethod ,function ((,operation symbol) ,component ,@more-args) (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args)
(if ,operation (if ,operation
,(next-method ,(next-method
(if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck. (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
...@@ -6636,14 +6681,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -6636,14 +6681,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
`(make-operation ,operation)) `(make-operation ,operation))
`(or (find-component () ,component) ,if-no-component)) `(or (find-component () ,component) ,if-no-component))
,if-no-operation)) ,if-no-operation))
(defmethod ,function ((,operation operation) ,component ,@more-args) (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
(if (typep ,component 'component) (if (typep ,component 'component)
(error "No defined method for ~S on ~/asdf-action:format-action/" (error "No defined method for ~S on ~/asdf-action:format-action/"
',function (cons ,operation ,component)) ',function (cons ,operation ,component))
(let ((,found (find-component () ,component))) (if-let (,found (find-component () ,component))
(if ,found ,(next-method operation found)
,(next-method operation found) ,if-no-component))))))))
,if-no-component)))))))))
;;;; self-description ;;;; self-description
...@@ -6922,15 +6966,14 @@ in some previous image, or T if it needs to be done.") ...@@ -6922,15 +6966,14 @@ in some previous image, or T if it needs to be done.")
(defclass basic-load-op (operation) ()) (defclass basic-load-op (operation) ())
(defclass basic-compile-op (operation) (defclass basic-compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
(flags :initarg :flags :accessor compile-op-flags (flags :initarg :flags :accessor compile-op-flags :initform nil))))
:initform nil))))
;;; Our default operations: loading into the current lisp image ;;; Our default operations: loading into the current lisp image
(with-upgradability () (with-upgradability ()
(defclass prepare-op (upward-operation sideway-operation) (defclass prepare-op (upward-operation sideway-operation)
((sideway-operation :initform 'load-op))) ((sideway-operation :initform 'load-op)))
(defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation) (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, ;; NB: even though compile-op depends 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. ;; so we need to directly depend on prepare-op for its side-effects in the current image.
((selfward-operation :initform '(prepare-op compile-op)))) ((selfward-operation :initform '(prepare-op compile-op))))
(defclass compile-op (basic-compile-op downward-operation selfward-operation) (defclass compile-op (basic-compile-op downward-operation selfward-operation)
...@@ -7161,7 +7204,7 @@ in some previous image, or T if it needs to be done.") ...@@ -7161,7 +7204,7 @@ in some previous image, or T if it needs to be done.")
#:visit-dependencies #:compute-action-stamp #:traverse-action #:visit-dependencies #:compute-action-stamp #:traverse-action
#:circular-dependency #:circular-dependency-actions #:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action #:call-while-visiting-action #:while-visiting-action
#:traverse #:plan-actions #:perform-plan #:plan-operates-on-p #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
#:planned-p #:index #:forced #:forced-not #:total-action-count #:planned-p #:index #:forced #:forced-not #:total-action-count
#:planned-action-count #:planned-output-action-count #:visited-actions #:planned-action-count #:planned-output-action-count #:visited-actions
#:visiting-action-set #:visiting-action-list #:plan-actions-r #:visiting-action-set #:visiting-action-list #:plan-actions-r
...@@ -7347,8 +7390,8 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -7347,8 +7390,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
(in-files (input-files o c)) (in-files (input-files o c))
;; Three kinds of actions: ;; Three kinds of actions:
(out-op (and out-files t)) ; those that create files on the filesystem (out-op (and out-files t)) ; those that create files on the filesystem
;(image-op (and in-files (null out-files))) ; those that load stuff into the image ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
;(null-op (and (null out-files) (null in-files))) ; dependency placeholders that do nothing ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
;; When was the thing last actually done? (Now, or ask.) ;; When was the thing last actually done? (Now, or ask.)
(op-time (or just-done (component-operation-time o c))) (op-time (or just-done (component-operation-time o c)))
;; Accumulated timestamp from dependencies (or T if forced or out-of-date) ;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
...@@ -7467,7 +7510,9 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -7467,7 +7510,9 @@ the action of OPERATION on COMPONENT in the PLAN"))
:stamp stamp :stamp stamp
:done-p (and done-p (not add-to-plan-p)) :done-p (and done-p (not add-to-plan-p))
:planned-p add-to-plan-p :planned-p add-to-plan-p
:index (if status (action-index status) (incf (plan-total-action-count plan))))) :index (if status
(action-index status)
(incf (plan-total-action-count plan)))))
(when add-to-plan-p (when add-to-plan-p
(incf (plan-planned-action-count plan)) (incf (plan-planned-action-count plan))
(unless aniip (unless aniip
...@@ -7483,6 +7528,8 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -7483,6 +7528,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
((actions-r :initform nil :accessor plan-actions-r))) ((actions-r :initform nil :accessor plan-actions-r)))
(defgeneric plan-actions (plan)) (defgeneric plan-actions (plan))
(defmethod plan-actions ((plan list))
plan)
(defmethod plan-actions ((plan sequential-plan)) (defmethod plan-actions ((plan sequential-plan))
(reverse (plan-actions-r plan))) (reverse (plan-actions-r plan)))
...@@ -7499,45 +7546,46 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -7499,45 +7546,46 @@ the action of OPERATION on COMPONENT in the PLAN"))
;;;; high-level interface: traverse, perform-plan, plan-operates-on-p ;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
(with-upgradability () (with-upgradability ()
(defgeneric* (traverse) (operation component &key &allow-other-keys) (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
(:documentation (:documentation
"Generate and return a plan for performing OPERATION on COMPONENT. "Generate and return a plan for performing OPERATION on COMPONENT."))
(define-convenience-action-methods make-plan (plan-class operation component &key))
The plan returned is a list of dotted-pairs. Each pair is the CONS
of ASDF operation object and a COMPONENT object. The pairs will be
processed in order by OPERATE."))
(define-convenience-action-methods traverse (operation component &key))
(defgeneric perform-plan (plan &key)) (defgeneric perform-plan (plan &key))
(defgeneric plan-operates-on-p (plan component)) (defgeneric plan-operates-on-p (plan component))
(defvar *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) (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
(let ((plan (apply 'make-instance (let ((plan (apply 'make-instance
(or plan-class *default-plan-class*) (or plan-class *default-plan-class*)
:system (component-system c) (remove-plist-key :plan-class keys)))) :system (component-system c) keys)))
(traverse-action plan o c t) (traverse-action plan o c t)
(plan-actions plan))) plan))
(defmethod perform-plan :around (plan &key) (defmethod perform-plan :around ((plan t) &key)
(declare (ignorable plan))
(let ((*package* *package*) (let ((*package* *package*)
(*readtable* *readtable*)) (*readtable* *readtable*))
(with-compilation-unit () ;; backward-compatibility. (with-compilation-unit () ;; backward-compatibility.
(call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
(defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys)
(apply 'perform-plan (plan-actions plan) keys))
(defmethod perform-plan ((steps list) &key force &allow-other-keys) (defmethod perform-plan ((steps list) &key force &allow-other-keys)
(loop* :for (o . c) :in steps (loop* :for (o . c) :in steps
:when (or force (not (nth-value 1 (compute-action-stamp nil o c)))) :when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
:do (perform-with-restarts o c))) :do (perform-with-restarts o c)))
(defmethod plan-operates-on-p ((plan plan-traversal) (component-path list))
(plan-operates-on-p (plan-actions plan) component-path))
(defmethod plan-operates-on-p ((plan list) (component-path list)) (defmethod plan-operates-on-p ((plan list) (component-path list))
(find component-path (mapcar 'cdr plan) (find component-path (mapcar 'cdr plan)
:test 'equal :key 'component-find-path))) :test 'equal :key 'component-find-path)))
;;;; Incidental traversals ;;;; Incidental traversals
(with-upgradability () (with-upgradability ()
(defclass filtered-sequential-plan (sequential-plan) (defclass filtered-sequential-plan (sequential-plan)
((action-filter :initform t :initarg :action-filter :reader plan-action-filter) ((action-filter :initform t :initarg :action-filter :reader plan-action-filter)
...@@ -7561,11 +7609,10 @@ processed in order by OPERATE.")) ...@@ -7561,11 +7609,10 @@ processed in order by OPERATE."))
(defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys) (defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys)
(let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys))) (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
(loop* :for (o . c) :in actions :do (loop* :for (o . c) :in actions :do (traverse-action plan o c t))
(traverse-action plan o c t)) plan))
(plan-actions plan)))
(define-convenience-action-methods traverse-sub-actions (o c &key)) (define-convenience-action-methods traverse-sub-actions (operation component &key))
(defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys) (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys)
(apply 'traverse-actions (direct-dependencies operation component) (apply 'traverse-actions (direct-dependencies operation component)
:system (component-system component) keys)) :system (component-system component) keys))
...@@ -7573,14 +7620,14 @@ processed in order by OPERATE.")) ...@@ -7573,14 +7620,14 @@ processed in order by OPERATE."))
(defmethod plan-actions ((plan filtered-sequential-plan)) (defmethod plan-actions ((plan filtered-sequential-plan))
(with-slots (keep-operation keep-component) plan (with-slots (keep-operation keep-component) plan
(loop* :for (o . c) :in (call-next-method) (loop* :for (o . c) :in (call-next-method)
:when (and (typep o keep-operation) :when (and (typep o keep-operation) (typep c keep-component))
(typep c keep-component))
:collect (cons o c)))) :collect (cons o c))))
(defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
(remove-duplicates (remove-duplicates
(mapcar 'cdr (apply 'traverse-sub-actions goal-operation system (mapcar 'cdr (plan-actions
(remove-plist-key :goal-operation keys))) (apply 'traverse-sub-actions goal-operation system
(remove-plist-key :goal-operation keys))))
:from-end t))) :from-end t)))
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
...@@ -7671,8 +7718,8 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: ...@@ -7671,8 +7718,8 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
(error 'missing-component-of-version :requires component :version version))) (error 'missing-component-of-version :requires component :version version)))
(defmethod operate ((operation operation) (component component) (defmethod operate ((operation operation) (component component)
&rest keys &key &allow-other-keys) &rest keys &key plan-class &allow-other-keys)
(let ((plan (apply 'traverse operation component keys))) (let ((plan (apply 'make-plan plan-class operation component keys)))
(apply 'perform-plan plan keys) (apply 'perform-plan plan keys)
(values operation plan))) (values operation plan)))
...@@ -7797,7 +7844,7 @@ for how to load or compile stuff") ...@@ -7797,7 +7844,7 @@ for how to load or compile stuff")
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;; Internal hacks for backward-compatibility ;;; Internal hacks for backward-compatibility
(asdf/package:define-package :asdf/backward-internals (asdf/package:define-package :asdf/backward-internals
(:recycle :asdf/backward-internals :asdf) (:recycle :asdf/backward-internals :asdf)
...@@ -8181,14 +8228,16 @@ for how to load or compile stuff") ...@@ -8181,14 +8228,16 @@ for how to load or compile stuff")
;; we'd have to have the monolithic-op not inherit from the main op, ;; 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. ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
(defclass lib-op (bundle-compile-op) (defclass no-ld-flags-op (operation) ())
(defclass lib-op (bundle-compile-op no-ld-flags-op)
((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) ((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." (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it."
#-(or ecl mkcl) "just compile the system")) #-(or ecl mkcl) "just compile the system"))
(defclass dll-op (bundle-op basic-compile-op) (defclass dll-op (bundle-compile-op selfward-operation no-ld-flags-op)
((bundle-type :initform :dll)) ((bundle-type :initform :dll))
(:documentation "Link together all the dynamic library used by this system into a single one.")) (:documentation "compile the system and produce dynamic (.so/.dll) library for it."))
(defclass binary-op (basic-compile-op selfward-operation) (defclass binary-op (basic-compile-op selfward-operation)
((selfward-operation :initform '(fasl-op lib-op))) ((selfward-operation :initform '(fasl-op lib-op)))
...@@ -8211,15 +8260,14 @@ for how to load or compile stuff") ...@@ -8211,15 +8260,14 @@ for how to load or compile stuff")
(defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) () (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) ()
(:documentation "Create a single fasl for the system and its dependencies.")) (:documentation "Create a single fasl for the system and its dependencies."))
(defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op) (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op no-ld-flags-op)
((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) ((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." (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies."
#-(or ecl mkcl) "Compile a 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) (defclass monolithic-dll-op (monolithic-bundle-compile-op sideway-operation selfward-operation no-ld-flags-op)
((bundle-type :initform :dll) ((bundle-type :initform :dll))
(selfward-operation :initform 'dll-op) (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
(sideway-operation :initform 'dll-op)))
(defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op) (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op)
#-(or mkcl ecl) (monolithic-bundle-op selfward-operation) #-(or mkcl ecl) (monolithic-bundle-op selfward-operation)
...@@ -8233,7 +8281,7 @@ for how to load or compile stuff") ...@@ -8233,7 +8281,7 @@ for how to load or compile stuff")
((or null string) bundle-type) ((or null string) bundle-type)
((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
#+ecl #+ecl
((member :binary :dll :lib :static-library :program :object :program) ((member :binary :dll :lib :shared-library :static-library :program :object :program)
(compile-file-type :type bundle-type)) (compile-file-type :type bundle-type))
((eql :binary) "image") ((eql :binary) "image")
((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll"))) ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
...@@ -8305,7 +8353,7 @@ for how to load or compile stuff") ...@@ -8305,7 +8353,7 @@ for how to load or compile stuff")
(remove-plist-keys '(:type :monolithic :name-suffix) (remove-plist-keys '(:type :monolithic :name-suffix)
(operation-original-initargs instance)))) (operation-original-initargs instance))))
(defmethod bundle-op-build-args :around ((o lib-op)) (defmethod bundle-op-build-args :around ((o no-ld-flags-op))
(declare (ignorable o)) (declare (ignorable o))
(let ((args (call-next-method))) (let ((args (call-next-method)))
(remf args :ld-flags) (remf args :ld-flags)
...@@ -9032,11 +9080,11 @@ effectively disabling the output translation facility." ...@@ -9032,11 +9080,11 @@ effectively disabling the output translation facility."
(:recycle :asdf/backward-interface :asdf) (:recycle :asdf/backward-interface :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade (:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
:asdf/lisp-action :asdf/operate :asdf/output-translations) :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
(:export (:export
#:*asdf-verbose* #:*asdf-verbose*
#:operation-error #:compile-error #:compile-failed #:compile-warned #:operation-error #:compile-error #:compile-failed #:compile-warned
#:error-component #:error-operation #:error-component #:error-operation #:traverse
#:component-load-dependencies #:component-load-dependencies
#:enable-asdf-binary-locations-compatibility #:enable-asdf-binary-locations-compatibility
#:operation-forced #:operation-forced
...@@ -9089,7 +9137,19 @@ We recommend you use ASDF:SYSTEM-SOURCE-FILE instead ...@@ -9089,7 +9137,19 @@ We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
for a mostly compatible replacement that we're supporting, for a mostly compatible replacement that we're supporting,
or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
if that's whay you mean." ;;) if that's whay you mean." ;;)
(system-source-file x))) (system-source-file x))
(defgeneric* (traverse) (operation component &key &allow-other-keys)
(:documentation
"Generate and return a plan for performing OPERATION on COMPONENT.
The plan returned is a list of dotted-pairs. Each pair is the CONS
of ASDF operation object and a COMPONENT object. The pairs will be
processed in order by OPERATE."))
(define-convenience-action-methods traverse (operation component &key))
(defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
(plan-actions (apply 'make-plan plan-class o c keys))))
;;;; ASDF-Binary-Locations compatibility ;;;; ASDF-Binary-Locations compatibility
...@@ -9160,7 +9220,15 @@ Deprecated function, for backward-compatibility only. ...@@ -9160,7 +9220,15 @@ Deprecated function, for backward-compatibility only.
Please use UIOP:RUN-PROGRAM instead." Please use UIOP:RUN-PROGRAM instead."
(let ((command (apply 'format nil control-string args))) (let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command) (asdf-message "; $ ~A~%" command)
(run-program command :force-shell t :ignore-error-status t :output *verbose-out*)))) (handler-case
(progn
(run-program command :force-shell t :ignore-error-status nil :output *verbose-out*)
0)
(subprocess-error (c)
(let ((code (subprocess-error-code c)))
(typecase code
(integer code)
(t 255))))))))
(with-upgradability () (with-upgradability ()
(defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
...@@ -9470,7 +9538,7 @@ system names to pathnames of .asd files") ...@@ -9470,7 +9538,7 @@ system names to pathnames of .asd files")
(defvar *source-registry-parameter* nil) (defvar *source-registry-parameter* nil)
(defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
;; Record the parameter used to configure the registry ;; Record the parameter used to configure the registry
(setf *source-registry-parameter* parameter) (setf *source-registry-parameter* parameter)
;; Clear the previous registry database: ;; Clear the previous registry database:
(setf *source-registry* (make-hash-table :test 'equal)) (setf *source-registry* (make-hash-table :test 'equal))
...@@ -9516,7 +9584,7 @@ system names to pathnames of .asd files") ...@@ -9516,7 +9584,7 @@ system names to pathnames of .asd files")
;; TODO: automatically generate interface with reexport? ;; TODO: automatically generate interface with reexport?
(:export (:export
#:defsystem #:find-system #:locate-system #:coerce-name #:defsystem #:find-system #:locate-system #:coerce-name
#:oos #:operate #:traverse #:perform-plan #:sequential-plan #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
#:system-definition-pathname #:with-system-definitions #:system-definition-pathname #:with-system-definitions
#:search-for-system-definition #:find-component #:component-find-path #:search-for-system-definition #:find-component #:component-find-path
#:compile-system #:load-system #:load-systems #:compile-system #:load-system #:load-systems
...@@ -9572,6 +9640,7 @@ system names to pathnames of .asd files") ...@@ -9572,6 +9640,7 @@ system names to pathnames of .asd files")
#:module-components ; backward-compatibility #:module-components ; backward-compatibility
#:operation-on-warnings #:operation-on-failure ; backward-compatibility #:operation-on-warnings #:operation-on-failure ; backward-compatibility
#:component-property ; backward-compatibility #:component-property ; backward-compatibility
#:traverse ; backward-compatibility
#:system-description #:system-description
#:system-long-description #:system-long-description
...@@ -9706,6 +9775,12 @@ system names to pathnames of .asd files") ...@@ -9706,6 +9775,12 @@ system names to pathnames of .asd files")
(and (first l) (register-pre-built-system (coerce-name name))) (and (first l) (register-pre-built-system (coerce-name name)))
(values-list l)))))))) (values-list l))))))))
#+cmu
(with-upgradability ()
(defun herald-asdf (stream)
(format stream " ASDF ~A" (asdf-version)))
(setf (getf ext:*herald-items* :asdf) `(herald-asdf)))
;;;; Done! ;;;; Done!
(with-upgradability () (with-upgradability ()
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment