# HG changeset patch # User ellis # Date 1687141528 14400 # Node ID 77da08c7f445e5cc1aeadc99a50759c941101c28 # Parent aa37feddcfb2df266d41751877c076c84c7188d6 bugfixes, tweaks to run.lisp diff -r aa37feddcfb2 -r 77da08c7f445 default-config.sexp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/default-config.sexp Sun Jun 18 22:25:28 2023 -0400 @@ -0,0 +1,1 @@ +;; demo user configuration file \ No newline at end of file diff -r aa37feddcfb2 -r 77da08c7f445 demo.asd --- a/demo.asd Thu Jun 15 22:01:40 2023 -0400 +++ b/demo.asd Sun Jun 18 22:25:28 2023 -0400 @@ -1,9 +1,4 @@ ;;; demo.asd -(in-package #:asdf-user) - -(defsystem "demo/sys" - :components ((:file "src/package"))) - (defsystem "demo" :version "0.1.0" :author "ellis " @@ -13,9 +8,12 @@ :bug-tracker "https://lab.rwest.io/otom8/demo/issues" :source-control (:hg "https://lab.rwest.io/otom8/demo") :license "WTFPL" - :depends-on ("demo/sys" :cl-dbi :sxql :log4cl :verbose :bordeaux-threads :clingon :clog) + :depends-on (:log4cl :bordeaux-threads :clingon :clog) :in-order-to ((test-op (test-op "src/test"))) - :build-pathname "demo") + :build-pathname "demo" + :components ((:module "src" + :components ((:file "package") + (:file "cfg"))))) (defmethod perform :after ((op load-op) (c (eql (find-system :demo)))) (pushnew :demo *features*)) diff -r aa37feddcfb2 -r 77da08c7f445 makefile --- a/makefile Thu Jun 15 22:01:40 2023 -0400 +++ b/makefile Sun Jun 18 22:25:28 2023 -0400 @@ -1,3 +1,4 @@ +# otom8/demo makefile MODE?=release LISP?=sbcl CFG?=default.cfg @@ -10,7 +11,7 @@ RS:Cargo.toml rustfmt.toml src/crates/* CL:*/*.asd */*.lisp deps:; -clean:;rm -rf *.fasl;cargo clean +clean:;rm -rf */*.fasl;cargo clean fmt:$(RS);cargo fmt build:$(RS) $(CL);cargo build --$(MODE);$(L_D) --eval '(asdf:make "demo")' \ diff -r aa37feddcfb2 -r 77da08c7f445 readme.org --- a/readme.org Thu Jun 15 22:01:40 2023 -0400 +++ b/readme.org Sun Jun 18 22:25:28 2023 -0400 @@ -24,20 +24,12 @@ #+begin_src bash ./tools/deps.sh #+end_src - - Rust =curl --proto '=https' --tlsv1.2 -sSf https://sh.rustup.rs | sh= - - Common Lisp - - on Linux :: - - Ubuntu/Debian :: =sudo apt-get install sbcl= - - Arch BTW :: =sudo pacman -S sbcl= - - on MacOS :: =brew install sbcl= - - on Windows :: download from - and figure it out. - *make executables* \\ Simply run =make build=. Read the ~makefile~ and change the options as needed. -- M :: Mode (debug, release) -- L :: Lisp (sbcl, cmucl, ccl) -- C :: Config (default.cfg) +- MODE :: Mode (debug, release) +- LISP :: Lisp (sbcl, cmucl, ccl) +- CFG :: Config (default.cfg) ** Run #+begin_src shell ./demo -i diff -r aa37feddcfb2 -r 77da08c7f445 run.lisp --- a/run.lisp Thu Jun 15 22:01:40 2023 -0400 +++ b/run.lisp Sun Jun 18 22:25:28 2023 -0400 @@ -1,2 +1,2 @@ -(load "tools/prepare-image") -(load "tools/init") +(defparameter *cwd* (asdf:system-source-directory :demo)) +(load (merge-pathnames "tools/build-image.lisp" *cwd*)) diff -r aa37feddcfb2 -r 77da08c7f445 src/package.lisp --- a/src/package.lisp Thu Jun 15 22:01:40 2023 -0400 +++ b/src/package.lisp Sun Jun 18 22:25:28 2023 -0400 @@ -1,9 +1,7 @@ ;; demo packages.lisp -(defpackage :demo-sys - (:nicknames :ds)) +(defpackage :demo-sys) (defpackage :demo-utils (:use :demo-sys) - (:nicknames :dutils) (:export #:source-dir #:random-id @@ -19,13 +17,11 @@ (:nicknames :ddb)) (defpackage :demo-ui (:use :demo-sys) - (:nicknames :dui) (:export #:on-new-window #:start-ui)) (defpackage :demo-cli (:use :demo-sys) - (:nicknames :dcli) (:export #:run-cli #:demo-path @@ -35,9 +31,7 @@ #:cli-cmd)) (defpackage :demo (:use #:cl #:demo-sys #:demo-utils #:demo-db #:demo-ui #:demo-cli) - (:nicknames :d) (:local-nicknames - (#:v #:org.shirakumo.verbose) (#:bt #:bordeaux-threads) (#:cli #:clingon))) (defpackage :demo-user diff -r aa37feddcfb2 -r 77da08c7f445 system-index.txt --- a/system-index.txt Thu Jun 15 22:01:40 2023 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ -demo.asd diff -r aa37feddcfb2 -r 77da08c7f445 tools/asdf.lisp --- a/tools/asdf.lisp Thu Jun 15 22:01:40 2023 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13987 +0,0 @@ -;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; Package: CL-USER ; buffer-read-only: t; -*- -;;; This is ASDF 3.3.6: Another System Definition Facility. -;;; -;;; Feedback, bug reports, and patches are all welcome: -;;; please mail to . -;;; Note first that the canonical source for ASDF is presently -;;; . -;;; -;;; If you obtained this copy from anywhere else, and you experience -;;; trouble using it, or find bugs, you may want to check at the -;;; location above for a more recent version (and for documentation -;;; and test files, if your copy came without them) before reporting -;;; bugs. There are usually two "supported" revisions - the git master -;;; branch is the latest development version, whereas the git release -;;; branch may be slightly older but is considered `stable' - -;;; -- LICENSE START -;;; (This is the MIT / X Consortium license as taken from -;;; http://www.opensource.org/licenses/mit-license.html on or about -;;; Monday; July 13, 2009) -;;; -;;; Copyright (c) 2001-2019 Daniel Barlow and contributors -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining -;;; a copy of this software and associated documentation files (the -;;; "Software"), to deal in the Software without restriction, including -;;; without limitation the rights to use, copy, modify, merge, publish, -;;; distribute, sublicense, and/or sell copies of the Software, and to -;;; permit persons to whom the Software is furnished to do so, subject to -;;; the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be -;;; included in all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;;; -;;; -- LICENSE END - -;;; The problem with writing a defsystem replacement is bootstrapping: -;;; we can't use defsystem to compile it. Hence, all in one file. - -#+genera -(eval-when (:compile-toplevel :load-toplevel :execute) - (multiple-value-bind (system-major system-minor) - (sct:get-system-version) - (multiple-value-bind (is-major is-minor) - (sct:get-system-version "Intel-Support") - (unless (or (> system-major 452) - (and is-major - (or (> is-major 3) - (and (= is-major 3) (> is-minor 86))))) - (error "ASDF requires either System 453 or later or Intel Support 3.87 or later"))))) -;;;; --------------------------------------------------------------------------- -;;;; ASDF package upgrade, including implementation-dependent magic. -;; -;; See https://bugs.launchpad.net/asdf/+bug/485687 -;; - -;; CAUTION: The definition of the UIOP/PACKAGE package MUST NOT CHANGE, -;; NOT NOW, NOT EVER, NOT UNDER ANY CIRCUMSTANCE. NEVER. -;; ... and the same goes for UIOP/PACKAGE-LOCAL-NICKNAMES. -;; -;; The entire point of UIOP/PACKAGE is to address the fact that the CL standard -;; *leaves it unspecified what happens when a package is redefined incompatibly*. -;; For instance, SBCL 1.4.2 will signal a full WARNING when this happens, -;; throwing a wrench in upgrading code with ASDF itself, while continuing to -;; export old symbols it now shouldn't as it also exports new ones, -;; causing problems with code that relies on the new/current exports. -;; CLISP and CCL also exports both sets of symbols, though without any WARNING. -;; ABCL 1.6.1 will plainly ignore the new definition. -;; Other implementations may do whatever they want and change their behavior at any time. -;; ***Using DEFPACKAGE twice with different definitions is nasal-demon territory.*** -;; -;; Thus we define UIOP/PACKAGE:DEFINE-PACKAGE with which packages can be defined -;; in an upgrade-friendly way: the new definition is authoritative, and -;; the package will define and export exactly those symbols in the new definition, -;; no more and no fewer, whereas it is well-defined what happens to previous symbols. -;; However, for obvious bootstrap reasons, we cannot use DEFINE-PACKAGE -;; to define UIOP/PACKAGE itself, only DEFPACKAGE. -;; Therefore, unlike the other packages in ASDF, UIOP/PACKAGE is immutable, -;; now and forever. It is frozen for the aeons to come, like the CL package itself, -;; to the same exact state it was defined at its inception, in ASDF 2.27 in 2013. -;; The same goes for UIOP/PACKAGE-LOCAL-NICKNAMES, that we use internally. -;; -;; If you ever must define new symbols in this file, you can and must -;; export them from a different package, possibly defined in the same file, -;; say a package UIOP/PACKAGE* defined at the end of this file with DEFINE-PACKAGE, -;; that might use :import-from to import the symbols from UIOP/PACKAGE, -;; if you must somehow define them in UIOP/PACKAGE. - -(defpackage :uiop/package ;;; THOU SHALT NOT modify this definition, EVER. See explanations above. - (:use :common-lisp) - (:export - #:find-package* #:find-symbol* #:symbol-call - #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern* - #:symbol-shadowing-p #:home-package-p - #:symbol-package-name #:standard-common-lisp-symbol-p - #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol - #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol - #:ensure-package-unused #:delete-package* - #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away - #:package-definition-form #:parse-define-package-form - #:ensure-package #:define-package - )) - -(in-package :uiop/package) - -;;; package local nicknames feature. -;;; This can't be deferred until common-lisp.lisp, where most such features are set. -;;; ABCL and CCL already define this feature appropriately. -;;; Seems to be unconditionally present for SBCL, ACL, and CLASP -;;; Don't know about ECL, or others -(eval-when (:load-toplevel :compile-toplevel :execute) - ;; ABCL pushes :package-local-nicknames without UIOP interfering, - ;; and Lispworks will do so - #+(or sbcl clasp) - (pushnew :package-local-nicknames *features*) - #+allegro - (let ((fname (find-symbol (symbol-name '#:add-package-local-nickname) '#:excl))) - (when (and fname (fboundp fname)) - (pushnew :package-local-nicknames *features*)))) - -;;; THOU SHALT NOT modify this definition, EVER, *EXCEPT* to add a new implementation. -;; If you somehow need to modify the API in any way, -;; you will need to create another, differently named, and just as immutable package. -#+package-local-nicknames -(defpackage :uiop/package-local-nicknames - (:use :cl) - (:import-from - #+allegro #:excl - #+sbcl #:sb-ext - #+(or clasp abcl ecl) #:ext - #+ccl #:ccl - #+lispworks #:hcl - #-(or allegro sbcl clasp abcl ccl lispworks ecl) - (error "Don't know from which package this lisp supplies the local-package-nicknames API.") - #:remove-package-local-nickname #:package-local-nicknames #:add-package-local-nickname) - (:export - #:add-package-local-nickname #:remove-package-local-nickname #:package-local-nicknames)) - -;;;; General purpose package utilities - -(eval-when (:load-toplevel :compile-toplevel :execute) - (deftype package-designator () '(and (or package character string symbol) (satisfies find-package))) - (define-condition no-such-package-error (type-error) - () - (:default-initargs :expected-type 'package-designator) - (:report (lambda (c s) - (format s "No package named ~a" (string (type-error-datum c)))))) - - (defmethod package-designator ((c no-such-package-error)) - (type-error-datum c)) - - (defun find-package* (package-designator &optional (errorp t)) - "Like CL:FIND-PACKAGE, but by default raises a UIOP:NO-SUCH-PACKAGE-ERROR if the - package is not found." - (let ((package (find-package package-designator))) - (cond - (package package) - (errorp (error 'no-such-package-error :datum package-designator)) - (t nil)))) - - (defun find-symbol* (name package-designator &optional (error t)) - "Find a symbol in a package of given string'ified NAME; -unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax -by letting you supply a symbol or keyword for the name; -also works well when the package is not present. -If optional ERROR argument is NIL, return NIL instead of an error -when the symbol is not found." - (block nil - (let ((package (find-package* package-designator error))) - (when package ;; package error handled by find-package* already - (multiple-value-bind (symbol status) (find-symbol (string name) package) - (cond - (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 export* (name package-designator) - (let* ((package (find-package* package-designator)) - (symbol (intern* name package))) - (export (or symbol (list symbol)) package))) - (defun import* (symbol package-designator) - (import (or symbol (list symbol)) (find-package* package-designator))) - (defun shadowing-import* (symbol package-designator) - (shadowing-import (or symbol (list symbol)) (find-package* package-designator))) - (defun shadow* (name package-designator) - (shadow (list (string name)) (find-package* package-designator))) - (defun make-symbol* (name) - (etypecase name - (string (make-symbol name)) - (symbol (copy-symbol name)))) - (defun unintern* (name package-designator &optional (error t)) - (block nil - (let ((package (find-package* package-designator error))) - (when package - (multiple-value-bind (symbol status) (find-symbol* name package error) - (cond - (status (unintern symbol package) - (return (values symbol status))) - (error (error "symbol ~A not present in package ~A" - (string symbol) (package-name package)))))) - (values nil nil)))) - (defun symbol-shadowing-p (symbol package) - (and (member symbol (package-shadowing-symbols package)) t)) - (defun home-package-p (symbol package) - (and package (let ((sp (symbol-package symbol))) - (and sp (let ((pp (find-package* package))) - (and pp (eq sp pp)))))))) - - -(eval-when (:load-toplevel :compile-toplevel :execute) - (defun symbol-package-name (symbol) - (let ((package (symbol-package symbol))) - (and package (package-name package)))) - (defun standard-common-lisp-symbol-p (symbol) - (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil) - (and (eq sym symbol) (eq status :external)))) - (defun reify-package (package &optional package-context) - (if (eq package package-context) t - (etypecase package - (null nil) - ((eql (find-package :cl)) :cl) - (package (package-name package))))) - (defun unreify-package (package &optional package-context) - (etypecase package - (null nil) - ((eql t) package-context) - ((or symbol string) (find-package package)))) - (defun reify-symbol (symbol &optional package-context) - (etypecase symbol - ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol) - (symbol (vector (symbol-name symbol) - (reify-package (symbol-package symbol) package-context))))) - (defun unreify-symbol (symbol &optional package-context) - (etypecase symbol - (symbol symbol) - ((simple-vector 2) - (let* ((symbol-name (svref symbol 0)) - (package-foo (svref symbol 1)) - (package (unreify-package package-foo package-context))) - (if package (intern* symbol-name package) - (make-symbol* symbol-name))))))) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (defvar *all-package-happiness* '()) - (defvar *all-package-fishiness* (list t)) - (defun record-fishy (info) - ;;(format t "~&FISHY: ~S~%" info) - (push info *all-package-fishiness*)) - (defmacro when-package-fishiness (&body body) - `(when *all-package-fishiness* ,@body)) - (defmacro note-package-fishiness (&rest info) - `(when-package-fishiness (record-fishy (list ,@info))))) - -(eval-when (:load-toplevel :compile-toplevel :execute) - #+(or clisp clozure) - (defun get-setf-function-symbol (symbol) - #+clisp (let ((sym (get symbol 'system::setf-function))) - (if sym (values sym :setf-function) - (let ((sym (get symbol 'system::setf-expander))) - (if sym (values sym :setf-expander) - (values nil nil))))) - #+clozure (gethash symbol ccl::%setf-function-names%)) - #+(or clisp clozure) - (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind) - #+clisp (assert (member kind '(:setf-function :setf-expander))) - #+clozure (assert (eq kind t)) - #+clisp - (cond - ((null new-setf-symbol) - (remprop symbol 'system::setf-function) - (remprop symbol 'system::setf-expander)) - ((eq kind :setf-function) - (setf (get symbol 'system::setf-function) new-setf-symbol)) - ((eq kind :setf-expander) - (setf (get symbol 'system::setf-expander) new-setf-symbol)) - (t (error "invalid kind of setf-function ~S for ~S to be set to ~S" - kind symbol new-setf-symbol))) - #+clozure - (progn - (gethash symbol ccl::%setf-function-names%) new-setf-symbol - (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol)) - #+(or clisp clozure) - (defun create-setf-function-symbol (symbol) - #+clisp (system::setf-symbol symbol) - #+clozure (ccl::construct-setf-function-name symbol)) - (defun set-dummy-symbol (symbol reason other-symbol) - (setf (get symbol 'dummy-symbol) (cons reason other-symbol))) - (defun make-dummy-symbol (symbol) - (let ((dummy (copy-symbol symbol))) - (set-dummy-symbol dummy 'replacing symbol) - (set-dummy-symbol symbol 'replaced-by dummy) - dummy)) - (defun dummy-symbol (symbol) - (get symbol 'dummy-symbol)) - (defun get-dummy-symbol (symbol) - (let ((existing (dummy-symbol symbol))) - (if existing (values (cdr existing) (car existing)) - (make-dummy-symbol symbol)))) - (defun nuke-symbol-in-package (symbol package-designator) - (let ((package (find-package* package-designator)) - (name (symbol-name symbol))) - (multiple-value-bind (sym stat) (find-symbol name package) - (when (and (member stat '(:internal :external)) (eq symbol sym)) - (if (symbol-shadowing-p symbol package) - (shadowing-import* (get-dummy-symbol symbol) package) - (unintern* symbol package)))))) - (defun nuke-symbol (symbol &optional (packages (list-all-packages))) - #+(or clisp clozure) - (multiple-value-bind (setf-symbol kind) - (get-setf-function-symbol symbol) - (when kind (nuke-symbol setf-symbol))) - (loop :for p :in packages :do (nuke-symbol-in-package symbol p))) - (defun rehome-symbol (symbol package-designator) - "Changes the home package of a symbol, also leaving it present in its old home if any" - (let* ((name (symbol-name symbol)) - (package (find-package* package-designator)) - (old-package (symbol-package symbol)) - (old-status (and old-package (nth-value 1 (find-symbol name old-package)))) - (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name)))) - (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package) - (unless (eq package old-package) - (let ((overwritten-symbol-shadowing-p - (and overwritten-symbol-status - (symbol-shadowing-p overwritten-symbol package)))) - (note-package-fishiness - :rehome-symbol name - (when old-package (package-name old-package)) old-status (and shadowing t) - (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p) - (when old-package - (if shadowing - (shadowing-import* shadowing old-package)) - (unintern* symbol old-package)) - (cond - (overwritten-symbol-shadowing-p - (shadowing-import* symbol package)) - (t - (when overwritten-symbol-status - (unintern* overwritten-symbol package)) - (import* symbol package))) - (if shadowing - (shadowing-import* symbol old-package) - (import* symbol old-package)) - #+(or clisp clozure) - (multiple-value-bind (setf-symbol kind) - (get-setf-function-symbol symbol) - (when kind - (let* ((setf-function (fdefinition setf-symbol)) - (new-setf-symbol (create-setf-function-symbol symbol))) - (note-package-fishiness - :setf-function - name (package-name package) - (symbol-name setf-symbol) (symbol-package-name setf-symbol) - (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol)) - (when (symbol-package setf-symbol) - (unintern* setf-symbol (symbol-package setf-symbol))) - (setf (fdefinition new-setf-symbol) setf-function) - (set-setf-function-symbol new-setf-symbol symbol kind)))) - #+(or clisp clozure) - (multiple-value-bind (overwritten-setf foundp) - (get-setf-function-symbol overwritten-symbol) - (when foundp - (unintern overwritten-setf))) - (when (eq old-status :external) - (export* symbol old-package)) - (when (eq overwritten-symbol-status :external) - (export* symbol package)))) - (values overwritten-symbol overwritten-symbol-status)))) - (defun ensure-package-unused (package) - (loop :for p :in (package-used-by-list package) :do - (unuse-package package p))) - (defun delete-package* (package &key nuke) - (let ((p (find-package package))) - (when p - (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s)))) - (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)) - (defun fresh-package-name (&key (prefix :%TO-BE-DELETED) - separator - (index (random most-positive-fixnum))) - (loop :for i :from index - :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i) - :thereis (and (not (find-package n)) n))) - (defun rename-package-away (p &rest keys &key prefix &allow-other-keys) - (let ((new-name - (apply 'fresh-package-name - :prefix (or prefix (format nil "__~A__" (package-name p))) keys))) - (record-fishy (list :rename-away (package-names p) new-name)) - (rename-package p new-name)))) - - -;;; Communicable representation of symbol and package information - -(eval-when (:load-toplevel :compile-toplevel :execute) - (defun package-definition-form (package-designator - &key (nicknamesp t) (usep t) - (shadowp t) (shadowing-import-p t) - (exportp t) (importp t) internp (error t)) - (let* ((package (or (find-package* package-designator error) - (return-from package-definition-form nil))) - (name (package-name package)) - (nicknames (package-nicknames package)) - (use (mapcar #'package-name (package-use-list package))) - (shadow ()) - (shadowing-import (make-hash-table :test 'equal)) - (import (make-hash-table :test 'equal)) - (export ()) - (intern ())) - (when package - (loop :for sym :being :the :symbols :in package - :for status = (nth-value 1 (find-symbol* sym package)) :do - (ecase status - ((nil :inherited)) - ((:internal :external) - (let* ((name (symbol-name sym)) - (external (eq status :external)) - (home (symbol-package sym)) - (home-name (package-name home)) - (imported (not (eq home package))) - (shadowing (symbol-shadowing-p sym package))) - (cond - ((and shadowing imported) - (push name (gethash home-name shadowing-import))) - (shadowing - (push name shadow)) - (imported - (push name (gethash home-name import)))) - (cond - (external - (push name export)) - (imported) - (t (push name intern))))))) - (labels ((sort-names (names) - (sort (copy-list names) #'string<)) - (table-keys (table) - (loop :for k :being :the :hash-keys :of table :collect k)) - (when-relevant (key value) - (when value (list (cons key value)))) - (import-options (key table) - (loop :for i :in (sort-names (table-keys table)) - :collect `(,key ,i ,@(sort-names (gethash i table)))))) - `(defpackage ,name - ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames))) - (:use ,@(and usep (sort-names use))) - ,@(when-relevant :shadow (and shadowp (sort-names shadow))) - ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import)) - ,@(import-options :import-from (and importp import)) - ,@(when-relevant :export (and exportp (sort-names export))) - ,@(when-relevant :intern (and internp (sort-names intern))))))))) - - -;;; ensure-package, define-package -(eval-when (:load-toplevel :compile-toplevel :execute) - ;; We already have UIOP:SIMPLE-STYLE-WARNING, but it comes from a later - ;; package. - (define-condition define-package-style-warning - #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning) - ()) - (defun ensure-shadowing-import (name to-package from-package shadowed imported) - (check-type name string) - (check-type to-package package) - (check-type from-package package) - (check-type shadowed hash-table) - (check-type imported hash-table) - (let ((import-me (find-symbol* name from-package))) - (multiple-value-bind (existing status) (find-symbol name to-package) - (cond - ((gethash name shadowed) - (unless (eq import-me existing) - (error "Conflicting shadowings for ~A" name))) - (t - (setf (gethash name shadowed) t) - (setf (gethash name imported) t) - (unless (or (null status) - (and (member status '(:internal :external)) - (eq existing import-me) - (symbol-shadowing-p existing to-package))) - (note-package-fishiness - :shadowing-import name - (package-name from-package) - (or (home-package-p import-me from-package) (symbol-package-name import-me)) - (package-name to-package) status - (and status (or (home-package-p existing to-package) (symbol-package-name existing))))) - (shadowing-import* import-me to-package)))))) - (defun ensure-imported (import-me into-package &optional from-package) - (check-type import-me symbol) - (check-type into-package package) - (check-type from-package (or null package)) - (let ((name (symbol-name import-me))) - (multiple-value-bind (existing status) (find-symbol name into-package) - (cond - ((not status) - (import* import-me into-package)) - ((eq import-me existing)) - (t - (let ((shadowing-p (symbol-shadowing-p existing into-package))) - (note-package-fishiness - :ensure-imported name - (and from-package (package-name from-package)) - (or (home-package-p import-me from-package) (symbol-package-name import-me)) - (package-name into-package) - status - (and status (or (home-package-p existing into-package) (symbol-package-name existing))) - shadowing-p) - (cond - ((or shadowing-p (eq status :inherited)) - (shadowing-import* import-me into-package)) - (t - (unintern* existing into-package) - (import* import-me into-package)))))))) - (values)) - (defun ensure-import (name to-package from-package shadowed imported) - (check-type name string) - (check-type to-package package) - (check-type from-package package) - (check-type shadowed hash-table) - (check-type imported hash-table) - (multiple-value-bind (import-me import-status) (find-symbol name from-package) - (when (null import-status) - (note-package-fishiness - :import-uninterned name (package-name from-package) (package-name to-package)) - (setf import-me (intern* name from-package))) - (multiple-value-bind (existing status) (find-symbol name to-package) - (cond - ((and imported (gethash name imported)) - (unless (and status (eq import-me existing)) - (error "Can't import ~S from both ~S and ~S" - name (package-name (symbol-package existing)) (package-name from-package)))) - ((gethash name shadowed) - (error "Can't both shadow ~S and import it from ~S" name (package-name from-package))) - (t - (setf (gethash name imported) t)))) - (ensure-imported import-me to-package from-package))) - (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited) - (check-type name string) - (check-type symbol symbol) - (check-type to-package package) - (check-type from-package package) - (check-type mixp (member nil t)) ; no cl:boolean on Genera - (check-type shadowed hash-table) - (check-type imported hash-table) - (check-type inherited hash-table) - (multiple-value-bind (existing status) (find-symbol name to-package) - (let* ((sp (symbol-package symbol)) - (in (gethash name inherited)) - (xp (and status (symbol-package existing)))) - (when (null sp) - (note-package-fishiness - :import-uninterned name - (package-name from-package) (package-name to-package) mixp) - (import* symbol from-package) - (setf sp (package-name from-package))) - (cond - ((gethash name shadowed)) - (in - (unless (equal sp (first in)) - (if mixp - (ensure-shadowing-import name to-package (second in) shadowed imported) - (error "Can't inherit ~S from ~S, it is inherited from ~S" - name (package-name sp) (package-name (first in)))))) - ((gethash name imported) - (unless (eq symbol existing) - (error "Can't inherit ~S from ~S, it is imported from ~S" - name (package-name sp) (package-name xp)))) - (t - (setf (gethash name inherited) (list sp from-package)) - (when (and status (not (eq sp xp))) - (let ((shadowing (symbol-shadowing-p existing to-package))) - (note-package-fishiness - :inherited name - (package-name from-package) - (or (home-package-p symbol from-package) (symbol-package-name symbol)) - (package-name to-package) - (or (home-package-p existing to-package) (symbol-package-name existing))) - (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported) - (unintern* existing to-package))))))))) - (defun ensure-mix (name symbol to-package from-package shadowed imported inherited) - (check-type name string) - (check-type symbol symbol) - (check-type to-package package) - (check-type from-package package) - (check-type shadowed hash-table) - (check-type imported hash-table) - (check-type inherited hash-table) - (unless (gethash name shadowed) - (multiple-value-bind (existing status) (find-symbol name to-package) - (let* ((sp (symbol-package symbol)) - (im (gethash name imported)) - (in (gethash name inherited))) - (cond - ((or (null status) - (and status (eq symbol existing)) - (and in (eq sp (first in)))) - (ensure-inherited name symbol to-package from-package t shadowed imported inherited)) - (in - (remhash name inherited) - (ensure-shadowing-import name to-package (second in) shadowed imported)) - (im - (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]" - name (package-name from-package) - (home-package-p symbol from-package) (symbol-package-name symbol) - (package-name to-package) - (home-package-p existing to-package) (symbol-package-name existing))) - (t - (ensure-inherited name symbol to-package from-package t shadowed imported inherited))))))) - - (defun recycle-symbol (name recycle exported) - ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE - ;; packages, and a hash-table of names (strings) of symbols scheduled to be - ;; EXPORTED from the package being defined. It returns two values, the - ;; symbol found (if any, or else NIL), and a boolean flag indicating whether - ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the - ;; re-homing of the symbol, etc. - (check-type name string) - (check-type recycle list) - (check-type exported hash-table) - (when (gethash name exported) ;; don't bother recycling private symbols - (let (recycled foundp) - (dolist (r recycle (values recycled foundp)) - (multiple-value-bind (symbol status) (find-symbol name r) - (when (and status (home-package-p symbol r)) - (cond - (foundp - ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that. - (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r))) - (t - (setf recycled symbol foundp r))))))))) - (defun symbol-recycled-p (sym recycle) - (check-type sym symbol) - (check-type recycle list) - (and (member (symbol-package sym) recycle) t)) - (defun ensure-symbol (name package intern recycle shadowed imported inherited exported) - (check-type name string) - (check-type package package) - (check-type intern (member nil t)) ; no cl:boolean on Genera - (check-type shadowed hash-table) - (check-type imported hash-table) - (check-type inherited hash-table) - (unless (or (gethash name shadowed) - (gethash name imported) - (gethash name inherited)) - (multiple-value-bind (existing status) - (find-symbol name package) - (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) - (cond - ((and status (eq existing recycled) (eq previous package))) - (previous - (rehome-symbol recycled package)) - ((and status (eq package (symbol-package existing)))) - (t - (when status - (note-package-fishiness - :ensure-symbol name - (reify-package (symbol-package existing) package) - status intern) - (unintern existing)) - (when intern - (intern* name package)))))))) - (declaim (ftype (function (t t t &optional t) t) ensure-exported)) - (defun ensure-exported-to-user (name symbol to-package &optional recycle) - (check-type name string) - (check-type symbol symbol) - (check-type to-package package) - (check-type recycle list) - (assert (equal name (symbol-name symbol))) - (multiple-value-bind (existing status) (find-symbol name to-package) - (unless (and status (eq symbol existing)) - (let ((accessible - (or (null status) - (let ((shadowing (symbol-shadowing-p existing to-package)) - (recycled (symbol-recycled-p existing recycle))) - (unless (and shadowing (not recycled)) - (note-package-fishiness - :ensure-export name (symbol-package-name symbol) - (package-name to-package) - (or (home-package-p existing to-package) (symbol-package-name existing)) - status shadowing) - (if (or (eq status :inherited) shadowing) - (shadowing-import* symbol to-package) - (unintern existing to-package)) - t))))) - (when (and accessible (eq status :external)) - (ensure-exported name symbol to-package recycle)))))) - (defun ensure-exported (name symbol from-package &optional recycle) - (dolist (to-package (package-used-by-list from-package)) - (ensure-exported-to-user name symbol to-package recycle)) - (unless (eq from-package (symbol-package symbol)) - (ensure-imported symbol from-package)) - (export* name from-package)) - (defun ensure-export (name from-package &optional recycle) - (multiple-value-bind (symbol status) (find-symbol* name from-package) - (unless (eq status :external) - (ensure-exported name symbol from-package recycle)))) - - #+package-local-nicknames - (defun install-package-local-nicknames (destination-package new-nicknames) - ;; First, remove all package-local nicknames. (We'll reinstall any desired ones later.) - (dolist (pair-to-remove (uiop/package-local-nicknames:package-local-nicknames destination-package)) - (uiop/package-local-nicknames:remove-package-local-nickname - (string (car pair-to-remove)) destination-package)) - ;; Then, install all desired nicknames. - (loop :for (nickname package) :in new-nicknames - :do (uiop/package-local-nicknames:add-package-local-nickname - (string nickname) - (find-package package) - destination-package))) - - (defun ensure-package (name &key - nicknames documentation use - shadow shadowing-import-from - import-from export intern - recycle mix reexport - unintern local-nicknames) - #+genera (declare (ignore documentation)) - (let* ((package-name (string name)) - (nicknames (mapcar #'string nicknames)) - (names (cons package-name nicknames)) - (previous (packages-from-names names)) - (discarded (cdr previous)) - (to-delete ()) - (package (or (first previous) (make-package package-name :nicknames nicknames))) - (recycle (packages-from-names recycle)) - (use (mapcar 'find-package* use)) - (mix (mapcar 'find-package* mix)) - (reexport (mapcar 'find-package* reexport)) - (shadow (mapcar 'string shadow)) - (export (mapcar 'string export)) - (intern (mapcar 'string intern)) - (unintern (mapcar 'string unintern)) - (local-nicknames (mapcar #'(lambda (pair) (mapcar 'string pair)) local-nicknames)) - (shadowed (make-hash-table :test 'equal)) ; string to bool - (imported (make-hash-table :test 'equal)) ; string to bool - (exported (make-hash-table :test 'equal)) ; string to bool - ;; string to list home package and use package: - (inherited (make-hash-table :test 'equal))) - #-package-local-nicknames - (declare (ignore local-nicknames)) ; if not supported - (when-package-fishiness (record-fishy package-name)) - ;; if supported, put package documentation - #-genera - (when documentation (setf (documentation package t) documentation)) - ;; remove unwanted packages from use list - (loop :for p :in (set-difference (package-use-list package) (append mix use)) - :do (note-package-fishiness :over-use name (package-names p)) - (unuse-package p package)) - ;; mark unwanted packages for deletion - (loop :for p :in discarded - :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) - (package-names p)) - :do (note-package-fishiness :nickname name (package-names p)) - (cond (n (rename-package p (first n) (rest n))) - (t (rename-package-away p) - (push p to-delete)))) - ;; give package its desired name - (rename-package package package-name nicknames) - ;; Handle local nicknames - #+package-local-nicknames - (install-package-local-nicknames package local-nicknames) - (dolist (name unintern) - (multiple-value-bind (existing status) (find-symbol name package) - (when status - (unless (eq status :inherited) - (note-package-fishiness - :unintern (package-name package) name (symbol-package-name existing) status) - (unintern* name package nil))))) - ;; handle exports - (dolist (name export) - (setf (gethash name exported) t)) - ;; handle reexportss - (dolist (p reexport) - (do-external-symbols (sym p) - (setf (gethash (string sym) exported) t))) - ;; unexport symbols not listed in (re)export - (do-external-symbols (sym package) - (let ((name (symbol-name sym))) - (unless (gethash name exported) - (note-package-fishiness - :over-export (package-name package) name - (or (home-package-p sym package) (symbol-package-name sym))) - (unexport sym package)))) - ;; handle explicitly listed shadowed ssymbols - (dolist (name shadow) - (setf (gethash name shadowed) t) - (multiple-value-bind (existing status) (find-symbol name package) - (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) - (let ((shadowing (and status (symbol-shadowing-p existing package)))) - (cond - ((eq previous package)) - (previous - (rehome-symbol recycled package)) - ((or (member status '(nil :inherited)) - (home-package-p existing package))) - (t - (let ((dummy (make-symbol name))) - (note-package-fishiness - :shadow-imported (package-name package) name - (symbol-package-name existing) status shadowing) - (shadowing-import* dummy package) - (import* dummy package))))))) - (shadow* name package)) - ;; handle shadowing imports - (loop :for (p . syms) :in shadowing-import-from - :for pp = (find-package* p) :do - (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported))) - ;; handle mixed packages - (loop :for p :in mix - :for pp = (find-package* p) :do - (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited))) - ;; handle import-from packages - (loop :for (p . syms) :in import-from - ;; FOR NOW suppress errors in the case where the :import-from - ;; symbol list is empty (used only to establish a dependency by - ;; package-inferred-system users). - :for pp = (find-package* p syms) :do - (when (null pp) - ;; TODO: ASDF 3.4 Change to a full warning. - (warn 'define-package-style-warning - :format-control "When defining package ~a, attempting to import-from non-existent package ~a. This is deprecated behavior and will be removed from UIOP in the future." - :format-arguments (list name p))) - (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported))) - ;; handle use-list and mix - (dolist (p (append use mix)) - (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited)) - (use-package p package)) - (loop :for name :being :the :hash-keys :of exported :do - (ensure-symbol name package t recycle shadowed imported inherited exported) - (ensure-export name package recycle)) - ;; intern dessired symbols - (dolist (name intern) - (ensure-symbol name package t recycle shadowed imported inherited exported)) - (do-symbols (sym package) - (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported)) - ;; delete now-deceased packages - (map () 'delete-package* to-delete) - 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 - :for (kw . args) :in clauses - :when (eq kw :nicknames) :append args :into nicknames :else - :when (eq kw :documentation) - :do (cond - (documentation (error "define-package: can't define documentation twice")) - ((or (atom args) (cdr args)) (error "define-package: bad documentation")) - (t (setf documentation (car args)))) :else - :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else - :when (eq kw :shadow) :append args :into shadow :else - :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else - :when (eq kw :import-from) :collect args :into import-from :else - :when (eq kw :export) :append args :into export :else - :when (eq kw :intern) :append args :into intern :else - :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else - :when (eq kw :mix) :append args :into mix :else - :when (eq kw :reexport) :append args :into reexport :else - :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport - :and :do (setf use-p t) :else - :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport - :and :do (setf use-p t) :else - :when (eq kw :unintern) :append args :into unintern :else - :when (eq kw :local-nicknames) - :if (symbol-call '#:uiop '#:featurep :package-local-nicknames) - :append args :into local-nicknames - :else - :do (error ":LOCAL-NICKAMES option is not supported on this lisp implementation.") - :end - :else - :do (error "unrecognized define-package keyword ~S" kw) - :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 local-nicknames - `(:local-nicknames ',local-nicknames))))))) - -(defmacro define-package (package &rest clauses) - "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form -\(KEYWORD . ARGS\). -DEFINE-PACKAGE supports the following keywords: -SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN, NICKNAMES, -DOCUMENTATION -- as per CL:DEFPACKAGE. -USE -- as per CL:DEFPACKAGE, but if neither USE, USE-REEXPORT, MIX, -nor MIX-REEXPORT is supplied, then it is equivalent to specifying -(:USE :COMMON-LISP). This is unlike CL:DEFPACKAGE for which the -behavior of a form without USE is implementation-dependent. -RECYCLE -- Recycle the package's exported symbols from the specified packages, -in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE, -either through an :EXPORT option or a :REEXPORT option, if the symbol exists in -one of the :RECYCLE packages, the first such symbol is re-homed to the package -being defined. -For the sake of idempotence, it is important that the package being defined -should appear in first position if it already exists, and even if it doesn't, -ahead of any package that is not going to be deleted afterwards and never -created again. In short, except for special cases, always make it the first -package on the list if the list is not empty. -MIX -- Takes a list of package designators. MIX behaves like -\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to -resolve conflicts in favor of the first found symbol. It may still yield -an error if there is a conflict with an explicitly :IMPORT-FROM symbol. -REEXPORT -- Takes a list of package designators. For each package, p, in the list, -export symbols with the same name as those exported from p. Note that in the case -of shadowing, etc. the symbols with the same name may not be the same symbols. -UNINTERN -- Remove symbols here from PACKAGE. Note that this is primarily useful -when *redefining* a previously-existing package in the current image (e.g., when -upgrading ASDF). Most programmers will have no use for this option. -LOCAL-NICKNAMES -- If the host implementation supports package local nicknames -\(check for the :PACKAGE-LOCAL-NICKNAMES feature\), then this should be a list of -nickname and package name pairs. Using this option will cause an error if the -host CL implementation does not support it. -USE-REEXPORT, MIX-REEXPORT -- Use or mix the specified packages as per the USE or -MIX directives, and reexport their contents as per the REEXPORT directive." - (let ((ensure-form - `(prog1 - (funcall 'ensure-package ,@(parse-define-package-form package clauses)) - #+sbcl (setf (sb-impl::package-source-location (find-package ',package)) - (sb-c:source-location))))) - `(progn - #+(or clasp ecl gcl mkcl) (defpackage ,package (:use)) - (eval-when (:compile-toplevel :load-toplevel :execute) - ,ensure-form)))) - -;; This package, unlike UIOP/PACKAGE, is allowed to evolve and acquire new symbols or drop old ones. -(define-package :uiop/package* - (:use-reexport :uiop/package - #+package-local-nicknames :uiop/package-local-nicknames) - (:import-from :uiop/package - #:define-package-style-warning - #:no-such-package-error - #:package-designator) - (:export #:define-package-style-warning - #:no-such-package-error - #:package-designator)) -;;;; ------------------------------------------------------------------------- -;;;; Handle compatibility with multiple implementations. -;;; This file is for papering over the deficiencies and peculiarities -;;; of various Common Lisp implementations. -;;; For implementation-specific access to the system, see os.lisp instead. -;;; A few functions are defined here, but actually exported from utility; -;;; from this package only common-lisp symbols are exported. - -(uiop/package:define-package :uiop/common-lisp - (:nicknames :uiop/cl) - (:use :uiop/package) - (:use-reexport #-genera :common-lisp #+genera :future-common-lisp) - #+allegro (:intern #:*acl-warn-save*) - #+cormanlisp (:shadow #:user-homedir-pathname) - #+cormanlisp - (:export - #:logical-pathname #:translate-logical-pathname - #:make-broadcast-stream #:file-namestring) - #+genera (:shadowing-import-from :scl #:boolean) - #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence) - #+(or mcl cmucl) (:shadow #:user-homedir-pathname)) -(in-package :uiop/common-lisp) - -#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl) -(error "ASDF is not supported on your implementation. Please help us port it.") - -;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. - - -;;;; Early meta-level tweaks - -#+(or allegro clasp clisp clozure cmucl ecl lispworks mezzano mkcl sbcl abcl) -(eval-when (:load-toplevel :compile-toplevel :execute) - (when (and #+allegro (member :ics *features*) - #+(or clasp clisp cmucl ecl lispworks mkcl) (member :unicode *features*) - #+clozure (member :openmcl-unicode-strings *features*) - #+sbcl (member :sb-unicode *features*) - #+abcl t) - ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode - ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. - (pushnew :asdf-unicode *features*))) - -#+allegro -(eval-when (:load-toplevel :compile-toplevel :execute) - ;; We need to disable autoloading BEFORE any mention of package ASDF. - ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file - ;; or any previous file. - (setf excl::*autoload-package-name-alist* - (remove "asdf" excl::*autoload-package-name-alist* - :test 'equalp :key 'car)) - (defparameter *acl-warn-save* - (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - excl:*warn-on-nested-reader-conditionals*)) - (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - (setf excl:*warn-on-nested-reader-conditionals* nil)) - (setf *print-readably* nil)) - -#+clasp -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf *load-verbose* nil) - (defun use-ecl-byte-compiler-p () nil)) - -#+clozure (in-package :ccl) -#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117 -(eval-when (:load-toplevel :compile-toplevel :execute) - (unless (fboundp 'external-process-wait) - (in-development-mode - (defun external-process-wait (proc) - (when (and (external-process-pid proc) (eq (external-process-%status proc) :running)) - (with-interrupts-enabled - (wait-on-semaphore (external-process-completed proc)))) - (values (external-process-%exit-code proc) - (external-process-%status proc)))))) -#+clozure (in-package :uiop/common-lisp) ;; back in this package. - -#+cmucl -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf ext:*gc-verbose* nil) - (defun user-homedir-pathname () - (first (ext:search-list (cl:user-homedir-pathname))))) - -#+cormanlisp -(eval-when (:load-toplevel :compile-toplevel :execute) - (deftype logical-pathname () nil) - (defun make-broadcast-stream () *error-output*) - (defun translate-logical-pathname (x) x) - (defun user-homedir-pathname (&optional host) - (declare (ignore host)) - (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname)))) - (defun file-namestring (p) - (setf p (pathname p)) - (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) - -#+ecl -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf *load-verbose* nil) - (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) - (unless (use-ecl-byte-compiler-p) (require :cmp))) - -#+gcl -(eval-when (:load-toplevel :compile-toplevel :execute) - (unless (member :ansi-cl *features*) - (error "ASDF only supports GCL in ANSI mode. Aborting.~%")) - (setf compiler::*compiler-default-type* (pathname "") - compiler::*lsp-ext* "") - #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later. - (cond - #+gcl - ((or (< system::*gcl-major-version* 2) - (and (= system::*gcl-major-version* 2) - (< system::*gcl-minor-version* 7))) - '(error "GCL 2.7 or later required to use ASDF"))))) - (eval code) - code)) - -#+genera -(eval-when (:load-toplevel :compile-toplevel :execute) - (unless (fboundp 'lambda) - (defmacro lambda (&whole form &rest bvl-decls-and-body) - (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1)) - `#',(cons 'lisp::lambda (cdr form)))) - (unless (fboundp 'ensure-directories-exist) - (defun ensure-directories-exist (path) - (fs:create-directories-recursively (pathname path)))) - (unless (fboundp 'read-sequence) - (defun read-sequence (sequence stream &key (start 0) end) - (scl:send stream :string-in nil sequence start end))) - (unless (fboundp 'write-sequence) - (defun write-sequence (sequence stream &key (start 0) end) - (scl:send stream :string-out sequence start end) - sequence))) - -#+lispworks -(eval-when (:load-toplevel :compile-toplevel :execute) - ;; lispworks 3 and earlier cannot be checked for so we always assume - ;; at least version 4 - (unless (member :lispworks4 *features*) - (pushnew :lispworks5+ *features*) - (unless (member :lispworks5 *features*) - (pushnew :lispworks6+ *features*) - (unless (member :lispworks6 *features*) - (pushnew :lispworks7+ *features*))))) - - -#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick - (read-from-string - "(eval-when (:load-toplevel :compile-toplevel :execute) - (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) - (ccl:define-entry-point (_system \"system\") ((name :string)) :int) - ;; Note: ASDF may expect user-homedir-pathname to provide - ;; the pathname of the current user's home directory, whereas - ;; MCL by default provides the directory from which MCL was started. - ;; See http://code.google.com/p/mcl/wiki/Portability - (defun user-homedir-pathname () - (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) - (defun probe-posix (posix-namestring) - \"If a file exists for the posix namestring, return the pathname\" - (ccl::with-cstrs ((cpath posix-namestring)) - (ccl::rlet ((is-dir :boolean) - (fsref :fsref)) - (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) - (ccl::%path-from-fsref fsref is-dir))))))")) - -#+mkcl -(eval-when (:load-toplevel :compile-toplevel :execute) - (require :cmp) - (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics - - -;;;; compatfmt: avoid fancy format directives when unsupported -(eval-when (:load-toplevel :compile-toplevel :execute) - (defun frob-substrings (string substrings &optional frob) - "for each substring in SUBSTRINGS, find occurrences of it within STRING -that don't use parts of matched occurrences of previous strings, and -FROB them, that is to say, remove them if FROB is NIL, -replace by FROB if FROB is a STRING, or if FROB is a FUNCTION, -call FROB with the match and a function that emits a string in the output. -Return a string made of the parts not omitted or emitted by FROB." - (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3))) - (let ((length (length string)) (stream nil)) - (labels ((emit-string (x &optional (start 0) (end (length x))) - (when (< start end) - (unless stream (setf stream (make-string-output-stream))) - (write-string x stream :start start :end end))) - (emit-substring (start end) - (when (and (zerop start) (= end length)) - (return-from frob-substrings string)) - (emit-string string start end)) - (recurse (substrings start end) - (cond - ((>= start end)) - ((null substrings) (emit-substring start end)) - (t (let* ((sub-spec (first substrings)) - (sub (if (consp sub-spec) (car sub-spec) sub-spec)) - (fun (if (consp sub-spec) (cdr sub-spec) frob)) - (found (search sub string :start2 start :end2 end)) - (more (rest substrings))) - (cond - (found - (recurse more start found) - (etypecase fun - (null) - (string (emit-string fun)) - (function (funcall fun sub #'emit-string))) - (recurse substrings (+ found (length sub)) end)) - (t - (recurse more start end)))))))) - (recurse substrings 0 length)) - (if stream (get-output-stream-string stream) ""))) - - (defmacro compatfmt (format) - #+(or gcl genera) - (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>"))) - #-(or gcl genera) format)) -;;;; ------------------------------------------------------------------------- -;;;; General Purpose Utilities for ASDF - -(uiop/package:define-package :uiop/utility - (:use :uiop/common-lisp :uiop/package) - ;; import and reexport a few things defined in :uiop/common-lisp - (:import-from :uiop/common-lisp #:compatfmt #:frob-substrings - #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) - (:export #:compatfmt #:frob-substrings #:compatfmt - #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) - (:export - ;; magic helper to define debugging functions: - #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* - #:with-upgradability ;; (un)defining functions in an upgrade-friendly way - #:nest #:if-let ;; basic flow control - #:parse-body ;; macro definition helper - #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists - #:remove-plist-keys #:remove-plist-key ;; plists - #:emptyp ;; sequences - #:+non-base-chars-exist-p+ ;; characters - #:+max-character-type-index+ #:character-type-index #:+character-types+ - #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings - #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ - #:string-prefix-p #:string-enclosed-p #:string-suffix-p - #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols - #:coerce-class ;; CLOS - #:timestamp< #:timestamps< #:timestamp*< #:timestamp<= ;; timestamps - #:earlier-timestamp #:timestamps-earliest #:earliest-timestamp - #:later-timestamp #:timestamps-latest #:latest-timestamp #:latest-timestamp-f - #:list-to-hash-set #:ensure-gethash ;; hash-table - #:ensure-function #:access-at #:access-at-count ;; functions - #:call-function #:call-functions #:register-hook-function - #:lexicographic< #:lexicographic<= ;; version - #:simple-style-warning #:style-warn ;; simple style warnings - #:match-condition-p #:match-any-condition-p ;; conditions - #:call-with-muffled-conditions #:with-muffled-conditions - #:not-implemented-error #:parameter-error - #:symbol-test-to-feature-expression - #:boolean-to-feature-expression)) -(in-package :uiop/utility) - -;;;; Defining functions in a way compatible with hot-upgrade: -;; - The WTIH-UPGRADABILITY infrastructure below ensures that functions are declared NOTINLINE, -;; so that new definitions are always seen by all callers, even those up the stack. -;; - WITH-UPGRADABILITY also uses EVAL-WHEN so that definitions used by ASDF are in a limbo state -;; (especially for gf's) in between the COMPILE-OP and LOAD-OP operations on the defining file. -;; - THOU SHALT NOT redefine a function with a backward-incompatible semantics without renaming it, -;; at least if that function is used by ASDF while performing the plan to load ASDF. -;; - THOU SHALT change the name of a function whenever thou makest an incompatible change. -;; - For instance, when the meanings of NIL and T for timestamps was inverted, -;; functions in the STAMP<, STAMP<=, etc. family had to be renamed to TIMESTAMP<, TIMESTAMP<=, etc., -;; because the change other caused a huge incompatibility during upgrade. -;; - Whenever a function goes from a DEFUN to a DEFGENERIC, or the DEFGENERIC signature changes, etc., -;; even in a backward-compatible way, you MUST precede the definition by FMAKUNBOUND. -;; - Since FMAKUNBOUND will remove all the methods on the generic function, make sure that -;; all the methods required for ASDF to successfully continue compiling itself -;; shall be defined in the same file as the one with the FMAKUNBOUND, *after* the DEFGENERIC. -;; - When a function goes from DEFGENERIC to DEFUN, you may omit to use FMAKUNBOUND. -;; - For safety, you shall put the FMAKUNBOUND just before the DEFUN or DEFGENERIC, -;; in the same WITH-UPGRADABILITY form (and its implicit EVAL-WHEN). -;; - Any time you change a signature, please keep a comment specifying the first release after the change; -;; put that comment on the same line as FMAKUNBOUND, it you use FMAKUNBOUND. -(eval-when (:load-toplevel :compile-toplevel :execute) - (defun ensure-function-notinline (definition &aux (name (second definition))) - (assert (member (first definition) '(defun defgeneric))) - `(progn - ,(when (and #+(or clasp ecl) (symbolp name)) ; NB: fails for (SETF functions) on ECL - `(declaim (notinline ,name))) - ,definition)) - (defmacro with-upgradability ((&optional) &body body) - "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified -to also declare the functions NOTINLINE and to accept a wrapping the function name -specification into a list with keyword argument SUPERSEDE (which defaults to T if the name -is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION -to supersede any previous definition." - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@(loop :for form :in body :collect - (if (consp form) - (case (first form) - ((defun defgeneric) (ensure-function-notinline form)) - (otherwise form)) - form))))) - -;;; Magic debugging help. See contrib/debug.lisp -(with-upgradability () - (defvar *uiop-debug-utility* - '(symbol-call :uiop :subpathname (symbol-call :uiop :uiop-directory) "contrib/debug.lisp") - "form that evaluates to the pathname to your favorite debugging utilities") - - (defmacro uiop-debug (&rest keys) - "Load the UIOP debug utility at compile-time as well as runtime" - `(eval-when (:compile-toplevel :load-toplevel :execute) - (load-uiop-debug-utility ,@keys))) - - (defun load-uiop-debug-utility (&key package utility-file) - "Load the UIOP debug utility in given PACKAGE (default *PACKAGE*). -Beware: The utility is located by EVAL'uating the UTILITY-FILE form (default *UIOP-DEBUG-UTILITY*)." - (let* ((*package* (if package (find-package package) *package*)) - (keyword (read-from-string - (format nil ":DBG-~:@(~A~)" (package-name *package*))))) - (unless (member keyword *features*) - (let* ((utility-file (or utility-file *uiop-debug-utility*)) - (file (ignore-errors (probe-file (eval utility-file))))) - (if file (load file) - (error "Failed to locate debug utility file: ~S" utility-file))))))) - -;;; Flow control -(with-upgradability () - (defmacro nest (&rest things) - "Macro to keep code nesting and indentation under control." ;; Thanks to mbaringer - (reduce #'(lambda (outer inner) `(,@outer ,inner)) - things :from-end t)) - - (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria - ;; bindings can be (var form) or ((var1 form1) ...) - (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) - (list bindings) - bindings)) - (variables (mapcar #'car binding-list))) - `(let ,binding-list - (if (and ,@variables) - ,then-form - ,else-form))))) - -;;; Macro definition helper -(with-upgradability () - (defun parse-body (body &key documentation whole) ;; from alexandria - "Parses BODY into (values remaining-forms declarations doc-string). -Documentation strings are recognized only if DOCUMENTATION is true. -Syntax errors in body are signalled and WHOLE is used in the signal -arguments when given." - (let ((doc nil) - (decls nil) - (current nil)) - (tagbody - :declarations - (setf current (car body)) - (when (and documentation (stringp current) (cdr body)) - (if doc - (error "Too many documentation strings in ~S." (or whole body)) - (setf doc (pop body))) - (go :declarations)) - (when (and (listp current) (eql (first current) 'declare)) - (push (pop body) decls) - (go :declarations))) - (values body (nreverse decls) doc)))) - - -;;; List manipulation -(with-upgradability () - (defmacro while-collecting ((&rest collectors) &body body) - "COLLECTORS should be a list of names for collections. A collector -defines a function that, when applied to an argument inside BODY, will -add its argument to the corresponding collection. Returns multiple values, -a list for each collection, in order. - E.g., -\(while-collecting \(foo bar\) - \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) - \(foo \(first x\)\) - \(bar \(second x\)\)\)\) -Returns two values: \(A B C\) and \(1 2 3\)." - (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) - (initial-values (mapcar (constantly nil) collectors))) - `(let ,(mapcar #'list vars initial-values) - (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) - ,@body - (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) - - (define-modify-macro appendf (&rest args) - append "Append onto list") ;; only to be used on short lists. - - (defun length=n-p (x n) ;is it that (= (length x) n) ? - (check-type n (integer 0 *)) - (loop - :for l = x :then (cdr l) - :for i :downfrom n :do - (cond - ((zerop i) (return (null l))) - ((not (consp l)) (return nil))))) - - (defun ensure-list (x) - (if (listp x) x (list x)))) - - -;;; Remove a key from a plist, i.e. for keyword argument cleanup -(with-upgradability () - (defun remove-plist-key (key plist) - "Remove a single key from a plist" - (loop :for (k v) :on plist :by #'cddr - :unless (eq k key) - :append (list k v))) - - (defun remove-plist-keys (keys plist) - "Remove a list of keys from a plist" - (loop :for (k v) :on plist :by #'cddr - :unless (member k keys) - :append (list k v)))) - - -;;; Sequences -(with-upgradability () - (defun emptyp (x) - "Predicate that is true for an empty sequence" - (or (null x) (and (vectorp x) (zerop (length x)))))) - - -;;; Characters -(with-upgradability () - ;; base-char != character on ECL, LW, SBCL, Genera. - ;; NB: We assume a total order on character types. - ;; If that's not true... this code will need to be updated. - (defparameter +character-types+ ;; assuming a simple hierarchy - #.(coerce (loop :for (type next) :on - '(;; In SCL, all characters seem to be 16-bit base-char - ;; Yet somehow character fails to be a subtype of base-char - #-scl base-char - ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER - ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER - #+lispworks7+ lw:bmp-char - #+lispworks lw:simple-char - character) - :unless (and next (subtypep next type)) - :collect type) 'vector)) - (defparameter +max-character-type-index+ (1- (length +character-types+))) - (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+)) - (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) - -(with-upgradability () - (defun character-type-index (x) - (declare (ignorable x)) - #.(case +max-character-type-index+ - (0 0) - (1 '(etypecase x - (character (if (typep x 'base-char) 0 1)) - (symbol (if (subtypep x 'base-char) 0 1)))) - (otherwise - '(or (position-if (etypecase x - (character #'(lambda (type) (typep x type))) - (symbol #'(lambda (type) (subtypep x type)))) - +character-types+) - (error "Not a character or character type: ~S" x)))))) - - -;;; Strings -(with-upgradability () - (defun base-string-p (string) - "Does the STRING only contain BASE-CHARs?" - (declare (ignorable string)) - (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string)))) - - (defun strings-common-element-type (strings) - "What least subtype of CHARACTER can contain all the elements of all the STRINGS?" - (declare (ignorable strings)) - #.(if +non-base-chars-exist-p+ - `(aref +character-types+ - (loop :with index = 0 :for s :in strings :do - (flet ((consider (i) - (cond ((= i ,+max-character-type-index+) (return i)) - ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i))))))) - (cond - ((emptyp s)) ;; NIL or empty string - ((characterp s) (consider (character-type-index s))) - ((stringp s) (let ((string-type-index - (character-type-index (array-element-type s)))) - (unless (>= index string-type-index) - (loop :for c :across s :for i = (character-type-index c) - :do (consider i) - ,@(when (> +max-character-type-index+ 1) - `((when (= i string-type-index) (return)))))))) - (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type)))) - :finally (return index))) - ''character)) - - (defun reduce/strcat (strings &key key start end) - "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE. -NIL is interpreted as an empty string. A character is interpreted as a string of length one." - (when (or start end) (setf strings (subseq strings start end))) - (when key (setf strings (mapcar key strings))) - (loop :with output = (make-string (loop :for s :in strings - :sum (if (characterp s) 1 (length s))) - :element-type (strings-common-element-type strings)) - :with pos = 0 - :for input :in strings - :do (etypecase input - (null) - (character (setf (char output pos) input) (incf pos)) - (string (replace output input :start1 pos) (incf pos (length input)))) - :finally (return output))) - - (defun strcat (&rest strings) - "Concatenate strings. -NIL is interpreted as an empty string, a character as a string of length one." - (reduce/strcat strings)) - - (defun first-char (s) - "Return the first character of a non-empty string S, or NIL" - (and (stringp s) (plusp (length s)) (char s 0))) - - (defun last-char (s) - "Return the last character of a non-empty string S, or NIL" - (and (stringp s) (plusp (length s)) (char s (1- (length s))))) - - (defun split-string (string &key max (separator '(#\Space #\Tab))) - "Split STRING into a list of components separated by -any of the characters in the sequence SEPARATOR. -If MAX is specified, then no more than max(1,MAX) components will be returned, -starting the separation from the end, e.g. when called with arguments - \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." - (block () - (let ((list nil) (words 0) (end (length string))) - (when (zerop end) (return nil)) - (flet ((separatorp (char) (find char separator)) - (done () (return (cons (subseq string 0 end) list)))) - (loop - :for start = (if (and max (>= words (1- max))) - (done) - (position-if #'separatorp string :end end :from-end t)) - :do (when (null start) (done)) - (push (subseq string (1+ start) end) list) - (incf words) - (setf end start)))))) - - (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))) - - (defvar +cr+ (coerce #(#\Return) 'string)) - (defvar +lf+ (coerce #(#\Linefeed) 'string)) - (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string)) - - (defun stripln (x) - "Strip a string X from any ending CR, LF or CRLF. -Return two values, the stripped string and the ending that was stripped, -or the original value and NIL if no stripping took place. -Since our STRCAT accepts NIL as empty string designator, -the two results passed to STRCAT always reconstitute the original string" - (check-type x string) - (block nil - (flet ((c (end) (when (string-suffix-p x end) - (return (values (subseq x 0 (- (length x) (length end))) end))))) - (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil))))) - - (defun standard-case-symbol-name (name-designator) - "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING; -if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\" -platform such as Allegro with modern syntax." - (check-type name-designator (or string symbol)) - (cond - ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower)) - (string name-designator)) - ;; Should we be doing something on CLISP? - (t (string-upcase name-designator)))) - - (defun find-standard-case-symbol (name-designator package-designator &optional (error t)) - "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR, -where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings. -If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found." - (find-symbol* (standard-case-symbol-name name-designator) - (etypecase package-designator - ((or package symbol) package-designator) - (string (standard-case-symbol-name package-designator))) - error))) - -;;; timestamps: a REAL or a boolean where T=-infinity, NIL=+infinity -(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) - (deftype timestamp () '(or real boolean))) -(with-upgradability () - (defun timestamp< (x y) - (etypecase x - ((eql t) (not (eql y t))) - (real (etypecase y - ((eql t) nil) - (real (< x y)) - (null t))) - (null nil))) - (defun timestamps< (list) (loop :for y :in list :for x = nil :then y :always (timestamp< x y))) - (defun timestamp*< (&rest list) (timestamps< list)) - (defun timestamp<= (x y) (not (timestamp< y x))) - (defun earlier-timestamp (x y) (if (timestamp< x y) x y)) - (defun timestamps-earliest (list) (reduce 'earlier-timestamp list :initial-value nil)) - (defun earliest-timestamp (&rest list) (timestamps-earliest list)) - (defun later-timestamp (x y) (if (timestamp< x y) y x)) - (defun timestamps-latest (list) (reduce 'later-timestamp list :initial-value t)) - (defun latest-timestamp (&rest list) (timestamps-latest list)) - (define-modify-macro latest-timestamp-f (&rest timestamps) latest-timestamp)) - - -;;; Function designators -(with-upgradability () - (defun ensure-function (fun &key (package :cl)) - "Coerce the object FUN into a function. - -If FUN is a FUNCTION, return it. -If the FUN is a non-sequence literal constant, return constantly that, -i.e. for a boolean keyword character number or pathname. -Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION. -If FUN is a CONS, return the function that applies its CAR -to the appended list of the rest of its CDR and the arguments, -unless the CAR is LAMBDA, in which case the expression is evaluated. -If FUN is a string, READ a form from it in the specified PACKAGE (default: CL) -and EVAL that in a (FUNCTION ...) context." - (etypecase fun - (function fun) - ((or boolean keyword character number pathname) (constantly fun)) - (hash-table #'(lambda (x) (gethash x fun))) - (symbol (fdefinition fun)) - (cons (if (eq 'lambda (car fun)) - (eval fun) - #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))) - (string (eval `(function ,(with-standard-io-syntax - (let ((*package* (find-package package))) - (read-from-string fun)))))))) - - (defun access-at (object at) - "Given an OBJECT and an AT specifier, list of successive accessors, -call each accessor on the result of the previous calls. -An accessor may be an integer, meaning a call to ELT, -a keyword, meaning a call to GETF, -NIL, meaning identity, -a function or other symbol, meaning itself, -or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION. -As a degenerate case, the AT specifier may be an atom of a single such accessor -instead of a list." - (flet ((access (object accessor) - (etypecase accessor - (function (funcall accessor object)) - (integer (elt object accessor)) - (keyword (getf object accessor)) - (null object) - (symbol (funcall accessor object)) - (cons (funcall (ensure-function accessor) object))))) - (if (listp at) - (dolist (accessor at object) - (setf object (access object accessor))) - (access object at)))) - - (defun access-at-count (at) - "From an AT specification, extract a COUNT of maximum number -of sub-objects to read as per ACCESS-AT" - (cond - ((integerp at) - (1+ at)) - ((and (consp at) (integerp (first at))) - (1+ (first at))))) - - (defun call-function (function-spec &rest arguments) - "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION, -with the given ARGUMENTS" - (apply (ensure-function function-spec) arguments)) - - (defun call-functions (function-specs) - "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION" - (map () 'call-function function-specs)) - - (defun register-hook-function (variable hook &optional call-now-p) - "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE. -When CALL-NOW-P is true, also call the function immediately." - (pushnew hook (symbol-value variable) :test 'equal) - (when call-now-p (call-function hook)))) - - -;;; CLOS -(with-upgradability () - (defun coerce-class (class &key (package :cl) (super t) (error 'error)) - "Coerce CLASS to a class that is subclass of SUPER if specified, -or invoke ERROR handler as per CALL-FUNCTION. - -A keyword designates the name a symbol, which when found in either PACKAGE, designates a class. --- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future. -A string is read as a symbol while in PACKAGE, the symbol designates a class. - -A class object designates itself. -NIL designates itself (no class). -A symbol otherwise designates a class by name." - (let* ((normalized - (typecase class - (keyword (or (find-symbol* class package nil) - (find-symbol* class *package* nil))) - (string (symbol-call :uiop :safe-read-from-string class :package package)) - (t class))) - (found - (etypecase normalized - ((or standard-class built-in-class) normalized) - ((or null keyword) nil) - (symbol (find-class normalized nil nil)))) - (super-class - (etypecase super - ((or standard-class built-in-class) super) - ((or null keyword) nil) - (symbol (find-class super nil nil))))) - #+allegro (when found (mop:finalize-inheritance found)) - (or (and found - (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class)) - found) - (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super))))) - - -;;; Hash-tables -(with-upgradability () - (defun ensure-gethash (key table default) - "Lookup the TABLE for a KEY as by GETHASH, but if not present, -call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION, -set the corresponding entry to the result in the table. -Return two values: the entry after its optional computation, and whether it was found" - (multiple-value-bind (value foundp) (gethash key table) - (values - (if foundp - value - (setf (gethash key table) (call-function default))) - foundp))) - - (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) - "Convert a LIST into hash-table that has the same elements when viewed as a set, -up to the given equality TEST" - (dolist (x list h) (setf (gethash x h) t)))) - - -;;; Lexicographic comparison of lists of numbers -(with-upgradability () - (defun lexicographic< (element< x y) - "Lexicographically compare two lists of using the function element< to compare elements. -element< is a strict total order; the resulting order on X and Y will also be strict." - (cond ((null y) nil) - ((null x) t) - ((funcall element< (car x) (car y)) t) - ((funcall element< (car y) (car x)) nil) - (t (lexicographic< element< (cdr x) (cdr y))))) - - (defun lexicographic<= (element< x y) - "Lexicographically compare two lists of using the function element< to compare elements. -element< is a strict total order; the resulting order on X and Y will be a non-strict total order." - (not (lexicographic< element< y x)))) - - -;;; Simple style warnings -(with-upgradability () - (define-condition simple-style-warning - #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning) - ()) - - (defun style-warn (datum &rest arguments) - (etypecase datum - (string (warn (make-condition 'simple-style-warning :format-control datum :format-arguments arguments))) - (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments)) - (style-warning (apply 'warn datum arguments))))) - - -;;; Condition control - -(with-upgradability () - (defparameter +simple-condition-format-control-slot+ - #+abcl 'system::format-control - #+allegro 'excl::format-control - #+(or clasp ecl mkcl) 'si::format-control - #+clisp 'system::$format-control - #+clozure 'ccl::format-control - #+(or cmucl scl) 'conditions::format-control - #+(or gcl lispworks) 'conditions::format-string - #+sbcl 'sb-kernel:format-control - #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil - "Name of the slot for FORMAT-CONTROL in simple-condition") - - (defun match-condition-p (x condition) - "Compare received CONDITION to some pattern X: -a symbol naming a condition class, -a simple vector of length 2, arguments to find-symbol* with result as above, -or a string describing the format-control of a simple-condition." - (etypecase x - (symbol (typep condition x)) - ((simple-vector 2) - (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))) - (function (funcall x condition)) - (string (and (typep condition 'simple-condition) - ;; On SBCL, it's always set and the check triggers a warning - #+(or allegro clozure cmucl lispworks scl) - (slot-boundp condition +simple-condition-format-control-slot+) - (ignore-errors (equal (simple-condition-format-control condition) x)))))) - - (defun match-any-condition-p (condition conditions) - "match CONDITION against any of the patterns of CONDITIONS supplied" - (loop :for x :in conditions :thereis (match-condition-p x condition))) - - (defun call-with-muffled-conditions (thunk conditions) - "calls the THUNK in a context where the CONDITIONS are muffled" - (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions) - (muffle-warning c))))) - (funcall thunk))) - - (defmacro with-muffled-conditions ((conditions) &body body) - "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS" - `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) - -;;; Conditions - -(with-upgradability () - (define-condition not-implemented-error (error) - ((functionality :initarg :functionality) - (format-control :initarg :format-control) - (format-arguments :initarg :format-arguments)) - (:report (lambda (condition stream) - (format stream "Not (currently) implemented on ~A: ~S~@[ ~?~]" - (nth-value 1 (symbol-call :uiop :implementation-type)) - (slot-value condition 'functionality) - (slot-value condition 'format-control) - (slot-value condition 'format-arguments))))) - - (defun not-implemented-error (functionality &optional format-control &rest format-arguments) - "Signal an error because some FUNCTIONALITY is not implemented in the current version -of the software on the current platform; it may or may not be implemented in different combinations -of version of the software and of the underlying platform. Optionally, report a formatted error -message." - (error 'not-implemented-error - :functionality functionality - :format-control format-control - :format-arguments format-arguments)) - - (define-condition parameter-error (error) - ((functionality :initarg :functionality) - (format-control :initarg :format-control) - (format-arguments :initarg :format-arguments)) - (:report (lambda (condition stream) - (apply 'format stream - (slot-value condition 'format-control) - (slot-value condition 'functionality) - (slot-value condition 'format-arguments))))) - - ;; Note that functionality MUST be passed as the second argument to parameter-error, just after - ;; the format-control. If you want it to not appear in first position in actual message, use - ;; ~* and ~:* to adjust parameter order. - (defun parameter-error (format-control functionality &rest format-arguments) - "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying -platform does not accept a given parameter or combination of parameters. Report a formatted error -message, that takes the functionality as its first argument (that can be skipped with ~*)." - (error 'parameter-error - :functionality functionality - :format-control format-control - :format-arguments format-arguments))) - -(with-upgradability () - (defun boolean-to-feature-expression (value) - "Converts a boolean VALUE to a form suitable for testing with #+." - (if value - '(:and) - '(:or))) - - (defun symbol-test-to-feature-expression (name package) - "Check if a symbol with a given NAME exists in PACKAGE and returns a -form suitable for testing with #+." - (boolean-to-feature-expression - (find-symbol* name package nil)))) -(uiop/package:define-package :uiop/version - (:recycle :uiop/version :uiop/utility :asdf) - (:use :uiop/common-lisp :uiop/package :uiop/utility) - (:export - #:*uiop-version* - #:parse-version #:unparse-version #:version< #:version<= #:version= ;; version support, moved from uiop/utility - #:next-version - #:deprecated-function-condition #:deprecated-function-name ;; deprecation control - #:deprecated-function-style-warning #:deprecated-function-warning - #:deprecated-function-error #:deprecated-function-should-be-deleted - #:version-deprecation #:with-deprecation)) -(in-package :uiop/version) - -(with-upgradability () - (defparameter *uiop-version* "3.3.6") - - (defun unparse-version (version-list) - "From a parsed version (a list of natural numbers), compute the version string" - (format nil "~{~D~^.~}" version-list)) - - (defun parse-version (version-string &optional on-error) - "Parse a VERSION-STRING as a series of natural numbers separated by dots. -Return a (non-null) list of integers if the string is valid; -otherwise return NIL. - -When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL, -with format arguments explaining why the version is invalid. -ON-ERROR is also called if the version is not canonical -in that it doesn't print back to itself, but the list is returned anyway." - (block nil - (unless (stringp version-string) - (call-function on-error "~S: ~S is not a string" 'parse-version version-string) - (return)) - (unless (loop :for prev = nil :then c :for c :across version-string - :always (or (digit-char-p c) - (and (eql c #\.) prev (not (eql prev #\.)))) - :finally (return (and c (digit-char-p c)))) - (call-function on-error "~S: ~S doesn't follow asdf version numbering convention" - 'parse-version version-string) - (return)) - (let* ((version-list - (mapcar #'parse-integer (split-string version-string :separator "."))) - (normalized-version (unparse-version version-list))) - (unless (equal version-string normalized-version) - (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string)) - version-list))) - - (defun next-version (version) - "When VERSION is not nil, it is a string, then parse it as a version, compute the next version -and return it as a string." - (when version - (let ((version-list (parse-version version))) - (incf (car (last version-list))) - (unparse-version version-list)))) - - (defun version< (version1 version2) - "Given two version strings, return T if the second is strictly newer" - (let ((v1 (parse-version version1 nil)) - (v2 (parse-version version2 nil))) - (lexicographic< '< v1 v2))) - - (defun version<= (version1 version2) - "Given two version strings, return T if the second is newer or the same" - (not (version< version2 version1)))) - - (defun version= (version1 version2) - "Given two version strings, return T if the first is newer or the same and -the second is also newer or the same." - (and (version<= version1 version2) - (version<= version2 version1))) - - -(with-upgradability () - (define-condition deprecated-function-condition (condition) - ((name :initarg :name :reader deprecated-function-name))) - (define-condition deprecated-function-style-warning (deprecated-function-condition style-warning) ()) - (define-condition deprecated-function-warning (deprecated-function-condition warning) ()) - (define-condition deprecated-function-error (deprecated-function-condition error) ()) - (define-condition deprecated-function-should-be-deleted (deprecated-function-condition error) ()) - - (defun deprecated-function-condition-kind (type) - (ecase type - ((deprecated-function-style-warning) :style-warning) - ((deprecated-function-warning) :warning) - ((deprecated-function-error) :error) - ((deprecated-function-should-be-deleted) :delete))) - - (defmethod print-object ((c deprecated-function-condition) stream) - (let ((name (deprecated-function-name c))) - (cond - (*print-readably* - (let ((fmt "#.(make-condition '~S :name ~S)") - (args (list (type-of c) name))) - (if *read-eval* - (apply 'format stream fmt args) - (error "Can't print ~?" fmt args)))) - (*print-escape* - (print-unreadable-object (c stream :type t) (format stream ":name ~S" name))) - (t - (let ((*package* (find-package :cl)) - (type (type-of c))) - (format stream - (if (eq type 'deprecated-function-should-be-deleted) - "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete" - "~A: Using deprecated function ~S -- please update your code to use a newer API.~ -~@[~%The docstring for this function says:~%~A~%~]") - type name (when (symbolp name) (documentation name 'function)))))))) - - (defun notify-deprecated-function (status name) - (ecase status - ((nil) nil) - ((:style-warning) (style-warn 'deprecated-function-style-warning :name name)) - ((:warning) (warn 'deprecated-function-warning :name name)) - ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error :name name)))) - - (defun version-deprecation (version &key (style-warning nil) - (warning (next-version style-warning)) - (error (next-version warning)) - (delete (next-version error))) - "Given a VERSION string, and the starting versions for notifying the programmer of -various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION -that is the highest level that has a declared version older than the specified version. -Each start version for a level of deprecation can be specified by a keyword argument, or -if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation." - (cond - ((and delete (version<= delete version)) :delete) - ((and error (version<= error version)) :error) - ((and warning (version<= warning version)) :warning) - ((and style-warning (version<= style-warning version)) :style-warning))) - - (defmacro with-deprecation ((level) &body definitions) - "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the -DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function -when it is compiled or called. - -Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet), -:STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used), -:ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while -at that level). - -Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD -from instrumentation by enclosing it in a PROGN." - (let ((level (eval level))) - (check-type level (member nil :style-warning :warning :error :delete)) - (when (eq level :delete) - (error 'deprecated-function-should-be-deleted :name - (mapcar 'second - (remove-if-not #'(lambda (x) (member x '(defun defmethod))) - definitions :key 'first)))) - (labels ((instrument (name head body whole) - (if level - (let ((notifiedp - (intern (format nil "*~A-~A-~A-~A*" - :deprecated-function level name :notified-p)))) - (multiple-value-bind (remaining-forms declarations doc-string) - (parse-body body :documentation t :whole whole) - `(progn - (defparameter ,notifiedp nil) - ;; tell some implementations to use the compiler-macro - (declaim (inline ,name)) - (define-compiler-macro ,name (&whole form &rest args) - (declare (ignore args)) - (notify-deprecated-function ,level ',name) - form) - (,@head ,@(when doc-string (list doc-string)) ,@declarations - (unless ,notifiedp - (setf ,notifiedp t) - (notify-deprecated-function ,level ',name)) - ,@remaining-forms)))) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (compiler-macro-function ',name) nil)) - (declaim (notinline ,name)) - (,@head ,@body))))) - `(progn - ,@(loop :for form :in definitions :collect - (cond - ((and (consp form) (eq (car form) 'defun)) - (instrument (second form) (subseq form 0 3) (subseq form 3) form)) - ((and (consp form) (eq (car form) 'defmethod)) - (let ((body-start (if (listp (third form)) 3 4))) - (instrument (second form) - (subseq form 0 body-start) - (subseq form body-start) - form))) - (t - form)))))))) -;;;; --------------------------------------------------------------------------- -;;;; Access to the Operating System - -(uiop/package:define-package :uiop/os - (:use :uiop/common-lisp :uiop/package :uiop/utility) - (:export - #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features - #:os-cond - #:getenv #:getenvp ;; environment variables - #:implementation-identifier ;; implementation identifier - #:implementation-type #:*implementation-type* - #:operating-system #:architecture #:lisp-version-string - #:hostname #:getcwd #:chdir - ;; Windows shortcut support - #:read-null-terminated-string #:read-little-endian - #:parse-file-location-info #:parse-windows-shortcut)) -(in-package :uiop/os) - -;;; Features -(with-upgradability () - (defun featurep (x &optional (*features* *features*)) - "Checks whether a feature expression X is true with respect to the *FEATURES* set, -as per the CLHS standard for #+ and #-. Beware that just like the CLHS, -we assume symbols from the KEYWORD package are used, but that unless you're using #+/#- -your reader will not have magically used the KEYWORD package, so you need specify -keywords explicitly." - (cond - ((atom x) (and (member x *features*) t)) - ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) - ((eq :or (car x)) (some #'featurep (cdr x))) - ((eq :and (car x)) (every #'featurep (cdr x))) - (t (parameter-error "~S: malformed feature specification ~S" 'featurep x)))) - - ;; Starting with UIOP 3.1.5, these are runtime tests. - ;; You may bind *features* with a copy of what your target system offers to test its properties. - (defun os-macosx-p () - "Is the underlying operating system MacOS X?" - ;; OS-MACOSX is not mutually exclusive with OS-UNIX, - ;; in fact the former implies the latter. - (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos)))) - - (defun os-unix-p () - "Is the underlying operating system some Unix variant?" - (or (featurep '(:or :unix :cygwin :haiku)) (os-macosx-p))) - - (defun os-windows-p () - "Is the underlying operating system Microsoft Windows?" - (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32 :mingw64)))) - - (defun os-genera-p () - "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?" - (featurep :genera)) - - (defun os-oldmac-p () - "Is the underlying operating system an (emulated?) MacOS 9 or earlier?" - (featurep :mcl)) - - (defun os-haiku-p () - "Is the underlying operating system Haiku?" - (featurep :haiku)) - - (defun os-mezzano-p () - "Is the underlying operating system Mezzano?" - (featurep :mezzano)) - - (defun detect-os () - "Detects the current operating system. Only needs be run at compile-time, -except on ABCL where it might change between FASL compilation and runtime." - (loop :with o - :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p) - (:os-windows . os-windows-p) - (:os-genera . os-genera-p) (:os-oldmac . os-oldmac-p) - (:os-haiku . os-haiku-p) - (:os-mezzano . os-mezzano-p)) - :when (and (or (not o) (eq feature :os-macosx) (eq feature :os-haiku)) (funcall detect)) - :do (setf o feature) (pushnew feature *features*) - :else :do (setf *features* (remove feature *features*)) - :finally - (return (or o (error "Congratulations for trying ASDF on an operating system~%~ -that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it."))))) - - (defmacro os-cond (&rest clauses) - #+abcl `(cond ,@clauses) - #-abcl (loop :for (test . body) :in clauses :when (eval test) :return `(progn ,@body))) - - (detect-os)) - -;;;; Environment variables: getting them, and parsing them. -(with-upgradability () - (defun getenv (x) - "Query the environment, as in C getenv. -Beware: may return empty string if a variable is present but empty; -use getenvp to return NIL in such a case." - (declare (ignorable x)) - #+(or abcl clasp clisp ecl xcl) (ext:getenv x) - #+allegro (sys:getenv x) - #+clozure (ccl:getenv x) - #+cmucl (unix:unix-getenv x) - #+scl (cdr (assoc x ext:*environment-list* :test #'string=)) - #+cormanlisp - (let* ((buffer (ct:malloc 1)) - (cname (ct:lisp-string-to-c-string x)) - (needed-size (win:getenvironmentvariable cname buffer 0)) - (buffer1 (ct:malloc (1+ needed-size)))) - (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) - nil - (ct:c-string-to-lisp-string buffer1)) - (ct:free buffer) - (ct:free buffer1))) - #+gcl (system:getenv x) - #+(or genera mezzano) nil - #+lispworks (lispworks:environment-variable x) - #+mcl (ccl:with-cstrs ((name x)) - (let ((value (_getenv name))) - (unless (ccl:%null-ptr-p value) - (ccl:%get-cstring value)))) - #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) - #+sbcl (sb-ext:posix-getenv x) - #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl) - (not-implemented-error 'getenv)) - - (defsetf getenv (x) (val) - "Set an environment variable." - (declare (ignorable x val)) - #+allegro `(setf (sys:getenv ,x) ,val) - #+clasp `(ext:setenv ,x ,val) - #+clisp `(system::setenv ,x ,val) - #+clozure `(ccl:setenv ,x ,val) - #+cmucl `(unix:unix-setenv ,x ,val 1) - #+(or ecl clasp) `(ext:setenv ,x ,val) - #+lispworks `(setf (lispworks:environment-variable ,x) ,val) - #+mkcl `(mkcl:setenv ,x ,val) - #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) - #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl) - '(not-implemented-error '(setf 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)))) - - -;;;; implementation-identifier -;; -;; produce a string to identify current implementation. -;; Initially stolen from SLIME's SWANK, completely rewritten since. -;; We're back to runtime checking, for the sake of e.g. ABCL. - -(with-upgradability () - (defun first-feature (feature-sets) - "A helper for various feature detection functions" - (dolist (x feature-sets) - (multiple-value-bind (short long feature-expr) - (if (consp x) - (values (first x) (second x) (cons :or (rest x))) - (values x x x)) - (when (featurep feature-expr) - (return (values short long)))))) - - (defun implementation-type () - "The type of Lisp implementation used, as a short UIOP-standardized keyword" - (first-feature - '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) - (:cmu :cmucl :cmu) :clasp :ecl :gcl - (:lwpe :lispworks-personal-edition) (:lw :lispworks) - :mcl :mezzano :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) - - (defvar *implementation-type* (implementation-type) - "The type of Lisp implementation used, as a short UIOP-standardized keyword") - - (defun operating-system () - "The operating system of the current host" - (first-feature - '(:cygwin - (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! - (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd - (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd - (:solaris :solaris :sunos) - (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly) - :unix - :genera - :mezzano))) - - (defun architecture () - "The CPU architecture of the current host" - (first-feature - '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386)) - (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) - (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) - :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) - :mipsel :mipseb :mips :alpha - (:arm64 :arm64 :aarch64 :armv8l :armv8b :aarch64_be :|aarch64|) - (:arm :arm :arm-target) :vlm :imach - ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, - ;; we may have to segregate the code still by architecture. - (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) - - #+clozure - (defun ccl-fasl-version () - ;; the fasl version is target-dependent from CCL 1.8 on. - (or (let ((s 'ccl::target-fasl-version)) - (and (fboundp s) (funcall s))) - (and (boundp 'ccl::fasl-version) - (symbol-value 'ccl::fasl-version)) - (error "Can't determine fasl version."))) - - (defun lisp-version-string () - "return a string that identifies the current Lisp implementation version" - (let ((s (lisp-implementation-version))) - (car ; as opposed to OR, this idiom prevents some unreachable code warning - (list - #+allegro - (format nil "~A~@[~A~]~@[~A~]~@[~A~]" - excl::*common-lisp-version-number* - ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default) - (and (eq excl:*current-case-mode* :case-sensitive-lower) "M") - ;; Note if not using International ACL - ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm - (excl:ics-target-case (:-ics "8")) - (and (member :smp *features*) "S")) - #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) - #+clisp - (subseq s 0 (position #\space s)) ; strip build information (date, etc.) - #+clozure - (format nil "~d.~d-f~d" ; shorten for windows - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version* - (logand (ccl-fasl-version) #xFF)) - #+cmucl (substitute #\- #\/ s) - #+scl (format nil "~A~A" s - ;; ANSI upper case vs lower case. - (ecase ext:*case-mode* (:upper "") (:lower "l"))) - #+ecl (format nil "~A~@[-~A~]" s - (let ((vcs-id (ext:lisp-implementation-vcs-id))) - (unless (equal vcs-id "UNKNOWN") - (subseq vcs-id 0 (min (length vcs-id) 8))))) - #+gcl (subseq s (1+ (position #\space s))) - #+genera - (multiple-value-bind (major minor) (sct:get-system-version "System") - (format nil "~D.~D" major minor)) - #+mcl (subseq s 8) ; strip the leading "Version " - #+mezzano (format nil "~A-~D" - (subseq s 0 (position #\space s)) ; strip commit hash - sys.int::*llf-version*) - ;; seems like there should be a shorter way to do this, like ACALL. - #+mkcl (or - (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil))) - (when (and fname (fboundp fname)) - (funcall fname))) - s) - s)))) - - (defun implementation-identifier () - "Return a string that identifies the ABI of the current implementation, -suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc." - (substitute-if - #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) - (format nil "~(~a~@{~@[-~a~]~}~)" - (or (implementation-type) (lisp-implementation-type)) - (lisp-version-string) - (or (operating-system) (software-type)) - (or (architecture) (machine-type)))))) - - -;;;; Other system information - -(with-upgradability () - (defun hostname () - "return the hostname of the current host" - #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mezzano mkcl sbcl scl xcl) (machine-instance) - #+cormanlisp "localhost" ;; is there a better way? Does it matter? - #+allegro (symbol-call :excl.osi :gethostname) - #+clisp (first (split-string (machine-instance) :separator " ")) - #+gcl (system:gethostname))) - - -;;; Current directory -(with-upgradability () - - #+cmucl - (defun parse-unix-namestring* (unix-namestring) - "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object" - (multiple-value-bind (host device directory name type version) - (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring)) - (make-pathname :host (or host lisp::*unix-host*) :device device - :directory directory :name name :type type :version version))) - - (defun getcwd () - "Get the current working directory as per POSIX getcwd(3), as a pathname object" - (or #+(or abcl genera mezzano xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical! - #+allegro (excl::current-directory) - #+clisp (ext:default-directory) - #+clozure (ccl:current-directory) - #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring - (strcat (nth-value 1 (unix:unix-current-directory)) "/")) - #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? - #+(or clasp ecl) (ext:getcwd) - #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p"")) - #+lispworks (hcl:get-working-directory) - #+mkcl (mk-ext:getcwd) - #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) - #+xcl (extensions:current-directory) - (not-implemented-error 'getcwd))) - - (defun chdir (x) - "Change current directory, as per POSIX chdir(2), to a given pathname object" - (if-let (x (pathname x)) - #+(or abcl genera mezzano xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical! - #+allegro (excl:chdir x) - #+clisp (ext:cd x) - #+clozure (setf (ccl:current-directory) x) - #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x)) - #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) - (error "Could not set current directory to ~A" x)) - #+ecl (ext:chdir x) - #+clasp (ext:chdir x t) - #+gcl (system:chdir x) - #+lispworks (hcl:change-directory x) - #+mkcl (mk-ext:chdir x) - #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) - #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) - (not-implemented-error 'chdir)))) - - -;;;; ----------------------------------------------------------------- -;;;; Windows shortcut support. Based on: -;;;; -;;;; Jesse Hager: The Windows Shortcut File Format. -;;;; http://www.wotsit.org/list.asp?fc=13 - -#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it -(with-upgradability () - (defparameter *link-initial-dword* 76) - (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) - - (defun read-null-terminated-string (s) - "Read a null-terminated string from an octet stream S" - ;; note: doesn't play well with UNICODE - (with-output-to-string (out) - (loop :for code = (read-byte s) - :until (zerop code) - :do (write-char (code-char code) out)))) - - (defun read-little-endian (s &optional (bytes 4)) - "Read a number in little-endian format from an byte (octet) stream S, -the number having BYTES octets (defaulting to 4)." - (loop :for i :from 0 :below bytes - :sum (ash (read-byte s) (* 8 i)))) - - (defun parse-file-location-info (s) - "helper to parse-windows-shortcut" - (let ((start (file-position s)) - (total-length (read-little-endian s)) - (end-of-header (read-little-endian s)) - (fli-flags (read-little-endian s)) - (local-volume-offset (read-little-endian s)) - (local-offset (read-little-endian s)) - (network-volume-offset (read-little-endian s)) - (remaining-offset (read-little-endian s))) - (declare (ignore total-length end-of-header local-volume-offset)) - (unless (zerop fli-flags) - (cond - ((logbitp 0 fli-flags) - (file-position s (+ start local-offset))) - ((logbitp 1 fli-flags) - (file-position s (+ start - network-volume-offset - #x14)))) - (strcat (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) - - (defun parse-windows-shortcut (pathname) - "From a .lnk windows shortcut, extract the pathname linked to" - ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE. - (with-open-file (s pathname :element-type '(unsigned-byte 8)) - (handler-case - (when (and (= (read-little-endian s) *link-initial-dword*) - (let ((header (make-array (length *link-guid*)))) - (read-sequence header s) - (equalp header *link-guid*))) - (let ((flags (read-little-endian s))) - (file-position s 76) ;skip rest of header - (when (logbitp 0 flags) - ;; skip shell item id list - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (cond - ((logbitp 1 flags) - (parse-file-location-info s)) - (t - (when (logbitp 2 flags) - ;; skip description string - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (when (logbitp 3 flags) - ;; finally, our pathname - (let* ((length (read-little-endian s 2)) - (buffer (make-array length))) - (read-sequence buffer s) - (map 'string #'code-char buffer))))))) - (end-of-file (c) - (declare (ignore c)) - nil))))) - - -;;;; ------------------------------------------------------------------------- -;;;; Portability layer around Common Lisp pathnames -;; This layer allows for portable manipulation of pathname objects themselves, -;; which all is necessary prior to any access the filesystem or environment. - -(uiop/package:define-package :uiop/pathname - (:nicknames :asdf/pathname) ;; deprecated. Used by ceramic - (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) - (:export - ;; Making and merging pathnames, portably - #:normalize-pathname-directory-component #:denormalize-pathname-directory-component - #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname* - #:make-pathname-component-logical #:make-pathname-logical - #:merge-pathnames* - #:nil-pathname #:*nil-pathname* #:with-pathname-defaults - ;; Predicates - #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname - #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p - ;; Directories - #:pathname-directory-pathname #:pathname-parent-directory-pathname - #:directory-pathname-p #:ensure-directory-pathname - ;; Parsing filenames - #:split-name-type #:parse-unix-namestring #:unix-namestring - #:split-unix-namestring-directory-components - ;; Absolute and relative pathnames - #:subpathname #:subpathname* - #:ensure-absolute-pathname - #:pathname-root #:pathname-host-pathname - #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname - ;; Checking constraints - #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints - ;; Wildcard pathnames - #:*wild* #:*wild-file* #:*wild-file-for-directory* #:*wild-directory* - #:*wild-inferiors* #:*wild-path* #:wilden - ;; Translate a pathname - #:relativize-directory-component #:relativize-pathname-directory - #:directory-separator-for-host #:directorize-pathname-host-device - #:translate-pathname* - #:*output-translation-function*)) -(in-package :uiop/pathname) - -;;; Normalizing pathnames across implementations - -(with-upgradability () - (defun normalize-pathname-directory-component (directory) - "Convert the DIRECTORY component from a format usable by the underlying -implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format -that is a list and not a string." - (cond - #-(or cmucl sbcl scl) ;; these implementations already normalize directory components. - ((stringp directory) `(:absolute ,directory)) - ((or (null directory) - (and (consp directory) (member (first directory) '(:absolute :relative)))) - directory) - #+gcl - ((consp directory) - (cons :relative directory)) - (t - (parameter-error (compatfmt "~@<~S: Unrecognized pathname directory component ~S~@:>") - 'normalize-pathname-directory-component directory)))) - - (defun denormalize-pathname-directory-component (directory-component) - "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable -by the underlying implementation's MAKE-PATHNAME and other primitives" - directory-component) - - (defun merge-pathname-directory-components (specified defaults) - "Helper for MERGE-PATHNAMES* that handles directory components" - (let ((directory (normalize-pathname-directory-component specified))) - (ecase (first directory) - ((nil) defaults) - (:absolute specified) - (:relative - (let ((defdir (normalize-pathname-directory-component defaults)) - (reldir (cdr directory))) - (cond - ((null defdir) - directory) - ((not (eq :back (first reldir))) - (append defdir reldir)) - (t - (loop :with defabs = (first defdir) - :with defrev = (reverse (rest defdir)) - :while (and (eq :back (car reldir)) - (or (and (eq :absolute defabs) (null defrev)) - (stringp (car defrev)))) - :do (pop reldir) (pop defrev) - :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) - - ;; Giving :unspecific as :type argument to make-pathname is not portable. - ;; See CLHS make-pathname and 19.2.2.2.3. - ;; This will be :unspecific if supported, or NIL if not. - (defparameter *unspecific-pathname-type* - #+(or abcl allegro clozure cmucl lispworks sbcl scl) :unspecific - #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil - "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") - - (defun make-pathname* (&rest keys &key directory host device name type version defaults - #+scl &allow-other-keys) - "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and - tries hard to make a pathname that will actually behave as documented, - despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME." - (declare (ignore host device directory name type version defaults)) - (apply 'make-pathname keys)) - - (defun make-pathname-component-logical (x) - "Make a pathname component suitable for use in a logical-pathname" - (typecase x - ((eql :unspecific) nil) - #+clisp (string (string-upcase x)) - #+clisp (cons (mapcar 'make-pathname-component-logical x)) - (t x))) - - (defun make-pathname-logical (pathname host) - "Take a PATHNAME's directory, name, type and version components, -and make a new pathname with corresponding components and specified logical HOST" - (make-pathname - :host host - :directory (make-pathname-component-logical (pathname-directory pathname)) - :name (make-pathname-component-logical (pathname-name pathname)) - :type (make-pathname-component-logical (pathname-type pathname)) - :version (make-pathname-component-logical (pathname-version pathname)))) - - (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) - "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that -if the SPECIFIED pathname does not have an absolute directory, -then the HOST and DEVICE both come from the DEFAULTS, whereas -if the SPECIFIED pathname does have an absolute directory, -then the HOST and DEVICE both come from the SPECIFIED pathname. -This is what users want on a modern Unix or Windows operating system, -unlike the MERGE-PATHNAMES behavior. -Also, if either argument is NIL, then the other argument is returned unmodified; -this is unlike MERGE-PATHNAMES which always merges with a pathname, -by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." - (when (null specified) (return-from merge-pathnames* defaults)) - (when (null defaults) (return-from merge-pathnames* specified)) - #+scl - (ext:resolve-pathname specified defaults) - #-scl - (let* ((specified (pathname specified)) - (defaults (pathname defaults)) - (directory (normalize-pathname-directory-component (pathname-directory specified))) - (name (or (pathname-name specified) (pathname-name defaults))) - (type (or (pathname-type specified) (pathname-type defaults))) - (version (or (pathname-version specified) (pathname-version defaults)))) - (labels ((unspecific-handler (p) - (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) - (multiple-value-bind (host device directory unspecific-handler) - (ecase (first directory) - ((:absolute) - (values (pathname-host specified) - (pathname-device specified) - directory - (unspecific-handler specified))) - ((nil :relative) - (values (pathname-host defaults) - (pathname-device defaults) - (merge-pathname-directory-components directory (pathname-directory defaults)) - (unspecific-handler defaults)))) - (make-pathname :host host :device device :directory directory - :name (funcall unspecific-handler name) - :type (funcall unspecific-handler type) - :version (funcall unspecific-handler version)))))) - - (defun logical-pathname-p (x) - "is X a logical-pathname?" - (typep x 'logical-pathname)) - - (defun physical-pathname-p (x) - "is X a pathname that is not a logical-pathname?" - (and (pathnamep x) (not (logical-pathname-p x)))) - - (defun physicalize-pathname (x) - "if X is a logical pathname, use translate-logical-pathname on it." - ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP - (let ((p (when x (pathname x)))) - (if (logical-pathname-p p) (translate-logical-pathname p) p))) - - (defun nil-pathname (&optional (defaults *default-pathname-defaults*)) - "A pathname that is as neutral as possible for use as defaults -when merging, making or parsing pathnames" - ;; 19.2.2.2.1 says a NIL host can mean a default host; - ;; see also "valid physical pathname host" in the CLHS glossary, that suggests - ;; strings and lists of strings or :unspecific - ;; But CMUCL decides to die on NIL. - ;; MCL has issues with make-pathname, nil and defaulting - (declare (ignorable defaults)) - #.`(make-pathname :directory nil :name nil :type nil :version nil - :device (or #+(and mkcl os-unix) :unspecific) - :host (or #+cmucl lisp::*unix-host* #+(and mkcl os-unix) "localhost") - #+scl ,@'(:scheme nil :scheme-specific-part nil - :username nil :password nil :parameters nil :query nil :fragment nil) - ;; the default shouldn't matter, but we really want something physical - #-mcl ,@'(:defaults defaults))) - - (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname))) - "A pathname that is as neutral as possible for use as defaults -when merging, making or parsing pathnames") - - (defmacro with-pathname-defaults ((&optional defaults) &body body) - "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified, -where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except -on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory." - `(let ((*default-pathname-defaults* - ,(or defaults - #-(or abcl genera xcl) '*nil-pathname* - #+(or abcl genera xcl) '*default-pathname-defaults*))) - ,@body))) - - -;;; Some pathname predicates -(with-upgradability () - (defun pathname-equal (p1 p2) - "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?" - (when (stringp p1) (setf p1 (pathname p1))) - (when (stringp p2) (setf p2 (pathname p2))) - (flet ((normalize-component (x) - (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal) - x))) - (macrolet ((=? (&rest accessors) - (flet ((frob (x) - (reduce 'list (cons 'normalize-component accessors) - :initial-value x :from-end t))) - `(equal ,(frob 'p1) ,(frob 'p2))))) - (or (and (null p1) (null p2)) - (and (pathnamep p1) (pathnamep p2) - (and (=? pathname-host) - #-(and mkcl os-unix) (=? pathname-device) - (=? normalize-pathname-directory-component pathname-directory) - (=? pathname-name) - (=? pathname-type) - #-mkcl (=? pathname-version))))))) - - (defun absolute-pathname-p (pathspec) - "If PATHSPEC is a pathname or namestring object that parses as a pathname -possessing an :ABSOLUTE directory component, return the (parsed) pathname. -Otherwise return NIL" - (and pathspec - (typep pathspec '(or null pathname string)) - (let ((pathname (pathname pathspec))) - (and (eq :absolute (car (normalize-pathname-directory-component - (pathname-directory pathname)))) - pathname)))) - - (defun relative-pathname-p (pathspec) - "If PATHSPEC is a pathname or namestring object that parses as a pathname -possessing a :RELATIVE or NIL directory component, return the (parsed) pathname. -Otherwise return NIL" - (and pathspec - (typep pathspec '(or null pathname string)) - (let* ((pathname (pathname pathspec)) - (directory (normalize-pathname-directory-component - (pathname-directory pathname)))) - (when (or (null directory) (eq :relative (car directory))) - pathname)))) - - (defun hidden-pathname-p (pathname) - "Return a boolean that is true if the pathname is hidden as per Unix style, -i.e. its name starts with a dot." - (and pathname (equal (first-char (pathname-name pathname)) #\.))) - - (defun file-pathname-p (pathname) - "Does PATHNAME represent a file, i.e. has a non-null NAME component? - -Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME. - -Note that this does _not_ check to see that PATHNAME points to an -actually-existing file. - -Returns the (parsed) PATHNAME when true" - (when pathname - (let ((pathname (pathname pathname))) - (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal) - (member (pathname-type pathname) '(nil :unspecific "") :test 'equal)) - pathname))))) - - -;;; Directory pathnames -(with-upgradability () - (defun pathname-directory-pathname (pathname) - "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, -and NIL NAME, TYPE and VERSION components" - (when pathname - (make-pathname :name nil :type nil :version nil :defaults pathname))) - - (defun pathname-parent-directory-pathname (pathname) - "Returns a new pathname that corresponds to the parent of the current pathname's directory, -i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is -Unix pathname /foo/bar/baz/file.type then return /foo/bar/" - (when pathname - (make-pathname :name nil :type nil :version nil - :directory (merge-pathname-directory-components - '(:relative :back) (pathname-directory pathname)) - :defaults pathname))) - - (defun directory-pathname-p (pathname) - "Does PATHNAME represent a directory? - -A directory-pathname is a pathname _without_ a filename. The three -ways that the filename components can be missing are for it to be NIL, -:UNSPECIFIC or the empty string. - -Note that this does _not_ check to see that PATHNAME points to an -actually-existing directory." - (when pathname - ;; I tried using Allegro's excl:file-directory-p, but this cannot be done, - ;; because it rejects apparently legal pathnames as - ;; ill-formed. [2014/02/10:rpg] - (let ((pathname (pathname pathname))) - (flet ((check-one (x) - (member x '(nil :unspecific) :test 'equal))) - (and (not (wild-pathname-p pathname)) - (check-one (pathname-name pathname)) - (check-one (pathname-type pathname)) - t))))) - - (defun ensure-directory-pathname (pathspec &optional (on-error 'error)) - "Converts the non-wild pathname designator PATHSPEC to directory form." - (cond - ((stringp pathspec) - (ensure-directory-pathname (pathname pathspec))) - ((not (pathnamep pathspec)) - (call-function on-error (compatfmt "~@") pathspec)) - ((wild-pathname-p pathspec) - (call-function on-error (compatfmt "~@") pathspec)) - ((directory-pathname-p pathspec) - pathspec) - (t - (handler-case - (make-pathname :directory (append (or (normalize-pathname-directory-component - (pathname-directory pathspec)) - (list :relative)) - (list #-genera (file-namestring pathspec) - ;; On Genera's native filesystem (LMFS), - ;; directories have a type and version - ;; which must be ignored when converting - ;; to a directory pathname - #+genera (if (typep pathspec 'fs:lmfs-pathname) - (pathname-name pathspec) - (file-namestring pathspec)))) - :name nil :type nil :version nil :defaults pathspec) - (error (c) (call-function on-error (compatfmt "~@") pathspec c))))))) - - -;;; Parsing filenames -(with-upgradability () - (declaim (ftype function ensure-pathname)) ; forward reference - - (defun split-unix-namestring-directory-components - (unix-namestring &key ensure-directory dot-dot) - "Splits the path string UNIX-NAMESTRING, returning four values: -A flag that is either :absolute or :relative, indicating - how the rest of the values are to be interpreted. -A directory path --- a list of strings and keywords, suitable for - use with MAKE-PATHNAME when prepended with the flag value. - Directory components with an empty name or the name . are removed. - Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP). -A last-component, either a file-namestring including type extension, - or NIL in the case of a directory pathname. -A flag that is true iff the unix-style-pathname was just - a file-namestring without / path specification. -ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname: -the third return value will be NIL, and final component of the namestring -will be treated as part of the directory path. - -An empty string is thus read as meaning a pathname object with all fields nil. - -Note that colon characters #\: will NOT be interpreted as host specification. -Absolute pathnames are only appropriate on Unix-style systems. - -The intention of this function is to support structured component names, -e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." - (check-type unix-namestring string) - (check-type dot-dot (member nil :back :up)) - (if (and (not (find #\/ unix-namestring)) (not ensure-directory) - (plusp (length unix-namestring))) - (values :relative () unix-namestring t) - (let* ((components (split-string unix-namestring :separator "/")) - (last-comp (car (last components)))) - (multiple-value-bind (relative components) - (if (equal (first components) "") - (if (equal (first-char unix-namestring) #\/) - (values :absolute (cdr components)) - (values :relative nil)) - (values :relative components)) - (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) - components)) - (setf components (substitute (or dot-dot :back) ".." components :test #'equal)) - (cond - ((equal last-comp "") - (values relative components nil nil)) ; "" already removed from components - (ensure-directory - (values relative components nil nil)) - (t - (values relative (butlast components) last-comp nil))))))) - - (defun split-name-type (filename) - "Split a filename into two values NAME and TYPE that are returned. -We assume filename has no directory component. -The last . if any separates name and type from from type, -except that if there is only one . and it is in first position, -the whole filename is the NAME with an empty type. -NAME is always a string. -For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned." - (check-type filename string) - (assert (plusp (length filename))) - (destructuring-bind (name &optional (type *unspecific-pathname-type*)) - (split-string filename :max 2 :separator ".") - (if (equal name "") - (values filename *unspecific-pathname-type*) - (values name type)))) - - (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory - &allow-other-keys) - "Coerce NAME into a PATHNAME using standard Unix syntax. - -Unix syntax is used whether or not the underlying system is Unix; -on such non-Unix systems it is reliably usable only for relative pathnames. -This function is especially useful to manipulate relative pathnames portably, -where it is crucial to possess a portable pathname syntax independent of the underlying OS. -This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF. - -When given a PATHNAME object, just return it untouched. -When given NIL, just return NIL. -When given a non-null SYMBOL, first downcase its name and treat it as a string. -When given a STRING, portably decompose it into a pathname as below. - -#\\/ separates directory components. - -The last #\\/-separated substring is interpreted as follows: -1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true, - the string is made the last directory component, and NAME and TYPE are NIL. - if the string is empty, it's the empty pathname with all slots NIL. -2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE - are separated by SPLIT-NAME-TYPE. -3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME. - -Directory components with an empty name or the name \".\" are removed. -Any directory named \"..\" is read as DOT-DOT, -which must be one of :BACK or :UP and defaults to :BACK. - -HOST, DEVICE and VERSION components are taken from DEFAULTS, -which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL. -No host or device can be specified in the string itself, -which makes it unsuitable for absolute pathnames outside Unix. - -For relative pathnames, these components (and hence the defaults) won't matter -if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES, -which is an important reason to always use MERGE-PATHNAMES*. - -Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME -with those keys, removing TYPE DEFAULTS and DOT-DOT. -When you're manipulating pathnames that are supposed to make sense portably -even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T -to throw an error if the pathname is absolute" - (block nil - (check-type type (or null string (eql :directory))) - (when ensure-directory - (setf type :directory)) - (etypecase name - ((or null pathname) (return name)) - (symbol - (setf name (string-downcase name))) - (string)) - (multiple-value-bind (relative path filename file-only) - (split-unix-namestring-directory-components - name :dot-dot dot-dot :ensure-directory (eq type :directory)) - (multiple-value-bind (name type) - (cond - ((or (eq type :directory) (null filename)) - (values nil nil)) - (type - (values filename type)) - (t - (split-name-type filename))) - (let* ((directory - (unless file-only (cons relative path))) - (pathname - #-abcl - (make-pathname - :directory directory - :name name :type type - :defaults (or #-mcl defaults *nil-pathname*)) - #+abcl - (if (and defaults - (ext:pathname-jar-p defaults) - (null directory)) - ;; When DEFAULTS is a jar, it will have the directory we want - (make-pathname :name name :type type - :defaults (or defaults *nil-pathname*)) - (make-pathname :name name :type type - :defaults (or defaults *nil-pathname*) - :directory directory)))) - (apply 'ensure-pathname - pathname - (remove-plist-keys '(:type :dot-dot :defaults) keys))))))) - - (defun unix-namestring (pathname) - "Given a non-wild PATHNAME, return a Unix-style namestring for it. -If the PATHNAME is NIL or a STRING, return it unchanged. - -This only considers the DIRECTORY, NAME and TYPE components of the pathname. -This is a portable solution for representing relative pathnames, -But unless you are running on a Unix system, it is not a general solution -to representing native pathnames. - -An error is signaled if the argument is not NULL, a STRING or a PATHNAME, -or if it is a PATHNAME but some of its components are not recognized." - (etypecase pathname - ((or null string) pathname) - (pathname - (with-output-to-string (s) - (flet ((err () (parameter-error "~S: invalid unix-namestring ~S" - 'unix-namestring pathname))) - (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) - (name (pathname-name pathname)) - (name (and (not (eq name :unspecific)) name)) - (type (pathname-type pathname)) - (type (and (not (eq type :unspecific)) type))) - (cond - ((member dir '(nil :unspecific))) - ((eq dir '(:relative)) (princ "./" s)) - ((consp dir) - (destructuring-bind (relabs &rest dirs) dir - (or (member relabs '(:relative :absolute)) (err)) - (when (eq relabs :absolute) (princ #\/ s)) - (loop :for x :in dirs :do - (cond - ((member x '(:back :up)) (princ "../" s)) - ((equal x "") (err)) - ;;((member x '("." "..") :test 'equal) (err)) - ((stringp x) (format s "~A/" x)) - (t (err)))))) - (t (err))) - (cond - (name - (unless (and (stringp name) (or (null type) (stringp type))) (err)) - (format s "~A~@[.~A~]" name type)) - (t - (or (null type) (err))))))))))) - -;;; Absolute and relative pathnames -(with-upgradability () - (defun subpathname (pathname subpath &key type) - "This function takes a PATHNAME and a SUBPATH and a TYPE. -If SUBPATH is already a PATHNAME object (not namestring), -and is an absolute pathname at that, it is returned unchanged; -otherwise, SUBPATH is turned into a relative pathname with given TYPE -as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE, -then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." - (or (and (pathnamep subpath) (absolute-pathname-p subpath)) - (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t) - (pathname-directory-pathname pathname)))) - - (defun subpathname* (pathname subpath &key type) - "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME." - (and pathname - (subpathname (ensure-directory-pathname pathname) subpath :type type))) - - (defun pathname-root (pathname) - "return the root directory for the host and device of given PATHNAME" - (make-pathname :directory '(:absolute) - :name nil :type nil :version nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) - - (defun pathname-host-pathname (pathname) - "return a pathname with the same host as given PATHNAME, and all other fields NIL" - (make-pathname :directory nil - :name nil :type nil :version nil :device nil - :defaults pathname ;; host device, and on scl, *some* - ;; scheme-specific parts: port username password, not others: - . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) - - (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) - "Given a pathname designator PATH, return an absolute pathname as specified by PATH -considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior, -with a format control-string and other arguments as arguments" - (cond - ((absolute-pathname-p path)) - ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error)) - ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) - ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults)))) - (or (if (absolute-pathname-p default-pathname) - (absolute-pathname-p (merge-pathnames* path default-pathname)) - (call-function on-error "Default pathname ~S is not an absolute pathname" - default-pathname)) - (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" - path default-pathname)))) - (t (call-function on-error - "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" - path defaults)))) - - (defun subpathp (maybe-subpath base-pathname) - "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that -when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." - (and (pathnamep maybe-subpath) (pathnamep base-pathname) - (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) - (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) - (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname)) - (with-pathname-defaults (*nil-pathname*) - (let ((enough (enough-namestring maybe-subpath base-pathname))) - (and (relative-pathname-p enough) (pathname enough)))))) - - (defun enough-pathname (maybe-subpath base-pathname) - "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that -when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." - (let ((sub (when maybe-subpath (pathname maybe-subpath))) - (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) - (or (and base (subpathp sub base)) sub))) - - (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) - "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null, -or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH -given DEFAULTS-PATHNAME as a base pathname." - (let ((enough (enough-pathname maybe-subpath defaults-pathname)) - (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*))) - (funcall thunk enough))) - - (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var) - (defaults *default-pathname-defaults*)) - &body body) - "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME" - `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body)))) - - -;;; Wildcard pathnames -(with-upgradability () - (defparameter *wild* (or #+cormanlisp "*" :wild) - "Wild component for use with MAKE-PATHNAME") - (defparameter *wild-directory-component* (or :wild) - "Wild directory component for use with MAKE-PATHNAME") - (defparameter *wild-inferiors-component* (or :wild-inferiors) - "Wild-inferiors directory component for use with MAKE-PATHNAME") - (defparameter *wild-file* - (make-pathname :directory nil :name *wild* :type *wild* - :version (or #-(or allegro abcl xcl) *wild*)) - "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME") - (defparameter *wild-file-for-directory* - (make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl) *wild*) - :version (or #-(or allegro abcl clisp gcl xcl) *wild*)) - "A pathname object with wildcards for matching any file with DIRECTORY") - (defparameter *wild-directory* - (make-pathname :directory `(:relative ,*wild-directory-component*) - :name nil :type nil :version nil) - "A pathname object with wildcards for matching any subdirectory") - (defparameter *wild-inferiors* - (make-pathname :directory `(:relative ,*wild-inferiors-component*) - :name nil :type nil :version nil) - "A pathname object with wildcards for matching any recursive subdirectory") - (defparameter *wild-path* - (merge-pathnames* *wild-file* *wild-inferiors*) - "A pathname object with wildcards for matching any file in any recursive subdirectory") - - (defun wilden (path) - "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory" - (merge-pathnames* *wild-path* path))) - - -;;; Translate a pathname -(with-upgradability () - (defun relativize-directory-component (directory-component) - "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component" - (let ((directory (normalize-pathname-directory-component directory-component))) - (cond - ((stringp directory) - (list :relative directory)) - ((eq (car directory) :absolute) - (cons :relative (cdr directory))) - (t - directory)))) - - (defun relativize-pathname-directory (pathspec) - "Given a PATHNAME, return a relative pathname with otherwise the same components" - (let ((p (pathname pathspec))) - (make-pathname - :directory (relativize-directory-component (pathname-directory p)) - :defaults p))) - - (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) - "Given a PATHNAME, return the character used to delimit directory names on this host and device." - (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) - (last-char (namestring foo)))) - - #-scl - (defun directorize-pathname-host-device (pathname) - "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components -added to its DIRECTORY component. This is useful for output translations." - (os-cond - ((os-unix-p) - (when (physical-pathname-p pathname) - (return-from directorize-pathname-host-device pathname)))) - (let* ((root (pathname-root pathname)) - (wild-root (wilden root)) - (absolute-pathname (merge-pathnames* pathname root)) - (separator (directory-separator-for-host root)) - (root-namestring (namestring root)) - (root-string - (substitute-if #\/ - #'(lambda (x) (or (eql x #\:) - (eql x separator))) - root-namestring))) - (multiple-value-bind (relative path filename) - (split-unix-namestring-directory-components root-string :ensure-directory t) - (declare (ignore relative filename)) - (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path)))) - (translate-pathname absolute-pathname wild-root (wilden new-base)))))) - - #+scl - (defun directorize-pathname-host-device (pathname) - (let ((scheme (ext:pathname-scheme pathname)) - (host (pathname-host pathname)) - (port (ext:pathname-port pathname)) - (directory (pathname-directory pathname))) - (flet ((specificp (x) (and x (not (eq x :unspecific))))) - (if (or (specificp port) - (and (specificp host) (plusp (length host))) - (specificp scheme)) - (let ((prefix "")) - (when (specificp port) - (setf prefix (format nil ":~D" port))) - (when (and (specificp host) (plusp (length host))) - (setf prefix (strcat host prefix))) - (setf prefix (strcat ":" prefix)) - (when (specificp scheme) - (setf prefix (strcat scheme prefix))) - (assert (and directory (eq (first directory) :absolute))) - (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) - pathname))) - - (defun translate-pathname* (path absolute-source destination &optional root source) - "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility. -PATH is the pathname to be translated. -ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname, -DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE, -or a relative pathname, to be merged with ROOT and used as destination for translate-pathname -or an absolute pathname, to be used as destination for translate-pathname. -In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE." - (declare (ignore source)) - (cond - ((functionp destination) - (funcall destination path absolute-source)) - ((eq destination t) - path) - ((not (pathnamep destination)) - (parameter-error "~S: Invalid destination" 'translate-pathname*)) - ((not (absolute-pathname-p destination)) - (translate-pathname path absolute-source (merge-pathnames* destination root))) - (root - (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) - (t - (translate-pathname path absolute-source destination)))) - - (defvar *output-translation-function* 'identity - "Hook for output translations. - -This function needs to be idempotent, so that actions can work -whether their inputs were translated or not, -which they will be if we are composing operations. e.g. if some -create-lisp-op creates a lisp file from some higher-level input, -you need to still be able to use compile-op on that lisp file.")) -;;;; ------------------------------------------------------------------------- -;;;; Portability layer around Common Lisp filesystem access - -(uiop/package:define-package :uiop/filesystem - (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname) - (:export - ;; Native namestrings - #:native-namestring #:parse-native-namestring - ;; Probing the filesystem - #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p - #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories - #:collect-sub*directories - ;; Resolving symlinks somewhat - #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks* - ;; merging with cwd - #:get-pathname-defaults #:call-with-current-directory #:with-current-directory - ;; Environment pathnames - #:inter-directory-separator #:split-native-pathnames-string - #:getenv-pathname #:getenv-pathnames - #:getenv-absolute-directory #:getenv-absolute-directories - #:lisp-implementation-directory #:lisp-implementation-pathname-p - ;; Simple filesystem operations - #:ensure-all-directories-exist - #:rename-file-overwriting-target - #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree)) -(in-package :uiop/filesystem) - -;;; Native namestrings, as seen by the operating system calls rather than Lisp -(with-upgradability () - (defun native-namestring (x) - "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system" - (when x - (let ((p (pathname x))) - #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978 - #+(or cmucl scl) (ext:unix-namestring p nil) - #+sbcl (sb-ext:native-namestring p) - #-(or clozure cmucl sbcl scl) - (os-cond - ((os-unix-p) (unix-namestring p)) - (t (namestring p)))))) - - (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys) - "From a native namestring suitable for use by the operating system, return -a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" - (check-type string (or string null)) - (let* ((pathname - (when string - (with-pathname-defaults () - #+clozure (ccl:native-to-pathname string) - #+cmucl (uiop/os::parse-unix-namestring* string) - #+sbcl (sb-ext:parse-native-namestring string) - #+scl (lisp::parse-unix-namestring string) - #-(or clozure cmucl sbcl scl) - (os-cond - ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory)) - (t (parse-namestring string)))))) - (pathname - (if ensure-directory - (and pathname (ensure-directory-pathname pathname)) - pathname))) - (apply 'ensure-pathname pathname constraints)))) - - -;;; Probing the filesystem -(with-upgradability () - (defun truename* (p) - "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories" - (when p - (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p)))) - (values - (or (ignore-errors (truename p)) - ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying - ;; a trailing directory separator, causes an error on some lisps. - #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d))) - ;; On Genera, truename of a directory pathname will probably fail as Genera - ;; will merge in a filename/type/version from *default-pathname-defaults* and - ;; will try to get the truename of a file that probably doesn't exist. - #+genera (when (directory-pathname-p p) - (let ((d (scl:send p :directory-pathname-as-file))) - (ensure-directory-pathname (ignore-errors (truename d)) nil))))))) - - (defun safe-file-write-date (pathname) - "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error." - ;; If FILE-WRITE-DATE returns NIL, it's possible that - ;; the user or some other agent has deleted an input file. - ;; Also, generated files will not exist at the time planning is done - ;; and calls compute-action-stamp which calls safe-file-write-date. - ;; So it is very possible that we can't get a valid file-write-date, - ;; and we can survive and we will continue the planning - ;; as if the file were very old. - ;; (or should we treat the case in a different, special way?) - (and pathname - (handler-case (file-write-date (physicalize-pathname pathname)) - (file-error () nil)))) - - (defun probe-file* (p &key truename) - "when given a pathname P (designated by a string as per PARSE-NAMESTRING), -probes the filesystem for a file or directory with given pathname. -If it exists, return its truename if TRUENAME is true, -or the original (parsed) pathname if it is false (the default)." - (values - (ignore-errors - (setf p (funcall 'ensure-pathname p - :namestring :lisp - :ensure-physical t - :ensure-absolute t :defaults 'get-pathname-defaults - :want-non-wild t - :on-error nil)) - (when p - #+allegro - (probe-file p :follow-symlinks truename) - #+gcl - (if truename - (truename* p) - (let ((kind (car (si::stat p)))) - (when (eq kind :link) - (setf kind (ignore-errors (car (si::stat (truename* p)))))) - (ecase kind - ((nil) nil) - ((:file :link) - (cond - ((file-pathname-p p) p) - ((directory-pathname-p p) - (subpathname p (car (last (pathname-directory p))))))) - (:directory (ensure-directory-pathname p))))) - #+clisp - #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) - (pp (find-symbol* '#:probe-pathname :ext nil))) - `(if truename - ,(if pp - `(values (,pp p)) - '(or (truename* p) - (truename* (ignore-errors (ensure-directory-pathname p))))) - ,(cond - (fs `(and (,fs p) p)) - (pp `(nth-value 1 (,pp p))) - (t '(or (and (truename* p) p) - (if-let (d (ensure-directory-pathname p)) - (and (truename* d) d))))))) - #-(or allegro clisp gcl) - (if truename - (probe-file p) - (and - #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p)) - #+(and lispworks os-unix) (system:get-file-stat p) - #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p)) - #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-date p) - p)))))) - - (defun directory-exists-p (x) - "Is X the name of a directory that exists on the filesystem?" - #+allegro - (excl:probe-directory x) - #+clisp - (handler-case (ext:probe-directory x) - (sys::simple-file-error () - nil)) - #-(or allegro clisp) - (let ((p (probe-file* x :truename t))) - (and (directory-pathname-p p) p))) - - (defun file-exists-p (x) - "Is X the name of a file that exists on the filesystem?" - (let ((p (probe-file* x :truename t))) - (and (file-pathname-p p) p))) - - (defun directory* (pathname-spec &rest keys &key &allow-other-keys) - "Return a list of the entries in a directory by calling DIRECTORY. -Try to override the defaults to not resolving symlinks, if implementation allows." - (apply 'directory pathname-spec - (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) - #+(or clozure digitool) '(:follow-links nil) - #+clisp '(:circle t :if-does-not-exist :ignore) - #+(or cmucl scl) '(:follow-links nil :truenamep nil) - #+lispworks '(:link-transparency nil) - #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) - '(:resolve-symlinks nil)))))) - - (defun filter-logical-directory-results (directory entries merger) - "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is, -given ENTRIES in the DIRECTORY, remove the entries which are physical yet -when transformed by MERGER have a different TRUENAME. -Also remove duplicates as may appear with some translation rules. -This function is used as a helper to DIRECTORY-FILES to avoid invalid entries -when using logical-pathnames." - (if (logical-pathname-p directory) - (remove-duplicates ;; on CLISP, querying ~/ will return duplicates - ;; Try hard to not resolve logical-pathname into physical pathnames; - ;; otherwise logical-pathname users/lovers will be disappointed. - ;; If directory* could use some implementation-dependent magic, - ;; we will have logical pathnames already; otherwise, - ;; we only keep pathnames for which specifying the name and - ;; translating the LPN commute. - (loop :for f :in entries - :for p = (or (and (logical-pathname-p f) f) - (let* ((u (ignore-errors (call-function merger f)))) - ;; The first u avoids a cumbersome (truename u) error. - ;; At this point f should already be a truename, - ;; but isn't quite in CLISP, for it doesn't have :version :newest - (and u (equal (truename* u) (truename* f)) u))) - :when p :collect p) - :test 'pathname-equal) - entries)) - - (defun directory-files (directory &optional (pattern *wild-file-for-directory*)) - "Return a list of the files in a directory according to the PATTERN. -Subdirectories should NOT be returned. - PATTERN defaults to a pattern carefully chosen based on the implementation; -override the default at your own risk. - DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this, -but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations." - (let ((dir (ensure-directory-pathname directory))) - (when (logical-pathname-p dir) - ;; Because of the filtering we do below, - ;; logical pathnames have restrictions on wild patterns. - ;; Not that the results are very portable when you use these patterns on physical pathnames. - (when (wild-pathname-p dir) - (parameter-error "~S: Invalid wild pattern in logical directory ~S" - 'directory-files directory)) - (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) - (parameter-error "~S: Invalid file pattern ~S for logical directory ~S" 'directory-files pattern directory)) - (setf pattern (make-pathname-logical pattern (pathname-host dir)))) - (let* ((pat (merge-pathnames* pattern dir)) - (entries (ignore-errors (directory* pat)))) - (remove-if 'directory-pathname-p - (filter-logical-directory-results - directory entries - #'(lambda (f) - (make-pathname :defaults dir - :name (make-pathname-component-logical (pathname-name f)) - :type (make-pathname-component-logical (pathname-type f)) - :version (make-pathname-component-logical (pathname-version f))))))))) - - (defun subdirectories (directory) - "Given a DIRECTORY pathname designator, return a list of the subdirectories under it. -The behavior in presence of symlinks is not portable. Use IOlib to handle such situations." - (let* ((directory (ensure-directory-pathname directory)) - #-(or abcl cormanlisp genera xcl) - (wild (merge-pathnames* - #-(or abcl allegro cmucl lispworks sbcl scl xcl) - *wild-directory* - #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*" - directory)) - (dirs - #-(or abcl cormanlisp genera xcl) - (ignore-errors - (directory* wild . #.(or #+clozure '(:directories t :files nil) - #+mcl '(:directories t)))) - #+(or abcl xcl) (system:list-directory directory) - #+cormanlisp (cl::directory-subdirs directory) - #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil))) - #+(or abcl allegro cmucl genera lispworks sbcl scl xcl) - (dirs (loop :for x :in dirs - :for d = #+(or abcl xcl) (extensions:probe-directory x) - #+allegro (excl:probe-directory x) - #+(or cmucl sbcl scl) (directory-pathname-p x) - #+genera (getf (cdr x) :directory) - #+lispworks (lw:file-directory-p x) - :when d :collect #+(or abcl allegro xcl) (ensure-directory-pathname d) - #+genera (ensure-directory-pathname (first x)) - #+(or cmucl lispworks sbcl scl) x))) - (filter-logical-directory-results - directory dirs - (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) - '(:absolute)))) ; because allegro returns NIL for #p"FOO:" - #'(lambda (d) - (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) - (and (consp dir) (consp (cdr dir)) - (make-pathname - :defaults directory :name nil :type nil :version nil - :directory (append prefix (make-pathname-component-logical (last dir))))))))))) - - (defun collect-sub*directories (directory collectp recursep collector) - "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory, -call-function the COLLECTOR function designator on the directory, -and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them. -This function will thus let you traverse a filesystem hierarchy, -superseding the functionality of CL-FAD:WALK-DIRECTORY. -The behavior in presence of symlinks is not portable. Use IOlib to handle such situations." - (when (call-function collectp directory) - (call-function collector directory) - (dolist (subdir (subdirectories directory)) - (when (call-function recursep subdir) - (collect-sub*directories subdir collectp recursep collector)))))) - -;;; Resolving symlinks somewhat -(with-upgradability () - (defun truenamize (pathname) - "Resolve as much of a pathname as possible" - (block nil - (when (typep pathname '(or null logical-pathname)) (return pathname)) - (let ((p pathname)) - (unless (absolute-pathname-p p) - (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil)) - (return p)))) - (when (logical-pathname-p p) (return p)) - (let ((found (probe-file* p :truename t))) - (when found (return found))) - (let* ((directory (normalize-pathname-directory-component (pathname-directory p))) - (up-components (reverse (rest directory))) - (down-components ())) - (assert (eq :absolute (first directory))) - (loop :while up-components :do - (if-let (parent - (ignore-errors - (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components)) - :name nil :type nil :version nil :defaults p)))) - (if-let (simplified - (ignore-errors - (merge-pathnames* - (make-pathname :directory `(:relative ,@down-components) - :defaults p) - (ensure-directory-pathname parent)))) - (return simplified))) - (push (pop up-components) down-components) - :finally (return p)))))) - - (defun resolve-symlinks (path) - "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH." - #-allegro (truenamize path) - #+allegro - (if (physical-pathname-p path) - (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path) - path)) - - (defvar *resolve-symlinks* t - "Determine whether or not ASDF resolves symlinks when defining systems. -Defaults to T.") - - (defun resolve-symlinks* (path) - "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)." - (if *resolve-symlinks* - (and path (resolve-symlinks path)) - path))) - - -;;; Check pathname constraints -(with-upgradability () - (defun ensure-pathname - (pathname &key - on-error - defaults type dot-dot namestring - empty-is-nil - want-pathname - want-logical want-physical ensure-physical - want-relative want-absolute ensure-absolute ensure-subpath - want-non-wild want-wild wilden - want-file want-directory ensure-directory - want-existing ensure-directories-exist - truename resolve-symlinks truenamize - &aux (p pathname)) ;; mutable working copy, preserve original - "Coerces its argument into a PATHNAME, -optionally doing some transformations and checking specified constraints. - -If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified. - -If the argument is a STRING, it is first converted to a pathname via -PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively -depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively, -or else by using CALL-FUNCTION on the NAMESTRING argument; -if :UNIX is specified (or NIL, the default, which specifies the same thing), -then PARSE-UNIX-NAMESTRING it is called with the keywords -DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and -the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true. - -The pathname passed or resulting from parsing the string -is then subjected to all the checks and transformations below are run. - -Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE. -The boolean T is an alias for ERROR. -ERROR means that an error will be raised if the constraint is not satisfied. -CERROR means that an continuable error will be raised if the constraint is not satisfied. -IGNORE means just return NIL instead of the pathname. - -The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION) -that will be called with the the following arguments: -a generic format string for ensure pathname, the pathname, -the keyword argument corresponding to the failed check or transformation, -a format string for the reason ENSURE-PATHNAME failed, -and a list with arguments to that format string. -If ON-ERROR is NIL, ERROR is used instead, which does the right thing. -You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\"). - -The transformations and constraint checks are done in this order, -which is also the order in the lambda-list: - -EMPTY-IS-NIL returns NIL if the argument is an empty string. -WANT-PATHNAME checks that pathname (after parsing if needed) is not null. -Otherwise, if the pathname is NIL, ensure-pathname returns NIL. -WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME -WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME -ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME -WANT-RELATIVE checks that pathname has a relative directory component -WANT-ABSOLUTE checks that pathname does have an absolute directory component -ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again -that the result absolute is an absolute pathname indeed. -ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS. -WANT-FILE checks that pathname has a non-nil FILE component -WANT-DIRECTORY checks that pathname has nil FILE and TYPE components -ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret -any file and type components as being actually a last directory component. -WANT-NON-WILD checks that pathname is not a wild pathname -WANT-WILD checks that pathname is a wild pathname -WILDEN merges the pathname with **/*.*.* if it is not wild -WANT-EXISTING checks that a file (or directory) exists with that pathname. -ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST. -TRUENAME replaces the pathname by its truename, or errors if not possible. -RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS. -TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." - (block nil - (flet ((report-error (keyword description &rest arguments) - (call-function (or on-error 'error) - "Invalid pathname ~S: ~*~?" - pathname keyword description arguments))) - (macrolet ((err (constraint &rest arguments) - `(report-error ',(intern* constraint :keyword) ,@arguments)) - (check (constraint condition &rest arguments) - `(when ,constraint - (unless ,condition (err ,constraint ,@arguments)))) - (transform (transform condition expr) - `(when ,transform - (,@(if condition `(when ,condition) '(progn)) - (setf p ,expr))))) - (etypecase p - ((or null pathname)) - (string - (when (and (emptyp p) empty-is-nil) - (return-from ensure-pathname nil)) - (setf p (case namestring - ((:unix nil) - (parse-unix-namestring - p :defaults defaults :type type :dot-dot dot-dot - :ensure-directory ensure-directory :want-relative want-relative)) - ((:native) - (parse-native-namestring p)) - ((:lisp) - (parse-namestring p)) - (t - (call-function namestring p)))))) - (etypecase p - (pathname) - (null - (check want-pathname (pathnamep p) "Expected a pathname, not NIL") - (return nil))) - (check want-logical (logical-pathname-p p) "Expected a logical pathname") - (check want-physical (physical-pathname-p p) "Expected a physical pathname") - (transform ensure-physical () (physicalize-pathname p)) - (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname") - (check want-relative (relative-pathname-p p) "Expected a relative pathname") - (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname") - (transform ensure-absolute (not (absolute-pathname-p p)) - (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?"))) - (check ensure-absolute (absolute-pathname-p p) - "Could not make into an absolute pathname even after merging with ~S" defaults) - (check ensure-subpath (absolute-pathname-p defaults) - "cannot be checked to be a subpath of non-absolute pathname ~S" defaults) - (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults) - (check want-file (file-pathname-p p) "Expected a file pathname") - (check want-directory (directory-pathname-p p) "Expected a directory pathname") - (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p)) - (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname") - (check want-wild (wild-pathname-p p) "Expected a wildcard pathname") - (transform wilden (not (wild-pathname-p p)) (wilden p)) - (when want-existing - (let ((existing (probe-file* p :truename truename))) - (if existing - (when truename - (return existing)) - (err want-existing "Expected an existing pathname")))) - (when ensure-directories-exist (ensure-directories-exist p)) - (when truename - (let ((truename (truename* p))) - (if truename - (return truename) - (err truename "Can't get a truename for pathname")))) - (transform resolve-symlinks () (resolve-symlinks p)) - (transform truenamize () (truenamize p)) - p))))) - - -;;; Pathname defaults -(with-upgradability () - (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*)) - "Find the actual DEFAULTS to use for pathnames, including -resolving them with respect to GETCWD if the DEFAULTS were relative" - (or (absolute-pathname-p defaults) - (merge-pathnames* defaults (getcwd)))) - - (defun call-with-current-directory (dir thunk) - "call the THUNK in a context where the current directory was changed to DIR, if not NIL. -Note that this operation is usually NOT thread-safe." - (if dir - (let* ((dir (resolve-symlinks* - (get-pathname-defaults - (ensure-directory-pathname - dir)))) - (cwd (getcwd)) - (*default-pathname-defaults* dir)) - (chdir dir) - (unwind-protect - (funcall thunk) - (chdir cwd))) - (funcall thunk))) - - (defmacro with-current-directory ((&optional dir) &body body) - "Call BODY while the POSIX current working directory is set to DIR" - `(call-with-current-directory ,dir #'(lambda () ,@body)))) - - -;;; Environment pathnames -(with-upgradability () - (defun inter-directory-separator () - "What character does the current OS conventionally uses to separate directories?" - (os-cond ((os-unix-p) #\:) (t #\;))) - - (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys) - "Given a string of pathnames specified in native OS syntax, separate them in a list, -check constraints and normalize each one as per ENSURE-PATHNAME, -where an empty string denotes NIL." - (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) - :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints)))) - - (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys) - "Extract a pathname from a user-configured environment variable, as per native OS, -check constraints and normalize as per ENSURE-PATHNAME." - ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory - (apply 'parse-native-namestring (getenvp x) - :ensure-directory (or ensure-directory want-directory) - :on-error (or on-error - `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) - constraints)) - (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys) - "Extract a list of pathname from a user-configured environment variable, as per native OS, -check constraints and normalize each one as per ENSURE-PATHNAME. - Any empty entries in the environment variable X will be returned as NILs." - (unless (getf constraints :empty-is-nil t) - (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-pathnames)) - (apply 'split-native-pathnames-string (getenvp x) - :on-error (or on-error - `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) - :empty-is-nil t - constraints)) - (defun getenv-absolute-directory (x) - "Extract an absolute directory pathname from a user-configured environment variable, -as per native OS" - (getenv-pathname x :want-absolute t :ensure-directory t)) - (defun getenv-absolute-directories (x) - "Extract a list of absolute directories from a user-configured environment variable, -as per native OS. Any empty entries in the environment variable X will be returned as -NILs." - (getenv-pathnames x :want-absolute t :ensure-directory t)) - - (defun lisp-implementation-directory (&key truename) - "Where are the system files of the current installation of the CL implementation?" - (declare (ignorable truename)) - (let ((dir - #+abcl extensions:*lisp-home* - #+(or allegro clasp ecl mkcl) #p"SYS:" - #+clisp custom:*lib-directory* - #+clozure #p"ccl:" - #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:"))) - #+gcl system::*system-directory* - #+lispworks lispworks:*lispworks-directory* - #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) - (funcall it) - (getenv-pathname "SBCL_HOME" :ensure-directory t)) - #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/"))) - #+xcl ext:*xcl-home*)) - (if (and dir truename) - (truename* dir) - dir))) - - (defun lisp-implementation-pathname-p (pathname) - "Is the PATHNAME under the current installation of the CL implementation?" - ;; Other builtin systems are those under the implementation directory - (and (when pathname - (if-let (impdir (lisp-implementation-directory)) - (or (subpathp pathname impdir) - (when *resolve-symlinks* - (if-let (truename (truename* pathname)) - (if-let (trueimpdir (truename* impdir)) - (subpathp truename trueimpdir))))))) - t))) - - -;;; Simple filesystem operations -(with-upgradability () - (defun ensure-all-directories-exist (pathnames) - "Ensure that for every pathname in PATHNAMES, we ensure its directories exist" - (dolist (pathname pathnames) - (when pathname - (ensure-directories-exist (physicalize-pathname pathname))))) - - (defun delete-file-if-exists (x) - "Delete a file X if it already exists" - (when x (handler-case (delete-file x) (file-error () nil)))) - - (defun rename-file-overwriting-target (source target) - "Rename a file, overwriting any previous file with the TARGET name, -in an atomic way if the implementation allows." - (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t)) - (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t))) - #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic - (progn (funcall 'require "syscalls") - (symbol-call :posix :copy-file source target :method :rename)) - #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic - #-clisp - (rename-file source target - #+(or clasp clozure ecl) :if-exists - #+clozure :rename-and-delete #+(or clasp ecl) t))) - - (defun delete-empty-directory (directory-pathname) - "Delete an empty directory" - #+(or abcl digitool gcl) (delete-file directory-pathname) - #+allegro (excl:delete-directory directory-pathname) - #+clisp (ext:delete-directory directory-pathname) - #+clozure (ccl::delete-empty-directory directory-pathname) - #+(or cmucl scl) (multiple-value-bind (ok errno) - (unix:unix-rmdir (native-namestring directory-pathname)) - (unless ok - #+cmucl (error "Error number ~A when trying to delete directory ~A" - errno directory-pathname) - #+scl (error "~@" - directory-pathname (unix:get-unix-error-msg errno)))) - #+cormanlisp (win32:delete-directory directory-pathname) - #+(or clasp ecl) (si:rmdir directory-pathname) - #+genera (fs:delete-directory directory-pathname) - #+lispworks (lw:delete-directory directory-pathname) - #+mkcl (mkcl:rmdir directory-pathname) - #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) - `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later - `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) - #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) - #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) - (not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera - - (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) - "Delete a directory including all its recursive contents, aka rm -rf. - -To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be -a physical non-wildcard directory pathname (not namestring). - -If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens: -if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done. - -Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass -the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument -which in practice is thus compulsory, and validates by returning a non-NIL result. -If you're suicidal or extremely confident, just use :VALIDATE T." - (check-type if-does-not-exist (member :error :ignore)) - (setf directory-pathname (ensure-pathname directory-pathname - :want-pathname t :want-non-wild t - :want-physical t :want-directory t)) - (cond - ((not validatep) - (parameter-error "~S was asked to delete ~S but was not provided a validation predicate" - 'delete-directory-tree directory-pathname)) - ((not (call-function validate directory-pathname)) - (parameter-error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]" - 'delete-directory-tree directory-pathname validate)) - ((not (directory-exists-p directory-pathname)) - (ecase if-does-not-exist - (:error - (error "~S was asked to delete ~S but the directory does not exist" - 'delete-directory-tree directory-pathname)) - (:ignore nil))) - #-(or allegro cmucl clozure genera sbcl scl) - ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, - ;; except on implementations where we can prevent DIRECTORY from following symlinks; - ;; instead spawn a standard external program to do the dirty work. - (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname)))) - (t - ;; On supported implementation, call supported system functions - #+allegro (symbol-call :excl.osi :delete-directory-and-files - directory-pathname :if-does-not-exist if-does-not-exist) - #+clozure (ccl:delete-directory directory-pathname) - #+genera (fs:delete-directory directory-pathname :confirm nil) - #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) - `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later - '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) - ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks, - ;; do things the hard way. - #-(or allegro clozure genera sbcl) - (let ((sub*directories - (while-collecting (c) - (collect-sub*directories directory-pathname t t #'c)))) - (dolist (d (nreverse sub*directories)) - (map () 'delete-file (directory-files d)) - (delete-empty-directory d))))))) -;;;; --------------------------------------------------------------------------- -;;;; Utilities related to streams - -(uiop/package:define-package :uiop/stream - (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem) - (:export - #:*default-stream-element-type* - #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr - #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding - #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format - #:*default-encoding* #:*utf-8-external-format* - #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string - #:with-output #:output-string #:with-input #:input-string - #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file - #:null-device-pathname #:call-with-null-input #:with-null-input - #:call-with-null-output #:with-null-output - #:finish-outputs #:format! #:safe-format! - #:copy-stream-to-stream #:concatenate-files #:copy-file - #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line - #:slurp-stream-forms #:slurp-stream-form - #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line - #:read-file-forms #:read-file-form #:safe-read-file-form - #:eval-input #:eval-thunk #:standard-eval-thunk - #:println #:writeln - #:file-stream-p #:file-or-synonym-stream-p - ;; Temporary files - #:*temporary-directory* #:temporary-directory #:default-temporary-directory - #:setup-temporary-directory - #:call-with-temporary-file #:with-temporary-file - #:add-pathname-suffix #:tmpize-pathname - #:call-with-staging-pathname #:with-staging-pathname)) -(in-package :uiop/stream) - -(with-upgradability () - (defvar *default-stream-element-type* - (or #+(or abcl cmucl cormanlisp scl xcl) 'character - #+lispworks 'lw:simple-char - :default) - "default element-type for open (depends on the current CL implementation)") - - (defvar *stdin* *standard-input* - "the original standard input stream at startup") - - (defun setup-stdin () - (setf *stdin* - #.(or #+clozure 'ccl::*stdin* - #+(or cmucl scl) 'system:*stdin* - #+(or clasp ecl) 'ext::+process-standard-input+ - #+sbcl 'sb-sys:*stdin* - '*standard-input*))) - - (defvar *stdout* *standard-output* - "the original standard output stream at startup") - - (defun setup-stdout () - (setf *stdout* - #.(or #+clozure 'ccl::*stdout* - #+(or cmucl scl) 'system:*stdout* - #+(or clasp ecl) 'ext::+process-standard-output+ - #+sbcl 'sb-sys:*stdout* - '*standard-output*))) - - (defvar *stderr* *error-output* - "the original error output stream at startup") - - (defun setup-stderr () - (setf *stderr* - #.(or #+allegro 'excl::*stderr* - #+clozure 'ccl::*stderr* - #+(or cmucl scl) 'system:*stderr* - #+(or clasp ecl) 'ext::+process-error-output+ - #+sbcl 'sb-sys:*stderr* - '*error-output*))) - - ;; Run them now. In image.lisp, we'll register them to be run at image restart. - (setup-stdin) (setup-stdout) (setup-stderr)) - - -;;; Encodings (mostly hooks only; full support requires asdf-encodings) -(with-upgradability () - (defparameter *default-encoding* - ;; preserve explicit user changes to something other than the legacy default :default - (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*))) - (unless (eq previous :default) previous)) - :utf-8) - "Default encoding for source files. -The default value :utf-8 is the portable thing. -The legacy behavior was :default. -If you (asdf:load-system :asdf-encodings) then -you will have autodetection via *encoding-detection-hook* below, -reading emacs-style -*- coding: utf-8 -*- specifications, -and falling back to utf-8 or latin1 if nothing is specified.") - - (defparameter *utf-8-external-format* - (if (featurep :asdf-unicode) - (or #+clisp charset:utf-8 :utf-8) - :default) - "Default :external-format argument to pass to CL:OPEN and also -CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. -On modern implementations, this will decode UTF-8 code points as CL characters. -On legacy implementations, it may fall back on some 8-bit encoding, -with non-ASCII code points being read as several CL characters; -hopefully, if done consistently, that won't affect program behavior too much.") - - (defun always-default-encoding (pathname) - "Trivial function to use as *encoding-detection-hook*, -always 'detects' the *default-encoding*" - (declare (ignore pathname)) - *default-encoding*) - - (defvar *encoding-detection-hook* #'always-default-encoding - "Hook for an extension to define a function to automatically detect a file's encoding") - - (defun detect-encoding (pathname) - "Detects the encoding of a specified file, going through user-configurable hooks" - (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname)) - (funcall *encoding-detection-hook* pathname) - *default-encoding*)) - - (defun default-encoding-external-format (encoding) - "Default, ignorant, function to transform a character ENCODING as a -portable keyword to an implementation-dependent EXTERNAL-FORMAT specification. -Load system ASDF-ENCODINGS to hook in a better one." - (case encoding - (:default :default) ;; for backward-compatibility only. Explicit usage discouraged. - (:utf-8 *utf-8-external-format*) - (otherwise - (cerror "Continue using :external-format :default" (compatfmt "~@") encoding) - :default))) - - (defvar *encoding-external-format-hook* - #'default-encoding-external-format - "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping -from non-default encodings to and implementation-defined external-format's") - - (defun encoding-external-format (encoding) - "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT, -going through all the proper hooks." - (funcall *encoding-external-format-hook* (or encoding *default-encoding*)))) - - -;;; Safe syntax -(with-upgradability () - (defvar *standard-readtable* (with-standard-io-syntax *readtable*) - "The standard readtable, implementing the syntax specified by the CLHS. -It must never be modified, though only good implementations will even enforce that.") - - (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)) - (*read-default-float-format* 'double-float) - (*print-readably* nil) - (*read-eval* nil)) - (funcall thunk)))) - - (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace) - "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX" - (with-safe-io-syntax (:package package) - (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace)))) - -;;; Output helpers - (with-upgradability () - (defun call-with-output-file (pathname thunk - &key - (element-type *default-stream-element-type*) - (external-format *utf-8-external-format*) - (if-exists :error) - (if-does-not-exist :create)) - "Open FILE for input with given recognizes options, call THUNK with the resulting stream. -Other keys are accepted but discarded." - (with-open-file (s pathname :direction :output - :element-type element-type - :external-format external-format - :if-exists if-exists - :if-does-not-exist if-does-not-exist) - (funcall thunk s))) - - (defmacro with-output-file ((var pathname &rest keys - &key element-type external-format if-exists if-does-not-exist) - &body body) - (declare (ignore element-type external-format if-exists if-does-not-exist)) - `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)) - - (defun call-with-output (output function &key (element-type 'character)) - "Calls FUNCTION with an actual stream argument, -behaving like FORMAT with respect to how stream designators are interpreted: -If OUTPUT is a STREAM, use it as the stream. -If OUTPUT is NIL, use a STRING-OUTPUT-STREAM of given ELEMENT-TYPE as the stream, and -return the resulting string. -If OUTPUT is T, use *STANDARD-OUTPUT* as the stream. -If OUTPUT is a STRING with a fill-pointer, use it as a STRING-OUTPUT-STREAM of given ELEMENT-TYPE. -If OUTPUT is a PATHNAME, open the file and write to it, passing ELEMENT-TYPE to WITH-OUTPUT-FILE --- this latter as an extension since ASDF 3.1. -\(Proper ELEMENT-TYPE treatment since ASDF 3.3.4 only.\) -Otherwise, signal an error." - (etypecase output - (null - (with-output-to-string (stream nil :element-type element-type) (funcall function stream))) - ((eql t) - (funcall function *standard-output*)) - (stream - (funcall function output)) - (string - (assert (fill-pointer output)) - (with-output-to-string (stream output :element-type element-type) (funcall function stream))) - (pathname - (call-with-output-file output function :element-type element-type))))) - -(with-upgradability () - (locally (declare #+sbcl (sb-ext:muffle-conditions style-warning)) - (handler-bind (#+sbcl (style-warning #'muffle-warning)) - (defmacro with-output ((output-var &optional (value output-var) &key element-type) &body body) - "Bind OUTPUT-VAR to an output stream obtained from VALUE (default: previous binding -of OUTPUT-VAR) treated as a stream designator per CALL-WITH-OUTPUT. Evaluate BODY in -the scope of this binding." - `(call-with-output ,value #'(lambda (,output-var) ,@body) - ,@(when element-type `(:element-type ,element-type))))))) - -(defun output-string (string &optional output) - "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string" - (if output - (with-output (output) (princ string output)) - string)) - - -;;; Input helpers -(with-upgradability () - (defun call-with-input-file (pathname thunk - &key - (element-type *default-stream-element-type*) - (external-format *utf-8-external-format*) - (if-does-not-exist :error)) - "Open FILE for input with given recognizes options, call THUNK with the resulting stream. -Other keys are accepted but discarded." - (with-open-file (s pathname :direction :input - :element-type element-type - :external-format external-format - :if-does-not-exist if-does-not-exist) - (funcall thunk s))) - - (defmacro with-input-file ((var pathname &rest keys - &key element-type external-format if-does-not-exist) - &body body) - (declare (ignore element-type external-format if-does-not-exist)) - `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)) - - (defun call-with-input (input function &key keys) - "Calls FUNCTION with an actual stream argument, interpreting -stream designators like READ, but also coercing strings to STRING-INPUT-STREAM, -and PATHNAME to FILE-STREAM. -If INPUT is a STREAM, use it as the stream. -If INPUT is NIL, use a *STANDARD-INPUT* as the stream. -If INPUT is T, use *TERMINAL-IO* as the stream. -If INPUT is a STRING, use it as a string-input-stream. -If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE --- the latter is an extension since ASDF 3.1. -Otherwise, signal an error." - (etypecase input - (null (funcall function *standard-input*)) - ((eql t) (funcall function *terminal-io*)) - (stream (funcall function input)) - (string (with-input-from-string (stream input) (funcall function stream))) - (pathname (apply 'call-with-input-file input function keys)))) - - (defmacro with-input ((input-var &optional (value input-var)) &body body) - "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR) -as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding." - `(call-with-input ,value #'(lambda (,input-var) ,@body))) - - (defun input-string (&optional input) - "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string -and return that" - (if (stringp input) - input - (with-input (input) (funcall 'slurp-stream-string input))))) - -;;; Null device -(with-upgradability () - (defun null-device-pathname () - "Pathname to a bit bucket device that discards any information written to it -and always returns EOF when read from" - (os-cond - ((os-unix-p) #p"/dev/null") - ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax? - (t (error "No /dev/null on your OS")))) - (defun call-with-null-input (fun &key element-type external-format if-does-not-exist) - "Call FUN with an input stream that always returns end of file. -The keyword arguments are allowed for backward compatibility, but are ignored." - (declare (ignore element-type external-format if-does-not-exist)) - (with-open-stream (input (make-concatenated-stream)) - (funcall fun input))) - (defmacro with-null-input ((var &rest keys - &key element-type external-format if-does-not-exist) - &body body) - (declare (ignore element-type external-format if-does-not-exist)) - "Evaluate BODY in a context when VAR is bound to an input stream that always returns end of file. -The keyword arguments are allowed for backward compatibility, but are ignored." - `(call-with-null-input #'(lambda (,var) ,@body) ,@keys)) - (defun call-with-null-output (fun - &key (element-type *default-stream-element-type*) - (external-format *utf-8-external-format*) - (if-exists :overwrite) - (if-does-not-exist :error)) - (declare (ignore element-type external-format if-exists if-does-not-exist)) - "Call FUN with an output stream that discards all output. -The keyword arguments are allowed for backward compatibility, but are ignored." - (with-open-stream (output (make-broadcast-stream)) - (funcall fun output))) - (defmacro with-null-output ((var &rest keys - &key element-type external-format if-does-not-exist if-exists) - &body body) - "Evaluate BODY in a context when VAR is bound to an output stream that discards all output. -The keyword arguments are allowed for backward compatibility, but are ignored." - (declare (ignore element-type external-format if-exists if-does-not-exist)) - `(call-with-null-output #'(lambda (,var) ,@body) ,@keys))) - -;;; Ensure output buffers are flushed -(with-upgradability () - (defun finish-outputs (&rest streams) - "Finish output on the main output streams as well as any specified one. -Useful for portably flushing I/O before user input or program exit." - ;; CCL notably buffers its stream output by default. - (dolist (s (append streams - (list *stdout* *stderr* *error-output* *standard-output* *trace-output* - *debug-io* *terminal-io* *query-io*))) - (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 stream) - (apply 'format stream format args) - (finish-outputs stream)) - - (defun safe-format! (stream format &rest args) - "Variant of FORMAT that is safe against both -dangerous syntax configuration and errors while printing." - (with-safe-io-syntax () - (ignore-errors (apply 'format! stream format args)) - (finish-outputs stream)))) ; just in case format failed - - -;;; Simple Whole-Stream processing -(with-upgradability () - (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix) - "Copy the contents of the INPUT stream into the OUTPUT stream. -If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX. -Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." - (with-open-stream (input input) - (if linewise - (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))) - (loop - :with buffer-size = (or buffer-size 8192) - :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) - :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) - "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files." - (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-file (input output) - "Copy contents of the INPUT file to the OUTPUT file" - ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f) - #+allegro - (excl.osi:copy-file input output) - #+ecl - (ext:copy-file input output) - #-(or allegro ecl) - (concatenate-files (list input) output)) - - (defun slurp-stream-string (input &key (element-type 'character) stripped) - "Read the contents of the INPUT stream as a string" - (let ((string - (with-open-stream (input input) - (with-output-to-string (output nil :element-type element-type) - (copy-stream-to-stream input output :element-type element-type))))) - (if stripped (stripln string) string))) - - (defun slurp-stream-lines (input &key count) - "Read the contents of the INPUT stream as a list of lines, return those lines. - -Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR -from the line-ending if the file or stream had CR+LF but Lisp only removed LF. - -Read no more than COUNT lines." - (check-type count (or null integer)) - (with-open-stream (input input) - (loop :for n :from 0 - :for l = (and (or (not count) (< n count)) - (read-line input nil nil)) - ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF - :while l :collect (stripln l)))) - - (defun slurp-stream-line (input &key (at 0)) - "Read the contents of the INPUT stream as a list of lines, -then return the ACCESS-AT of that list of lines using the AT specifier. -PATH defaults to 0, i.e. return the first line. -PATH is typically an integer, or a list of an integer and a function. -If PATH is NIL, it will return all the lines in the file. - -The stream will not be read beyond the Nth lines, -where N is the index specified by path -if path is either an integer or a list that starts with an integer." - (access-at (slurp-stream-lines input :count (access-at-count at)) at)) - - (defun slurp-stream-forms (input &key count) - "Read the contents of the INPUT stream as a list of forms, -and return those forms. - -If COUNT is null, read to the end of the stream; -if COUNT is an integer, stop after COUNT forms were read. - -BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" - (check-type count (or null integer)) - (loop :with eof = '#:eof - :for n :from 0 - :for form = (if (and count (>= n count)) - eof - (read-preserving-whitespace input nil eof)) - :until (eq form eof) :collect form)) - - (defun slurp-stream-form (input &key (at 0)) - "Read the contents of the INPUT stream as a list of forms, -then return the ACCESS-AT of these forms following the AT. -AT defaults to 0, i.e. return the first form. -AT is typically a list of integers. -If AT is NIL, it will return all the forms in the file. - -The stream will not be read beyond the Nth form, -where N is the index specified by path, -if path is either an integer or a list that starts with an integer. - -BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" - (access-at (slurp-stream-forms input :count (access-at-count at)) at)) - - (defun read-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 read-file-lines (file &rest keys) - "Open FILE with option KEYS, read its contents as a list of lines -BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" - (apply 'call-with-input-file file 'slurp-stream-lines keys)) - - (defun read-file-line (file &rest keys &key (at 0) &allow-other-keys) - "Open input FILE with option KEYS (except AT), -and read its contents as per SLURP-STREAM-LINE with given AT specifier. -BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" - (apply 'call-with-input-file file - #'(lambda (input) (slurp-stream-line input :at at)) - (remove-plist-key :at keys))) - - (defun read-file-forms (file &rest keys &key count &allow-other-keys) - "Open input FILE with option KEYS (except COUNT), -and read its contents as per SLURP-STREAM-FORMS with given COUNT. -If COUNT is null, read to the end of the stream; -if COUNT is an integer, stop after COUNT forms were read. -BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" - (apply 'call-with-input-file file - #'(lambda (input) (slurp-stream-forms input :count count)) - (remove-plist-key :count keys))) - - (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys) - "Open input FILE with option KEYS (except AT), -and read its contents as per SLURP-STREAM-FORM with given AT specifier. -BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" - (apply 'call-with-input-file file - #'(lambda (input) (slurp-stream-form input :at at)) - (remove-plist-key :at keys))) - - (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys) - "Reads the specified line from the top of a file using a safe standardized syntax. -Extracts the line using READ-FILE-LINE, -within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." - (with-safe-io-syntax (:package package) - (apply 'read-file-line pathname (remove-plist-key :package keys)))) - - (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys) - "Reads the specified form from the top of a file using a safe standardized syntax. -Extracts the form using READ-FILE-FORM, -within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." - (with-safe-io-syntax (:package package) - (apply 'read-file-form pathname (remove-plist-key :package keys)))) - - (defun eval-input (input) - "Portably read and evaluate forms from INPUT, return the last values." - (with-input (input) - (loop :with results :with eof ='#:eof - :for form = (read input nil eof) - :until (eq form eof) - :do (setf results (multiple-value-list (eval form))) - :finally (return (values-list results))))) - - (defun eval-thunk (thunk) - "Evaluate a THUNK of code: -If a function, FUNCALL it without arguments. -If a constant literal and not a sequence, return it. -If a cons or a symbol, EVAL it. -If a string, repeatedly read and evaluate from it, returning the last values." - (etypecase thunk - ((or boolean keyword number character pathname) thunk) - ((or cons symbol) (eval thunk)) - (function (funcall thunk)) - (string (eval-input thunk)))) - - (defun standard-eval-thunk (thunk &key (package :cl)) - "Like EVAL-THUNK, but in a more standardized evaluation context." - ;; Note: it's "standard-" not "safe-", because evaluation is never safe. - (when thunk - (with-safe-io-syntax (:package package) - (let ((*read-eval* t)) - (eval-thunk thunk)))))) - -(with-upgradability () - (defun println (x &optional (stream *standard-output*)) - "Variant of PRINC that also calls TERPRI afterwards" - (princ x stream) (terpri stream) (finish-output stream) (values)) - - (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys) - "Variant of WRITE that also calls TERPRI afterwards" - (apply 'write x keys) (terpri stream) (finish-output stream) (values))) - - -;;; Using temporary files -(with-upgradability () - (defun default-temporary-directory () - "Return a default directory to use for temporary files" - (os-cond - ((os-unix-p) - (or (getenv-pathname "TMPDIR" :ensure-directory t) - (parse-native-namestring "/tmp/"))) - ((os-windows-p) - (getenv-pathname "TEMP" :ensure-directory t)) - (t (subpathname (user-homedir-pathname) "tmp/")))) - - (defvar *temporary-directory* nil "User-configurable location for temporary files") - - (defun temporary-directory () - "Return a directory to use for temporary files" - (or *temporary-directory* (default-temporary-directory))) - - (defun setup-temporary-directory () - "Configure a default temporary directory to use." - (setf *temporary-directory* (default-temporary-directory)) - #+gcl (setf system::*tmp-dir* *temporary-directory*)) - - (defun call-with-temporary-file - (thunk &key - (want-stream-p t) (want-pathname-p t) (direction :io) keep after - directory (type "tmp" typep) prefix (suffix (when typep "-tmp")) - (element-type *default-stream-element-type*) - (external-format *utf-8-external-format*)) - "Call a THUNK with stream and/or pathname arguments identifying a temporary file. - -The temporary file's pathname will be based on concatenating -PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string, -and optional SUFFIX (defaults to \"-tmp\" if a type was provided) -and TYPE (defaults to \"tmp\", using a dot as separator if not NIL), -within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute. - -The file will be open with specified DIRECTION (defaults to :IO), -ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and -EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*). -If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed -with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T), -and stream will be closed after the THUNK exits (either normally or abnormally). -If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then -THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument. -Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument. -If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned. -Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true." - #+xcl (declare (ignorable typep)) - (check-type direction (member :output :io)) - (assert (or want-stream-p want-pathname-p)) - (loop - :with prefix-pn = (ensure-absolute-pathname - (or prefix "tmp") - (or (ensure-pathname - directory - :namestring :native - :ensure-directory t - :ensure-physical t) - #'temporary-directory)) - :with prefix-nns = (native-namestring prefix-pn) - :with results = (progn (ensure-directories-exist prefix-pn) - ()) - :for counter :from (random (expt 36 #-gcl 8 #+gcl 5)) - :for pathname = (parse-native-namestring - (format nil "~A~36R~@[~A~]~@[.~A~]" - prefix-nns counter suffix (unless (eq type :unspecific) type))) - :for okp = nil :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 -- - ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr. - ;; Can we at least design some hook? - (unwind-protect - (progn - (ensure-directories-exist pathname) - (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 - (setf okp pathname) - (when want-stream-p - ;; Note: can't return directly from within with-open-file - ;; or the non-local return causes the file creation to be undone. - (setf results (multiple-value-list - (if want-pathname-p - (call-function thunk stream pathname) - (call-function thunk stream))))))) - ;; if we don't want a stream, then we must call the thunk *after* - ;; the stream is closed, but only if it was successfully opened. - (when okp - (when (and want-pathname-p (not want-stream-p)) - (setf results (multiple-value-list (call-function thunk okp)))) - ;; if the stream was successfully opened, then return a value, - ;; either one computed already, or one from AFTER, if that exists. - (if after - (return (call-function after pathname)) - (return (values-list results))))) - (when (and okp (not (call-function keep))) - (ignore-errors (delete-file-if-exists okp)))))) - - (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) - (pathname (gensym "PATHNAME") pathnamep) - directory prefix suffix type - keep direction element-type external-format) - &body body) - "Evaluate BODY where the symbols specified by keyword arguments -STREAM and PATHNAME (if respectively specified) are bound corresponding -to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE. -At least one of STREAM or PATHNAME must be specified. -If the STREAM is not specified, it will be closed before the BODY is evaluated. -If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY, -separates forms run before and after the stream is closed. -The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned. -Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE." - (check-type stream symbol) - (check-type pathname symbol) - (assert (or streamp pathnamep)) - (let* ((afterp (position :close-stream body)) - (before (if afterp (subseq body 0 afterp) body)) - (after (when afterp (subseq body (1+ afterp)))) - (beforef (gensym "BEFORE")) - (afterf (gensym "AFTER"))) - (when (eql afterp 0) - (style-warn ":CLOSE-STREAM should not be the first form of BODY in WITH-TEMPORARY-FILE. Instead, do not provide a STREAM.")) - `(flet (,@(when before - `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) - ,@(when after `((declare (ignorable ,pathname)))) - ,@before))) - ,@(when after - (assert pathnamep) - `((,afterf (,pathname) ,@after)))) - #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf)))) - (call-with-temporary-file - ,(when before `#',beforef) - :want-stream-p ,streamp - :want-pathname-p ,pathnamep - ,@(when direction `(:direction ,direction)) - ,@(when directory `(:directory ,directory)) - ,@(when prefix `(:prefix ,prefix)) - ,@(when suffix `(:suffix ,suffix)) - ,@(when type `(:type ,type)) - ,@(when keep `(:keep ,keep)) - ,@(when after `(:after #',afterf)) - ,@(when element-type `(:element-type ,element-type)) - ,@(when external-format `(:external-format ,external-format)))))) - - (defun get-temporary-file (&key directory prefix suffix type (keep t)) - (with-temporary-file (:pathname pn :keep keep - :directory directory :prefix prefix :suffix suffix :type type) - pn)) - - ;; Temporary pathnames in simple cases where no contention is assumed - (defun add-pathname-suffix (pathname suffix &rest keys) - "Add a SUFFIX to the name of a PATHNAME, return a new pathname. -Further KEYS can be passed to MAKE-PATHNAME." - (apply 'make-pathname :name (strcat (pathname-name pathname) suffix) - :defaults pathname keys)) - - (defun tmpize-pathname (x) - "Return a new pathname modified from X by adding a trivial random suffix. -A new empty file with said temporary pathname is created, to ensure there is no -clash with any concurrent process attempting the same thing." - (let* ((px (ensure-pathname x :ensure-physical t)) - (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp")) - (directory (pathname-directory-pathname px))) - ;; Genera uses versioned pathnames -- If we leave the empty file in place, - ;; the system will create a new version of the file when the caller opens - ;; it for output. That empty file will remain after the operation is completed. - ;; As Genera is a single core processor, the possibility of a name conflict is - ;; minimal if not nil. (And, in the event of a collision, the two processes - ;; would be writing to different versions of the file.) - (get-temporary-file :directory directory :prefix prefix :type (pathname-type px) - #+genera :keep #+genera nil))) - - (defun call-with-staging-pathname (pathname fun) - "Calls FUN with a staging pathname, and atomically -renames the staging pathname to the PATHNAME in the end. -NB: this protects only against failure of the program, not against concurrent attempts. -For the latter case, we ought pick a random suffix and atomically open it." - (let* ((pathname (pathname pathname)) - (staging (tmpize-pathname pathname))) - (unwind-protect - (multiple-value-prog1 - (funcall fun staging) - (rename-file-overwriting-target staging pathname)) - (delete-file-if-exists staging)))) - - (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) - "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME" - `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))) - -(with-upgradability () - (defun file-stream-p (stream) - (typep stream 'file-stream)) - (defun file-or-synonym-stream-p (stream) - (or (file-stream-p stream) - (and (typep stream 'synonym-stream) - (file-or-synonym-stream-p - (symbol-value (synonym-stream-symbol stream))))))) -;;;; ------------------------------------------------------------------------- -;;;; Starting, Stopping, Dumping a Lisp image - -(uiop/package:define-package :uiop/image - (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) - (:export - #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* - #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0 - #:*lisp-interaction* - #:fatal-condition #:fatal-condition-p - #:handle-fatal-condition - #:call-with-fatal-condition-handler #:with-fatal-condition-handler - #:*image-restore-hook* #:*image-prelude* #:*image-entry-point* - #:*image-postlude* #:*image-dump-hook* - #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace - #:shell-boolean-exit - #:register-image-restore-hook #:register-image-dump-hook - #:call-image-restore-hook #:call-image-dump-hook - #:restore-image #:dump-image #:create-image -)) -(in-package :uiop/image) - -(with-upgradability () - (defvar *lisp-interaction* t - "Is this an interactive Lisp environment, or is it batch processing?") - - (defvar *command-line-arguments* nil - "Command-line arguments") - - (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments - "Is this a dumped image? As a standalone executable?") - - (defvar *image-restore-hook* nil - "Functions to call (in reverse order) when the image is restored") - - (defvar *image-restored-p* nil - "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping") - - (defvar *image-prelude* nil - "a form to evaluate, or string containing forms to read and evaluate -when the image is restarted, but before the entry point is called.") - - (defvar *image-entry-point* nil - "a function with which to restart the dumped image when execution is restored from it.") - - (defvar *image-postlude* nil - "a form to evaluate, or string containing forms to read and evaluate -before the image dump hooks are called and before the image is dumped.") - - (defvar *image-dump-hook* nil - "Functions to call (in order) when before an image is dumped")) - -(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) - (deftype fatal-condition () - `(and serious-condition #+clozure (not ccl:process-reset)))) - -;;; Exiting properly or im- -(with-upgradability () - (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." - (when finish-output ;; essential, for ClozureCL, and for standard compliance. - (finish-outputs)) - #+(or abcl xcl) (ext:quit :status code) - #+allegro (excl:exit code :quiet t) - #+(or clasp ecl) (si:quit code) - #+clisp (ext:quit code) - #+clozure (ccl:quit code) - #+cormanlisp (win32:exitprocess code) - #+(or cmucl scl) (unix:unix-exit code) - #+gcl (system:quit code) - #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code) - #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) - #+mcl (progn code (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 clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) - (not-implemented-error 'quit "(called with exit code ~S)" code)) - - (defun die (code format &rest arguments) - "Die in error with some error message" - (with-safe-io-syntax () - (ignore-errors - (format! *stderr* "~&~?~&" format arguments))) - (quit code)) - - (defun raw-print-backtrace (&key (stream *debug-io*) count condition) - "Print a backtrace, directly accessing the implementation" - (declare (ignorable stream count condition)) - #+abcl - (loop :for i :from 0 - :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do - (safe-format! stream "~&~D: ~A~%" i frame)) - #+allegro - (let ((*terminal-io* stream) - (*standard-output* stream) - (tpl:*zoom-print-circle* *print-circle*) - (tpl:*zoom-print-level* *print-level*) - (tpl:*zoom-print-length* *print-length*)) - (tpl:do-command "zoom" - :from-read-eval-print-loop nil - :count (or count t) - :all t)) - #+clasp - (clasp-debug:print-backtrace :stream stream :count count) - #+(or ecl mkcl) - (let* ((top (si:ihs-top)) - (repeats (if count (min top count) top)) - (backtrace (loop :for ihs :from 0 :below top - :collect (list (si::ihs-fun ihs) - (si::ihs-env ihs))))) - (loop :for i :from 0 :below repeats - :for frame :in (nreverse backtrace) :do - (safe-format! stream "~&~D: ~S~%" i frame))) - #+clisp - (system::print-backtrace :out stream :limit count) - #+(or clozure mcl) - (let ((*debug-io* stream)) - #+clozure (ccl:print-call-history :count count :start-frame-number 1) - #+mcl (ccl:print-call-history :detailed-p nil) - (finish-output stream)) - #+(or cmucl scl) - (let ((debug:*debug-print-level* *print-level*) - (debug:*debug-print-length* *print-length*)) - (debug:backtrace (or count most-positive-fixnum) stream)) - #+gcl - (let ((*debug-io* stream)) - (ignore-errors - (with-safe-io-syntax () - (if condition - (conditions::condition-backtrace condition) - (system::simple-backtrace))))) - #+lispworks - (let ((dbg::*debugger-stack* - (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) - (*debug-io* stream) - (dbg:*debug-print-level* *print-level*) - (dbg:*debug-print-length* *print-length*)) - (dbg:bug-backtrace nil)) - #+mezzano - (let ((*standard-output* stream)) - (sys.int::backtrace count)) - #+sbcl - (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum)) - #+xcl - (loop :for i :from 0 :below (or count most-positive-fixnum) - :for frame :in (extensions:backtrace-as-list) :do - (safe-format! stream "~&~D: ~S~%" i frame))) - - (defun print-backtrace (&rest keys &key stream count condition) - "Print a backtrace" - (declare (ignore stream count condition)) - (with-safe-io-syntax (:package :cl) - (let ((*print-readably* nil) - (*print-circle* t) - (*print-miser-width* 75) - (*print-length* nil) - (*print-level* nil) - (*print-pretty* t)) - (ignore-errors (apply 'raw-print-backtrace keys))))) - - (defun print-condition-backtrace (condition &key (stream *stderr*) count) - "Print a condition after a backtrace triggered by that condition" - ;; We print the condition *after* the backtrace, - ;; for the sake of who sees the backtrace at a terminal. - ;; It is up to the caller to print the condition *before*, with some context. - (print-backtrace :stream stream :count count :condition condition) - (when condition - (safe-format! stream "~&Above backtrace due to this condition:~%~A~&" - condition))) - - (defun fatal-condition-p (condition) - "Is the CONDITION fatal?" - (typep condition 'fatal-condition)) - - (defun handle-fatal-condition (condition) - "Handle a fatal CONDITION: -depending on whether *LISP-INTERACTION* is set, enter debugger or die" - (cond - (*lisp-interaction* - (invoke-debugger condition)) - (t - (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition) - (print-condition-backtrace condition :stream *stderr*) - (die 99 "~A" condition)))) - - (defun call-with-fatal-condition-handler (thunk) - "Call THUNK in a context where fatal conditions are appropriately handled" - (handler-bind ((fatal-condition #'handle-fatal-condition)) - (funcall thunk))) - - (defmacro with-fatal-condition-handler ((&optional) &body body) - "Execute BODY in a context where fatal conditions are appropriately handled" - `(call-with-fatal-condition-handler #'(lambda () ,@body))) - - (defun shell-boolean-exit (x) - "Quit with a return code that is 0 iff argument X is true" - (quit (if x 0 1)))) - - -;;; Using image hooks -(with-upgradability () - (defun register-image-restore-hook (hook &optional (call-now-p t)) - "Regiter a hook function to be run when restoring a dumped image" - (register-hook-function '*image-restore-hook* hook call-now-p)) - - (defun register-image-dump-hook (hook &optional (call-now-p nil)) - "Register a the hook function to be run before to dump an image" - (register-hook-function '*image-dump-hook* hook call-now-p)) - - (defun call-image-restore-hook () - "Call the hook functions registered to be run when restoring a dumped image" - (call-functions (reverse *image-restore-hook*))) - - (defun call-image-dump-hook () - "Call the hook functions registered to be run before to dump an image" - (call-functions *image-dump-hook*))) - - -;;; Proper command-line arguments -(with-upgradability () - (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 - #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) - #+clisp (coerce (ext:argv) 'list) - #+clozure ccl:*command-line-argument-list* - #+(or cmucl scl) extensions:*command-line-strings* - #+gcl si:*command-args* - #+(or genera mcl mezzano) nil - #+lispworks sys:*line-arguments-list* - #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i)) - #+sbcl sb-ext:*posix-argv* - #+xcl system:*argv* - #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl) - (not-implemented-error 'raw-command-line-arguments)) - - (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 a generated script that uses -- -if we are not called from a directly executable image." - (block nil - #+abcl (return arguments) - ;; SBCL and Allegro already separate user arguments from implementation arguments. - #-(or sbcl allegro) - (unless (eq *image-dumped-p* :executable) - ;; LispWorks command-line processing isn't transparent to the user - ;; unless you create a standalone executable; in that case, - ;; we rely on cl-launch or some other script to set the arguments for us. - #+lispworks (return *command-line-arguments*) - ;; On other implementations, on non-standalone executables, - ;; we trust cl-launch or whichever script starts the program - ;; to use -- as a delimiter between implementation arguments and user arguments. - #-lispworks (setf arguments (member "--" arguments :test 'string-equal))) - (rest arguments))) - - (defun argv0 () - "On supported implementations (most that matter), or when invoked by a proper wrapper script, -return a string that for the name with which the program was invoked, i.e. argv[0] in C. -Otherwise, return NIL." - (cond - ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 ! - ;; NB: not currently available on ABCL, Corman, Genera, MCL - (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl) - (first (raw-command-line-arguments)) - #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0))) - (t ;; argv[0] is the name of the interpreter. - ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8. - (getenvp "__CL_ARGV0")))) - - (defun setup-command-line-arguments () - (setf *command-line-arguments* (command-line-arguments))) - - (defun restore-image (&key - (lisp-interaction *lisp-interaction*) - (restore-hook *image-restore-hook*) - (prelude *image-prelude*) - (entry-point *image-entry-point*) - (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) - "From a freshly restarted Lisp image, restore the saved Lisp environment -by setting appropriate variables, running various hooks, and calling any specified entry point. - -If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*, -call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return -immediately to the surrounding restore process if allowed to continue. - -Then, comes the restore process itself: -First, call each function in the RESTORE-HOOK, -in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK. -Second, evaluate the prelude, which is often Lisp text that is read, -as per EVAL-INPUT. -Third, call the ENTRY-POINT function, if any is specified, with no argument. - -The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL, -any unhandled error leads to a backtrace and an exit with an error status. -If LISP-INTERACTION is NIL, the process also exits when no error occurs: -if neither restart nor entry function is provided, the program will exit with status 0 (success); -if a function was provided, the program will exit after the function returns (if it returns), -with status 0 if and only if the primary return value of result is generalized boolean true, -and with status 1 if this value is NIL. - -If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result -of the function will be returned rather than interpreted as a boolean designating an exit code." - (when *image-restored-p* - (if if-already-restored - (call-function if-already-restored "Image already ~:[being ~;~]restored" - (eq *image-restored-p* t)) - (return-from restore-image))) - (with-fatal-condition-handler () - (setf *lisp-interaction* lisp-interaction) - (setf *image-restore-hook* restore-hook) - (setf *image-prelude* prelude) - (setf *image-restored-p* :in-progress) - (call-image-restore-hook) - (standard-eval-thunk prelude) - (setf *image-restored-p* t) - (let ((results (multiple-value-list - (if entry-point - (call-function entry-point) - t)))) - (if lisp-interaction - (values-list results) - (shell-boolean-exit (first results))))))) - - -;;; Dumping an image - -(with-upgradability () - (defun dump-image (filename &key output-name executable - (postlude *image-postlude*) - (dump-hook *image-dump-hook*) - #+clozure prepend-symbols #+clozure (purify t) - #+sbcl compression - #+(and sbcl os-windows) application-type) - "Dump an image of the current Lisp environment at pathname FILENAME, with various options. - -First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of - the functions in DUMP-HOOK, in reverse order of registration by REGISTER-IMAGE-DUMP-HOOK. - -If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup. - -Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL, -or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." - ;; Note: at least SBCL saves only global values of variables in the heap image, - ;; so make sure things you want to dump are NOT just local bindings shadowing the global values. - (declare (ignorable filename output-name executable)) - (setf *image-dumped-p* (if executable :executable t)) - (setf *image-restored-p* :in-regress) - (setf *image-postlude* postlude) - (standard-eval-thunk *image-postlude*) - (setf *image-dump-hook* dump-hook) - (call-image-dump-hook) - (setf *image-restored-p* nil) - #-(or clisp clozure (and cmucl executable) lispworks sbcl scl) - (when executable - (not-implemented-error 'dump-image "dumping an executable")) - #+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 - ;; Faré explains the odd executable value (slightly paraphrased): - ;; 0 is very different from t in clisp and there for a good reason: - ;; 0 turns the executable into one that has its own command-line handling, so hackers can't - ;; use the underlying -i or -x to turn your would-be restricted binary into an unrestricted evaluator. - :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x - (when executable - (list - ;; :parse-options nil ;--- requires a non-standard patch to clisp. - :norc t :script nil :init-function #'restore-image))) - #+clozure - (flet ((dump (prepend-kernel) - (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify - :toplevel-function (when executable #'restore-image)))) - ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system)) - (if prepend-symbols - (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path) - (require 'elf) - (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) - (dump path)) - (dump t))) - #+(or cmucl scl) - (progn - (ext:gc :full t) - (setf ext:*batch-mode* nil) - (setf ext::*gc-run-time* 0) - (apply 'ext:save-lisp filename - :allow-other-keys t ;; hush SCL and old versions of CMUCL - #+(and cmucl executable) :executable #+(and cmucl executable) t - (when executable '(:init-function restore-image :process-command-line nil - :quiet t :load-init-file nil :site-init nil)))) - #+gcl - (progn - (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) - (si::save-system filename)) - #+lispworks - (if executable - (lispworks:deliver 'restore-image 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 - (append - (when compression (list :compression compression)) - ;;--- only save runtime-options for standalone executables - (when executable (list :toplevel #'restore-image :save-runtime-options t)) - #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window. - ;; the default is :console - only works with SBCL 1.1.15 or later. - (when application-type (list :application-type application-type))))) - #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl) - (not-implemented-error 'dump-image)) - - (defun create-image (destination lisp-object-files - &key kind output-name prologue-code epilogue-code extra-object-files - (prelude () preludep) (postlude () postludep) - (entry-point () entry-point-p) build-args no-uiop) - (declare (ignorable destination lisp-object-files extra-object-files kind output-name - prologue-code epilogue-code prelude preludep postlude postludep - entry-point entry-point-p build-args no-uiop)) - "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options" - ;; Is it meaningful to run these in the current environment? - ;; only if we also track the object files that constitute the "current" image, - ;; and otherwise simulate dump-image, including quitting at the end. - #-(or clasp ecl mkcl) (not-implemented-error 'create-image) - #+(or clasp ecl mkcl) - (let ((epilogue-code - (if no-uiop - epilogue-code - (let ((forms - (append - (when epilogue-code `(,epilogue-code)) - (when postludep `((setf *image-postlude* ',postlude))) - (when preludep `((setf *image-prelude* ',prelude))) - (when entry-point-p `((setf *image-entry-point* ',entry-point))) - (case kind - ((:image) - (setf kind :program) ;; to ECL, it's just another program. - `((setf *image-dumped-p* t) - (si::top-level #+(or clasp ecl) t) (quit))) - ((:program) - `((setf *image-dumped-p* :executable) - (shell-boolean-exit - (restore-image)))))))) - (when forms `(progn ,@forms)))))) - (check-type kind (member :dll :shared-library :lib :static-library - :fasl :fasb :program)) - (apply #+clasp 'cmp:builder #+clasp kind - #+(or ecl mkcl) - (ecase kind - ((:dll :shared-library) - #+ecl 'c::build-shared-library #+mkcl 'compiler:build-shared-library) - ((:lib :static-library) - #+ecl 'c::build-static-library #+mkcl 'compiler:build-static-library) - ((:fasl #+ecl :fasb) - #+ecl 'c::build-fasl #+mkcl 'compiler:build-fasl) - #+mkcl ((:fasb) 'compiler:build-bundle) - ((:program) - #+ecl 'c::build-program #+mkcl 'compiler:build-program)) - (pathname destination) - #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files - (append lisp-object-files #+(or clasp ecl) extra-object-files) - #+ecl :init-name - #+ecl (getf build-args :init-name) - (append - (when prologue-code `(:prologue-code ,prologue-code)) - (when epilogue-code `(:epilogue-code ,epilogue-code)) - #+mkcl (when extra-object-files `(:object-files ,extra-object-files)) - build-args))))) - - -;;; Some universal image restore hooks -(with-upgradability () - (map () 'register-image-restore-hook - '(setup-stdin setup-stdout setup-stderr - setup-command-line-arguments setup-temporary-directory - #+abcl detect-os))) -;;;; ------------------------------------------------------------------------- -;;;; Support to build (compile and load) Lisp files - -(uiop/package:define-package :uiop/lisp-build - (:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp - (:use :uiop/common-lisp :uiop/package :uiop/utility - :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) - (:export - ;; Variables - #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* - #:*output-translation-function* - #:*optimization-settings* #:*previous-optimization-settings* - #:*base-build-directory* - #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error - #:compile-warned-warning #:compile-failed-warning - #:check-lisp-compile-results #:check-lisp-compile-warnings - #:*uninteresting-conditions* #:*usual-uninteresting-conditions* - #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* - ;; Types - #+sbcl #:sb-grovel-unknown-constant-condition - ;; Functions & Macros - #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings - #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions - #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions - #:reify-simple-sexp #:unreify-simple-sexp - #:reify-deferred-warnings #:unreify-deferred-warnings - #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings - #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type* - #:enable-deferred-warnings-check #:disable-deferred-warnings-check - #:current-lisp-file-pathname #:load-pathname - #:lispize-pathname #:compile-file-type #:call-around-hook - #:compile-file* #:compile-file-pathname* #:*compile-check* - #:load* #:load-from-string #:combine-fasls) - (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) -(in-package :uiop/lisp-build) - -(with-upgradability () - (defvar *compile-file-warnings-behaviour* - (or #+clisp :ignore :warn) - "How should ASDF react if it encounters a warning when compiling a file? -Valid values are :error, :warn, and :ignore.") - - (defvar *compile-file-failure-behaviour* - (or #+(or mkcl sbcl) :error #+clisp :ignore :warn) - "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) -when compiling a file, which includes any non-style-warning warning. -Valid values are :error, :warn, and :ignore. -Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") - - (defvar *base-build-directory* nil - "When set to a non-null value, it should be an absolute directory pathname, -which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE, -what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it. -This can help you produce more deterministic output for FASLs.")) - -;;; Optimization settings -(with-upgradability () - (defvar *optimization-settings* nil - "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS") - (defvar *previous-optimization-settings* nil - "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS") - (defparameter +optimization-variables+ - ;; TODO: allegro genera corman mcl - (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*) - #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents) - #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* - ccl::*nx-debug* ccl::*nx-cspeed*) - #+(or cmucl scl) '(c::*default-cookie*) - #+clasp nil - #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*)) - #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*) - #+lispworks '(compiler::*optimization-level*) - #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*) - #+sbcl '(sb-c::*policy*))) - (defun get-optimization-settings () - "Get current compiler optimization settings, ready to PROCLAIM again" - #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) - (warn "~S does not support ~S. Please help me fix that." - 'get-optimization-settings (implementation-type)) - #+clasp (cleavir-env:optimize (cleavir-env:optimize-info CLASP-CLEAVIR:*CLASP-ENV*)) - #+(or abcl allegro clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) - (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity))) - #.`(loop #+(or allegro clozure) - ,@'(:with info = #+allegro (sys:declaration-information 'optimize) - #+clozure (ccl:declaration-information 'optimize nil)) - :for x :in settings - ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+)) - :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order - #+clisp (gethash x system::*optimize* 1) - #+(or abcl ecl mkcl xcl) (symbol-value v) - #+(or cmucl scl) (slot-value c::*default-cookie* - (case x (compilation-speed 'c::cspeed) - (otherwise x))) - #+lispworks (slot-value compiler::*optimization-level* x) - #+sbcl (sb-c::policy-quality sb-c::*policy* x)) - :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)))) - (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body) - #+(or allegro clasp clisp) - (let ((previous-settings (gensym "PREVIOUS-SETTINGS")) - (reset-settings (gensym "RESET-SETTINGS"))) - `(let* ((,previous-settings (get-optimization-settings)) - (,reset-settings #+clasp (reverse ,previous-settings) #-clasp ,previous-settings)) - ,@(when settings `((proclaim `(optimize ,@,settings)))) - (unwind-protect (progn ,@body) - (proclaim `(optimize ,@,reset-settings))))) - #-(or allegro clasp clisp) - `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v)) - ,@(when settings `((proclaim `(optimize ,@,settings)))) - ,@body))) - - -;;; Condition control -(with-upgradability () - #+sbcl - (progn - (defun sb-grovel-unknown-constant-condition-p (c) - "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL" - (ignore-errors - (and (typep c 'sb-int:simple-style-warning) - (string-enclosed-p - "Couldn't grovel for " - (simple-condition-format-control c) - " (unknown to the C compiler).")))) - (deftype sb-grovel-unknown-constant-condition () - '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p)))) - - (defvar *usual-uninteresting-conditions* - (append - ;;#+clozure '(ccl:compiler-warning) - #+cmucl '("Deleting unreachable code.") - #+lispworks '("~S being redefined in ~A (previously in ~A)." - "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when. - #+sbcl - '(sb-c::simple-compiler-note - "&OPTIONAL and &KEY found in the same lambda list: ~S" - sb-kernel:undefined-alien-style-warning - sb-grovel-unknown-constant-condition ; defined above. - sb-ext:implicit-generic-function-warning ;; Controversial. - sb-int:package-at-variance - sb-kernel:uninteresting-redefinition - ;; BEWARE: the below four are controversial to include here. - sb-kernel:redefinition-with-defun - sb-kernel:redefinition-with-defgeneric - sb-kernel:redefinition-with-defmethod - sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs - #+sbcl - (let ((condition (find-symbol* '#:lexical-environment-too-complex :sb-kernel nil))) - (when condition - (list condition))) - '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop - "A suggested value to which to set or bind *uninteresting-conditions*.") - - (defvar *uninteresting-conditions* '() - "Conditions that may be skipped while compiling or loading Lisp code.") - (defvar *uninteresting-compiler-conditions* '() - "Additional conditions that may be skipped while compiling Lisp code.") - (defvar *uninteresting-loader-conditions* - (append - '("Overwriting already existing readtable ~S." ;; from named-readtables - #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers - #+clisp '(clos::simple-gf-replacing-method-warning)) - "Additional conditions that may be skipped while loading Lisp code.")) - -;;;; ----- Filtering conditions while building ----- -(with-upgradability () - (defun call-with-muffled-compiler-conditions (thunk) - "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled" - (call-with-muffled-conditions - thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*))) - (defmacro with-muffled-compiler-conditions ((&optional) &body body) - "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS" - `(call-with-muffled-compiler-conditions #'(lambda () ,@body))) - (defun call-with-muffled-loader-conditions (thunk) - "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled" - (call-with-muffled-conditions - thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*))) - (defmacro with-muffled-loader-conditions ((&optional) &body body) - "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS" - `(call-with-muffled-loader-conditions #'(lambda () ,@body)))) - - -;;;; Handle warnings and failures -(with-upgradability () - (define-condition compile-condition (condition) - ((context-format - :initform nil :reader compile-condition-context-format :initarg :context-format) - (context-arguments - :initform nil :reader compile-condition-context-arguments :initarg :context-arguments) - (description - :initform nil :reader compile-condition-description :initarg :description)) - (:report (lambda (c s) - (format s (compatfmt "~@<~A~@[ while ~?~]~@:>") - (or (compile-condition-description c) (type-of c)) - (compile-condition-context-format c) - (compile-condition-context-arguments c))))) - (define-condition compile-file-error (compile-condition error) ()) - (define-condition compile-warned-warning (compile-condition warning) ()) - (define-condition compile-warned-error (compile-condition error) ()) - (define-condition compile-failed-warning (compile-condition warning) ()) - (define-condition compile-failed-error (compile-condition error) ()) - - (defun check-lisp-compile-warnings (warnings-p failure-p - &optional context-format context-arguments) - "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings, -raise an error or warning as appropriate" - (when failure-p - (case *compile-file-failure-behaviour* - (:warn (warn 'compile-failed-warning - :description "Lisp compilation failed" - :context-format context-format - :context-arguments context-arguments)) - (:error (error 'compile-failed-error - :description "Lisp compilation failed" - :context-format context-format - :context-arguments context-arguments)) - (:ignore nil))) - (when warnings-p - (case *compile-file-warnings-behaviour* - (:warn (warn 'compile-warned-warning - :description "Lisp compilation had style-warnings" - :context-format context-format - :context-arguments context-arguments)) - (:error (error 'compile-warned-error - :description "Lisp compilation had style-warnings" - :context-format context-format - :context-arguments context-arguments)) - (:ignore nil)))) - - (defun check-lisp-compile-results (output warnings-p failure-p - &optional context-format context-arguments) - "Given the results of COMPILE-FILE, raise an error or warning as appropriate" - (unless output - (error 'compile-file-error :context-format context-format :context-arguments context-arguments)) - (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments))) - - -;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman. -;;; -;;; To support an implementation, three functions must be implemented: -;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings -;;; See their respective docstrings. -(with-upgradability () - (defun reify-simple-sexp (sexp) - "Given a simple SEXP, return a representation of it as a portable SEXP. -Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells." - (etypecase sexp - (symbol (reify-symbol sexp)) - ((or number character simple-string pathname) sexp) - (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))) - (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list)))))) - - (defun unreify-simple-sexp (sexp) - "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents" - (etypecase sexp - ((or symbol number character simple-string pathname) sexp) - (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) - ((simple-vector 2) (unreify-symbol sexp)) - ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector)))) - - #+clozure - (progn - (defun reify-source-note (source-note) - (when source-note - (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename) - (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note - (declare (ignorable source)) - (list :filename filename :start-pos start-pos :end-pos end-pos - #|:source (reify-source-note source)|#)))) - (defun unreify-source-note (source-note) - (when source-note - (destructuring-bind (&key filename start-pos end-pos source) source-note - (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos - :source (unreify-source-note source))))) - (defun unsymbolify-function-name (name) - (if-let (setfed (gethash name ccl::%setf-function-name-inverses%)) - `(setf ,setfed) - name)) - (defun symbolify-function-name (name) - (if (and (consp name) (eq (first name) 'setf)) - (let ((setfed (second name))) - (gethash setfed ccl::%setf-function-names%)) - name)) - (defun reify-function-name (function-name) - (let ((name (or (first function-name) ;; defun: extract the name - (let ((sec (second function-name))) - (or (and (atom sec) sec) ; scoped method: drop scope - (first sec)))))) ; method: keep gf name, drop method specializers - (list name))) - (defun unreify-function-name (function-name) - function-name) - (defun nullify-non-literals (sexp) - (typecase sexp - ((or number character simple-string symbol pathname) sexp) - (cons (cons (nullify-non-literals (car sexp)) - (nullify-non-literals (cdr sexp)))) - (t nil))) - (defun reify-deferred-warning (deferred-warning) - (with-accessors ((warning-type ccl::compiler-warning-warning-type) - (args ccl::compiler-warning-args) - (source-note ccl:compiler-warning-source-note) - (function-name ccl:compiler-warning-function-name)) deferred-warning - (list :warning-type warning-type :function-name (reify-function-name function-name) - :source-note (reify-source-note source-note) - :args (destructuring-bind (fun &rest more) - args - (cons (unsymbolify-function-name fun) - (nullify-non-literals more)))))) - (defun unreify-deferred-warning (reified-deferred-warning) - (destructuring-bind (&key warning-type function-name source-note args) - reified-deferred-warning - (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*)) - 'ccl::compiler-warning) - :function-name (unreify-function-name function-name) - :source-note (unreify-source-note source-note) - :warning-type warning-type - :args (destructuring-bind (fun . more) args - (cons (symbolify-function-name fun) more)))))) - #+(or cmucl scl) - (defun reify-undefined-warning (warning) - ;; Extracting undefined-warnings from the compilation-unit - ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" - (list* - (c::undefined-warning-kind warning) - (c::undefined-warning-name warning) - (c::undefined-warning-count warning) - (mapcar - #'(lambda (frob) - ;; the lexenv slot can be ignored for reporting purposes - `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob) - :source ,(c::compiler-error-context-source frob) - :original-source ,(c::compiler-error-context-original-source frob) - :context ,(c::compiler-error-context-context frob) - :file-name ,(c::compiler-error-context-file-name frob) ; a pathname - :file-position ,(c::compiler-error-context-file-position frob) ; an integer - :original-source-path ,(c::compiler-error-context-original-source-path frob))) - (c::undefined-warning-warnings warning)))) - - #+sbcl - (defun reify-undefined-warning (warning) - ;; Extracting undefined-warnings from the compilation-unit - ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" - (list* - (sb-c::undefined-warning-kind warning) - (sb-c::undefined-warning-name warning) - (sb-c::undefined-warning-count warning) - ;; the COMPILER-ERROR-CONTEXT struct has changed in SBCL, which means how we - ;; handle deferred warnings must change... TODO: when enough time has - ;; gone by, just assume all versions of SBCL are adequately - ;; up-to-date, and cut this material.[2018/05/30:rpg] - (mapcar - #'(lambda (frob) - ;; the lexenv slot can be ignored for reporting purposes - `( - #- #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c) - ,@`(:enclosing-source - ,(sb-c::compiler-error-context-enclosing-source frob) - :source - ,(sb-c::compiler-error-context-source frob) - :original-source - ,(sb-c::compiler-error-context-original-source frob)) - #+ #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c) - ,@ `(:%enclosing-source - ,(sb-c::compiler-error-context-enclosing-source frob) - :%source - ,(sb-c::compiler-error-context-source frob) - :original-form - ,(sb-c::compiler-error-context-original-form frob)) - :context ,(sb-c::compiler-error-context-context frob) - :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname - :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer - :original-source-path ,(sb-c::compiler-error-context-original-source-path frob))) - (sb-c::undefined-warning-warnings warning)))) - - (defun reify-deferred-warnings () - "return a portable S-expression, portably readable and writeable in any Common Lisp implementation -using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by -WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." - #+allegro - (list :functions-defined excl::.functions-defined. - :functions-called excl::.functions-called.) - #+clozure - (mapcar 'reify-deferred-warning - (if-let (dw ccl::*outstanding-deferred-warnings*) - (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) - (ccl::deferred-warnings.warnings mdw)))) - #+(or cmucl scl) - (when lisp::*in-compilation-unit* - ;; Try to send nothing through the pipe if nothing needs to be accumulated - `(,@(when c::*undefined-warnings* - `((c::*undefined-warnings* - ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*)))) - ,@(loop :for what :in '(c::*compiler-error-count* - c::*compiler-warning-count* - c::*compiler-note-count*) - :for value = (symbol-value what) - :when (plusp value) - :collect `(,what . ,value)))) - #+sbcl - (when sb-c::*in-compilation-unit* - ;; Try to send nothing through the pipe if nothing needs to be accumulated - `(,@(when sb-c::*undefined-warnings* - `((sb-c::*undefined-warnings* - ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*)))) - ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count* - sb-c::*compiler-error-count* - sb-c::*compiler-warning-count* - sb-c::*compiler-style-warning-count* - sb-c::*compiler-note-count*) - :for value = (symbol-value what) - :when (plusp value) - :collect `(,what . ,value))))) - - (defun unreify-deferred-warnings (reified-deferred-warnings) - "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding -deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT. -Handle any warning that has been resolved already, -such as an undefined function that has been defined since. -One of three functions required for deferred-warnings support in ASDF." - (declare (ignorable reified-deferred-warnings)) - #+allegro - (destructuring-bind (&key functions-defined functions-called) - reified-deferred-warnings - (setf excl::.functions-defined. - (append functions-defined excl::.functions-defined.) - excl::.functions-called. - (append functions-called excl::.functions-called.))) - #+clozure - (let ((dw (or ccl::*outstanding-deferred-warnings* - (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) - (appendf (ccl::deferred-warnings.warnings dw) - (mapcar 'unreify-deferred-warning reified-deferred-warnings))) - #+(or cmucl scl) - (dolist (item reified-deferred-warnings) - ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. - ;; For *undefined-warnings*, the adjustment is a list of initargs. - ;; For everything else, it's an integer. - (destructuring-bind (symbol . adjustment) item - (case symbol - ((c::*undefined-warnings*) - (setf c::*undefined-warnings* - (nconc (mapcan - #'(lambda (stuff) - (destructuring-bind (kind name count . rest) stuff - (unless (case kind (:function (fboundp name))) - (list - (c::make-undefined-warning - :name name - :kind kind - :count count - :warnings - (mapcar #'(lambda (x) - (apply #'c::make-compiler-error-context x)) - rest)))))) - adjustment) - c::*undefined-warnings*))) - (otherwise - (set symbol (+ (symbol-value symbol) adjustment)))))) - #+sbcl - (dolist (item reified-deferred-warnings) - ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. - ;; For *undefined-warnings*, the adjustment is a list of initargs. - ;; For everything else, it's an integer. - (destructuring-bind (symbol . adjustment) item - (case symbol - ((sb-c::*undefined-warnings*) - (setf sb-c::*undefined-warnings* - (nconc (mapcan - #'(lambda (stuff) - (destructuring-bind (kind name count . rest) stuff - (unless (case kind (:function (fboundp name))) - (list - (sb-c::make-undefined-warning - :name name - :kind kind - :count count - :warnings - (mapcar #'(lambda (x) - (apply #'sb-c::make-compiler-error-context x)) - rest)))))) - adjustment) - sb-c::*undefined-warnings*))) - (otherwise - (set symbol (+ (symbol-value symbol) adjustment))))))) - - (defun reset-deferred-warnings () - "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT. -One of three functions required for deferred-warnings support in ASDF." - #+allegro - (setf excl::.functions-defined. nil - excl::.functions-called. nil) - #+clozure - (if-let (dw ccl::*outstanding-deferred-warnings*) - (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) - (setf (ccl::deferred-warnings.warnings mdw) nil))) - #+(or cmucl scl) - (when lisp::*in-compilation-unit* - (setf c::*undefined-warnings* nil - c::*compiler-error-count* 0 - c::*compiler-warning-count* 0 - c::*compiler-note-count* 0)) - #+sbcl - (when sb-c::*in-compilation-unit* - (setf sb-c::*undefined-warnings* nil - sb-c::*aborted-compilation-unit-count* 0 - sb-c::*compiler-error-count* 0 - sb-c::*compiler-warning-count* 0 - sb-c::*compiler-style-warning-count* 0 - sb-c::*compiler-note-count* 0))) - - (defun save-deferred-warnings (warnings-file) - "Save forward reference conditions so they may be issued at a latter time, -possibly in a different process." - (with-open-file (s warnings-file :direction :output :if-exists :supersede - :element-type *default-stream-element-type* - :external-format *utf-8-external-format*) - (with-safe-io-syntax () - (let ((*read-eval* t)) - (write (reify-deferred-warnings) :stream s :pretty t :readably t)) - (terpri s)))) - - (defun warnings-file-type (&optional implementation-type) - "The pathname type for warnings files on given IMPLEMENTATION-TYPE, -where NIL designates the current one" - (case (or implementation-type *implementation-type*) - ((:acl :allegro) "allegro-warnings") - ;;((:clisp) "clisp-warnings") - ((:cmu :cmucl) "cmucl-warnings") - ((:sbcl) "sbcl-warnings") - ((:clozure :ccl) "ccl-warnings") - ((:scl) "scl-warnings"))) - - (defvar *warnings-file-type* nil - "Pathname type for warnings files, or NIL if disabled") - - (defun enable-deferred-warnings-check () - "Enable the saving of deferred warnings" - (setf *warnings-file-type* (warnings-file-type))) - - (defun disable-deferred-warnings-check () - "Disable the saving of deferred warnings" - (setf *warnings-file-type* nil)) - - (defun warnings-file-p (file &optional implementation-type) - "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE? -If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead." - (if-let (type (if implementation-type - (warnings-file-type implementation-type) - *warnings-file-type*)) - (equal (pathname-type file) type))) - - (defun check-deferred-warnings (files &optional context-format context-arguments) - "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS, -re-intern and raise any warnings that are still meaningful." - (let ((file-errors nil) - (failure-p nil) - (warnings-p nil)) - (handler-bind - ((warning #'(lambda (c) - (setf warnings-p t) - (unless (typep c 'style-warning) - (setf failure-p t))))) - (with-compilation-unit (:override t) - (reset-deferred-warnings) - (dolist (file files) - (unreify-deferred-warnings - (handler-case - (with-safe-io-syntax () - (let ((*read-eval* t)) - (read-file-form file))) - (error (c) - ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging - (push c file-errors) - nil)))))) - (dolist (error file-errors) (error error)) - (check-lisp-compile-warnings - (or failure-p warnings-p) failure-p context-format context-arguments))) - - #| - Mini-guide to adding support for deferred warnings on an implementation. - - First, look at what such a warning looks like: - - (describe - (handler-case - (and (eval '(lambda () (some-undefined-function))) nil) - (t (c) c))) - - Then you can grep for the condition type in your compiler sources - and see how to catch those that have been deferred, - and/or read, clear and restore the deferred list. - - Also look at - (macroexpand-1 '(with-compilation-unit () foo)) - |# - - (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring) - "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK -and save those warnings to the given file for latter use, -possibly in a different process. Otherwise just call THUNK." - (declare (ignorable source-namestring)) - (if warnings-file - (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring) - (unwind-protect - (let (#+sbcl (sb-c::*undefined-warnings* nil)) - (multiple-value-prog1 - (funcall thunk) - (save-deferred-warnings warnings-file))) - (reset-deferred-warnings))) - (funcall thunk))) - - (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body) - "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS" - `(call-with-saved-deferred-warnings - #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring))) - - -;;; from ASDF -(with-upgradability () - (defun current-lisp-file-pathname () - "Portably return the PATHNAME of the current Lisp source file being compiled or loaded" - (or *compile-file-pathname* *load-pathname*)) - - (defun load-pathname () - "Portably return the LOAD-PATHNAME of the current source file or fasl. - May return a relative pathname." - *load-pathname*) ;; magic no longer needed for GCL. - - (defun lispize-pathname (input-file) - "From a INPUT-FILE pathname, return a corresponding .lisp source pathname" - (make-pathname :type "lisp" :defaults input-file)) - - (defun compile-file-type (&rest keys) - "pathname TYPE for lisp FASt Loading files" - (declare (ignorable keys)) - #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) - #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys))) - - (defun call-around-hook (hook function) - "Call a HOOK around the execution of FUNCTION" - (call-function (or hook 'funcall) function)) - - (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) - "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*" - (let* ((keys - (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format - ,@(unless output-file '(:output-file))) keys))) - (if (absolute-pathname-p output-file) - ;; what cfp should be doing, w/ mp* instead of mp - (let* ((type (pathname-type (apply 'compile-file-type keys))) - (defaults (make-pathname - :type type :defaults (merge-pathnames* input-file)))) - (merge-pathnames* output-file defaults)) - (funcall *output-translation-function* - (apply 'compile-file-pathname input-file keys))))) - - (defvar *compile-check* nil - "A hook for user-defined compile-time invariants") - - (defun compile-file* (input-file &rest keys - &key (compile-check *compile-check*) output-file warnings-file - #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl - &allow-other-keys) - "This function provides a portable wrapper around COMPILE-FILE. -It ensures that the OUTPUT-FILE value is only returned and -the file only actually created if the compilation was successful, -even though your implementation may not do that. It also checks an optional -user-provided consistency function COMPILE-CHECK to determine success; -it will call this function if not NIL at the end of the compilation -with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE -where TMP-FILE is the name of a temporary output-file. -It also checks two flags (with legacy british spelling from ASDF1), -*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR* -with appropriate implementation-dependent defaults, -and if a failure (respectively warnings) are reported by COMPILE-FILE, -it will consider that an error unless the respective behaviour flag -is one of :SUCCESS :WARN :IGNORE. -If WARNINGS-FILE is defined, deferred warnings are saved to that file. -On ECL or MKCL, it creates both the linkable object and loadable fasl files. -On implementations that erroneously do not recognize standard keyword arguments, -it will filter them appropriately." - #+(or clasp ecl) - (when (and object-file (equal (compile-file-type) (pathname object-file))) - (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" - 'compile-file* output-file object-file) - (rotatef output-file object-file)) - (let* ((keywords (remove-plist-keys - `(:output-file :compile-check :warnings-file - #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys)) - (output-file - (or output-file - (apply 'compile-file-pathname* input-file :output-file output-file keywords))) - (physical-output-file (physicalize-pathname output-file)) - #+(or clasp ecl) - (object-file - (unless (use-ecl-byte-compiler-p) - (or object-file - #+ecl (compile-file-pathname output-file :type :object) - #+clasp (compile-file-pathname output-file :output-type :object)))) - #+mkcl - (object-file - (or object-file - (compile-file-pathname output-file :fasl-p nil))) - (tmp-file (tmpize-pathname physical-output-file)) - #+clasp - (tmp-object-file (compile-file-pathname tmp-file :output-type :object)) - #+sbcl - (cfasl-file (etypecase emit-cfasl - (null nil) - ((eql t) (make-pathname :type "cfasl" :defaults physical-output-file)) - (string (parse-namestring emit-cfasl)) - (pathname emit-cfasl))) - #+sbcl - (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file))) - #+clisp - (tmp-lib (make-pathname :type "lib" :defaults tmp-file))) - (multiple-value-bind (output-truename warnings-p failure-p) - (with-enough-pathname (input-file :defaults *base-build-directory*) - (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file)) - (with-muffled-compiler-conditions () - (or #-(or clasp ecl mkcl) - (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t)) - (apply 'compile-file input-file :output-file tmp-file - #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) - #-sbcl keywords)) - #+ecl (apply 'compile-file input-file :output-file - (if object-file - (list* object-file :system-p t keywords) - (list* tmp-file keywords))) - #+clasp (apply 'compile-file input-file :output-file - (if object-file - (list* tmp-object-file :output-type :object #|:system-p t|# keywords) - (list* tmp-file keywords))) - #+mkcl (apply 'compile-file input-file - :output-file object-file :fasl-p nil keywords))))) - (cond - ((and output-truename - (flet ((check-flag (flag behaviour) - (or (not flag) (member behaviour '(:success :warn :ignore))))) - (and (check-flag failure-p *compile-file-failure-behaviour*) - (check-flag warnings-p *compile-file-warnings-behaviour*))) - (progn - #+(or clasp ecl mkcl) - (when (and #+(or clasp ecl) object-file) - (setf output-truename - (compiler::build-fasl tmp-file - #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list #+clasp tmp-object-file #-clasp object-file)))) - (or (not compile-check) - (apply compile-check input-file - :output-file output-truename - keywords)))) - (delete-file-if-exists physical-output-file) - (when output-truename - ;; see CLISP bug 677 - #+clisp - (progn - (setf tmp-lib (make-pathname :type "lib" :defaults output-truename)) - (unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file))) - (rename-file-overwriting-target tmp-lib lib-file)) - #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file)) - #+clasp - (progn - ;;; the following 4 rename-file-overwriting-target better be atomic, but we can't implement this right now - #+:target-os-darwin - (let ((temp-dwarf (pathname (strcat (namestring output-truename) ".dwarf"))) - (target-dwarf (pathname (strcat (namestring physical-output-file) ".dwarf")))) - (when (probe-file temp-dwarf) - (rename-file-overwriting-target temp-dwarf target-dwarf))) - ;;; need to rename the bc or ll file as well or test-bundle.script fails - ;;; They might not exist with parallel compilation - (let ((bitcode-src (compile-file-pathname tmp-file :output-type :bitcode)) - (bitcode-target (compile-file-pathname physical-output-file :output-type :bitcode))) - (when (probe-file bitcode-src) - (rename-file-overwriting-target bitcode-src bitcode-target))) - (rename-file-overwriting-target tmp-object-file object-file)) - (rename-file-overwriting-target output-truename physical-output-file) - (setf output-truename (truename physical-output-file))) - #+clasp (delete-file-if-exists tmp-file) - #+clisp (progn (delete-file-if-exists tmp-file) ;; this one works around clisp BUG 677 - (delete-file-if-exists tmp-lib))) ;; this one is "normal" defensive cleanup - (t ;; error or failed check - (delete-file-if-exists output-truename) - #+clisp (delete-file-if-exists tmp-lib) - #+sbcl (delete-file-if-exists tmp-cfasl) - (setf output-truename nil))) - (values output-truename warnings-p failure-p)))) - - (defun load* (x &rest keys &key &allow-other-keys) - "Portable wrapper around LOAD that properly handles loading from a stream." - (with-muffled-loader-conditions () - (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t)) - (etypecase x - ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream) - (apply 'load x keys)) - ;; Genera can't load from a string-input-stream - ;; ClozureCL 1.6 can only load from file input stream - ;; Allegro 5, I don't remember but it must have been broken when I tested. - #+(or allegro clozure genera) - (stream ;; make do this way - (let ((*package* *package*) - (*readtable* *readtable*) - (*load-pathname* nil) - (*load-truename* nil)) - (eval-input x))))))) - - (defun load-from-string (string) - "Portably read and evaluate forms from a STRING." - (with-input-from-string (s string) (load* s)))) - -;;; Links FASLs together -(with-upgradability () - (defun combine-fasls (inputs output) - "Combine a list of FASLs INPUTS into a single FASL OUTPUT" - #-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl) - (not-implemented-error 'combine-fasls "~%inputs: ~S~%output: ~S" inputs output) - #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0 - #+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output) - #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) - #+lispworks - (let (fasls) - (unwind-protect - (progn - (loop :for i :in inputs - :for n :from 1 - :for f = (add-pathname-suffix - output (format nil "-FASL~D" n)) - :do (copy-file i f) - (push f fasls)) - (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) - (eval `(scm:defsystem :fasls-to-concatenate - (:default-pathname ,(pathname-directory-pathname output)) - :members - ,(loop :for f :in (reverse fasls) - :collect `(,(namestring f) :load-only t)))) - (scm:concatenate-system output :fasls-to-concatenate :force t)) - (loop :for f :in fasls :do (ignore-errors (delete-file f))) - (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))) -;;;; ------------------------------------------------------------------------- -;;;; launch-program - semi-portably spawn asynchronous subprocesses - -(uiop/package:define-package :uiop/launch-program - (:use :uiop/common-lisp :uiop/package :uiop/utility - :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream - :uiop/version) - (:export - ;;; Escaping the command invocation madness - #:easy-sh-character-p #:escape-sh-token #:escape-sh-command - #:escape-windows-token #:escape-windows-command - #:escape-shell-token #:escape-shell-command - #:escape-token #:escape-command - - ;;; launch-program - #:launch-program - #:close-streams #:process-alive-p #:terminate-process #:wait-process - #:process-info - #:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid)) -(in-package :uiop/launch-program) - -;;;; ----- Escaping strings for the shell ----- -(with-upgradability () - (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) - (parameter-error "~S: only one of good-chars and bad-chars can be provided" - 'requires-escaping-p)) - ((typep good-chars 'function) - (complement good-chars)) - ((typep bad-chars 'function) - 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 (parameter-error "~S: no good-char criterion" 'requires-escaping-p))) - token)) - - (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 easy-windows-character-p (x) - "Is X an \"easy\" character that does not require quoting by the shell?" - (or (alphanumericp x) (find x "+-_.,@:/="))) - - (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 :good-chars #'easy-windows-character-p :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) - "Is X an \"easy\" character that does not require quoting by the shell?" - (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) - "Escape a token for the current operating system shell" - (os-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))) - - -(with-upgradability () - ;;; Internal helpers for run-program - (defun %normalize-io-specifier (specifier &optional role) - "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent -argument to pass to the internal RUN-PROGRAM" - (declare (ignorable role)) - (typecase specifier - (null (or #+(or allegro lispworks) (null-device-pathname))) - (string (parse-native-namestring specifier)) - (pathname specifier) - (stream specifier) - ((eql :stream) :stream) - ((eql :interactive) - #+(or allegro lispworks) nil - #+clisp :terminal - #+(or abcl clasp clozure cmucl ecl mkcl sbcl scl) t - #-(or abcl clasp clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp) - (not-implemented-error :interactive-output - "On this lisp implementation, cannot interpret ~a value of ~a" - specifier role)) - ((eql :output) - (cond ((eq role :error-output) - #+(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl) - :output - #-(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl) - (not-implemented-error :error-output-redirect - "Can't send ~a to ~a on this lisp implementation." - role specifier)) - (t (parameter-error "~S IO specifier invalid for ~S" specifier role)))) - ((eql t) - #+ (or lispworks abcl) - (not-implemented-error :interactive-output - "On this lisp implementation, cannot interpret ~a value of ~a" - specifier role) - #- (or lispworks abcl) - (cond ((eq role :error-output) *error-output*) - ((eq role :output) #+lispworks *terminal-io* #-lispworks *standard-output*) - ((eq role :input) *standard-input*))) - (otherwise - (parameter-error "Incorrect I/O specifier ~S for ~S" - specifier role)))) - - (defun %interactivep (input output error-output) - (member :interactive (list input output error-output))) - - (defun %signal-to-exit-code (signum) - (+ 128 signum)) - - (defun %code-to-status (exit-code signal-code) - (cond ((null exit-code) :running) - ((null signal-code) (values :exited exit-code)) - (t (values :signaled signal-code)))) - - #+mkcl - (defun %mkcl-signal-to-number (signal) - (require :mk-unix) - (symbol-value (find-symbol signal :mk-unix))) - - (defclass process-info () - (;; The process field is highly platform-, implementation-, and - ;; even version-dependent. - ;; Prior to LispWorks 7, the only information that - ;; `sys:run-shell-command` with `:wait nil` was certain to return - ;; is a PID (e.g. when all streams are nil), hence we stored it - ;; and used `sys:pid-exit-status` to obtain an exit status - ;; later. That is still what we do. - ;; From LispWorks 7 on, if `sys:run-shell-command` does not - ;; return a proper stream, we are instead given a dummy stream. - ;; We can thus always store a stream and use - ;; `sys:pipe-exit-status` to obtain an exit status later. - ;; The advantage of dealing with streams instead of PID is the - ;; availability of functions like `sys:pipe-kill-process`. - (process :initform nil) - (input-stream :initform nil) - (output-stream :initform nil) - (bidir-stream :initform nil) - (error-output-stream :initform nil) - ;; For backward-compatibility, to maintain the property (zerop - ;; exit-code) <-> success, an exit in response to a signal is - ;; encoded as 128+signum. - (exit-code :initform nil) - ;; If the platform allows it, distinguish exiting with a code - ;; >128 from exiting in response to a signal by setting this code - (signal-code :initform nil)) - (:documentation "This class should be treated as opaque by programmers, except for the -exported PROCESS-INFO-* functions. It should never be directly instantiated by -MAKE-INSTANCE. Primarily, it is being made available to enable type-checking.")) - -;;;--------------------------------------------------------------------------- -;;; The following two helper functions take care of handling the IF-EXISTS and -;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the -;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master -;;; function to treat input and output files unconditionally for reading and -;;; writing. -;;;--------------------------------------------------------------------------- - - (defun %handle-if-exists (file if-exists) - (when (or (stringp file) (pathnamep file)) - (ecase if-exists - ((:append :supersede :error) - (with-open-file (dummy file :direction :output :if-exists if-exists) - (declare (ignorable dummy))))))) - - (defun %handle-if-does-not-exist (file if-does-not-exist) - (when (or (stringp file) (pathnamep file)) - (ecase if-does-not-exist - ((:create :error) - (with-open-file (dummy file :direction :probe - :if-does-not-exist if-does-not-exist) - (declare (ignorable dummy))))))) - - (defun process-info-error-output (process-info) - (slot-value process-info 'error-output-stream)) - (defun process-info-input (process-info) - (or (slot-value process-info 'bidir-stream) - (slot-value process-info 'input-stream))) - (defun process-info-output (process-info) - (or (slot-value process-info 'bidir-stream) - (slot-value process-info 'output-stream))) - - (defun process-info-pid (process-info) - (let ((process (slot-value process-info 'process))) - (declare (ignorable process)) - #+abcl (symbol-call :sys :process-pid process) - #+allegro process - #+clasp (if (find-symbol* '#:external-process-pid :ext nil) - (symbol-call :ext '#:external-process-pid process) - (not-implemented-error 'process-info-pid)) - #+clozure (ccl:external-process-id process) - #+ecl (ext:external-process-pid process) - #+(or cmucl scl) (ext:process-pid process) - #+lispworks7+ (sys:pipe-pid process) - #+(and lispworks (not lispworks7+)) process - #+mkcl (mkcl:process-id process) - #+sbcl (sb-ext:process-pid process) - #-(or abcl allegro clasp clozure cmucl ecl mkcl lispworks sbcl scl) - (not-implemented-error 'process-info-pid))) - - (defun %process-status (process-info) - (if-let (exit-code (slot-value process-info 'exit-code)) - (return-from %process-status - (if-let (signal-code (slot-value process-info 'signal-code)) - (values :signaled signal-code) - (values :exited exit-code)))) - #-(or allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl) - (not-implemented-error '%process-status) - (if-let (process (slot-value process-info 'process)) - (multiple-value-bind (status code) - (progn - #+allegro (multiple-value-bind (exit-code pid signal-code) - (sys:reap-os-subprocess :pid process :wait nil) - (assert pid) - (%code-to-status exit-code signal-code)) - #+clasp (if (find-symbol* '#:external-process-status :ext nil) - (symbol-call :ext '#:external-process-status process) - (not-implemented-error '%process-status)) - #+clozure (ccl:external-process-status process) - #+(or cmucl scl) (let ((status (ext:process-status process))) - (if (member status '(:exited :signaled)) - ;; Calling ext:process-exit-code on - ;; processes that are still alive - ;; yields an undefined result - (values status (ext:process-exit-code process)) - status)) - #+ecl (ext:external-process-status process) - #+lispworks - ;; a signal is only returned on LispWorks 7+ - (multiple-value-bind (exit-code signal-code) - (symbol-call :sys - #+lispworks7+ :pipe-exit-status - #-lispworks7+ :pid-exit-status - process :wait nil) - (%code-to-status exit-code signal-code)) - #+mkcl (let ((status (mk-ext:process-status process))) - (if (eq status :exited) - ;; Only call mk-ext:process-exit-code when - ;; necessary since it leads to another waitpid() - (let ((code (mk-ext:process-exit-code process))) - (if (stringp code) - (values :signaled (%mkcl-signal-to-number code)) - (values :exited code))) - status)) - #+sbcl (let ((status (sb-ext:process-status process))) - (if (eq status :running) - :running - ;; sb-ext:process-exit-code can also be - ;; called for stopped processes to determine - ;; the signal that stopped them - (values status (sb-ext:process-exit-code process))))) - (case status - (:exited (setf (slot-value process-info 'exit-code) code)) - (:signaled (let ((%code (%signal-to-exit-code code))) - (setf (slot-value process-info 'exit-code) %code - (slot-value process-info 'signal-code) code)))) - (if code - (values status code) - status)))) - - (defun process-alive-p (process-info) - "Check if a process has yet to exit." - (unless (slot-value process-info 'exit-code) - #+abcl (sys:process-alive-p (slot-value process-info 'process)) - #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process)) - #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process)) - #-(or abcl cmucl sbcl scl) (find (%process-status process-info) - '(:running :stopped :continued :resumed)))) - - (defun wait-process (process-info) - "Wait for the process to terminate, if it is still running. -Otherwise, return immediately. An exit code (a number) will be -returned, with 0 indicating success, and anything else indicating -failure. If the process exits after receiving a signal, the exit code -will be the sum of 128 and the (positive) numeric signal code. A second -value may be returned in this case: the numeric signal code itself. -Any asynchronously spawned process requires this function to be run -before it is garbage-collected in order to free up resources that -might otherwise be irrevocably lost." - (if-let (exit-code (slot-value process-info 'exit-code)) - (if-let (signal-code (slot-value process-info 'signal-code)) - (values exit-code signal-code) - exit-code) - (let ((process (slot-value process-info 'process))) - #-(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl) - (not-implemented-error 'wait-process) - (when process - ;; 1- wait - #+clozure (ccl::external-process-wait process) - #+(or cmucl scl) (ext:process-wait process) - #+sbcl (sb-ext:process-wait process) - ;; 2- extract result - (multiple-value-bind (exit-code signal-code) - (progn - #+abcl (sys:process-wait process) - #+allegro (multiple-value-bind (exit-code pid signal) - (sys:reap-os-subprocess :pid process :wait t) - (assert pid) - (values exit-code signal)) - #+clasp (if (find-symbol* '#:external-process-wait :ext nil) - (multiple-value-bind (status code) - (symbol-call :ext '#:external-process-wait process t) - (if (eq status :signaled) - (values nil code) - code)) - (not-implemented-error 'wait-process)) - #+clozure (multiple-value-bind (status code) - (ccl:external-process-status process) - (if (eq status :signaled) - (values nil code) - code)) - #+(or cmucl scl) (let ((status (ext:process-status process)) - (code (ext:process-exit-code process))) - (if (eq status :signaled) - (values nil code) - code)) - #+ecl (multiple-value-bind (status code) - (ext:external-process-wait process t) - (if (eq status :signaled) - (values nil code) - code)) - #+lispworks (symbol-call :sys - #+lispworks7+ :pipe-exit-status - #-lispworks7+ :pid-exit-status - process :wait t) - #+mkcl (let ((code (mkcl:join-process process))) - (if (stringp code) - (values nil (%mkcl-signal-to-number code)) - code)) - #+sbcl (let ((status (sb-ext:process-status process)) - (code (sb-ext:process-exit-code process))) - (if (eq status :signaled) - (values nil code) - code))) - (if signal-code - (let ((%exit-code (%signal-to-exit-code signal-code))) - (setf (slot-value process-info 'exit-code) %exit-code - (slot-value process-info 'signal-code) signal-code) - (values %exit-code signal-code)) - (progn (setf (slot-value process-info 'exit-code) exit-code) - exit-code))))))) - - ;; WARNING: For signals other than SIGTERM and SIGKILL this may not - ;; do what you expect it to. Sending SIGSTOP to a process spawned - ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used - ;; to run the command (via `sh -c command`) but not the actual - ;; command. - #+os-unix - (defun %posix-send-signal (process-info signal) - #+allegro (excl.osi:kill (slot-value process-info 'process) signal) - #+clozure (ccl:signal-external-process (slot-value process-info 'process) - signal :error-if-exited nil) - #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal) - #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal) - #-(or allegro clozure cmucl sbcl scl) - (if-let (pid (process-info-pid process-info)) - (symbol-call :uiop :run-program - (format nil "kill -~a ~a" signal pid) :ignore-error-status t))) - - ;;; this function never gets called on Windows, but the compiler cannot tell - ;;; that. [2016/09/25:rpg] - #+os-windows - (defun %posix-send-signal (process-info signal) - (declare (ignore process-info signal)) - (values)) - - (defun terminate-process (process-info &key urgent) - "Cause the process to exit. To that end, the process may or may -not be sent a signal, which it will find harder (or even impossible) -to ignore if URGENT is T. On some platforms, it may also be subject to -race conditions." - (declare (ignorable urgent)) - #+abcl (sys:process-kill (slot-value process-info 'process)) - ;; On ECL, this will only work on versions later than 2016-09-06, - ;; but we still want to compile on earlier versions, so we use symbol-call - #+(or clasp ecl) (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent) - #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process)) - #+mkcl (mk-ext:terminate-process (slot-value process-info 'process) - :force urgent) - #-(or abcl clasp ecl lispworks7+ mkcl) - (os-cond - ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15))) - ((os-windows-p) (if-let (pid (process-info-pid process-info)) - (symbol-call :uiop :run-program - (format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid) - :ignore-error-status t))) - (t (not-implemented-error 'terminate-process)))) - - (defun close-streams (process-info) - "Close any stream that the process might own. Needs to be run -whenever streams were requested by passing :stream to :input, :output, -or :error-output." - (dolist (stream - (cons (slot-value process-info 'error-output-stream) - (if-let (bidir-stream (slot-value process-info 'bidir-stream)) - (list bidir-stream) - (list (slot-value process-info 'input-stream) - (slot-value process-info 'output-stream))))) - (when stream (close stream)))) - - (defun launch-program (command &rest keys - &key - input (if-input-does-not-exist :error) - output (if-output-exists :supersede) - error-output (if-error-output-exists :supersede) - (element-type #-clozure *default-stream-element-type* - #+clozure 'character) - (external-format *utf-8-external-format*) - directory - #+allegro separate-streams - &allow-other-keys) - "Launch 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) _asynchronously_. - -If OUTPUT is a pathname, a string designating a pathname, or NIL (the -default) designating the null device, the file at that path is used as -output. -If it's :INTERACTIVE, output is inherited from the current process; -beware that this may be different from your *STANDARD-OUTPUT*, and -under SLIME will be on your *inferior-lisp* buffer. If it's T, output -goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new -stream will be made available that can be accessed via -PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value -that the underlying lisp implementation knows how to handle. - -IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a -pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the -default). The meaning of these values and their effect on the case -where OUTPUT does not exist, is analogous to the IF-EXISTS parameter -to OPEN with :DIRECTION :OUTPUT. - -ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*, -:OUTPUT means redirecting the error output to the output stream, -and :STREAM causes a stream to be made available via -PROCESS-INFO-ERROR-OUTPUT. - -IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it -affects ERROR-OUTPUT rather than OUTPUT. - -INPUT is similar to OUTPUT, except that T designates the -*STANDARD-INPUT* and a stream requested through the :STREAM keyword -would be available through PROCESS-INFO-INPUT. - -IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string -or a pathname, can take the values :CREATE and :ERROR (the -default). The meaning of these values is analogous to the -IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT. - -ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp -implementation, when applicable, for creation of the output stream. - -LAUNCH-PROGRAM returns a PROCESS-INFO object. - -LAUNCH-PROGRAM currently does not smooth over all the differences between -implementations. Of particular note is when streams are provided for OUTPUT or -ERROR-OUTPUT. Some implementations don't support this at all, some support only -certain subclasses of streams, and some support any arbitrary -stream. Additionally, the implementations that support streams may have -differing behavior on how those streams are filled with data. If data is not -periodically read from the child process and sent to the stream, the child -could block because its output buffers are full." - #-(or abcl allegro clasp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) - (progn command keys input output error-output directory element-type external-format - if-input-does-not-exist if-output-exists if-error-output-exists ;; ignore - (not-implemented-error 'launch-program)) - #+allegro - (when (some #'(lambda (stream) - (and (streamp stream) - (not (file-stream-p stream)))) - (list input output error-output)) - (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp" - 'launch-program)) - #+(or abcl clisp lispworks) - (when (some #'streamp (list input output error-output)) - (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp" - 'launch-program)) - #+clisp - (unless (eq error-output :interactive) - (parameter-error "~S: The only admissible value for ~S is ~S on this lisp" - 'launch-program :error-output :interactive)) - #+(or clasp ecl) - (when (and #+ecl (version< (lisp-implementation-version) "20.4.24") - (some #'(lambda (stream) - (and (streamp stream) - (not (file-or-synonym-stream-p stream)))) - (list input output error-output))) - (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp" - 'launch-program)) - #+(or abcl allegro clasp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) - (nest - (progn ;; see comments for these functions - (%handle-if-does-not-exist input if-input-does-not-exist) - (%handle-if-exists output if-output-exists) - (%handle-if-exists error-output if-error-output-exists)) - #+(or clasp ecl) (let ((*standard-input* *stdin*) - (*standard-output* *stdout*) - (*error-output* *stderr*))) - (let ((process-info (make-instance 'process-info)) - (input (%normalize-io-specifier input :input)) - (output (%normalize-io-specifier output :output)) - (error-output (%normalize-io-specifier error-output :error-output)) - #+(and allegro os-windows) (interactive (%interactivep input output error-output)) - (command - (etypecase command - #+os-unix (string `("/bin/sh" "-c" ,command)) - #+os-unix (list command) - #+os-windows - (string - ;; 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 clasp clisp clozure ecl) - (nest - #+(or clasp ecl sbcl) (unless (find-symbol* :escape-arguments #+(or clasp ecl) :ext #+sbcl :sb-impl nil)) - (parameter-error "~S doesn't support string commands on Windows on this Lisp" - 'launch-program command)) - ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified - ;; when the command contains spaces or special characters: - ;; IIUC, the system will use space as a separator, - ;; but the C++ argv-decoding libraries won't, and - ;; you're supposed to use an extra argument to CreateProcess to bridge the gap, - ;; yet neither allegro nor clisp provide access to that argument. - #+(or allegro clisp) (strcat "cmd /c " 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 - ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304 - ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13) - #+(or clasp clozure ecl sbcl) (cons "cmd" (strcat "/c " command))) - #+os-windows - (list - #+allegro (escape-windows-command command) - #-allegro command))))) - #+(or abcl (and allegro os-unix) clasp clozure cmucl ecl mkcl sbcl) - (let ((program (car command)) - #-allegro (arguments (cdr command)))) - #+(and (or clasp ecl sbcl) os-windows) - (multiple-value-bind (arguments escape-arguments) - (if (listp arguments) - (values arguments t) - (values (list arguments) nil))) - #-(or allegro mkcl sbcl) (with-current-directory (directory)) - (multiple-value-bind - #+(or abcl clozure cmucl sbcl scl) (process) - #+allegro (in-or-io out-or-err err-or-pid pid-or-nil) - #+(or clasp ecl) (stream code process) - #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil) - #+mkcl (stream process code) - #.`(apply - #+abcl 'sys:run-program - #+allegro ,@'('excl:run-shell-command - #+os-unix (coerce (cons program command) 'vector) - #+os-windows command) - #+clasp (if (find-symbol* '#:run-program :ext nil) - (find-symbol* '#:run-program :ext nil) - (not-implemented-error 'launch-program)) - #+clozure 'ccl:run-program - #+(or cmucl ecl scl) 'ext:run-program - - #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed - #+mkcl 'mk-ext:run-program - #+sbcl 'sb-ext:run-program - #+(or abcl clasp clozure cmucl ecl mkcl sbcl) ,@'(program arguments) - #+(and (or clasp ecl sbcl) os-windows) ,@'(:escape-arguments escape-arguments) - :input input :if-input-does-not-exist :error - :output output :if-output-exists :append - ,(or #+(or allegro lispworks) :error-output :error) error-output - ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append - :wait nil :element-type element-type :external-format external-format - :allow-other-keys t - #+allegro ,@`(:directory directory - #+os-windows ,@'(:show-window (if interactive nil :hide))) - #+lispworks ,@'(:save-exit-status t) - #+mkcl ,@'(:directory (native-namestring directory)) - #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys - #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys))))) - (labels ((prop (key value) (setf (slot-value process-info key) value))) - #+allegro - (cond - (separate-streams - (prop 'process pid-or-nil) - (when (eq input :stream) (prop 'input-stream in-or-io)) - (when (eq output :stream) (prop 'output-stream out-or-err)) - (when (eq error-output :stream) (prop 'error-output-stream err-or-pid))) - (t - (prop 'process err-or-pid) - (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) - (0) - (1 (prop 'input-stream in-or-io)) - (2 (prop 'output-stream in-or-io)) - (3 (prop 'bidir-stream in-or-io))) - (when (eq error-output :stream) - (prop 'error-output-stream out-or-err)))) - #+(or abcl clozure cmucl sbcl scl) - (progn - (prop 'process process) - (when (eq input :stream) - (nest - (prop 'input-stream) - #+abcl (symbol-call :sys :process-input) - #+clozure (ccl:external-process-input-stream) - #+(or cmucl scl) (ext:process-input) - #+sbcl (sb-ext:process-input) - process)) - (when (eq output :stream) - (nest - (prop 'output-stream) - #+abcl (symbol-call :sys :process-output) - #+clozure (ccl:external-process-output-stream) - #+(or cmucl scl) (ext:process-output) - #+sbcl (sb-ext:process-output) - process)) - (when (eq error-output :stream) - (nest - (prop 'error-output-stream) - #+abcl (symbol-call :sys :process-error) - #+clozure (ccl:external-process-error-stream) - #+(or cmucl scl) (ext:process-error) - #+sbcl (sb-ext:process-error) - process))) - #+(or clasp ecl mkcl) - (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) - code ;; ignore - (unless (zerop mode) - (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream)) - (when (eq error-output :stream) - (prop 'error-output-stream - (if (and #+clasp nil #-clasp t (version< (lisp-implementation-version) "16.0.0")) - (symbol-call :ext :external-process-error process) - (symbol-call :ext :external-process-error-stream process)))) - (prop 'process process)) - #+lispworks - ;; See also the comments on the process-info class - (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) - (cond - ((or (plusp mode) (eq error-output :stream)) - (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-nil) - (when (plusp mode) - (prop (ecase mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) - io-or-pid)) - (when (eq error-output :stream) - (prop 'error-output-stream err-or-nil))) - ;; Prior to Lispworks 7, this returned (pid); now it - ;; returns (io err pid) of which we keep io. - (t (prop 'process io-or-pid))))) - process-info))) - -;;;; ------------------------------------------------------------------------- -;;;; run-program initially from xcvb-driver. - -(uiop/package:define-package :uiop/run-program - (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv. - (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version - :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program) - (:export - #:run-program - #:slurp-input-stream #:vomit-output-stream - #:subprocess-error - #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process) - (:import-from :uiop/launch-program - #:%handle-if-does-not-exist #:%handle-if-exists #:%interactivep - #:input-stream #:output-stream #:error-output-stream)) -(in-package :uiop/run-program) - -;;;; Slurping a stream, typically the output of another program -(with-upgradability () - (defun call-stream-processor (fun processor stream) - "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM, -a PROCESSOR specification which is either an atom or a list specifying -a processor an keyword arguments, call the specified processor with -the given STREAM as input" - (if (consp processor) - (apply fun (first processor) stream (rest processor)) - (funcall fun processor stream))) - - (defgeneric slurp-input-stream (processor input-stream &key) - (:documentation - "SLURP-INPUT-STREAM is a generic function with two positional arguments -PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps) -the contents of the INPUT-STREAM and processes them according to a method -specified by PROCESSOR. - -Built-in methods include the following: -* if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument -* if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the - INPUT-STREAM and the rest of the list. That is (x . y) will be treated as - \(APPLY x y\) -* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream, - per copy-stream-to-stream, with appropriate keyword arguments. -* if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM - are returned as a string, as per SLURP-STREAM-STRING. -* if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES. -* if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE. -* if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS. -* if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM. -* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned. - -Programmers are encouraged to define their own methods for this generic function.")) - - #-genera - (defmethod slurp-input-stream ((function function) input-stream &key) - (funcall function input-stream)) - - (defmethod slurp-input-stream ((list cons) input-stream &key) - (apply (first list) input-stream (rest list))) - - #-genera - (defmethod slurp-input-stream ((output-stream stream) input-stream - &key linewise prefix (element-type 'character) buffer-size) - (copy-stream-to-stream - input-stream output-stream - :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) - - (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped) - (slurp-stream-string stream :stripped stripped)) - - (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped) - (slurp-stream-string stream :stripped stripped)) - - (defmethod slurp-input-stream ((x (eql :lines)) stream &key count) - (slurp-stream-lines stream :count count)) - - (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0)) - (slurp-stream-line stream :at at)) - - (defmethod slurp-input-stream ((x (eql :forms)) stream &key count) - (slurp-stream-forms stream :count count)) - - (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0)) - (slurp-stream-form stream :at at)) - - (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) - (apply 'slurp-input-stream *standard-output* stream keys)) - - (defmethod slurp-input-stream ((x null) (stream t) &key) - nil) - - (defmethod slurp-input-stream ((pathname pathname) input - &key - (element-type *default-stream-element-type*) - (external-format *utf-8-external-format*) - (if-exists :rename-and-delete) - (if-does-not-exist :create) - buffer-size - linewise) - (with-output-file (output pathname - :element-type element-type - :external-format external-format - :if-exists if-exists - :if-does-not-exist if-does-not-exist) - (copy-stream-to-stream - input output - :element-type element-type :buffer-size buffer-size :linewise linewise))) - - (defmethod slurp-input-stream (x stream - &key linewise prefix (element-type 'character) buffer-size) - (declare (ignorable stream linewise prefix element-type buffer-size)) - (cond - #+genera - ((functionp x) (funcall x stream)) - #+genera - ((output-stream-p x) - (copy-stream-to-stream - stream x - :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) - (t - (parameter-error "Invalid ~S destination ~S" 'slurp-input-stream x))))) - -;;;; Vomiting a stream, typically into the input of another program. -(with-upgradability () - (defgeneric vomit-output-stream (processor output-stream &key) - (:documentation - "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments -PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits) -some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR. - -Built-in methods include the following: -* if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument -* if PROCESSOR is a list, its first element should be a function. - It will be applied to a cons of the OUTPUT-STREAM and the rest of the list. - That is (x . y) will be treated as \(APPLY x y\) -* if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM, - per copy-stream-to-stream, with appropriate keyword arguments. -* if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM. -* if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done. - -Programmers are encouraged to define their own methods for this generic function.")) - - #-genera - (defmethod vomit-output-stream ((function function) output-stream &key) - (funcall function output-stream)) - - (defmethod vomit-output-stream ((list cons) output-stream &key) - (apply (first list) output-stream (rest list))) - - #-genera - (defmethod vomit-output-stream ((input-stream stream) output-stream - &key linewise prefix (element-type 'character) buffer-size) - (copy-stream-to-stream - input-stream output-stream - :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) - - (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri) - (princ x stream) - (when fresh-line (fresh-line stream)) - (when terpri (terpri stream)) - (values)) - - (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) - (apply 'vomit-output-stream *standard-input* stream keys)) - - (defmethod vomit-output-stream ((x null) (stream t) &key) - (values)) - - (defmethod vomit-output-stream ((pathname pathname) input - &key - (element-type *default-stream-element-type*) - (external-format *utf-8-external-format*) - (if-exists :rename-and-delete) - (if-does-not-exist :create) - buffer-size - linewise) - (with-output-file (output pathname - :element-type element-type - :external-format external-format - :if-exists if-exists - :if-does-not-exist if-does-not-exist) - (copy-stream-to-stream - input output - :element-type element-type :buffer-size buffer-size :linewise linewise))) - - (defmethod vomit-output-stream (x stream - &key linewise prefix (element-type 'character) buffer-size) - (declare (ignorable stream linewise prefix element-type buffer-size)) - (cond - #+genera - ((functionp x) (funcall x stream)) - #+genera - ((input-stream-p x) - (copy-stream-to-stream - x stream - :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) - (t - (parameter-error "Invalid ~S source ~S" 'vomit-output-stream x))))) - - -;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output. -(with-upgradability () - (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~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]" - (subprocess-error-process condition) - (subprocess-error-command condition) - (subprocess-error-code condition))))) - - (defun %check-result (exit-code &key command process ignore-error-status) - (unless ignore-error-status - (unless (eql exit-code 0) - (cerror "IGNORE-ERROR-STATUS" - 'subprocess-error :command command :code exit-code :process process))) - exit-code) - - (defun %active-io-specifier-p (specifier) - "Determines whether a run-program I/O specifier requires Lisp-side processing -via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T), -or whether it's already taken care of by the implementation's underlying run-program." - (not (typep specifier '(or null string pathname (member :interactive :output) - #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t)) - #+lispworks file-stream)))) - - (defun %run-program (command &rest keys &key &allow-other-keys) - "DEPRECATED. Use LAUNCH-PROGRAM instead." - (apply 'launch-program command keys)) - - (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner - &key - (element-type #-clozure *default-stream-element-type* #+clozure 'character) - (external-format *utf-8-external-format*) &allow-other-keys) - ;; handle redirection for run-program and system - ;; SPEC is the specification for the subprocess's input or output or error-output - ;; TVAL is the value used if the spec is T - ;; GF is the generic function to call to handle arbitrary values of SPEC - ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background - ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it) - ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument - ;; FUN is a function of the new reduced spec and an activity function to call with a stream - ;; when the subprocess is active and communicating through that stream. - ;; ACTIVEP is a boolean true if we will get to run code while the process is running - ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open. - ;; RETURNER is a function called with the value of the activity. - ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way. - (declare (ignorable stream-easy-p)) - (let* ((actual-spec (if (eq spec t) tval spec)) - (activity-spec (if (eq actual-spec :output) - (ecase direction - ((:input :output) - (parameter-error "~S does not allow ~S as a ~S spec" - 'run-program :output direction)) - ((:error-output) - nil)) - actual-spec))) - (labels ((activity (stream) - (call-function returner (call-stream-processor gf activity-spec stream))) - (easy-case () - (funcall fun actual-spec nil)) - (hard-case () - (if activep - (funcall fun :stream #'activity) - (with-temporary-file (:pathname tmp) - (ecase direction - (:input - (with-output-file (s tmp :if-exists :overwrite - :external-format external-format - :element-type element-type) - (activity s)) - (funcall fun tmp nil)) - ((:output :error-output) - (multiple-value-prog1 (funcall fun tmp nil) - (with-input-file (s tmp - :external-format external-format - :element-type element-type) - (activity s))))))))) - (typecase activity-spec - ((or null string pathname (eql :interactive)) - (easy-case)) - #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard - (stream - (if stream-easy-p (easy-case) (hard-case))) - (t - (hard-case)))))) - - (defmacro place-setter (place) - (when place - (let ((value (gensym))) - `#'(lambda (,value) (setf ,place ,value))))) - - (defmacro with-program-input (((reduced-input-var - &optional (input-activity-var (gensym) iavp)) - input-form &key setf stream-easy-p active keys) &body body) - `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p - #'(lambda (,reduced-input-var ,input-activity-var) - ,@(unless iavp `((declare (ignore ,input-activity-var)))) - ,@body) - :input ,input-form ,active (place-setter ,setf) ,keys)) - - (defmacro with-program-output (((reduced-output-var - &optional (output-activity-var (gensym) oavp)) - output-form &key setf stream-easy-p active keys) &body body) - `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p - #'(lambda (,reduced-output-var ,output-activity-var) - ,@(unless oavp `((declare (ignore ,output-activity-var)))) - ,@body) - :output ,output-form ,active (place-setter ,setf) ,keys)) - - (defmacro with-program-error-output (((reduced-error-output-var - &optional (error-output-activity-var (gensym) eoavp)) - error-output-form &key setf stream-easy-p active keys) - &body body) - `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p - #'(lambda (,reduced-error-output-var ,error-output-activity-var) - ,@(unless eoavp `((declare (ignore ,error-output-activity-var)))) - ,@body) - :error-output ,error-output-form ,active (place-setter ,setf) ,keys)) - - (defun %use-launch-program (command &rest keys - &key input output error-output ignore-error-status &allow-other-keys) - ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM - #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl) - (progn - command keys input output error-output ignore-error-status ;; ignore - (not-implemented-error '%use-launch-program)) - (when (member :stream (list input output error-output)) - (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument" - 'run-program :stream)) - (let* ((active-input-p (%active-io-specifier-p input)) - (active-output-p (%active-io-specifier-p output)) - (active-error-output-p (%active-io-specifier-p error-output)) - (activity - (cond - (active-output-p :output) - (active-input-p :input) - (active-error-output-p :error-output) - (t nil))) - output-result error-output-result exit-code process-info) - (with-program-output ((reduced-output output-activity) - output :keys keys :setf output-result - :stream-easy-p t :active (eq activity :output)) - (with-program-error-output ((reduced-error-output error-output-activity) - error-output :keys keys :setf error-output-result - :stream-easy-p t :active (eq activity :error-output)) - (with-program-input ((reduced-input input-activity) - input :keys keys - :stream-easy-p t :active (eq activity :input)) - (setf process-info - (apply 'launch-program command - :input reduced-input :output reduced-output - :error-output (if (eq error-output :output) :output reduced-error-output) - keys)) - (labels ((get-stream (stream-name &optional fallbackp) - (or (slot-value process-info stream-name) - (when fallbackp - (slot-value process-info 'bidir-stream)))) - (run-activity (activity stream-name &optional fallbackp) - (if-let (stream (get-stream stream-name fallbackp)) - (funcall activity stream) - (error 'subprocess-error - :code `(:missing ,stream-name) - :command command :process process-info)))) - (unwind-protect - (ecase activity - ((nil)) - (:input (run-activity input-activity 'input-stream t)) - (:output (run-activity output-activity 'output-stream t)) - (:error-output (run-activity error-output-activity 'error-output-stream))) - (close-streams process-info) - (setf exit-code (wait-process process-info))))))) - (%check-result exit-code - :command command :process process-info - :ignore-error-status ignore-error-status) - (values output-result error-output-result exit-code))) - - (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM - (etypecase command - (string command) - (list (escape-shell-command - (os-cond - ((os-unix-p) (cons "exec" command)) - (t command)))))) - - (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM - (flet ((redirect (spec operator) - (let ((pathname - (typecase spec - (null (null-device-pathname)) - (string (parse-native-namestring spec)) - (pathname spec) - ((eql :output) - (unless (equal operator " 2>>") - (parameter-error "~S: only the ~S argument can be ~S" - 'run-program :error-output :output)) - (return-from redirect '(" 2>&1")))))) - (when pathname - (list operator " " - (escape-shell-token (native-namestring pathname))))))) - (let* ((redirections (append (redirect in " <") (redirect out " >>") (redirect err " 2>>"))) - (normalized (%normalize-system-command command)) - (directory (or directory #+(or abcl xcl) (getcwd))) - (chdir (when directory - (let ((dir-arg (escape-shell-token (native-namestring directory)))) - (os-cond - ((os-unix-p) `("cd " ,dir-arg " ; ")) - ((os-windows-p) `("cd /d " ,dir-arg " & "))))))) - (reduce/strcat - (os-cond - ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized)) - ((os-windows-p) `(,@redirections " (" ,@chdir ,normalized ")"))))))) - - (defun %system (command &rest keys &key directory - input (if-input-does-not-exist :error) - output (if-output-exists :supersede) - error-output (if-error-output-exists :supersede) - &allow-other-keys) - "A portable abstraction of a low-level call to libc's system()." - (declare (ignorable keys directory input if-input-does-not-exist output - if-output-exists error-output if-error-output-exists)) - (when (member :stream (list input output error-output)) - (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument" - 'run-program :stream)) - #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) - (let (#+(or abcl ecl mkcl) - (version (parse-version - #-abcl - (lisp-implementation-version) - #+abcl - (second (split-string (implementation-identifier) :separator '(#\-)))))) - (nest - #+abcl (unless (lexicographic< '< version '(1 4 0))) - #+ecl (unless (lexicographic<= '< version '(16 0 0))) - #+mkcl (unless (lexicographic<= '< version '(1 1 9))) - (return-from %system - (wait-process - (apply 'launch-program (%normalize-system-command command) keys))))) - #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl) - (let ((%command (%redirected-system-command command input output error-output directory))) - ;; see comments for these functions - (%handle-if-does-not-exist input if-input-does-not-exist) - (%handle-if-exists output if-output-exists) - (%handle-if-exists error-output if-error-output-exists) - #+abcl (ext:run-shell-command %command) - #+(or clasp ecl) (let ((*standard-input* *stdin*) - (*standard-output* *stdout*) - (*error-output* *stderr*)) - (ext:system %command)) - #+clisp - (let ((raw-exit-code - (or - #.`(#+os-windows ,@'(ext:run-shell-command %command) - #+os-unix ,@'(ext:run-program "/bin/sh" :arguments `("-c" ,%command)) - :wait t :input :terminal :output :terminal) - 0))) - (if (minusp raw-exit-code) - (- 128 raw-exit-code) - raw-exit-code)) - #+cormanlisp (win32:system %command) - #+gcl (system:system %command) - #+genera (not-implemented-error '%system) - #+(and lispworks os-windows) - (system:call-system %command :current-directory directory :wait t) - #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) - #+mkcl (mkcl:system %command) - #+xcl (system:%run-shell-command %command))) - - (defun %use-system (command &rest keys - &key input output error-output ignore-error-status &allow-other-keys) - ;; helper for RUN-PROGRAM when using %system - (let (output-result error-output-result exit-code) - (with-program-output ((reduced-output) - output :keys keys :setf output-result) - (with-program-error-output ((reduced-error-output) - error-output :keys keys :setf error-output-result) - (with-program-input ((reduced-input) input :keys keys) - (setf exit-code (apply '%system command - :input reduced-input :output reduced-output - :error-output reduced-error-output keys))))) - (%check-result exit-code - :command command - :ignore-error-status ignore-error-status) - (values output-result error-output-result exit-code))) - - (defun run-program (command &rest keys - &key ignore-error-status (force-shell nil force-shell-suppliedp) - input (if-input-does-not-exist :error) - output (if-output-exists :supersede) - error-output (if-error-output-exists :supersede) - (element-type #-clozure *default-stream-element-type* #+clozure 'character) - (external-format *utf-8-external-format*) - &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); -_synchronously_ process its output as specified and return the processing results -when the program and its output processing are complete. - -Always call a shell (rather than directly execute the command when possible) -if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is -specified to be NIL. - -Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0), -unless IGNORE-ERROR-STATUS is specified. - -If OUTPUT is a pathname, a string designating a pathname, or NIL (the default) -designating the null device, the file at that path is used as output. -If it's :INTERACTIVE, output is inherited from the current process; -beware that this may be different from your *STANDARD-OUTPUT*, -and under SLIME will be on your *inferior-lisp* buffer. -If it's T, output goes to your current *STANDARD-OUTPUT* stream. -Otherwise, OUTPUT should be a value that is a suitable first argument to -SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments. -In this case, RUN-PROGRAM will create a temporary stream for the program output; -the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM, -using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords). -The primary value resulting from that call (or NIL if no call was needed) -will be the first value returned by RUN-PROGRAM. -E.g., using :OUTPUT :STRING will have it return the entire output stream as a string. -And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string -stripped of any ending newline. - -IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a -pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the -default). The meaning of these values and their effect on the case -where OUTPUT does not exist, is analogous to the IF-EXISTS parameter -to OPEN with :DIRECTION :OUTPUT. - -ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned -as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*. -Also :OUTPUT means redirecting the error output to the output stream, -in which case NIL is returned. - -IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it -affects ERROR-OUTPUT rather than OUTPUT. - -INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used, -no value is returned, and T designates the *STANDARD-INPUT*. - -IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string -or a pathname, can take the values :CREATE and :ERROR (the -default). The meaning of these values is analogous to the -IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT. - -ELEMENT-TYPE and EXTERNAL-FORMAT are passed on -to your Lisp implementation, when applicable, for creation of the output stream. - -One and only one of the stream slurping or vomiting may or may not happen -in parallel in parallel with the subprocess, -depending on options and implementation, -and with priority being given to output processing. -Other streams are completely produced or consumed -before or after the subprocess is spawned, using temporary files. - -RUN-PROGRAM returns 3 values: -0- the result of the OUTPUT slurping if any, or NIL -1- the result of the ERROR-OUTPUT slurping if any, or NIL -2- either 0 if the subprocess exited with success status, -or an indication of failure via the EXIT-CODE of the process" - (declare (ignorable input output error-output if-input-does-not-exist if-output-exists - if-error-output-exists element-type external-format ignore-error-status)) - #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl) - (not-implemented-error 'run-program) - (apply (if (or force-shell - ;; Per doc string, set FORCE-SHELL to T if we get command as a string. - ;; But don't override user's specified preference. [2015/06/29:rpg] - (and (stringp command) - (or (not force-shell-suppliedp) - #-(or allegro clisp clozure sbcl) (os-cond ((os-windows-p) t)))) - #+(or clasp clisp cormanlisp gcl (and lispworks os-windows) mcl xcl) t - ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program - #+ecl #.(if-let (ver (parse-version (lisp-implementation-version))) - (lexicographic<= '< ver '(16 0 0))) - #+(and lispworks os-unix) (%interactivep input output error-output)) - '%use-system '%use-launch-program) - command keys))) - -;;;; --------------------------------------------------------------------------- -;;;; Generic support for configuration files - -(uiop/package:define-package :uiop/configuration - (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27. - (:use :uiop/package :uiop/common-lisp :uiop/utility - :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) - (:export - #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver - #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem - #:get-folder-path - #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs - #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames - #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames - #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname - #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory - #:configuration-inheritance-directive-p - #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache* - #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook - #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* - #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration - #:uiop-directory)) -(in-package :uiop/configuration) - -(with-upgradability () - (define-condition invalid-configuration () - ((form :reader condition-form :initarg :form) - (location :reader condition-location :initarg :location) - (format :reader condition-format :initarg :format) - (arguments :reader condition-arguments :initarg :arguments :initform nil)) - (:report (lambda (c s) - (format s (compatfmt "~@<~? (will be skipped)~@:>") - (condition-format c) - (list* (condition-form c) (condition-location c) - (condition-arguments c)))))) - - (defun configuration-inheritance-directive-p (x) - "Is X a configuration inheritance directive?" - (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) - (or (member x kw) - (and (length=n-p x 1) (member (car x) kw))))) - - (defun report-invalid-form (reporter &rest args) - "Report an invalid form according to REPORTER and various ARGS" - (etypecase reporter - (null - (apply 'error 'invalid-configuration args)) - (function - (apply reporter args)) - ((or symbol string) - (apply 'error reporter args)) - (cons - (apply 'apply (append reporter args))))) - - (defvar *ignored-configuration-form* nil - "Have configuration forms been ignored while parsing the configuration?") - - (defun validate-configuration-form (form tag directive-validator - &key location invalid-form-reporter) - "Validate a configuration FORM. By default it will raise an error if the -FORM is not valid. Otherwise it will return the validated form. - Arguments control the behavior: - The configuration FORM should be of the form (TAG . ) - Each element of will be checked by first seeing if it's a configuration inheritance -directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR -on it. - In the event of an invalid form, INVALID-FORM-REPORTER will be used to control -reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where -the configuration form appeared." - (unless (and (consp form) (eq (car form) tag)) - (setf *ignored-configuration-form* t) - (report-invalid-form invalid-form-reporter :form form :location location) - (return-from validate-configuration-form nil)) - (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) - :for directive :in (cdr form) - :when (cond - ((configuration-inheritance-directive-p directive) - (incf inherit) t) - ((eq directive :ignore-invalid-entries) - (setf ignore-invalid-p t) t) - ((funcall directive-validator directive) - t) - (ignore-invalid-p - nil) - (t - (setf *ignored-configuration-form* t) - (report-invalid-form invalid-form-reporter :form directive :location location) - nil)) - :do (push directive x) - :finally - (unless (= inherit 1) - (report-invalid-form invalid-form-reporter - :form form :location location - ;; we throw away the form and location arguments, hence the ~2* - ;; this is necessary because of the report in INVALID-CONFIGURATION - :format (compatfmt "~@") - :arguments '(:inherit-configuration :ignore-inherited-configuration))) - (return (nreverse x)))) - - (defun validate-configuration-file (file validator &key description) - "Validate a configuration FILE. The configuration file should have only one s-expression -in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error -reporting." - (let ((forms (read-file-forms file))) - (unless (length=n-p forms 1) - (error (compatfmt "~@~%") - description forms)) - (funcall validator (car forms) :location file))) - - (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter) - "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will -be applied to the results to yield a configuration form. Current -values of TAG include :source-registry and :output-translations." - (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list - (remove-if - 'hidden-pathname-p - (directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) - #'string< :key #'namestring))) - `(,tag - ,@(loop :for file :in files :append - (loop :with ignore-invalid-p = nil - :for form :in (read-file-forms file) - :when (eq form :ignore-invalid-entries) - :do (setf ignore-invalid-p t) - :else - :when (funcall validator form) - :collect form - :else - :when ignore-invalid-p - :do (setf *ignored-configuration-form* t) - :else - :do (report-invalid-form invalid-form-reporter :form form :location file))) - :inherit-configuration))) - - (defun resolve-relative-location (x &key ensure-directory wilden) - "Given a designator X for an relative location, resolve it to a pathname." - (ensure-pathname - (etypecase x - (null nil) - (pathname x) - (string (parse-unix-namestring - x :ensure-directory ensure-directory)) - (cons - (if (null (cdr x)) - (resolve-relative-location - (car x) :ensure-directory ensure-directory :wilden wilden) - (let* ((car (resolve-relative-location - (car x) :ensure-directory t :wilden nil))) - (merge-pathnames* - (resolve-relative-location - (cdr x) :ensure-directory ensure-directory :wilden wilden) - car)))) - ((eql :*/) *wild-directory*) - ((eql :**/) *wild-inferiors*) - ((eql :*.*.*) *wild-file*) - ((eql :implementation) - (parse-unix-namestring - (implementation-identifier) :ensure-directory t)) - ((eql :implementation-type) - (parse-unix-namestring - (string-downcase (implementation-type)) :ensure-directory t)) - ((eql :hostname) - (parse-unix-namestring (hostname) :ensure-directory t))) - :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*)))) - :want-relative t)) - - (defvar *here-directory* nil - "This special variable is bound to the currect directory during calls to -PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here -directive.") - - (defvar *user-cache* nil - "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache") - - (defun resolve-absolute-location (x &key ensure-directory wilden) - "Given a designator X for an absolute location, resolve it to a pathname" - (ensure-pathname - (etypecase x - (null nil) - (pathname x) - (string - (let ((p #-mcl (parse-namestring x) - #+mcl (probe-posix x))) - #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) - (if ensure-directory (ensure-directory-pathname p) p))) - (cons - (return-from resolve-absolute-location - (if (null (cdr x)) - (resolve-absolute-location - (car x) :ensure-directory ensure-directory :wilden wilden) - (merge-pathnames* - (resolve-relative-location - (cdr x) :ensure-directory ensure-directory :wilden wilden) - (resolve-absolute-location - (car x) :ensure-directory t :wilden nil))))) - ((eql :root) - ;; special magic! we return a relative pathname, - ;; but what it means to the output-translations is - ;; "relative to the root of the source pathname's host and device". - (return-from resolve-absolute-location - (let ((p (make-pathname :directory '(:relative)))) - (if wilden (wilden p) p)))) - ((eql :home) (user-homedir-pathname)) - ((eql :here) (resolve-absolute-location - (or *here-directory* (pathname-directory-pathname (truename (load-pathname)))) - :ensure-directory t :wilden nil)) - ((eql :user-cache) (resolve-absolute-location - *user-cache* :ensure-directory t :wilden nil))) - :wilden (and wilden (not (pathnamep x))) - :resolve-symlinks *resolve-symlinks* - :want-absolute t)) - - ;; Try to override declaration in previous versions of ASDF. - (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean) - (:ensure-directory boolean)) t) resolve-location)) - - (defun resolve-location (x &key ensure-directory wilden directory) - "Resolve location designator X into a PATHNAME" - ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory - (loop :with dirp = (or directory ensure-directory) - :with (first . rest) = (if (atom x) (list x) x) - :with path = (or (resolve-absolute-location - first :ensure-directory (and (or dirp rest) t) - :wilden (and wilden (null rest))) - (return nil)) - :for (element . morep) :on rest - :for dir = (and (or morep dirp) t) - :for wild = (and wilden (not morep)) - :for sub = (merge-pathnames* - (resolve-relative-location - element :ensure-directory dir :wilden wild) - path) - :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub)) - :finally (return path))) - - (defun location-designator-p (x) - "Is X a designator for a location?" - ;; NIL means "skip this entry", or as an output translation, same as translation input. - ;; T means "any input" for a translation, or as output, same as translation input. - (flet ((absolute-component-p (c) - (typep c '(or string pathname - (member :root :home :here :user-cache)))) - (relative-component-p (c) - (typep c '(or string pathname - (member :*/ :**/ :*.*.* :implementation :implementation-type))))) - (or (typep x 'boolean) - (absolute-component-p x) - (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) - - (defun location-function-p (x) - "Is X the specification of a location function?" - ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support. - (and (length=n-p x 2) (eq (car x) :function))) - - (defvar *clear-configuration-hook* '()) - - (defun register-clear-configuration-hook (hook-function &optional call-now-p) - "Register a function to be called when clearing configuration" - (register-hook-function '*clear-configuration-hook* hook-function call-now-p)) - - (defun clear-configuration () - "Call the functions in *CLEAR-CONFIGURATION-HOOK*" - (call-functions *clear-configuration-hook*)) - - (register-image-dump-hook 'clear-configuration) - - (defun upgrade-configuration () - "If a previous version of ASDF failed to read some configuration, try again now." - (when *ignored-configuration-form* - (clear-configuration) - (setf *ignored-configuration-form* nil))) - - - (defun get-folder-path (folder) - "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path, -this function tries to locate the Windows FOLDER for one of -:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA. - Returns NIL when the folder is not defined (e.g., not on Windows)." - (or #+(and lispworks os-windows) (sys:get-folder-path folder) - ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - (ecase folder - (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA") - (subpathname* (get-folder-path :appdata) "Local"))) - (:appdata (getenv-absolute-directory "APPDATA")) - (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") - (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) - - - ;; Support for the XDG Base Directory Specification - (defun xdg-data-home (&rest more) - "Returns an absolute pathname for the directory containing user-specific data files. -MORE may contain specifications for a subpath relative to this directory: a -subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see -also \"Configuration DSL\"\) in the ASDF manual." - (resolve-absolute-location - `(,(or (getenv-absolute-directory "XDG_DATA_HOME") - (os-cond - ((os-windows-p) (get-folder-path :local-appdata)) - (t (subpathname (user-homedir-pathname) ".local/share/")))) - ,more))) - - (defun xdg-config-home (&rest more) - "Returns a pathname for the directory containing user-specific configuration files. -MORE may contain specifications for a subpath relative to this directory: a -subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see -also \"Configuration DSL\"\) in the ASDF manual." - (resolve-absolute-location - `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME") - (os-cond - ((os-windows-p) (xdg-data-home "config/")) - (t (subpathname (user-homedir-pathname) ".config/")))) - ,more))) - - (defun xdg-data-dirs (&rest more) - "The preference-ordered set of additional paths to search for data files. -Returns a list of absolute directory pathnames. -MORE may contain specifications for a subpath relative to these directories: a -subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see -also \"Configuration DSL\"\) in the ASDF manual." - (mapcar #'(lambda (d) (resolve-location `(,d ,more))) - (or (remove nil (getenv-absolute-directories "XDG_DATA_DIRS")) - (os-cond - ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata))) - ;; macOS' separate read-only system volume means that the contents - ;; of /usr/share are frozen by Apple. Unlike when running natively - ;; on macOS, Genera must access the filesystem through NFS. Attempting - ;; to export either the root (/) or /usr/share simply doesn't work. - ;; (Genera will go into an infinite loop trying to access those mounts.) - ;; So, when running Genera on macOS, only search /usr/local/share. - ((os-genera-p) - #+Genera (sys:system-case - (darwin-vlm (mapcar 'parse-unix-namestring '("/usr/local/share/"))) - (otherwise (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/"))))) - (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/"))))))) - - (defun xdg-config-dirs (&rest more) - "The preference-ordered set of additional base paths to search for configuration files. -Returns a list of absolute directory pathnames. -MORE may contain specifications for a subpath relative to these directories: -subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see -also \"Configuration DSL\"\) in the ASDF manual." - (mapcar #'(lambda (d) (resolve-location `(,d ,more))) - (or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIRS")) - (os-cond - ((os-windows-p) (xdg-data-dirs "config/")) - (t (mapcar 'parse-unix-namestring '("/etc/xdg/"))))))) - - (defun xdg-cache-home (&rest more) - "The base directory relative to which user specific non-essential data files should be stored. -Returns an absolute directory pathname. -MORE may contain specifications for a subpath relative to this directory: a -subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see -also \"Configuration DSL\"\) in the ASDF manual." - (resolve-absolute-location - `(,(or (getenv-absolute-directory "XDG_CACHE_HOME") - (os-cond - ((os-windows-p) (xdg-data-home "cache/")) - (t (subpathname* (user-homedir-pathname) ".cache/")))) - ,more))) - - (defun xdg-runtime-dir (&rest more) - "Pathname for user-specific non-essential runtime files and other file objects, -such as sockets, named pipes, etc. -Returns an absolute directory pathname. -MORE may contain specifications for a subpath relative to this directory: a -subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see -also \"Configuration DSL\"\) in the ASDF manual." - ;; The XDG spec says that if not provided by the login system, the application should - ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL. - (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more))) - - ;;; NOTE: modified the docstring because "system user configuration - ;;; directories" seems self-contradictory. I'm not sure my wording is right. - (defun system-config-pathnames (&rest more) - "Return a list of directories where are stored the system's default user configuration information. -MORE may contain specifications for a subpath relative to these directories: a -subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see -also \"Configuration DSL\"\) in the ASDF manual." - (declare (ignorable more)) - (os-cond - ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more)))))) - - (defun filter-pathname-set (dirs) - "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list." - (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal)) - - (defun xdg-data-pathnames (&rest more) - "Return a list of absolute pathnames for application data directories. With APP, -returns directory for data for that application, without APP, returns the set of directories -for storing all application configurations. -MORE may contain specifications for a subpath relative to these directories: a -subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see -also \"Configuration DSL\"\) in the ASDF manual." - (filter-pathname-set - `(,(xdg-data-home more) - ,@(xdg-data-dirs more)))) - - (defun xdg-config-pathnames (&rest more) - "Return a list of pathnames for application configuration. -MORE may contain specifications for a subpath relative to these directories: a -subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see -also \"Configuration DSL\"\) in the ASDF manual." - (filter-pathname-set - `(,(xdg-config-home more) - ,@(xdg-config-dirs more)))) - - (defun find-preferred-file (files &key (direction :input)) - "Find first file in the list of FILES that exists (for direction :input or :probe) -or just the first one (for direction :output or :io). - Note that when we say \"file\" here, the files in question may be directories." - (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files)) - - (defun xdg-data-pathname (&optional more (direction :input)) - (find-preferred-file (xdg-data-pathnames more) :direction direction)) - - (defun xdg-config-pathname (&optional more (direction :input)) - (find-preferred-file (xdg-config-pathnames more) :direction direction)) - - (defun compute-user-cache () - "Compute (and return) the location of the default user-cache for translate-output -objects. Side-effects for cached file location computation." - (setf *user-cache* (xdg-cache-home "common-lisp" :implementation))) - (register-image-restore-hook 'compute-user-cache) - - (defun uiop-directory () - "Try to locate the UIOP source directory at runtime" - (labels ((pf (x) (ignore-errors (probe-file* x))) - (sub (x y) (pf (subpathname x y))) - (ssd (x) (ignore-errors (symbol-call :asdf :system-source-directory x)))) - ;; NB: conspicuously *not* including searches based on #.(current-lisp-pathname) - (or - ;; Look under uiop if available as source override, under asdf if avaiable as source - (ssd "uiop") - (sub (ssd "asdf") "uiop/") - ;; Look in recommended path for user-visible source installation - (sub (user-homedir-pathname) "common-lisp/asdf/uiop/") - ;; Look in XDG paths under known package names for user-invisible source installation - (xdg-data-pathname "common-lisp/source/asdf/uiop/") - (xdg-data-pathname "common-lisp/source/cl-asdf/uiop/") ; traditional Debian location - ;; The last one below is useful for Fare, primary (sole?) known user - (sub (user-homedir-pathname) "cl/asdf/uiop/") - (cerror "Configure source registry to include UIOP source directory and retry." - "Unable to find UIOP directory") - (uiop-directory))))) -;;; ------------------------------------------------------------------------- -;;; Hacks for backward-compatibility with older versions of UIOP - -(uiop/package:define-package :uiop/backward-driver - (:recycle :uiop/backward-driver :asdf/backward-driver :uiop) - (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version - :uiop/pathname :uiop/stream :uiop/os :uiop/image - :uiop/run-program :uiop/lisp-build :uiop/configuration) - (:export - #:coerce-pathname - #:user-configuration-directories #:system-configuration-directories - #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory - #:version-compatible-p)) -(in-package :uiop/backward-driver) - -(eval-when (:compile-toplevel :load-toplevel :execute) -(with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2" :warning "3.4")) - ;; Backward compatibility with ASDF 2.000 to 2.26 - - ;; For backward-compatibility only, for people using internals - ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release) - ;; Will be removed after 2015-12. - (defun coerce-pathname (name &key type defaults) - "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead." - (parse-unix-namestring name :type type :defaults defaults)) - - ;; Backward compatibility for ASDF 2.27 to 3.1.4 - (defun user-configuration-directories () - "Return the current user's list of user configuration directories -for configuring common-lisp. -DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead." - (xdg-config-pathnames "common-lisp")) - (defun system-configuration-directories () - "Return the list of system configuration directories for common-lisp. -DEPRECATED. Use UIOP:SYSTEM-CONFIG-PATHNAMES (with argument \"common-lisp\"), -instead." - (system-config-pathnames "common-lisp")) - (defun in-first-directory (dirs x &key (direction :input)) - "Finds the first appropriate file named X in the list of DIRS for I/O -in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE). -If direction is :INPUT or :PROBE, will return the first extant file named -X in one of the DIRS. -If direction is :OUTPUT or :IO, will simply return the file named X in the -first element of DIRS that exists. DEPRECATED." - (find-preferred-file - (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs) - :direction direction)) - (defun in-user-configuration-directory (x &key (direction :input)) - "Return the file named X in the user configuration directory for common-lisp. -DEPRECATED." - (xdg-config-pathname `("common-lisp" ,x) direction)) - (defun in-system-configuration-directory (x &key (direction :input)) - "Return the pathname for the file named X under the system configuration directory -for common-lisp. DEPRECATED." - (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction)) - - - ;; Backward compatibility with ASDF 1 to ASDF 2.32 - - (defun version-compatible-p (provided-version required-version) - "Is the provided version a compatible substitution for the required-version? -If major versions differ, it's not compatible. -If they are equal, then any later version is compatible, -with later being determined by a lexicographical comparison of minor numbers. -DEPRECATED." - (let ((x (parse-version provided-version nil)) - (y (parse-version required-version nil))) - (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x))))))) - -;;;; --------------------------------------------------------------------------- -;;;; Re-export all the functionality in UIOP - -(uiop/package:define-package :uiop/driver - (:nicknames :uiop ;; Official name we recommend should be used for all references to uiop symbols. - :asdf/driver) ;; DO NOT USE, a deprecated name, not supported anymore. - ;; We should remove the name :asdf/driver at some point, - ;; but not until it has been eradicated from Quicklisp for a year or two. - ;; The last known user was cffi (PR merged in May 2020). - (:use :uiop/common-lisp) - ;; NB: We are not reexporting uiop/common-lisp - ;; which include all of CL with compatibility modifications on select platforms, - ;; because that would cause potential conflicts for packages that - ;; might want to :use (:cl :uiop) or :use (:closer-common-lisp :uiop), etc. - (:use-reexport - :uiop/package* :uiop/utility :uiop/version - :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image - :uiop/launch-program :uiop/run-program - :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) - -;; Provide both lowercase and uppercase, to satisfy more implementations. -(provide "uiop") (provide "UIOP") -;;;; ------------------------------------------------------------------------- -;;;; Handle upgrade as forward- and backward-compatibly as possible -;; See https://bugs.launchpad.net/asdf/+bug/485687 - -(uiop/package:define-package :asdf/upgrade - (:recycle :asdf/upgrade :asdf) - (:use :uiop/common-lisp :uiop) - (:export - #:asdf-version #:*previous-asdf-versions* #:*asdf-version* - #:asdf-message #:*verbose-out* - #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter* - #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf - ;; There will be no symbol left behind! - #:with-asdf-deprecation - #:intern*) - (:import-from :uiop/package #:intern* #:find-symbol*)) -(in-package :asdf/upgrade) - -;;; Special magic to detect if this is an upgrade - -(with-upgradability () - (defun asdf-version () - "Exported interface to the version of ASDF currently installed. A string. -You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")." - (when (find-package :asdf) - (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) - (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf)) - (rev (and revsym (boundp revsym) (symbol-value revsym)))) - (etypecase rev - (string rev) - (cons (format nil "~{~D~^.~}" rev)) - (null "1.0")))))) - ;; This (private) variable contains a list of versions of previously loaded variants of ASDF, - ;; from which ASDF was upgraded. - ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly. - (defvar *previous-asdf-versions* - (let ((previous (asdf-version))) - (when previous - ;; Punt on upgrade from ASDF1 or ASDF2, by renaming (or deleting) the package. - (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature. - (let ((away (format nil "~A-~A" :asdf previous))) - (rename-package :asdf away) - (when *load-verbose* - (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))) - (list previous)))) - ;; This public variable will be bound shortly to the currently loaded version of ASDF. - (defvar *asdf-version* nil) - ;; We need to clear systems from versions older than the one in this (private) parameter. - ;; The latest incompatible defclass is 2.32.13 renaming a slot in component, - ;; or 3.2.0.2 for CCL (incompatibly changing some superclasses). - ;; the latest incompatible gf change is in 3.1.7.20 (see redefined-functions below). - (defparameter *oldest-forward-compatible-asdf-version* "3.2.0.2") - ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages - (defvar *verbose-out* nil) - ;; Private function by which ASDF outputs progress messages and warning messages: - (defun asdf-message (format-string &rest format-args) - (when *verbose-out* (apply 'format *verbose-out* format-string format-args))) - ;; Private hook for functions to run after ASDF has upgraded itself from an older variant: - (defvar *post-upgrade-cleanup-hook* ()) - ;; Private variable for post upgrade cleanup to communicate if an upgrade has - ;; actually occured. - (defvar *asdf-upgraded-p*) - ;; Private function to detect whether the current upgrade counts as an incompatible - ;; data schema upgrade implying the need to drop data. - (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*)) - (and *previous-asdf-versions* - (version< (first *previous-asdf-versions*) oldest-compatible-version))) - ;; Private variant of defparameter that works in presence of incompatible upgrades: - ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change), - ;; but behaves like defparameter if in presence of an incompatible upgrade. - (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*)) - (let* ((name (string-trim "*" var)) - (valfun (intern (format nil "%~A-~A-~A" :compute name :value)))) - `(progn - (defun ,valfun () ,value) - (defvar ,var (,valfun) ,@(ensure-list docstring)) - (when (upgrading-p ,version) - (setf ,var (,valfun)))))) - ;; Private macro to declare sections of code that are only compiled and run when upgrading. - ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects, - ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs. - (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*) - (upgrading-p `(upgrading-p ,version)) when) &body body) - "A wrapper macro for code that should only be run when upgrading a -previously-loaded version of ASDF." - `(with-upgradability () - (when (and ,upgrading-p ,@(when when `(,when))) - (handler-bind ((style-warning #'muffle-warning)) - (eval '(progn ,@body)))))) - ;; Only now can we safely update the version. - (let* (;; For bug reporting sanity, please always bump this version when you modify this file. - ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8 - ;; can help you do these changes in synch (look at the source for documentation). - ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp. - ;; "3.4" would be the general branch for major version 3, minor version 4. - ;; "3.4.5" would be an official release in the 3.4 branch. - ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. - ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 - ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "3.3.6") - (existing-version (asdf-version))) - (setf *asdf-version* asdf-version) - (when (and existing-version (not (equal asdf-version existing-version))) - (push existing-version *previous-asdf-versions*) - (when (or *verbose-out* *load-verbose*) - (format (or *verbose-out* *trace-output*) - (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") - existing-version asdf-version))))) - -;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined -(when-upgrading () - (let* ((previous-version (first *previous-asdf-versions*)) - (redefined-functions ;; List of functions that changed incompatibly since 2.27: - ;; gf signature changed, defun that became a generic function (but not way around), - ;; method removed that will mess up with new ones - ;; (especially :around :before :after, more specific or call-next-method'ed method) - ;; and/or semantics otherwise modified. Oops. - ;; NB: it's too late to do anything about functions in UIOP! - ;; If you introduce some critical incompatibility there, you MUST change the function name. - ;; Note that we don't need do anything about functions that changed incompatibly - ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade. - ;; Also, the strong constraints apply most importantly for functions called from - ;; the continuation of compiling or loading some of the code in ASDF or UIOP. - ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36 - ;; and at https://gitlab.common-lisp.net/asdf/asdf/-/merge_requests/141 - `(,@(when (version< previous-version "2.31") '(#:normalize-version)) ;; pathname became &key - ,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2 - ,@(when (version< previous-version "3.1.7.20") '(#:find-component)))) ;; added &key registered - (redefined-classes - ;; with the old ASDF during upgrade, and many implementations bork - (when (or #+(or clozure mkcl) t) - '((#:compile-concatenated-source-op (#:operation) ()) - (#:compile-bundle-op (#:operation) ()) - (#:concatenate-source-op (#:operation) ()) - (#:dll-op (#:operation) ()) - (#:lib-op (#:operation) ()) - (#:monolithic-compile-bundle-op (#:operation) ()) - (#:monolithic-concatenate-source-op (#:operation) ()))))) - (loop :for name :in redefined-functions - :for sym = (find-symbol* name :asdf nil) - :do (when sym (fmakunbound sym))) - (labels ((asym (x) (multiple-value-bind (s p) - (if (consp x) (values (car x) (cadr x)) (values x :asdf)) - (find-symbol* s p nil))) - (asyms (l) (mapcar #'asym l))) - (loop :for (name superclasses slots) :in redefined-classes - :for sym = (find-symbol* name :asdf nil) - :when (and sym (find-class sym)) - :do #+ccl (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots))) - #-ccl (setf (find-class sym) nil))))) ;; mkcl - -;;; Self-upgrade functions -(with-upgradability () - ;; This private function is called at the end of asdf/footer and ensures that, - ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called. - (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*))) - (let ((new-version (asdf-version))) - (unless (equal old-version new-version) - (push new-version *previous-asdf-versions*) - (when (boundp '*asdf-upgraded-p*) - (setf *asdf-upgraded-p* t)) - (when old-version - (if (version<= new-version old-version) - (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") - old-version new-version) - (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") - old-version new-version)) - ;; In case the previous version was too old to be forward-compatible, clear systems. - ;; TODO: if needed, we may have to define a separate hook to run - ;; in case of forward-compatible upgrade. - ;; Or to move the tests forward-compatibility test inside each hook function? - (unless (version<= *oldest-forward-compatible-asdf-version* old-version) - (call-functions (reverse *post-upgrade-cleanup-hook*))) - t)))) - - (defun upgrade-asdf () - "Try to upgrade of ASDF. If a different version was used, return T. - We need do that before we operate on anything that may possibly depend on ASDF." - (let ((*load-print* nil) - (*compile-print* nil) - (*asdf-upgraded-p* nil)) - (handler-bind (((or style-warning) #'muffle-warning)) - (symbol-call :asdf :load-system :asdf :verbose nil)) - *asdf-upgraded-p*)) - - (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body) - `(with-upgradability () - (with-deprecation ((version-deprecation *asdf-version* ,@keys)) - ,@body)))) -;;;; ------------------------------------------------------------------------- -;;;; Session - -(uiop/package:define-package :asdf/session - (:recycle :asdf/session :asdf/cache :asdf/component - :asdf/action :asdf/find-system :asdf/plan :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade) - (:export - #:get-file-stamp #:compute-file-stamp #:register-file-stamp - #:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache - #:do-asdf-cache #:normalize-namestring - #:call-with-asdf-session #:with-asdf-session - #:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session - #:session-cache #:forcing #:asdf-upgraded-p - #:visited-actions #:visiting-action-set #:visiting-action-list - #:total-action-count #:planned-action-count #:planned-output-action-count - #:clear-configuration-and-retry #:retry - #:operate-level - ;; conditions - #:system-definition-error ;; top level, moved here because this is the earliest place for it. - #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error)) -(in-package :asdf/session) - - -(with-upgradability () - ;; The session variable. - ;; NIL when outside a session. - (defvar *asdf-session* nil) - (defparameter* *asdf-session-class* 'session - "The default class for sessions") - - (defclass session () - (;; The ASDF session cache is used to memoize some computations. - ;; It is instrumental in achieving: - ;; * Consistency in the view of the world relied on by ASDF within a given session. - ;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops - ;; (a.k.a. stack overflows) and other erratic behavior. - ;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and - ;; no expensive recomputations of transitive dependencies for input-files or output-files. - ;; * Testability of ASDF with the ability to fake timestamps without actually touching files. - (ancestor - :initform nil :initarg :ancestor :reader session-ancestor - :documentation "Top level session that this is part of") - (session-cache - :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache - :documentation "Memoize expensive computations") - (operate-level - :initform 0 :initarg :operate-level :accessor session-operate-level - :documentation "Number of nested calls to operate we're under (for toplevel session only)") - ;; shouldn't the below be superseded by the session-wide caching of action-status - ;; for (load-op "asdf") ? - (asdf-upgraded-p - :initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p - :documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.") - (forcing - :initform nil :initarg :forcing :accessor forcing - :documentation "Forcing parameters for the session") - ;; Table that to actions already visited while walking the dependencies associates status - (visited-actions :initform (make-hash-table :test 'equal) :accessor visited-actions) - ;; Actions that depend on those being currently walked through, to detect circularities - (visiting-action-set ;; as a set - :initform (make-hash-table :test 'equal) :accessor visiting-action-set) - (visiting-action-list :initform () :accessor visiting-action-list) ;; as a list - ;; Counts of total actions in plan - (total-action-count :initform 0 :accessor total-action-count) - ;; Count of actions that need to be performed - (planned-action-count :initform 0 :accessor planned-action-count) - ;; Count of actions that need to be performed that have a non-empty list of output-files. - (planned-output-action-count :initform 0 :accessor planned-output-action-count)) - (:documentation "An ASDF session with a cache to memoize some computations")) - - (defun toplevel-asdf-session () - (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*))) - - (defun operate-level () - (session-operate-level (toplevel-asdf-session))) - - (defun (setf operate-level) (new-level) - (setf (session-operate-level (toplevel-asdf-session)) new-level)) - - (defun asdf-cache () - (session-cache *asdf-session*)) - - ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session. - ;; Return those values. - (defun set-asdf-cache-entry (key value-list) - (values-list (if *asdf-session* - (setf (gethash key (asdf-cache)) value-list) - value-list))) - - ;; Unset the session cache entry for KEY, when inside a session. - (defun unset-asdf-cache-entry (key) - (when *asdf-session* - (remhash key (session-cache *asdf-session*)))) - - ;; Consult the session cache entry for KEY if present and in a session; - ;; if not present, compute it by calling the THUNK, - ;; and set the session cache entry accordingly, if in a session. - ;; Return the values from the cache and/or the thunk computation. - (defun consult-asdf-cache (key &optional thunk) - (if *asdf-session* - (multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*)) - (if foundp - (values-list results) - (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) - (call-function thunk))) - - ;; Syntactic sugar for consult-asdf-cache - (defmacro do-asdf-cache (key &body body) - `(consult-asdf-cache ,key #'(lambda () ,@body))) - - ;; Compute inside a ASDF session with a cache. - ;; First, make sure an ASDF session is underway, by binding the session cache variable - ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true). - ;; Second, if a new session was started, establish restarts for retrying the overall computation. - ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache - ;; entry isn't found, or just call the THUNK if no KEY was specified. - (defun call-with-asdf-session (thunk &key override key override-cache override-forcing) - (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) - (if (and (not override) *asdf-session*) - (funcall fun) - (loop - (restart-case - (let ((*asdf-session* - (apply 'make-instance *asdf-session-class* - (when *asdf-session* - `(:ancestor ,(toplevel-asdf-session) - ,@(unless override-forcing - `(:forcing ,(forcing *asdf-session*))) - ,@(unless override-cache - `(:session-cache ,(session-cache *asdf-session*)))))))) - (return (funcall fun))) - (retry () - :report (lambda (s) - (format s (compatfmt "~@")))) - (clear-configuration-and-retry () - :report (lambda (s) - (format s (compatfmt "~@"))) - (unless (null *asdf-session*) - (clrhash (session-cache *asdf-session*))) - (clear-configuration))))))) - - ;; Syntactic sugar for call-with-asdf-session - (defmacro with-asdf-session ((&key key override override-cache override-forcing) &body body) - `(call-with-asdf-session - #'(lambda () ,@body) - :override ,override :key ,key - :override-cache ,override-cache :override-forcing ,override-forcing)) - - - ;;; Define specific accessor for file (date) stamp. - - ;; Normalize a namestring for use as a key in the session cache. - (defun normalize-namestring (pathname) - (let ((resolved (resolve-symlinks* - (ensure-absolute-pathname - (physicalize-pathname pathname) - 'get-pathname-defaults)))) - (with-pathname-defaults () (namestring resolved)))) - - ;; Compute the file stamp for a normalized namestring - (defun compute-file-stamp (normalized-namestring) - (with-pathname-defaults () - (or (safe-file-write-date normalized-namestring) t))) - - ;; Override the time STAMP associated to a given FILE in the session cache. - ;; If no STAMP is specified, recompute a new one from the filesystem. - (defun register-file-stamp (file &optional (stamp nil stampp)) - (let* ((namestring (normalize-namestring file)) - (stamp (if stampp stamp (compute-file-stamp namestring)))) - (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp)))) - - ;; Get or compute a memoized stamp for given FILE from the session cache. - (defun get-file-stamp (file) - (when file - (let ((namestring (normalize-namestring file))) - (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))) - - - ;;; Conditions - - (define-condition system-definition-error (error) () - ;; [this use of :report should be redundant, but unfortunately it's not. - ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function - ;; over print-object; this is always conditions::%print-condition for - ;; condition objects, which in turn does inheritance of :report options at - ;; run-time. fortunately, inheritance means we only need this kludge here in - ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] - #+cmucl (:report print-object)) - - (define-condition formatted-system-definition-error (system-definition-error) - ((format-control :initarg :format-control :reader format-control) - (format-arguments :initarg :format-arguments :reader format-arguments)) - (:report (lambda (c s) - (apply 'format s (format-control c) (format-arguments c))))) - - (defun sysdef-error (format &rest arguments) - (error 'formatted-system-definition-error :format-control - format :format-arguments arguments))) -;;;; ------------------------------------------------------------------------- -;;;; Components - -(uiop/package:define-package :asdf/component - (:recycle :asdf/component :asdf/find-component :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session) - (:export - #:component #:component-find-path - #:find-component ;; methods defined in find-component - #:component-name #:component-pathname #:component-relative-pathname - #:component-parent #:component-system #:component-parent-pathname - #:child-component #:parent-component #:module - #:file-component - #:source-file #:c-source-file #:java-source-file - #:static-file #:doc-file #:html-file - #:file-type - #:source-file-type #:source-file-explicit-type ;; backward-compatibility - #:component-in-order-to #:component-sideway-dependencies - #:component-if-feature #:around-compile-hook - #:component-description #:component-long-description - #:component-version #:version-satisfies - #:component-inline-methods ;; backward-compatibility only. DO NOT USE! - #:component-operation-times ;; For internal use only. - ;; portable ASDF encoding and implementation-specific external-format - #:component-external-format #:component-encoding - #:component-children-by-name #:component-children #:compute-children-by-name - #:component-build-operation - #:module-default-component-class - #:module-components ;; backward-compatibility. DO NOT USE. - #:sub-components - - ;; conditions - #:duplicate-names - - ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes - #:name #:version #:description #:long-description #:author #:maintainer #:licence - #:components-by-name #:components #:children #:children-by-name - #:default-component-class #:source-file - #:defsystem-depends-on ; This symbol retained for backward compatibility. - #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods - #:relative-pathname #:absolute-pathname #:operation-times #:around-compile - #:%encoding #:properties #:component-properties #:parent)) -(in-package :asdf/component) - -(with-upgradability () - (defgeneric component-name (component) - (:documentation "Name of the COMPONENT, unique relative to its parent")) - (defgeneric component-system (component) - (:documentation "Top-level system containing the COMPONENT")) - (defgeneric component-pathname (component) - (:documentation "Pathname of the COMPONENT if any, or NIL.")) - (defgeneric component-relative-pathname (component) - ;; in ASDF4, rename that to component-specified-pathname ? - (:documentation "Specified pathname of the COMPONENT, -intended to be merged with the pathname of that component's parent if any, using merged-pathnames*. -Despite the function's name, the return value can be an absolute pathname, in which case the merge -will leave it unmodified.")) - (defgeneric component-external-format (component) - (:documentation "The external-format of the COMPONENT. -By default, deduced from the COMPONENT-ENCODING.")) - (defgeneric component-encoding (component) - (:documentation "The encoding of the COMPONENT. By default, only :utf-8 is supported. -Use asdf-encodings to support more encodings.")) - (defgeneric version-satisfies (component version) - (:documentation "Check whether a COMPONENT satisfies the constraint of being at least as recent -as the specified VERSION, which must be a string of dot-separated natural numbers, or NIL.")) - (defgeneric component-version (component) - (:documentation "Return the version of a COMPONENT, which must be a string of dot-separated -natural numbers, or NIL.")) - (defgeneric (setf component-version) (new-version component) - (:documentation "Updates the version of a COMPONENT, which must be a string of dot-separated -natural numbers, or NIL.")) - (defgeneric component-parent (component) - (:documentation "The parent of a child COMPONENT, -or NIL for top-level components (a.k.a. systems)")) - ;; NIL is a designator for the absence of a component, in which case the parent is also absent. - (defmethod component-parent ((component null)) nil) - - ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component. - (with-asdf-deprecation (:style-warning "3.4") - (defgeneric source-file-type (component system) - (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))) - - (define-condition duplicate-names (system-definition-error) - ((name :initarg :name :reader duplicate-names-name)) - (:report (lambda (c s) - (format s (compatfmt "~@") - (duplicate-names-name c)))))) - - -(with-upgradability () - (defclass component () - ((name :accessor component-name :initarg :name :type string :documentation - "Component name: designator for a string composed of portable pathname characters") - ;; We might want to constrain version with - ;; :type (and string (satisfies parse-version)) - ;; but we cannot until we fix all systems that don't use it correctly! - (version :accessor component-version :initarg :version :initform nil) - (description :accessor component-description :initarg :description :initform nil) - (long-description :accessor component-long-description :initarg :long-description :initform nil) - (sideway-dependencies :accessor component-sideway-dependencies :initform nil) - (if-feature :accessor component-if-feature :initform nil :initarg :if-feature) - ;; In the ASDF object model, dependencies exist between *actions*, - ;; where an action is a pair of an operation and a component. - ;; Dependencies are represented as alists of operations - ;; to a list where each entry is a pair of an operation and a list of component specifiers. - ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies: - ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to. - ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl) - ;; and do-first things that modify the current image (such as loading a fasl). - ;; These are now unified because we now correctly propagate timestamps between dependencies. - ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017, - ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains. - ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52! - ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. - ;; Maybe rename the slots in ASDF? But that's not very backward-compatible. - ;; See our ASDF 2 paper for more complete explanations. - (in-order-to :initform nil :initarg :in-order-to - :accessor component-in-order-to) - ;; Methods defined using the "inline" style inside a defsystem form: - ;; we store them here so we can delete them when the system is re-evaluated. - (inline-methods :accessor component-inline-methods :initform nil) - ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative. - ;; There is no initform and no direct accessor for this specified pathname, - ;; so we only access the information through appropriate methods, after it has been processed. - ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4. - (relative-pathname :initarg :pathname) - ;; The absolute-pathname is computed based on relative-pathname and parent pathname. - ;; The slot is but a cache used by component-pathname. - (absolute-pathname) - (operation-times :initform (make-hash-table) - :accessor component-operation-times) - (around-compile :initarg :around-compile) - ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE! - (properties :accessor component-properties :initarg :properties - :initform nil) - (%encoding :accessor %component-encoding :initform nil :initarg :encoding) - ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it. - (parent :initarg :parent :initform nil :reader component-parent) - (build-operation - :initarg :build-operation :initform nil :reader component-build-operation) - ;; Cache for ADDITIONAL-INPUT-FILES function. - (additional-input-files :accessor %additional-input-files :initform nil)) - (:documentation "Base class for all components of a build")) - - (defgeneric find-component (base path &key registered) - (:documentation "Find a component by resolving the PATH starting from BASE parent. -If REGISTERED is true, only search currently registered systems.")) - - (defun component-find-path (component) - "Return a path from a root system to the COMPONENT. -The return value is a list of component NAMES; a list of strings." - (check-type component (or null component)) - (reverse - (loop :for c = component :then (component-parent c) - :while c :collect (component-name c)))) - - (defmethod print-object ((c component) stream) - (print-unreadable-object (c stream :type t :identity nil) - (format stream "~{~S~^ ~}" (component-find-path c)))) - - (defmethod component-system ((component component)) - (if-let (system (component-parent component)) - (component-system system) - component))) - - -;;;; Component hierarchy within a system -;; The tree typically but not necessarily follows the filesystem hierarchy. -(with-upgradability () - (defclass child-component (component) () - (:documentation "A CHILD-COMPONENT is a COMPONENT that may be part of -a PARENT-COMPONENT.")) - - (defclass file-component (child-component) - ((type :accessor file-type :initarg :type)) ; no default - (:documentation "a COMPONENT that represents a file")) - (defclass source-file (file-component) - ((type :accessor source-file-explicit-type ;; backward-compatibility - :initform nil))) ;; NB: many systems have come to rely on this default. - (defclass c-source-file (source-file) - ((type :initform "c"))) - (defclass java-source-file (source-file) - ((type :initform "java"))) - (defclass static-file (source-file) - ((type :initform nil)) - (:documentation "Component for a file to be included as is in the build output")) - (defclass doc-file (static-file) ()) - (defclass html-file (doc-file) - ((type :initform "html"))) - - (defclass parent-component (component) - ((children - :initform nil - :initarg :components - :reader module-components ; backward-compatibility - :accessor component-children) - (children-by-name - :reader module-components-by-name ; backward-compatibility - :accessor component-children-by-name) - (default-component-class - :initform nil - :initarg :default-component-class - :accessor module-default-component-class)) - (:documentation "A PARENT-COMPONENT is a component that may have children."))) - -(with-upgradability () - ;; (Private) Function that given a PARENT component, - ;; the list of children of which has been initialized, - ;; compute the hash-table in slot children-by-name that allows to retrieve its children by name. - ;; If ONLY-IF-NEEDED-P is defined, skip any (re)computation if the slot is already populated. - (defun compute-children-by-name (parent &key only-if-needed-p) - (unless (and only-if-needed-p (slot-boundp parent 'children-by-name)) - (let ((hash (make-hash-table :test 'equal))) - (setf (component-children-by-name parent) hash) - (loop :for c :in (component-children parent) - :for name = (component-name c) - :for previous = (gethash name hash) - :do (when previous (error 'duplicate-names :name name)) - (setf (gethash name hash) c)) - hash)))) - -(with-upgradability () - (defclass module (child-component parent-component) - (#+clisp (components)) ;; backward compatibility during upgrade only - (:documentation "A module is a intermediate component with both a parent and children, -typically but not necessarily representing the files in a subdirectory of the build source."))) - - -;;;; component pathnames -(with-upgradability () - (defgeneric component-parent-pathname (component) - (:documentation "The pathname of the COMPONENT's parent, if any, or NIL")) - (defmethod component-parent-pathname (component) - (component-pathname (component-parent component))) - - ;; The default method for component-pathname tries to extract a cached precomputed - ;; absolute-pathname from the relevant slot, and if not, computes it by merging the - ;; component-relative-pathname (which should be component-specified-pathname, it can be absolute) - ;; with the directory of the component-parent-pathname. - (defmethod component-pathname ((component component)) - (if (slot-boundp component 'absolute-pathname) - (slot-value component 'absolute-pathname) - (let ((pathname - (merge-pathnames* - (component-relative-pathname component) - (pathname-directory-pathname (component-parent-pathname component))))) - (unless (or (null pathname) (absolute-pathname-p pathname)) - (error (compatfmt "~@") - pathname (component-find-path component))) - (setf (slot-value component 'absolute-pathname) pathname) - pathname))) - - ;; Default method for component-relative-pathname: - ;; combine the contents of slot relative-pathname (from specified initarg :pathname) - ;; with the appropriate source-file-type, which defaults to the file-type of the component. - (defmethod component-relative-pathname ((component component)) - ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1. - ;; We ought to be able to extract this from the component alone with FILE-TYPE. - ;; TODO: track who uses it in Quicklisp, and have them not use it anymore; - ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge? - (let (#+abcl - (parent - (component-parent-pathname component))) - (parse-unix-namestring - (or (and (slot-boundp component 'relative-pathname) - (slot-value component 'relative-pathname)) - (component-name component)) - :want-relative - #-abcl t - ;; JAR-PATHNAMES always have absolute directories - #+abcl (not (ext:pathname-jar-p parent)) - :type (source-file-type component (component-system component)) - :defaults (component-parent-pathname component)))) - - (defmethod source-file-type ((component parent-component) (system parent-component)) - :directory) - - (defmethod source-file-type ((component file-component) (system parent-component)) - (file-type component))) - - -;;;; Encodings -(with-upgradability () - (defmethod component-encoding ((c component)) - (or (loop :for x = c :then (component-parent x) - :while x :thereis (%component-encoding x)) - (detect-encoding (component-pathname c)))) - - (defmethod component-external-format ((c component)) - (encoding-external-format (component-encoding c)))) - - -;;;; around-compile-hook -(with-upgradability () - (defgeneric around-compile-hook (component) - (:documentation "An optional hook function that will be called with one argument, a thunk. -The hook function must call the thunk, that will compile code from the component, and may or may not -also evaluate the compiled results. The hook function may establish dynamic variable bindings around -this compilation, or check its results, etc.")) - (defmethod around-compile-hook ((c component)) - (cond - ((slot-boundp c 'around-compile) - (slot-value c 'around-compile)) - ((component-parent c) - (around-compile-hook (component-parent c)))))) - - -;;;; version-satisfies -(with-upgradability () - ;; short-circuit testing of null version specifications. - ;; this is an all-pass, without warning - (defmethod version-satisfies :around ((c t) (version null)) - t) - (defmethod version-satisfies ((c component) version) - (unless (and version (slot-boundp c 'version) (component-version c)) - (when version - (warn "Requested version ~S but ~S has no version" version c)) - (return-from version-satisfies nil)) - (version-satisfies (component-version c) version)) - - (defmethod version-satisfies ((cver string) version) - (version<= version cver))) - - -;;; all sub-components (of a given type) -(with-upgradability () - (defun sub-components (component &key (type t)) - "Compute the transitive sub-components of given COMPONENT that are of given TYPE" - (while-collecting (c) - (labels ((recurse (x) - (when (if-let (it (component-if-feature x)) (featurep it) t) - (when (typep x type) - (c x)) - (when (typep x 'parent-component) - (map () #'recurse (component-children x)))))) - (recurse component))))) - -;;;; ------------------------------------------------------------------------- -;;;; Operations - -(uiop/package:define-package :asdf/operation - (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session) - (:export - #:operation - #:*operations* #:make-operation #:find-operation - #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature. -(in-package :asdf/operation) - -;;; Operation Classes -(when-upgrading (:version "2.27" :when (find-class 'operation nil)) - ;; override any obsolete shared-initialize method when upgrading from ASDF2. - (defmethod shared-initialize :after ((o operation) (slot-names t) &key) - (values))) - -(with-upgradability () - (defclass operation () - () - (:documentation "The base class for all ASDF operations. - -ASDF does NOT and never did distinguish between multiple operations of the same class. -Therefore, all slots of all operations MUST have :allocation :class and no initargs. No exceptions. -")) - - (defvar *in-make-operation* nil) - - (defun check-operation-constructor () - "Enforce that OPERATION instances must be created with MAKE-OPERATION." - (unless *in-make-operation* - (sysdef-error "OPERATION instances must only be created through MAKE-OPERATION."))) - - (defmethod print-object ((o operation) stream) - (print-unreadable-object (o stream :type t :identity nil))) - - ;;; Override previous methods (from 3.1.7 and earlier) and add proper error checking. - #-genera ;; Genera adds its own system initargs, e.g. clos-internals:storage-area 8 - (defmethod initialize-instance :after ((o operation) &rest initargs &key &allow-other-keys) - (unless (null initargs) - (parameter-error "~S does not accept initargs" 'operation)))) - - -;;; make-operation, find-operation - -(with-upgradability () - ;; A table to memoize instances of a given operation. There shall be only one. - (defparameter* *operations* (make-hash-table :test 'equal)) - - ;; A memoizing way of creating instances of operation. - (defun make-operation (operation-class) - "This function creates and memoizes an instance of OPERATION-CLASS. -All operation instances MUST be created through this function. - -Use of INITARGS is not supported at this time." - (let ((class (coerce-class operation-class - :package :asdf/interface :super 'operation :error 'sysdef-error)) - (*in-make-operation* t)) - (ensure-gethash class *operations* `(make-instance ,class)))) - - ;; This function is mostly for backward and forward compatibility: - ;; operations used to preserve the operation-original-initargs of the context, - ;; and may in the future preserve some operation-canonical-initargs. - ;; Still, the treatment of NIL as a disabling context is useful in some cases. - (defgeneric find-operation (context spec) - (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) - (defmethod find-operation ((context t) (spec operation)) - spec) - (defmethod find-operation ((context t) (spec symbol)) - (when spec ;; NIL designates itself, i.e. absence of operation - (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context) - (defmethod find-operation ((context t) (spec string)) - (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context) - -;;;; ------------------------------------------------------------------------- -;;;; Systems - -(uiop/package:define-package :asdf/system - (:recycle :asdf :asdf/system :asdf/find-system) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component) - (:export - #:system #:proto-system #:undefined-system #:reset-system-class - #:system-source-file #:system-source-directory #:system-relative-pathname - #:system-description #:system-long-description - #:system-author #:system-maintainer #:system-licence #:system-license - #:system-version - #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on - #:system-depends-on #:system-weakly-depends-on - #:component-build-pathname #:build-pathname - #:component-entry-point #:entry-point - #:homepage #:system-homepage - #:bug-tracker #:system-bug-tracker - #:mailto #:system-mailto - #:long-name #:system-long-name - #:source-control #:system-source-control - #:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename - #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system -(in-package :asdf/system) - -(with-upgradability () - ;; The method is actually defined in asdf/find-system, - ;; but we declare the function here to avoid a forward reference. - (defgeneric find-system (system &optional error-p) - (:documentation "Given a system designator, find the actual corresponding system object. -If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL. -A system designator is usually a string (conventionally all lowercase) or a symbol, designating -the same system as its downcased name; it can also be a system object (designating itself).")) - - (defgeneric system-source-file (system) - (:documentation "Return the source file in which system is defined.")) - - ;; This is bad design, but was the easiest kluge I found to let the user specify that - ;; some special actions create outputs at locations controled by the user that are not affected - ;; by the usual output-translations. - ;; TODO: Fix operate to stop passing flags to operation (which in the current design shouldn't - ;; have any flags, since the stamp cache, etc., can't distinguish them), and instead insert - ;; *there* the ability of specifying special output paths, not in the system definition. - (defgeneric component-build-pathname (component) - (:documentation "The COMPONENT-BUILD-PATHNAME, when defined and not null, specifies the -output pathname for the action using the COMPONENT-BUILD-OPERATION. - -NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) - - ;; TODO: Should this have been made a SYSTEM-ENTRY-POINT instead? - (defgeneric component-entry-point (component) - (:documentation "The COMPONENT-ENTRY-POINT, when defined, specifies what function to call -(with no argument) when running an image dumped from the COMPONENT. - -NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) - - (defmethod component-entry-point ((c component)) - nil)) - - -;;;; The system class - -(with-upgradability () - (defclass proto-system () ; slots to keep when resetting a system - ;; To preserve identity for all objects, we'd need keep the components slots - ;; but also to modify parse-component-form to reset the recycled objects. - ((name) - (source-file) - ;; These two slots contains the *inferred* dependencies of define-op, - ;; from loading the .asd file, as list and as set. - (definition-dependency-list - :initform nil :accessor definition-dependency-list) - (definition-dependency-set - :initform (list-to-hash-set nil) :accessor definition-dependency-set)) - (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when -a SYSTEM is redefined and its class is modified.")) - - (defclass system (module proto-system) - ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component. - (;; {,long-}description is now inherited from component, but we add the legacy accessors - (description :writer (setf system-description)) - (long-description :writer (setf system-long-description)) - (author :writer (setf system-author) :initarg :author :initform nil) - (maintainer :writer (setf system-maintainer) :initarg :maintainer :initform nil) - (licence :writer (setf system-licence) :initarg :licence - :writer (setf system-license) :initarg :license - :initform nil) - (homepage :writer (setf system-homepage) :initarg :homepage :initform nil) - (bug-tracker :writer (setf system-bug-tracker) :initarg :bug-tracker :initform nil) - (mailto :writer (setf system-mailto) :initarg :mailto :initform nil) - (long-name :writer (setf system-long-name) :initarg :long-name :initform nil) - ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced. - ;; I'm introducing the slot before the conventions are set for maximum compatibility. - (source-control :writer (setf system-source-control) :initarg :source-control :initform nil) - - (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p) - (build-pathname - :initform nil :initarg :build-pathname :accessor component-build-pathname) - (entry-point - :initform nil :initarg :entry-point :accessor component-entry-point) - (source-file :initform nil :initarg :source-file :accessor system-source-file) - ;; This slot contains the *declared* defsystem-depends-on dependencies - (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on - :initform nil) - ;; these two are specially set in parse-component-form, so have no :INITARGs. - (depends-on :reader system-depends-on :initform nil) - (weakly-depends-on :reader system-weakly-depends-on :initform nil)) - (:documentation "SYSTEM is the base class for top-level components that users may request -ASDF to build.")) - - (defclass undefined-system (system) () - (:documentation "System that was not defined yet.")) - - (defun reset-system-class (system new-class &rest keys &key &allow-other-keys) - "Erase any data from a SYSTEM except its basic identity, then reinitialize it -based on supplied KEYS." - (change-class (change-class system 'proto-system) new-class) - (apply 'reinitialize-instance system keys))) - - -;;; Canonicalizing system names - -(with-upgradability () - (defun coerce-name (name) - "Given a designator for a component NAME, return the name as a string. -The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component), -a SYMBOL (designing its name, downcased), or a STRING (designing itself)." - (typecase name - (component (component-name name)) - (symbol (string-downcase name)) - (string name) - (t (sysdef-error (compatfmt "~@") name)))) - - (defun primary-system-name (system-designator) - "Given a system designator NAME, return the name of the corresponding -primary system, after which the .asd file in which it is defined is named. -If given a string or symbol (to downcase), do it syntactically - by stripping anything from the first slash on. -If given a component, do it semantically by extracting -the system-primary-system-name of its system from its source-file if any, -falling back to the syntactic criterion if none." - (etypecase system-designator - (string (if-let (p (position #\/ system-designator)) - (subseq system-designator 0 p) system-designator)) - (symbol (primary-system-name (coerce-name system-designator))) - (component (let* ((system (component-system system-designator)) - (source-file (physicalize-pathname (system-source-file system)))) - (if source-file - (and (equal (pathname-type source-file) "asd") - (pathname-name source-file)) - (primary-system-name (component-name system))))))) - - (defun primary-system-p (system) - "Given a system designator SYSTEM, return T if it designates a primary system, or else NIL. -If given a string, do it syntactically and return true if the name does not contain a slash. -If given a symbol, downcase to a string then fallback to previous case (NB: for NIL return T). -If given a component, do it semantically and return T if it's a SYSTEM and its primary-system-name -is the same as its component-name." - (etypecase system - (string (not (find #\/ system))) - (symbol (primary-system-p (coerce-name system))) - (component (and (typep system 'system) - (equal (component-name system) (primary-system-name system)))))) - - (defun coerce-filename (name) - "Coerce a system designator NAME into a string suitable as a filename component. -The (current) transformation is to replace characters /:\\ each by --, -the former being forbidden in a filename component. -NB: The onus is unhappily on the user to avoid clashes." - (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))) - - -;;; System virtual slot readers, recursing to the primary system if needed. -(with-upgradability () - (defvar *system-virtual-slots* '(long-name description long-description - author maintainer mailto - homepage source-control - licence version bug-tracker) - "The list of system virtual slot names.") - (defun system-virtual-slot-value (system slot-name) - "Return SYSTEM's virtual SLOT-NAME value. -If SYSTEM's SLOT-NAME value is NIL and SYSTEM is a secondary system, look in -the primary one." - (or (slot-value system slot-name) - (unless (primary-system-p system) - (slot-value (find-system (primary-system-name system)) - slot-name)))) - (defmacro define-system-virtual-slot-reader (slot-name) - (let ((name (intern (strcat (string :system-) (string slot-name))))) - `(progn - (fmakunbound ',name) ;; These were gf from defgeneric before 3.3.2.11 - (declaim (notinline ,name)) - (defun ,name (system) (system-virtual-slot-value system ',slot-name))))) - (defmacro define-system-virtual-slot-readers () - `(progn ,@(mapcar (lambda (slot-name) - `(define-system-virtual-slot-reader ,slot-name)) - *system-virtual-slots*))) - (define-system-virtual-slot-readers) - (defun system-license (system) - (system-virtual-slot-value system 'licence))) - - -;;;; Pathnames - -(with-upgradability () - ;; Resolve a system designator to a system before extracting its system-source-file - (defmethod system-source-file ((system-name string)) - (system-source-file (find-system system-name))) - (defmethod system-source-file ((system-name symbol)) - (when system-name - (system-source-file (find-system system-name)))) - - (defun system-source-directory (system-designator) - "Return a pathname object corresponding to the directory -in which the system specification (.asd file) is located." - (pathname-directory-pathname (system-source-file system-designator))) - - (defun system-relative-pathname (system name &key type) - "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, -return the absolute pathname of a corresponding file under that system's source code pathname." - (subpathname (system-source-directory system) name :type type)) - - (defmethod component-pathname ((system system)) - "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, -return the absolute pathname of a corresponding file under that system's source code pathname." - (let ((pathname (or (call-next-method) (system-source-directory system)))) - (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age - (slot-value system 'relative-pathname)) ;; systems that directly access this slot. - (setf (slot-value system 'relative-pathname) pathname)) - pathname)) - - ;; The default method of component-relative-pathname for a system: - ;; if a pathname was specified in the .asd file, it must be relative to the .asd file - ;; (actually, to its truename* if *resolve-symlinks* it true, the default). - ;; The method will return an *absolute* pathname, once again showing that the historical name - ;; component-relative-pathname is misleading and should have been component-specified-pathname. - (defmethod component-relative-pathname ((system system)) - (parse-unix-namestring - (and (slot-boundp system 'relative-pathname) - (slot-value system 'relative-pathname)) - :want-relative t - :type :directory - :ensure-absolute t - :defaults (system-source-directory system))) - - ;; A system has no parent; if some method wants to make a path "relative to its parent", - ;; it will instead be relative to the system itself. - (defmethod component-parent-pathname ((system system)) - (system-source-directory system)) - - ;; Most components don't have a specified component-build-pathname, and therefore - ;; no magic redirection of their output that disregards the output-translations. - (defmethod component-build-pathname ((c component)) - nil)) - -;;;; ------------------------------------------------------------------------- -;;;; Finding systems - -(uiop/package:define-package :asdf/system-registry - (:recycle :asdf/system-registry :asdf/find-system :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/session :asdf/component :asdf/system) - (:export - #:remove-entry-from-registry #:coerce-entry-to-directory - #:registered-system #:register-system - #:registered-systems* #:registered-systems - #:clear-system #:map-systems - #:*system-definition-search-functions* #:search-for-system-definition - #:*central-registry* #:probe-asd #:sysdef-central-registry-search - #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed - #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* - #:find-system-if-being-defined #:mark-component-preloaded ;; forward references to asdf/find-system - #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems* - #:*registered-systems* #:clear-registered-systems - ;; defined in source-registry, but specially mentioned here: - #:sysdef-source-registry-search)) -(in-package :asdf/system-registry) - -(with-upgradability () - ;;; Registry of Defined Systems - - (defvar *registered-systems* (make-hash-table :test 'equal) - "This is a hash table whose keys are strings -- the names of systems -- -and whose values are systems. -A system is referred to as \"registered\" if it is present in this table.") - - (defun registered-system (name) - "Return a system of given NAME that was registered already, -if such a system exists. NAME is a system designator, to be -normalized by COERCE-NAME. The value returned is a system object, -or NIL if not found." - (gethash (coerce-name name) *registered-systems*)) - - (defun registered-systems* () - "Return a list containing every registered system (as a system object)." - (loop :for registered :being :the :hash-values :of *registered-systems* - :collect registered)) - - (defun registered-systems () - "Return a list of the names of every registered system." - (mapcar 'coerce-name (registered-systems*))) - - (defun register-system (system) - "Given a SYSTEM object, register it." - (check-type system system) - (let ((name (component-name system))) - (check-type name string) - (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name) - (setf (gethash name *registered-systems*) system))) - - (defun map-systems (fn) - "Apply FN to each defined system. - -FN should be a function of one argument. It will be -called with an object of type asdf:system." - (loop :for registered :being :the :hash-values :of *registered-systems* - :do (funcall fn registered))) - - - ;;; Preloaded systems: in the image even if you can't find source files backing them. - - (defvar *preloaded-systems* (make-hash-table :test 'equal) - "Registration table for preloaded systems.") - - (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/find-system - - (defun make-preloaded-system (name keys) - "Make a preloaded system of given NAME with build information from KEYS" - (let ((system (apply 'make-instance (getf keys :class 'system) - :name name :source-file (getf keys :source-file) - (remove-plist-keys '(:class :name :source-file) keys)))) - (mark-component-preloaded system) - system)) - - (defun sysdef-preloaded-system-search (requested) - "If REQUESTED names a system registered as preloaded, return a new system -with its registration information." - (let ((name (coerce-name requested))) - (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) - (when foundp - (make-preloaded-system name keys))))) - - (defun ensure-preloaded-system-registered (name) - "If there isn't a registered _defined_ system of given NAME, -and a there is a registered _preloaded_ system of given NAME, -then define and register said preloaded system." - (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name))) - (register-system system))) - - (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys) - "Register a system as being preloaded. If the system has not been loaded from the filesystem -yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be -registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION). -If VERSION is the default T, and a system was already loaded, then its version will be preserved." - (let ((name (coerce-name system-name))) - (when (eql version t) - (if-let (system (registered-system name)) - (setf (getf keys :version) (component-version system)))) - (setf (gethash name *preloaded-systems*) keys) - (ensure-preloaded-system-registered system-name))) - - - ;;; Immutable systems: in the image and can't be reloaded from source. - - (defvar *immutable-systems* nil - "A hash-set (equal hash-table mapping keys to T) of systems that are immutable, -i.e. already loaded in memory and not to be refreshed from the filesystem. -They will be treated specially by find-system, and passed as :force-not argument to make-plan. - -For instance, to can deliver an image with many systems precompiled, that *will not* check the -filesystem for them every time a user loads an extension, what more risk a problematic upgrade - or catastrophic downgrade, before you dump an image, you may use: - (map () 'asdf:register-immutable-system (asdf:already-loaded-systems)) - -Note that direct access to this variable from outside ASDF is not supported. -Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and -contact maintainers if you need a stable API to do more than that.") - - (defun sysdef-immutable-system-search (requested) - (let ((name (coerce-name requested))) - (when (and *immutable-systems* (gethash name *immutable-systems*)) - (or (registered-system requested) - (error 'formatted-system-definition-error - :format-control "Requested system ~A registered as an immutable-system, ~ -but not even registered as defined" - :format-arguments (list name)))))) - - (defun register-immutable-system (system-name &rest keys) - "Register SYSTEM-NAME as preloaded and immutable. -It will automatically be considered as passed to FORCE-NOT in a plan." - (let ((system-name (coerce-name system-name))) - (apply 'register-preloaded-system system-name keys) - (unless *immutable-systems* - (setf *immutable-systems* (list-to-hash-set nil))) - (setf (gethash system-name *immutable-systems*) t))) - - - ;;; Making systems undefined. - - (defun clear-system (system) - "Clear the entry for a SYSTEM in the database of systems previously defined. -However if the system was registered as PRELOADED (which it is if it is IMMUTABLE), -then a new system with the same name will be defined and registered in its place -from which build details will have been cleared. -Note that this does NOT in any way cause any of the code of the system to be unloaded. -Returns T if system was or is now undefined, NIL if a new preloaded system was redefined." - ;; There is no "unload" operation in Common Lisp, and - ;; a general such operation cannot be portably written, - ;; considering how much CL relies on side-effects to global data structures. - (let ((name (coerce-name system))) - (remhash name *registered-systems*) - (unset-asdf-cache-entry `(find-system ,name)) - (not (ensure-preloaded-system-registered name)))) - - (defun clear-registered-systems () - "Clear all currently registered defined systems. -Preloaded systems (including immutable ones) will be reset, other systems will be de-registered." - (map () 'clear-system (registered-systems))) - - - ;;; Searching for system definitions - - ;; For the sake of keeping things reasonably neat, we adopt a convention that - ;; only symbols are to be pushed to this list (rather than e.g. function objects), - ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF- - (defvar *system-definition-search-functions* '() - "A list that controls the ways that ASDF looks for system definitions. -It contains symbols to be funcalled in order, with a requested system name as argument, -until one returns a non-NIL result (if any), which must then be a fully initialized system object -with that name.") - - ;; Initialize and/or upgrade the *system-definition-search-functions* - ;; so it doesn't contain obsolete symbols, and does contain the current ones. - (defun cleanup-system-definition-search-functions () - (setf *system-definition-search-functions* - (append - ;; Remove known-incompatible sysdef functions from old versions of asdf. - ;; Order matters, so we can't just use set-difference. - (let ((obsolete - '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) - (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*)) - ;; Tuck our defaults at the end of the list if they were absent. - ;; This is imperfect, in case they were removed on purpose, - ;; but then it will be the responsibility of whoever removes these symmbols - ;; to upgrade asdf before he does such a thing rather than after. - (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) - '(sysdef-central-registry-search - sysdef-source-registry-search))))) - (cleanup-system-definition-search-functions) - - ;; This (private) function does the search for a system definition using *s-d-s-f*; - ;; it is to be called by locate-system. - (defun search-for-system-definition (system) - ;; Search for valid definitions of the system available in the current session. - ;; Previous definitions as registered in *registered-systems* MUST NOT be considered; - ;; they will be reconciled by locate-system then find-system. - ;; There are two special treatments: first, specially search for objects being defined - ;; in the current session, to avoid definition races between several files; - ;; second, specially search for immutable systems, so they cannot be redefined. - ;; Finally, use the search functions specified in *system-definition-search-functions*. - (let ((name (coerce-name system))) - (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x)))) - (try 'find-system-if-being-defined) - (try 'sysdef-immutable-system-search) - (map () #'try *system-definition-search-functions*)))) - - - ;;; The legacy way of finding a system: the *central-registry* - - ;; This variable contains a list of directories to be lazily searched for the requested asd - ;; by sysdef-central-registry-search. - (defvar *central-registry* nil - "A list of 'system directory designators' ASDF uses to find systems. - -A 'system directory designator' is a pathname or an expression -which evaluates to a pathname. For example: - - (setf asdf:*central-registry* - (list '*default-pathname-defaults* - #p\"/home/me/cl/systems/\" - #p\"/usr/share/common-lisp/systems/\")) - -This variable is for backward compatibility. -Going forward, we recommend new users should be using the source-registry.") - - ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS. - ;; Return the truename of that file if it is found and TRUENAME is true. - ;; Return NIL if the file is not found. - ;; On Windows, follow shortcuts to .asd files. - (defun probe-asd (name defaults &key truename) - (block nil - (when (directory-pathname-p defaults) - (if-let (file (probe-file* - (ensure-absolute-pathname - (parse-unix-namestring name :type "asd") - #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil)) - nil) - :truename truename)) - (return file)) - #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) - (os-cond - ((os-windows-p) - (when (physical-pathname-p defaults) - (let ((shortcut - (make-pathname - :defaults defaults :case :local - :name (strcat name ".asd") - :type "lnk"))) - (when (probe-file* shortcut) - (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))))) - - ;; Function to push onto *s-d-s-f* to use the *central-registry* - (defun sysdef-central-registry-search (system) - (let ((name (primary-system-name system)) - (to-remove nil) - (to-replace nil)) - (block nil - (unwind-protect - (dolist (dir *central-registry*) - (let ((defaults (eval dir)) - directorized) - (when defaults - (cond ((directory-pathname-p defaults) - (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) - (when file - (return file)))) - (t - (restart-case - (let* ((*print-circle* nil) - (message - (format nil - (compatfmt "~@") - system dir defaults))) - (error message)) - (remove-entry-from-registry () - :report "Remove entry from *central-registry* and continue" - (push dir to-remove)) - (coerce-entry-to-directory () - :test (lambda (c) (declare (ignore c)) - (and (not (directory-pathname-p defaults)) - (directory-pathname-p - (setf directorized - (ensure-directory-pathname defaults))))) - :report (lambda (s) - (format s (compatfmt "~@") - directorized dir)) - (push (cons dir directorized) to-replace)))))))) - ;; cleanup - (dolist (dir to-remove) - (setf *central-registry* (remove dir *central-registry*))) - (dolist (pair to-replace) - (let* ((current (car pair)) - (new (cdr pair)) - (position (position current *central-registry*))) - (setf *central-registry* - (append (subseq *central-registry* 0 position) - (list new) - (subseq *central-registry* (1+ position))))))))))) - -;;;; ------------------------------------------------------------------------- -;;;; Actions - -(uiop/package:define-package :asdf/action - (:nicknames :asdf-action) - (:recycle :asdf/action :asdf/plan :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation) - (:import-from :asdf/operation #:check-operation-constructor) - (:import-from :asdf/component #:%additional-input-files) - (:export - #:action #:define-convenience-action-methods - #:action-description #:format-action - #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation - #:non-propagating-operation - #:component-depends-on - #:input-files #:output-files #:output-file #:operation-done-p - #:action-operation #:action-component #:make-action - #:component-operation-time #:mark-operation-done #:compute-action-stamp - #:perform #:perform-with-restarts #:retry #:accept - #:action-path #:find-action - #:operation-definition-warning #:operation-definition-error ;; condition - #:action-valid-p - #:circular-dependency #:circular-dependency-actions - #:call-while-visiting-action #:while-visiting-action - #:additional-input-files)) -(in-package :asdf/action) - -(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning - - (deftype action () - "A pair of operation and component uniquely identifies a node in the dependency graph -of steps to be performed while building a system." - '(cons operation component)) - - (deftype operation-designator () - "An operation designates itself. NIL designates a context-dependent current operation, -and a class-name or class designates the canonical instance of the designated class." - '(or operation null symbol class))) - -;;; these are pseudo accessors -- let us abstract away the CONS cell representation of plan -;;; actions. -(with-upgradability () - (defun make-action (operation component) - (cons operation component)) - (defun action-operation (action) - (car action)) - (defun action-component (action) - (cdr action))) - -;;;; Reified representation for storage or debugging. Note: an action is identified by its class. -(with-upgradability () - (defun action-path (action) - "A readable data structure that identifies the action." - (when action - (let ((o (action-operation action)) - (c (action-component action))) - (cons (type-of o) (component-find-path c))))) - (defun find-action (path) - "Reconstitute an action from its action-path" - (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c))))) - -;;;; Convenience methods -(with-upgradability () - ;; A macro that defines convenience methods for a generic function (gf) that - ;; dispatches on operation and component. The convenience methods allow users - ;; to call the gf with operation and/or component designators, that the - ;; methods will resolve into actual operation and component objects, so that - ;; the users can interact using readable designators, but developers only have - ;; to write methods that handle operation and component objects. - ;; FUNCTION is the generic function name - ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT. - ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found. - ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found. - (defmacro define-convenience-action-methods - (function formals &key if-no-operation if-no-component) - (let* ((rest (gensym "REST")) - (found (gensym "FOUND")) - (keyp (equal (last formals) '(&key))) - (formals-no-key (if keyp (butlast formals) formals)) - (len (length formals-no-key)) - (operation 'operation) - (component 'component) - (opix (position operation formals)) - (coix (position component formals)) - (prefix (subseq formals 0 opix)) - (suffix (subseq formals (1+ coix) len)) - (more-args (when keyp `(&rest ,rest &key &allow-other-keys)))) - (assert (and (integerp opix) (integerp coix) (= coix (1+ opix)))) - (flet ((next-method (o c) - (if keyp - `(apply ',function ,@prefix ,o ,c ,@suffix ,rest) - `(,function ,@prefix ,o ,c ,@suffix)))) - `(progn - (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args) - (declare (notinline ,function)) - (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on - ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component))) - (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args) - (declare (notinline ,function)) - (if ,operation - ,(next-method - `(make-operation ,operation) - `(or (find-component () ,component) ,if-no-component)) - ,if-no-operation)) - (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args) - (declare (notinline ,function)) - (if (typep ,component 'component) - (error "No defined method for ~S on ~/asdf-action:format-action/" - ',function (make-action ,operation ,component)) - (if-let (,found (find-component () ,component)) - ,(next-method operation found) - ,if-no-component)))))))) - - -;;;; Self-description -(with-upgradability () - (defgeneric action-description (operation component) - (:documentation "returns a phrase that describes performing this operation -on this component, e.g. \"loading /a/b/c\". -You can put together sentences using this phrase.")) - (defmethod action-description (operation component) - (format nil (compatfmt "~@<~A on ~A~@:>") - operation component)) - - (defun format-action (stream action &optional colon-p at-sign-p) - "FORMAT helper to display an action's action-description. -Use it in FORMAT control strings as ~/asdf-action:format-action/" - (assert (null colon-p)) (assert (null at-sign-p)) - (destructuring-bind (operation . component) action - (princ (action-description operation component) stream)))) - - -;;;; Detection of circular dependencies -(with-upgradability () - (defun action-valid-p (operation component) - "Is this action valid to include amongst dependencies?" - ;; If either the operation or component was resolved to nil, the action is invalid. - ;; :if-feature will invalidate actions on components for which the features don't apply. - (and operation component - (if-let (it (component-if-feature component)) (featurep it) t))) - - (define-condition circular-dependency (system-definition-error) - ((actions :initarg :actions :reader circular-dependency-actions)) - (:report (lambda (c s) - (format s (compatfmt "~@") - (first (circular-dependency-actions c)) - (circular-dependency-actions c))))) - - (defun call-while-visiting-action (operation component fun) - "Detect circular dependencies" - (with-asdf-session () - (with-accessors ((action-set visiting-action-set) - (action-list visiting-action-list)) *asdf-session* - (let ((action (cons operation component))) - (when (gethash action action-set) - (error 'circular-dependency :actions - (member action (reverse action-list) :test 'equal))) - (setf (gethash action action-set) t) - (push action action-list) - (unwind-protect - (funcall fun) - (pop action-list) - (setf (gethash action action-set) nil)))))) - - ;; Syntactic sugar for call-while-visiting-action - (defmacro while-visiting-action ((o c) &body body) - `(call-while-visiting-action ,o ,c #'(lambda () ,@body)))) - - -;;;; Dependencies -(with-upgradability () - (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies - (:documentation - "Returns a list of dependencies needed by the component to perform - the operation. A dependency has one of the following forms: - - ( *), where is an operation designator - with respect to FIND-OPERATION in the context of the OPERATION argument, - and each is a component designator with respect to - FIND-COMPONENT in the context of the COMPONENT argument, - and means that the component depends on - having been performed on each ; - - [Note: an is an operation designator -- it can be either an - operation name or an operation object. Similarly, a may be - a component name or a component object. Also note that, the degenerate - case of () is a no-op.] - - Methods specialized on subclasses of existing component types - should usually append the results of CALL-NEXT-METHOD to the list.")) - (define-convenience-action-methods component-depends-on (operation component)) - - (defmethod component-depends-on :around ((o operation) (c component)) - (do-asdf-cache `(component-depends-on ,o ,c) - (call-next-method)))) - - -;;;; upward-operation, downward-operation, sideway-operation, selfward-operation -;; These together handle actions that propagate along the component hierarchy or operation universe. -(with-upgradability () - (defclass downward-operation (operation) - ((downward-operation - :initform nil :reader downward-operation - :type operation-designator :allocation :class)) - (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy. -I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then -the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M. -The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself. -E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the -children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP.")) - (defun downward-operation-depends-on (o c) - `((,(or (downward-operation o) o) ,@(component-children c)))) - (defmethod component-depends-on ((o downward-operation) (c parent-component)) - `(,@(downward-operation-depends-on o c) ,@(call-next-method))) - - (defclass upward-operation (operation) - ((upward-operation - :initform nil :reader upward-operation - :type operation-designator :allocation :class)) - (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy. -I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U, -then the action (O . C) of O on a component C that has the parent P will depends on (U . P). -The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself. -E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT -must first be prepared for loading or compiling with PREPARE-OP.")) - ;; For backward-compatibility reasons, a system inherits from module and is a child-component - ;; so we must guard against this case. ASDF4: remove that. - (defun upward-operation-depends-on (o c) - (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p)))) - (defmethod component-depends-on ((o upward-operation) (c child-component)) - `(,@(upward-operation-depends-on o c) ,@(call-next-method))) - - (defclass sideway-operation (operation) - ((sideway-operation - :initform nil :reader sideway-operation - :type operation-designator :allocation :class)) - (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings -that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot -designates operation S (where NIL designates O itself), then the action (O . C) of O on component C -depends on each of (S . D) where D is a declared dependency of C. -E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, -each of its declared dependencies must first be loaded as by LOAD-OP.")) - (defun sideway-operation-depends-on (o c) - `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c)))) - (defmethod component-depends-on ((o sideway-operation) (c component)) - `(,@(sideway-operation-depends-on o c) ,@(call-next-method))) - - (defclass selfward-operation (operation) - ((selfward-operation - ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which - :type (or operation-designator list) :reader selfward-operation :allocation :class)) - (:documentation "A SELFWARD-OPERATION depends on another operation on the same component. -I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L, -then the action (O . C) of O on component C depends on each (S . C) for S in L. -E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP. -A operation-designator designates a singleton list of the designated operation; -a list of operation-designators designates the list of designated operations; -NIL is not a valid operation designator in that context. Note that any dependency -ordering between the operations in a list of SELFWARD-OPERATION should be specified separately -in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly.")) - (defun selfward-operation-depends-on (o c) - (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c))) - (defmethod component-depends-on ((o selfward-operation) (c component)) - `(,@(selfward-operation-depends-on o c) ,@(call-next-method))) - - (defclass non-propagating-operation (operation) - () - (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates -no dependencies whatsoever. It is supplied in order that the programmer be able -to specify that s/he is intentionally specifying an operation which invokes no -dependencies."))) - - -;;;--------------------------------------------------------------------------- -;;; Help programmers catch obsolete OPERATION subclasses -;;;--------------------------------------------------------------------------- -(with-upgradability () - (define-condition operation-definition-warning (simple-warning) - () - (:documentation "Warning condition related to definition of obsolete OPERATION objects.")) - - (define-condition operation-definition-error (simple-error) - () - (:documentation "Error condition related to definition of incorrect OPERATION objects.")) - - (defmethod initialize-instance :before ((o operation) &key) - (check-operation-constructor) - (unless (typep o '(or downward-operation upward-operation sideway-operation - selfward-operation non-propagating-operation)) - (warn 'operation-definition-warning - :format-control - "No dependency propagating scheme specified for operation class ~S. -The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins." - :format-arguments (list (type-of o))))) - - (defmethod initialize-instance :before ((o non-propagating-operation) &key) - (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation)) - (error 'operation-definition-error - :format-control - "Inconsistent class: ~S - NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses." - :format-arguments - (list (type-of o))))) - - (defun backward-compatible-depends-on (o c) - "DEPRECATED: all subclasses of OPERATION used in ASDF should inherit from one of - DOWNWARD-OPERATION UPWARD-OPERATION SIDEWAY-OPERATION SELFWARD-OPERATION NON-PROPAGATING-OPERATION. - The function BACKWARD-COMPATIBLE-DEPENDS-ON temporarily provides ASDF2 behaviour for those that - don't. In the future this functionality will be removed, and the default will be no propagation." - (uiop/version::notify-deprecated-function - (version-deprecation *asdf-version* :style-warning "3.2") - `(backward-compatible-depends-on :for-operation ,o)) - `(,@(sideway-operation-depends-on o c) - ,@(when (typep c 'parent-component) (downward-operation-depends-on o c)))) - - (defmethod component-depends-on ((o operation) (c component)) - `(;; Normal behavior, to allow user-specified in-order-to dependencies - ,@(cdr (assoc (type-of o) (component-in-order-to c))) - ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation - ;; or non-propagation through an appropriate mixin will be downward and sideway. - ,@(unless (typep o '(or downward-operation upward-operation sideway-operation - selfward-operation non-propagating-operation)) - (backward-compatible-depends-on o c)))) - - (defmethod downward-operation ((o operation)) nil) - (defmethod sideway-operation ((o operation)) nil)) - - -;;;--------------------------------------------------------------------------- -;;; End of OPERATION class checking -;;;--------------------------------------------------------------------------- - - -;;;; Inputs, Outputs, and invisible dependencies -(with-upgradability () - (defgeneric output-files (operation component) - (:documentation "Methods for this function return two values: a list of output files -corresponding to this action, and a boolean indicating if they have already been subjected -to relevant output translations and should not be further translated. - -Methods on PERFORM *must* call this function to determine where their outputs are to be located. -They may rely on the order of the files to discriminate between outputs. -")) - (defgeneric input-files (operation component) - (:documentation "A list of input files corresponding to this action. - -Methods on PERFORM *must* call this function to determine where their inputs are located. -They may rely on the order of the files to discriminate between inputs. -")) - (defgeneric operation-done-p (operation component) - (:documentation "Returns a boolean which is NIL if the action must be performed (again).")) - (define-convenience-action-methods output-files (operation component)) - (define-convenience-action-methods input-files (operation component)) - (define-convenience-action-methods operation-done-p (operation component)) - - (defmethod operation-done-p ((o operation) (c component)) - t) - - ;; Translate output files, unless asked not to. Memoize the result. - (defmethod output-files :around ((operation t) (component t)) - (do-asdf-cache `(output-files ,operation ,component) - (values - (multiple-value-bind (pathnames fixedp) (call-next-method) - ;; 1- Make sure we have absolute pathnames - (let* ((directory (pathname-directory-pathname - (component-pathname (find-component () component)))) - (absolute-pathnames - (loop - :for pathname :in pathnames - :collect (ensure-absolute-pathname pathname directory)))) - ;; 2- Translate those pathnames as required - (if fixedp - absolute-pathnames - (mapcar *output-translation-function* absolute-pathnames)))) - t))) - (defmethod output-files ((o operation) (c component)) - nil) - (defun output-file (operation component) - "The unique output file of performing OPERATION on COMPONENT" - (let ((files (output-files operation component))) - (assert (length=n-p files 1)) - (first files))) - - (defgeneric additional-input-files (operation component) - (:documentation "Additional input files for the operation on this - component. These are files that are inferred, rather than - explicitly specified, and these are typically NOT files that - undergo operations directly. Instead, they are files that it is - important for ASDF to know about in order to compute operation times,etc.")) - (define-convenience-action-methods additional-input-files (operation component)) - (defmethod additional-input-files ((op operation) (comp component)) - (cdr (assoc op (%additional-input-files comp)))) - - ;; Memoize input files. - (defmethod input-files :around (operation component) - (do-asdf-cache `(input-files ,operation ,component) - ;; get the additional input files, if any - (append (call-next-method) - ;; must come after the first, for other code that - ;; assumes the first will be the "key" file - (additional-input-files operation component)))) - - ;; By default an action has no input-files. - (defmethod input-files ((o operation) (c component)) - nil) - - ;; An action with a selfward-operation by default gets its input-files from the output-files of - ;; the actions using selfward-operations it depends on (and the same component), - ;; or if there are none, on the component-pathname of the component if it's a file - ;; -- and then on the results of the next-method. - (defmethod input-files ((o selfward-operation) (c component)) - `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o)) - :append (or (output-files dep-o c) (input-files dep-o c))) - (if-let ((pathname (component-pathname c))) - (and (file-pathname-p pathname) (list pathname)))) - ,@(call-next-method)))) - - -;;;; Done performing -(with-upgradability () - ;; ASDF4: hide it behind plan-action-stamp - (defgeneric component-operation-time (operation component) - (:documentation "Return the timestamp for when an action was last performed")) - (defgeneric (setf component-operation-time) (time operation component) - (:documentation "Update the timestamp for when an action was last performed")) - (define-convenience-action-methods component-operation-time (operation component)) - - ;; ASDF4: hide it behind (setf plan-action-stamp) - (defgeneric mark-operation-done (operation component) - (:documentation "Mark a action as having been just done. - -Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP -using the JUST-DONE flag.")) - (defgeneric compute-action-stamp (plan- operation component &key just-done) - ;; NB: using plan- rather than plan above allows clisp to upgrade from 2.26(!) - (:documentation "Has this action been successfully done already, -and at what known timestamp has it been done at or will it be done at? -* PLAN is a plan object modelling future effects of actions, - or NIL to denote what actually happened. -* OPERATION and COMPONENT denote the action. -Takes keyword JUST-DONE: -* JUST-DONE is a boolean that is true if the action was just successfully performed, - at which point we want compute the actual stamp and warn if files are missing; - otherwise we are making plans, anticipating the effects of the action. -Returns two values: -* a STAMP saying when it was done or will be done, - or T if the action involves files that need to be recomputed. -* a boolean DONE-P that indicates whether the action has actually been done, - and both its output-files and its in-image side-effects are up to date.")) - - (defmethod component-operation-time ((o operation) (c component)) - (gethash o (component-operation-times c))) - - (defmethod (setf component-operation-time) (stamp (o operation) (c component)) - (assert stamp () "invalid null stamp for ~A" (action-description o c)) - (setf (gethash o (component-operation-times c)) stamp)) - - (defmethod mark-operation-done ((o operation) (c component)) - (let ((stamp (compute-action-stamp nil o c :just-done t))) - (assert stamp () "Failed to compute a stamp for completed action ~A" (action-description o c))1 - (setf (component-operation-time o c) stamp)))) - - -;;;; Perform -(with-upgradability () - (defgeneric perform (operation component) - (:documentation "PERFORM an action, consuming its input-files and building its output-files")) - (define-convenience-action-methods perform (operation component)) - - (defmethod perform :around ((o operation) (c component)) - (while-visiting-action (o c) (call-next-method))) - (defmethod perform :before ((o operation) (c component)) - (ensure-all-directories-exist (output-files o c))) - (defmethod perform :after ((o operation) (c component)) - (mark-operation-done o c)) - (defmethod perform ((o operation) (c parent-component)) - nil) - (defmethod perform ((o operation) (c source-file)) - ;; For backward compatibility, don't error on operations that don't specify propagation. - (when (typep o '(or downward-operation upward-operation sideway-operation - selfward-operation non-propagating-operation)) - (sysdef-error - (compatfmt "~@") - 'perform (make-action o c)))) - - ;; The restarts of the perform-with-restarts variant matter in an interactive context. - ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build - ;; may call perform directly rather than call p-w-r. - (defgeneric perform-with-restarts (operation component) - (:documentation "PERFORM an action in a context where suitable restarts are in place.")) - (defmethod perform-with-restarts (operation component) - (perform operation component)) - (defmethod perform-with-restarts :around (operation component) - (loop - (restart-case - (return (call-next-method)) - (retry () - :report - (lambda (s) - (format s (compatfmt "~@") - (action-description operation component)))) - (accept () - :report - (lambda (s) - (format s (compatfmt "~@") - (action-description operation component))) - (mark-operation-done operation component) - (return)))))) -;;;; ------------------------------------------------------------------------- -;;;; Actions to build Common Lisp software - -(uiop/package:define-package :asdf/lisp-action - (:recycle :asdf/lisp-action :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/operation :asdf/action) - (:export - #:try-recompiling - #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp - #:basic-load-op #:basic-compile-op - #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op - #:call-with-around-compile-hook - #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source - #:lisp-compilation-output-files)) -(in-package :asdf/lisp-action) - - -;;;; Component classes -(with-upgradability () - (defclass cl-source-file (source-file) - ((type :initform "lisp")) - (:documentation "Component class for a Common Lisp source file (using type \"lisp\")")) - (defclass cl-source-file.cl (cl-source-file) - ((type :initform "cl")) - (:documentation "Component class for a Common Lisp source file using type \"cl\"")) - (defclass cl-source-file.lsp (cl-source-file) - ((type :initform "lsp")) - (:documentation "Component class for a Common Lisp source file using type \"lsp\""))) - - -;;;; Operation classes -(with-upgradability () - (defclass basic-load-op (operation) () - (:documentation "Base class for operations that apply the load-time effects of a file")) - (defclass basic-compile-op (operation) () - (:documentation "Base class for operations that apply the compile-time effects of a file"))) - - -;;; Our default operations: loading into the current lisp image -(with-upgradability () - (defclass prepare-op (upward-operation sideway-operation) - ((sideway-operation :initform 'load-op :allocation :class)) - (:documentation "Load the dependencies for the COMPILE-OP or LOAD-OP of a given COMPONENT.")) - (defclass load-op (basic-load-op downward-operation selfward-operation) - ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p, - ;; so we need to directly depend on prepare-op for its side-effects in the current image. - ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)) - (:documentation "Operation for loading the compiled FASL for a Lisp file")) - (defclass compile-op (basic-compile-op downward-operation selfward-operation) - ((selfward-operation :initform 'prepare-op :allocation :class)) - (:documentation "Operation for compiling a Lisp file to a FASL")) - - - (defclass prepare-source-op (upward-operation sideway-operation) - ((sideway-operation :initform 'load-source-op :allocation :class)) - (:documentation "Operation for loading the dependencies of a Lisp file as source.")) - (defclass load-source-op (basic-load-op downward-operation selfward-operation) - ((selfward-operation :initform 'prepare-source-op :allocation :class)) - (:documentation "Operation for loading a Lisp file as source.")) - - (defclass test-op (selfward-operation) - ((selfward-operation :initform 'load-op :allocation :class)) - (:documentation "Operation for running the tests for system. -If the tests fail, an error will be signaled."))) - - -;;;; Methods for prepare-op, compile-op and load-op - -;;; prepare-op -(with-upgradability () - (defmethod action-description ((o prepare-op) (c component)) - (format nil (compatfmt "~@") c)) - (defmethod perform ((o prepare-op) (c component)) - nil) - (defmethod input-files ((o prepare-op) (s system)) - (if-let (it (system-source-file s)) (list it)))) - -;;; compile-op -(with-upgradability () - (defmethod action-description ((o compile-op) (c component)) - (format nil (compatfmt "~@") c)) - (defmethod action-description ((o compile-op) (c parent-component)) - (format nil (compatfmt "~@") c)) - (defgeneric call-with-around-compile-hook (component thunk) - (:documentation "A method to be called around the PERFORM'ing of actions that apply the -compile-time side-effects of file (i.e., COMPILE-OP or LOAD-SOURCE-OP). This method can be used -to setup readtables and other variables that control reading, macroexpanding, and compiling, etc. -Note that it will NOT be called around the performing of LOAD-OP.")) - (defmethod call-with-around-compile-hook ((c component) function) - (call-around-hook (around-compile-hook c) function)) - (defun perform-lisp-compilation (o c) - "Perform the compilation of the Lisp file associated to the specified action (O . C)." - (let (;; Before 2.26.53, that was unfortunately component-pathname. Now, - ;; we consult input-files, the first of which should be the one to compile-file - (input-file (first (input-files o c))) - ;; On some implementations, there are more than one output-file, - ;; but the first one should always be the primary fasl that gets loaded. - (outputs (output-files o c))) - (multiple-value-bind (output warnings-p failure-p) - (destructuring-bind - (output-file - &optional - #+(or clasp ecl mkcl) object-file - #+clisp lib-file - warnings-file &rest rest) outputs - ;; Allow for extra outputs that are not of type warnings-file - ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional. - (declare (ignore rest)) - (when warnings-file - (unless (equal (pathname-type warnings-file) (warnings-file-type)) - (setf warnings-file nil))) - (let ((*package* (find-package* '#:common-lisp-user))) - (call-with-around-compile-hook - c #'(lambda (&rest flags) - (apply 'compile-file* input-file - :output-file output-file - :external-format (component-external-format c) - :warnings-file warnings-file - (append - #+clisp (list :lib-file lib-file) - #+(or clasp ecl mkcl) (list :object-file object-file) - flags)))))) - (check-lisp-compile-results output warnings-p failure-p - "~/asdf-action::format-action/" (list (cons o c)))))) - (defun report-file-p (f) - "Is F a build report file containing, e.g., warnings to check?" - (equalp (pathname-type f) "build-report")) - (defun perform-lisp-warnings-check (o c) - "Check the warnings associated with the dependencies of an action." - (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c))) - (actual-warnings-files (loop :for w :in expected-warnings-files - :when (get-file-stamp w) - :collect w - :else :do (warn "Missing warnings file ~S while ~A" - w (action-description o c))))) - (check-deferred-warnings actual-warnings-files) - (let* ((output (output-files o c)) - (report (find-if #'report-file-p output))) - (when report - (with-open-file (s report :direction :output :if-exists :supersede) - (format s ":success~%")))))) - (defmethod perform ((o compile-op) (c cl-source-file)) - (perform-lisp-compilation o c)) - (defun lisp-compilation-output-files (o c) - "Compute the output-files for compiling the Lisp file for the specified action (O . C), -an OPERATION and a COMPONENT." - (let* ((i (first (input-files o c))) - (f (compile-file-pathname - i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl - #+mkcl :fasl-p #+mkcl t))) - `(,f ;; the fasl is the primary output, in first position - #+clasp - ,@(unless nil ;; was (use-ecl-byte-compiler-p) - `(,(compile-file-pathname i :output-type :object))) - #+clisp - ,@`(,(make-pathname :type "lib" :defaults f)) - #+ecl - ,@(unless (use-ecl-byte-compiler-p) - `(,(compile-file-pathname i :type :object))) - #+mkcl - ,(compile-file-pathname i :fasl-p nil) ;; object file - ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c)))) - `(,(make-pathname :type *warnings-file-type* :defaults f)))))) - (defmethod output-files ((o compile-op) (c cl-source-file)) - (lisp-compilation-output-files o c)) - (defmethod perform ((o compile-op) (c static-file)) - nil) - - ;; Performing compile-op on a system will check the deferred warnings for the system - (defmethod perform ((o compile-op) (c system)) - (when (and *warnings-file-type* (not (builtin-system-p c))) - (perform-lisp-warnings-check o c))) - (defmethod input-files ((o compile-op) (c system)) - (when (and *warnings-file-type* (not (builtin-system-p c))) - ;; The most correct way to do it would be to use: - ;; (collect-dependencies o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file) - ;; but it's expensive and we don't care too much about file order or ASDF extensions. - (loop :for sub :in (sub-components c :type 'cl-source-file) - :nconc (remove-if-not 'warnings-file-p (output-files o sub))))) - (defmethod output-files ((o compile-op) (c system)) - (when (and *warnings-file-type* (not (builtin-system-p c))) - (if-let ((pathname (component-pathname c))) - (list (subpathname pathname (coerce-filename c) :type "build-report")))))) - -;;; load-op -(with-upgradability () - (defmethod action-description ((o load-op) (c cl-source-file)) - (format nil (compatfmt "~@") c)) - (defmethod action-description ((o load-op) (c parent-component)) - (format nil (compatfmt "~@") c)) - (defmethod action-description ((o load-op) (c component)) - (format nil (compatfmt "~@") c)) - (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) - (loop - (restart-case - (return (call-next-method)) - (try-recompiling () - :report (lambda (s) - (format s "Recompile ~a and try loading it again" - (component-name c))) - (perform (find-operation o 'compile-op) c))))) - (defun perform-lisp-load-fasl (o c) - "Perform the loading of a FASL associated to specified action (O . C), -an OPERATION and a COMPONENT." - (if-let (fasl (first (input-files o c))) - (let ((*package* (find-package '#:common-lisp-user))) - (load* fasl)))) - (defmethod perform ((o load-op) (c cl-source-file)) - (perform-lisp-load-fasl o c)) - (defmethod perform ((o load-op) (c static-file)) - nil)) - - -;;;; prepare-source-op, load-source-op - -;;; prepare-source-op -(with-upgradability () - (defmethod action-description ((o prepare-source-op) (c component)) - (format nil (compatfmt "~@") c)) - (defmethod input-files ((o prepare-source-op) (s system)) - (if-let (it (system-source-file s)) (list it))) - (defmethod perform ((o prepare-source-op) (c component)) - nil)) - -;;; load-source-op -(with-upgradability () - (defmethod action-description ((o load-source-op) (c component)) - (format nil (compatfmt "~@") c)) - (defmethod action-description ((o load-source-op) (c parent-component)) - (format nil (compatfmt "~@") c)) - (defun perform-lisp-load-source (o c) - "Perform the loading of a Lisp file as associated to specified action (O . C)" - (call-with-around-compile-hook - c #'(lambda () - (load* (first (input-files o c)) - :external-format (component-external-format c))))) - - (defmethod perform ((o load-source-op) (c cl-source-file)) - (perform-lisp-load-source o c)) - (defmethod perform ((o load-source-op) (c static-file)) - nil)) - - -;;;; test-op -(with-upgradability () - (defmethod perform ((o test-op) (c component)) - nil) - (defmethod operation-done-p ((o test-op) (c system)) - "Testing a system is _never_ done." - nil)) -;;;; ------------------------------------------------------------------------- -;;;; Finding components - -(uiop/package:define-package :asdf/find-component - (:recycle :asdf/find-component :asdf/find-system :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/system-registry) - (:export - #:find-component - #:resolve-dependency-name #:resolve-dependency-spec - #:resolve-dependency-combination - ;; Conditions - #:missing-component #:missing-requires #:missing-parent #:missing-component-of-version #:retry - #:missing-dependency #:missing-dependency-of-version - #:missing-requires #:missing-parent - #:missing-required-by #:missing-version)) -(in-package :asdf/find-component) - -;;;; Missing component conditions - -(with-upgradability () - (define-condition missing-component (system-definition-error) - ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) - (parent :initform nil :reader missing-parent :initarg :parent))) - - (define-condition missing-component-of-version (missing-component) - ((version :initform nil :reader missing-version :initarg :version))) - - (define-condition missing-dependency (missing-component) - ((required-by :initarg :required-by :reader missing-required-by))) - - (defmethod print-object ((c missing-dependency) s) - (format s (compatfmt "~@<~A, required by ~A~@:>") - (call-next-method c nil) (missing-required-by c))) - - (define-condition missing-dependency-of-version (missing-dependency - missing-component-of-version) - ()) - - (defmethod print-object ((c missing-component) s) - (format s (compatfmt "~@") - (missing-requires c) - (when (missing-parent c) - (coerce-name (missing-parent c))))) - - (defmethod print-object ((c missing-component-of-version) s) - (format s (compatfmt "~@") - (missing-requires c) - (missing-version c) - (when (missing-parent c) - (coerce-name (missing-parent c)))))) - - -;;;; Finding components - -(with-upgradability () - (defgeneric resolve-dependency-combination (component combinator arguments) - (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS) -in the context of COMPONENT")) - - ;; Methods for find-component - - ;; If the base component is a string, resolve it as a system, then if not nil follow the path. - (defmethod find-component ((base string) path &key registered) - (if-let ((s (if registered - (registered-system base) - (find-system base nil)))) - (find-component s path :registered registered))) - - ;; If the base component is a symbol, coerce it to a name if not nil, and resolve that. - ;; If nil, use the path as base if not nil, or else return nil. - (defmethod find-component ((base symbol) path &key registered) - (cond - (base (find-component (coerce-name base) path :registered registered)) - (path (find-component path nil :registered registered)) - (t nil))) - - ;; If the base component is a cons cell, resolve its car, and add its cdr to the path. - (defmethod find-component ((base cons) path &key registered) - (find-component (car base) (cons (cdr base) path) :registered registered)) - - ;; If the base component is a parent-component and the path a string, find the named child. - (defmethod find-component ((parent parent-component) (name string) &key registered) - (declare (ignorable registered)) - (compute-children-by-name parent :only-if-needed-p t) - (values (gethash name (component-children-by-name parent)))) - - ;; If the path is a symbol, coerce it to a name if non-nil, or else just return the base. - (defmethod find-component (base (name symbol) &key registered) - (if name - (find-component base (coerce-name name) :registered registered) - base)) - - ;; If the path is a cons, first resolve its car as path, then its cdr. - (defmethod find-component ((c component) (name cons) &key registered) - (find-component (find-component c (car name) :registered registered) - (cdr name) :registered registered)) - - ;; If the path is a component, return it, disregarding the base. - (defmethod find-component ((base t) (actual component) &key registered) - (declare (ignorable registered)) - actual) - - ;; Resolve dependency NAME in the context of a COMPONENT, with given optional VERSION constraint. - ;; This (private) function is used below by RESOLVE-DEPENDENCY-SPEC and by the :VERSION spec. - (defun resolve-dependency-name (component name &optional version) - (loop - (restart-case - (return - (let ((comp (find-component (component-parent component) name))) - (unless comp - (error 'missing-dependency - :required-by component - :requires name)) - (when version - (unless (version-satisfies comp version) - (error 'missing-dependency-of-version - :required-by component - :version version - :requires name))) - comp)) - (retry () - :report (lambda (s) - (format s (compatfmt "~@") name)) - :test - (lambda (c) - (or (null c) - (and (typep c 'missing-dependency) - (eq (missing-required-by c) component) - (equal (missing-requires c) name)))) - (unless (component-parent component) - (let ((name (coerce-name name))) - (unset-asdf-cache-entry `(find-system ,name)))))))) - - ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT. - ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON - ;; and by PARSE-DEFSYSTEM to process DEFSYSTEM-DEPENDS-ON. - (defun resolve-dependency-spec (component dep-spec) - (let ((component (find-component () component))) - (if (atom dep-spec) - (resolve-dependency-name component dep-spec) - (resolve-dependency-combination component (car dep-spec) (cdr dep-spec))))) - - ;; Methods for RESOLVE-DEPENDENCY-COMBINATION to parse lists as dependency specifications. - (defmethod resolve-dependency-combination (component combinator arguments) - (parameter-error (compatfmt "~@") - 'resolve-dependency-combination (cons combinator arguments) component)) - - (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) - (when (featurep (first arguments)) - (resolve-dependency-spec component (second arguments)))) - - (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments) - (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788 - -;;;; ------------------------------------------------------------------------- -;;;; Forcing - -(uiop/package:define-package :asdf/forcing - (:recycle :asdf/forcing :asdf/plan :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/operation :asdf/system :asdf/system-registry) - (:export - #:forcing #:make-forcing #:forced #:forced-not #:performable-p - #:normalize-forced-systems #:normalize-forced-not-systems - #:action-forced-p #:action-forced-not-p)) -(in-package :asdf/forcing) - -;;;; Forcing -(with-upgradability () - (defclass forcing () - (;; Can plans using this forcing be PERFORMed? A plan that has different force and force-not - ;; settings than the session can only be used for read-only queries that do not cause the - ;; status of any action to be raised. - (performable-p :initform nil :initarg :performable-p :reader performable-p) - ;; Parameters - (parameters :initform nil :initarg :parameters :reader parameters) - ;; Table of systems specified via :force arguments - (forced :initarg :forced :reader forced) - ;; Table of systems specified via :force-not argument (and/or immutable) - (forced-not :initarg :forced-not :reader forced-not))) - - (defgeneric action-forced-p (forcing operation component) - (:documentation "Is this action forced to happen in this plan?")) - (defgeneric action-forced-not-p (forcing operation component) - (:documentation "Is this action forced to not happen in this plan? -Takes precedence over action-forced-p.")) - - (defun normalize-forced-systems (force system) - "Given a SYSTEM on which operate is called and the specified FORCE argument, -extract a hash-set of systems that are forced, or a predicate on system names, -or NIL if none are forced, or :ALL if all are." - (etypecase force - ((or (member nil :all) hash-table function) force) - (cons (list-to-hash-set (mapcar #'coerce-name force))) - ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) - - (defun normalize-forced-not-systems (force-not system) - "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument, -and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not, -or predicate on system names, or NIL if none are forced, or :ALL if all are." - (let ((requested - (etypecase force-not - ((or (member nil :all) hash-table function) force-not) - (cons (list-to-hash-set (mapcar #'coerce-name force-not))) - ((eql t) (if system (let ((name (coerce-name system))) - #'(lambda (x) (not (equal x name)))) - :all))))) - (if (and *immutable-systems* requested) - #'(lambda (x) (or (call-function requested x) - (call-function *immutable-systems* x))) - (or *immutable-systems* requested)))) - - ;; TODO: shouldn't we be looking up the primary system name, rather than the system name? - (defun action-override-p (forcing operation component override-accessor) - "Given a plan, an action, and a function that given the plan accesses a set of overrides, -i.e. force or force-not, see if the override applies to the current action." - (declare (ignore operation)) - (call-function (funcall override-accessor forcing) - (coerce-name (component-system (find-component () component))))) - - (defmethod action-forced-p (forcing operation component) - (and - ;; Did the user ask us to re-perform the action? - (action-override-p forcing operation component 'forced) - ;; You really can't force a builtin system and :all doesn't apply to it. - (not (builtin-system-p (component-system component))))) - - (defmethod action-forced-not-p (forcing operation component) - ;; Did the user ask us to not re-perform the action? - ;; NB: force-not takes precedence over force, as it should - (action-override-p forcing operation component 'forced-not)) - - ;; Null forcing means no forcing either way - (defmethod action-forced-p ((forcing null) (operation operation) (component component)) - nil) - (defmethod action-forced-not-p ((forcing null) (operation operation) (component component)) - nil) - - (defun or-function (fun1 fun2) - (cond - ((or (null fun2) (eq fun1 :all)) fun1) - ((or (null fun1) (eq fun2 :all)) fun2) - (t #'(lambda (x) (or (call-function fun1 x) (call-function fun2 x)))))) - - (defun make-forcing (&key performable-p system - (force nil force-p) (force-not nil force-not-p) &allow-other-keys) - (let* ((session-forcing (when *asdf-session* (forcing *asdf-session*))) - (system (and system (coerce-name system))) - (forced (normalize-forced-systems force system)) - (forced-not (normalize-forced-not-systems force-not system)) - (parameters `(,@(when force `(:force ,force)) - ,@(when force-not `(:force-not ,force-not)) - ,@(when (or (eq force t) (eq force-not t)) `(:system ,system)) - ,@(when performable-p `(:performable-p t)))) - forcing) - (cond - ((not session-forcing) - (setf forcing (make-instance 'forcing - :performable-p performable-p :parameters parameters - :forced forced :forced-not forced-not)) - (when (and performable-p *asdf-session*) - (setf (forcing *asdf-session*) forcing))) - (performable-p - (when (and (not (equal parameters (parameters session-forcing))) - (or force-p force-not-p)) - (parameter-error "~*~S and ~S arguments not allowed in a nested call to ~3:*~S ~ -unless identically to toplevel" - (find-symbol* :operate :asdf) :force :force-not)) - (setf forcing session-forcing)) - (t - (setf forcing (make-instance 'forcing - ;; Combine force and force-not with values from the toplevel-plan - :parameters `(,@parameters :on-top-of ,(parameters session-forcing)) - :forced (or-function (forced session-forcing) forced) - :forced-not (or-function (forced-not session-forcing) forced-not))))) - forcing)) - - (defmethod print-object ((forcing forcing) stream) - (print-unreadable-object (forcing stream :type t) - (format stream "~{~S~^ ~}" (parameters forcing)))) - - ;; During upgrade, the *asdf-session* may legitimately be NIL, so we must handle that case. - (defmethod forcing ((x null)) - (if-let (session (toplevel-asdf-session)) - (forcing session) - (make-forcing :performable-p t))) - - ;; When performing a plan that is a list of actions, use the toplevel asdf sesssion forcing. - (defmethod forcing ((x cons)) (forcing (toplevel-asdf-session)))) -;;;; ------------------------------------------------------------------------- -;;;; Plan - -(uiop/package:define-package :asdf/plan - ;; asdf/action below is needed for required-components, traverse-action and traverse-sub-actions - ;; that used to live there before 3.2.0. - (:recycle :asdf/plan :asdf/action :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/operation :asdf/action :asdf/lisp-action - :asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing) - (:export - #:plan #:plan-traversal #:sequential-plan #:*plan-class* - #:action-status #:status-stamp #:status-index #:status-done-p #:status-keep-p #:status-need-p - #:action-already-done-p - #:+status-good+ #:+status-todo+ #:+status-void+ - #:system-out-of-date #:action-up-to-date-p - #:circular-dependency #:circular-dependency-actions - #:needed-in-image-p - #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies - #:compute-action-stamp #:traverse-action #:record-dependency - #:make-plan #:plan-actions #:plan-actions-r #:perform-plan #:mark-as-done - #:required-components #:filtered-sequential-plan - #:plan-component-type #:plan-keep-operation #:plan-keep-component)) -(in-package :asdf/plan) - -;;;; Generic plan traversal class -(with-upgradability () - (defclass plan () () - (:documentation "Base class for a plan based on which ASDF can build a system")) - (defclass plan-traversal (plan) - (;; The forcing parameters for this plan. Also indicates whether the plan is performable, - ;; in which case the forcing is the same as for the entire session. - (forcing :initform (forcing (toplevel-asdf-session)) :initarg :forcing :reader forcing)) - (:documentation "Base class for plans that simply traverse dependencies")) - ;; Sequential plans (the default) - (defclass sequential-plan (plan-traversal) - ((actions-r :initform nil :accessor plan-actions-r)) - (:documentation "Simplest, default plan class, accumulating a sequence of actions")) - - (defgeneric plan-actions (plan) - (:documentation "Extract from a plan a list of actions to perform in sequence")) - (defmethod plan-actions ((plan list)) - plan) - (defmethod plan-actions ((plan sequential-plan)) - (reverse (plan-actions-r plan))) - - (defgeneric record-dependency (plan operation component) - (:documentation "Record that, within PLAN, performing OPERATION on COMPONENT depends on all -of the (OPERATION . COMPONENT) actions in the current ASDF session's VISITING-ACTION-LIST. - -You can get a single action which dominates the set of dependencies corresponding to this call with -(first (visiting-action-list *asdf-session*)) -since VISITING-ACTION-LIST is a stack whose top action depends directly on its second action, -and whose second action depends directly on its third action, and so forth.")) - - ;; No need to record a dependency to build a full graph, just accumulate nodes in order. - (defmethod record-dependency ((plan sequential-plan) (o operation) (c component)) - (values))) - -(when-upgrading (:version "3.3.0") - (defmethod initialize-instance :after ((plan plan-traversal) &key &allow-other-keys))) - - -;;;; Planned action status -(with-upgradability () - (defclass action-status () - ((bits - :type fixnum :initarg :bits :reader status-bits - :documentation "bitmap describing the status of the action.") - (stamp - :type (or integer boolean) :initarg :stamp :reader status-stamp - :documentation "STAMP associated with the ACTION if it has been completed already in some -previous session or image, T if it was done and builtin the image, or NIL if it needs to be done.") - (level - :type fixnum :initarg :level :initform 0 :reader status-level - :documentation "the highest (operate-level) at which the action was needed") - (index - :type (or integer null) :initarg :index :initform nil :reader status-index - :documentation "INDEX associated with the ACTION in the current session, -or NIL if no the status is considered outside of a specific plan.")) - (:documentation "Status of an action in a plan")) - - ;; STAMP KEEP-P DONE-P NEED-P symbol bitmap previously currently - ;; not-nil T T T => GOOD 7 up-to-date done (e.g. file previously loaded) - ;; not-nil T T NIL => HERE 6 up-to-date unplanned yet done - ;; not-nil T NIL T => REDO 5 up-to-date planned (e.g. file to load) - ;; not-nil T NIL NIL => SKIP 4 up-to-date unplanned (e.g. file compiled) - ;; not-nil NIL T T => DONE 3 out-of-date done - ;; not-nil NIL T NIL => WHAT 2 out-of-date unplanned yet done(?) - ;; NIL NIL NIL T => TODO 1 out-of-date planned - ;; NIL NIL NIL NIL => VOID 0 out-of-date unplanned - ;; - ;; Note that a VOID status cannot happen as part of a transitive dependency of a wanted node - ;; while traversing a node with TRAVERSE-ACTION; it can only happen while checking whether an - ;; action is up-to-date with ACTION-UP-TO-DATE-P. - ;; - ;; When calling TRAVERSE-ACTION, the +need-bit+ is set, - ;; unless the action is up-to-date and not needed-in-image (HERE, SKIP). - ;; When PERFORMing an action, the +done-bit+ is set. - ;; When the +need-bit+ is set but not the +done-bit+, the level slot indicates which level of - ;; OPERATE it was last marked needed for; if it happens to be needed at a higher-level, then - ;; its urgency (and that of its transitive dependencies) must be escalated so that it will be - ;; done before the end of this level of operate. - ;; - ;; Also, when no ACTION-STATUS is associated to an action yet, NIL serves as a bottom value. - ;; - (defparameter +keep-bit+ 4) - (defparameter +done-bit+ 2) - (defparameter +need-bit+ 1) - (defparameter +good-bits+ 7) - (defparameter +todo-bits+ 1) - (defparameter +void-bits+ 0) - - (defparameter +status-good+ - (make-instance 'action-status :bits +good-bits+ :stamp t)) - (defparameter +status-todo+ - (make-instance 'action-status :bits +todo-bits+ :stamp nil)) - (defparameter +status-void+ - (make-instance 'action-status :bits +void-bits+ :stamp nil))) - -(with-upgradability () - (defun make-action-status (&key bits stamp (level 0) index) - (check-type bits (integer 0 7)) - (check-type stamp (or integer boolean)) - (check-type level (integer 0 #.most-positive-fixnum)) - (check-type index (or integer null)) - (assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) () - "Bad action-status :bits ~S :stamp ~S" bits stamp) - (block nil - (when (and (null index) (zerop level)) - (case bits - (#.+void-bits+ (return +status-void+)) - (#.+todo-bits+ (return +status-todo+)) - (#.+good-bits+ (when (eq stamp t) (return +status-good+))))) - (make-instance 'action-status :bits bits :stamp stamp :level level :index index))) - - (defun status-keep-p (status) - (plusp (logand (status-bits status) #.+keep-bit+))) - (defun status-done-p (status) - (plusp (logand (status-bits status) #.+done-bit+))) - (defun status-need-p (status) - (plusp (logand (status-bits status) #.+need-bit+))) - - (defun merge-action-status (status1 status2) ;; status-and - "Return the earliest status later than both status1 and status2" - (make-action-status - :bits (logand (status-bits status1) (status-bits status2)) - :stamp (latest-timestamp (status-stamp status1) (status-stamp status2)) - :level (min (status-level status1) (status-level status2)) - :index (or (status-index status1) (status-index status2)))) - - (defun mark-status-needed (status &optional (level (operate-level))) ;; limited status-or - "Return the same status but with the need bit set, for the given level" - (if (and (status-need-p status) - (>= (status-level status) level)) - status - (make-action-status - :bits (logior (status-bits status) +need-bit+) - :level (max level (status-level status)) - :stamp (status-stamp status) - :index (status-index status)))) - - (defmethod print-object ((status action-status) stream) - (print-unreadable-object (status stream :type t) - (with-slots (bits stamp level index) status - (format stream "~{~S~^ ~}" `(:bits ,bits :stamp ,stamp :level ,level :index ,index))))) - - (defgeneric action-status (plan operation component) - (:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT -in the PLAN, or NIL if the action wasn't visited yet as part of the PLAN.")) - - (defgeneric (setf action-status) (new-status plan operation component) - (:documentation "Sets the ACTION-STATUS associated to -the action of OPERATION on COMPONENT in the PLAN")) - - (defmethod action-status ((plan null) (o operation) (c component)) - (multiple-value-bind (stamp done-p) (component-operation-time o c) - (if done-p - (make-action-status :bits #.+keep-bit+ :stamp stamp) - +status-void+))) - - (defmethod (setf action-status) (new-status (plan null) (o operation) (c component)) - (let ((times (component-operation-times c))) - (if (status-done-p new-status) - (setf (gethash o times) (status-stamp new-status)) - (remhash o times))) - new-status) - - ;; Handle FORCED-NOT: it makes an action return its current timestamp as status - (defmethod action-status ((p plan) (o operation) (c component)) - ;; TODO: should we instead test something like: - ;; (action-forced-not-p plan operation (primary-system component)) - (or (gethash (make-action o c) (visited-actions *asdf-session*)) - (when (action-forced-not-p (forcing p) o c) - (let ((status (action-status nil o c))) - (setf (gethash (make-action o c) (visited-actions *asdf-session*)) - (make-action-status - :bits +good-bits+ - :stamp (or (and status (status-stamp status)) t) - :index (incf (total-action-count *asdf-session*)))))))) - - (defmethod (setf action-status) (new-status (p plan) (o operation) (c component)) - (setf (gethash (make-action o c) (visited-actions *asdf-session*)) new-status)) - - (defmethod (setf action-status) :after - (new-status (p sequential-plan) (o operation) (c component)) - (unless (status-done-p new-status) - (push (make-action o c) (plan-actions-r p))))) - - -;;;; Is the action needed in this image? -(with-upgradability () - (defgeneric needed-in-image-p (operation component) - (:documentation "Is the action of OPERATION on COMPONENT needed in the current image -to be meaningful, or could it just as well have been done in another Lisp image?")) - - (defmethod needed-in-image-p ((o operation) (c component)) - ;; We presume that actions that modify the filesystem don't need be run - ;; in the current image if they have already been done in another, - ;; and can be run in another process (e.g. a fork), - ;; whereas those that don't are meant to side-effect the current image and can't. - (not (output-files o c)))) - - -;;;; Visiting dependencies of an action and computing action stamps -(with-upgradability () - (defun map-direct-dependencies (operation component fun) - "Call FUN on all the valid dependencies of the given action in the given plan" - (loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) - :for dep-o = (find-operation operation dep-o-spec) - :when dep-o - :do (loop :for dep-c-spec :in dep-c-specs - :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec)) - :when (action-valid-p dep-o dep-c) - :do (funcall fun dep-o dep-c)))) - - (defun reduce-direct-dependencies (operation component combinator seed) - "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR -for each dependency action on the dependency's operation and component and an accumulator -initialized with SEED." - (map-direct-dependencies - operation component - #'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed)))) - seed) - - (defun direct-dependencies (operation component) - "Compute a list of the direct dependencies of the action within the plan" - (reverse (reduce-direct-dependencies operation component #'acons nil))) - - ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp - ;; shall also be parametrized by the plan, or by a second model object, - ;; so they need not refer to the state of the filesystem, - ;; and the stamps could be cryptographic checksums rather than timestamps. - ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP. - (define-condition dependency-not-done (warning) - ((op - :initarg :op) - (component - :initarg :component) - (dep-op - :initarg :dep-op) - (dep-component - :initarg :dep-component) - (plan - :initarg :plan - :initform nil)) - (:report (lambda (condition stream) - (with-slots (op component dep-op dep-component plan) condition - (format stream "Computing just-done stamp ~@[in plan ~S~] for action ~S, but dependency ~S wasn't done yet!" - plan - (action-path (make-action op component)) - (action-path (make-action dep-op dep-component))))))) - - (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) - ;; Given an action, figure out at what time in the past it has been done, - ;; or if it has just been done, return the time that it has. - ;; Returns two values: - ;; 1- the TIMESTAMP of the action if it has already been done and is up to date, - ;; or NIL is either hasn't been done or is out of date. - ;; (An ASDF extension could use a cryptographic digest instead.) - ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done - ;; in the current image, or NIL if it hasn't. - ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but - ;; hasn't been done in the current image yet, then it can have a non-NIL timestamp, - ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded, - ;; i.e. that of the input-files. - ;; If just-done is NIL, these values return are the notional fields of - ;; a KEEP, REDO or TODO status (VOID is possible, but probably an error). - ;; If just-done is T, they are the notional fields of DONE status - ;; (or, if something went wrong, TODO). - (nest - (block ()) - (let* ((dep-status ; collect timestamp from dependencies (or T if forced or out-of-date) - (reduce-direct-dependencies - o c - #'(lambda (do dc status) - ;; out-of-date dependency: don't bother looking further - (let ((action-status (action-status plan do dc))) - (cond - ((and action-status (or (status-keep-p action-status) - (and just-done (status-stamp action-status)))) - (merge-action-status action-status status)) - (just-done - ;; It's OK to lose some ASDF action stamps during self-upgrade - (unless (equal "asdf" (primary-system-name dc)) - (warn 'dependency-not-done - :plan plan - :op o :component c - :dep-op do :dep-component dc)) - status) - (t - (return (values nil nil)))))) - +status-good+)) - (dep-stamp (status-stamp dep-status)))) - (let* (;; collect timestamps from inputs, and exit early if any is missing - (in-files (input-files o c)) - (in-stamps (mapcar #'get-file-stamp in-files)) - (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) - (latest-in (timestamps-latest (cons dep-stamp in-stamps)))) - (when (and missing-in (not just-done)) (return (values nil nil)))) - (let* (;; collect timestamps from outputs, and exit early if any is missing - (out-files (remove-if 'null (output-files o c))) - (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) - (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) - (earliest-out (timestamps-earliest out-stamps))) - (when (and missing-out (not just-done)) (return (values nil nil)))) - (let (;; Time stamps from the files at hand, and whether any is missing - (all-present (not (or missing-in missing-out))) - ;; Has any input changed since we last generated the files? - ;; Note that we use timestamp<= instead of timestamp< to play nice with generated files. - ;; Any race condition is intrinsic to the limited timestamp resolution. - (up-to-date-p (timestamp<= latest-in earliest-out)) - ;; If everything is up to date, the latest of inputs and outputs is our stamp - (done-stamp (timestamps-latest (cons latest-in out-stamps)))) - ;; Warn if some files are missing: - ;; either our model is wrong or some other process is messing with our files. - (when (and just-done (not all-present)) - ;; Shouldn't that be an error instead? - (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ - ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" - (action-description o c) - missing-in (length missing-in) (and missing-in missing-out) - missing-out (length missing-out)))) - (let (;; There are three kinds of actions: - (out-op (and out-files t)) ; those that create files on the filesystem - ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image - ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing - )) - (if (or just-done ;; The done-stamp is valid: if we're just done, or - (and all-present ;; if all filesystem effects are up-to-date - up-to-date-p - (operation-done-p o c) ;; and there's no invalidating reason. - (not (action-forced-p (forcing (or plan *asdf-session*)) o c)))) - (values done-stamp ;; return the hard-earned timestamp - (or just-done - out-op ;; A file-creating op is done when all files are up to date. - ;; An image-effecting operation is done when - (and (status-done-p dep-status) ;; all the dependencies were done, and - (multiple-value-bind (perform-stamp perform-done-p) - (component-operation-time o c) - (and perform-done-p ;; the op was actually run, - (equal perform-stamp done-stamp)))))) ;; with a matching stamp. - ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet - (values nil nil))))) - - -;;;; The four different actual traversals: -;; * TRAVERSE-ACTION o c T: Ensure all dependencies are either up-to-date in-image, or planned -;; * TRAVERSE-ACTION o c NIL: Ensure all dependencies are up-to-date or planned, in-image or not -;; * ACTION-UP-TO-DATE-P: Check whether some (defsystem-depends-on ?) dependencies are up to date -;; * COLLECT-ACTION-DEPENDENCIES: Get the dependencies (filtered), don't change any status -(with-upgradability () - - ;; Compute the action status for a newly visited action. - (defun compute-action-status (plan operation component need-p) - (multiple-value-bind (stamp done-p) - (compute-action-stamp plan operation component) - (assert (or stamp (not done-p))) - (make-action-status - :bits (logior (if stamp #.+keep-bit+ 0) - (if done-p #.+done-bit+ 0) - (if need-p #.+need-bit+ 0)) - :stamp stamp - :level (operate-level) - :index (incf (total-action-count *asdf-session*))))) - - ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data, - ;; visits the action defined by its OPERATION and COMPONENT arguments, - ;; and all its transitive dependencies (unless already visited), - ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P, - ;; i.e. needs to be done in the current image vs merely have been done in a previous image. - ;; - ;; TRAVERSE-ACTION updates the VISITED-ACTIONS entries for the action and for all its - ;; transitive dependencies (that haven't been sufficiently visited so far). - ;; It does not return any usable value. - ;; - ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action, - ;; the below method would be insufficient, since it assumes a single image - ;; to traverse each node at most twice; non-niip actions would be traversed only once, - ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action. - - (defun traverse-action (plan operation component needed-in-image-p) - (block nil - (unless (action-valid-p operation component) (return)) - ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph, - ;; instead of just a dependency order as in vanilla ASDF. - ;; TODO: It is also needed to detect OPERATE-in-PERFORM. - (record-dependency plan operation component) - (while-visiting-action (operation component) ; maintain context, handle circularity. - ;; needed-in-image distinguishes b/w things that must happen in the - ;; current image and those things that simply need to have been done in a previous one. - (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image - ;; effective niip: meaningful for the action and required by the plan as traversed - (eniip (and aniip needed-in-image-p)) - ;; status: have we traversed that action previously, and if so what was its status? - (status (action-status plan operation component)) - (level (operate-level))) - (when (and status - (or (status-done-p status) ;; all done - (and (status-need-p status) (<= level (status-level status))) ;; already visited - (and (status-keep-p status) (not eniip)))) ;; up-to-date and not eniip - (return)) ; Already visited with sufficient need-in-image level! - (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T - (map-direct-dependencies ; recursively traverse dependencies - operation component #'(lambda (o c) (traverse-action plan o c niip))) - ;; AFTER dependencies have been traversed, compute action stamp - (let* ((status (if status - (mark-status-needed status level) - (compute-action-status plan operation component t))) - (out-of-date-p (not (status-keep-p status))) - (to-perform-p (or out-of-date-p (and niip (not (status-done-p status)))))) - (cond ; it needs be done if it's out of date or needed in image but absent - ((and out-of-date-p (not niip)) ; if we need to do it, - (visit-action t)) ; then we need to do it *in the (current) image*! - (t - (setf (action-status plan operation component) status) - (when (status-done-p status) - (setf (component-operation-time operation component) - (status-stamp status))) - (when to-perform-p ; if it needs to be added to the plan, count it - (incf (planned-action-count *asdf-session*)) - (unless aniip ; if it's output-producing, count it - (incf (planned-output-action-count *asdf-session*))))))))) - (visit-action eniip)))))) ; visit the action - - ;; NB: This is not an error, not a warning, but a normal expected condition, - ;; to be to signaled by FIND-SYSTEM when it detects an out-of-date system, - ;; *before* it tries to replace it with a new definition. - (define-condition system-out-of-date (condition) - ((name :initarg :name :reader component-name)) - (:documentation "condition signaled when a system is detected as being out of date") - (:report (lambda (c s) - (format s "system ~A is out of date" (component-name c))))) - - (defun action-up-to-date-p (plan operation component) - "Check whether an action was up-to-date at the beginning of the session. -Update the VISITED-ACTIONS table with the known status, but don't add anything to the PLAN." - (block nil - (unless (action-valid-p operation component) (return t)) - (while-visiting-action (operation component) ; maintain context, handle circularity. - ;; Do NOT record the dependency: it might be out of date. - (let ((status (or (action-status plan operation component) - (setf (action-status plan operation component) - (let ((dependencies-up-to-date-p - (handler-case - (block nil - (map-direct-dependencies - operation component - #'(lambda (o c) - (unless (action-up-to-date-p plan o c) - (return nil)))) - t) - (system-out-of-date () nil)))) - (if dependencies-up-to-date-p - (compute-action-status plan operation component nil) - +status-void+)))))) - (and (status-keep-p status) (status-stamp status))))))) - - -;;;; Incidental traversals - -;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source -;;; files required by a bundling operation. -(with-upgradability () - (defclass filtered-sequential-plan (sequential-plan) - ((component-type :initform t :initarg :component-type :reader plan-component-type) - (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation) - (keep-component :initform t :initarg :keep-component :reader plan-keep-component)) - (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions.")) - - (defmethod initialize-instance :after ((plan filtered-sequential-plan) - &key system other-systems) - ;; Ignore force and force-not, rely on other-systems: - ;; force traversal of what we're interested in, i.e. current system or also others; - ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems. - (setf (slot-value plan 'forcing) - (make-forcing :system system :force :all :force-not (if other-systems nil t)))) - - (defmethod plan-actions ((plan filtered-sequential-plan)) - (with-slots (keep-operation keep-component) plan - (loop :for action :in (call-next-method) - :as o = (action-operation action) - :as c = (action-component action) - :when (and (typep o keep-operation) (typep c keep-component)) - :collect (make-action o c)))) - - (defun collect-action-dependencies (plan operation component) - (when (action-valid-p operation component) - (while-visiting-action (operation component) ; maintain context, handle circularity. - (let ((action (make-action operation component))) - (unless (nth-value 1 (gethash action (visited-actions *asdf-session*))) - (setf (gethash action (visited-actions *asdf-session*)) nil) - (when (and (typep component (plan-component-type plan)) - (not (action-forced-not-p (forcing plan) operation component))) - (map-direct-dependencies operation component - #'(lambda (o c) (collect-action-dependencies plan o c))) - (push action (plan-actions-r plan)))))))) - - (defgeneric collect-dependencies (operation component &key &allow-other-keys) - (:documentation "Given an action, build a plan for all of its dependencies.")) - (define-convenience-action-methods collect-dependencies (operation component &key)) - (defmethod collect-dependencies ((operation operation) (component component) - &rest keys &key &allow-other-keys) - (let ((plan (apply 'make-instance 'filtered-sequential-plan - :system (component-system component) keys))) - (loop :for action :in (direct-dependencies operation component) - :do (collect-action-dependencies plan (action-operation action) (action-component action))) - (plan-actions plan))) - - (defun required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) - "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and -return a list of the components involved in building the desired action." - (with-asdf-session (:override t) - (remove-duplicates - (mapcar 'action-component - (apply 'collect-dependencies goal-operation system - (remove-plist-key :goal-operation keys))) - :from-end t)))) - - -;;;; High-level interface: make-plan, perform-plan -(with-upgradability () - (defgeneric make-plan (plan-class operation component &key &allow-other-keys) - (:documentation "Generate and return a plan for performing OPERATION on COMPONENT.")) - (define-convenience-action-methods make-plan (plan-class operation component &key)) - - (defgeneric mark-as-done (plan-class operation component) - (:documentation "Mark an action as done in a plan, after performing it.")) - (define-convenience-action-methods mark-as-done (plan-class operation component)) - - (defgeneric perform-plan (plan &key) - (:documentation "Actually perform a plan and build the requested actions")) - - (defparameter* *plan-class* 'sequential-plan - "The default plan class to use when building with ASDF") - - (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) - (with-asdf-session () - (let ((plan (apply 'make-instance (or plan-class *plan-class*) keys))) - (traverse-action plan o c t) - plan))) - - (defmethod perform-plan :around ((plan t) &key) - (assert (performable-p (forcing plan)) () "plan not performable") - (let ((*package* *package*) - (*readtable* *readtable*)) - (with-compilation-unit () ;; backward-compatibility. - (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. - - (defun action-already-done-p (plan operation component) - (if-let (status (action-status plan operation component)) - (status-done-p status))) - - (defmethod perform-plan ((plan t) &key) - (loop :for action :in (plan-actions plan) - :as o = (action-operation action) - :as c = (action-component action) :do - (unless (action-already-done-p plan o c) - (perform-with-restarts o c) - (mark-as-done plan o c)))) - - (defmethod mark-as-done ((plan plan) (o operation) (c component)) - (let ((plan-status (action-status plan o c)) - (perform-status (action-status nil o c))) - (assert (and (status-stamp perform-status) (status-keep-p perform-status)) () - "Just performed ~A but failed to mark it done" (action-description o c)) - (setf (action-status plan o c) - (make-action-status - :bits (logior (status-bits plan-status) +done-bit+) - :stamp (status-stamp perform-status) - :level (status-level plan-status) - :index (status-index plan-status)))))) -;;;; ------------------------------------------------------------------------- -;;;; Invoking Operations - -(uiop/package:define-package :asdf/operate - (:recycle :asdf/operate :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/system-registry :asdf/find-component - :asdf/operation :asdf/action :asdf/lisp-action :asdf/forcing :asdf/plan) - (:export - #:operate #:oos #:build-op #:make - #:load-system #:load-systems #:load-systems* - #:compile-system #:test-system #:require-system #:module-provide-asdf - #:component-loaded-p #:already-loaded-systems - #:recursive-operate)) -(in-package :asdf/operate) - -(with-upgradability () - (defgeneric operate (operation component &key) - (:documentation - "Operate does mainly four things for the user: - -1. Resolves the OPERATION designator into an operation object. - OPERATION is typically a symbol denoting an operation class, instantiated with MAKE-OPERATION. -2. Resolves the COMPONENT designator into a component object. - COMPONENT is typically a string or symbol naming a system, loaded from disk using FIND-SYSTEM. -3. It then calls MAKE-PLAN with the operation and system as arguments. -4. Finally calls PERFORM-PLAN on the resulting plan to actually build the system. - -The entire computation is wrapped in WITH-COMPILATION-UNIT and error handling code. -If a VERSION argument is supplied, then operate also ensures that the system found satisfies it -using the VERSION-SATISFIES method. -If a PLAN-CLASS argument is supplied, that class is used for the plan. -If a PLAN-OPTIONS argument is supplied, the options are passed to the plan. - -The :FORCE or :FORCE-NOT argument to OPERATE can be: - T to force the inside of the specified system to be rebuilt (resp. not), - without recursively forcing the other systems we depend on. - :ALL to force all systems including other systems we depend on to be rebuilt (resp. not). - (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list -:FORCE-NOT has precedence over :FORCE; builtin systems cannot be forced. - -For backward compatibility, all keyword arguments are passed to MAKE-OPERATION -when instantiating a new operation, that will in turn be inherited by new operations. -But do NOT depend on it, for this is deprecated behavior.")) - - (define-convenience-action-methods operate (operation component &key) - :if-no-component (error 'missing-component :requires component)) - - ;; This method ensures that an ASDF upgrade is attempted as the very first thing, - ;; with suitable state preservation in case in case it actually happens, - ;; and that a few suitable dynamic bindings are established. - (defmethod operate :around (operation component &rest keys - &key verbose - (on-warnings *compile-file-warnings-behaviour*) - (on-failure *compile-file-failure-behaviour*)) - (nest - (with-asdf-session ()) - (let* ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) - (etypecase operation - (operation (let ((name (type-of operation))) - #'(lambda () (make-operation name)))) - ((or symbol string) (constantly operation)))) - (component-path (typecase component ;; to remake the component after ASDF upgrade - (component (component-find-path component)) - (t component))) - (system-name (labels ((first-name (x) - (etypecase x - ((or string symbol) x) ; NB: includes the NIL case. - (cons (or (first-name (car x)) (first-name (cdr x))))))) - (coerce-name (first-name component-path))))) - (apply 'make-forcing :performable-p t :system system-name keys) - ;; Before we operate on any system, make sure ASDF is up-to-date, - ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. - (unless (asdf-upgraded-p (toplevel-asdf-session)) - (setf (asdf-upgraded-p (toplevel-asdf-session)) t) - (when (upgrade-asdf) - ;; If we were upgraded, restart OPERATE the hardest of ways, for - ;; its function may have been redefined. - (return-from operate - (with-asdf-session (:override t :override-cache t) - (apply 'operate (funcall operation-remaker) component-path keys)))))) - ;; Setup proper bindings around any operate call. - (let* ((*verbose-out* (and verbose *standard-output*)) - (*compile-file-warnings-behaviour* on-warnings) - (*compile-file-failure-behaviour* on-failure))) - (unwind-protect - (progn - (incf (operate-level)) - (call-next-method)) - (decf (operate-level))))) - - (defmethod operate :before ((operation operation) (component component) - &key version) - (unless (version-satisfies component version) - (error 'missing-component-of-version :requires component :version version)) - (record-dependency nil operation component)) - - (defmethod operate ((operation operation) (component component) - &key plan-class plan-options) - (let ((plan (apply 'make-plan plan-class operation component - :forcing (forcing *asdf-session*) plan-options))) - (perform-plan plan) - (values operation plan))) - - (defun oos (operation component &rest args &key &allow-other-keys) - (apply 'operate operation component args)) - - (setf (documentation 'oos 'function) - (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" - (documentation 'operate 'function))) - - (define-condition recursive-operate (warning) - ((operation :initarg :operation :reader condition-operation) - (component :initarg :component :reader condition-component) - (action :initarg :action :reader condition-action)) - (:report (lambda (c s) - (format s (compatfmt "~@") - 'operate - (type-of (condition-operation c)) - (component-find-path (condition-component c)) - (action-path (condition-action c))))))) - -;;;; Common operations -(when-upgrading () - (defmethod component-depends-on ((o prepare-op) (s system)) - (call-next-method))) -(with-upgradability () - (defclass build-op (non-propagating-operation) () - (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation, -to operate by default on a system or component, via the function BUILD. -Its meaning is configurable via the :BUILD-OPERATION option of a component. -which typically specifies the name of a specific operation to which to delegate the build, -as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on); -if NIL is specified (the default), BUILD-OP falls back to LOAD-OP, -that will load the system in the current image.")) - (defmethod component-depends-on ((o build-op) (c component)) - `((,(or (component-build-operation c) 'load-op) ,c) - ,@(call-next-method))) - - (defun make (system &rest keys) - "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO). -It will build system FOO using the operation BUILD-OP, -the meaning of which is configurable by the system, and -defaults to LOAD-OP, to load it in current image." - (apply 'operate 'build-op system keys) - t) - - (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys) - "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." - (declare (ignore force force-not verbose version)) - (apply 'operate 'load-op system keys) - t) - - (defun load-systems* (systems &rest keys) - "Loading multiple systems at once." - (dolist (s systems) (apply 'load-system s keys))) - - (defun load-systems (&rest systems) - "Loading multiple systems at once." - (load-systems* systems)) - - (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys) - "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." - (declare (ignore force force-not verbose version)) - (apply 'operate 'compile-op system args) - t) - - (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys) - "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." - (declare (ignore force force-not verbose version)) - (apply 'operate 'test-op system args) - t)) - -;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE, -;; only tries to load its specified target if it's not loaded yet. -(with-upgradability () - (defun component-loaded-p (component) - "Has the given COMPONENT been successfully loaded in the current image (yet)? -Note that this returns true even if the component is not up to date." - (if-let ((component (find-component component () :registered t))) - (nth-value 1 (component-operation-time (make-operation 'load-op) component)))) - - (defun already-loaded-systems () - "return a list of the names of the systems that have been successfully loaded so far" - (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*))))) - - -;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible, -;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL -;; Note that despite the two being homonyms, the _function_ require-system -;; and the _class_ require-system are quite distinct entities, fulfilling independent purposes. -(with-upgradability () - (defvar *modules-being-required* nil) - - (defclass require-system (system) - ((module :initarg :module :initform nil :accessor required-module)) - (:documentation "A SYSTEM subclass whose processing is handled by -the implementation's REQUIRE rather than by internal ASDF mechanisms.")) - - (defmethod perform ((o compile-op) (c require-system)) - nil) - - (defmethod perform ((o load-op) (s require-system)) - (let* ((module (or (required-module s) (coerce-name s))) - (*modules-being-required* (cons module *modules-being-required*))) - (assert (null (component-children s))) - (require module))) - - (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments) - (unless (and (length=n-p arguments 1) - (typep (car arguments) '(or string (and symbol (not null))))) - (parameter-error (compatfmt "~@") - 'resolve-dependency-combination - (cons combinator arguments) component combinator)) - ;; :require must be prepared for some implementations providing modules using ASDF, - ;; as SBCL used to do, and others may might do. Thus, the system provided in the end - ;; would be a downcased name as per module-provide-asdf above. For the same reason, - ;; we cannot assume that the system in the end will be of type require-system, - ;; but must check whether we can use find-system and short-circuit cl:require. - ;; Otherwise, calling cl:require could result in nasty reentrant calls between - ;; cl:require and asdf:operate that could potentially blow up the stack, - ;; all the while defeating the consistency of the dependency graph. - (let* ((module (car arguments)) ;; NB: we already checked that it was not null - ;; CMUCL, MKCL, SBCL like their module names to be all upcase. - (module-name (string module)) - (system-name (string-downcase module)) - (system (find-system system-name nil))) - (or system (let ((system (make-instance 'require-system :name system-name :module module-name))) - (register-system system) - system)))) - - (defun module-provide-asdf (name) - ;; We must use string-downcase, because modules are traditionally specified as symbols, - ;; that implementations traditionally normalize as uppercase, for which we seek a system - ;; with a name that is traditionally in lowercase. Case is lost along the way. That's fine. - ;; We could make complex, non-portable rules to try to preserve case, and just documenting - ;; them would be a hell that it would be a disservice to inflict on users. - (let ((module-name (string name)) - (system-name (string-downcase name))) - (unless (member module-name *modules-being-required* :test 'equal) - (let ((*modules-being-required* (cons module-name *modules-being-required*)) - #+sbcl (sb-impl::*requiring* (remove module-name sb-impl::*requiring* :test 'equal))) - (handler-bind - (((or style-warning recursive-operate) #'muffle-warning) - (missing-component (constantly nil)) - (fatal-condition - #'(lambda (e) - (format *error-output* (compatfmt "~@~%") - name e)))) - (let ((*verbose-out* (make-broadcast-stream))) - (let ((system (find-system system-name nil))) - (when system - ;; Do not use require-system after all, use load-system: - ;; on the one hand, REQUIRE already uses *MODULES* not to load something twice, - ;; on the other hand, REQUIRE-SYSTEM uses FORCE-NOT which may conflict with - ;; the toplevel session forcing settings. - (load-system system :verbose nil) - t))))))))) - - -;;;; Some upgrade magic -(with-upgradability () - (defun restart-upgraded-asdf () - ;; If we're in the middle of something, restart it. - (let ((systems-being-defined - (when *asdf-session* - (prog1 - (loop :for k :being :the hash-keys :of (asdf-cache) - :when (eq (first k) 'find-system) :collect (second k)) - (clrhash (asdf-cache)))))) - ;; Regardless, clear defined systems, since they might be invalid - ;; after an incompatible ASDF upgrade. - (clear-registered-systems) - ;; The configuration also may have to be upgraded. - (upgrade-configuration) - ;; If we were in the middle of an operation, be sure to restore the system being defined. - (dolist (s systems-being-defined) (find-system s nil)))) - (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf)) -;;;; ------------------------------------------------------------------------- -;;;; Finding systems - -(uiop/package:define-package :asdf/find-system - (:recycle :asdf/find-system :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/session :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-action - :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate) - (:import-from #:asdf/component #:%additional-input-files) - (:export - #:find-system #:locate-system #:load-asd #:define-op - #:load-system-definition-error #:error-name #:error-pathname #:error-condition)) -(in-package :asdf/find-system) - -(with-upgradability () - (define-condition load-system-definition-error (system-definition-error) - ((name :initarg :name :reader error-name) - (pathname :initarg :pathname :reader error-pathname) - (condition :initarg :condition :reader error-condition)) - (:report (lambda (c s) - (format s (compatfmt "~@") - (error-name c) (error-pathname c) (error-condition c))))) - - - ;;; Methods for find-system - - ;; Reject NIL as a system designator. - (defmethod find-system ((name null) &optional (error-p t)) - (when error-p - (sysdef-error (compatfmt "~@")))) - - ;; Default method for find-system: resolve the argument using COERCE-NAME. - (defmethod find-system (name &optional (error-p t)) - (find-system (coerce-name name) error-p)) - - (defun find-system-if-being-defined (name) - ;; This function finds systems being defined *in the current ASDF session*, as embodied by - ;; its session cache, even before they are fully defined and registered in *registered-systems*. - ;; The purpose of this function is to prevent races between two files that might otherwise - ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow. - ;; This function explicitly MUST NOT find definitions merely registered in previous sessions. - ;; NB: this function depends on a corresponding side-effect in parse-defsystem; - ;; the precise protocol between the two functions may change in the future (or not). - (first (gethash `(find-system ,(coerce-name name)) (asdf-cache)))) - - (defclass define-op (non-propagating-operation) () - (:documentation "An operation to record dependencies on loading a .asd file.")) - - (defmethod record-dependency ((plan null) (operation t) (component t)) - (unless (or (typep operation 'define-op) - (and (typep operation 'load-op) - (typep component 'system) - (equal "asdf" (coerce-name component)))) - (if-let ((action (first (visiting-action-list *asdf-session*)))) - (let ((parent-operation (action-operation action)) - (parent-component (action-component action))) - (cond - ((and (typep parent-operation 'define-op) - (typep parent-component 'system)) - (let ((action (cons operation component))) - (unless (gethash action (definition-dependency-set parent-component)) - (push (cons operation component) (definition-dependency-list parent-component)) - (setf (gethash action (definition-dependency-set parent-component)) t)))) - (t - (warn 'recursive-operate - :operation operation :component component :action action))))))) - - (defmethod component-depends-on ((o define-op) (s system)) - `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below. - ;; 2- We don't call-next-method to avoid other methods - ,@(loop :for (o . c) :in (definition-dependency-list s) :collect (list o c)))) - - (defmethod component-depends-on ((o operation) (s system)) - `(,@(when (and (not (typep o 'define-op)) - (or (system-source-file s) (definition-dependency-list s))) - `((define-op ,(primary-system-name s)))) - ,@(call-next-method))) - - (defmethod perform ((o operation) (c undefined-system)) - (sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c))) - - ;; TODO: could this file be refactored so that locate-system is merely - ;; the cache-priming call to input-files here? - (defmethod input-files ((o define-op) (s system)) - (if-let ((asd (system-source-file s))) (list asd))) - - (defmethod perform ((o define-op) (s system)) - (nest - (if-let ((pathname (first (input-files o s))))) - (let ((readtable *readtable*) ;; save outer syntax tables. TODO: proper syntax-control - (print-pprint-dispatch *print-pprint-dispatch*))) - (with-standard-io-syntax) - (let ((*print-readably* nil) - ;; Note that our backward-compatible *readtable* is - ;; a global readtable that gets globally side-effected. Ouch. - ;; Same for the *print-pprint-dispatch* table. - ;; We should do something about that for ASDF3 if possible, or else ASDF4. - (*readtable* readtable) ;; restore inside syntax table - (*print-pprint-dispatch* print-pprint-dispatch) - (*package* (find-package :asdf-user)) - (*default-pathname-defaults* - ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. - (pathname-directory-pathname (physicalize-pathname pathname))))) - (handler-bind - (((and error (not missing-component)) - #'(lambda (condition) - (error 'load-system-definition-error - :name (coerce-name s) :pathname pathname :condition condition)))) - (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") - (coerce-name s) pathname) - ;; dependencies will depend on what's loaded via definition-dependency-list - (unset-asdf-cache-entry `(component-depends-on ,o ,s)) - (unset-asdf-cache-entry `(input-files ,o ,s))) - (load* pathname :external-format (encoding-external-format (detect-encoding pathname))))) - - (defun load-asd (pathname &key name) - "Load system definitions from PATHNAME. -NAME if supplied is the name of a system expected to be defined in that file. - -Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." - (with-asdf-session () - ;; TODO: use OPERATE, so we consult the cache and only load once per session. - (flet ((do-it (o c) (operate o c))) - (let ((primary-name (primary-system-name (or name (pathname-name pathname)))) - (operation (make-operation 'define-op))) - (if-let (system (registered-system primary-name)) - (progn - ;; We already determine this to be obsolete --- - ;; or should we move some tests from find-system to check for up-to-date-ness here? - (setf (component-operation-time operation system) t - (definition-dependency-list system) nil - (definition-dependency-set system) (list-to-hash-set nil)) - (do-it operation system)) - (let ((system (make-instance 'undefined-system - :name primary-name :source-file pathname))) - (register-system system) - (unwind-protect (do-it operation system) - (when (typep system 'undefined-system) - (clear-system system))))))))) - - (defvar *old-asdf-systems* (make-hash-table :test 'equal)) - - ;; (Private) function to check that a system that was found isn't an asdf downgrade. - ;; Returns T if everything went right, NIL if the system was an ASDF at an older version, - ;; or UIOP of the same or older version, that shall not be loaded. - ;; Also issue a warning if it was a strictly older version of ASDF. - (defun check-not-old-asdf-system (name pathname) - (or (not (member name '("asdf" "uiop") :test 'equal)) - (null pathname) - (let* ((asdfp (equal name "asdf")) ;; otherwise, it's uiop - (version-pathname - (subpathname pathname "version" :type (if asdfp "lisp-expr" "lisp"))) - (version (and (probe-file* version-pathname :truename nil) - (read-file-form version-pathname :at (if asdfp '(0) '(2 2 2))))) - (old-version (asdf-version))) - (cond - ;; Same version is OK for ASDF, to allow loading from modified source. - ;; However, do *not* load UIOP of the exact same version: - ;; it was already loaded it as part of ASDF and would only be double-loading. - ;; Be quiet about it, though, since it's a normal situation. - ((equal old-version version) asdfp) - ((version< old-version version) t) ;; newer version: Good! - (t ;; old version: bad - (ensure-gethash - (list (namestring pathname) version) *old-asdf-systems* - #'(lambda () - (let ((old-pathname (system-source-file (registered-system "asdf")))) - (if asdfp - (warn "~@<~ - You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ - or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ - ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ - Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~ - and having an old version registered is a configuration error. ~ - ASDF will ignore this configured system rather than downgrade itself. ~ - In the future, you may want to either: ~ - (a) upgrade this configured ASDF to a newer version, ~ - (b) install a newer ASDF and register it in front of the former in your configuration, or ~ - (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~ - Note that the older ASDF might be registered implicitly through configuration inherited ~ - from your system installation, in which case you might have to specify ~ - :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~ - or other source-registry configuration file, environment variable or lisp parameter. ~ - Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~ - that you might want to upgrade (if a recent enough version is available) ~ - or else remove altogether (since most implementations ship with a recent asdf); ~ - if you lack the system administration rights to upgrade or remove this package, ~ - then you might indeed want to either install and register a more recent version, ~ - or use :ignore-inherited-configuration to avoid registering the old one. ~ - Please consult ASDF documentation and/or experts.~@:>~%" - old-version old-pathname version pathname) - ;; NB: for UIOP, don't warn, just ignore. - (warn "ASDF ~A (from ~A), UIOP ~A (from ~A)" - old-version old-pathname version pathname) - )))) - nil))))) ;; only issue the warning the first time, but always return nil - - (defun locate-system (name) - "Given a system NAME designator, try to locate where to load the system from. -Returns six values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME PREVIOUS-PRIMARY -FOUNDP is true when a system was found, -either a new unregistered one or a previously registered one. -FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed. -PATHNAME when not null is a path from which to load the system, -either associated with FOUND-SYSTEM, or with the PREVIOUS system. -PREVIOUS when not null is a previously loaded SYSTEM object of same name. -PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. -PREVIOUS-PRIMARY when not null is the primary system for the PREVIOUS system." - (with-asdf-session () ;; NB: We don't cache the results. We once used to, but it wasn't useful, - ;; and keeping a negative cache was a bug (see lp#1335323), which required - ;; explicit invalidation in clear-system and find-system (when unsucccessful). - (let* ((name (coerce-name name)) - (previous (registered-system name)) ; load from disk if absent or newer on disk - (previous-primary-name (and previous (primary-system-name previous))) - (previous-primary-system (and previous-primary-name - (registered-system previous-primary-name))) - (previous-time (and previous-primary-system - (component-operation-time 'define-op previous-primary-system))) - (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (ensure-pathname - (or (and (typep found '(or pathname string)) (pathname found)) - (system-source-file found-system) - (system-source-file previous)) - :want-absolute t :resolve-symlinks *resolve-symlinks*)) - (foundp (and (or found-system pathname previous) t))) - (check-type found (or null pathname system)) - (unless (check-not-old-asdf-system name pathname) - (check-type previous system) ;; asdf is preloaded, so there should be a previous one. - (setf found-system nil pathname nil)) - (values foundp found-system pathname previous previous-time previous-primary-system)))) - - ;; TODO: make a prepare-define-op node for this - ;; so we can properly cache the answer rather than recompute it. - (defun definition-dependencies-up-to-date-p (system) - (check-type system system) - (or (not (primary-system-p system)) - (handler-case - (loop :with plan = (make-instance *plan-class*) - :for action :in (definition-dependency-list system) - :always (action-up-to-date-p - plan (action-operation action) (action-component action)) - :finally - (let ((o (make-operation 'define-op))) - (multiple-value-bind (stamp done-p) - (compute-action-stamp plan o system) - (return (and (timestamp<= stamp (component-operation-time o system)) - done-p))))) - (system-out-of-date () nil)))) - - ;; Main method for find-system: first, make sure the computation is memoized in a session cache. - ;; Unless the system is immutable, use locate-system to find the primary system; - ;; reconcile the finding (if any) with any previous definition (in a previous session, - ;; preloaded, with a previous configuration, or before filesystem changes), and - ;; load a found .asd if appropriate. Finally, update registration table and return results. - (defmethod find-system ((name string) &optional (error-p t)) - (nest - (with-asdf-session (:key `(find-system ,name))) - (let ((name-primary-p (primary-system-p name))) - (unless name-primary-p (find-system (primary-system-name name) nil))) - (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name))) - (multiple-value-bind (foundp found-system pathname previous previous-time previous-primary) - (locate-system name) - (assert (eq foundp (and (or found-system pathname previous) t)))) - (let ((previous-pathname (system-source-file previous)) - (system (or previous found-system))) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and system pathname) - (setf (system-source-file system) pathname)) - (if-let ((stamp (get-file-stamp pathname))) - (let ((up-to-date-p - (and previous previous-primary - (or (pathname-equal pathname previous-pathname) - (and pathname previous-pathname - (pathname-equal - (physicalize-pathname pathname) - (physicalize-pathname previous-pathname)))) - (timestamp<= stamp previous-time) - ;; Check that all previous definition-dependencies are up-to-date, - ;; traversing them without triggering the adding of nodes to the plan. - ;; TODO: actually have a prepare-define-op, extract its timestamp, - ;; and check that it is less than the stamp of the previous define-op ? - (definition-dependencies-up-to-date-p previous-primary)))) - (unless up-to-date-p - (restart-case - (signal 'system-out-of-date :name name) - (continue () :report "continue")) - (load-asd pathname :name name))))) - ;; Try again after having loaded from disk if needed - (or (registered-system name) - (when error-p (error 'missing-component :requires name))))) - - ;; Resolved forward reference for asdf/system-registry. - (defun mark-component-preloaded (component) - "Mark a component as preloaded." - (let ((component (find-component component nil :registered t))) - ;; Recurse to children, so asdf/plan will hopefully be happy. - (map () 'mark-component-preloaded (component-children component)) - ;; Mark the timestamps of the common lisp-action operations as 0. - (let ((cot (component-operation-times component))) - (dolist (o `(,@(when (primary-system-p component) '(define-op)) - prepare-op compile-op load-op)) - (setf (gethash (make-operation o) cot) 0)))))) -;;;; ------------------------------------------------------------------------- -;;;; Defsystem - -(uiop/package:define-package :asdf/parse-defsystem - (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf) - (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares - (:use :uiop/common-lisp :asdf/driver :asdf/upgrade - :asdf/session :asdf/component :asdf/system :asdf/system-registry - :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate) - (:import-from :asdf/system #:depends-on #:weakly-depends-on) - ;; these needed for record-additional-system-input-file - (:import-from :asdf/operation #:make-operation) - (:import-from :asdf/component #:%additional-input-files) - (:import-from :asdf/find-system #:define-op) - (:export - #:defsystem #:register-system-definition - #:*default-component-class* - #:determine-system-directory #:parse-component-form - #:non-toplevel-system #:non-system-system #:bad-system-name - #:*known-systems-with-bad-secondary-system-names* - #:known-system-with-bad-secondary-system-names-p - #:sysdef-error-component #:check-component-input - #:explain - ;; for extending the component types - #:compute-component-children - #:class-for-type)) -(in-package :asdf/parse-defsystem) - -;;; Pathname -(with-upgradability () - (defun determine-system-directory (pathname) - ;; The defsystem macro calls this function to determine the pathname of a system as follows: - ;; 1. If the pathname argument is an pathname object (NOT a namestring), - ;; that is already an absolute pathname, return it. - ;; 2. Otherwise, the directory containing the LOAD-PATHNAME - ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and - ;; if it is indeed available and an absolute pathname, then - ;; the PATHNAME argument is normalized to a relative pathname - ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) - ;; and merged into that DIRECTORY as per SUBPATHNAME. - ;; Note: avoid *COMPILE-FILE-PATHNAME* because the .asd is loaded as source, - ;; but may be from within the EVAL-WHEN of a file compilation. - ;; If no absolute pathname was found, we return NIL. - (check-type pathname (or null string pathname)) - (pathname-directory-pathname - (resolve-symlinks* - (ensure-absolute-pathname - (parse-unix-namestring pathname :type :directory) - #'(lambda () (ensure-absolute-pathname - (load-pathname) 'get-pathname-defaults nil)) - nil))))) - - -(when-upgrading (:version "3.3.4.17") - ;; This turned into a generic function in 3.3.4.17 - (fmakunbound 'class-for-type)) - -;;; Component class -(with-upgradability () - ;; What :file gets interpreted as, unless overridden by a :default-component-class - (defvar *default-component-class* 'cl-source-file) - - (defgeneric class-for-type (parent type-designator) - (:documentation - "Return a CLASS object to be used to instantiate components specified by TYPE-DESIGNATOR in the context of PARENT.")) - - (defmethod class-for-type ((parent null) type) - "If the PARENT is NIL, then TYPE must designate a subclass of SYSTEM." - (or (coerce-class type :package :asdf/interface :super 'system :error nil) - (sysdef-error "don't recognize component type ~S in the context of no parent" type))) - - (defmethod class-for-type ((parent parent-component) type) - (or (coerce-class type :package :asdf/interface :super 'component :error nil) - (and (eq type :file) - (coerce-class - (or (loop :for p = parent :then (component-parent p) :while p - :thereis (module-default-component-class p)) - *default-component-class*) - :package :asdf/interface :super 'component :error nil)) - (sysdef-error "don't recognize component type ~S" type)))) - - -;;; Check inputs -(with-upgradability () - (define-condition non-system-system (system-definition-error) - ((name :initarg :name :reader non-system-system-name) - (class-name :initarg :class-name :reader non-system-system-class-name)) - (:report (lambda (c s) - (format s (compatfmt "~@") - (non-system-system-name c) (non-system-system-class-name c) 'system)))) - - (define-condition non-toplevel-system (system-definition-error) - ((parent :initarg :parent :reader non-toplevel-system-parent) - (name :initarg :name :reader non-toplevel-system-name)) - (:report (lambda (c s) - (format s (compatfmt "~@") - (non-toplevel-system-parent c) (non-toplevel-system-name c))))) - - (define-condition bad-system-name (warning) - ((name :initarg :name :reader component-name) - (source-file :initarg :source-file :reader system-source-file)) - (:report (lambda (c s) - (let* ((file (system-source-file c)) - (name (component-name c)) - (asd (pathname-name file))) - (format s (compatfmt "~@") - file name asd (strcat asd "/") (strcat asd "/test")))))) - - (defun sysdef-error-component (msg type name value) - (sysdef-error (strcat msg (compatfmt "~&~@")) - type name value)) - - (defun check-component-input (type name weakly-depends-on - depends-on components) - "A partial test of the values of a component." - (unless (listp depends-on) - (sysdef-error-component ":depends-on must be a list." - type name depends-on)) - (unless (listp weakly-depends-on) - (sysdef-error-component ":weakly-depends-on must be a list." - type name weakly-depends-on)) - (unless (listp components) - (sysdef-error-component ":components must be NIL or a list of components." - type name components))) - - - (defun record-additional-system-input-file (pathname component parent) - (let* ((record-on (if parent - (loop :with retval - :for par = parent :then (component-parent par) - :while par - :do (setf retval par) - :finally (return retval)) - component)) - (comp (if (typep record-on 'component) - record-on - ;; at this point there will be no parent for RECORD-ON - (find-component record-on nil))) - (op (make-operation 'define-op)) - (cell (or (assoc op (%additional-input-files comp)) - (let ((new-cell (list op))) - (push new-cell (%additional-input-files comp)) - new-cell)))) - (pushnew pathname (cdr cell) :test 'pathname-equal) - (values))) - - ;; Given a form used as :version specification, in the context of a system definition - ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form - ;; to an acceptable ASDF-format version. - (fmakunbound 'normalize-version) ;; signature changed between 2.27 and 2.31 - (defun normalize-version (form &key pathname component parent) - (labels ((invalid (&optional (continuation "using NIL instead")) - (warn (compatfmt "~@") - form component parent pathname continuation)) - (invalid-parse (control &rest args) - (unless (if-let (target (find-component parent component)) (builtin-system-p target)) - (apply 'warn control args) - (invalid)))) - (if-let (v (typecase form - ((or string null) form) - (real - (invalid "Substituting a string") - (format nil "~D" form)) ;; 1.0 becomes "1.0" - (cons - (case (first form) - ((:read-file-form) - (destructuring-bind (subpath &key (at 0)) (rest form) - (let ((path (subpathname pathname subpath))) - (record-additional-system-input-file path component parent) - (safe-read-file-form path - :at at :package :asdf-user)))) - ((:read-file-line) - (destructuring-bind (subpath &key (at 0)) (rest form) - (let ((path (subpathname pathname subpath))) - (record-additional-system-input-file path component parent) - (safe-read-file-line (subpathname pathname subpath) - :at at)))) - (otherwise - (invalid)))) - (t - (invalid)))) - (if-let (pv (parse-version v #'invalid-parse)) - (unparse-version pv) - (invalid)))))) - - -;;; "inline methods" -(with-upgradability () - (defparameter* +asdf-methods+ - '(perform-with-restarts perform explain output-files operation-done-p)) - - (defun %remove-component-inline-methods (component) - (dolist (name +asdf-methods+) - (map () - ;; this is inefficient as most of the stored - ;; methods will not be for this particular gf - ;; But this is hardly performance-critical - #'(lambda (m) - (remove-method (symbol-function name) m)) - (component-inline-methods component))) - (component-inline-methods component) nil) - - (defparameter *standard-method-combination-qualifiers* - '(:around :before :after)) - -;;; Find inline method definitions of the form -;;; -;;; :perform (test-op :before (operation component) ...) -;;; -;;; in REST (which is the plist of all DEFSYSTEM initargs) and define the specified methods. - (defun %define-component-inline-methods (ret rest) - ;; find key-value pairs that look like inline method definitions in REST. For each identified - ;; definition, parse it and, if it is well-formed, define the method. - (loop :for (key value) :on rest :by #'cddr - :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=)) - :when name :do - ;; parse VALUE as an inline method definition of the form - ;; - ;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY) - (destructuring-bind (operation-name &rest rest) value - (let ((qualifiers '())) - ;; ensure that OPERATION-NAME is a symbol. - (unless (and (symbolp operation-name) (not (null operation-name))) - (sysdef-error "Ill-formed inline method: ~S. The first element is not a symbol ~ - designating an operation but ~S." - value operation-name)) - ;; ensure that REST starts with either a cons (potential lambda list, further checked - ;; below) or a qualifier accepted by the standard method combination. Everything else - ;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely - ;; has to start with the lambda list. - (cond - ((consp (car rest))) - ((not (member (car rest) - *standard-method-combination-qualifiers*)) - (sysdef-error "Ill-formed inline method: ~S. Only a single of the standard ~ - qualifiers ~{~S~^ ~} is allowed, not ~S." - value *standard-method-combination-qualifiers* (car rest))) - (t - (setf qualifiers (list (pop rest))))) - ;; REST must start with a two-element lambda list. - (unless (and (listp (car rest)) - (length=n-p (car rest) 2) - (null (cddar rest))) - (sysdef-error "Ill-formed inline method: ~S. The operation name ~S is not followed by ~ - a lambda-list of the form (OPERATION COMPONENT) and a method body." - value operation-name)) - ;; define the method. - (destructuring-bind ((o c) &rest body) rest - (pushnew - (eval `(defmethod ,name ,@qualifiers ((,o ,operation-name) (,c (eql ,ret))) ,@body)) - (component-inline-methods ret))))))) - - (defun %refresh-component-inline-methods (component rest) - ;; clear methods, then add the new ones - (%remove-component-inline-methods component) - (%define-component-inline-methods component rest))) - - -;;; Main parsing function -(with-upgradability () - (defun parse-dependency-def (dd) - (if (listp dd) - (case (first dd) - (:feature - (unless (= (length dd) 3) - (sysdef-error "Ill-formed feature dependency: ~s" dd)) - (let ((embedded (parse-dependency-def (third dd)))) - `(:feature ,(second dd) ,embedded))) - (feature - (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd)) - (:require - (unless (= (length dd) 2) - (sysdef-error "Ill-formed require dependency: ~s" dd)) - dd) - (:version - (unless (= (length dd) 3) - (sysdef-error "Ill-formed version dependency: ~s" dd)) - `(:version ,(coerce-name (second dd)) ,(third dd))) - (otherwise (sysdef-error "Ill-formed dependency: ~s" dd))) - (coerce-name dd))) - - (defun parse-dependency-defs (dd-list) - "Parse the dependency defs in DD-LIST into canonical form by translating all -system names contained using COERCE-NAME. Return the result." - (mapcar 'parse-dependency-def dd-list)) - - (defgeneric compute-component-children (component components serial-p) - (:documentation - "Return a list of children for COMPONENT. - -COMPONENTS is a list of the explicitly defined children descriptions. - -SERIAL-P is non-NIL if each child in COMPONENTS should depend on the previous -children.")) - - (defun stable-union (s1 s2 &key (test #'eql) (key 'identity)) - (append s1 - (remove-if #'(lambda (e2) (member (funcall key e2) (funcall key s1) :test test)) s2))) - - (defun parse-component-form (parent options &key previous-serial-components) - (destructuring-bind - (type name &rest rest &key - (builtin-system-p () bspp) - ;; the following list of keywords is reproduced below in the - ;; remove-plist-keys form. important to keep them in sync - components pathname perform explain output-files operation-done-p - weakly-depends-on depends-on serial - do-first if-component-dep-fails version - ;; list ends - &allow-other-keys) options - (declare (ignore perform explain output-files operation-done-p builtin-system-p)) - (check-component-input type name weakly-depends-on depends-on components) - (when (and parent - (find-component parent name) - (not ;; ignore the same object when rereading the defsystem - (typep (find-component parent name) - (class-for-type parent type)))) - (error 'duplicate-names :name name)) - (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3")) - (let* ((name (coerce-name name)) - (args `(:name ,name - :pathname ,pathname - ,@(when parent `(:parent ,parent)) - ,@(remove-plist-keys - '(:components :pathname :if-component-dep-fails :version - :perform :explain :output-files :operation-done-p - :weakly-depends-on :depends-on :serial) - rest))) - (component (find-component parent name)) - (class (class-for-type parent type))) - (when (and parent (subtypep class 'system)) - (error 'non-toplevel-system :parent parent :name name)) - (if component ; preserve identity - (apply 'reinitialize-instance component args) - (setf component (apply 'make-instance class args))) - (component-pathname component) ; eagerly compute the absolute pathname - (when (typep component 'system) - ;; cache information for introspection - (setf (slot-value component 'depends-on) - (parse-dependency-defs depends-on) - (slot-value component 'weakly-depends-on) - ;; these must be a list of systems, cannot be features or versioned systems - (mapcar 'coerce-name weakly-depends-on))) - (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous - (when (and (typep component 'system) (not bspp)) - (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile))) - (setf version (normalize-version version :component name :parent parent :pathname sysfile))) - ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8. - ;; A better fix is required. - (setf (slot-value component 'version) version) - (when (typep component 'parent-component) - (setf (component-children component) (compute-component-children component components serial)) - (compute-children-by-name component)) - (when previous-serial-components - (setf depends-on (stable-union depends-on previous-serial-components :test #'equal))) - (when weakly-depends-on - ;; ASDF4: deprecate this feature and remove it. - (appendf depends-on - (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) - ;; Used by POIU. ASDF4: rename to component-depends-on? - (setf (component-sideway-dependencies component) depends-on) - (%refresh-component-inline-methods component rest) - (when if-component-dep-fails - (error "The system definition for ~S uses deprecated ~ - ASDF option :IF-COMPONENT-DEP-FAILS. ~ - Starting with ASDF 3, please use :IF-FEATURE instead" - (coerce-name (component-system component)))) - component))) - - (defmethod compute-component-children ((component parent-component) components serial-p) - (loop - :with previous-components = nil ; list of strings - :for c-form :in components - :for c = (parse-component-form component c-form - :previous-serial-components previous-components) - :for name :of-type string = (component-name c) - :when serial-p - ;; if this is an if-feature component, we need to make a serial link - ;; from previous components to following components -- otherwise should - ;; the IF-FEATURE component drop out, the chain of serial dependencies will be - ;; broken. - :unless (component-if-feature c) - :do (setf previous-components nil) - :end - :and - :do (push name previous-components) - :end - :collect c)) - - ;; the following are all systems that Stas Boukarev maintains and refuses to fix, - ;; hoping instead to make my life miserable. Instead, I just make ASDF ignore them. - (defparameter* *known-systems-with-bad-secondary-system-names* - (list-to-hash-set '("cl-ppcre" "cl-interpol"))) - (defun known-system-with-bad-secondary-system-names-p (asd-name) - ;; Does .asd file with name ASD-NAME contain known exceptions - ;; that should be screened out of checking for BAD-SYSTEM-NAME? - (gethash asd-name *known-systems-with-bad-secondary-system-names*)) - - (defun register-system-definition - (name &rest options &key pathname (class 'system) (source-file () sfp) - defsystem-depends-on &allow-other-keys) - ;; The system must be registered before we parse the body, - ;; otherwise we recur when trying to find an existing system - ;; of the same name to reuse options (e.g. pathname) from. - ;; To avoid infinite recursion in cases where you defsystem a system - ;; that is registered to a different location to find-system, - ;; we also need to remember it in the asdf-cache. - (nest - (with-asdf-session ()) - (let* ((name (coerce-name name)) - (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))))) - (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x)))) - (let* ((asd-name (and source-file - (equal "asd" (fix-case (pathname-type source-file))) - (fix-case (pathname-name source-file)))) - ;; note that PRIMARY-NAME is a *syntactically* primary name - (primary-name (primary-system-name name))) - (when (and asd-name - (not (equal asd-name primary-name)) - (not (known-system-with-bad-secondary-system-names-p asd-name))) - (warn (make-condition 'bad-system-name :source-file source-file :name name)))) - (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object, - ;; so that in case it fails, there is no incomplete object polluting the build. - (checked-defsystem-depends-on - (let* ((dep-forms (parse-dependency-defs defsystem-depends-on)) - (deps (loop :for spec :in dep-forms - :when (resolve-dependency-spec nil spec) - :collect :it))) - (load-systems* deps) - dep-forms)) - (system (or (find-system-if-being-defined name) - (if-let (registered (registered-system name)) - (reset-system-class registered 'undefined-system - :name name :source-file source-file) - (register-system (make-instance 'undefined-system - :name name :source-file source-file))))) - (component-options - (append - (remove-plist-keys '(:defsystem-depends-on :class) options) - ;; cache defsystem-depends-on in canonical form - (when checked-defsystem-depends-on - `(:defsystem-depends-on ,checked-defsystem-depends-on)))) - (directory (determine-system-directory pathname))) - ;; This works hand in hand with asdf/find-system:find-system-if-being-defined: - (set-asdf-cache-entry `(find-system ,name) (list system))) - ;; We change-class AFTER we loaded the defsystem-depends-on - ;; since the class might be defined as part of those. - (let ((class (class-for-type nil class))) - (unless (subtypep class 'system) - (error 'non-system-system :name name :class-name (class-name class))) - (unless (eq (type-of system) class) - (reset-system-class system class))) - (parse-component-form nil (list* :system name :pathname directory component-options)))) - - (defmacro defsystem (name &body options) - `(apply 'register-system-definition ',name ',options))) -;;;; ------------------------------------------------------------------------- -;;;; ASDF-Bundle - -(uiop/package:define-package :asdf/bundle - (:recycle :asdf/bundle :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/component :asdf/system :asdf/operation - :asdf/find-component ;; used by ECL - :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem) - (:export - #:bundle-op #:bundle-type #:program-system - #:bundle-system #:bundle-pathname-type #:direct-dependency-files - #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p - #:basic-compile-bundle-op #:prepare-bundle-op - #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op - #:lib-op #:monolithic-lib-op - #:dll-op #:monolithic-dll-op - #:deliver-asd-op #:monolithic-deliver-asd-op - #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system - #:user-system-p #:user-system #:trivial-system-p - #:prologue-code #:epilogue-code #:static-library)) -(in-package :asdf/bundle) - -(with-upgradability () - (defclass bundle-op (operation) () - (:documentation "base class for operations that bundle outputs from multiple components")) - (defgeneric bundle-type (bundle-op)) - - (defclass monolithic-op (operation) () - (:documentation "A MONOLITHIC operation operates on a system *and all of its -dependencies*. So, for example, a monolithic concatenate operation will -concatenate together a system's components and all of its dependencies, but a -simple concatenate operation will concatenate only the components of the system -itself.")) - - (defclass monolithic-bundle-op (bundle-op monolithic-op) - ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation. - ;; DEPRECATED. Supported replacement: Define slots on program-system instead. - ((prologue-code :initform nil :accessor prologue-code) - (epilogue-code :initform nil :accessor epilogue-code)) - (:documentation "operations that are both monolithic-op and bundle-op")) - - (defclass program-system (system) - ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system - ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code) - (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code) - (no-uiop :initform nil :initarg :no-uiop :reader no-uiop) - (prefix-lisp-object-files :initarg :prefix-lisp-object-files - :initform nil :accessor prefix-lisp-object-files) - (postfix-lisp-object-files :initarg :postfix-lisp-object-files - :initform nil :accessor postfix-lisp-object-files) - (extra-object-files :initarg :extra-object-files - :initform nil :accessor extra-object-files) - (extra-build-args :initarg :extra-build-args - :initform nil :accessor extra-build-args))) - - (defmethod prologue-code ((x system)) nil) - (defmethod epilogue-code ((x system)) nil) - (defmethod no-uiop ((x system)) nil) - (defmethod prefix-lisp-object-files ((x system)) nil) - (defmethod postfix-lisp-object-files ((x system)) nil) - (defmethod extra-object-files ((x system)) nil) - (defmethod extra-build-args ((x system)) nil) - - (defclass link-op (bundle-op) () - (:documentation "Abstract operation for linking files together")) - - (defclass gather-operation (bundle-op) () - (:documentation "Abstract operation for gathering many input files from a system")) - (defgeneric gather-operation (gather-operation)) - (defmethod gather-operation ((o gather-operation)) nil) - (defgeneric gather-type (gather-operation)) - - (defun operation-monolithic-p (op) - (typep op 'monolithic-op)) - - ;; Dependencies of a gather-op are the actions of the dependent operation - ;; for all the (sorted) required components for loading the system. - ;; Monolithic operations typically use lib-op as the dependent operation, - ;; and all system-level dependencies as required components. - ;; Non-monolithic operations typically use compile-op as the dependent operation, - ;; and all transitive sub-components as required components (excluding other systems). - (defmethod component-depends-on ((o gather-operation) (s system)) - (let* ((mono (operation-monolithic-p o)) - (go (make-operation (or (gather-operation o) 'compile-op))) - (bundle-p (typep go 'bundle-op)) - ;; In a non-mono operation, don't recurse to other systems. - ;; In a mono operation gathering bundles, don't recurse inside systems. - (component-type (if mono (if bundle-p 'system t) '(not system))) - ;; In the end, only keep system bundles or non-system bundles, depending. - (keep-component (if bundle-p 'system '(not system))) - (deps - ;; Required-components only looks at the dependencies of an action, excluding the action - ;; itself, so it may be safely used by an action recursing on its dependencies (which - ;; may or may not be an overdesigned API, since in practice we never use it that way). - ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks - ;; cleaner, we will miss the load-op on the requested system itself, which doesn't - ;; matter for a regular system, but matters, a lot, for a package-inferred-system. - ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works - ;; for our needs of gathering all the files we want to include in a bundle. - ;; Note that we use basic-compile-op rather than compile-op so it will still work on - ;; systems that would somehow load dependencies with load-bundle-op. - (required-components - s :other-systems mono :component-type component-type :keep-component keep-component - :goal-operation 'load-op :keep-operation 'basic-compile-op))) - `((,go ,@deps) ,@(call-next-method)))) - - ;; Create a single fasl for the entire library - (defclass basic-compile-bundle-op (bundle-op basic-compile-op) () - (:documentation "Base class for compiling into a bundle")) - (defmethod bundle-type ((o basic-compile-bundle-op)) :fasb) - (defmethod gather-type ((o basic-compile-bundle-op)) - #-(or clasp ecl mkcl) :fasl - #+(or clasp ecl mkcl) :object) - - ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op - (defclass prepare-bundle-op (sideway-operation) - ((sideway-operation - :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op - :allocation :class)) - (:documentation "Operation class for loading the bundles of a system's dependencies")) - - (defclass lib-op (link-op gather-operation non-propagating-operation) () - (:documentation "Compile the system and produce a linkable static library (.a/.lib) -for all the linkable object files associated with the system. Compare with DLL-OP. - -On most implementations, these object files only include extensions to the runtime -written in C or another language with a compiler producing linkable object files. -On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files -themselves. In any case, this operation will produce what you need to further build -a static runtime for your system, or a dynamic library to load in an existing runtime.")) - (defmethod bundle-type ((o lib-op)) :lib) - (defmethod gather-type ((o lib-op)) :object) - - ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so; - ;; on other implementations, we combine (usually concatenate) the .fasl files into one. - (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation - #+(or clasp ecl mkcl) link-op) - ((selfward-operation :initform '(prepare-bundle-op) :allocation :class)) - (:documentation "This operator is an alternative to COMPILE-OP. Build a system -and all of its dependencies, but build only a single (\"monolithic\") FASL, instead -of one per source file, which may be more resource efficient. That monolithic -FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP.")) - - (defclass load-bundle-op (basic-load-op selfward-operation) - ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)) - (:documentation "This operator is an alternative to LOAD-OP. Build a system -and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with -respect to LOAD-OP is that it builds only a single FASL, which may be -faster and more resource efficient.")) - - ;; NB: since the monolithic-op's can't be sideway-operation's, - ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's, - ;; we'd have to have the monolithic-op not inherit from the main op, - ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above. - - (defclass dll-op (link-op gather-operation non-propagating-operation) () - (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) -for all the linkable object files associated with the system. Compare with LIB-OP.")) - (defmethod bundle-type ((o dll-op)) :dll) - (defmethod gather-type ((o dll-op)) :object) - - (defclass deliver-asd-op (basic-compile-op selfward-operation) - ((selfward-operation - ;; TODO: implement link-op on all implementations, and make that - ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op) - :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) - :allocation :class)) - (:documentation "produce an asd file for delivering the system as a single fasl")) - - - (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op) - ((selfward-operation - ;; TODO: implement link-op on all implementations, and make that - ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op) - :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op) - :allocation :class)) - (:documentation "produce fasl and asd files for combined system and dependencies.")) - - (defclass monolithic-compile-bundle-op - (basic-compile-bundle-op monolithic-bundle-op - #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation) - () - (:documentation "Create a single fasl for the system and its dependencies.")) - - (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op) - ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)) - (:documentation "Load a single fasl for the system and its dependencies.")) - - (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation) () - (:documentation "Compile the system and produce a linkable static library (.a/.lib) -for all the linkable object files associated with the system or its dependencies. See LIB-OP.")) - - (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation) () - (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) -for all the linkable object files associated with the system or its dependencies. See LIB-OP")) - - (defclass image-op (monolithic-bundle-op selfward-operation - #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation) - ((selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class)) - (:documentation "create an image file from the system and its dependencies")) - (defmethod bundle-type ((o image-op)) :image) - #+(or clasp ecl mkcl) (defmethod gather-operation ((o image-op)) 'lib-op) - #+(or clasp ecl mkcl) (defmethod gather-type ((o image-op)) :static-library) - - (defclass program-op (image-op) () - (:documentation "create an executable file from the system and its dependencies")) - (defmethod bundle-type ((o program-op)) :program) - - ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type. - (defun bundle-pathname-type (bundle-type) - (etypecase bundle-type - ((or null string) ;; pass through nil or string literal - bundle-type) - ((eql :no-output-file) ;; marker for a bundle-type that has NO output file - (error "No output file, therefore no pathname type")) - ((eql :fasl) ;; the type of a fasl - (compile-file-type)) ; on image-based platforms, used as input and output - ((eql :fasb) ;; the type of a fasl - #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output - #+(or ecl mkcl) "fasb" - #+clasp "fasp") ; on C-linking platforms, only used as output for system bundles - ((member :image) - #+allegro "dxl" - #+(and clisp os-windows) "exe" - #-(or allegro (and clisp os-windows)) "image") - ;; NB: on CLASP and ECL these implementations, we better agree with - ;; (compile-file-type :type bundle-type)) - ((eql :object) ;; the type of a linkable object file - (os-cond ((os-unix-p) - #+clasp "fasp" ;(core:build-extension cmp:*default-object-type*) - #-clasp "o") - ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj")))) - ((member :lib :static-library) ;; the type of a linkable library - (os-cond ((os-unix-p) "a") - ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) - ((member :dll :shared-library) ;; the type of a shared library - (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) - ((eql :program) ;; the type of an executable program - (os-cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) - - ;; Compute the output-files for a given bundle action - (defun bundle-output-files (o c) - (let ((bundle-type (bundle-type o))) - (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type. - (and (null (input-files o c)) (not (member bundle-type '(:image :program))))) - (let ((name (or (component-build-pathname c) - (let ((suffix - (unless (typep o 'program-op) - ;; "." is no good separator for Logical Pathnames, so we use "--" - (if (operation-monolithic-p o) - "--all-systems" - ;; These use a different type .fasb or .a instead of .fasl - #-(or clasp ecl mkcl) "--system")))) - (format nil "~A~@[~A~]" (coerce-filename (component-name c)) suffix)))) - (type (bundle-pathname-type bundle-type))) - (values (list (subpathname (component-pathname c) name :type type)) - (eq (class-of o) (coerce-class (component-build-operation c) - :package :asdf/interface - :super 'operation - :error nil))))))) - - (defmethod output-files ((o bundle-op) (c system)) - (bundle-output-files o c)) - - #-(or clasp ecl mkcl) - (progn - (defmethod perform ((o image-op) (c system)) - (dump-image (output-file o c) :executable (typep o 'program-op))) - (defmethod perform :before ((o program-op) (c system)) - (setf *image-entry-point* (ensure-function (component-entry-point c))))) - - (defclass compiled-file (file-component) - ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")) - (:documentation "Class for a file that is already compiled, -e.g. as part of the implementation, of an outer build system that calls into ASDF, -or of opaque libraries shipped along the source code.")) - - (defclass precompiled-system (system) - ((build-pathname :initarg :fasb :initarg :fasl)) - (:documentation "Class For a system that is delivered as a precompiled fasl")) - - (defclass prebuilt-system (system) - ((build-pathname :initarg :static-library :initarg :lib - :accessor prebuilt-system-static-library)) - (:documentation "Class for a system delivered with a linkable static library (.a/.lib)"))) - - -;;; -;;; BUNDLE-OP -;;; -;;; This operation takes all components from one or more systems and -;;; creates a single output file, which may be -;;; a FASL, a statically linked library, a shared library, etc. -;;; The different targets are defined by specialization. -;;; -(when-upgrading (:version "3.2.0") - ;; Cancel any previously defined method - (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys) - (declare (ignore initargs)))) - -(with-upgradability () - (defgeneric trivial-system-p (component)) - - (defun user-system-p (s) - (and (typep s 'system) - (not (builtin-system-p s)) - (not (trivial-system-p s))))) - -(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) - (deftype user-system () '(and system (satisfies user-system-p)))) - -;;; -;;; First we handle monolithic bundles. -;;; These are standalone systems which contain everything, -;;; including other ASDF systems required by the current one. -;;; A PROGRAM is always monolithic. -;;; -;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL -;;; -(with-upgradability () - (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) - ;; This function selects output files from direct dependencies; - ;; your component-depends-on method must gather the correct dependencies in the correct order. - (while-collecting (collect) - (map-direct-dependencies - o c #'(lambda (sub-o sub-c) - (loop :for f :in (funcall key sub-o sub-c) - :when (funcall test f) :do (collect f)))))) - - (defun pathname-type-equal-function (type) - #'(lambda (p) (equalp (pathname-type p) type))) - - (defmethod input-files ((o gather-operation) (c system)) - (unless (eq (bundle-type o) :no-output-file) - (direct-dependency-files - o c :key 'output-files - :test (pathname-type-equal-function (bundle-pathname-type (gather-type o)))))) - - ;; Find the operation that produces a given bundle-type - (defun select-bundle-operation (type &optional monolithic) - (ecase type - ((:dll :shared-library) - (if monolithic 'monolithic-dll-op 'dll-op)) - ((:lib :static-library) - (if monolithic 'monolithic-lib-op 'lib-op)) - ((:fasb) - (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op)) - ((:image) - 'image-op) - ((:program) - 'program-op)))) - -;;; -;;; LOAD-BUNDLE-OP -;;; -;;; This is like ASDF's LOAD-OP, but using bundle fasl files. -;;; -(with-upgradability () - (defmethod component-depends-on ((o load-bundle-op) (c system)) - `((,o ,@(component-sideway-dependencies c)) - (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c) - ,@(call-next-method))) - - (defmethod input-files ((o load-bundle-op) (c system)) - (when (user-system-p c) - (output-files (find-operation o 'compile-bundle-op) c))) - - (defmethod perform ((o load-bundle-op) (c system)) - (when (input-files o c) - (perform-lisp-load-fasl o c))) - - (defmethod mark-operation-done :after ((o load-bundle-op) (c system)) - (mark-operation-done (find-operation o 'load-op) c))) - -;;; -;;; PRECOMPILED FILES -;;; -;;; This component can be used to distribute ASDF systems in precompiled form. -;;; Only useful when the dependencies have also been precompiled. -;;; -(with-upgradability () - (defmethod trivial-system-p ((s system)) - (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) - - (defmethod input-files ((o operation) (c compiled-file)) - (list (component-pathname c))) - (defmethod perform ((o load-op) (c compiled-file)) - (perform-lisp-load-fasl o c)) - (defmethod perform ((o load-source-op) (c compiled-file)) - (perform (find-operation o 'load-op) c)) - (defmethod perform ((o operation) (c compiled-file)) - nil)) - -;;; -;;; Pre-built systems -;;; -(with-upgradability () - (defmethod trivial-system-p ((s prebuilt-system)) - t) - - (defmethod perform ((o link-op) (c prebuilt-system)) - nil) - - (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system)) - nil) - - (defmethod perform ((o lib-op) (c prebuilt-system)) - nil) - - (defmethod perform ((o dll-op) (c prebuilt-system)) - nil) - - (defmethod component-depends-on ((o gather-operation) (c prebuilt-system)) - nil) - - (defmethod output-files ((o lib-op) (c prebuilt-system)) - (values (list (prebuilt-system-static-library c)) t))) - - -;;; -;;; PREBUILT SYSTEM CREATOR -;;; -(with-upgradability () - (defmethod output-files ((o deliver-asd-op) (s system)) - (list (make-pathname :name (coerce-filename (component-name s)) :type "asd" - :defaults (component-pathname s)))) - - ;; because of name collisions between the output files of different - ;; subclasses of DELIVER-ASD-OP, we cannot trust the file system to - ;; tell us if the output file is up-to-date, so just treat the - ;; operation as never being done. - (defmethod operation-done-p ((o deliver-asd-op) (s system)) - (declare (ignorable o s)) - nil) - - (defun space-for-crlf (s) - (substitute-if #\space #'(lambda (x) (find x +crlf+)) s)) - - (defmethod perform ((o deliver-asd-op) (s system)) - "Write an ASDF system definition for loading S as a delivered system." - (let* ((inputs (input-files o s)) - (fasl (first inputs)) - (library (second inputs)) - (asd (output-file o s)) - (name (if (and fasl asd) (pathname-name asd) (return-from perform))) - (version (component-version s)) - (dependencies - (if (operation-monolithic-p o) - ;; We want only dependencies, and we use basic-load-op rather than load-op so that - ;; this will keep working on systems that load dependencies with load-bundle-op - (remove-if-not 'builtin-system-p - (required-components s :component-type 'system - :keep-operation 'basic-load-op)) - (while-collecting (x) ;; resolve the sideway-dependencies of s - (map-direct-dependencies - 'prepare-op s - #'(lambda (o c) - (when (and (typep o 'load-op) (typep c 'system)) - (x c))))))) - (depends-on (mapcar 'coerce-name dependencies))) - (when (pathname-equal asd (system-source-file s)) - (cerror "overwrite the asd file" - "~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~ -which is probably not what you want; you probably need to tweak your output translations." - (cons o s) asd)) - (with-open-file (s asd :direction :output :if-exists :supersede - :if-does-not-exist :create) - (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%" - (operation-monolithic-p o) name) - ;; this can cause bugs in cases where one of the functions returns a multi-line - ;; string - (let ((description-string (format nil ";;; Built for ~A ~A on a ~A/~A ~A" - (lisp-implementation-type) - (lisp-implementation-version) - (software-type) - (machine-type) - (software-version)))) - ;; ensure the whole thing is on one line - (println (space-for-crlf description-string) s)) - (let ((*package* (find-package :asdf-user))) - (pprint `(defsystem ,name - :class prebuilt-system - :version ,version - :depends-on ,depends-on - :components ((:compiled-file ,(pathname-name fasl))) - ,@(when library `(:lib ,(file-namestring library)))) - s) - (terpri s))))) - - #-(or clasp ecl mkcl) - (defmethod perform ((o basic-compile-bundle-op) (c system)) - (let* ((input-files (input-files o c)) - (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) - (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) - (output-files (output-files o c)) ; can't use OUTPUT-FILE fn because possibility it's NIL - (output-file (first output-files))) - (assert (eq (not input-files) (not output-files))) - (when input-files - (when non-fasl-files - (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S" - (implementation-type) non-fasl-files)) - (when (or (prologue-code c) (epilogue-code c)) - (error "prologue-code and epilogue-code are not supported on ~A" - (implementation-type))) - (with-staging-pathname (output-file) - (combine-fasls fasl-files output-file))))) - - (defmethod input-files ((o load-op) (s precompiled-system)) - (bundle-output-files (find-operation o 'compile-bundle-op) s)) - - (defmethod perform ((o load-op) (s precompiled-system)) - (perform-lisp-load-fasl o s)) - - (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system)) - `((load-op ,s) ,@(call-next-method)))) - -#| ;; Example use: -(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) -(asdf:load-system :precompiled-asdf-utils) -|# - -#+(or clasp ecl mkcl) -(with-upgradability () - (defun system-module-pathname (module) - (let ((name (coerce-name module))) - (some - 'file-exists-p - (list - #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object) - #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib) - #+ecl (compile-file-pathname (make-pathname :name (strcat "lib" name) :defaults "sys:") :type :lib) - #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object) - #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:") - #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;"))))) - - (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name))) - "Creates a prebuilt-system if PATHNAME isn't NIL." - (when pathname - (make-instance 'prebuilt-system - :name (coerce-name name) - :static-library (resolve-symlinks* pathname)))) - - (defun linkable-system (x) - (or ;; If the system is available as source, use it. - (if-let (s (find-system x)) - (and (output-files 'lib-op s) s)) - ;; If an ASDF upgrade is available from source, but not a UIOP upgrade to that, - ;; then use the asdf/driver system instead of - ;; the UIOP that was disabled by check-not-old-asdf-system. - (if-let (s (and (equal (coerce-name x) "uiop") - (output-files 'lib-op "asdf") - (find-system "asdf/driver"))) - (and (output-files 'lib-op s) s)) - ;; If there was no source upgrade, look for modules provided by the implementation. - (if-let (p (system-module-pathname (coerce-name x))) - (make-prebuilt-system x p)))) - - (defmethod component-depends-on :around ((o image-op) (c system)) - (let* ((next (call-next-method)) - (deps (make-hash-table :test 'equal)) - (linkable (loop :for (do . dcs) :in next :collect - (cons do - (loop :for dc :in dcs - :for dep = (and dc (resolve-dependency-spec c dc)) - :when dep - :do (setf (gethash (coerce-name (component-system dep)) deps) t) - :collect (or (and (typep dep 'system) (linkable-system dep)) dep)))))) - `((lib-op - ,@(unless (no-uiop c) - (list (linkable-system "cmp") - (unless (or (and (gethash "uiop" deps) (linkable-system "uiop")) - (and (gethash "asdf" deps) (linkable-system "asdf"))) - (or (linkable-system "uiop") - (linkable-system "asdf") - "asdf"))))) - ,@linkable))) - - (defmethod perform ((o link-op) (c system)) - (let* ((object-files (input-files o c)) - (output (output-files o c)) - (bundle (first output)) - (programp (typep o 'program-op)) - (kind (bundle-type o))) - (when output - (apply 'create-image - bundle (append - (when programp (prefix-lisp-object-files c)) - object-files - (when programp (postfix-lisp-object-files c))) - :kind kind - :prologue-code (when programp (prologue-code c)) - :epilogue-code (when programp (epilogue-code c)) - :build-args (when programp (extra-build-args c)) - :extra-object-files (when programp (extra-object-files c)) - :no-uiop (no-uiop c) - (when programp `(:entry-point ,(component-entry-point c)))))))) -;;;; ------------------------------------------------------------------------- -;;;; Concatenate-source - -(uiop/package:define-package :asdf/concatenate-source - (:recycle :asdf/concatenate-source :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/component :asdf/operation - :asdf/system - :asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle) - (:export - #:concatenate-source-op - #:load-concatenated-source-op - #:compile-concatenated-source-op - #:load-compiled-concatenated-source-op - #:monolithic-concatenate-source-op - #:monolithic-load-concatenated-source-op - #:monolithic-compile-concatenated-source-op - #:monolithic-load-compiled-concatenated-source-op)) -(in-package :asdf/concatenate-source) - -;;; -;;; Concatenate sources -;;; -(with-upgradability () - ;; Base classes for both regular and monolithic concatenate-source operations - (defclass basic-concatenate-source-op (bundle-op) ()) - (defmethod bundle-type ((o basic-concatenate-source-op)) "lisp") - (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ()) - (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ()) - (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ()) - - ;; Regular concatenate-source operations - (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) () - (:documentation "Operation to concatenate all sources in a system into a single file")) - (defclass load-concatenated-source-op (basic-load-concatenated-source-op) - ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)) - (:documentation "Operation to load the result of concatenate-source-op as source")) - (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op) - ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)) - (:documentation "Operation to compile the result of concatenate-source-op")) - (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) - ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class)) - (:documentation "Operation to load the result of compile-concatenated-source-op")) - - (defclass monolithic-concatenate-source-op - (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) () - (:documentation "Operation to concatenate all sources in a system and its dependencies -into a single file")) - (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op) - ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)) - (:documentation "Operation to load the result of monolithic-concatenate-source-op as source")) - (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op) - ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)) - (:documentation "Operation to compile the result of monolithic-concatenate-source-op")) - (defclass monolithic-load-compiled-concatenated-source-op - (basic-load-compiled-concatenated-source-op) - ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class)) - (:documentation "Operation to load the result of monolithic-compile-concatenated-source-op")) - - (defmethod input-files ((operation basic-concatenate-source-op) (s system)) - (loop :with encoding = (or (component-encoding s) *default-encoding*) - :with other-encodings = '() - :with around-compile = (around-compile-hook s) - :with other-around-compile = '() - :for c :in (required-components ;; see note about similar call to required-components - s :goal-operation 'load-op ;; in bundle.lisp - :keep-operation 'basic-compile-op - :other-systems (operation-monolithic-p operation)) - :append - (when (typep c 'cl-source-file) - (let ((e (component-encoding c))) - (unless (or (equal e encoding) - (and (equal e :ASCII) (equal encoding :UTF-8))) - (let ((a (assoc e other-encodings))) - (if a (push (component-find-path c) (cdr a)) - (push (list e (component-find-path c)) other-encodings))))) - (unless (equal around-compile (around-compile-hook c)) - (push (component-find-path c) other-around-compile)) - (input-files (make-operation 'compile-op) c)) :into inputs - :finally - (when other-encodings - (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}" - operation encoding - (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x))))) - other-encodings))) - (when other-around-compile - (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" - operation around-compile other-around-compile)) - (return inputs))) - (defmethod output-files ((o basic-compile-concatenated-source-op) (s system)) - (lisp-compilation-output-files o s)) - - (defmethod perform ((o basic-concatenate-source-op) (s system)) - (let* ((ins (input-files o s)) - (out (output-file o s)) - (tmp (tmpize-pathname out))) - (concatenate-files ins tmp) - (rename-file-overwriting-target tmp out))) - (defmethod perform ((o basic-load-concatenated-source-op) (s system)) - (perform-lisp-load-source o s)) - (defmethod perform ((o basic-compile-concatenated-source-op) (s system)) - (perform-lisp-compilation o s)) - (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system)) - (perform-lisp-load-fasl o s))) - -;;;; ------------------------------------------------------------------------- -;;;; Package systems in the style of quick-build or faslpath - -(uiop:define-package :asdf/package-inferred-system - (:recycle :asdf/package-inferred-system :asdf/package-system :asdf) - (:use :uiop/common-lisp :uiop - :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action - :asdf/parse-defsystem) - (:export - #:package-inferred-system #:sysdef-package-inferred-system-search - #:package-system ;; backward compatibility only. To be removed. - #:register-system-packages - #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error)) -(in-package :asdf/package-inferred-system) - -(with-upgradability () - ;; The names of the recognized defpackage forms. - (defparameter *defpackage-forms* '(defpackage define-package)) - - (defun initial-package-inferred-systems-table () - ;; Mark all existing packages are preloaded. - (let ((h (make-hash-table :test 'equal))) - (dolist (p (list-all-packages)) - (dolist (n (package-names p)) - (setf (gethash n h) t))) - h)) - - ;; Mapping from package names to systems that provide them. - (defvar *package-inferred-systems* (initial-package-inferred-systems-table)) - - (defclass package-inferred-system (system) - () - (:documentation "Class for primary systems for which secondary systems are automatically -in the one-file, one-file, one-system style: system names are mapped to files under the primary -system's system-source-directory, dependencies are inferred from the first defpackage form in -every such file")) - - ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release: - (defclass package-system (package-inferred-system) ()) - - ;; Is a given form recognizable as a defpackage form? - (defun defpackage-form-p (form) - (and (consp form) - (member (car form) *defpackage-forms*))) - - ;; Find the first defpackage form in a stream, if any - (defun stream-defpackage-form (stream) - (loop :for form = (read stream nil nil) :while form - :when (defpackage-form-p form) :return form)) - - (defun file-defpackage-form (file) - "Return the first DEFPACKAGE form in FILE." - (with-input-file (f file) - (stream-defpackage-form f))) - - (define-condition package-inferred-system-missing-package-error (system-definition-error) - ((system :initarg :system :reader error-system) - (pathname :initarg :pathname :reader error-pathname)) - (:report (lambda (c s) - (format s (compatfmt "~@") - (error-system c) (error-pathname c))))) - - (defun package-dependencies (defpackage-form) - "Return a list of packages depended on by the package -defined in DEFPACKAGE-FORM. A package is depended upon if -the DEFPACKAGE-FORM uses it or imports a symbol from it." - (assert (defpackage-form-p defpackage-form)) - (remove-duplicates - (while-collecting (dep) - (loop :for (option . arguments) :in (cddr defpackage-form) :do - (ecase option - ((:use :mix :reexport :use-reexport :mix-reexport) - (dolist (p arguments) (dep (string p)))) - ((:import-from :shadowing-import-from) - (dep (string (first arguments)))) - #+package-local-nicknames - ((:local-nicknames) - (loop :for (nil actual-package-name) :in arguments :do - (dep (string actual-package-name)))) - ((:nicknames :documentation :shadow :export :intern :unintern :recycle))))) - :from-end t :test 'equal)) - - (defun package-designator-name (package) - "Normalize a package designator to a string" - (etypecase package - (package (package-name package)) - (string package) - (symbol (string package)))) - - (defun register-system-packages (system packages) - "Register SYSTEM as providing PACKAGES." - (let ((name (or (eq system t) (coerce-name system)))) - (dolist (p (ensure-list packages)) - (setf (gethash (package-designator-name p) *package-inferred-systems*) name)))) - - (defun package-name-system (package-name) - "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists, -otherwise return a default system name computed from PACKAGE-NAME." - (check-type package-name string) - (or (gethash package-name *package-inferred-systems*) - (string-downcase package-name))) - - ;; Given a file in package-inferred-system style, find its dependencies - (defun package-inferred-system-file-dependencies (file &optional system) - (if-let (defpackage-form (file-defpackage-form file)) - (remove t (mapcar 'package-name-system (package-dependencies defpackage-form))) - (error 'package-inferred-system-missing-package-error :system system :pathname file))) - - ;; Given package-inferred-system object, check whether its specification matches - ;; the provided parameters - (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies) - (and (eq (type-of system) 'package-inferred-system) - (equal (component-name system) name) - (pathname-equal directory (component-pathname system)) - (equal dependencies (component-sideway-dependencies system)) - (equal around-compile (around-compile-hook system)) - (let ((children (component-children system))) - (and (length=n-p children 1) - (let ((child (first children))) - (and (eq (type-of child) 'cl-source-file) - (equal (component-name child) "lisp") - (and (slot-boundp child 'relative-pathname) - (equal (slot-value child 'relative-pathname) subpath)))))))) - - ;; sysdef search function to push into *system-definition-search-functions* - (defun sysdef-package-inferred-system-search (system-name) - "Takes SYSTEM-NAME and returns an initialized SYSTEM object, or NIL. Made to be added to -*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*." - (let ((primary (primary-system-name system-name))) - ;; this function ONLY does something if the primary system name is NOT the same as - ;; SYSTEM-NAME. It is used to find the systems with names that are relative to - ;; the primary system's name, and that are not explicitly specified in the system - ;; definition - (unless (equal primary system-name) - (let ((top (find-system primary nil))) - (when (typep top 'package-inferred-system) - (if-let (dir (component-pathname top)) - (let* ((sub (subseq system-name (1+ (length primary)))) - (component-type (class-for-type top :file)) - (file-type (file-type (make-instance component-type))) - (f (probe-file* (subpathname dir sub :type file-type) - :truename *resolve-symlinks*))) - (when (file-pathname-p f) - (let ((dependencies (package-inferred-system-file-dependencies f system-name)) - (previous (registered-system system-name)) - (around-compile (around-compile-hook top))) - (if (same-package-inferred-system-p previous system-name dir sub around-compile dependencies) - previous - (eval `(defsystem ,system-name - :class package-inferred-system - :default-component-class ,component-type - :source-file ,(system-source-file top) - :pathname ,dir - :depends-on ,dependencies - :around-compile ,around-compile - :components ((,component-type file-type :pathname ,sub))))))))))))))) - -(with-upgradability () - (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*) - (setf *system-definition-search-functions* - (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil) - *system-definition-search-functions*))) -;;;; --------------------------------------------------------------------------- -;;;; asdf-output-translations - -(uiop/package:define-package :asdf/output-translations - (:recycle :asdf/output-translations :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade) - (:export - #:*output-translations* #:*output-translations-parameter* - #:invalid-output-translation - #:output-translations #:output-translations-initialized-p - #:initialize-output-translations #:clear-output-translations - #:disable-output-translations #:ensure-output-translations - #:apply-output-translations - #:validate-output-translations-directive #:validate-output-translations-form - #:validate-output-translations-file #:validate-output-translations-directory - #:parse-output-translations-string #:wrapping-output-translations - #:user-output-translations-pathname #:system-output-translations-pathname - #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname - #:environment-output-translations #:process-output-translations - #:compute-output-translations - #+abcl #:translate-jar-pathname - )) -(in-package :asdf/output-translations) - -;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro -;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us. -(when-upgrading (:version "3.1.2") (fmakunbound '(setf output-translations))) - -(with-upgradability () - (define-condition invalid-output-translation (invalid-configuration warning) - ((format :initform (compatfmt "~@")))) - - (defvar *output-translations* () - "Either NIL (for uninitialized), or a list of one element, -said element itself being a sorted list of mappings. -Each mapping is a pair of a source pathname and destination pathname, -and the order is by decreasing length of namestring of the source pathname.") - - (defun output-translations () - "Return the configured output-translations, if any" - (car *output-translations*)) - - ;; Set the output-translations, by sorting the provided new-value. - (defun set-output-translations (new-value) - (setf *output-translations* - (list - (stable-sort (copy-list new-value) #'> - :key #'(lambda (x) - (etypecase (car x) - ((eql t) -1) - (pathname - (let ((directory - (normalize-pathname-directory-component - (pathname-directory (car x))))) - (if (listp directory) (length directory) 0)))))))) - new-value) - (defun (setf output-translations) (new-value) (set-output-translations new-value)) - - (defun output-translations-initialized-p () - "Have the output-translations been initialized yet?" - (and *output-translations* t)) - - (defun clear-output-translations () - "Undoes any initialization of the output translations." - (setf *output-translations* '()) - (values)) - (register-clear-configuration-hook 'clear-output-translations) - - - ;;; Validation of the configuration directives... - - (defun validate-output-translations-directive (directive) - (or (member directive '(:enable-user-cache :disable-cache nil)) - (and (consp directive) - (or (and (length=n-p directive 2) - (or (and (eq (first directive) :include) - (typep (second directive) '(or string pathname null))) - (and (location-designator-p (first directive)) - (or (location-designator-p (second directive)) - (location-function-p (second directive)))))) - (and (length=n-p directive 1) - (location-designator-p (first directive))))))) - - (defun validate-output-translations-form (form &key location) - (validate-configuration-form - form - :output-translations - 'validate-output-translations-directive - :location location :invalid-form-reporter 'invalid-output-translation)) - - (defun validate-output-translations-file (file) - (validate-configuration-file - file 'validate-output-translations-form :description "output translations")) - - (defun validate-output-translations-directory (directory) - (validate-configuration-directory - directory :output-translations 'validate-output-translations-directive - :invalid-form-reporter 'invalid-output-translation)) - - - ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents - (defun parse-output-translations-string (string &key location) - (cond - ((or (null string) (equal string "")) - '(:output-translations :inherit-configuration)) - ((not (stringp string)) - (error (compatfmt "~@") string)) - ((eql (char string 0) #\") - (parse-output-translations-string (read-from-string string) :location location)) - ((eql (char string 0) #\() - (validate-output-translations-form (read-from-string string) :location location)) - (t - (loop - :with inherit = nil - :with directives = () - :with start = 0 - :with end = (length string) - :with source = nil - :with separator = (inter-directory-separator) - :for i = (or (position separator string :start start) end) :do - (let ((s (subseq string start i))) - (cond - (source - (push (list source (if (equal "" s) nil s)) directives) - (setf source nil)) - ((equal "" s) - (when inherit - (error (compatfmt "~@") - string)) - (setf inherit t) - (push :inherit-configuration directives)) - (t - (setf source s))) - (setf start (1+ i)) - (when (> start end) - (when source - (error (compatfmt "~@") - string)) - (unless inherit - (push :ignore-inherited-configuration directives)) - (return `(:output-translations ,@(nreverse directives))))))))) - - - ;; The default sources of configuration for output-translations - (defparameter* *default-output-translations* - '(environment-output-translations - user-output-translations-pathname - user-output-translations-directory-pathname - system-output-translations-pathname - system-output-translations-directory-pathname)) - - ;; Compulsory implementation-dependent wrapping for the translations: - ;; handle implementation-provided systems. - (defun wrapping-output-translations () - `(:output-translations - ;; Some implementations have precompiled ASDF systems, - ;; so we must disable translations for implementation paths. - #+(or clasp #|clozure|# ecl mkcl sbcl) - ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) - (when h `(((,h ,*wild-path*) ())))) - #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) - ;; All-import, here is where we want user stuff to be: - :inherit-configuration - ;; These are for convenience, and can be overridden by the user: - #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) - #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - ;; We enable the user cache by default, and here is the place we do: - :enable-user-cache)) - - ;; Relative pathnames of output-translations configuration to XDG configuration directory - (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf")) - (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/")) - - ;; Locating various configuration pathnames, depending on input or output intent. - (defun user-output-translations-pathname (&key (direction :input)) - (xdg-config-pathname *output-translations-file* direction)) - (defun system-output-translations-pathname (&key (direction :input)) - (find-preferred-file (system-config-pathnames *output-translations-file*) - :direction direction)) - (defun user-output-translations-directory-pathname (&key (direction :input)) - (xdg-config-pathname *output-translations-directory* direction)) - (defun system-output-translations-directory-pathname (&key (direction :input)) - (find-preferred-file (system-config-pathnames *output-translations-directory*) - :direction direction)) - (defun environment-output-translations () - (getenv "ASDF_OUTPUT_TRANSLATIONS")) - - - ;;; Processing the configuration. - - (defgeneric process-output-translations (spec &key inherit collect)) - - (defun inherit-output-translations (inherit &key collect) - (when inherit - (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) - - (defun process-output-translations-directive (directive &key inherit collect) - (if (atom directive) - (ecase directive - ((:enable-user-cache) - (process-output-translations-directive '(t :user-cache) :collect collect)) - ((:disable-cache) - (process-output-translations-directive '(t t) :collect collect)) - ((:inherit-configuration) - (inherit-output-translations inherit :collect collect)) - ((:ignore-inherited-configuration :ignore-invalid-entries nil) - nil)) - (let ((src (first directive)) - (dst (second directive))) - (if (eq src :include) - (when dst - (process-output-translations (pathname dst) :inherit nil :collect collect)) - (when src - (let ((trusrc (or (eql src t) - (let ((loc (resolve-location src :ensure-directory t :wilden t))) - (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc))))) - (cond - ((location-function-p dst) - (funcall collect - (list trusrc (ensure-function (second dst))))) - ((typep dst 'boolean) - (funcall collect (list trusrc t))) - (t - (let* ((trudst (resolve-location dst :ensure-directory t :wilden t))) - (funcall collect (list trudst t)) - (funcall collect (list trusrc trudst))))))))))) - - (defmethod process-output-translations ((x symbol) &key - (inherit *default-output-translations*) - collect) - (process-output-translations (funcall x) :inherit inherit :collect collect)) - (defmethod process-output-translations ((pathname pathname) &key inherit collect) - (cond - ((directory-pathname-p pathname) - (process-output-translations (validate-output-translations-directory pathname) - :inherit inherit :collect collect)) - ((probe-file* pathname :truename *resolve-symlinks*) - (process-output-translations (validate-output-translations-file pathname) - :inherit inherit :collect collect)) - (t - (inherit-output-translations inherit :collect collect)))) - (defmethod process-output-translations ((string string) &key inherit collect) - (process-output-translations (parse-output-translations-string string) - :inherit inherit :collect collect)) - (defmethod process-output-translations ((x null) &key inherit collect) - (inherit-output-translations inherit :collect collect)) - (defmethod process-output-translations ((form cons) &key inherit collect) - (dolist (directive (cdr (validate-output-translations-form form))) - (process-output-translations-directive directive :inherit inherit :collect collect))) - - - ;;; Top-level entry-points to configure output-translations - - (defun compute-output-translations (&optional parameter) - "read the configuration, return it" - (remove-duplicates - (while-collecting (c) - (inherit-output-translations - `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) - :test 'equal :from-end t)) - - ;; Saving the user-provided parameter to output-translations, if any, - ;; so we can recompute the translations after code upgrade. - (defvar *output-translations-parameter* nil) - - ;; Main entry-point for users. - (defun initialize-output-translations (&optional (parameter *output-translations-parameter*)) - "read the configuration, initialize the internal configuration variable, -return the configuration" - (setf *output-translations-parameter* parameter - (output-translations) (compute-output-translations parameter))) - - (defun disable-output-translations () - "Initialize output translations in a way that maps every file to itself, -effectively disabling the output translation facility." - (initialize-output-translations - '(:output-translations :disable-cache :ignore-inherited-configuration))) - - ;; checks an initial variable to see whether the state is initialized - ;; or cleared. In the former case, return current configuration; in - ;; the latter, initialize. ASDF will call this function at the start - ;; of (asdf:find-system). - (defun ensure-output-translations () - (if (output-translations-initialized-p) - (output-translations) - (initialize-output-translations))) - - - ;; Top-level entry-point to _use_ output-translations - (defun apply-output-translations (path) - (etypecase path - (logical-pathname - path) - ((or pathname string) - (ensure-output-translations) - (loop :with p = (resolve-symlinks* path) - :for (source destination) :in (car *output-translations*) - :for root = (when (or (eq source t) - (and (pathnamep source) - (not (absolute-pathname-p source)))) - (pathname-root p)) - :for absolute-source = (cond - ((eq source t) (wilden root)) - (root (merge-pathnames* source root)) - (t source)) - :when (or (eq source t) (pathname-match-p p absolute-source)) - :return (translate-pathname* p absolute-source destination root source) - :finally (return p))))) - - - ;; Hook into uiop's output-translation mechanism - #-cormanlisp - (setf *output-translation-function* 'apply-output-translations) - - - ;;; Implementation-dependent hacks - #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar. - (defun translate-jar-pathname (source wildcard) - (declare (ignore wildcard)) - (flet ((normalize-device (pathname) - (if (find :windows *features*) - pathname - (make-pathname :defaults pathname :device :unspecific)))) - (let* ((jar - (pathname (first (pathname-device source)))) - (target-root-directory-namestring - (format nil "/___jar___file___root___/~@[~A/~]" - (and (find :windows *features*) - (pathname-device jar)))) - (relative-source - (relativize-pathname-directory source)) - (relative-jar - (relativize-pathname-directory (ensure-directory-pathname jar))) - (target-root-directory - (normalize-device - (pathname-directory-pathname - (parse-namestring target-root-directory-namestring)))) - (target-root - (merge-pathnames* relative-jar target-root-directory)) - (target - (merge-pathnames* relative-source target-root))) - (normalize-device (apply-output-translations target)))))) - -;;;; ----------------------------------------------------------------- -;;;; Source Registry Configuration, by Francois-Rene Rideau -;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 - -(uiop/package:define-package :asdf/source-registry - ;; NB: asdf/find-system allows upgrade from <=3.2.1 that have initialize-source-registry there - (:recycle :asdf/source-registry :asdf/find-system :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/system-registry) - (:export - #:*source-registry-parameter* #:*default-source-registries* - #:invalid-source-registry - #:source-registry-initialized-p - #:initialize-source-registry #:clear-source-registry #:*source-registry* - #:ensure-source-registry #:*source-registry-parameter* - #:*default-source-registry-exclusions* #:*source-registry-exclusions* - #:*wild-asd* #:directory-asd-files #:register-asd-directory - #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files - #:validate-source-registry-directive #:validate-source-registry-form - #:validate-source-registry-file #:validate-source-registry-directory - #:parse-source-registry-string #:wrapping-source-registry - #:default-user-source-registry #:default-system-source-registry - #:user-source-registry #:system-source-registry - #:user-source-registry-directory #:system-source-registry-directory - #:environment-source-registry #:process-source-registry #:inherit-source-registry - #:compute-source-registry #:flatten-source-registry - #:sysdef-source-registry-search)) -(in-package :asdf/source-registry) - -(with-upgradability () - (define-condition invalid-source-registry (invalid-configuration warning) - ((format :initform (compatfmt "~@")))) - - ;; Default list of directories under which the source-registry tree search won't recurse - (defvar *default-source-registry-exclusions* - '(;;-- Using ack 1.2 exclusions - ".bzr" ".cdv" - ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards - ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" - "_sgbak" "autom4te.cache" "cover_db" "_build" - ;;-- debian often builds stuff under the debian directory... BAD. - "debian")) - - ;; Actual list of directories under which the source-registry tree search won't recurse - (defvar *source-registry-exclusions* *default-source-registry-exclusions*) - - ;; The state of the source-registry after search in configured locations - (defvar *source-registry* nil - "Either NIL (for uninitialized), or an equal hash-table, mapping -system names to pathnames of .asd files") - - ;; Saving the user-provided parameter to the source-registry, if any, - ;; so we can recompute the source-registry after code upgrade. - (defvar *source-registry-parameter* nil) - - (defun source-registry-initialized-p () - (typep *source-registry* 'hash-table)) - - (defun clear-source-registry () - "Undoes any initialization of the source registry." - (setf *source-registry* nil) - (values)) - (register-clear-configuration-hook 'clear-source-registry) - - (defparameter *wild-asd* - (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) - - (defun directory-asd-files (directory) - (directory-files directory *wild-asd*)) - - (defun collect-asds-in-directory (directory collect) - (let ((asds (directory-asd-files directory))) - (map () collect asds) - asds)) - - (defvar *recurse-beyond-asds* t - "Should :tree entries of the source-registry recurse in subdirectories -after having found a .asd file? True by default.") - - ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache, - ;; read its contents instead of further recursively querying the filesystem. - (defun process-source-registry-cache (directory collect) - (let ((cache (ignore-errors - (safe-read-file-form (subpathname directory ".cl-source-registry.cache"))))) - (when (and (listp cache) (eq :source-registry-cache (first cache))) - (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s))) - t))) - - (defun collect-sub*directories-asd-files - (directory &key (exclude *default-source-registry-exclusions*) collect - (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache) - (let ((visited (make-hash-table :test 'equalp))) - (flet ((collectp (dir) - (unless (and (not ignore-cache) (process-source-registry-cache dir collect)) - (let ((asds (collect-asds-in-directory dir collect))) - (or recurse-beyond-asds (not asds))))) - (recursep (x) ; x will be a directory pathname - (and - (not (member (car (last (pathname-directory x))) exclude :test #'equal)) - (flet ((pathname-key (x) - (namestring (truename* x)))) - (let ((visitedp (gethash (pathname-key x) visited))) - (if visitedp nil - (setf (gethash (pathname-key x) visited) t))))))) - (collect-sub*directories directory #'collectp #'recursep (constantly nil))))) - - - ;;; Validate the configuration forms - - (defun validate-source-registry-directive (directive) - (or (member directive '(:default-registry)) - (and (consp directive) - (let ((rest (rest directive))) - (case (first directive) - ((:include :directory :tree) - (and (length=n-p rest 1) - (location-designator-p (first rest)))) - ((:exclude :also-exclude) - (every #'stringp rest)) - ((:default-registry) - (null rest))))))) - - (defun validate-source-registry-form (form &key location) - (validate-configuration-form - form :source-registry 'validate-source-registry-directive - :location location :invalid-form-reporter 'invalid-source-registry)) - - (defun validate-source-registry-file (file) - (validate-configuration-file - file 'validate-source-registry-form :description "a source registry")) - - (defun validate-source-registry-directory (directory) - (validate-configuration-directory - directory :source-registry 'validate-source-registry-directive - :invalid-form-reporter 'invalid-source-registry)) - - - ;;; Parse the configuration string - - (defun parse-source-registry-string (string &key location) - (cond - ((or (null string) (equal string "")) - '(:source-registry :inherit-configuration)) - ((not (stringp string)) - (error (compatfmt "~@") string)) - ((find (char string 0) "\"(") - (validate-source-registry-form (read-from-string string) :location location)) - (t - (loop - :with inherit = nil - :with directives = () - :with start = 0 - :with end = (length string) - :with separator = (inter-directory-separator) - :for pos = (position separator string :start start) :do - (let ((s (subseq string start (or pos end)))) - (flet ((check (dir) - (unless (absolute-pathname-p dir) - (error (compatfmt "~@") string)) - dir)) - (cond - ((equal "" s) ; empty element: inherit - (when inherit - (error (compatfmt "~@") - string)) - (setf inherit t) - (push ':inherit-configuration directives)) - ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? - (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) - (t - (push `(:directory ,(check s)) directives)))) - (cond - (pos - (setf start (1+ pos))) - (t - (unless inherit - (push '(:ignore-inherited-configuration) directives)) - (return `(:source-registry ,@(nreverse directives)))))))))) - - (defun register-asd-directory (directory &key recurse exclude collect) - (if (not recurse) - (collect-asds-in-directory directory collect) - (collect-sub*directories-asd-files - directory :exclude exclude :collect collect))) - - (defparameter* *default-source-registries* - '(environment-source-registry - user-source-registry - user-source-registry-directory - default-user-source-registry - system-source-registry - system-source-registry-directory - default-system-source-registry) - "List of default source registries" "3.1.0.102") - - (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf")) - (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/")) - - (defun wrapping-source-registry () - `(:source-registry - #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) - :inherit-configuration - #+mkcl (:tree ,(translate-logical-pathname "SYS:")) - #+cmucl (:tree #p"modules:") - #+scl (:tree #p"file://modules/"))) - (defun default-user-source-registry () - `(:source-registry - (:tree (:home "common-lisp/")) - #+sbcl (:directory (:home ".sbcl/systems/")) - (:directory ,(xdg-data-home "common-lisp/systems/")) - (:tree ,(xdg-data-home "common-lisp/source/")) - :inherit-configuration)) - (defun default-system-source-registry () - `(:source-registry - ,@(loop :for dir :in (xdg-data-dirs "common-lisp/") - :collect `(:directory (,dir "systems/")) - :collect `(:tree (,dir "source/"))) - :inherit-configuration)) - (defun user-source-registry (&key (direction :input)) - (xdg-config-pathname *source-registry-file* direction)) - (defun system-source-registry (&key (direction :input)) - (find-preferred-file (system-config-pathnames *source-registry-file*) - :direction direction)) - (defun user-source-registry-directory (&key (direction :input)) - (xdg-config-pathname *source-registry-directory* direction)) - (defun system-source-registry-directory (&key (direction :input)) - (find-preferred-file (system-config-pathnames *source-registry-directory*) - :direction direction)) - (defun environment-source-registry () - (getenv "CL_SOURCE_REGISTRY")) - - - ;;; Process the source-registry configuration - - (defgeneric process-source-registry (spec &key inherit register)) - - (defun inherit-source-registry (inherit &key register) - (when inherit - (process-source-registry (first inherit) :register register :inherit (rest inherit)))) - - (defun process-source-registry-directive (directive &key inherit register) - (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) - (ecase kw - ((:include) - (destructuring-bind (pathname) rest - (process-source-registry (resolve-location pathname) :inherit nil :register register))) - ((:directory) - (destructuring-bind (pathname) rest - (when pathname - (funcall register (resolve-location pathname :ensure-directory t))))) - ((:tree) - (destructuring-bind (pathname) rest - (when pathname - (funcall register (resolve-location pathname :ensure-directory t) - :recurse t :exclude *source-registry-exclusions*)))) - ((:exclude) - (setf *source-registry-exclusions* rest)) - ((:also-exclude) - (appendf *source-registry-exclusions* rest)) - ((:default-registry) - (inherit-source-registry - '(default-user-source-registry default-system-source-registry) :register register)) - ((:inherit-configuration) - (inherit-source-registry inherit :register register)) - ((:ignore-inherited-configuration) - nil))) - nil) - - (defmethod process-source-registry ((x symbol) &key inherit register) - (process-source-registry (funcall x) :inherit inherit :register register)) - (defmethod process-source-registry ((pathname pathname) &key inherit register) - (cond - ((directory-pathname-p pathname) - (let ((*here-directory* (resolve-symlinks* pathname))) - (process-source-registry (validate-source-registry-directory pathname) - :inherit inherit :register register))) - ((probe-file* pathname :truename *resolve-symlinks*) - (let ((*here-directory* (pathname-directory-pathname pathname))) - (process-source-registry (validate-source-registry-file pathname) - :inherit inherit :register register))) - (t - (inherit-source-registry inherit :register register)))) - (defmethod process-source-registry ((string string) &key inherit register) - (process-source-registry (parse-source-registry-string string) - :inherit inherit :register register)) - (defmethod process-source-registry ((x null) &key inherit register) - (inherit-source-registry inherit :register register)) - (defmethod process-source-registry ((form cons) &key inherit register) - (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) - (dolist (directive (cdr (validate-source-registry-form form))) - (process-source-registry-directive directive :inherit inherit :register register)))) - - - ;; Flatten the user-provided configuration into an ordered list of directories and trees - (defun flatten-source-registry (&optional (parameter *source-registry-parameter*)) - (remove-duplicates - (while-collecting (collect) - (with-pathname-defaults () ;; be location-independent - (inherit-source-registry - `(wrapping-source-registry - ,parameter - ,@*default-source-registries*) - :register #'(lambda (directory &key recurse exclude) - (collect (list directory :recurse recurse :exclude exclude)))))) - :test 'equal :from-end t)) - - ;; MAYBE: move this utility function to uiop/pathname and export it? - (defun pathname-directory-depth (p) - (length (normalize-pathname-directory-component (pathname-directory p)))) - - (defun preferred-source-path-p (x y) - "Return T iff X is to be preferred over Y as a source path" - (let ((lx (pathname-directory-depth x)) - (ly (pathname-directory-depth y))) - (or (< lx ly) - (and (= lx ly) - (string< (namestring x) - (namestring y)))))) - - ;; Will read the configuration and initialize all internal variables. - (defun compute-source-registry (&optional (parameter *source-registry-parameter*) - (registry *source-registry*)) - (dolist (entry (flatten-source-registry parameter)) - (destructuring-bind (directory &key recurse exclude) entry - (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates - (register-asd-directory - directory :recurse recurse :exclude exclude :collect - #'(lambda (asd) - (let* ((name (pathname-name asd)) - (name (if (typep asd 'logical-pathname) - ;; logical pathnames are upper-case, - ;; at least in the CLHS and on SBCL, - ;; yet (coerce-name :foo) is lower-case. - ;; won't work well with (load-system "Foo") - ;; instead of (load-system 'foo) - (string-downcase name) - name))) - (unless (gethash name registry) ; already shadowed by something else - (if-let (old (gethash name h)) - ;; If the name appears multiple times, - ;; prefer the one with the shallowest directory, - ;; or if they have same depth, compare unix-namestring with string< - (multiple-value-bind (better worse) - (if (preferred-source-path-p asd old) - (progn (setf (gethash name h) asd) (values asd old)) - (values old asd)) - (when *verbose-out* - (warn (compatfmt "~@") - directory recurse name better worse))) - (setf (gethash name h) asd)))))) - (maphash #'(lambda (k v) (setf (gethash k registry) v)) h)))) - (values)) - - (defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) - ;; Record the parameter used to configure the registry - (setf *source-registry-parameter* parameter) - ;; Clear the previous registry database: - (setf *source-registry* (make-hash-table :test 'equal)) - ;; Do it! - (compute-source-registry parameter)) - - ;; Checks an initial variable to see whether the state is initialized - ;; or cleared. In the former case, return current configuration; in - ;; the latter, initialize. ASDF will call this function at the start - ;; of (asdf:find-system) to make sure the source registry is initialized. - ;; However, it will do so *without* a parameter, at which point it - ;; will be too late to provide a parameter to this function, though - ;; you may override the configuration explicitly by calling - ;; initialize-source-registry directly with your parameter. - (defun ensure-source-registry (&optional parameter) - (unless (source-registry-initialized-p) - (initialize-source-registry parameter)) - (values)) - - (defun sysdef-source-registry-search (system) - (ensure-source-registry) - (values (gethash (primary-system-name system) *source-registry*)))) - - -;;;; ------------------------------------------------------------------------- -;;; Internal hacks for backward-compatibility - -(uiop/package:define-package :asdf/backward-internals - (:recycle :asdf/backward-internals :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) - (:export #:load-sysdef)) -(in-package :asdf/backward-internals) - -(with-asdf-deprecation (:style-warning "3.2" :warning "3.4") - (defun load-sysdef (name pathname) - (declare (ignore name pathname)) - ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older. - (error "Use asdf:load-asd instead of asdf::load-sysdef"))) -;;;; ------------------------------------------------------------------------- -;;; Backward-compatible interfaces - -(uiop/package:define-package :asdf/backward-interface - (:recycle :asdf/backward-interface :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/system-registry :asdf/operation :asdf/action - :asdf/lisp-action :asdf/plan :asdf/operate - :asdf/find-system :asdf/parse-defsystem :asdf/output-translations :asdf/bundle) - (:export - #:*asdf-verbose* - #:operation-error #:compile-error #:compile-failed #:compile-warned - #:error-component #:error-operation #:traverse - #:component-load-dependencies - #:enable-asdf-binary-locations-compatibility - #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings - #:component-property - #:run-shell-command - #:system-definition-pathname #:system-registered-p #:require-system - #:explain - #+ecl #:make-build)) -(in-package :asdf/backward-interface) - -;; NB: the warning status of these functions may have to be distinguished later, -;; as some get removed faster than the others in client code. -(with-asdf-deprecation (:style-warning "3.2" :warning "3.4") - - ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp; - ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition - ;; that do not involve ASDF actions. - ;; TODO: find the offenders and stop them. - (progn - (define-condition operation-error (error) ;; Bad, backward-compatible name - ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel - ((component :reader error-component :initarg :component) - (operation :reader error-operation :initarg :operation)) - (:report (lambda (c s) - (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") - (type-of c) (error-operation c) (error-component c))))) - (define-condition compile-error (operation-error) ()) - (define-condition compile-failed (compile-error) ()) - (define-condition compile-warned (compile-error) ())) - - ;; In Quicklisp 2015-05, still used by lisp-executable, staple, repl-utilities, cffi - (defun component-load-dependencies (component) ;; from ASDF 2.000 to 2.26 - "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead; or better, -define your operations with proper use of SIDEWAY-OPERATION, SELFWARD-OPERATION, -or define methods on PREPARE-OP, etc." - ;; Old deprecated name for the same thing. Please update your software. - (component-sideway-dependencies component)) - - ;; These old interfaces from ASDF1 have never been very meaningful - ;; but are still used in obscure places. - ;; In Quicklisp 2015-05, still used by cl-protobufs and clx. - (defgeneric operation-on-warnings (operation) - (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) - (defgeneric operation-on-failure (operation) - (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) - (defgeneric (setf operation-on-warnings) (x operation) - (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) - (defgeneric (setf operation-on-failure) (x operation) - (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) - (progn - (defmethod operation-on-warnings ((o operation)) - *compile-file-warnings-behaviour*) - (defmethod operation-on-failure ((o operation)) - *compile-file-failure-behaviour*) - (defmethod (setf operation-on-warnings) (x (o operation)) - (setf *compile-file-warnings-behaviour* x)) - (defmethod (setf operation-on-failure) (x (o operation)) - (setf *compile-file-failure-behaviour* x))) - - ;; Quicklisp 2015-05: Still used by SLIME's swank-asdf (!), common-lisp-stat, - ;; js-parser, osicat, babel, staple, weblocks, cl-png, plain-odbc, autoproject, - ;; cl-blapack, com.informatimago, cells-gtk3, asdf-dependency-grovel, - ;; cl-glfw, cffi, jwacs, montezuma - (defun system-definition-pathname (x) - ;; As of 2.014.8, we mean to make this function obsolete, - ;; but that won't happen until all clients have been updated. - "DEPRECATED. This function used to expose ASDF internals with subtle -differences with respect to user expectations, that have been refactored -away since. We recommend you use ASDF:SYSTEM-SOURCE-FILE instead for a -mostly compatible replacement that we're supporting, or even -ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME -if that's whay you mean." ;;) - (system-source-file x)) - - ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2. - ;; It was never officially exposed but some people still used it. - (defgeneric traverse (operation component &key &allow-other-keys) - (:documentation - "DEPRECATED. Use MAKE-PLAN and PLAN-ACTIONS, or REQUIRED-COMPONENTS, -or some other supported interface instead. - -Generate and return a plan for performing OPERATION on COMPONENT. - -The plan returned is a list of dotted-pairs. Each pair is the CONS -of ASDF operation object and a COMPONENT object. The pairs will be -processed in order by OPERATE.")) - (progn - (define-convenience-action-methods traverse (operation component &key))) - (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys) - (plan-actions (apply 'make-plan plan-class o c keys))) - - - ;; ASDF-Binary-Locations compatibility - ;; This remains supported for legacy user, but not recommended for new users. - ;; We suspect there are no more legacy users in 2016. - (defun enable-asdf-binary-locations-compatibility - (&key - (centralize-lisp-binaries nil) - (default-toplevel-directory - ;; Use ".cache/common-lisp/" instead ??? - (subpathname (user-homedir-pathname) ".fasls/")) - (include-per-user-information nil) - (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil)) - (source-to-target-mappings nil) - (file-types `(,(compile-file-type) - "build-report" - #+clasp (compile-file-type :output-type :object) - #+ecl (compile-file-type :type :object) - #+mkcl (compile-file-type :fasl-p nil) - #+clisp "lib" #+sbcl "cfasl" - #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) - "DEPRECATED. Use asdf-output-translations instead." - #+(or clasp clisp ecl mkcl) - (when (null map-all-source-files) - (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) - (let* ((patterns (if map-all-source-files (list *wild-file*) - (loop :for type :in file-types - :collect (make-pathname :type type :defaults *wild-file*)))) - (destination-directory - (if centralize-lisp-binaries - `(,default-toplevel-directory - ,@(when include-per-user-information - (cdr (pathname-directory (user-homedir-pathname)))) - :implementation ,*wild-inferiors*) - `(:root ,*wild-inferiors* :implementation)))) - (initialize-output-translations - `(:output-translations - ,@source-to-target-mappings - #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) - ,@(loop :for pattern :in patterns - :collect `((:root ,*wild-inferiors* ,pattern) - (,@destination-directory ,pattern))) - (t t) - :ignore-inherited-configuration)))) - (progn - (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) - (declare (ignore operation-class system args)) - (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) - (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. -ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, -which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, -and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. -In case you insist on preserving your previous A-B-L configuration, but -do not know how to achieve the same effect with A-O-T, you may use function -ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; -call that function where you would otherwise have loaded and configured A-B-L.")))) - - - ;; run-shell-command from ASDF 2, lightly fixed from ASDF 1, copied from MK-DEFSYSTEM. Die! - (defun run-shell-command (control-string &rest args) - "PLEASE DO NOT USE. This function is not just DEPRECATED, but also dysfunctional. -Please use UIOP:RUN-PROGRAM instead." - #-(and ecl os-windows) - (let ((command (apply 'format nil control-string args))) - (asdf-message "; $ ~A~%" command) - (let ((exit-code - (ignore-errors - (nth-value 2 (run-program command :force-shell t :ignore-error-status t - :output *verbose-out*))))) - (typecase exit-code - ((integer 0 255) exit-code) - (t 255)))) - #+(and ecl os-windows) - (not-implemented-error "run-shell-command" "for ECL on Windows.")) - - ;; HOW do we get rid of variables??? With a symbol-macro that issues a warning? - ;; In Quicklisp 2015-05, cl-protobufs still uses it, but that should be fixed in next version. - (progn - (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. - - ;; Do NOT use in new code. NOT SUPPORTED. - ;; NB: When this goes away, remove the slot PROPERTY in COMPONENT. - ;; In Quicklisp 2014-05, it's still used by yaclml, amazon-ecs, blackthorn-engine, cl-tidy. - ;; See TODO for further cleanups required before to get rid of it. - (defgeneric component-property (component property)) - (defgeneric (setf component-property) (new-value component property)) - - (defmethod component-property ((c component) property) - (cdr (assoc property (slot-value c 'properties) :test #'equal))) - - (defmethod (setf component-property) (new-value (c component) property) - (let ((a (assoc property (slot-value c 'properties) :test #'equal))) - (if a - (setf (cdr a) new-value) - (setf (slot-value c 'properties) - (acons property new-value (slot-value c 'properties))))) - new-value) - - - ;; This method survives from ASDF 1, but really it is superseded by action-description. - (defgeneric explain (operation component) - (:documentation "Display a message describing an action. - -DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead.")) - (progn - (define-convenience-action-methods explain (operation component))) - (defmethod explain ((o operation) (c component)) - (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))) - -(with-asdf-deprecation (:style-warning "3.3") - (defun system-registered-p (name) - "DEPRECATED. Return a generalized boolean that is true if a system of given NAME was registered already. -NAME is a system designator, to be normalized by COERCE-NAME. -The value returned if true is a pair of a timestamp and a system object." - (if-let (system (registered-system name)) - (cons (if-let (primary-system (registered-system (primary-system-name name))) - (component-operation-time 'define-op primary-system)) - system))) - - (defun require-system (system &rest keys &key &allow-other-keys) - "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the -system or its dependencies if it has already been loaded." - (declare (ignore keys)) - (unless (component-loaded-p system) - (load-system system)))) - -;;; This function is for backward compatibility with ECL only. -#+ecl -(with-asdf-deprecation (:style-warning "3.2" :warning "9999") - (defun make-build (system &rest args - &key (monolithic nil) (type :fasl) (move-here nil move-here-p) - prologue-code epilogue-code no-uiop - prefix-lisp-object-files postfix-lisp-object-files extra-object-files - &allow-other-keys) - (let* ((operation (asdf/bundle::select-bundle-operation type monolithic)) - (move-here-path (if (and move-here - (typep move-here '(or pathname string))) - (ensure-pathname move-here :namestring :lisp :ensure-directory t) - (system-relative-pathname system "asdf-output/"))) - (extra-build-args (remove-plist-keys - '(:monolithic :type :move-here - :prologue-code :epilogue-code :no-uiop - :prefix-lisp-object-files :postfix-lisp-object-files - :extra-object-files) - args)) - (build-system (if (subtypep operation 'image-op) - (eval `(defsystem "asdf.make-build" - :class program-system - :source-file nil - :pathname ,(system-source-directory system) - :build-operation ,operation - :build-pathname ,(subpathname move-here-path - (file-namestring (first (output-files operation system)))) - :depends-on (,(coerce-name system)) - :prologue-code ,prologue-code - :epilogue-code ,epilogue-code - :no-uiop ,no-uiop - :prefix-lisp-object-files ,prefix-lisp-object-files - :postfix-lisp-object-files ,postfix-lisp-object-files - :extra-object-files ,extra-object-files - :extra-build-args ,extra-build-args)) - system)) - (files (output-files operation build-system))) - (operate operation build-system) - (if (or move-here - (and (null move-here-p) (member operation '(program-op image-op)))) - (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) - :for f :in files - :for new-f = (make-pathname :name (pathname-name f) - :type (pathname-type f) - :defaults dest-path) - :do (rename-file-overwriting-target f new-f) - :collect new-f) - files)))) -;;;; --------------------------------------------------------------------------- -;;;; Handle ASDF package upgrade, including implementation-dependent magic. - -(uiop/package:define-package :asdf/interface - (:nicknames :asdf :asdf-utilities) - (:recycle :asdf/interface :asdf) - (:unintern - #:loaded-systems ; makes for annoying SLIME completion - #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/system-registry :asdf/find-component - :asdf/operation :asdf/action :asdf/lisp-action - :asdf/output-translations :asdf/source-registry - :asdf/forcing :asdf/plan :asdf/operate :asdf/find-system :asdf/parse-defsystem - :asdf/bundle :asdf/concatenate-source - :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system) - ;; Note: (1) we are NOT automatically reexporting everything from previous packages. - ;; (2) we only reexport UIOP functionality when backward-compatibility requires it. - (:export - #:defsystem #:find-system #:load-asd #:locate-system #:coerce-name - #:primary-system-name #:primary-system-p - #:oos #:operate #:make-plan #:perform-plan #:sequential-plan - #:system-definition-pathname - #:search-for-system-definition #:find-component #:component-find-path - #:compile-system #:load-system #:load-systems #:load-systems* - #:require-system #:test-system #:clear-system - #:operation #:make-operation #:find-operation - #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation - #:non-propagating-operation - #:build-op #:make - #:load-op #:prepare-op #:compile-op - #:prepare-source-op #:load-source-op #:test-op #:define-op - #:feature #:version #:version-satisfies #:upgrade-asdf - #:implementation-identifier #:implementation-type #:hostname - #:component-depends-on ; backward-compatible name rather than action-depends-on - #:input-files #:additional-input-files - #:output-files #:output-file #:perform #:perform-with-restarts - #:operation-done-p #:explain #:action-description #:component-sideway-dependencies - #:needed-in-image-p - #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system - #:program-system - #:basic-compile-bundle-op #:prepare-bundle-op - #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op - #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op - #:monolithic-lib-op #:monolithic-dll-op #:monolithic-deliver-asd-op - #:concatenate-source-op - #:load-concatenated-source-op - #:compile-concatenated-source-op - #:load-compiled-concatenated-source-op - #:monolithic-concatenate-source-op - #:monolithic-load-concatenated-source-op - #:monolithic-compile-concatenated-source-op - #:monolithic-load-compiled-concatenated-source-op - #:operation-monolithic-p - #:required-components - #:component-loaded-p - #:component #:parent-component #:child-component #:system #:module - #:file-component #:source-file #:c-source-file #:java-source-file - #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp - #:static-file #:doc-file #:html-file - #:file-type #:source-file-type - #:register-preloaded-system #:sysdef-preloaded-system-search - #:register-immutable-system #:sysdef-immutable-system-search - #:package-inferred-system #:register-system-packages - #:component-children - #:component-children-by-name - #:component-pathname - #:component-relative-pathname - #:component-name - #:component-version - #:component-parent - #:component-system - #:component-encoding - #:component-external-format - #:system-description - #:system-long-description - #:system-author - #:system-maintainer - #:system-license - #:system-licence - #:system-version - #:system-source-file - #:system-source-directory - #:system-relative-pathname - #:system-homepage - #:system-mailto - #:system-bug-tracker - #:system-long-name - #:system-source-control - #:map-systems - #:system-defsystem-depends-on - #:system-depends-on - #:system-weakly-depends-on - #:*system-definition-search-functions* ; variables - #:*central-registry* - #:*compile-file-warnings-behaviour* - #:*compile-file-failure-behaviour* - #:*resolve-symlinks* - #:*verbose-out* - #:asdf-version - #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error - #:compile-warned-warning #:compile-failed-warning - #:error-name - #:error-pathname - #:load-system-definition-error - #:error-component #:error-operation - #:system-definition-error - #:missing-component - #:missing-component-of-version - #:missing-dependency - #:missing-dependency-of-version - #:circular-dependency ; errors - #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name #:system-out-of-date - #:package-inferred-system-missing-package-error - #:operation-definition-warning #:operation-definition-error - #:try-recompiling ; restarts - #:retry - #:accept - #:coerce-entry-to-directory - #:remove-entry-from-registry - #:clear-configuration-and-retry - #:*encoding-detection-hook* - #:*encoding-external-format-hook* - #:*default-encoding* - #:*utf-8-external-format* - #:clear-configuration - #:*output-translations-parameter* - #:initialize-output-translations - #:disable-output-translations - #:clear-output-translations - #:ensure-output-translations - #:apply-output-translations - #:compile-file* - #:compile-file-pathname* - #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check - #:enable-asdf-binary-locations-compatibility - #:*default-source-registries* - #:*source-registry-parameter* - #:initialize-source-registry - #:compute-source-registry - #:clear-source-registry - #:ensure-source-registry - #:process-source-registry - #:registered-system #:registered-systems #:already-loaded-systems - #:resolve-location - #:asdf-message - #:*user-cache* - #:user-output-translations-pathname - #:system-output-translations-pathname - #:user-output-translations-directory-pathname - #:system-output-translations-directory-pathname - #:user-source-registry - #:system-source-registry - #:user-source-registry-directory - #:system-source-registry-directory - - ;; The symbols below are all DEPRECATED, do not use. To be removed in a further release. - #:*asdf-verbose* #:run-shell-command - #:component-load-dependencies #:system-registered-p #:package-system - #+ecl #:make-build - #:operation-on-warnings #:operation-on-failure #:operation-error - #:compile-failed #:compile-warned #:compile-error - #:module-components #:component-property #:traverse)) -;;;; --------------------------------------------------------------------------- -;;;; ASDF-USER, where the action happens. - -(uiop/package:define-package :asdf/user - (:nicknames :asdf-user) - ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below. - ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop. - ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo. - ;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package - ;; that only :use's :cl and :asdf - (:use :uiop/common-lisp :uiop :asdf/interface)) -;;;; ----------------------------------------------------------------------- -;;;; ASDF Footer: last words and cleanup - -(uiop/package:define-package :asdf/footer - (:recycle :asdf/footer :asdf) - (:use :uiop/common-lisp :uiop - :asdf/system ;; used by ECL - :asdf/upgrade :asdf/system-registry :asdf/operate :asdf/bundle) - ;; Happily, all those implementations all have the same module-provider hook interface. - #+(or abcl clasp cmucl clozure ecl mezzano mkcl sbcl) - (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext #+mezzano :sys.int - #:*module-provider-functions* - #+ecl #:*load-hooks*) - #+(or clasp mkcl) (:import-from :si #:*load-hooks*)) - -(in-package :asdf/footer) - -;;;; Register ASDF itself and all its subsystems as preloaded. -(with-upgradability () - (dolist (s '("asdf" "asdf-package-system")) - ;; Don't bother with these system names, no one relies on them anymore: - ;; "asdf-utils" "asdf-bundle" "asdf-driver" "asdf-defsystem" - (register-preloaded-system s :version *asdf-version*)) - (register-preloaded-system "uiop" :version *uiop-version*)) - -;;;; Ensure that the version slot on the registered preloaded systems are -;;;; correct, by CLEARing the system. However, we do not CLEAR-SYSTEM -;;;; unconditionally. This is because it's possible the user has upgraded the -;;;; systems using ASDF itself, meaning that the registered systems have real -;;;; data from the file system that we want to preserve instead of blasting -;;;; away and replacing with a blank preloaded system. -(with-upgradability () - (unless (equal (system-version (registered-system "asdf")) (asdf-version)) - (clear-system "asdf")) - ;; 3.1.2 is the last version where asdf-package-system was a separate system. - (when (version< "3.1.2" (system-version (registered-system "asdf-package-system"))) - (clear-system "asdf-package-system")) - (unless (equal (system-version (registered-system "uiop")) *uiop-version*) - (clear-system "uiop"))) - -;;;; Hook ASDF into the implementation's REQUIRE and other entry points. -#+(or abcl clasp clisp clozure cmucl ecl mezzano mkcl sbcl) -(with-upgradability () - ;; Hook into CL:REQUIRE. - #-clisp (pushnew 'module-provide-asdf *module-provider-functions*) - #+clisp (if-let (x (find-symbol* '#:*module-provider-functions* :custom nil)) - (eval `(pushnew 'module-provide-asdf ,x))) - - #+(or clasp ecl mkcl) - (progn - (pushnew '("fasb" . si::load-binary) *load-hooks* :test 'equal :key 'car) - - #+os-windows - (unless (assoc "asd" *load-hooks* :test 'equal) - (appendf *load-hooks* '(("asd" . si::load-source)))) - - ;; Wrap module provider functions in an idempotent, upgrade friendly way - (defvar *wrapped-module-provider* (make-hash-table)) - (setf (gethash 'module-provide-asdf *wrapped-module-provider*) 'module-provide-asdf) - (defun wrap-module-provider (provider name) - (let ((results (multiple-value-list (funcall provider name)))) - (when (first results) (register-preloaded-system (coerce-name name))) - (values-list results))) - (defun wrap-module-provider-function (provider) - (ensure-gethash provider *wrapped-module-provider* - (constantly - #'(lambda (module-name) - (wrap-module-provider provider module-name))))) - (setf *module-provider-functions* - (mapcar #'wrap-module-provider-function *module-provider-functions*)))) - -#+cmucl ;; Hook into the CMUCL herald. -(with-upgradability () - (defun herald-asdf (stream) - (format stream " ASDF ~A" (asdf-version))) - (setf (getf ext:*herald-items* :asdf) '(herald-asdf))) - - -;;;; Done! -(with-upgradability () - #+allegro ;; restore *w-o-n-r-c* setting as saved in uiop/common-lisp - (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) - - ;; Advertise the features we provide. - (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf3.3)) (pushnew f *features*)) - - ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users. - (provide "asdf") (provide "ASDF") - - ;; Finally, call a function that will cleanup in case this is an upgrade of an older ASDF. - (cleanup-upgraded-asdf)) - -(when *load-verbose* - (asdf-message ";; ASDF, version ~a~%" (asdf-version))) diff -r aa37feddcfb2 -r 77da08c7f445 tools/prepare-image.lisp --- a/tools/prepare-image.lisp Thu Jun 15 22:01:40 2023 -0400 +++ b/tools/prepare-image.lisp Sun Jun 18 22:25:28 2023 -0400 @@ -3,30 +3,15 @@ ;; For SBCL, if you don't have SBCL_HOME set, then we won't be able to require this later. #+sbcl (require 'sb-introspect) - -(when (probe-file "tools/asdf.lisp") - (format t "Compiling asdf..~%") - (let ((output (compile-file "tools/asdf.lisp" :verbose nil :print nil))) - (load output)) - (provide "asdf")) - +#-sbcl (require "asdf") #+sbcl (require "sb-sprof") -#+nil -(push (pathname (format nil "~a/local-projects/poiu/" (namestring (uiop:getcwd)))) - asdf:*central-registry*) - -(defvar *asdf-root-guesser* nil) - -(defparameter *cwd* (merge-pathnames - *default-pathname-defaults* - (uiop:getcwd))) +(defvar *cwd* (uiop:getcwd)) (defun update-output-translations (root) - "This function is called dynamically from deliver-utils/common.lisp!" (asdf:initialize-output-translations `(:output-translations :inherit-configuration @@ -43,69 +28,6 @@ (asdf:register-preloaded-system :sb-rotate-byte) (asdf:register-preloaded-system :sb-cltl2)) -(defun %read-version (file) - (let ((key "version: ")) - (loop for line in (uiop:read-file-lines file) - if (string= key line :end2 (length key)) - return (subseq line (length key))))) - -(defun init-quicklisp () - (let ((version (%read-version "quicklisp/dists/quicklisp/distinfo.txt"))) - (let ((quicklisp-loc (ensure-directories-exist - (merge-pathnames - (format nil "build/quicklisp/~a/" version) - *cwd*))) - (src (merge-pathnames - "quicklisp/" - *cwd*))) - (flet ((safe-copy-file (path &optional (dest path)) - (let ((src (merge-pathnames - path - "quicklisp/")) - (dest (merge-pathnames - dest - quicklisp-loc))) - (format t "Copying: ~a to ~a~%" src dest) - - (when (equal src dest) - (error "Trying to overwrite the same file")) - (unless (uiop:file-exists-p dest) - (uiop:copy-file - src - (ensure-directories-exist - dest)))))) - (loop for name in - (append (directory - (merge-pathnames - "quicklisp/quicklisp/*.lisp" - *cwd*)) - (directory - (merge-pathnames - "quicklisp/quicklisp/*.asd" - *cwd*))) - do (safe-copy-file name - (format nil "quicklisp/~a.~a" - (pathname-name name) - (pathname-type name)))) - (loop for name in (directory - (merge-pathnames - "quicklisp/*.lisp" - *cwd*)) - do (safe-copy-file name - (format nil "~a.lisp" - (pathname-name name)))) - (safe-copy-file "setup.lisp") - (safe-copy-file "quicklisp/version.txt") - (safe-copy-file "dists/quicklisp/distinfo.txt") - (safe-copy-file "dists/quicklisp/enabled.txt") - (safe-copy-file "dists/quicklisp/preference.txt")) - (load (merge-pathnames - "setup.lisp" - quicklisp-loc))))) - -(init-quicklisp) - -#+nil (ql:update-all-dists :prompt nil) ;; is the package name already loaded as a feature? uhh look it up @@ -117,28 +39,11 @@ (when (probe-file dir) (push dir ql:*local-project-directories*))))) #-demo - (push-src-dir "local-projects") - (push-src-dir "src") - (push-src-dir "third-party") - (push-src-dir "lisp"))) - - -(defun update-root (cwd) - (update-output-translations cwd) - (update-project-directories cwd)) + (push-src-dir ".") + (push-src-dir "vendor"))) (update-project-directories *cwd*) -(defun maybe-asdf-prepare () - (when *asdf-root-guesser* - (update-root (funcall *asdf-root-guesser*)))) - -(compile 'maybe-asdf-prepare) - -(defun unprepare-asdf (root-guesser) - "This function is called dynamically from deliver-utils/common.lisp!" - (setf *asdf-root-guesser* root-guesser)) - (defun maybe-configure-proxy () (let ((proxy (uiop:getenv "HTTP_PROXY"))) (when (and proxy (> (length proxy) 0)) @@ -146,15 +51,9 @@ (maybe-configure-proxy) - (ql:quickload "log4cl") (ql:quickload "prove-asdf") (log:info "*local-project-directories: ~S" ql:*local-project-directories*) -;; (ql:quickload :cl-ppcre) -;; make sure we have build asd -#+nil -(push (pathname (format nil "~a/build-utils/" *cwd*)) - asdf:*central-registry*) (ql:register-local-projects) diff -r aa37feddcfb2 -r 77da08c7f445 vendor/system-index.txt