diff --git a/Makefile b/Makefile index d3d85cf698161b560bc3e22583605d512543d006..29bc7202f5c7cd8ac299c031d56540432f0551d6 100644 --- a/Makefile +++ b/Makefile @@ -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 > $@ push: git status diff --git a/action.lisp b/action.lisp index a972d20e7f00f2a5b409921e8476e857ba3ff96e..df7b54d5e13cf86b9076a6d1f32dfb192f752540 100644 --- a/action.lisp +++ b/action.lisp @@ -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) - (:fmakunbound - #:explain #:output-files #:perform #:perform-with-restarts - #:operation-done-p #:compute-action-stamp #:component-depends-on #:mark-operation-done) (:intern #:stamp #:done-p) (:export #:action @@ -25,6 +22,11 @@ #:perform #:perform-with-restarts #:retry #:accept)) (in-package :asdf/action) +(when-upgrade () + (undefine-functions + '(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)) t) +(defmethod output-files :around (operation component) + "Translate output files, unless asked not to" + operation component ;; hush genera, not convinced by declare ignorable(!) + (values + (multiple-value-bind (files fixedp) (call-next-method) + (if fixedp + files + (mapcar *output-translation-hook* files))) + t)) (defmethod output-files ((o operation) (c component)) (declare (ignorable o c)) nil) diff --git a/asdf.asd b/asdf.asd index 16e1ef961363ade6f787960316eec4b45b545902..7e80e8d59df6fb3b4855c05593ce54212ed5f90d 100644 --- a/asdf.asd +++ b/asdf.asd @@ -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"))))) diff --git a/backward-interface.lisp b/backward-interface.lisp index a4fcffc40d40af50413e457735e0f01c6b93e436..8caae230a4aa8395bc747c0fdb9aad71f4d5b822 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -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) (:export @@ -19,7 +18,7 @@ #:system-definition-pathname)) (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) - - #+abcl - (ext:run-shell-command command :output *verbose-out*) - - #+allegro - ;; will this fail if command has embedded quotes - it seems to work - (multiple-value-bind (stdout stderr exit-code) - (excl.osi:command-output - #-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) - exit-code) - - #+clisp - ;; CLISP returns NIL for exit status zero. - (if *verbose-out* - (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r" - command)) - (outstream (ext:run-shell-command new-command :output :stream :wait t))) - (multiple-value-bind (retval out-lines) - (unwind-protect - (parse-clisp-shell-output outstream) - (ignore-errors (close outstream))) - (asdf-message "~{~&~a~%~}~%" out-lines) - retval)) - ;; there will be no output, just grab up the exit status - (or (ext:run-shell-command command :output nil :wait t) 0)) - - #+clozure - (nth-value 1 - (ccl:external-process-status - (ccl:run-program - (cond - ((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) - (ext:process-exit-code - (ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out*)) - - #+cormanlisp - (win32:system command) - - #+ecl ;; courtesy of Juan Jose Garcia Ripoll - (ext:system command) - - #+gcl - (lisp:system command) - - #+lispworks - (apply 'system:call-system-showing-output command - :show-cmd nil :prefix "" :output-stream *verbose-out* - (when (os-unix-p) '(:shell-type "/bin/sh"))) - - #+mcl - (ccl::with-cstrs ((%command command)) (_system %command)) - - #+mkcl - ;; 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)) - exit-code) - - #+sbcl - (sb-ext:process-exit-code - (apply 'sb-ext:run-program - #+win32 "sh" #-win32 "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out* - #+win32 '(:search t) #-win32 nil)) - - #+xcl - (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"))) - -#+clisp -(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*))) diff --git a/bundle.lisp b/bundle.lisp index ce1f8f79c69f7c303345c33c8fe1d1528faed93a..4609c96f97fb19c463c1623f536081e36095389f 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -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) (:export @@ -23,6 +22,8 @@ #:system-fasl)) (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) diff --git a/compatibility.lisp b/compatibility.lisp index 730ff4079f0a1fa180b0b9c4ef64bea36747b7a9..fc906df8426e3612c702325be17d5da33605d982 100644 --- a/compatibility.lisp +++ b/compatibility.lisp @@ -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) (:export #:strcat #:compatfmt)) (in-package :asdf/compatibility) diff --git a/component.lisp b/component.lisp index cbb84b7b9181c3507da84d934a77f7cf22b68616..4bc3d67ae929bf3c3c0c6132d301fbe2cd60149c 100644 --- a/component.lisp +++ b/component.lisp @@ -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))) diff --git a/concatenate-source.lisp b/concatenate-source.lisp index da3dc8e65f7f3579cc087de90c6c3967adf112e8..2a1a0b60bfb6ccbcfd49fd94d65d2376c232c83e 100644 --- a/concatenate-source.lisp +++ b/concatenate-source.lisp @@ -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) (:export diff --git a/configuration.lisp b/configuration.lisp index fe0ac956ae83c8efa341c169b9ba897cec4f1c0c..d9988fcc6ed8833232c279afa1b6029fc1f7d2df 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -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) (:export #:get-folder-path #: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) diff --git a/find-component.lisp b/find-component.lisp index 420417ffa1f9d9a43a8660cc5ab2ab9c8e723cf3..3db1cffb4720b02ff225927b80805fed2966397b 100644 --- a/find-component.lisp +++ b/find-component.lisp @@ -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) (:export #:find-component #: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) diff --git a/footer.lisp b/footer.lisp index f956e3564dc11441bb7d73fb15455d9d96b2a326..6cf5ae6fd36f692c1369f7352c29ff3e6befdbb6 100644 --- a/footer.lisp +++ b/footer.lisp @@ -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* diff --git a/generate-asdf.asd b/generate-asdf.asd index 37465389da124912f3cb1da6570c4ba827a34586..0ea8ab55213eac197d561316025dbdb3719cf0c8 100644 --- a/generate-asdf.asd +++ b/generate-asdf.asd @@ -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")))) (:module "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"))))) diff --git a/header.lisp b/header.lisp index f0b92ed822f055dd2e69b55faa0a969649cb48d2..e472f143318f96b0d4119abcc8629858c7d19ed7 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;; -*- 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 . diff --git a/image.lisp b/image.lisp new file mode 100644 index 0000000000000000000000000000000000000000..72c805a2c66dfa749142ed4d8a158a53f8b46811 --- /dev/null +++ b/image.lisp @@ -0,0 +1,243 @@ +;;;; ------------------------------------------------------------------------- +;;;; 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) + (:export + #:*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 + #:initialize-asdf-utilities + #: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))) + (cond + (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 () + (ignore-errors + (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)) + #+sbcl + (sb-debug:backtrace + #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream 'most-positive-fixnum) + out)) + +(defun bork (condition) + "Depending on whether *DEBUGGING* is set, enter debugger or die" + (with-safe-io-syntax () + (ignore-errors (format! *stderr* "~&BORK:~%~A~%" condition))) + (cond + (*debugging* + (invoke-debugger condition)) + (t + (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*) + (values)) + + +;;; 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 + #-abcl + (let* (#-(or sbcl allegro) + (arguments + (if (eq *dumped* :executable) + arguments + (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)) + (do-resume)) + +;;; Dumping an image + +#-ecl +(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.")) + #+allegro + (progn + (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)) + #+clisp + (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 + (list + :norc t + :script nil + :init-function #'resume + ;; :parse-options nil ;--- requires a non-standard patch to clisp. + ))) + #+clozure + (ccl:save-application filename :prepend-kernel t + :toplevel-function (when executable #'resume)) + #+(or cmu scl) + (progn + (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)))) + #+gcl + (progn + (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) + (si::save-system filename)) + #+lispworks + (if executable + (lispworks:deliver 'resume filename 0 :interface nil) + (hcl:save-image filename :environment nil)) + #+sbcl + (progn + ;;(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 + #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) + (die "Can't dump ~S: asdf doesn't support image dumping with this Lisp implementation.~%" filename)) + diff --git a/interface.lisp b/interface.lisp index f9b2d88b3b77d40e2824f2dc421e879d462d1948..6d996be56032dc5f175076c7b170c7b2904e8dcc 100644 --- a/interface.lisp +++ b/interface.lisp @@ -11,7 +11,8 @@ #:loaded-systems ; makes for annoying SLIME completion #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function (:use :common-lisp - :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade + :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname + :asdf/stream :asdf/os :asdf/run-program :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-build :asdf/lisp-action :asdf/configuration :asdf/output-translations :asdf/source-registry @@ -136,6 +137,6 @@ #:system-source-registry-directory)) (in-package :asdf/interface) -(with-upgrade (:when (fboundp 'make-sub-operation)) +(when-upgrade (:when (fboundp 'make-sub-operation)) (defun* make-sub-operation (c o dep-c dep-o) (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) diff --git a/lisp-build.lisp b/lisp-build.lisp index 184a1ddede6d258505bf879f62d092e692a3c0fb..986ec99a5c0bddfc36051ab716aac839413d71e5 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -3,16 +3,21 @@ (asdf/package:define-package :asdf/lisp-build (:recycle :asdf/lisp-build :asdf) - (:use :common-lisp :asdf/compatibility :asdf/utility :asdf/pathname :asdf/os) - (:fmakunbound #:compile-file*) + (:use :common-lisp :asdf/compatibility :asdf/utility :asdf/pathname :asdf/stream :asdf/os) (:export #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* - #:*compile-file-function* #:compile-file* #:compile-file-pathname* + #:*compile-file-function* #:compile-file* #:compile-file-pathname* #:*output-translation-hook* + #:*optimization-settings* + #:*uninteresting-conditions* #:*uninteresting-load-conditions* + #:*fatal-conditions* #:*deferred-warnings* #+(or ecl mkcl) #:compile-file-keeping-object #:lispize-pathname #:fasl-type #:call-around-hook + #:*output-translation-hook* #:combine-fasls)) (in-package :asdf/lisp-build) +(eval-when (:compile-toplevel :load-toplevel :execute) (undefine-function 'compile-file*)) + (defvar *compile-file-warnings-behaviour* (or #+clisp :ignore :warn) "How should ASDF react if it encounters a warning when compiling a file? @@ -27,6 +32,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (defvar *compile-file-function* 'compile-file* "Function used to compile lisp files.") +(defvar *output-translation-hook* 'identity) + (defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) @@ -75,7 +82,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (defaults (make-pathname :type type :defaults (merge-pathnames* input-file)))) (merge-pathnames* output-file defaults)) - (funcall (find-symbol* :apply-output-translations :asdf/output-translations) + (funcall *output-translation-hook* (apply 'compile-file-pathname input-file (if output-file keys (remove-keyword :output-file keys)))))) @@ -137,3 +144,67 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))) +;;; Optimization settings + +(defvar *optimization-settings* nil) +(defvar *previous-optimization-settings* nil) +(defun get-optimization-settings () + "Get current compiler optimization settings, ready to PROCLAIM again" + (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 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 cmu scl) (funcall f c::*default-cookie*) + #+sbcl (cdr (assoc x sb-c::*policy*))) + :when y :collect (list x y)))) +(defun proclaim-optimization-settings () + "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*" + (proclaim `(optimize ,@*optimization-settings*)) + (let ((settings (get-optimization-settings))) + (unless (equal *previous-optimization-settings* settings) + (setf *previous-optimization-settings* settings)))) + + +;;; Condition control + +(defvar *uninteresting-conditions* + (append + #+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 + ;; the below four are controversial to include here; + ;; however there are issues with the asdf upgrade if they are not present + 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 + sb-kernel:undefined-alien-style-warning + sb-ext:implicit-generic-function-warning + sb-kernel:lexical-environment-too-complex + "Couldn't grovel for ~A (unknown to the C compiler).") + ;;#+clozure '(ccl:compiler-warning) + '("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. type symbols, predicates or strings") + +(defvar *uninteresting-load-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. type symbols, predicates or strings") + +(defvar *fatal-conditions* + '(serious-condition) + "Conditions to be considered fatal during compilation.") + +(defvar *deferred-warnings* () + "Warnings the handling of which is deferred until the end of the compilation unit") + diff --git a/operate.lisp b/operate.lisp index 6297d780efcb09f4486a8d000e191e7e20d36683..eaac663452dedc05ec1ecc0f6cb885b80e9992cc 100644 --- a/operate.lisp +++ b/operate.lisp @@ -3,7 +3,6 @@ (asdf/package:define-package :asdf/operate (:recycle :asdf/operate :asdf) - (:fmakunbound #:operate) (:use :common-lisp :asdf/utility :asdf/upgrade :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-build :asdf/lisp-action #:asdf/plan @@ -16,6 +15,8 @@ #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*)) (in-package :asdf/operate) +(when-upgrade () (undefine-function 'operate)) + (defgeneric* operate (operation-class system &key &allow-other-keys)) (defun* cleanup-upgraded-asdf () diff --git a/operation.lisp b/operation.lisp index 6aad910dcc8844d4fb9547d7b0da19edbc242105..4db71eff609e36b0a6e348751676352bf0de7e19 100644 --- a/operation.lisp +++ b/operation.lisp @@ -13,7 +13,7 @@ ;;; Operation Classes -(with-upgrade (:when (find-class 'operation nil)) +(when-upgrade (:when (find-class 'operation nil)) (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key) (declare (ignorable o slot-names initargs)) (values))) diff --git a/os.lisp b/os.lisp index eba027231de603b22d7068da34fa8b453f44abf2..8067e9acc789449b4f2fdf599f6011739cf054d4 100644 --- a/os.lisp +++ b/os.lisp @@ -3,69 +3,52 @@ (asdf/package:define-package :asdf/os (:recycle :asdf/os :asdf) - (:use :cl :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname) + (:use :cl :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname :asdf/stream) (:export #:featurep #:os-unix-p #:os-windows-p ;; features - #:read-file-forms ;; simple filesystem manipulation - #:copy-stream-to-stream #:concatenate-files ;; simple stream copy #:getenv ;; environment variables, and parsing them #:inter-directory-separator #:split-pathnames* #:getenv-pathname #:getenv-pathnames #:getenv-absolute-directory #:getenv-absolute-directories #:implementation-identifier ;; implementation identifier #:implementation-type #:operating-system #:architecture #:lisp-version-string - #:hostname #:user-homedir #:lisp-implementation-directory)) + #:hostname #:user-homedir #:lisp-implementation-directory + #:getcwd #:chdir #:call-with-current-directory #:with-current-directory + #:*temporary-directory* #:temporary-directory #:default-temporary-directory #:with-temporary-file)) (in-package :asdf/os) ;;; Features -(defun* featurep (x &optional (features *features*)) - (cond - ((atom x) - (and (member x features) t)) - ((eq :not (car x)) - (assert (null (cddr x))) - (not (featurep (cadr x) features))) - ((eq :or (car x)) - (some #'(lambda (x) (featurep x features)) (cdr x))) - ((eq :and (car x)) - (every #'(lambda (x) (featurep x features)) (cdr x))) - (t - (error "Malformed feature specification ~S" x)))) - -(defun* os-unix-p () - (featurep '(:or :unix :cygwin :darwin))) - -(defun* os-windows-p () - (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) - -;;; Simple filesystem manipulation -(defun* read-file-forms (file) - (with-open-file (in file) - (loop :with eof = (list nil) - :for form = (read in nil eof) - :until (eq form eof) - :collect form))) - -;; Simple stream copy -(defun* copy-stream-to-stream (input output &key (element-type 'character) (buffer-size 8192)) - "Copy the contents of the INPUT stream into the OUTPUT stream, -using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver - (with-open-stream (input input) - (loop - :for buffer = (make-array (list buffer-size) :element-type element-type) - :for end = (read-sequence buffer input) - :until (zerop end) - :do (write-sequence buffer output :end end) - (when (< end buffer-size) (return))))) - -(defun* concatenate-files (inputs output) - (with-open-file (o output :element-type '(unsigned-byte 8) - :direction :output :if-exists :rename-and-delete) - (dolist (input inputs) - (with-open-file (i input :element-type '(unsigned-byte 8) - :direction :input :if-does-not-exist :error) - (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun* featurep (x &optional (features *features*)) + (cond + ((atom x) + (and (member x features) t)) + ((eq :not (car x)) + (assert (null (cddr x))) + (not (featurep (cadr x) features))) + ((eq :or (car x)) + (some #'(lambda (x) (featurep x features)) (cdr x))) + ((eq :and (car x)) + (every #'(lambda (x) (featurep x features)) (cdr x))) + (t + (error "Malformed feature specification ~S" x)))) + (defun* os-unix-p () + (featurep '(:or :unix :cygwin :darwin))) + + (defun* os-windows-p () + (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) + + (defun detect-os () + (flet ((yes (yes) (pushnew yes *features*)) + (no (no) (setf *features* (remove no *features*)))) + (cond + ((os-unix-p) (yes :os-unix) (no :os-windows)) + ((os-windows-p) (yes :os-windows) (no :os-unix)) + (t (error "Congratulations for trying XCVB on an operating system~%~ +that is neither Unix, nor Windows.~%Now you port it."))))) + + (detect-os)) ;;;; Environment variables: getting them, and parsing them. @@ -92,11 +75,16 @@ using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver (let ((value (_getenv name))) (unless (ccl:%null-ptr-p value) (ccl:%get-cstring value)))) - #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x) + #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) #+sbcl (sb-ext:posix-getenv x) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv)) +(defun getenvp (x) + "Predicate that is true if the named variable is present in the libc environment, +then returning the non-empty string value of the variable" + (let ((g (getenv x))) (and (not (emptyp g)) g))) + (defun* inter-directory-separator () (if (os-unix-p) #\: #\;)) (defun* split-pathnames* (x want-absolute want-directory fmt &rest args) @@ -226,10 +214,113 @@ using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver (ignore-errors #+clozure #p"ccl:" #+(or ecl mkcl) #p"SYS:" - #+sbcl (aif (find-symbol* :sbcl-homedir-pathname :sb-int) + #+gcl system::*system-directory* + #+sbcl (aif (find-symbol* :sbcl-homedir-pathname :sb-int nil) (funcall it) (getenv-pathname "SBCL_HOME" :want-directory t))))) (if (and dir truename) (truename* dir) dir))) - \ No newline at end of file + + +;;; Current directory + +(defun getcwd () + "Get the current working directory as per POSIX getcwd(3)" + (or #+clisp (ext:default-directory) + #+clozure (ccl:current-directory) + #+cmu (unix:unix-current-directory) + #+cormanlisp (pl::get-current-directory) + #+ecl (ext:getcwd) + #+mkcl (mk-ext:getcwd) + #+sbcl (sb-unix:posix-getcwd/) + (error "getcwd not supported on your implementation"))) + +(defun chdir (x) + "Change current directory, as per POSIX chdir(2)" + #-(or clisp clozure) (when (pathnamep x) (setf x (native-namestring x))) + (or #+clisp (ext:cd x) + #+clozure (setf (ccl:current-directory) x) + #+cormanlisp (unless (zerop (win32::_chdir x)) + (error "Could not set current directory to ~A" x)) + #+sbcl (symbol-call :sb-posix :chdir x) + (error "chdir not supported on your implementation"))) + +(defun call-with-current-directory (dir thunk) + (if dir + (let* ((dir (truename (merge-pathnames (pathname-directory-pathname dir)))) + (*default-pathname-defaults* dir) + (cwd (getcwd))) + (chdir dir) + (unwind-protect + (funcall thunk) + (chdir cwd))) + (funcall thunk))) + +(defmacro with-current-directory ((dir) &body body) + "Call BODY while the POSIX current working directory is set to DIR" + `(call-with-current-directory ,dir #'(lambda () ,@body))) + + +;;; Using temporary files + +(defun* default-temporary-directory () + (flet ((f (s v d) (format nil "~A~A" (or (getenvp v) d (error "No temporary directory!")) s))) + (let ((dir (cond + ((os-unix-p) (f #\/ "TMPDIR" "/tmp")) + ((os-windows-p) (f #\\ "TEMP" nil)))) + #+mcl (dir (probe-posix dir))) + (or (parse-native-namestring dir) (default-directory))))) + +(defvar *temporary-directory* nil) + +(defun temporary-directory () + (or *temporary-directory* (default-temporary-directory))) + +(defun call-with-temporary-file + (thunk &key + prefix keep (direction :io) + (element-type *default-stream-element-type*) + (external-format :default)) + (check-type direction (member :output :io)) + (loop + :with prefix = (or prefix (format nil "~Atmp" (native-namestring (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 + ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL + ;; TODO: on Unix, use CFFI and mkstemp -- but the master is precisely meant to not depend on CFFI or on anything! Grrrr. + (with-open-file (stream pathname + :direction direction + :element-type element-type :external-format external-format + :if-exists nil :if-does-not-exist :create) + (when stream + (return + (if keep + (funcall thunk stream pathname) + (unwind-protect + (funcall thunk stream pathname) + (ignore-errors (delete-file pathname))))))))) + +(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) + (pathname (gensym "PATHNAME") pathnamep) + prefix keep direction element-type external-format) + &body body) + "Evaluate BODY where the symbols specified by keyword arguments +STREAM and PATHNAME are bound corresponding to a newly created temporary file +ready for I/O. Unless KEEP is specified, delete the file afterwards." + (check-type stream symbol) + (check-type pathname symbol) + `(flet ((think (,stream ,pathname) + ,@(unless pathnamep `((declare (ignore ,pathname)))) + ,@(unless streamp `((when ,stream (close ,stream)))) + ,@body)) + #-gcl (declare (dynamic-extent #'think)) + (call-with-temporary-file + #'think + ,@(when direction `(:direction ,direction)) + ,@(when prefix `(:prefix ,prefix)) + ,@(when keep `(:keep ,keep)) + ,@(when element-type `(:element-type ,element-type)) + ,@(when external-format `(:external-format external-format))))) + diff --git a/output-translations.lisp b/output-translations.lisp index e059809ca0cced7894d04e1077cd799e961e0dc8..12da80345a2efa70e5d7d6fa355ad768810e1e56 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -3,9 +3,7 @@ (asdf/package:define-package :asdf/output-translations (:recycle :asdf/output-translations :asdf) - (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/configuration :asdf/action) - (:fmakunbound #:apply-output-translations) - (:fmakunbound-setf #:output-translations) + (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/lisp-build :asdf/upgrade :asdf/configuration) (:export #:invalid-output-translation #:output-translations #:output-translations-initialized-p @@ -22,6 +20,8 @@ )) (in-package :asdf/output-translations) +(when-upgrade () (undefine-functions '(apply-output-translations (setf output-translations)))) + (define-condition invalid-output-translation (invalid-configuration warning) ((format :initform (compatfmt "~@")))) @@ -281,16 +281,6 @@ effectively disabling the output translation facility." :return (translate-pathname* p absolute-source destination root source) :finally (return p))))) -(defmethod output-files :around (operation component) - "Translate output files, unless asked not to" - operation component ;; hush genera, not convinced by declare ignorable(!) - (values - (multiple-value-bind (files fixedp) (call-next-method) - (if fixedp - files - (mapcar #'apply-output-translations files))) - t)) - #+abcl (defun* translate-jar-pathname (source wildcard) (declare (ignore wildcard)) @@ -318,4 +308,5 @@ effectively disabling the output translation facility." (merge-pathnames* relative-source target-root))) (normalize-device (apply-output-translations target))))) +(setf *output-translation-hook* 'apply-output-translations) (pushnew 'clear-output-translations *clear-configuration-hook*) diff --git a/package.lisp b/package.lisp index 71617f2f7f6550da2dc076876fb65f92a430d46f..e3c0f244f63ec18b0d65152e96acd489d33f0ad2 100644 --- a/package.lisp +++ b/package.lisp @@ -13,14 +13,14 @@ (defpackage :asdf/package (:use :common-lisp) (:export - #:find-package* #:find-symbol* #:intern* #:unintern* + #:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern* + #:symbol-shadowing-p #:rehome-symbol + #:delete-package* #:package-names #:packages-from-names #:symbol-name-package #:package-data - #:delete-package* #:ensure-package #:define-package)) + #:ensure-package #:define-package)) (in-package :asdf/package) -(declaim (optimize (speed 0) (safety 3) #-gcl (debug 3))) - (defmacro DBG (tag &rest exprs) "simple debug statement macro: outputs a tag plus a list of variable and their values, returns the last value" @@ -38,6 +38,7 @@ outputs a tag plus a list of variable and their values, returns the last value" exprs) (apply 'values ,res))))) + ;;;; General purpose package utilities (eval-when (:load-toplevel :compile-toplevel :execute) @@ -62,6 +63,11 @@ when the symbol is not found." (status (return (values symbol status))) (error (error "There is no symbol ~S in package ~S" name (package-name package)))))) (values nil nil)))) + (defun symbol-call (package name &rest args) + "Call a function associated with symbol of given name in given package, +with given ARGS. Useful when the call is read before the package is loaded, +or when loading the package is optional." + (apply (find-symbol* name package) args)) (defun intern* (name package-designator &optional (error t)) (intern (string name) (find-package* package-designator error))) (defun unintern* (name package-designator &optional (error t)) @@ -122,10 +128,25 @@ when the symbol is not found." (when (eq overwritten-symbol-status :external) (export symbol package)))) (values overwritten-symbol overwritten-symbol-status)))) - (defun symbol-name-package (symbol) - (cons (symbol-name symbol) (package-name (symbol-package symbol)))) + (defun ensure-package-unused (package) + (loop :for p :in (package-used-by-list package) :do + (unuse-package package p))) + (defun delete-package* (package) + (let ((p (find-package package))) + (when p + (ensure-package-unused p) + (delete-package package)))) (defun package-names (package) (cons (package-name package) (package-nicknames package))) + (defun packages-from-names (names) + (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))) + + +;;; Communicable representation of symbol and package information + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun symbol-name-package (symbol) + (cons (symbol-name symbol) (package-name (symbol-package symbol)))) (defun package-data (package-designator &key name-package (error t)) (let ((package (find-package* package-designator error))) (when package @@ -153,34 +174,16 @@ when the symbol is not found." :use ,(sort-packages (package-use-list package)) :used-by ,(sort-packages (package-used-by-list package)))))))))) + +;;; ensure-package, define-package + (eval-when (:load-toplevel :compile-toplevel :execute) - (defun soft-upgrade-p (upgrade) - (ecase upgrade ((:soft nil) t) (:hard nil))) - (defun ensure-package-unused (package) - (loop :for p :in (package-used-by-list package) :do - (unuse-package package p))) - (defun delete-package* (package) - (let ((p (find-package package))) - (when p - (ensure-package-unused p) - (delete-package package)))) - (defun ensure-package-fmakunbound (package symbols) - (loop :for name :in symbols - :for sym = (find-symbol* name package nil) - :when sym :do (fmakunbound sym))) - (defun ensure-package-fmakunbound-setf (package symbols) - (loop :for name :in symbols - :for sym = (find-symbol* name package nil) - :when sym :do (progn #-gcl (fmakunbound `(setf ,sym))))) - (defun packages-from-names (names) - (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t)) (defun ensure-package (name &key - upgrade nicknames documentation use shadow shadowing-import-from import-from export intern recycle mix reexport - unintern fmakunbound fmakunbound-setf) + unintern) (let* ((name (string name)) (nicknames (mapcar #'string nicknames)) (names (cons name nicknames)) @@ -292,7 +295,6 @@ when the symbol is not found." (t (return))) (when (eq ustat :external) (ensure-exported name sym u)))))))) - (assert (soft-upgrade-p upgrade)) #-gcl (setf (documentation package t) documentation) #+gcl documentation (loop :for p :in discarded :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) @@ -327,28 +329,24 @@ when the symbol is not found." (do-external-symbols (sym p) (ensure-mix sym p))) (loop :for (p . syms) :in import-from :do (dolist (sym syms) (ensure-import sym p))) - (loop :for p :in use :for sp = (string p) :for pp = (find-package sp) :do + (loop :for p :in use :for sp = (string p) :for pp = (find-package* sp) :do (do-external-symbols (sym pp) (ensure-inherited sym sp)) (use-package pp package)) (loop :for name :being :the :hash-keys :of exported :do (ensure-symbol name t)) - (dolist (name (append intern fmakunbound fmakunbound-setf)) + (dolist (name intern) (ensure-symbol (string name) t)) (do-symbols (sym package) (ensure-symbol (symbol-name sym))) (loop :for name :being :the :hash-keys :of exported :do (ensure-export name package)) - ;; do away with packages with conflicting (nick)names - ;; note from ASDF 2.26: ECL might not be liking an early fmakunbound (below #-ecl'ed) - (ensure-package-fmakunbound package fmakunbound) - (ensure-package-fmakunbound-setf package fmakunbound-setf) package)))) (eval-when (:load-toplevel :compile-toplevel :execute) (defun parse-define-package-form (package clauses) (loop :with use-p = nil :with recycle-p = nil - :with documentation = nil :with upgrade = nil + :with documentation = nil :for (kw . args) :in clauses :when (eq kw :nicknames) :append args :into nicknames :else :when (eq kw :documentation) @@ -366,23 +364,14 @@ when the symbol is not found." :when (eq kw :mix) :append args :into mix :else :when (eq kw :reexport) :append args :into reexport :else :when (eq kw :unintern) :append args :into unintern :else - :when (eq kw :fmakunbound) :append args :into fmakunbound :else - :when (eq kw :fmakunbound-setf) :append args :into fmakunbound-setf :else - :when (eq kw :upgrade) - :do (unless (and (consp args) (null (cdr args)) (member (car args) '(:soft :hard)) (null upgrade)) - (error "define-package: bad :upgrade directive")) - (setf upgrade (car args)) :else :do (error "unrecognized define-package keyword ~S" kw) - (progn fmakunbound fmakunbound-setf) :finally (return `(,package :nicknames ,nicknames :documentation ,documentation :use ,(if use-p use '(:common-lisp)) :shadow ,shadow :shadowing-import-from ,shadowing-import-from :import-from ,import-from :export ,export :intern ,intern :recycle ,(if recycle-p recycle (cons package nicknames)) - :mix ,mix :reexport ,reexport :unintern ,unintern - ,@(when upgrade `(:upgrade ,upgrade)) - #|:fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf|#))))) + :mix ,mix :reexport ,reexport :unintern ,unintern))))) (defmacro define-package (package &rest clauses) `(eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/pathname.lisp b/pathname.lisp index 601fda3be8a92763ec7168ca1cad6fd5607817d0..c09499dd896c0baa07ff1dab561d4c0dc12c5ccd 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -3,9 +3,8 @@ (asdf/package:define-package :asdf/pathname (:recycle :asdf/pathname :asdf) - (:fmakunbound #:translate-pathname*) #+gcl<2.7 (:shadowing-import-from :system :*load-pathname*) ;; GCL 2.6 sucks - (:use :common-lisp :asdf/utility) + (:use :common-lisp :asdf/compatibility :asdf/utility) (:export #:*resolve-symlinks* ;; Making and merging pathnames, portably @@ -42,6 +41,7 @@ #:delete-file-if-exists ;; Translate a pathname #:translate-pathname* + #:native-namestring #:parse-native-namestring ;; temporary #:add-pathname-suffix #:tmpize-pathname #:call-with-staging-pathname #:with-staging-pathname @@ -54,6 +54,8 @@ #:parse-file-location-info #:parse-windows-shortcut)) (in-package :asdf/pathname) +(eval-when (:compile-toplevel :load-toplevel :execute) (fmakunbound 'translate-pathname*)) + ;;; User-visible parameters (defvar *resolve-symlinks* t "Determine whether or not ASDF resolves symlinks when defining systems. @@ -270,7 +272,7 @@ with given pathname and if it exists return its truename." (pathname (unless (wild-pathname-p p) #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) '(probe-file p) - #+clisp (aif (find-symbol* '#:probe-pathname :ext) + #+clisp (aif (find-symbol* '#:probe-pathname :ext nil) `(ignore-errors (,it p))) #+gcl<2.7 '(or (probe-file p) @@ -297,7 +299,7 @@ with given pathname and if it exists return its truename." #+clozure '(: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) + #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) '(:resolve-symlinks nil)))))) (defun* filter-logical-directory-results (directory entries merger) @@ -674,6 +676,25 @@ Host, device and version components are taken from DEFAULTS." (t (translate-pathname path absolute-source destination)))) + +;;; Native vs Lisp syntax + +(defun native-namestring (x) + "From a CL pathname, a namestring suitable for use by the OS shell" + (let ((p (pathname x))) + #+clozure (let ((*default-pathname-defaults* #p"")) (ccl:native-translated-namestring p)) ; see ccl bug 978 + #+(or cmu scl) (ext:unix-namestring p nil) + #+sbcl (sb-ext:native-namestring p) + #-(or clozure cmu sbcl scl) (namestring p))) + +(defun parse-native-namestring (x) + "From a native namestring suitable for use by the OS shell, a CL pathname" + (check-type x string) + #+clozure (ccl:native-to-pathname x) + #+sbcl (sb-ext:parse-native-namestring x) + #-(or clozure sbcl) (parse-namestring x)) + + ;;; Temporary pathnames (defun* add-pathname-suffix (pathname suffix) (make-pathname :name (strcat (pathname-name pathname) suffix) diff --git a/plan.lisp b/plan.lisp index 13deebc8a8fa8fa695fd269f10542670a142431a..60b712789f4bfb7b344e1e85a000fcb69fc4511f 100644 --- a/plan.lisp +++ b/plan.lisp @@ -3,8 +3,7 @@ (asdf/package:define-package :asdf/plan (:recycle :asdf/plan :asdf) - (:fmakunbound #:traverse #:perform-plan #:traverse-action) - (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os + (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action) #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of) @@ -25,6 +24,8 @@ #:perform-plan #:plan-operates-on-p)) (in-package :asdf/plan) +(when-upgrade () (undefine-functions '(traverse perform-plan traverse-action))) + ;;;; Planned action status (defgeneric* plan-action-status (plan operation component) diff --git a/run-program.lisp b/run-program.lisp new file mode 100644 index 0000000000000000000000000000000000000000..d24ad9e402f60e72b17625a6ea30b011f066950f --- /dev/null +++ b/run-program.lisp @@ -0,0 +1,363 @@ +;;;; ------------------------------------------------------------------------- +;;;; run-program/ initially from xcvb-driver. + +(asdf/package:define-package :asdf/run-program + (:recycle :asdf/run-program :xcvb-driver) + (:use :common-lisp :asdf/utility :asdf/pathname :asdf/stream :asdf/os) + (:export + ;;; Escaping the command invocation madness + #:easy-sh-character-p #:escape-sh-token #:escape-sh-command + #:escape-windows-token #:escape-windows-command + #:escape-token #:escape-command + + ;;; run-program/foo + #:run-program/ + #:subprocess-error + #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process)) +(in-package :asdf/run-program) + +;;;; ----- Escaping strings for the shell ----- + +(defun requires-escaping-p (token &key good-chars bad-chars) + "Does this token require escaping, given the specification of +either good chars that don't need escaping or bad chars that do need escaping, +as either a recognizing function or a sequence of characters." + (some + (cond + ((and good-chars bad-chars) + (error "only one of good-chars and bad-chars can be provided")) + ((functionp good-chars) + (complement good-chars)) + ((functionp bad-chars) + bad-chars) + ((and good-chars (typep good-chars 'sequence)) + (lambda (c) (not (find c good-chars)))) + ((and bad-chars (typep bad-chars 'sequence)) + (lambda (c) (find c bad-chars))) + (t (error "requires-escaping-p: no good-char criterion"))) + token)) + +(defun output-string (string &optional stream) + (if stream + (with-output (stream) (princ string stream)) + string)) + +(defun escape-token (token &key stream quote good-chars bad-chars escaper) + "Call the ESCAPER function on TOKEN string if it needs escaping as per +REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN, +using STREAM as output (or returning result as a string if NIL)" + (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars) + (with-output (stream) + (apply escaper token stream (when quote `(:quote ,quote)))) + (output-string token stream))) + +(defun escape-windows-token-within-double-quotes (x &optional s) + "Escape a string token X within double-quotes +for use within a MS Windows command-line, outputing to S." + (labels ((issue (c) (princ c s)) + (issue-backslash (n) (loop :repeat n :do (issue #\\)))) + (loop + :initially (issue #\") :finally (issue #\") + :with l = (length x) :with i = 0 + :for i+1 = (1+ i) :while (< i l) :do + (case (char x i) + ((#\") (issue-backslash 1) (issue #\") (setf i i+1)) + ((#\\) + (let* ((j (and (< i+1 l) (position-if-not + (lambda (c) (eql c #\\)) x :start i+1))) + (n (- (or j l) i))) + (cond + ((null j) + (issue-backslash (* 2 n)) (setf i l)) + ((and (< j l) (eql (char x j) #\")) + (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j))) + (t + (issue-backslash n) (setf i j))))) + (otherwise + (issue (char x i)) (setf i i+1)))))) + +(defun escape-windows-token (token &optional s) + "Escape a string TOKEN within double-quotes if needed +for use within a MS Windows command-line, outputing to S." + (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil + :escaper 'escape-windows-token-within-double-quotes)) + +(defun escape-sh-token-within-double-quotes (x s &key (quote t)) + "Escape a string TOKEN within double-quotes +for use within a POSIX Bourne shell, outputing to S; +omit the outer double-quotes if key argument :QUOTE is NIL" + (when quote (princ #\" s)) + (loop :for c :across x :do + (when (find c "$`\\\"") (princ #\\ s)) + (princ c s)) + (when quote (princ #\" s))) + +(defun easy-sh-character-p (x) + (or (alphanumericp x) (find x "+-_.,%@:/"))) + +(defun escape-sh-token (token &optional s) + "Escape a string TOKEN within double-quotes if needed +for use within a POSIX Bourne shell, outputing to S." + (escape-token token :stream s :quote #\" :good-chars + #'easy-sh-character-p + :escaper 'escape-sh-token-within-double-quotes)) + +(defun escape-shell-token (token &optional s) + (cond + ((os-unix-p) (escape-sh-token token s)) + ((os-windows-p) (escape-windows-token token s)))) + +(defun escape-command (command &optional s + (escaper 'escape-shell-token)) + "Given a COMMAND as a list of tokens, return a string of the +spaced, escaped tokens, using ESCAPER to escape." + (etypecase command + (string (output-string command s)) + (list (with-output (s) + (loop :for first = t :then nil :for token :in command :do + (unless first (princ #\space s)) + (funcall escaper token s)))))) + +(defun escape-windows-command (command &optional s) + "Escape a list of command-line arguments into a string suitable for parsing +by CommandLineToArgv in MS Windows" + ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx + ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx + (escape-command command s 'escape-windows-token)) + +(defun escape-sh-command (command &optional s) + "Escape a list of command-line arguments into a string suitable for parsing +by /bin/sh in POSIX" + (escape-command command s 'escape-sh-token)) + +(defun escape-shell-command (command &optional stream) + "Escape a command for the current operating system's shell" + (escape-command command stream 'escape-shell-token)) + +;;;; ----- Running an external program ----- +;;; Simple variant of run-program with no input, and capturing output +;;; On some implementations, may output to a temporary file... + +(defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys)) + +(defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys) + (funcall function input-stream)) + +(defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys) + (apply (first list) (cons input-stream (rest list)))) + +(defmethod slurp-input-stream ((output-stream stream) input-stream + &key (element-type 'character) &allow-other-keys) + (copy-stream-to-stream + input-stream output-stream :element-type element-type)) + +(defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-string stream)) + +(defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-string stream)) + +(defmethod slurp-input-stream ((x (eql :lines)) stream &key &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-lines stream)) + +(defmethod slurp-input-stream ((x (eql :form)) stream &key &allow-other-keys) + (declare (ignorable x)) + (read stream)) + +(defmethod slurp-input-stream ((x (eql :forms)) stream &key &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-forms stream)) + +(define-condition subprocess-error (error) + ((code :initform nil :initarg :code :reader subprocess-error-code) + (command :initform nil :initarg :command :reader subprocess-error-command) + (process :initform nil :initarg :process :reader subprocess-error-process)) + (:report (lambda (condition stream) + (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]" + (subprocess-error-process condition) + (subprocess-error-command condition) + (subprocess-error-code condition))))) + +(defun run-program/ (command + &key output ignore-error-status force-shell + (element-type *default-stream-element-type*) + (external-format :default) + &allow-other-keys) + "Run program specified by COMMAND, +either a list of strings specifying a program and list of arguments, +or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows); +have its output processed by the OUTPUT processor function +as per SLURP-INPUT-STREAM, +or merely output to the inherited standard output if it's NIL. +Always call a shell (rather than directly execute the command) +if FORCE-SHELL is specified. +Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS +is specified. +Return the exit status code of the process that was called. +Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor." + (declare (ignorable ignore-error-status element-type external-format)) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) + (error "RUN-PROGRAM/ not implemented for this Lisp") + (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl) + (run-program (command &key pipe interactive) + "runs the specified command (a list of program and arguments). + If using a pipe, returns two values: process and stream + If not using a pipe, returns one values: the process result; + also, inherits the output stream." + ;; NB: these implementations have unix vs windows set at compile-time. + (assert (not (and pipe interactive))) + (let* ((wait (not pipe)) + #-(and clisp os-windows) + (command + (etypecase command + #+os-unix (string `("/bin/sh" "-c" ,command)) + #+os-unix (list command) + #+os-windows + (string + ;; NB: We do NOT add cmd /c here. You might want to. + #+allegro command + ;; On ClozureCL for Windows, we assume you are using + ;; r15398 or later in 1.9 or later, + ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858 + #+clozure (cons "cmd" (strcat "/c " command)) + ;; NB: On other Windows implementations, this is utterly bogus + ;; except in the most trivial cases where no quoting is needed. + ;; Use at your own risk. + #-(or allegro clozure) (list "cmd" "/c" command)) + #+os-windows + (list + #+(or allegro clozure) (escape-windows-command command) + #-(or allegro clozure) command))) + #+(and clozure os-windows) (command (list command)) + (process* + (multiple-value-list + #+allegro + (excl:run-shell-command + #+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)) + #+clisp + (flet ((run (f &rest args) + (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output + ,(if pipe :stream :terminal))))) + (etypecase command + #+os-windows (run 'ext:run-shell-command command) + (list (run 'ext:run-program (car command) + :arguments (cdr command))))) + #+lispworks + (system:run-shell-command + (cons "/usr/bin/env" command) ; lispworks wants a full path. + :input interactive :output (or (and pipe :stream) interactive) + :wait wait :save-exit-status (and pipe t)) + #+(or clozure cmu ecl sbcl scl) + (#+(or cmu ecl scl) ext:run-program + #+clozure ccl:run-program + #+sbcl sb-ext:run-program + (car command) (cdr command) + :input interactive :wait wait + :output (if pipe :stream t) + . #.(append + #+(or clozure cmu ecl sbcl scl) '(:error t) + #+sbcl '(:search t + #|:external-format external-format ; not in old SBCLs|#))))) + (process + #+(or allegro lispworks) (if pipe (third process*) (first process*)) + #+ecl (third process*) + #-(or allegro lispworks ecl) (first process*)) + (stream + (when pipe + #+(or allegro lispworks ecl) (first process*) + #+clisp (first process*) + #+clozure (ccl::external-process-output process) + #+(or cmu scl) (ext:process-output process) + #+sbcl (sb-ext:process-output process)))) + (values process stream))) + #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl) + (process-result (process) + ;; 1- wait + #+(and clozure os-unix) (ccl::external-process-wait process) + #+(or cmu scl) (ext:process-wait process) + #+(and ecl os-unix) (ext:external-process-wait process) + #+sbcl (sb-ext:process-wait process) + ;; 2- extract result + #+allegro (sys:reap-os-subprocess :pid process :wait t) + #+clisp process + #+clozure (nth-value 1 (ccl:external-process-status process)) + #+(or cmu scl) (ext:process-exit-code process) + #+ecl (nth-value 1 (ext:external-process-status process)) + #+lispworks (system:pid-exit-status process :wait t) + #+sbcl (sb-ext:process-exit-code process)) + (check-result (exit-code process) + #+clisp + (setf exit-code + (typecase exit-code (integer exit-code) (null 0) (t -1))) + (unless (or ignore-error-status + (equal exit-code 0)) + (error 'subprocess-error :command command :code exit-code :process process)) + exit-code) + (use-run-program () + #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) + (let* ((interactive (eq output :interactive)) + (pipe (and output (not interactive)))) + (multiple-value-bind (process stream) + (run-program command :pipe pipe :interactive interactive) + (if (and output (not interactive)) + (unwind-protect + (slurp-input-stream output stream) + (when stream (close stream)) + (check-result (process-result process) process)) + (unwind-protect + (check-result + #+(or allegro lispworks) ; when not capturing, returns the exit code! + process + #-(or allegro lispworks) (process-result process) + process)))))) + (system-command (command) + (etypecase command + (string (if (os-windows-p) (format nil "cmd /c ~A" command) command)) + (list (escape-shell-command + (if (os-unix-p) (cons "exec" command) command))))) + (redirected-system-command (command out) + (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A") + (system-command command) (native-namestring out))) + (system (command &key interactive) + #+(or abcl xcl) (ext:run-shell-command command) + #+allegro + (excl:run-shell-command command :input interactive :output interactive :wait t) + #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl) + (process-result (run-program command :pipe nil :interactive interactive)) + #+ecl (ext:system command) + #+cormanlisp (win32:system command) + #+gcl (lisp:system command) + #+(and lispworks os-windows) + (system:call-system-showing-output + command :show-cmd interactive :prefix "" :output-stream nil) + #+mcl (ccl::with-cstrs ((%command command)) (_system %command)) + #+mkcl (nth-value 2 + (mkcl:run-program #+windows command #+windows () + #-windows "/bin/sh" (list "-c" command) + :input nil :output nil))) + (call-system (command-string &key interactive) + (check-result (system command-string :interactive interactive) nil)) + (use-system () + (let ((interactive (eq output :interactive))) + (if (and output (not interactive)) + (with-temporary-file (:pathname tmp :direction :output) + (call-system (redirected-system-command command tmp)) + (with-open-file (stream tmp + :direction :input + :if-does-not-exist :error + :element-type element-type + :external-format external-format) + (slurp-input-stream output stream))) + (call-system (system-command command) :interactive interactive))))) + (if (and (not force-shell) + #+(or clisp ecl) ignore-error-status + #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil) + (use-run-program) + (use-system)))) + diff --git a/source-registry.lisp b/source-registry.lisp index 9892bc0d8bd712871cbbda49c9cab0cdf25840e2..c0e63727017c7e1c7ff124b1371b1cfe1c7fad52 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -4,7 +4,6 @@ (asdf/package:define-package :asdf/source-registry (:recycle :asdf/source-registry :asdf) - (:fmakunbound #:inherit-source-registry #:process-source-registry #:process-source-registry-directive) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade :asdf/find-system :asdf/configuration) (:export @@ -25,6 +24,10 @@ #:sysdef-source-registry-search)) (in-package :asdf/source-registry) +(when-upgrade () + (undefine-functions '(inherit-source-registry process-source-registry + process-source-registry-directive))) + (define-condition invalid-source-registry (invalid-configuration warning) ((format :initform (compatfmt "~@")))) diff --git a/stream.lisp b/stream.lisp new file mode 100644 index 0000000000000000000000000000000000000000..9fabbe670c00dd90ad669efb5ba6272d0140bc1e --- /dev/null +++ b/stream.lisp @@ -0,0 +1,190 @@ +;;;; --------------------------------------------------------------------------- +;;;; Utilities related to streams + +(asdf/package:define-package :asdf/stream + (:recycle :asdf/stream) + (:use :cl :asdf/package :asdf/compatibility :asdf/utility) + (:export + #:*default-stream-element-type* #:*stderr* + #:finish-outputs #:format! + #:with-output #:with-input #:call-with-input-file + #:with-safe-io-syntax #:read-function + #:read-file-forms #:read-first-file-form + #:copy-stream-to-stream #:concatenate-files + #:copy-stream-to-stream-line-by-line + #:slurp-stream-string #:slurp-stream-lines + #:slurp-stream-forms #:slurp-file-string + #:slurp-file-lines #:slurp-file-forms)) +(in-package :asdf/stream) + +(defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default) + "default element-type for open (depends on the current CL implementation)") + +(defvar *stderr* #-clozure *error-output* #+clozure ccl::*stderr* + "the original error output stream at startup") + + +;;; Ensure output buffers are flushed + +(defun finish-outputs () + "Finish output on the main output streams. +Useful for portably flushing I/O before user input or program exit." + ;; CCL notably buffers its stream output by default. + (dolist (s (list *stderr* *error-output* *standard-output* *trace-output*)) + (ignore-errors (finish-output s))) + (values)) + +(defun format! (stream format &rest args) + "Just like format, but call finish-outputs before and after the output." + (finish-outputs) + (apply 'format stream format args) + (finish-output stream)) + + +;;; Output to a stream or string, FORMAT-style + +(defgeneric call-with-output (x thunk) + (:documentation + ;; code from fare-utils base/streams where it's now named + ;; call-with-output-stream to avoid the package clash in a lot of my code. + "Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing: +If OBJ is a stream, use it as the stream. +If OBJ is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string. +If OBJ is T, use *STANDARD-OUTPUT* as the stream. +If OBJ is a string with a fill-pointer, use it as a string-output-stream. +Otherwise, signal an error.") + (:method ((x null) thunk) + (declare (ignorable x)) + (with-output-to-string (s) (funcall thunk s))) + (:method ((x (eql t)) thunk) + (declare (ignorable x)) + (funcall thunk *standard-output*) nil) + #-genera + (:method ((x stream) thunk) + (funcall thunk x) nil) + (:method ((x string) thunk) + (assert (fill-pointer x)) + (with-output-to-string (s x) (funcall thunk s))) + (:method (x thunk) + (declare (ignorable thunk)) + (cond + #+genera + ((typep x 'stream) (funcall thunk x) nil) + (t (error "not a valid stream designator ~S" x))))) + +(defmacro with-output ((x &optional (value x)) &body body) + "Bind X to an output stream, coercing VALUE (default: previous binding of X) +as per FORMAT, and evaluate BODY within the scope of this binding." + `(call-with-output ,value #'(lambda (,x) ,@body))) + + +;;; Input helpers + +(defun call-with-input-file (pathname thunk + &key (element-type *default-stream-element-type*) + (external-format :default)) + "Open FILE for input with given options, call THUNK with the resulting stream." + (with-open-file (s pathname :direction :input + :element-type element-type :external-format external-format + :if-does-not-exist :error) + (funcall thunk s))) + +(defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body) + (declare (ignore element-type external-format)) + `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)) + + +;;; Reading helpers + +(defmacro with-safe-io-syntax ((&key (package :cl)) &body body) + "Establish safe CL reader options around the evaluation of BODY" + `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body)))) + +(defun call-with-safe-io-syntax (thunk &key (package :cl)) + (with-standard-io-syntax () + (let ((*package* (find-package package)) + (*print-readably* nil) + (*read-eval* nil)) + (funcall thunk)))) + +(defun read-function (string) + "Read a form from a string in function context, return a function" + (eval `(function ,(read-from-string string)))) + +(defun* read-file-forms (file) + (with-open-file (in file) + (loop :with eof = (list nil) + :for form = (read in nil eof) + :until (eq form eof) + :collect form))) + +(defun read-first-file-form (pathname &key (package :cl) eof-error-p eof-value) + "Reads the first form from the top of a file using a safe standardized syntax" + (with-safe-io-syntax (:package package) + (with-input-file (in pathname) + (read in eof-error-p eof-value)))) + + +;;; Simple Whole-Stream processing + +(defun* copy-stream-to-stream (input output &key (element-type 'character) (buffer-size 8192)) + "Copy the contents of the INPUT stream into the OUTPUT stream, +using WRITE-SEQUENCE and a sensibly sized buffer." + (with-open-stream (input input) + (loop + :for buffer = (make-array (list buffer-size) :element-type element-type) + :for end = (read-sequence buffer input) + :until (zerop end) + :do (write-sequence buffer output :end end) + (when (< end buffer-size) (return))))) + +(defun* concatenate-files (inputs output) + (with-open-file (o output :element-type '(unsigned-byte 8) + :direction :output :if-exists :rename-and-delete) + (dolist (input inputs) + (with-open-file (i input :element-type '(unsigned-byte 8) + :direction :input :if-does-not-exist :error) + (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) + +(defun copy-stream-to-stream-line-by-line (input output &key prefix) + "Copy the contents of the INPUT stream into the OUTPUT stream, +reading contents line by line." + (with-open-stream (input input) + (loop :for (line eof) = (multiple-value-list (read-line input nil nil)) + :while line :do + (when prefix (princ prefix output)) + (princ line output) + (unless eof (terpri output)) + (finish-output output) + (when eof (return))))) + +(defun slurp-stream-string (input &key (element-type 'character)) + "Read the contents of the INPUT stream as a string" + (with-open-stream (input input) + (with-output-to-string (output) + (copy-stream-to-stream input output :element-type element-type)))) + +(defun slurp-stream-lines (input) + "Read the contents of the INPUT stream as a list of lines" + (with-open-stream (input input) + (loop :for l = (read-line input nil nil) :while l :collect l))) + +(defun slurp-stream-forms (input) + "Read the contents of the INPUT stream as a list of forms" + (with-open-stream (input input) + (loop :with eof = '#:eof + :for form = (read input nil eof) + :until (eq form eof) :collect form))) + +(defun slurp-file-string (file &rest keys) + "Open FILE with option KEYS, read its contents as a string" + (apply 'call-with-input-file file 'slurp-stream-string keys)) + +(defun slurp-file-lines (file &rest keys) + "Open FILE with option KEYS, read its contents as a list of lines" + (apply 'call-with-input-file file 'slurp-stream-lines keys)) + +(defun slurp-file-forms (file &rest keys) + "Open FILE with option KEYS, read its contents as a list of forms" + (apply 'call-with-input-file file 'slurp-stream-forms keys)) + diff --git a/system.lisp b/system.lisp index d104595cdb142eee75be1ac03f03d0fecc0d49ad..255adf4c9d4fa1b3e4c7bc531423699167b0ad76 100644 --- a/system.lisp +++ b/system.lisp @@ -3,7 +3,6 @@ (asdf/package:define-package :asdf/system (:recycle :asdf/system :asdf) - (:fmakunbound #:find-system #:system-source-file #:system-relative-pathname #:builtin-system-p) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade :asdf/component) (:intern #:children #:children-by-name #:default-component-class @@ -22,6 +21,10 @@ #:system-defsystem-depends-on)) (in-package :asdf/system) +(when-upgrade () + (undefine-functions '(find-system system-source-file + system-relative-pathname builtin-system-p))) + (defgeneric* find-system (system &optional error-p)) (declaim (ftype (function (t t) t) probe-asd)) @@ -56,7 +59,7 @@ (setf (gethash name hash) c)) hash)))) -(with-upgrade (:when (find-class 'module nil)) +(when-upgrade (:when (find-class 'module nil)) (defmethod reinitialize-instance :after ((m module) &rest initargs &key) (declare (ignorable m initargs)) (values)) (defmethod update-instance-for-redefined-class :after diff --git a/test/script-support.lisp b/test/script-support.lisp index 4cdfd732e0e0617869479a71299be23bf7e9b04e..dbccd990697c60fa4779e97d92cc161e1184658b 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -6,7 +6,6 @@ #:register-directory #:asdf-load #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl #:compile-load-asdf #:load-asdf-system #:quit-on-error #:test-asdf - #:native-namestring #:assert-equal #:exit-lisp #:leave-lisp #:quietly)) @@ -108,13 +107,6 @@ #+allegro (setf excl:*warn-on-nested-reader-conditionals* nil) -(defun native-namestring (x) - (let ((p (pathname x))) - #+clozure (ccl:native-translated-namestring p) - #+(or cmu scl) (ext:unix-namestring p nil) - #+sbcl (sb-ext:native-namestring p) - #-(or clozure cmu sbcl scl) (namestring p))) - ;;; code adapted from cl-launch http://www.cliki.net/cl-launch (defun exit-lisp (return) #+allegro diff --git a/test/test1.script b/test/test1.script index ea61d1a4468a14f2dccd539db3bd7399d51a265e..1f1ae519d181bcce49500ed08936afbdc64685e1 100644 --- a/test/test1.script +++ b/test/test1.script @@ -7,13 +7,13 @@ (touch-file "file2.lisp" :offset -3400) (quit-on-error + (DBG "loading test1") + (asdf:load-system 'test1) (let* ((file1 (asdf:compile-file-pathname* "file1")) (file2 (asdf:compile-file-pathname* "file2")) (date (file-write-date "test1.asd")) (then (file-write-date file2))) - (DBG "loading test1") - (asdf:load-system 'test1) (DBG "test that it compiled" date then) (assert (probe-file file1)) (assert (probe-file file2)) diff --git a/upgrade.lisp b/upgrade.lisp index 6bebf5ed1dcdd544a0bec3122872ca6ec0783445..d8c3b9e573b0986f7f6c010cbb02b1f293649b42 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -6,7 +6,7 @@ (:recycle :asdf/upgrade :asdf) (:use :common-lisp :asdf/package :asdf/compatibility :asdf/utility) (:export - #:upgrade-asdf #:asdf-upgrade-error #:with-upgrade + #:upgrade-asdf #:asdf-upgrade-error #:when-upgrade #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:asdf-version #:*upgraded-p* #:asdf-message #:*asdf-verbose* #:*verbose-out*)) @@ -31,7 +31,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.73") + (asdf-version "2.26.74") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -52,7 +52,7 @@ (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~ Otherwise, when you upgrade ASDF, you must do it before you operate on any system.~%")) -(defmacro with-upgrade ((&key (upgraded-p '*upgraded-p*) when) &body body) +(defmacro when-upgrade ((&key (upgraded-p '*upgraded-p*) when) &body body) `(eval-when (:compile-toplevel :load-toplevel :execute) (when (and ,upgraded-p ,@(when when `(,when))) (handler-bind ((style-warning #'muffle-warning)) diff --git a/utility.lisp b/utility.lisp index 84e5a4fe40b4a82d62312eaf823cabd3e56ac046..9f15dd743ae74328d0ed16abf68ceaf6cbc18918 100644 --- a/utility.lisp +++ b/utility.lisp @@ -4,31 +4,47 @@ (asdf/package:define-package :asdf/utility (:recycle :asdf/utility :asdf) (:use :common-lisp :asdf/package :asdf/compatibility) + (:import-from :asdf/package #:DBG) (:export - #:find-symbol* ;; reexport from asdf/package + #:find-symbol* ;;#:DBG ;; reexport from asdf/package #:strcat #:compatfmt ;; reexport from asdf/compatibility + #:undefine-function #:undefine-functions #:defun* #:defgeneric* ;; defining macros #:aif #:it ;; basic flow control #:while-collecting #:appendf #:length=n-p ;; lists #:remove-keys #:remove-keyword ;; keyword argument lists - #:first-char #:last-char #:split-string #:string-suffix-p ;; strings + #:emptyp ;; sequences + #:first-char #:last-char #:split-string ;; strings + #:string-prefix-p #:string-enclosed-p #:string-suffix-p #:find-class* ;; CLOS #:stamp< #:stamp<= #:earlier-stamp #:stamps-earliest #:earliest-stamp ;; stamps #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f #:list-to-hash-set ;; hash-table - #:ensure-function ;; functions + #:ensure-function #:call-function #:call-functions ;; functions + #:eval-string #:load-string #:load-stream #:parse-version #:version-compatible-p)) ;; version (in-package :asdf/utility) ;;; *-defining macros +;;; Functions + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun undefine-function (function-spec) + (cond + ((symbolp function-spec) (fmakunbound function-spec)) + ((and (consp function-spec) (eq (car function-spec) 'setf) + (consp (cdr function-spec)) (null (cddr function-spec))) + #-(or gcl<2.7) (fmakunbound function-spec)) + (t (error "bad function spec ~S" function-spec)))) + (defun undefine-functions (function-spec-list) + (map () 'undefine-function function-spec-list))) + (macrolet ((defdef (def* def) `(defmacro ,def* (name formals &rest rest) `(progn - ;; #+(or ecl gcl) - ,(when (and #+gcl<2.7 (symbolp name)) - `(fmakunbound ',name)) + (undefine-function ',name) #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl `(declaim (notinline ,name))) @@ -84,7 +100,13 @@ Returns two values: \(A B C\) and \(1 2 3\)." :unless (eq k key) :append (list k v))) +;;; Sequences +(defun emptyp (x) + "Predicate that is true for an empty sequence" + (or (null x) (and (vectorp x) (zerop (length x))))) + ;;; Strings + (defun* first-char (s) (and (stringp s) (plusp (length s)) (char s 0))) @@ -111,12 +133,27 @@ starting the separation from the end, e.g. when called with arguments (incf words) (setf end start)))))) -(defun* string-suffix-p (s suffix) - (check-type s string) - (check-type suffix string) - (let ((start (- (length s) (length suffix)))) - (and (<= 0 start) - (string-equal s suffix :start1 start)))) +(defun string-prefix-p (prefix string) + "Does STRING begin with PREFIX?" + (let* ((x (string prefix)) + (y (string string)) + (lx (length x)) + (ly (length y))) + (and (<= lx ly) (string= x y :end2 lx)))) + +(defun string-suffix-p (string suffix) + "Does STRING end with SUFFIX?" + (let* ((x (string string)) + (y (string suffix)) + (lx (length x)) + (ly (length y))) + (and (<= ly lx) (string= x y :start1 (- lx ly))))) + +(defun string-enclosed-p (prefix string suffix) + "Does STRING begin with PREFIX and end with SUFFIX?" + (and (string-prefix-p prefix string) + (string-suffix-p string suffix))) + ;;; CLOS (defun* find-class* (x &optional (errorp t) environment) @@ -149,7 +186,7 @@ starting the separation from the end, e.g. when called with arguments (defun* list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) (dolist (x list h) (setf (gethash x h) t))) -;;; Functions +;;; Code execution (defun* ensure-function (fun &key (package :asdf)) (etypecase fun ((or boolean keyword character number pathname) (constantly fun)) @@ -159,6 +196,35 @@ starting the separation from the end, e.g. when called with arguments (let ((*package* (find-package package))) (read-from-string fun)))))))) +(defun* call-function (function-spec) + (funcall (ensure-function function-spec))) + +(defun* call-functions (function-specs) + (map () 'call-hook-function function-specs)) + +(defun eval-string (string) + "Evaluate a form read from a string" + (eval (read-from-string string))) + +(defun do-load (x &key external-format print) + (apply 'load x :print print (when external-format `(:external-format ,external-format)))) + +(defun load-stream (&optional (stream *standard-input*)) + "Portably read and evaluate forms from a STREAM." + ;; GCL 2.6 can't load from a string-input-stream + ;; ClozureCL 1.6 can only load from file input + ;; Allegro 5, I don't remember but it must have been broken when I tested. + #+(or gcl-pre2.7 clozure allegro) + (with-controlled-loader-conditions () + (do ((eof '#:eof) (x t (read stream nil eof))) ((eq x eof)) (eval x))) + #-(or gcl-pre2.7 clozure allegro) + (do-load stream)) + +(defun load-string (string) + "Portably read and evaluate forms from a STRING." + (with-input-from-string (s string) (load-stream s))) + + ;;; Version handling (defun* parse-version (string &optional on-error)