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
(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
#: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
(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)
: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")))))
(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
#: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.
;;;; 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
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*)))
;;;; 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
#: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)
#+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)
(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
#:*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)
(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)))
(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
(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
#: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)
(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
#: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)
;;;; 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*
(: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")
(: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"))
(: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 <asdf-devel@common-lisp.net>.
--- /dev/null
+;;;; -------------------------------------------------------------------------
+;;;; 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))
+
#: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
#: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)))
(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?
(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))
(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))))))
(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")
+
(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
#: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 ()
;;; 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)))
(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.
(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)
(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)))))
+
(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
))
(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 "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
: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))
(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*)
(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"
exprs)
(apply 'values ,res)))))
+
;;;; General purpose package utilities
(eval-when (:load-toplevel :compile-toplevel :execute)
(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))
(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
: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))
(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))
(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)
: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)
(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
#: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
#: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.
(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)
#+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)
(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)
(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)
#: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)
--- /dev/null
+;;;; -------------------------------------------------------------------------
+;;;; 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))))
+
(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
#: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 "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
--- /dev/null
+;;;; ---------------------------------------------------------------------------
+;;;; 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))
+
(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
#: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))
(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
#: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))
#+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
(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))
(: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*))
;; "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)))
(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))
(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)))
: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)))
(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)
(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))
(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)
common-lisp.net / projects/asdf/asdf.git / commitdiff
