Commit 052b3bbc authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.74: move a bunch of functionality from xcvb-driver to asdf.

This notably includes the former xcvb-driver:run-program/,
a much better replacement for run-shell-command.
This also includes image initialization, dumping, quitting.
parent b93678ae
......@@ -53,7 +53,7 @@ archive-copy: archive build/asdf.lisp
build/asdf.lisp: $(wildcard *.lisp)
mkdir -p build
cat header.lisp package.lisp compatibility.lisp utility.lisp upgrade.lisp pathname.lisp os.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp > $@
cat header.lisp package.lisp compatibility.lisp utility.lisp upgrade.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp > $@
git status
......@@ -3,12 +3,9 @@
(asdf/package:define-package :asdf/action
(:recycle :asdf/action :asdf)
(:use :common-lisp :asdf/compatibility :asdf/utility :asdf/pathname :asdf/os
(:use :common-lisp :asdf/compatibility :asdf/utility :asdf/pathname :asdf/os :asdf/lisp-build
:asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation)
#+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of)
#:explain #:output-files #:perform #:perform-with-restarts
#:operation-done-p #:compute-action-stamp #:component-depends-on #:mark-operation-done)
(:intern #:stamp #:done-p)
......@@ -25,6 +22,11 @@
#:perform #:perform-with-restarts #:retry #:accept))
(in-package :asdf/action)
(when-upgrade ()
'(explain output-files perform perform-with-restarts
operation-done-p compute-action-stamp component-depends-on mark-operation-done)))
(deftype action () '(cons operation component)) ;; a step to be performed while building the system
;;;; self-description
......@@ -111,6 +113,15 @@ You can put together sentences using this phrase."))
(declare (ignorable o c))
(defmethod output-files :around (operation component)
"Translate output files, unless asked not to"
operation component ;; hush genera, not convinced by declare ignorable(!)
(multiple-value-bind (files fixedp) (call-next-method)
(if fixedp
(mapcar *output-translation-hook* files)))
(defmethod output-files ((o operation) (c component))
(declare (ignorable o c))
......@@ -15,7 +15,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.73" ;; to be automatically updated by bin/bump-revision
:version "2.26.74" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components ((:module "build" :components ((:file "asdf")))))
......@@ -3,8 +3,7 @@
(asdf/package:define-package :asdf/backward-interface
(:recycle :asdf/backward-interface :asdf)
(:fmakunbound #:component-load-dependencies)
(:use :common-lisp :asdf/utility :asdf/pathname :asdf/os
(:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/run-program
:asdf/upgrade :asdf/component :asdf/system :asdf/operation :asdf/action
:asdf/lisp-build :asdf/operate :asdf/output-translations)
......@@ -19,7 +18,7 @@
(in-package :asdf/backward-interface)
(defvar *asdf-verbose* nil) ; worked around by cl-protobufs. It was a mistake to introduce it. mea culpa -fare
(when-upgrade () (undefine-function 'component-load-dependencies))
(defun* component-load-dependencies (component)
;; Old deprecated name for the same thing. Please update your software.
......@@ -109,28 +108,8 @@ call that function where you would otherwise have loaded and configured A-B-L.")
;;;; run-shell-command
;; run-shell-command functions for other lisp implementations will be
;; gratefully accepted, if they do the same thing.
;; If the docstring is ambiguous, send a bug report.
;; WARNING! The function below is mostly dysfunctional.
;; For instance, it will probably run fine on most implementations on Unix,
;; which will hopefully use the shell /bin/sh (which we force in some cases)
;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
;; But behavior on Windows may vary wildly between implementations,
;; either relying on your having installed a POSIX sh, or going through
;; the CMD.EXE interpreter, for a totally different meaning, depending on
;; what is easily expressible in said implementation.
;; We probably should move this functionality to its own system and deprecate
;; use of it from the asdf package. However, this would break unspecified
;; existing software, so until a clear alternative exists, we can't deprecate
;; it, and even after it's been deprecated, we will support it for a few
;; years so everyone has time to migrate away from it. -- fare 2009-12-01
;; As a suggested replacement which is portable to all ASDF-supported
;; implementations and operating systems except Genera, I recommend
;; xcvb-driver's xcvb-driver:run-program/ and its derivatives.
;; WARNING! The function below is dysfunctional and deprecated.
;; Please use asdf/run-program:run-program/ instead.
(defun* run-shell-command (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
......@@ -138,113 +117,4 @@ synchronously execute the result using a Bourne-compatible shell, with
output to *VERBOSE-OUT*. Returns the shell's exit code."
(let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
(ext:run-shell-command command :output *verbose-out*)
;; will this fail if command has embedded quotes - it seems to work
(multiple-value-bind (stdout stderr exit-code)
#-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
#+mswindows command ; BEWARE!
:input nil :whole nil
#+mswindows :show-window #+mswindows :hide)
(asdf-message "~{~&~a~%~}~%" stderr)
(asdf-message "~{~&~a~%~}~%" stdout)
;; CLISP returns NIL for exit status zero.
(if *verbose-out*
(let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
(outstream (ext:run-shell-command new-command :output :stream :wait t)))
(multiple-value-bind (retval out-lines)
(parse-clisp-shell-output outstream)
(ignore-errors (close outstream)))
(asdf-message "~{~&~a~%~}~%" out-lines)
;; there will be no output, just grab up the exit status
(or (ext:run-shell-command command :output nil :wait t) 0))
(nth-value 1
((os-unix-p) "/bin/sh")
((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
(t (error "Unsupported OS")))
(if (os-unix-p) (list "-c" command) '())
:input nil :output *verbose-out* :wait t)))
#+(or cmu scl)
(list "-c" command)
:input nil :output *verbose-out*))
(win32:system command)
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(ext:system command)
(lisp:system command)
(apply 'system:call-system-showing-output command
:show-cmd nil :prefix "" :output-stream *verbose-out*
(when (os-unix-p) '(:shell-type "/bin/sh")))
(ccl::with-cstrs ((%command command)) (_system %command))
;; This has next to no chance of working on basic Windows!
;; Your best hope is that Cygwin or MSYS is somewhere in the PATH.
(multiple-value-bind (io process exit-code)
(apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh"
(list "-c" command)
:input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it
#-windows '(:search nil))
(declare (ignore io process))
(apply 'sb-ext:run-program
#+win32 "sh" #-win32 "/bin/sh"
(list "-c" command)
:input nil :output *verbose-out*
#+win32 '(:search t) #-win32 nil))
(ext:run-shell-command command)
#-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl)
(error "RUN-SHELL-COMMAND not implemented for this Lisp")))
(defun* parse-clisp-shell-output (stream)
"Helper function for running shell commands under clisp. Parses a specially-
crafted output string to recover the exit status of the shell command and a
list of lines of output."
(loop :with status-prefix = "ASDF-EXIT-STATUS "
:with prefix-length = (length status-prefix)
:with exit-status = -1 :with lines = ()
:for line = (read-line stream nil nil)
:while line :do (push line lines) :finally
(let* ((last (car lines))
(status (and last (>= (length last) prefix-length)
(string-equal last status-prefix :end1 prefix-length)
(parse-integer last :start prefix-length :junk-allowed t))))
(when status
(setf exit-status status)
(pop lines) (when (equal "" (car lines)) (pop lines)))
(return (values exit-status (reverse lines))))))
(run-program/ command :force-shell t :output *verbose-out*)))
......@@ -2,10 +2,9 @@
;;;; ASDF-Bundle
(asdf/package:define-package :asdf/bundle
(:fmakunbound #:trivial-system-p)
(:recycle :asdf/bundle :asdf)
(:intern #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library)
(:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/lisp-build
(:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/lisp-build :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
......@@ -23,6 +22,8 @@
(in-package :asdf/bundle)
(when-upgrade () (undefine-function 'trivial-system-p))
(defclass bundle-op (operation)
((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
(name-suffix :initarg :name-suffix :initform nil)
......@@ -14,6 +14,7 @@
#+ecl (:export #:use-ecl-byte-compiler-p)
#+genera (:import-from :scl #:boolean)
#+genera (:export #:boolean #:ensure-directories-exist)
#+mcl (:export #:probe-posix #:current-user-homedir-pathname)
#:strcat #:compatfmt))
(in-package :asdf/compatibility)
......@@ -3,7 +3,6 @@
(asdf/package:define-package :asdf/component
(:recycle :asdf/component :asdf)
(:fmakunbound #:component-relative-pathname #:source-file-type)
(:use :common-lisp :asdf/utility :asdf/pathname :asdf/upgrade)
(:intern #:name #:version #:description #:long-description
#:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
......@@ -28,6 +27,8 @@
#:*default-encoding* #:*utf-8-external-format*))
(in-package :asdf/component)
(when-upgrade () (undefine-functions '(component-relative-pathname source-file-type)))
(defgeneric* component-name (component)
(:documentation "Name of the COMPONENT, unique relative to its parent"))
(defgeneric* component-system (component)
......@@ -48,7 +49,7 @@ another pathname in a degenerate way."))
(defgeneric* version-satisfies (component version))
(defgeneric* source-file-type (component system))
(with-upgrade (:when (find-class 'component nil))
(when-upgrade (:when (find-class 'component nil))
(defmethod reinitialize-instance :after ((c component) &rest initargs &key)
(declare (ignorable c initargs)) (values)))
......@@ -4,7 +4,7 @@
(asdf/package:define-package :asdf/concatenate-source
(:recycle :asdf/concatenate-source :asdf)
(:intern #:translate-output-p #:concatenated-source-file)
(:use :common-lisp :asdf/utility :asdf/os
(:use :common-lisp :asdf/utility :asdf/stream
:asdf/component :asdf/operation :asdf/system :asdf/find-system :asdf/defsystem
:asdf/action :asdf/lisp-action :asdf/bundle)
......@@ -3,8 +3,7 @@
(asdf/package:define-package :asdf/configuration
(:recycle :asdf/configuration :asdf)
(:fmakunbound #:resolve-location)
(:use :common-lisp :asdf/utility :asdf/pathname :asdf/os)
(:use :common-lisp :asdf/utility :asdf/pathname :asdf/stream :asdf/os :asdf/upgrade)
#:user-configuration-directories #:system-configuration-directories
......@@ -18,6 +17,8 @@
#:resolve-relative-location-component #:resolve-absolute-location-component))
(in-package :asdf/configuration)
(when-upgrade () (undefine-function 'resolve-location))
(define-condition invalid-configuration ()
((form :reader condition-form :initarg :form)
(location :reader condition-location :initarg :location)
......@@ -3,9 +3,8 @@
(asdf/package:define-package :asdf/find-component
(:recycle :asdf/find-component :asdf)
(:fmakunbound #:find-component)
(:use :common-lisp :asdf/utility :asdf/os
:asdf/component :asdf/system :asdf/find-system)
:asdf/upgrade :asdf/component :asdf/system :asdf/find-system)
#:resolve-dependency-name #:resolve-dependency-spec
......@@ -17,6 +16,8 @@
#:missing-required-by #:missing-version))
(in-package :asdf/find-component)
(when-upgrade () (undefine-function 'find-component))
;;;; Missing component conditions
(define-condition missing-component-of-version (missing-component)
......@@ -15,7 +15,7 @@
;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
#+(or abcl clisp clozure cmu ecl mkcl sbcl)
(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil))))
(when x
(eval `(pushnew 'module-provide-asdf
#+abcl sys::*module-provider-functions*
......@@ -31,7 +31,11 @@
(:file "compatibility" :depends-on ("package"))
(:file "utility" :depends-on ("compatibility"))
(:file "pathname" :depends-on ("utility"))
(:file "os" :depends-on ("pathname"))))
(:file "stream" :depends-on ("utility"))
(:file "os" :depends-on ("pathname" "streams"))
(:file "image" :depends-on ("os"))
(:file "run-program" :depends-on ("os"))
(:file "lisp-build" :depends-on ("pathname"))))
"code" :pathname "" :components
(:file "upgrade")
......@@ -39,7 +43,6 @@
(:file "system" :depends-on ("component"))
(:file "find-system" :depends-on ("system"))
(:file "find-component" :depends-on ("find-system"))
(:file "lisp-build")
(:file "operation")
(:file "action" :depends-on ("find-component" "operation"))
(:file "lisp-action" :depends-on ("action" "lisp-build"))
......@@ -52,6 +55,6 @@
(:file "defsystem" :depends-on ("backward-internals"))
(:file "bundle" :depends-on ("lisp-action"))
(:file "concatenate-source" :depends-on ("lisp-action"))
(:file "backward-interface" :depends-on ("lisp-action"))))
(:file "backward-interface" :depends-on ("lisp-action")))
(:file "interface")
(:file "footer" :depends-on ("interface"))))
(:file "footer" :depends-on ("interface")))))
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.73: Another System Definition Facility.
;;; This is ASDF 2.26.74: Another System Definition Facility.
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <>.
;;;; -------------------------------------------------------------------------
;;;; Starting, Stopping, Dumping a Lisp image
(asdf/package:define-package :asdf/image
(:recycle :asdf/image :xcvb-driver)
(:use :common-lisp :asdf/utility :asdf/pathname :asdf/stream :asdf/os)
#:*arguments* #:*dumped* #:raw-command-line-arguments #:*command-line-arguments*
#:*debugging* #:*post-image-restart* #:*entry-point*
#:quit #:die #:print-backtrace #:bork #:with-coded-exit #:shell-boolean
#:register-image-resume-hook #:register-image-dump-hook
#:call-image-resume-hook #:call-image-dump-hook
#:resume #:do-resume #:dump-image
(in-package :asdf/image)
(defvar *debugging* nil
"Shall we print extra debugging information?")
(defvar *arguments* nil
"Command-line arguments")
(defvar *dumped* nil
"Is this a dumped image? As a standalone executable?")
(defvar *image-resume-hook* nil
"Functions to call (in reverse order) when the image is resumed")
(defvar *image-dump-hook* nil
"Functions to call (in order) when before an image is dumped")
(defvar *post-image-restart* nil
"a string containing forms to read and evaluate when the image is restarted,
but before the entry point is called.")
(defvar *entry-point* nil
"a function with which to restart the dumped image when execution is resumed from it.")
;;; Exiting properly or im-
(defun quit (&optional (code 0) (finish-output t))
"Quits from the Lisp world, with the given exit status if provided.
This is designed to abstract away the implementation specific quit forms."
(with-safe-io-syntax ()
(when finish-output ;; essential, for ClozureCL, and for standard compliance.
(ignore-errors (finish-outputs))))
#+(or abcl xcl) (ext:quit :status code)
#+allegro (excl:exit code :quiet t)
#+clisp (ext:quit code)
#+clozure (ccl:quit code)
#+cormanlisp (win32:exitprocess code)
#+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit code)
#+gcl (lisp:quit code)
#+genera (error "You probably don't want to Halt the Machine.")
#+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) ?
#+mkcl (mk-ext:quit :exit-code code)
#+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
(quit (find-symbol* :quit :sb-ext nil)))
(exit `(,exit :code code :abort (not finish-output)))
(quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
#-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "xcvb driver: Quitting not implemented"))
(defun die (format &rest arguments)
"Die in error with some error message"
(with-safe-io-syntax ()
(format! *stderr* "~&")
(apply #'format! *stderr* format arguments)
(format! *stderr* "~&")))
(quit 99))
(defun print-backtrace (out)
"Print a backtrace (implementation-defined)"
(declare (ignorable out))
#+clozure (let ((*debug-io* out))
(ccl:print-call-history :count 100 :start-frame-number 1)
(finish-output out))
#.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream 'most-positive-fixnum)
(defun bork (condition)
"Depending on whether *DEBUGGING* is set, enter debugger or die"
(with-safe-io-syntax ()
(ignore-errors (format! *stderr* "~&BORK:~%~A~%" condition)))
(invoke-debugger condition))
(with-safe-io-syntax ()
(ignore-errors (print-backtrace *stderr*)))
(die "~A" condition))))
(defun call-with-coded-exit (thunk)
(handler-bind ((error 'bork))
(funcall thunk)
(quit 0)))
(defmacro with-coded-exit ((&optional) &body body)
"Run BODY, BORKing on error and otherwise exiting with a success status"
`(call-with-coded-exit #'(lambda () ,@body)))
(defun shell-boolean (x)
"Quit with a return code that is 0 iff argument X is true"
(quit (if x 0 1)))
;;; Using hooks
(defun* register-image-resume-hook (hook)
(pushnew hook *image-resume-hook*))
(defun* register-image-dump-hook (hook)
(pushnew hook *image-dump-hook*))
(defun* call-image-resume-hook ()
(call-functions (reverse *image-resume-hook*)))
(defun* call-image-dump-hook ()
(call-functions *image-dump-hook*))
;;; Build initialization
(defun initialize-asdf-utilities ()
"Setup the XCVB environment with respect to debugging, profiling, performance"
(setf *temporary-directory* (default-temporary-directory)
*stderr* #-clozure *error-output* #+clozure ccl::*stderr*)
;;; Proper command-line arguments
(defun raw-command-line-arguments ()
"Find what the actual command line for this process was."
#+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
#+allegro (sys:command-line-arguments) ; default: :application t
#+clisp (coerce (ext:argv) 'list)
#+clozure (ccl::command-line-arguments)
#+(or cmu scl) extensions:*command-line-strings*
#+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
#+gcl si:*command-args*
#+lispworks sys:*line-arguments-list*
#+sbcl sb-ext:*posix-argv*
#+xcl system:*argv*
#-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
(error "raw-command-line-arguments not implemented yet"))
(defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
"Extract user arguments from command-line invocation of current process.
Assume the calling conventions of an XCVB-generated script
if we are not called from a directly executable image dumped by XCVB."
#+abcl arguments
(let* (#-(or sbcl allegro)
(if (eq *dumped* :executable)
(member "--" arguments :test 'string-equal))))
(rest arguments)))
(defun do-resume (&key (post-image-restart *post-image-restart*) (entry-point *entry-point*))
(with-safe-io-syntax (:package :asdf)
(let ((*read-eval* t))
(when post-image-restart (load-string post-image-restart))))
(with-coded-exit ()
(when entry-point
(let ((ret (apply entry-point *arguments*)))
(if (typep ret 'integer)
(quit ret)
(quit 99))))))
(defun resume ()
(setf *arguments* (command-line-arguments))
;;; Dumping an image
(defun dump-image (filename &key output-name executable pre-image-dump post-image-restart entry-point package)
(declare (ignorable filename output-name executable pre-image-dump post-image-restart entry-point))
(setf *dumped* (if executable :executable t))
(setf *package* (find-package (or package :cl-user)))
(with-safe-io-syntax ()
(let ((*read-eval* t))
(when pre-image-dump (load-string pre-image-dump))
(setf *entry-point* (when entry-point (read-function entry-point)))
(when post-image-restart (setf *post-image-restart* post-image-restart))))
#-(or clisp clozure cmu lispworks sbcl)
(when executable
(error "Dumping an executable is not supported on this implementation! Aborting."))
(sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
(excl:dumplisp :name filename :suppress-allegro-cl-banner t))
(apply #'ext:saveinitmem filename
:quiet t
:start-package *package*
:keep-global-handlers nil
:executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
(when executable
:norc t
:script nil
:init-function #'resume
;; :parse-options nil ;--- requires a non-standard patch to clisp.
(ccl:save-application filename :prepend-kernel t
:toplevel-function (when executable #'resume))
#+(or cmu scl)
(ext:gc :full t)
(setf ext:*batch-mode* nil)
(setf ext::*gc-run-time* 0)
(apply 'ext:save-lisp filename #+cmu :executable #+cmu t
(when executable '(:init-function resume :process-command-line nil))))
(si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
(si::save-system filename))
(if executable
(lispworks:deliver 'resume filename 0 :interface nil)
(hcl:save-image filename :environment nil))
;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
(setf sb-ext::*gc-run-time* 0)
(apply 'sb-ext:save-lisp-and-die filename
:executable t ;--- always include the runtime that goes with the core
(when executable (list :toplevel #'resume :save-runtime-options t)))) ;--- only save runtime-options for standalone executables