1.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2+++ b/default-config.sexp Sun Jun 18 22:25:28 2023 -0400
1.3@@ -0,0 +1,1 @@
1.4+;; demo user configuration file
1.5\ No newline at end of file
2.1--- a/demo.asd Thu Jun 15 22:01:40 2023 -0400
2.2+++ b/demo.asd Sun Jun 18 22:25:28 2023 -0400
2.3@@ -1,9 +1,4 @@
2.4 ;;; demo.asd
2.5-(in-package #:asdf-user)
2.6-
2.7-(defsystem "demo/sys"
2.8- :components ((:file "src/package")))
2.9-
2.10 (defsystem "demo"
2.11 :version "0.1.0"
2.12 :author "ellis <ellis@rwest.io>"
2.13@@ -13,9 +8,12 @@
2.14 :bug-tracker "https://lab.rwest.io/otom8/demo/issues"
2.15 :source-control (:hg "https://lab.rwest.io/otom8/demo")
2.16 :license "WTFPL"
2.17- :depends-on ("demo/sys" :cl-dbi :sxql :log4cl :verbose :bordeaux-threads :clingon :clog)
2.18+ :depends-on (:log4cl :bordeaux-threads :clingon :clog)
2.19 :in-order-to ((test-op (test-op "src/test")))
2.20- :build-pathname "demo")
2.21+ :build-pathname "demo"
2.22+ :components ((:module "src"
2.23+ :components ((:file "package")
2.24+ (:file "cfg")))))
2.25
2.26 (defmethod perform :after ((op load-op) (c (eql (find-system :demo))))
2.27 (pushnew :demo *features*))
3.1--- a/makefile Thu Jun 15 22:01:40 2023 -0400
3.2+++ b/makefile Sun Jun 18 22:25:28 2023 -0400
3.3@@ -1,3 +1,4 @@
3.4+# otom8/demo makefile
3.5 MODE?=release
3.6 LISP?=sbcl
3.7 CFG?=default.cfg
3.8@@ -10,7 +11,7 @@
3.9 RS:Cargo.toml rustfmt.toml src/crates/*
3.10 CL:*/*.asd */*.lisp
3.11 deps:;
3.12-clean:;rm -rf *.fasl;cargo clean
3.13+clean:;rm -rf */*.fasl;cargo clean
3.14 fmt:$(RS);cargo fmt
3.15 build:$(RS) $(CL);cargo build --$(MODE);$(L_D)
3.16 --eval '(asdf:make "demo")' \
4.1--- a/readme.org Thu Jun 15 22:01:40 2023 -0400
4.2+++ b/readme.org Sun Jun 18 22:25:28 2023 -0400
4.3@@ -24,20 +24,12 @@
4.4 #+begin_src bash
4.5 ./tools/deps.sh
4.6 #+end_src
4.7- - Rust =curl --proto '=https' --tlsv1.2 -sSf https://sh.rustup.rs | sh=
4.8- - Common Lisp
4.9- - on Linux ::
4.10- - Ubuntu/Debian :: =sudo apt-get install sbcl=
4.11- - Arch BTW :: =sudo pacman -S sbcl=
4.12- - on MacOS :: =brew install sbcl=
4.13- - on Windows :: download from
4.14- <https://www.sbcl.org/platform-table.html> and figure it out.
4.15 - *make executables* \\
4.16 Simply run =make build=. Read the ~makefile~ and change the options
4.17 as needed.
4.18-- M :: Mode (debug, release)
4.19-- L :: Lisp (sbcl, cmucl, ccl)
4.20-- C :: Config (default.cfg)
4.21+- MODE :: Mode (debug, release)
4.22+- LISP :: Lisp (sbcl, cmucl, ccl)
4.23+- CFG :: Config (default.cfg)
4.24 ** Run
4.25 #+begin_src shell
4.26 ./demo -i
5.1--- a/run.lisp Thu Jun 15 22:01:40 2023 -0400
5.2+++ b/run.lisp Sun Jun 18 22:25:28 2023 -0400
5.3@@ -1,2 +1,2 @@
5.4-(load "tools/prepare-image")
5.5-(load "tools/init")
5.6+(defparameter *cwd* (asdf:system-source-directory :demo))
5.7+(load (merge-pathnames "tools/build-image.lisp" *cwd*))
6.1--- a/src/package.lisp Thu Jun 15 22:01:40 2023 -0400
6.2+++ b/src/package.lisp Sun Jun 18 22:25:28 2023 -0400
6.3@@ -1,9 +1,7 @@
6.4 ;; demo packages.lisp
6.5-(defpackage :demo-sys
6.6- (:nicknames :ds))
6.7+(defpackage :demo-sys)
6.8 (defpackage :demo-utils
6.9 (:use :demo-sys)
6.10- (:nicknames :dutils)
6.11 (:export
6.12 #:source-dir
6.13 #:random-id
6.14@@ -19,13 +17,11 @@
6.15 (:nicknames :ddb))
6.16 (defpackage :demo-ui
6.17 (:use :demo-sys)
6.18- (:nicknames :dui)
6.19 (:export
6.20 #:on-new-window
6.21 #:start-ui))
6.22 (defpackage :demo-cli
6.23 (:use :demo-sys)
6.24- (:nicknames :dcli)
6.25 (:export
6.26 #:run-cli
6.27 #:demo-path
6.28@@ -35,9 +31,7 @@
6.29 #:cli-cmd))
6.30 (defpackage :demo
6.31 (:use #:cl #:demo-sys #:demo-utils #:demo-db #:demo-ui #:demo-cli)
6.32- (:nicknames :d)
6.33 (:local-nicknames
6.34- (#:v #:org.shirakumo.verbose)
6.35 (#:bt #:bordeaux-threads)
6.36 (#:cli #:clingon)))
6.37 (defpackage :demo-user
7.1--- a/system-index.txt Thu Jun 15 22:01:40 2023 -0400
7.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
7.3@@ -1,1 +0,0 @@
7.4-demo.asd
8.1--- a/tools/asdf.lisp Thu Jun 15 22:01:40 2023 -0400
8.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
8.3@@ -1,13987 +0,0 @@
8.4-;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; Package: CL-USER ; buffer-read-only: t; -*-
8.5-;;; This is ASDF 3.3.6: Another System Definition Facility.
8.6-;;;
8.7-;;; Feedback, bug reports, and patches are all welcome:
8.8-;;; please mail to <asdf-devel@common-lisp.net>.
8.9-;;; Note first that the canonical source for ASDF is presently
8.10-;;; <URL:http://common-lisp.net/project/asdf/>.
8.11-;;;
8.12-;;; If you obtained this copy from anywhere else, and you experience
8.13-;;; trouble using it, or find bugs, you may want to check at the
8.14-;;; location above for a more recent version (and for documentation
8.15-;;; and test files, if your copy came without them) before reporting
8.16-;;; bugs. There are usually two "supported" revisions - the git master
8.17-;;; branch is the latest development version, whereas the git release
8.18-;;; branch may be slightly older but is considered `stable'
8.19-
8.20-;;; -- LICENSE START
8.21-;;; (This is the MIT / X Consortium license as taken from
8.22-;;; http://www.opensource.org/licenses/mit-license.html on or about
8.23-;;; Monday; July 13, 2009)
8.24-;;;
8.25-;;; Copyright (c) 2001-2019 Daniel Barlow and contributors
8.26-;;;
8.27-;;; Permission is hereby granted, free of charge, to any person obtaining
8.28-;;; a copy of this software and associated documentation files (the
8.29-;;; "Software"), to deal in the Software without restriction, including
8.30-;;; without limitation the rights to use, copy, modify, merge, publish,
8.31-;;; distribute, sublicense, and/or sell copies of the Software, and to
8.32-;;; permit persons to whom the Software is furnished to do so, subject to
8.33-;;; the following conditions:
8.34-;;;
8.35-;;; The above copyright notice and this permission notice shall be
8.36-;;; included in all copies or substantial portions of the Software.
8.37-;;;
8.38-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
8.39-;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
8.40-;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
8.41-;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
8.42-;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
8.43-;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
8.44-;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
8.45-;;;
8.46-;;; -- LICENSE END
8.47-
8.48-;;; The problem with writing a defsystem replacement is bootstrapping:
8.49-;;; we can't use defsystem to compile it. Hence, all in one file.
8.50-
8.51-#+genera
8.52-(eval-when (:compile-toplevel :load-toplevel :execute)
8.53- (multiple-value-bind (system-major system-minor)
8.54- (sct:get-system-version)
8.55- (multiple-value-bind (is-major is-minor)
8.56- (sct:get-system-version "Intel-Support")
8.57- (unless (or (> system-major 452)
8.58- (and is-major
8.59- (or (> is-major 3)
8.60- (and (= is-major 3) (> is-minor 86)))))
8.61- (error "ASDF requires either System 453 or later or Intel Support 3.87 or later")))))
8.62-;;;; ---------------------------------------------------------------------------
8.63-;;;; ASDF package upgrade, including implementation-dependent magic.
8.64-;;
8.65-;; See https://bugs.launchpad.net/asdf/+bug/485687
8.66-;;
8.67-
8.68-;; CAUTION: The definition of the UIOP/PACKAGE package MUST NOT CHANGE,
8.69-;; NOT NOW, NOT EVER, NOT UNDER ANY CIRCUMSTANCE. NEVER.
8.70-;; ... and the same goes for UIOP/PACKAGE-LOCAL-NICKNAMES.
8.71-;;
8.72-;; The entire point of UIOP/PACKAGE is to address the fact that the CL standard
8.73-;; *leaves it unspecified what happens when a package is redefined incompatibly*.
8.74-;; For instance, SBCL 1.4.2 will signal a full WARNING when this happens,
8.75-;; throwing a wrench in upgrading code with ASDF itself, while continuing to
8.76-;; export old symbols it now shouldn't as it also exports new ones,
8.77-;; causing problems with code that relies on the new/current exports.
8.78-;; CLISP and CCL also exports both sets of symbols, though without any WARNING.
8.79-;; ABCL 1.6.1 will plainly ignore the new definition.
8.80-;; Other implementations may do whatever they want and change their behavior at any time.
8.81-;; ***Using DEFPACKAGE twice with different definitions is nasal-demon territory.***
8.82-;;
8.83-;; Thus we define UIOP/PACKAGE:DEFINE-PACKAGE with which packages can be defined
8.84-;; in an upgrade-friendly way: the new definition is authoritative, and
8.85-;; the package will define and export exactly those symbols in the new definition,
8.86-;; no more and no fewer, whereas it is well-defined what happens to previous symbols.
8.87-;; However, for obvious bootstrap reasons, we cannot use DEFINE-PACKAGE
8.88-;; to define UIOP/PACKAGE itself, only DEFPACKAGE.
8.89-;; Therefore, unlike the other packages in ASDF, UIOP/PACKAGE is immutable,
8.90-;; now and forever. It is frozen for the aeons to come, like the CL package itself,
8.91-;; to the same exact state it was defined at its inception, in ASDF 2.27 in 2013.
8.92-;; The same goes for UIOP/PACKAGE-LOCAL-NICKNAMES, that we use internally.
8.93-;;
8.94-;; If you ever must define new symbols in this file, you can and must
8.95-;; export them from a different package, possibly defined in the same file,
8.96-;; say a package UIOP/PACKAGE* defined at the end of this file with DEFINE-PACKAGE,
8.97-;; that might use :import-from to import the symbols from UIOP/PACKAGE,
8.98-;; if you must somehow define them in UIOP/PACKAGE.
8.99-
8.100-(defpackage :uiop/package ;;; THOU SHALT NOT modify this definition, EVER. See explanations above.
8.101- (:use :common-lisp)
8.102- (:export
8.103- #:find-package* #:find-symbol* #:symbol-call
8.104- #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
8.105- #:symbol-shadowing-p #:home-package-p
8.106- #:symbol-package-name #:standard-common-lisp-symbol-p
8.107- #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
8.108- #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol
8.109- #:ensure-package-unused #:delete-package*
8.110- #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
8.111- #:package-definition-form #:parse-define-package-form
8.112- #:ensure-package #:define-package
8.113- ))
8.114-
8.115-(in-package :uiop/package)
8.116-
8.117-;;; package local nicknames feature.
8.118-;;; This can't be deferred until common-lisp.lisp, where most such features are set.
8.119-;;; ABCL and CCL already define this feature appropriately.
8.120-;;; Seems to be unconditionally present for SBCL, ACL, and CLASP
8.121-;;; Don't know about ECL, or others
8.122-(eval-when (:load-toplevel :compile-toplevel :execute)
8.123- ;; ABCL pushes :package-local-nicknames without UIOP interfering,
8.124- ;; and Lispworks will do so
8.125- #+(or sbcl clasp)
8.126- (pushnew :package-local-nicknames *features*)
8.127- #+allegro
8.128- (let ((fname (find-symbol (symbol-name '#:add-package-local-nickname) '#:excl)))
8.129- (when (and fname (fboundp fname))
8.130- (pushnew :package-local-nicknames *features*))))
8.131-
8.132-;;; THOU SHALT NOT modify this definition, EVER, *EXCEPT* to add a new implementation.
8.133-;; If you somehow need to modify the API in any way,
8.134-;; you will need to create another, differently named, and just as immutable package.
8.135-#+package-local-nicknames
8.136-(defpackage :uiop/package-local-nicknames
8.137- (:use :cl)
8.138- (:import-from
8.139- #+allegro #:excl
8.140- #+sbcl #:sb-ext
8.141- #+(or clasp abcl ecl) #:ext
8.142- #+ccl #:ccl
8.143- #+lispworks #:hcl
8.144- #-(or allegro sbcl clasp abcl ccl lispworks ecl)
8.145- (error "Don't know from which package this lisp supplies the local-package-nicknames API.")
8.146- #:remove-package-local-nickname #:package-local-nicknames #:add-package-local-nickname)
8.147- (:export
8.148- #:add-package-local-nickname #:remove-package-local-nickname #:package-local-nicknames))
8.149-
8.150-;;;; General purpose package utilities
8.151-
8.152-(eval-when (:load-toplevel :compile-toplevel :execute)
8.153- (deftype package-designator () '(and (or package character string symbol) (satisfies find-package)))
8.154- (define-condition no-such-package-error (type-error)
8.155- ()
8.156- (:default-initargs :expected-type 'package-designator)
8.157- (:report (lambda (c s)
8.158- (format s "No package named ~a" (string (type-error-datum c))))))
8.159-
8.160- (defmethod package-designator ((c no-such-package-error))
8.161- (type-error-datum c))
8.162-
8.163- (defun find-package* (package-designator &optional (errorp t))
8.164- "Like CL:FIND-PACKAGE, but by default raises a UIOP:NO-SUCH-PACKAGE-ERROR if the
8.165- package is not found."
8.166- (let ((package (find-package package-designator)))
8.167- (cond
8.168- (package package)
8.169- (errorp (error 'no-such-package-error :datum package-designator))
8.170- (t nil))))
8.171-
8.172- (defun find-symbol* (name package-designator &optional (error t))
8.173- "Find a symbol in a package of given string'ified NAME;
8.174-unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
8.175-by letting you supply a symbol or keyword for the name;
8.176-also works well when the package is not present.
8.177-If optional ERROR argument is NIL, return NIL instead of an error
8.178-when the symbol is not found."
8.179- (block nil
8.180- (let ((package (find-package* package-designator error)))
8.181- (when package ;; package error handled by find-package* already
8.182- (multiple-value-bind (symbol status) (find-symbol (string name) package)
8.183- (cond
8.184- (status (return (values symbol status)))
8.185- (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
8.186- (values nil nil))))
8.187- (defun symbol-call (package name &rest args)
8.188- "Call a function associated with symbol of given name in given package,
8.189-with given ARGS. Useful when the call is read before the package is loaded,
8.190-or when loading the package is optional."
8.191- (apply (find-symbol* name package) args))
8.192- (defun intern* (name package-designator &optional (error t))
8.193- (intern (string name) (find-package* package-designator error)))
8.194- (defun export* (name package-designator)
8.195- (let* ((package (find-package* package-designator))
8.196- (symbol (intern* name package)))
8.197- (export (or symbol (list symbol)) package)))
8.198- (defun import* (symbol package-designator)
8.199- (import (or symbol (list symbol)) (find-package* package-designator)))
8.200- (defun shadowing-import* (symbol package-designator)
8.201- (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
8.202- (defun shadow* (name package-designator)
8.203- (shadow (list (string name)) (find-package* package-designator)))
8.204- (defun make-symbol* (name)
8.205- (etypecase name
8.206- (string (make-symbol name))
8.207- (symbol (copy-symbol name))))
8.208- (defun unintern* (name package-designator &optional (error t))
8.209- (block nil
8.210- (let ((package (find-package* package-designator error)))
8.211- (when package
8.212- (multiple-value-bind (symbol status) (find-symbol* name package error)
8.213- (cond
8.214- (status (unintern symbol package)
8.215- (return (values symbol status)))
8.216- (error (error "symbol ~A not present in package ~A"
8.217- (string symbol) (package-name package))))))
8.218- (values nil nil))))
8.219- (defun symbol-shadowing-p (symbol package)
8.220- (and (member symbol (package-shadowing-symbols package)) t))
8.221- (defun home-package-p (symbol package)
8.222- (and package (let ((sp (symbol-package symbol)))
8.223- (and sp (let ((pp (find-package* package)))
8.224- (and pp (eq sp pp))))))))
8.225-
8.226-
8.227-(eval-when (:load-toplevel :compile-toplevel :execute)
8.228- (defun symbol-package-name (symbol)
8.229- (let ((package (symbol-package symbol)))
8.230- (and package (package-name package))))
8.231- (defun standard-common-lisp-symbol-p (symbol)
8.232- (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
8.233- (and (eq sym symbol) (eq status :external))))
8.234- (defun reify-package (package &optional package-context)
8.235- (if (eq package package-context) t
8.236- (etypecase package
8.237- (null nil)
8.238- ((eql (find-package :cl)) :cl)
8.239- (package (package-name package)))))
8.240- (defun unreify-package (package &optional package-context)
8.241- (etypecase package
8.242- (null nil)
8.243- ((eql t) package-context)
8.244- ((or symbol string) (find-package package))))
8.245- (defun reify-symbol (symbol &optional package-context)
8.246- (etypecase symbol
8.247- ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
8.248- (symbol (vector (symbol-name symbol)
8.249- (reify-package (symbol-package symbol) package-context)))))
8.250- (defun unreify-symbol (symbol &optional package-context)
8.251- (etypecase symbol
8.252- (symbol symbol)
8.253- ((simple-vector 2)
8.254- (let* ((symbol-name (svref symbol 0))
8.255- (package-foo (svref symbol 1))
8.256- (package (unreify-package package-foo package-context)))
8.257- (if package (intern* symbol-name package)
8.258- (make-symbol* symbol-name)))))))
8.259-
8.260-(eval-when (:load-toplevel :compile-toplevel :execute)
8.261- (defvar *all-package-happiness* '())
8.262- (defvar *all-package-fishiness* (list t))
8.263- (defun record-fishy (info)
8.264- ;;(format t "~&FISHY: ~S~%" info)
8.265- (push info *all-package-fishiness*))
8.266- (defmacro when-package-fishiness (&body body)
8.267- `(when *all-package-fishiness* ,@body))
8.268- (defmacro note-package-fishiness (&rest info)
8.269- `(when-package-fishiness (record-fishy (list ,@info)))))
8.270-
8.271-(eval-when (:load-toplevel :compile-toplevel :execute)
8.272- #+(or clisp clozure)
8.273- (defun get-setf-function-symbol (symbol)
8.274- #+clisp (let ((sym (get symbol 'system::setf-function)))
8.275- (if sym (values sym :setf-function)
8.276- (let ((sym (get symbol 'system::setf-expander)))
8.277- (if sym (values sym :setf-expander)
8.278- (values nil nil)))))
8.279- #+clozure (gethash symbol ccl::%setf-function-names%))
8.280- #+(or clisp clozure)
8.281- (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
8.282- #+clisp (assert (member kind '(:setf-function :setf-expander)))
8.283- #+clozure (assert (eq kind t))
8.284- #+clisp
8.285- (cond
8.286- ((null new-setf-symbol)
8.287- (remprop symbol 'system::setf-function)
8.288- (remprop symbol 'system::setf-expander))
8.289- ((eq kind :setf-function)
8.290- (setf (get symbol 'system::setf-function) new-setf-symbol))
8.291- ((eq kind :setf-expander)
8.292- (setf (get symbol 'system::setf-expander) new-setf-symbol))
8.293- (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
8.294- kind symbol new-setf-symbol)))
8.295- #+clozure
8.296- (progn
8.297- (gethash symbol ccl::%setf-function-names%) new-setf-symbol
8.298- (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
8.299- #+(or clisp clozure)
8.300- (defun create-setf-function-symbol (symbol)
8.301- #+clisp (system::setf-symbol symbol)
8.302- #+clozure (ccl::construct-setf-function-name symbol))
8.303- (defun set-dummy-symbol (symbol reason other-symbol)
8.304- (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
8.305- (defun make-dummy-symbol (symbol)
8.306- (let ((dummy (copy-symbol symbol)))
8.307- (set-dummy-symbol dummy 'replacing symbol)
8.308- (set-dummy-symbol symbol 'replaced-by dummy)
8.309- dummy))
8.310- (defun dummy-symbol (symbol)
8.311- (get symbol 'dummy-symbol))
8.312- (defun get-dummy-symbol (symbol)
8.313- (let ((existing (dummy-symbol symbol)))
8.314- (if existing (values (cdr existing) (car existing))
8.315- (make-dummy-symbol symbol))))
8.316- (defun nuke-symbol-in-package (symbol package-designator)
8.317- (let ((package (find-package* package-designator))
8.318- (name (symbol-name symbol)))
8.319- (multiple-value-bind (sym stat) (find-symbol name package)
8.320- (when (and (member stat '(:internal :external)) (eq symbol sym))
8.321- (if (symbol-shadowing-p symbol package)
8.322- (shadowing-import* (get-dummy-symbol symbol) package)
8.323- (unintern* symbol package))))))
8.324- (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
8.325- #+(or clisp clozure)
8.326- (multiple-value-bind (setf-symbol kind)
8.327- (get-setf-function-symbol symbol)
8.328- (when kind (nuke-symbol setf-symbol)))
8.329- (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
8.330- (defun rehome-symbol (symbol package-designator)
8.331- "Changes the home package of a symbol, also leaving it present in its old home if any"
8.332- (let* ((name (symbol-name symbol))
8.333- (package (find-package* package-designator))
8.334- (old-package (symbol-package symbol))
8.335- (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
8.336- (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
8.337- (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
8.338- (unless (eq package old-package)
8.339- (let ((overwritten-symbol-shadowing-p
8.340- (and overwritten-symbol-status
8.341- (symbol-shadowing-p overwritten-symbol package))))
8.342- (note-package-fishiness
8.343- :rehome-symbol name
8.344- (when old-package (package-name old-package)) old-status (and shadowing t)
8.345- (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
8.346- (when old-package
8.347- (if shadowing
8.348- (shadowing-import* shadowing old-package))
8.349- (unintern* symbol old-package))
8.350- (cond
8.351- (overwritten-symbol-shadowing-p
8.352- (shadowing-import* symbol package))
8.353- (t
8.354- (when overwritten-symbol-status
8.355- (unintern* overwritten-symbol package))
8.356- (import* symbol package)))
8.357- (if shadowing
8.358- (shadowing-import* symbol old-package)
8.359- (import* symbol old-package))
8.360- #+(or clisp clozure)
8.361- (multiple-value-bind (setf-symbol kind)
8.362- (get-setf-function-symbol symbol)
8.363- (when kind
8.364- (let* ((setf-function (fdefinition setf-symbol))
8.365- (new-setf-symbol (create-setf-function-symbol symbol)))
8.366- (note-package-fishiness
8.367- :setf-function
8.368- name (package-name package)
8.369- (symbol-name setf-symbol) (symbol-package-name setf-symbol)
8.370- (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
8.371- (when (symbol-package setf-symbol)
8.372- (unintern* setf-symbol (symbol-package setf-symbol)))
8.373- (setf (fdefinition new-setf-symbol) setf-function)
8.374- (set-setf-function-symbol new-setf-symbol symbol kind))))
8.375- #+(or clisp clozure)
8.376- (multiple-value-bind (overwritten-setf foundp)
8.377- (get-setf-function-symbol overwritten-symbol)
8.378- (when foundp
8.379- (unintern overwritten-setf)))
8.380- (when (eq old-status :external)
8.381- (export* symbol old-package))
8.382- (when (eq overwritten-symbol-status :external)
8.383- (export* symbol package))))
8.384- (values overwritten-symbol overwritten-symbol-status))))
8.385- (defun ensure-package-unused (package)
8.386- (loop :for p :in (package-used-by-list package) :do
8.387- (unuse-package package p)))
8.388- (defun delete-package* (package &key nuke)
8.389- (let ((p (find-package package)))
8.390- (when p
8.391- (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
8.392- (ensure-package-unused p)
8.393- (delete-package package))))
8.394- (defun package-names (package)
8.395- (cons (package-name package) (package-nicknames package)))
8.396- (defun packages-from-names (names)
8.397- (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
8.398- (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
8.399- separator
8.400- (index (random most-positive-fixnum)))
8.401- (loop :for i :from index
8.402- :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
8.403- :thereis (and (not (find-package n)) n)))
8.404- (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
8.405- (let ((new-name
8.406- (apply 'fresh-package-name
8.407- :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
8.408- (record-fishy (list :rename-away (package-names p) new-name))
8.409- (rename-package p new-name))))
8.410-
8.411-
8.412-;;; Communicable representation of symbol and package information
8.413-
8.414-(eval-when (:load-toplevel :compile-toplevel :execute)
8.415- (defun package-definition-form (package-designator
8.416- &key (nicknamesp t) (usep t)
8.417- (shadowp t) (shadowing-import-p t)
8.418- (exportp t) (importp t) internp (error t))
8.419- (let* ((package (or (find-package* package-designator error)
8.420- (return-from package-definition-form nil)))
8.421- (name (package-name package))
8.422- (nicknames (package-nicknames package))
8.423- (use (mapcar #'package-name (package-use-list package)))
8.424- (shadow ())
8.425- (shadowing-import (make-hash-table :test 'equal))
8.426- (import (make-hash-table :test 'equal))
8.427- (export ())
8.428- (intern ()))
8.429- (when package
8.430- (loop :for sym :being :the :symbols :in package
8.431- :for status = (nth-value 1 (find-symbol* sym package)) :do
8.432- (ecase status
8.433- ((nil :inherited))
8.434- ((:internal :external)
8.435- (let* ((name (symbol-name sym))
8.436- (external (eq status :external))
8.437- (home (symbol-package sym))
8.438- (home-name (package-name home))
8.439- (imported (not (eq home package)))
8.440- (shadowing (symbol-shadowing-p sym package)))
8.441- (cond
8.442- ((and shadowing imported)
8.443- (push name (gethash home-name shadowing-import)))
8.444- (shadowing
8.445- (push name shadow))
8.446- (imported
8.447- (push name (gethash home-name import))))
8.448- (cond
8.449- (external
8.450- (push name export))
8.451- (imported)
8.452- (t (push name intern)))))))
8.453- (labels ((sort-names (names)
8.454- (sort (copy-list names) #'string<))
8.455- (table-keys (table)
8.456- (loop :for k :being :the :hash-keys :of table :collect k))
8.457- (when-relevant (key value)
8.458- (when value (list (cons key value))))
8.459- (import-options (key table)
8.460- (loop :for i :in (sort-names (table-keys table))
8.461- :collect `(,key ,i ,@(sort-names (gethash i table))))))
8.462- `(defpackage ,name
8.463- ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
8.464- (:use ,@(and usep (sort-names use)))
8.465- ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
8.466- ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
8.467- ,@(import-options :import-from (and importp import))
8.468- ,@(when-relevant :export (and exportp (sort-names export)))
8.469- ,@(when-relevant :intern (and internp (sort-names intern)))))))))
8.470-
8.471-
8.472-;;; ensure-package, define-package
8.473-(eval-when (:load-toplevel :compile-toplevel :execute)
8.474- ;; We already have UIOP:SIMPLE-STYLE-WARNING, but it comes from a later
8.475- ;; package.
8.476- (define-condition define-package-style-warning
8.477- #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning)
8.478- ())
8.479- (defun ensure-shadowing-import (name to-package from-package shadowed imported)
8.480- (check-type name string)
8.481- (check-type to-package package)
8.482- (check-type from-package package)
8.483- (check-type shadowed hash-table)
8.484- (check-type imported hash-table)
8.485- (let ((import-me (find-symbol* name from-package)))
8.486- (multiple-value-bind (existing status) (find-symbol name to-package)
8.487- (cond
8.488- ((gethash name shadowed)
8.489- (unless (eq import-me existing)
8.490- (error "Conflicting shadowings for ~A" name)))
8.491- (t
8.492- (setf (gethash name shadowed) t)
8.493- (setf (gethash name imported) t)
8.494- (unless (or (null status)
8.495- (and (member status '(:internal :external))
8.496- (eq existing import-me)
8.497- (symbol-shadowing-p existing to-package)))
8.498- (note-package-fishiness
8.499- :shadowing-import name
8.500- (package-name from-package)
8.501- (or (home-package-p import-me from-package) (symbol-package-name import-me))
8.502- (package-name to-package) status
8.503- (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
8.504- (shadowing-import* import-me to-package))))))
8.505- (defun ensure-imported (import-me into-package &optional from-package)
8.506- (check-type import-me symbol)
8.507- (check-type into-package package)
8.508- (check-type from-package (or null package))
8.509- (let ((name (symbol-name import-me)))
8.510- (multiple-value-bind (existing status) (find-symbol name into-package)
8.511- (cond
8.512- ((not status)
8.513- (import* import-me into-package))
8.514- ((eq import-me existing))
8.515- (t
8.516- (let ((shadowing-p (symbol-shadowing-p existing into-package)))
8.517- (note-package-fishiness
8.518- :ensure-imported name
8.519- (and from-package (package-name from-package))
8.520- (or (home-package-p import-me from-package) (symbol-package-name import-me))
8.521- (package-name into-package)
8.522- status
8.523- (and status (or (home-package-p existing into-package) (symbol-package-name existing)))
8.524- shadowing-p)
8.525- (cond
8.526- ((or shadowing-p (eq status :inherited))
8.527- (shadowing-import* import-me into-package))
8.528- (t
8.529- (unintern* existing into-package)
8.530- (import* import-me into-package))))))))
8.531- (values))
8.532- (defun ensure-import (name to-package from-package shadowed imported)
8.533- (check-type name string)
8.534- (check-type to-package package)
8.535- (check-type from-package package)
8.536- (check-type shadowed hash-table)
8.537- (check-type imported hash-table)
8.538- (multiple-value-bind (import-me import-status) (find-symbol name from-package)
8.539- (when (null import-status)
8.540- (note-package-fishiness
8.541- :import-uninterned name (package-name from-package) (package-name to-package))
8.542- (setf import-me (intern* name from-package)))
8.543- (multiple-value-bind (existing status) (find-symbol name to-package)
8.544- (cond
8.545- ((and imported (gethash name imported))
8.546- (unless (and status (eq import-me existing))
8.547- (error "Can't import ~S from both ~S and ~S"
8.548- name (package-name (symbol-package existing)) (package-name from-package))))
8.549- ((gethash name shadowed)
8.550- (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
8.551- (t
8.552- (setf (gethash name imported) t))))
8.553- (ensure-imported import-me to-package from-package)))
8.554- (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
8.555- (check-type name string)
8.556- (check-type symbol symbol)
8.557- (check-type to-package package)
8.558- (check-type from-package package)
8.559- (check-type mixp (member nil t)) ; no cl:boolean on Genera
8.560- (check-type shadowed hash-table)
8.561- (check-type imported hash-table)
8.562- (check-type inherited hash-table)
8.563- (multiple-value-bind (existing status) (find-symbol name to-package)
8.564- (let* ((sp (symbol-package symbol))
8.565- (in (gethash name inherited))
8.566- (xp (and status (symbol-package existing))))
8.567- (when (null sp)
8.568- (note-package-fishiness
8.569- :import-uninterned name
8.570- (package-name from-package) (package-name to-package) mixp)
8.571- (import* symbol from-package)
8.572- (setf sp (package-name from-package)))
8.573- (cond
8.574- ((gethash name shadowed))
8.575- (in
8.576- (unless (equal sp (first in))
8.577- (if mixp
8.578- (ensure-shadowing-import name to-package (second in) shadowed imported)
8.579- (error "Can't inherit ~S from ~S, it is inherited from ~S"
8.580- name (package-name sp) (package-name (first in))))))
8.581- ((gethash name imported)
8.582- (unless (eq symbol existing)
8.583- (error "Can't inherit ~S from ~S, it is imported from ~S"
8.584- name (package-name sp) (package-name xp))))
8.585- (t
8.586- (setf (gethash name inherited) (list sp from-package))
8.587- (when (and status (not (eq sp xp)))
8.588- (let ((shadowing (symbol-shadowing-p existing to-package)))
8.589- (note-package-fishiness
8.590- :inherited name
8.591- (package-name from-package)
8.592- (or (home-package-p symbol from-package) (symbol-package-name symbol))
8.593- (package-name to-package)
8.594- (or (home-package-p existing to-package) (symbol-package-name existing)))
8.595- (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
8.596- (unintern* existing to-package)))))))))
8.597- (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
8.598- (check-type name string)
8.599- (check-type symbol symbol)
8.600- (check-type to-package package)
8.601- (check-type from-package package)
8.602- (check-type shadowed hash-table)
8.603- (check-type imported hash-table)
8.604- (check-type inherited hash-table)
8.605- (unless (gethash name shadowed)
8.606- (multiple-value-bind (existing status) (find-symbol name to-package)
8.607- (let* ((sp (symbol-package symbol))
8.608- (im (gethash name imported))
8.609- (in (gethash name inherited)))
8.610- (cond
8.611- ((or (null status)
8.612- (and status (eq symbol existing))
8.613- (and in (eq sp (first in))))
8.614- (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
8.615- (in
8.616- (remhash name inherited)
8.617- (ensure-shadowing-import name to-package (second in) shadowed imported))
8.618- (im
8.619- (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
8.620- name (package-name from-package)
8.621- (home-package-p symbol from-package) (symbol-package-name symbol)
8.622- (package-name to-package)
8.623- (home-package-p existing to-package) (symbol-package-name existing)))
8.624- (t
8.625- (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
8.626-
8.627- (defun recycle-symbol (name recycle exported)
8.628- ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
8.629- ;; packages, and a hash-table of names (strings) of symbols scheduled to be
8.630- ;; EXPORTED from the package being defined. It returns two values, the
8.631- ;; symbol found (if any, or else NIL), and a boolean flag indicating whether
8.632- ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the
8.633- ;; re-homing of the symbol, etc.
8.634- (check-type name string)
8.635- (check-type recycle list)
8.636- (check-type exported hash-table)
8.637- (when (gethash name exported) ;; don't bother recycling private symbols
8.638- (let (recycled foundp)
8.639- (dolist (r recycle (values recycled foundp))
8.640- (multiple-value-bind (symbol status) (find-symbol name r)
8.641- (when (and status (home-package-p symbol r))
8.642- (cond
8.643- (foundp
8.644- ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
8.645- (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
8.646- (t
8.647- (setf recycled symbol foundp r)))))))))
8.648- (defun symbol-recycled-p (sym recycle)
8.649- (check-type sym symbol)
8.650- (check-type recycle list)
8.651- (and (member (symbol-package sym) recycle) t))
8.652- (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
8.653- (check-type name string)
8.654- (check-type package package)
8.655- (check-type intern (member nil t)) ; no cl:boolean on Genera
8.656- (check-type shadowed hash-table)
8.657- (check-type imported hash-table)
8.658- (check-type inherited hash-table)
8.659- (unless (or (gethash name shadowed)
8.660- (gethash name imported)
8.661- (gethash name inherited))
8.662- (multiple-value-bind (existing status)
8.663- (find-symbol name package)
8.664- (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
8.665- (cond
8.666- ((and status (eq existing recycled) (eq previous package)))
8.667- (previous
8.668- (rehome-symbol recycled package))
8.669- ((and status (eq package (symbol-package existing))))
8.670- (t
8.671- (when status
8.672- (note-package-fishiness
8.673- :ensure-symbol name
8.674- (reify-package (symbol-package existing) package)
8.675- status intern)
8.676- (unintern existing))
8.677- (when intern
8.678- (intern* name package))))))))
8.679- (declaim (ftype (function (t t t &optional t) t) ensure-exported))
8.680- (defun ensure-exported-to-user (name symbol to-package &optional recycle)
8.681- (check-type name string)
8.682- (check-type symbol symbol)
8.683- (check-type to-package package)
8.684- (check-type recycle list)
8.685- (assert (equal name (symbol-name symbol)))
8.686- (multiple-value-bind (existing status) (find-symbol name to-package)
8.687- (unless (and status (eq symbol existing))
8.688- (let ((accessible
8.689- (or (null status)
8.690- (let ((shadowing (symbol-shadowing-p existing to-package))
8.691- (recycled (symbol-recycled-p existing recycle)))
8.692- (unless (and shadowing (not recycled))
8.693- (note-package-fishiness
8.694- :ensure-export name (symbol-package-name symbol)
8.695- (package-name to-package)
8.696- (or (home-package-p existing to-package) (symbol-package-name existing))
8.697- status shadowing)
8.698- (if (or (eq status :inherited) shadowing)
8.699- (shadowing-import* symbol to-package)
8.700- (unintern existing to-package))
8.701- t)))))
8.702- (when (and accessible (eq status :external))
8.703- (ensure-exported name symbol to-package recycle))))))
8.704- (defun ensure-exported (name symbol from-package &optional recycle)
8.705- (dolist (to-package (package-used-by-list from-package))
8.706- (ensure-exported-to-user name symbol to-package recycle))
8.707- (unless (eq from-package (symbol-package symbol))
8.708- (ensure-imported symbol from-package))
8.709- (export* name from-package))
8.710- (defun ensure-export (name from-package &optional recycle)
8.711- (multiple-value-bind (symbol status) (find-symbol* name from-package)
8.712- (unless (eq status :external)
8.713- (ensure-exported name symbol from-package recycle))))
8.714-
8.715- #+package-local-nicknames
8.716- (defun install-package-local-nicknames (destination-package new-nicknames)
8.717- ;; First, remove all package-local nicknames. (We'll reinstall any desired ones later.)
8.718- (dolist (pair-to-remove (uiop/package-local-nicknames:package-local-nicknames destination-package))
8.719- (uiop/package-local-nicknames:remove-package-local-nickname
8.720- (string (car pair-to-remove)) destination-package))
8.721- ;; Then, install all desired nicknames.
8.722- (loop :for (nickname package) :in new-nicknames
8.723- :do (uiop/package-local-nicknames:add-package-local-nickname
8.724- (string nickname)
8.725- (find-package package)
8.726- destination-package)))
8.727-
8.728- (defun ensure-package (name &key
8.729- nicknames documentation use
8.730- shadow shadowing-import-from
8.731- import-from export intern
8.732- recycle mix reexport
8.733- unintern local-nicknames)
8.734- #+genera (declare (ignore documentation))
8.735- (let* ((package-name (string name))
8.736- (nicknames (mapcar #'string nicknames))
8.737- (names (cons package-name nicknames))
8.738- (previous (packages-from-names names))
8.739- (discarded (cdr previous))
8.740- (to-delete ())
8.741- (package (or (first previous) (make-package package-name :nicknames nicknames)))
8.742- (recycle (packages-from-names recycle))
8.743- (use (mapcar 'find-package* use))
8.744- (mix (mapcar 'find-package* mix))
8.745- (reexport (mapcar 'find-package* reexport))
8.746- (shadow (mapcar 'string shadow))
8.747- (export (mapcar 'string export))
8.748- (intern (mapcar 'string intern))
8.749- (unintern (mapcar 'string unintern))
8.750- (local-nicknames (mapcar #'(lambda (pair) (mapcar 'string pair)) local-nicknames))
8.751- (shadowed (make-hash-table :test 'equal)) ; string to bool
8.752- (imported (make-hash-table :test 'equal)) ; string to bool
8.753- (exported (make-hash-table :test 'equal)) ; string to bool
8.754- ;; string to list home package and use package:
8.755- (inherited (make-hash-table :test 'equal)))
8.756- #-package-local-nicknames
8.757- (declare (ignore local-nicknames)) ; if not supported
8.758- (when-package-fishiness (record-fishy package-name))
8.759- ;; if supported, put package documentation
8.760- #-genera
8.761- (when documentation (setf (documentation package t) documentation))
8.762- ;; remove unwanted packages from use list
8.763- (loop :for p :in (set-difference (package-use-list package) (append mix use))
8.764- :do (note-package-fishiness :over-use name (package-names p))
8.765- (unuse-package p package))
8.766- ;; mark unwanted packages for deletion
8.767- (loop :for p :in discarded
8.768- :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
8.769- (package-names p))
8.770- :do (note-package-fishiness :nickname name (package-names p))
8.771- (cond (n (rename-package p (first n) (rest n)))
8.772- (t (rename-package-away p)
8.773- (push p to-delete))))
8.774- ;; give package its desired name
8.775- (rename-package package package-name nicknames)
8.776- ;; Handle local nicknames
8.777- #+package-local-nicknames
8.778- (install-package-local-nicknames package local-nicknames)
8.779- (dolist (name unintern)
8.780- (multiple-value-bind (existing status) (find-symbol name package)
8.781- (when status
8.782- (unless (eq status :inherited)
8.783- (note-package-fishiness
8.784- :unintern (package-name package) name (symbol-package-name existing) status)
8.785- (unintern* name package nil)))))
8.786- ;; handle exports
8.787- (dolist (name export)
8.788- (setf (gethash name exported) t))
8.789- ;; handle reexportss
8.790- (dolist (p reexport)
8.791- (do-external-symbols (sym p)
8.792- (setf (gethash (string sym) exported) t)))
8.793- ;; unexport symbols not listed in (re)export
8.794- (do-external-symbols (sym package)
8.795- (let ((name (symbol-name sym)))
8.796- (unless (gethash name exported)
8.797- (note-package-fishiness
8.798- :over-export (package-name package) name
8.799- (or (home-package-p sym package) (symbol-package-name sym)))
8.800- (unexport sym package))))
8.801- ;; handle explicitly listed shadowed ssymbols
8.802- (dolist (name shadow)
8.803- (setf (gethash name shadowed) t)
8.804- (multiple-value-bind (existing status) (find-symbol name package)
8.805- (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
8.806- (let ((shadowing (and status (symbol-shadowing-p existing package))))
8.807- (cond
8.808- ((eq previous package))
8.809- (previous
8.810- (rehome-symbol recycled package))
8.811- ((or (member status '(nil :inherited))
8.812- (home-package-p existing package)))
8.813- (t
8.814- (let ((dummy (make-symbol name)))
8.815- (note-package-fishiness
8.816- :shadow-imported (package-name package) name
8.817- (symbol-package-name existing) status shadowing)
8.818- (shadowing-import* dummy package)
8.819- (import* dummy package)))))))
8.820- (shadow* name package))
8.821- ;; handle shadowing imports
8.822- (loop :for (p . syms) :in shadowing-import-from
8.823- :for pp = (find-package* p) :do
8.824- (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
8.825- ;; handle mixed packages
8.826- (loop :for p :in mix
8.827- :for pp = (find-package* p) :do
8.828- (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
8.829- ;; handle import-from packages
8.830- (loop :for (p . syms) :in import-from
8.831- ;; FOR NOW suppress errors in the case where the :import-from
8.832- ;; symbol list is empty (used only to establish a dependency by
8.833- ;; package-inferred-system users).
8.834- :for pp = (find-package* p syms) :do
8.835- (when (null pp)
8.836- ;; TODO: ASDF 3.4 Change to a full warning.
8.837- (warn 'define-package-style-warning
8.838- :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."
8.839- :format-arguments (list name p)))
8.840- (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
8.841- ;; handle use-list and mix
8.842- (dolist (p (append use mix))
8.843- (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
8.844- (use-package p package))
8.845- (loop :for name :being :the :hash-keys :of exported :do
8.846- (ensure-symbol name package t recycle shadowed imported inherited exported)
8.847- (ensure-export name package recycle))
8.848- ;; intern dessired symbols
8.849- (dolist (name intern)
8.850- (ensure-symbol name package t recycle shadowed imported inherited exported))
8.851- (do-symbols (sym package)
8.852- (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
8.853- ;; delete now-deceased packages
8.854- (map () 'delete-package* to-delete)
8.855- package)))
8.856-
8.857-
8.858-(eval-when (:load-toplevel :compile-toplevel :execute)
8.859- (defun parse-define-package-form (package clauses)
8.860- (loop
8.861- :with use-p = nil :with recycle-p = nil
8.862- :with documentation = nil
8.863- :for (kw . args) :in clauses
8.864- :when (eq kw :nicknames) :append args :into nicknames :else
8.865- :when (eq kw :documentation)
8.866- :do (cond
8.867- (documentation (error "define-package: can't define documentation twice"))
8.868- ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
8.869- (t (setf documentation (car args)))) :else
8.870- :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
8.871- :when (eq kw :shadow) :append args :into shadow :else
8.872- :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
8.873- :when (eq kw :import-from) :collect args :into import-from :else
8.874- :when (eq kw :export) :append args :into export :else
8.875- :when (eq kw :intern) :append args :into intern :else
8.876- :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
8.877- :when (eq kw :mix) :append args :into mix :else
8.878- :when (eq kw :reexport) :append args :into reexport :else
8.879- :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
8.880- :and :do (setf use-p t) :else
8.881- :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
8.882- :and :do (setf use-p t) :else
8.883- :when (eq kw :unintern) :append args :into unintern :else
8.884- :when (eq kw :local-nicknames)
8.885- :if (symbol-call '#:uiop '#:featurep :package-local-nicknames)
8.886- :append args :into local-nicknames
8.887- :else
8.888- :do (error ":LOCAL-NICKAMES option is not supported on this lisp implementation.")
8.889- :end
8.890- :else
8.891- :do (error "unrecognized define-package keyword ~S" kw)
8.892- :finally (return `(',package
8.893- :nicknames ',nicknames :documentation ',documentation
8.894- :use ',(if use-p use '(:common-lisp))
8.895- :shadow ',shadow :shadowing-import-from ',shadowing-import-from
8.896- :import-from ',import-from :export ',export :intern ',intern
8.897- :recycle ',(if recycle-p recycle (cons package nicknames))
8.898- :mix ',mix :reexport ',reexport :unintern ',unintern
8.899- ,@(when local-nicknames
8.900- `(:local-nicknames ',local-nicknames)))))))
8.901-
8.902-(defmacro define-package (package &rest clauses)
8.903- "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
8.904-\(KEYWORD . ARGS\).
8.905-DEFINE-PACKAGE supports the following keywords:
8.906-SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN, NICKNAMES,
8.907-DOCUMENTATION -- as per CL:DEFPACKAGE.
8.908-USE -- as per CL:DEFPACKAGE, but if neither USE, USE-REEXPORT, MIX,
8.909-nor MIX-REEXPORT is supplied, then it is equivalent to specifying
8.910-(:USE :COMMON-LISP). This is unlike CL:DEFPACKAGE for which the
8.911-behavior of a form without USE is implementation-dependent.
8.912-RECYCLE -- Recycle the package's exported symbols from the specified packages,
8.913-in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE,
8.914-either through an :EXPORT option or a :REEXPORT option, if the symbol exists in
8.915-one of the :RECYCLE packages, the first such symbol is re-homed to the package
8.916-being defined.
8.917-For the sake of idempotence, it is important that the package being defined
8.918-should appear in first position if it already exists, and even if it doesn't,
8.919-ahead of any package that is not going to be deleted afterwards and never
8.920-created again. In short, except for special cases, always make it the first
8.921-package on the list if the list is not empty.
8.922-MIX -- Takes a list of package designators. MIX behaves like
8.923-\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
8.924-resolve conflicts in favor of the first found symbol. It may still yield
8.925-an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
8.926-REEXPORT -- Takes a list of package designators. For each package, p, in the list,
8.927-export symbols with the same name as those exported from p. Note that in the case
8.928-of shadowing, etc. the symbols with the same name may not be the same symbols.
8.929-UNINTERN -- Remove symbols here from PACKAGE. Note that this is primarily useful
8.930-when *redefining* a previously-existing package in the current image (e.g., when
8.931-upgrading ASDF). Most programmers will have no use for this option.
8.932-LOCAL-NICKNAMES -- If the host implementation supports package local nicknames
8.933-\(check for the :PACKAGE-LOCAL-NICKNAMES feature\), then this should be a list of
8.934-nickname and package name pairs. Using this option will cause an error if the
8.935-host CL implementation does not support it.
8.936-USE-REEXPORT, MIX-REEXPORT -- Use or mix the specified packages as per the USE or
8.937-MIX directives, and reexport their contents as per the REEXPORT directive."
8.938- (let ((ensure-form
8.939- `(prog1
8.940- (funcall 'ensure-package ,@(parse-define-package-form package clauses))
8.941- #+sbcl (setf (sb-impl::package-source-location (find-package ',package))
8.942- (sb-c:source-location)))))
8.943- `(progn
8.944- #+(or clasp ecl gcl mkcl) (defpackage ,package (:use))
8.945- (eval-when (:compile-toplevel :load-toplevel :execute)
8.946- ,ensure-form))))
8.947-
8.948-;; This package, unlike UIOP/PACKAGE, is allowed to evolve and acquire new symbols or drop old ones.
8.949-(define-package :uiop/package*
8.950- (:use-reexport :uiop/package
8.951- #+package-local-nicknames :uiop/package-local-nicknames)
8.952- (:import-from :uiop/package
8.953- #:define-package-style-warning
8.954- #:no-such-package-error
8.955- #:package-designator)
8.956- (:export #:define-package-style-warning
8.957- #:no-such-package-error
8.958- #:package-designator))
8.959-;;;; -------------------------------------------------------------------------
8.960-;;;; Handle compatibility with multiple implementations.
8.961-;;; This file is for papering over the deficiencies and peculiarities
8.962-;;; of various Common Lisp implementations.
8.963-;;; For implementation-specific access to the system, see os.lisp instead.
8.964-;;; A few functions are defined here, but actually exported from utility;
8.965-;;; from this package only common-lisp symbols are exported.
8.966-
8.967-(uiop/package:define-package :uiop/common-lisp
8.968- (:nicknames :uiop/cl)
8.969- (:use :uiop/package)
8.970- (:use-reexport #-genera :common-lisp #+genera :future-common-lisp)
8.971- #+allegro (:intern #:*acl-warn-save*)
8.972- #+cormanlisp (:shadow #:user-homedir-pathname)
8.973- #+cormanlisp
8.974- (:export
8.975- #:logical-pathname #:translate-logical-pathname
8.976- #:make-broadcast-stream #:file-namestring)
8.977- #+genera (:shadowing-import-from :scl #:boolean)
8.978- #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence)
8.979- #+(or mcl cmucl) (:shadow #:user-homedir-pathname))
8.980-(in-package :uiop/common-lisp)
8.981-
8.982-#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
8.983-(error "ASDF is not supported on your implementation. Please help us port it.")
8.984-
8.985-;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
8.986-
8.987-
8.988-;;;; Early meta-level tweaks
8.989-
8.990-#+(or allegro clasp clisp clozure cmucl ecl lispworks mezzano mkcl sbcl abcl)
8.991-(eval-when (:load-toplevel :compile-toplevel :execute)
8.992- (when (and #+allegro (member :ics *features*)
8.993- #+(or clasp clisp cmucl ecl lispworks mkcl) (member :unicode *features*)
8.994- #+clozure (member :openmcl-unicode-strings *features*)
8.995- #+sbcl (member :sb-unicode *features*)
8.996- #+abcl t)
8.997- ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
8.998- ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie.
8.999- (pushnew :asdf-unicode *features*)))
8.1000-
8.1001-#+allegro
8.1002-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1003- ;; We need to disable autoloading BEFORE any mention of package ASDF.
8.1004- ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file
8.1005- ;; or any previous file.
8.1006- (setf excl::*autoload-package-name-alist*
8.1007- (remove "asdf" excl::*autoload-package-name-alist*
8.1008- :test 'equalp :key 'car))
8.1009- (defparameter *acl-warn-save*
8.1010- (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
8.1011- excl:*warn-on-nested-reader-conditionals*))
8.1012- (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
8.1013- (setf excl:*warn-on-nested-reader-conditionals* nil))
8.1014- (setf *print-readably* nil))
8.1015-
8.1016-#+clasp
8.1017-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1018- (setf *load-verbose* nil)
8.1019- (defun use-ecl-byte-compiler-p () nil))
8.1020-
8.1021-#+clozure (in-package :ccl)
8.1022-#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117
8.1023-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1024- (unless (fboundp 'external-process-wait)
8.1025- (in-development-mode
8.1026- (defun external-process-wait (proc)
8.1027- (when (and (external-process-pid proc) (eq (external-process-%status proc) :running))
8.1028- (with-interrupts-enabled
8.1029- (wait-on-semaphore (external-process-completed proc))))
8.1030- (values (external-process-%exit-code proc)
8.1031- (external-process-%status proc))))))
8.1032-#+clozure (in-package :uiop/common-lisp) ;; back in this package.
8.1033-
8.1034-#+cmucl
8.1035-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1036- (setf ext:*gc-verbose* nil)
8.1037- (defun user-homedir-pathname ()
8.1038- (first (ext:search-list (cl:user-homedir-pathname)))))
8.1039-
8.1040-#+cormanlisp
8.1041-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1042- (deftype logical-pathname () nil)
8.1043- (defun make-broadcast-stream () *error-output*)
8.1044- (defun translate-logical-pathname (x) x)
8.1045- (defun user-homedir-pathname (&optional host)
8.1046- (declare (ignore host))
8.1047- (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
8.1048- (defun file-namestring (p)
8.1049- (setf p (pathname p))
8.1050- (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
8.1051-
8.1052-#+ecl
8.1053-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1054- (setf *load-verbose* nil)
8.1055- (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
8.1056- (unless (use-ecl-byte-compiler-p) (require :cmp)))
8.1057-
8.1058-#+gcl
8.1059-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1060- (unless (member :ansi-cl *features*)
8.1061- (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
8.1062- (setf compiler::*compiler-default-type* (pathname "")
8.1063- compiler::*lsp-ext* "")
8.1064- #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later.
8.1065- (cond
8.1066- #+gcl
8.1067- ((or (< system::*gcl-major-version* 2)
8.1068- (and (= system::*gcl-major-version* 2)
8.1069- (< system::*gcl-minor-version* 7)))
8.1070- '(error "GCL 2.7 or later required to use ASDF")))))
8.1071- (eval code)
8.1072- code))
8.1073-
8.1074-#+genera
8.1075-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1076- (unless (fboundp 'lambda)
8.1077- (defmacro lambda (&whole form &rest bvl-decls-and-body)
8.1078- (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1))
8.1079- `#',(cons 'lisp::lambda (cdr form))))
8.1080- (unless (fboundp 'ensure-directories-exist)
8.1081- (defun ensure-directories-exist (path)
8.1082- (fs:create-directories-recursively (pathname path))))
8.1083- (unless (fboundp 'read-sequence)
8.1084- (defun read-sequence (sequence stream &key (start 0) end)
8.1085- (scl:send stream :string-in nil sequence start end)))
8.1086- (unless (fboundp 'write-sequence)
8.1087- (defun write-sequence (sequence stream &key (start 0) end)
8.1088- (scl:send stream :string-out sequence start end)
8.1089- sequence)))
8.1090-
8.1091-#+lispworks
8.1092-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1093- ;; lispworks 3 and earlier cannot be checked for so we always assume
8.1094- ;; at least version 4
8.1095- (unless (member :lispworks4 *features*)
8.1096- (pushnew :lispworks5+ *features*)
8.1097- (unless (member :lispworks5 *features*)
8.1098- (pushnew :lispworks6+ *features*)
8.1099- (unless (member :lispworks6 *features*)
8.1100- (pushnew :lispworks7+ *features*)))))
8.1101-
8.1102-
8.1103-#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
8.1104- (read-from-string
8.1105- "(eval-when (:load-toplevel :compile-toplevel :execute)
8.1106- (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
8.1107- (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
8.1108- ;; Note: ASDF may expect user-homedir-pathname to provide
8.1109- ;; the pathname of the current user's home directory, whereas
8.1110- ;; MCL by default provides the directory from which MCL was started.
8.1111- ;; See http://code.google.com/p/mcl/wiki/Portability
8.1112- (defun user-homedir-pathname ()
8.1113- (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
8.1114- (defun probe-posix (posix-namestring)
8.1115- \"If a file exists for the posix namestring, return the pathname\"
8.1116- (ccl::with-cstrs ((cpath posix-namestring))
8.1117- (ccl::rlet ((is-dir :boolean)
8.1118- (fsref :fsref))
8.1119- (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
8.1120- (ccl::%path-from-fsref fsref is-dir))))))"))
8.1121-
8.1122-#+mkcl
8.1123-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1124- (require :cmp)
8.1125- (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
8.1126-
8.1127-
8.1128-;;;; compatfmt: avoid fancy format directives when unsupported
8.1129-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1130- (defun frob-substrings (string substrings &optional frob)
8.1131- "for each substring in SUBSTRINGS, find occurrences of it within STRING
8.1132-that don't use parts of matched occurrences of previous strings, and
8.1133-FROB them, that is to say, remove them if FROB is NIL,
8.1134-replace by FROB if FROB is a STRING, or if FROB is a FUNCTION,
8.1135-call FROB with the match and a function that emits a string in the output.
8.1136-Return a string made of the parts not omitted or emitted by FROB."
8.1137- (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3)))
8.1138- (let ((length (length string)) (stream nil))
8.1139- (labels ((emit-string (x &optional (start 0) (end (length x)))
8.1140- (when (< start end)
8.1141- (unless stream (setf stream (make-string-output-stream)))
8.1142- (write-string x stream :start start :end end)))
8.1143- (emit-substring (start end)
8.1144- (when (and (zerop start) (= end length))
8.1145- (return-from frob-substrings string))
8.1146- (emit-string string start end))
8.1147- (recurse (substrings start end)
8.1148- (cond
8.1149- ((>= start end))
8.1150- ((null substrings) (emit-substring start end))
8.1151- (t (let* ((sub-spec (first substrings))
8.1152- (sub (if (consp sub-spec) (car sub-spec) sub-spec))
8.1153- (fun (if (consp sub-spec) (cdr sub-spec) frob))
8.1154- (found (search sub string :start2 start :end2 end))
8.1155- (more (rest substrings)))
8.1156- (cond
8.1157- (found
8.1158- (recurse more start found)
8.1159- (etypecase fun
8.1160- (null)
8.1161- (string (emit-string fun))
8.1162- (function (funcall fun sub #'emit-string)))
8.1163- (recurse substrings (+ found (length sub)) end))
8.1164- (t
8.1165- (recurse more start end))))))))
8.1166- (recurse substrings 0 length))
8.1167- (if stream (get-output-stream-string stream) "")))
8.1168-
8.1169- (defmacro compatfmt (format)
8.1170- #+(or gcl genera)
8.1171- (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>")))
8.1172- #-(or gcl genera) format))
8.1173-;;;; -------------------------------------------------------------------------
8.1174-;;;; General Purpose Utilities for ASDF
8.1175-
8.1176-(uiop/package:define-package :uiop/utility
8.1177- (:use :uiop/common-lisp :uiop/package)
8.1178- ;; import and reexport a few things defined in :uiop/common-lisp
8.1179- (:import-from :uiop/common-lisp #:compatfmt #:frob-substrings
8.1180- #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
8.1181- (:export #:compatfmt #:frob-substrings #:compatfmt
8.1182- #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
8.1183- (:export
8.1184- ;; magic helper to define debugging functions:
8.1185- #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
8.1186- #:with-upgradability ;; (un)defining functions in an upgrade-friendly way
8.1187- #:nest #:if-let ;; basic flow control
8.1188- #:parse-body ;; macro definition helper
8.1189- #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
8.1190- #:remove-plist-keys #:remove-plist-key ;; plists
8.1191- #:emptyp ;; sequences
8.1192- #:+non-base-chars-exist-p+ ;; characters
8.1193- #:+max-character-type-index+ #:character-type-index #:+character-types+
8.1194- #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
8.1195- #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
8.1196- #:string-prefix-p #:string-enclosed-p #:string-suffix-p
8.1197- #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols
8.1198- #:coerce-class ;; CLOS
8.1199- #:timestamp< #:timestamps< #:timestamp*< #:timestamp<= ;; timestamps
8.1200- #:earlier-timestamp #:timestamps-earliest #:earliest-timestamp
8.1201- #:later-timestamp #:timestamps-latest #:latest-timestamp #:latest-timestamp-f
8.1202- #:list-to-hash-set #:ensure-gethash ;; hash-table
8.1203- #:ensure-function #:access-at #:access-at-count ;; functions
8.1204- #:call-function #:call-functions #:register-hook-function
8.1205- #:lexicographic< #:lexicographic<= ;; version
8.1206- #:simple-style-warning #:style-warn ;; simple style warnings
8.1207- #:match-condition-p #:match-any-condition-p ;; conditions
8.1208- #:call-with-muffled-conditions #:with-muffled-conditions
8.1209- #:not-implemented-error #:parameter-error
8.1210- #:symbol-test-to-feature-expression
8.1211- #:boolean-to-feature-expression))
8.1212-(in-package :uiop/utility)
8.1213-
8.1214-;;;; Defining functions in a way compatible with hot-upgrade:
8.1215-;; - The WTIH-UPGRADABILITY infrastructure below ensures that functions are declared NOTINLINE,
8.1216-;; so that new definitions are always seen by all callers, even those up the stack.
8.1217-;; - WITH-UPGRADABILITY also uses EVAL-WHEN so that definitions used by ASDF are in a limbo state
8.1218-;; (especially for gf's) in between the COMPILE-OP and LOAD-OP operations on the defining file.
8.1219-;; - THOU SHALT NOT redefine a function with a backward-incompatible semantics without renaming it,
8.1220-;; at least if that function is used by ASDF while performing the plan to load ASDF.
8.1221-;; - THOU SHALT change the name of a function whenever thou makest an incompatible change.
8.1222-;; - For instance, when the meanings of NIL and T for timestamps was inverted,
8.1223-;; functions in the STAMP<, STAMP<=, etc. family had to be renamed to TIMESTAMP<, TIMESTAMP<=, etc.,
8.1224-;; because the change other caused a huge incompatibility during upgrade.
8.1225-;; - Whenever a function goes from a DEFUN to a DEFGENERIC, or the DEFGENERIC signature changes, etc.,
8.1226-;; even in a backward-compatible way, you MUST precede the definition by FMAKUNBOUND.
8.1227-;; - Since FMAKUNBOUND will remove all the methods on the generic function, make sure that
8.1228-;; all the methods required for ASDF to successfully continue compiling itself
8.1229-;; shall be defined in the same file as the one with the FMAKUNBOUND, *after* the DEFGENERIC.
8.1230-;; - When a function goes from DEFGENERIC to DEFUN, you may omit to use FMAKUNBOUND.
8.1231-;; - For safety, you shall put the FMAKUNBOUND just before the DEFUN or DEFGENERIC,
8.1232-;; in the same WITH-UPGRADABILITY form (and its implicit EVAL-WHEN).
8.1233-;; - Any time you change a signature, please keep a comment specifying the first release after the change;
8.1234-;; put that comment on the same line as FMAKUNBOUND, it you use FMAKUNBOUND.
8.1235-(eval-when (:load-toplevel :compile-toplevel :execute)
8.1236- (defun ensure-function-notinline (definition &aux (name (second definition)))
8.1237- (assert (member (first definition) '(defun defgeneric)))
8.1238- `(progn
8.1239- ,(when (and #+(or clasp ecl) (symbolp name)) ; NB: fails for (SETF functions) on ECL
8.1240- `(declaim (notinline ,name)))
8.1241- ,definition))
8.1242- (defmacro with-upgradability ((&optional) &body body)
8.1243- "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
8.1244-to also declare the functions NOTINLINE and to accept a wrapping the function name
8.1245-specification into a list with keyword argument SUPERSEDE (which defaults to T if the name
8.1246-is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION
8.1247-to supersede any previous definition."
8.1248- `(eval-when (:compile-toplevel :load-toplevel :execute)
8.1249- ,@(loop :for form :in body :collect
8.1250- (if (consp form)
8.1251- (case (first form)
8.1252- ((defun defgeneric) (ensure-function-notinline form))
8.1253- (otherwise form))
8.1254- form)))))
8.1255-
8.1256-;;; Magic debugging help. See contrib/debug.lisp
8.1257-(with-upgradability ()
8.1258- (defvar *uiop-debug-utility*
8.1259- '(symbol-call :uiop :subpathname (symbol-call :uiop :uiop-directory) "contrib/debug.lisp")
8.1260- "form that evaluates to the pathname to your favorite debugging utilities")
8.1261-
8.1262- (defmacro uiop-debug (&rest keys)
8.1263- "Load the UIOP debug utility at compile-time as well as runtime"
8.1264- `(eval-when (:compile-toplevel :load-toplevel :execute)
8.1265- (load-uiop-debug-utility ,@keys)))
8.1266-
8.1267- (defun load-uiop-debug-utility (&key package utility-file)
8.1268- "Load the UIOP debug utility in given PACKAGE (default *PACKAGE*).
8.1269-Beware: The utility is located by EVAL'uating the UTILITY-FILE form (default *UIOP-DEBUG-UTILITY*)."
8.1270- (let* ((*package* (if package (find-package package) *package*))
8.1271- (keyword (read-from-string
8.1272- (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
8.1273- (unless (member keyword *features*)
8.1274- (let* ((utility-file (or utility-file *uiop-debug-utility*))
8.1275- (file (ignore-errors (probe-file (eval utility-file)))))
8.1276- (if file (load file)
8.1277- (error "Failed to locate debug utility file: ~S" utility-file)))))))
8.1278-
8.1279-;;; Flow control
8.1280-(with-upgradability ()
8.1281- (defmacro nest (&rest things)
8.1282- "Macro to keep code nesting and indentation under control." ;; Thanks to mbaringer
8.1283- (reduce #'(lambda (outer inner) `(,@outer ,inner))
8.1284- things :from-end t))
8.1285-
8.1286- (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
8.1287- ;; bindings can be (var form) or ((var1 form1) ...)
8.1288- (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
8.1289- (list bindings)
8.1290- bindings))
8.1291- (variables (mapcar #'car binding-list)))
8.1292- `(let ,binding-list
8.1293- (if (and ,@variables)
8.1294- ,then-form
8.1295- ,else-form)))))
8.1296-
8.1297-;;; Macro definition helper
8.1298-(with-upgradability ()
8.1299- (defun parse-body (body &key documentation whole) ;; from alexandria
8.1300- "Parses BODY into (values remaining-forms declarations doc-string).
8.1301-Documentation strings are recognized only if DOCUMENTATION is true.
8.1302-Syntax errors in body are signalled and WHOLE is used in the signal
8.1303-arguments when given."
8.1304- (let ((doc nil)
8.1305- (decls nil)
8.1306- (current nil))
8.1307- (tagbody
8.1308- :declarations
8.1309- (setf current (car body))
8.1310- (when (and documentation (stringp current) (cdr body))
8.1311- (if doc
8.1312- (error "Too many documentation strings in ~S." (or whole body))
8.1313- (setf doc (pop body)))
8.1314- (go :declarations))
8.1315- (when (and (listp current) (eql (first current) 'declare))
8.1316- (push (pop body) decls)
8.1317- (go :declarations)))
8.1318- (values body (nreverse decls) doc))))
8.1319-
8.1320-
8.1321-;;; List manipulation
8.1322-(with-upgradability ()
8.1323- (defmacro while-collecting ((&rest collectors) &body body)
8.1324- "COLLECTORS should be a list of names for collections. A collector
8.1325-defines a function that, when applied to an argument inside BODY, will
8.1326-add its argument to the corresponding collection. Returns multiple values,
8.1327-a list for each collection, in order.
8.1328- E.g.,
8.1329-\(while-collecting \(foo bar\)
8.1330- \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
8.1331- \(foo \(first x\)\)
8.1332- \(bar \(second x\)\)\)\)
8.1333-Returns two values: \(A B C\) and \(1 2 3\)."
8.1334- (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
8.1335- (initial-values (mapcar (constantly nil) collectors)))
8.1336- `(let ,(mapcar #'list vars initial-values)
8.1337- (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
8.1338- ,@body
8.1339- (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
8.1340-
8.1341- (define-modify-macro appendf (&rest args)
8.1342- append "Append onto list") ;; only to be used on short lists.
8.1343-
8.1344- (defun length=n-p (x n) ;is it that (= (length x) n) ?
8.1345- (check-type n (integer 0 *))
8.1346- (loop
8.1347- :for l = x :then (cdr l)
8.1348- :for i :downfrom n :do
8.1349- (cond
8.1350- ((zerop i) (return (null l)))
8.1351- ((not (consp l)) (return nil)))))
8.1352-
8.1353- (defun ensure-list (x)
8.1354- (if (listp x) x (list x))))
8.1355-
8.1356-
8.1357-;;; Remove a key from a plist, i.e. for keyword argument cleanup
8.1358-(with-upgradability ()
8.1359- (defun remove-plist-key (key plist)
8.1360- "Remove a single key from a plist"
8.1361- (loop :for (k v) :on plist :by #'cddr
8.1362- :unless (eq k key)
8.1363- :append (list k v)))
8.1364-
8.1365- (defun remove-plist-keys (keys plist)
8.1366- "Remove a list of keys from a plist"
8.1367- (loop :for (k v) :on plist :by #'cddr
8.1368- :unless (member k keys)
8.1369- :append (list k v))))
8.1370-
8.1371-
8.1372-;;; Sequences
8.1373-(with-upgradability ()
8.1374- (defun emptyp (x)
8.1375- "Predicate that is true for an empty sequence"
8.1376- (or (null x) (and (vectorp x) (zerop (length x))))))
8.1377-
8.1378-
8.1379-;;; Characters
8.1380-(with-upgradability ()
8.1381- ;; base-char != character on ECL, LW, SBCL, Genera.
8.1382- ;; NB: We assume a total order on character types.
8.1383- ;; If that's not true... this code will need to be updated.
8.1384- (defparameter +character-types+ ;; assuming a simple hierarchy
8.1385- #.(coerce (loop :for (type next) :on
8.1386- '(;; In SCL, all characters seem to be 16-bit base-char
8.1387- ;; Yet somehow character fails to be a subtype of base-char
8.1388- #-scl base-char
8.1389- ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
8.1390- ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
8.1391- #+lispworks7+ lw:bmp-char
8.1392- #+lispworks lw:simple-char
8.1393- character)
8.1394- :unless (and next (subtypep next type))
8.1395- :collect type) 'vector))
8.1396- (defparameter +max-character-type-index+ (1- (length +character-types+)))
8.1397- (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+))
8.1398- (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
8.1399-
8.1400-(with-upgradability ()
8.1401- (defun character-type-index (x)
8.1402- (declare (ignorable x))
8.1403- #.(case +max-character-type-index+
8.1404- (0 0)
8.1405- (1 '(etypecase x
8.1406- (character (if (typep x 'base-char) 0 1))
8.1407- (symbol (if (subtypep x 'base-char) 0 1))))
8.1408- (otherwise
8.1409- '(or (position-if (etypecase x
8.1410- (character #'(lambda (type) (typep x type)))
8.1411- (symbol #'(lambda (type) (subtypep x type))))
8.1412- +character-types+)
8.1413- (error "Not a character or character type: ~S" x))))))
8.1414-
8.1415-
8.1416-;;; Strings
8.1417-(with-upgradability ()
8.1418- (defun base-string-p (string)
8.1419- "Does the STRING only contain BASE-CHARs?"
8.1420- (declare (ignorable string))
8.1421- (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
8.1422-
8.1423- (defun strings-common-element-type (strings)
8.1424- "What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
8.1425- (declare (ignorable strings))
8.1426- #.(if +non-base-chars-exist-p+
8.1427- `(aref +character-types+
8.1428- (loop :with index = 0 :for s :in strings :do
8.1429- (flet ((consider (i)
8.1430- (cond ((= i ,+max-character-type-index+) (return i))
8.1431- ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i)))))))
8.1432- (cond
8.1433- ((emptyp s)) ;; NIL or empty string
8.1434- ((characterp s) (consider (character-type-index s)))
8.1435- ((stringp s) (let ((string-type-index
8.1436- (character-type-index (array-element-type s))))
8.1437- (unless (>= index string-type-index)
8.1438- (loop :for c :across s :for i = (character-type-index c)
8.1439- :do (consider i)
8.1440- ,@(when (> +max-character-type-index+ 1)
8.1441- `((when (= i string-type-index) (return))))))))
8.1442- (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))))
8.1443- :finally (return index)))
8.1444- ''character))
8.1445-
8.1446- (defun reduce/strcat (strings &key key start end)
8.1447- "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
8.1448-NIL is interpreted as an empty string. A character is interpreted as a string of length one."
8.1449- (when (or start end) (setf strings (subseq strings start end)))
8.1450- (when key (setf strings (mapcar key strings)))
8.1451- (loop :with output = (make-string (loop :for s :in strings
8.1452- :sum (if (characterp s) 1 (length s)))
8.1453- :element-type (strings-common-element-type strings))
8.1454- :with pos = 0
8.1455- :for input :in strings
8.1456- :do (etypecase input
8.1457- (null)
8.1458- (character (setf (char output pos) input) (incf pos))
8.1459- (string (replace output input :start1 pos) (incf pos (length input))))
8.1460- :finally (return output)))
8.1461-
8.1462- (defun strcat (&rest strings)
8.1463- "Concatenate strings.
8.1464-NIL is interpreted as an empty string, a character as a string of length one."
8.1465- (reduce/strcat strings))
8.1466-
8.1467- (defun first-char (s)
8.1468- "Return the first character of a non-empty string S, or NIL"
8.1469- (and (stringp s) (plusp (length s)) (char s 0)))
8.1470-
8.1471- (defun last-char (s)
8.1472- "Return the last character of a non-empty string S, or NIL"
8.1473- (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
8.1474-
8.1475- (defun split-string (string &key max (separator '(#\Space #\Tab)))
8.1476- "Split STRING into a list of components separated by
8.1477-any of the characters in the sequence SEPARATOR.
8.1478-If MAX is specified, then no more than max(1,MAX) components will be returned,
8.1479-starting the separation from the end, e.g. when called with arguments
8.1480- \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
8.1481- (block ()
8.1482- (let ((list nil) (words 0) (end (length string)))
8.1483- (when (zerop end) (return nil))
8.1484- (flet ((separatorp (char) (find char separator))
8.1485- (done () (return (cons (subseq string 0 end) list))))
8.1486- (loop
8.1487- :for start = (if (and max (>= words (1- max)))
8.1488- (done)
8.1489- (position-if #'separatorp string :end end :from-end t))
8.1490- :do (when (null start) (done))
8.1491- (push (subseq string (1+ start) end) list)
8.1492- (incf words)
8.1493- (setf end start))))))
8.1494-
8.1495- (defun string-prefix-p (prefix string)
8.1496- "Does STRING begin with PREFIX?"
8.1497- (let* ((x (string prefix))
8.1498- (y (string string))
8.1499- (lx (length x))
8.1500- (ly (length y)))
8.1501- (and (<= lx ly) (string= x y :end2 lx))))
8.1502-
8.1503- (defun string-suffix-p (string suffix)
8.1504- "Does STRING end with SUFFIX?"
8.1505- (let* ((x (string string))
8.1506- (y (string suffix))
8.1507- (lx (length x))
8.1508- (ly (length y)))
8.1509- (and (<= ly lx) (string= x y :start1 (- lx ly)))))
8.1510-
8.1511- (defun string-enclosed-p (prefix string suffix)
8.1512- "Does STRING begin with PREFIX and end with SUFFIX?"
8.1513- (and (string-prefix-p prefix string)
8.1514- (string-suffix-p string suffix)))
8.1515-
8.1516- (defvar +cr+ (coerce #(#\Return) 'string))
8.1517- (defvar +lf+ (coerce #(#\Linefeed) 'string))
8.1518- (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string))
8.1519-
8.1520- (defun stripln (x)
8.1521- "Strip a string X from any ending CR, LF or CRLF.
8.1522-Return two values, the stripped string and the ending that was stripped,
8.1523-or the original value and NIL if no stripping took place.
8.1524-Since our STRCAT accepts NIL as empty string designator,
8.1525-the two results passed to STRCAT always reconstitute the original string"
8.1526- (check-type x string)
8.1527- (block nil
8.1528- (flet ((c (end) (when (string-suffix-p x end)
8.1529- (return (values (subseq x 0 (- (length x) (length end))) end)))))
8.1530- (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil)))))
8.1531-
8.1532- (defun standard-case-symbol-name (name-designator)
8.1533- "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING;
8.1534-if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\"
8.1535-platform such as Allegro with modern syntax."
8.1536- (check-type name-designator (or string symbol))
8.1537- (cond
8.1538- ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower))
8.1539- (string name-designator))
8.1540- ;; Should we be doing something on CLISP?
8.1541- (t (string-upcase name-designator))))
8.1542-
8.1543- (defun find-standard-case-symbol (name-designator package-designator &optional (error t))
8.1544- "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR,
8.1545-where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings.
8.1546-If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
8.1547- (find-symbol* (standard-case-symbol-name name-designator)
8.1548- (etypecase package-designator
8.1549- ((or package symbol) package-designator)
8.1550- (string (standard-case-symbol-name package-designator)))
8.1551- error)))
8.1552-
8.1553-;;; timestamps: a REAL or a boolean where T=-infinity, NIL=+infinity
8.1554-(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
8.1555- (deftype timestamp () '(or real boolean)))
8.1556-(with-upgradability ()
8.1557- (defun timestamp< (x y)
8.1558- (etypecase x
8.1559- ((eql t) (not (eql y t)))
8.1560- (real (etypecase y
8.1561- ((eql t) nil)
8.1562- (real (< x y))
8.1563- (null t)))
8.1564- (null nil)))
8.1565- (defun timestamps< (list) (loop :for y :in list :for x = nil :then y :always (timestamp< x y)))
8.1566- (defun timestamp*< (&rest list) (timestamps< list))
8.1567- (defun timestamp<= (x y) (not (timestamp< y x)))
8.1568- (defun earlier-timestamp (x y) (if (timestamp< x y) x y))
8.1569- (defun timestamps-earliest (list) (reduce 'earlier-timestamp list :initial-value nil))
8.1570- (defun earliest-timestamp (&rest list) (timestamps-earliest list))
8.1571- (defun later-timestamp (x y) (if (timestamp< x y) y x))
8.1572- (defun timestamps-latest (list) (reduce 'later-timestamp list :initial-value t))
8.1573- (defun latest-timestamp (&rest list) (timestamps-latest list))
8.1574- (define-modify-macro latest-timestamp-f (&rest timestamps) latest-timestamp))
8.1575-
8.1576-
8.1577-;;; Function designators
8.1578-(with-upgradability ()
8.1579- (defun ensure-function (fun &key (package :cl))
8.1580- "Coerce the object FUN into a function.
8.1581-
8.1582-If FUN is a FUNCTION, return it.
8.1583-If the FUN is a non-sequence literal constant, return constantly that,
8.1584-i.e. for a boolean keyword character number or pathname.
8.1585-Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
8.1586-If FUN is a CONS, return the function that applies its CAR
8.1587-to the appended list of the rest of its CDR and the arguments,
8.1588-unless the CAR is LAMBDA, in which case the expression is evaluated.
8.1589-If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
8.1590-and EVAL that in a (FUNCTION ...) context."
8.1591- (etypecase fun
8.1592- (function fun)
8.1593- ((or boolean keyword character number pathname) (constantly fun))
8.1594- (hash-table #'(lambda (x) (gethash x fun)))
8.1595- (symbol (fdefinition fun))
8.1596- (cons (if (eq 'lambda (car fun))
8.1597- (eval fun)
8.1598- #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))))
8.1599- (string (eval `(function ,(with-standard-io-syntax
8.1600- (let ((*package* (find-package package)))
8.1601- (read-from-string fun))))))))
8.1602-
8.1603- (defun access-at (object at)
8.1604- "Given an OBJECT and an AT specifier, list of successive accessors,
8.1605-call each accessor on the result of the previous calls.
8.1606-An accessor may be an integer, meaning a call to ELT,
8.1607-a keyword, meaning a call to GETF,
8.1608-NIL, meaning identity,
8.1609-a function or other symbol, meaning itself,
8.1610-or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
8.1611-As a degenerate case, the AT specifier may be an atom of a single such accessor
8.1612-instead of a list."
8.1613- (flet ((access (object accessor)
8.1614- (etypecase accessor
8.1615- (function (funcall accessor object))
8.1616- (integer (elt object accessor))
8.1617- (keyword (getf object accessor))
8.1618- (null object)
8.1619- (symbol (funcall accessor object))
8.1620- (cons (funcall (ensure-function accessor) object)))))
8.1621- (if (listp at)
8.1622- (dolist (accessor at object)
8.1623- (setf object (access object accessor)))
8.1624- (access object at))))
8.1625-
8.1626- (defun access-at-count (at)
8.1627- "From an AT specification, extract a COUNT of maximum number
8.1628-of sub-objects to read as per ACCESS-AT"
8.1629- (cond
8.1630- ((integerp at)
8.1631- (1+ at))
8.1632- ((and (consp at) (integerp (first at)))
8.1633- (1+ (first at)))))
8.1634-
8.1635- (defun call-function (function-spec &rest arguments)
8.1636- "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION,
8.1637-with the given ARGUMENTS"
8.1638- (apply (ensure-function function-spec) arguments))
8.1639-
8.1640- (defun call-functions (function-specs)
8.1641- "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION"
8.1642- (map () 'call-function function-specs))
8.1643-
8.1644- (defun register-hook-function (variable hook &optional call-now-p)
8.1645- "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE.
8.1646-When CALL-NOW-P is true, also call the function immediately."
8.1647- (pushnew hook (symbol-value variable) :test 'equal)
8.1648- (when call-now-p (call-function hook))))
8.1649-
8.1650-
8.1651-;;; CLOS
8.1652-(with-upgradability ()
8.1653- (defun coerce-class (class &key (package :cl) (super t) (error 'error))
8.1654- "Coerce CLASS to a class that is subclass of SUPER if specified,
8.1655-or invoke ERROR handler as per CALL-FUNCTION.
8.1656-
8.1657-A keyword designates the name a symbol, which when found in either PACKAGE, designates a class.
8.1658--- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future.
8.1659-A string is read as a symbol while in PACKAGE, the symbol designates a class.
8.1660-
8.1661-A class object designates itself.
8.1662-NIL designates itself (no class).
8.1663-A symbol otherwise designates a class by name."
8.1664- (let* ((normalized
8.1665- (typecase class
8.1666- (keyword (or (find-symbol* class package nil)
8.1667- (find-symbol* class *package* nil)))
8.1668- (string (symbol-call :uiop :safe-read-from-string class :package package))
8.1669- (t class)))
8.1670- (found
8.1671- (etypecase normalized
8.1672- ((or standard-class built-in-class) normalized)
8.1673- ((or null keyword) nil)
8.1674- (symbol (find-class normalized nil nil))))
8.1675- (super-class
8.1676- (etypecase super
8.1677- ((or standard-class built-in-class) super)
8.1678- ((or null keyword) nil)
8.1679- (symbol (find-class super nil nil)))))
8.1680- #+allegro (when found (mop:finalize-inheritance found))
8.1681- (or (and found
8.1682- (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class))
8.1683- found)
8.1684- (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super)))))
8.1685-
8.1686-
8.1687-;;; Hash-tables
8.1688-(with-upgradability ()
8.1689- (defun ensure-gethash (key table default)
8.1690- "Lookup the TABLE for a KEY as by GETHASH, but if not present,
8.1691-call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION,
8.1692-set the corresponding entry to the result in the table.
8.1693-Return two values: the entry after its optional computation, and whether it was found"
8.1694- (multiple-value-bind (value foundp) (gethash key table)
8.1695- (values
8.1696- (if foundp
8.1697- value
8.1698- (setf (gethash key table) (call-function default)))
8.1699- foundp)))
8.1700-
8.1701- (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
8.1702- "Convert a LIST into hash-table that has the same elements when viewed as a set,
8.1703-up to the given equality TEST"
8.1704- (dolist (x list h) (setf (gethash x h) t))))
8.1705-
8.1706-
8.1707-;;; Lexicographic comparison of lists of numbers
8.1708-(with-upgradability ()
8.1709- (defun lexicographic< (element< x y)
8.1710- "Lexicographically compare two lists of using the function element< to compare elements.
8.1711-element< is a strict total order; the resulting order on X and Y will also be strict."
8.1712- (cond ((null y) nil)
8.1713- ((null x) t)
8.1714- ((funcall element< (car x) (car y)) t)
8.1715- ((funcall element< (car y) (car x)) nil)
8.1716- (t (lexicographic< element< (cdr x) (cdr y)))))
8.1717-
8.1718- (defun lexicographic<= (element< x y)
8.1719- "Lexicographically compare two lists of using the function element< to compare elements.
8.1720-element< is a strict total order; the resulting order on X and Y will be a non-strict total order."
8.1721- (not (lexicographic< element< y x))))
8.1722-
8.1723-
8.1724-;;; Simple style warnings
8.1725-(with-upgradability ()
8.1726- (define-condition simple-style-warning
8.1727- #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning)
8.1728- ())
8.1729-
8.1730- (defun style-warn (datum &rest arguments)
8.1731- (etypecase datum
8.1732- (string (warn (make-condition 'simple-style-warning :format-control datum :format-arguments arguments)))
8.1733- (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments))
8.1734- (style-warning (apply 'warn datum arguments)))))
8.1735-
8.1736-
8.1737-;;; Condition control
8.1738-
8.1739-(with-upgradability ()
8.1740- (defparameter +simple-condition-format-control-slot+
8.1741- #+abcl 'system::format-control
8.1742- #+allegro 'excl::format-control
8.1743- #+(or clasp ecl mkcl) 'si::format-control
8.1744- #+clisp 'system::$format-control
8.1745- #+clozure 'ccl::format-control
8.1746- #+(or cmucl scl) 'conditions::format-control
8.1747- #+(or gcl lispworks) 'conditions::format-string
8.1748- #+sbcl 'sb-kernel:format-control
8.1749- #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil
8.1750- "Name of the slot for FORMAT-CONTROL in simple-condition")
8.1751-
8.1752- (defun match-condition-p (x condition)
8.1753- "Compare received CONDITION to some pattern X:
8.1754-a symbol naming a condition class,
8.1755-a simple vector of length 2, arguments to find-symbol* with result as above,
8.1756-or a string describing the format-control of a simple-condition."
8.1757- (etypecase x
8.1758- (symbol (typep condition x))
8.1759- ((simple-vector 2)
8.1760- (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
8.1761- (function (funcall x condition))
8.1762- (string (and (typep condition 'simple-condition)
8.1763- ;; On SBCL, it's always set and the check triggers a warning
8.1764- #+(or allegro clozure cmucl lispworks scl)
8.1765- (slot-boundp condition +simple-condition-format-control-slot+)
8.1766- (ignore-errors (equal (simple-condition-format-control condition) x))))))
8.1767-
8.1768- (defun match-any-condition-p (condition conditions)
8.1769- "match CONDITION against any of the patterns of CONDITIONS supplied"
8.1770- (loop :for x :in conditions :thereis (match-condition-p x condition)))
8.1771-
8.1772- (defun call-with-muffled-conditions (thunk conditions)
8.1773- "calls the THUNK in a context where the CONDITIONS are muffled"
8.1774- (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
8.1775- (muffle-warning c)))))
8.1776- (funcall thunk)))
8.1777-
8.1778- (defmacro with-muffled-conditions ((conditions) &body body)
8.1779- "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
8.1780- `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
8.1781-
8.1782-;;; Conditions
8.1783-
8.1784-(with-upgradability ()
8.1785- (define-condition not-implemented-error (error)
8.1786- ((functionality :initarg :functionality)
8.1787- (format-control :initarg :format-control)
8.1788- (format-arguments :initarg :format-arguments))
8.1789- (:report (lambda (condition stream)
8.1790- (format stream "Not (currently) implemented on ~A: ~S~@[ ~?~]"
8.1791- (nth-value 1 (symbol-call :uiop :implementation-type))
8.1792- (slot-value condition 'functionality)
8.1793- (slot-value condition 'format-control)
8.1794- (slot-value condition 'format-arguments)))))
8.1795-
8.1796- (defun not-implemented-error (functionality &optional format-control &rest format-arguments)
8.1797- "Signal an error because some FUNCTIONALITY is not implemented in the current version
8.1798-of the software on the current platform; it may or may not be implemented in different combinations
8.1799-of version of the software and of the underlying platform. Optionally, report a formatted error
8.1800-message."
8.1801- (error 'not-implemented-error
8.1802- :functionality functionality
8.1803- :format-control format-control
8.1804- :format-arguments format-arguments))
8.1805-
8.1806- (define-condition parameter-error (error)
8.1807- ((functionality :initarg :functionality)
8.1808- (format-control :initarg :format-control)
8.1809- (format-arguments :initarg :format-arguments))
8.1810- (:report (lambda (condition stream)
8.1811- (apply 'format stream
8.1812- (slot-value condition 'format-control)
8.1813- (slot-value condition 'functionality)
8.1814- (slot-value condition 'format-arguments)))))
8.1815-
8.1816- ;; Note that functionality MUST be passed as the second argument to parameter-error, just after
8.1817- ;; the format-control. If you want it to not appear in first position in actual message, use
8.1818- ;; ~* and ~:* to adjust parameter order.
8.1819- (defun parameter-error (format-control functionality &rest format-arguments)
8.1820- "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying
8.1821-platform does not accept a given parameter or combination of parameters. Report a formatted error
8.1822-message, that takes the functionality as its first argument (that can be skipped with ~*)."
8.1823- (error 'parameter-error
8.1824- :functionality functionality
8.1825- :format-control format-control
8.1826- :format-arguments format-arguments)))
8.1827-
8.1828-(with-upgradability ()
8.1829- (defun boolean-to-feature-expression (value)
8.1830- "Converts a boolean VALUE to a form suitable for testing with #+."
8.1831- (if value
8.1832- '(:and)
8.1833- '(:or)))
8.1834-
8.1835- (defun symbol-test-to-feature-expression (name package)
8.1836- "Check if a symbol with a given NAME exists in PACKAGE and returns a
8.1837-form suitable for testing with #+."
8.1838- (boolean-to-feature-expression
8.1839- (find-symbol* name package nil))))
8.1840-(uiop/package:define-package :uiop/version
8.1841- (:recycle :uiop/version :uiop/utility :asdf)
8.1842- (:use :uiop/common-lisp :uiop/package :uiop/utility)
8.1843- (:export
8.1844- #:*uiop-version*
8.1845- #:parse-version #:unparse-version #:version< #:version<= #:version= ;; version support, moved from uiop/utility
8.1846- #:next-version
8.1847- #:deprecated-function-condition #:deprecated-function-name ;; deprecation control
8.1848- #:deprecated-function-style-warning #:deprecated-function-warning
8.1849- #:deprecated-function-error #:deprecated-function-should-be-deleted
8.1850- #:version-deprecation #:with-deprecation))
8.1851-(in-package :uiop/version)
8.1852-
8.1853-(with-upgradability ()
8.1854- (defparameter *uiop-version* "3.3.6")
8.1855-
8.1856- (defun unparse-version (version-list)
8.1857- "From a parsed version (a list of natural numbers), compute the version string"
8.1858- (format nil "~{~D~^.~}" version-list))
8.1859-
8.1860- (defun parse-version (version-string &optional on-error)
8.1861- "Parse a VERSION-STRING as a series of natural numbers separated by dots.
8.1862-Return a (non-null) list of integers if the string is valid;
8.1863-otherwise return NIL.
8.1864-
8.1865-When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
8.1866-with format arguments explaining why the version is invalid.
8.1867-ON-ERROR is also called if the version is not canonical
8.1868-in that it doesn't print back to itself, but the list is returned anyway."
8.1869- (block nil
8.1870- (unless (stringp version-string)
8.1871- (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
8.1872- (return))
8.1873- (unless (loop :for prev = nil :then c :for c :across version-string
8.1874- :always (or (digit-char-p c)
8.1875- (and (eql c #\.) prev (not (eql prev #\.))))
8.1876- :finally (return (and c (digit-char-p c))))
8.1877- (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
8.1878- 'parse-version version-string)
8.1879- (return))
8.1880- (let* ((version-list
8.1881- (mapcar #'parse-integer (split-string version-string :separator ".")))
8.1882- (normalized-version (unparse-version version-list)))
8.1883- (unless (equal version-string normalized-version)
8.1884- (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
8.1885- version-list)))
8.1886-
8.1887- (defun next-version (version)
8.1888- "When VERSION is not nil, it is a string, then parse it as a version, compute the next version
8.1889-and return it as a string."
8.1890- (when version
8.1891- (let ((version-list (parse-version version)))
8.1892- (incf (car (last version-list)))
8.1893- (unparse-version version-list))))
8.1894-
8.1895- (defun version< (version1 version2)
8.1896- "Given two version strings, return T if the second is strictly newer"
8.1897- (let ((v1 (parse-version version1 nil))
8.1898- (v2 (parse-version version2 nil)))
8.1899- (lexicographic< '< v1 v2)))
8.1900-
8.1901- (defun version<= (version1 version2)
8.1902- "Given two version strings, return T if the second is newer or the same"
8.1903- (not (version< version2 version1))))
8.1904-
8.1905- (defun version= (version1 version2)
8.1906- "Given two version strings, return T if the first is newer or the same and
8.1907-the second is also newer or the same."
8.1908- (and (version<= version1 version2)
8.1909- (version<= version2 version1)))
8.1910-
8.1911-
8.1912-(with-upgradability ()
8.1913- (define-condition deprecated-function-condition (condition)
8.1914- ((name :initarg :name :reader deprecated-function-name)))
8.1915- (define-condition deprecated-function-style-warning (deprecated-function-condition style-warning) ())
8.1916- (define-condition deprecated-function-warning (deprecated-function-condition warning) ())
8.1917- (define-condition deprecated-function-error (deprecated-function-condition error) ())
8.1918- (define-condition deprecated-function-should-be-deleted (deprecated-function-condition error) ())
8.1919-
8.1920- (defun deprecated-function-condition-kind (type)
8.1921- (ecase type
8.1922- ((deprecated-function-style-warning) :style-warning)
8.1923- ((deprecated-function-warning) :warning)
8.1924- ((deprecated-function-error) :error)
8.1925- ((deprecated-function-should-be-deleted) :delete)))
8.1926-
8.1927- (defmethod print-object ((c deprecated-function-condition) stream)
8.1928- (let ((name (deprecated-function-name c)))
8.1929- (cond
8.1930- (*print-readably*
8.1931- (let ((fmt "#.(make-condition '~S :name ~S)")
8.1932- (args (list (type-of c) name)))
8.1933- (if *read-eval*
8.1934- (apply 'format stream fmt args)
8.1935- (error "Can't print ~?" fmt args))))
8.1936- (*print-escape*
8.1937- (print-unreadable-object (c stream :type t) (format stream ":name ~S" name)))
8.1938- (t
8.1939- (let ((*package* (find-package :cl))
8.1940- (type (type-of c)))
8.1941- (format stream
8.1942- (if (eq type 'deprecated-function-should-be-deleted)
8.1943- "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete"
8.1944- "~A: Using deprecated function ~S -- please update your code to use a newer API.~
8.1945-~@[~%The docstring for this function says:~%~A~%~]")
8.1946- type name (when (symbolp name) (documentation name 'function))))))))
8.1947-
8.1948- (defun notify-deprecated-function (status name)
8.1949- (ecase status
8.1950- ((nil) nil)
8.1951- ((:style-warning) (style-warn 'deprecated-function-style-warning :name name))
8.1952- ((:warning) (warn 'deprecated-function-warning :name name))
8.1953- ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error :name name))))
8.1954-
8.1955- (defun version-deprecation (version &key (style-warning nil)
8.1956- (warning (next-version style-warning))
8.1957- (error (next-version warning))
8.1958- (delete (next-version error)))
8.1959- "Given a VERSION string, and the starting versions for notifying the programmer of
8.1960-various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION
8.1961-that is the highest level that has a declared version older than the specified version.
8.1962-Each start version for a level of deprecation can be specified by a keyword argument, or
8.1963-if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation."
8.1964- (cond
8.1965- ((and delete (version<= delete version)) :delete)
8.1966- ((and error (version<= error version)) :error)
8.1967- ((and warning (version<= warning version)) :warning)
8.1968- ((and style-warning (version<= style-warning version)) :style-warning)))
8.1969-
8.1970- (defmacro with-deprecation ((level) &body definitions)
8.1971- "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the
8.1972-DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function
8.1973-when it is compiled or called.
8.1974-
8.1975-Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet),
8.1976-:STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used),
8.1977-:ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while
8.1978-at that level).
8.1979-
8.1980-Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD
8.1981-from instrumentation by enclosing it in a PROGN."
8.1982- (let ((level (eval level)))
8.1983- (check-type level (member nil :style-warning :warning :error :delete))
8.1984- (when (eq level :delete)
8.1985- (error 'deprecated-function-should-be-deleted :name
8.1986- (mapcar 'second
8.1987- (remove-if-not #'(lambda (x) (member x '(defun defmethod)))
8.1988- definitions :key 'first))))
8.1989- (labels ((instrument (name head body whole)
8.1990- (if level
8.1991- (let ((notifiedp
8.1992- (intern (format nil "*~A-~A-~A-~A*"
8.1993- :deprecated-function level name :notified-p))))
8.1994- (multiple-value-bind (remaining-forms declarations doc-string)
8.1995- (parse-body body :documentation t :whole whole)
8.1996- `(progn
8.1997- (defparameter ,notifiedp nil)
8.1998- ;; tell some implementations to use the compiler-macro
8.1999- (declaim (inline ,name))
8.2000- (define-compiler-macro ,name (&whole form &rest args)
8.2001- (declare (ignore args))
8.2002- (notify-deprecated-function ,level ',name)
8.2003- form)
8.2004- (,@head ,@(when doc-string (list doc-string)) ,@declarations
8.2005- (unless ,notifiedp
8.2006- (setf ,notifiedp t)
8.2007- (notify-deprecated-function ,level ',name))
8.2008- ,@remaining-forms))))
8.2009- `(progn
8.2010- (eval-when (:compile-toplevel :load-toplevel :execute)
8.2011- (setf (compiler-macro-function ',name) nil))
8.2012- (declaim (notinline ,name))
8.2013- (,@head ,@body)))))
8.2014- `(progn
8.2015- ,@(loop :for form :in definitions :collect
8.2016- (cond
8.2017- ((and (consp form) (eq (car form) 'defun))
8.2018- (instrument (second form) (subseq form 0 3) (subseq form 3) form))
8.2019- ((and (consp form) (eq (car form) 'defmethod))
8.2020- (let ((body-start (if (listp (third form)) 3 4)))
8.2021- (instrument (second form)
8.2022- (subseq form 0 body-start)
8.2023- (subseq form body-start)
8.2024- form)))
8.2025- (t
8.2026- form))))))))
8.2027-;;;; ---------------------------------------------------------------------------
8.2028-;;;; Access to the Operating System
8.2029-
8.2030-(uiop/package:define-package :uiop/os
8.2031- (:use :uiop/common-lisp :uiop/package :uiop/utility)
8.2032- (:export
8.2033- #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features
8.2034- #:os-cond
8.2035- #:getenv #:getenvp ;; environment variables
8.2036- #:implementation-identifier ;; implementation identifier
8.2037- #:implementation-type #:*implementation-type*
8.2038- #:operating-system #:architecture #:lisp-version-string
8.2039- #:hostname #:getcwd #:chdir
8.2040- ;; Windows shortcut support
8.2041- #:read-null-terminated-string #:read-little-endian
8.2042- #:parse-file-location-info #:parse-windows-shortcut))
8.2043-(in-package :uiop/os)
8.2044-
8.2045-;;; Features
8.2046-(with-upgradability ()
8.2047- (defun featurep (x &optional (*features* *features*))
8.2048- "Checks whether a feature expression X is true with respect to the *FEATURES* set,
8.2049-as per the CLHS standard for #+ and #-. Beware that just like the CLHS,
8.2050-we assume symbols from the KEYWORD package are used, but that unless you're using #+/#-
8.2051-your reader will not have magically used the KEYWORD package, so you need specify
8.2052-keywords explicitly."
8.2053- (cond
8.2054- ((atom x) (and (member x *features*) t))
8.2055- ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
8.2056- ((eq :or (car x)) (some #'featurep (cdr x)))
8.2057- ((eq :and (car x)) (every #'featurep (cdr x)))
8.2058- (t (parameter-error "~S: malformed feature specification ~S" 'featurep x))))
8.2059-
8.2060- ;; Starting with UIOP 3.1.5, these are runtime tests.
8.2061- ;; You may bind *features* with a copy of what your target system offers to test its properties.
8.2062- (defun os-macosx-p ()
8.2063- "Is the underlying operating system MacOS X?"
8.2064- ;; OS-MACOSX is not mutually exclusive with OS-UNIX,
8.2065- ;; in fact the former implies the latter.
8.2066- (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos))))
8.2067-
8.2068- (defun os-unix-p ()
8.2069- "Is the underlying operating system some Unix variant?"
8.2070- (or (featurep '(:or :unix :cygwin :haiku)) (os-macosx-p)))
8.2071-
8.2072- (defun os-windows-p ()
8.2073- "Is the underlying operating system Microsoft Windows?"
8.2074- (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32 :mingw64))))
8.2075-
8.2076- (defun os-genera-p ()
8.2077- "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
8.2078- (featurep :genera))
8.2079-
8.2080- (defun os-oldmac-p ()
8.2081- "Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
8.2082- (featurep :mcl))
8.2083-
8.2084- (defun os-haiku-p ()
8.2085- "Is the underlying operating system Haiku?"
8.2086- (featurep :haiku))
8.2087-
8.2088- (defun os-mezzano-p ()
8.2089- "Is the underlying operating system Mezzano?"
8.2090- (featurep :mezzano))
8.2091-
8.2092- (defun detect-os ()
8.2093- "Detects the current operating system. Only needs be run at compile-time,
8.2094-except on ABCL where it might change between FASL compilation and runtime."
8.2095- (loop :with o
8.2096- :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
8.2097- (:os-windows . os-windows-p)
8.2098- (:os-genera . os-genera-p) (:os-oldmac . os-oldmac-p)
8.2099- (:os-haiku . os-haiku-p)
8.2100- (:os-mezzano . os-mezzano-p))
8.2101- :when (and (or (not o) (eq feature :os-macosx) (eq feature :os-haiku)) (funcall detect))
8.2102- :do (setf o feature) (pushnew feature *features*)
8.2103- :else :do (setf *features* (remove feature *features*))
8.2104- :finally
8.2105- (return (or o (error "Congratulations for trying ASDF on an operating system~%~
8.2106-that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
8.2107-
8.2108- (defmacro os-cond (&rest clauses)
8.2109- #+abcl `(cond ,@clauses)
8.2110- #-abcl (loop :for (test . body) :in clauses :when (eval test) :return `(progn ,@body)))
8.2111-
8.2112- (detect-os))
8.2113-
8.2114-;;;; Environment variables: getting them, and parsing them.
8.2115-(with-upgradability ()
8.2116- (defun getenv (x)
8.2117- "Query the environment, as in C getenv.
8.2118-Beware: may return empty string if a variable is present but empty;
8.2119-use getenvp to return NIL in such a case."
8.2120- (declare (ignorable x))
8.2121- #+(or abcl clasp clisp ecl xcl) (ext:getenv x)
8.2122- #+allegro (sys:getenv x)
8.2123- #+clozure (ccl:getenv x)
8.2124- #+cmucl (unix:unix-getenv x)
8.2125- #+scl (cdr (assoc x ext:*environment-list* :test #'string=))
8.2126- #+cormanlisp
8.2127- (let* ((buffer (ct:malloc 1))
8.2128- (cname (ct:lisp-string-to-c-string x))
8.2129- (needed-size (win:getenvironmentvariable cname buffer 0))
8.2130- (buffer1 (ct:malloc (1+ needed-size))))
8.2131- (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
8.2132- nil
8.2133- (ct:c-string-to-lisp-string buffer1))
8.2134- (ct:free buffer)
8.2135- (ct:free buffer1)))
8.2136- #+gcl (system:getenv x)
8.2137- #+(or genera mezzano) nil
8.2138- #+lispworks (lispworks:environment-variable x)
8.2139- #+mcl (ccl:with-cstrs ((name x))
8.2140- (let ((value (_getenv name)))
8.2141- (unless (ccl:%null-ptr-p value)
8.2142- (ccl:%get-cstring value))))
8.2143- #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
8.2144- #+sbcl (sb-ext:posix-getenv x)
8.2145- #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
8.2146- (not-implemented-error 'getenv))
8.2147-
8.2148- (defsetf getenv (x) (val)
8.2149- "Set an environment variable."
8.2150- (declare (ignorable x val))
8.2151- #+allegro `(setf (sys:getenv ,x) ,val)
8.2152- #+clasp `(ext:setenv ,x ,val)
8.2153- #+clisp `(system::setenv ,x ,val)
8.2154- #+clozure `(ccl:setenv ,x ,val)
8.2155- #+cmucl `(unix:unix-setenv ,x ,val 1)
8.2156- #+(or ecl clasp) `(ext:setenv ,x ,val)
8.2157- #+lispworks `(setf (lispworks:environment-variable ,x) ,val)
8.2158- #+mkcl `(mkcl:setenv ,x ,val)
8.2159- #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
8.2160- #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl)
8.2161- '(not-implemented-error '(setf getenv)))
8.2162-
8.2163- (defun getenvp (x)
8.2164- "Predicate that is true if the named variable is present in the libc environment,
8.2165-then returning the non-empty string value of the variable"
8.2166- (let ((g (getenv x))) (and (not (emptyp g)) g))))
8.2167-
8.2168-
8.2169-;;;; implementation-identifier
8.2170-;;
8.2171-;; produce a string to identify current implementation.
8.2172-;; Initially stolen from SLIME's SWANK, completely rewritten since.
8.2173-;; We're back to runtime checking, for the sake of e.g. ABCL.
8.2174-
8.2175-(with-upgradability ()
8.2176- (defun first-feature (feature-sets)
8.2177- "A helper for various feature detection functions"
8.2178- (dolist (x feature-sets)
8.2179- (multiple-value-bind (short long feature-expr)
8.2180- (if (consp x)
8.2181- (values (first x) (second x) (cons :or (rest x)))
8.2182- (values x x x))
8.2183- (when (featurep feature-expr)
8.2184- (return (values short long))))))
8.2185-
8.2186- (defun implementation-type ()
8.2187- "The type of Lisp implementation used, as a short UIOP-standardized keyword"
8.2188- (first-feature
8.2189- '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
8.2190- (:cmu :cmucl :cmu) :clasp :ecl :gcl
8.2191- (:lwpe :lispworks-personal-edition) (:lw :lispworks)
8.2192- :mcl :mezzano :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
8.2193-
8.2194- (defvar *implementation-type* (implementation-type)
8.2195- "The type of Lisp implementation used, as a short UIOP-standardized keyword")
8.2196-
8.2197- (defun operating-system ()
8.2198- "The operating system of the current host"
8.2199- (first-feature
8.2200- '(:cygwin
8.2201- (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
8.2202- (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
8.2203- (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
8.2204- (:solaris :solaris :sunos)
8.2205- (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly)
8.2206- :unix
8.2207- :genera
8.2208- :mezzano)))
8.2209-
8.2210- (defun architecture ()
8.2211- "The CPU architecture of the current host"
8.2212- (first-feature
8.2213- '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
8.2214- (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
8.2215- (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
8.2216- :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
8.2217- :mipsel :mipseb :mips :alpha
8.2218- (:arm64 :arm64 :aarch64 :armv8l :armv8b :aarch64_be :|aarch64|)
8.2219- (:arm :arm :arm-target) :vlm :imach
8.2220- ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
8.2221- ;; we may have to segregate the code still by architecture.
8.2222- (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
8.2223-
8.2224- #+clozure
8.2225- (defun ccl-fasl-version ()
8.2226- ;; the fasl version is target-dependent from CCL 1.8 on.
8.2227- (or (let ((s 'ccl::target-fasl-version))
8.2228- (and (fboundp s) (funcall s)))
8.2229- (and (boundp 'ccl::fasl-version)
8.2230- (symbol-value 'ccl::fasl-version))
8.2231- (error "Can't determine fasl version.")))
8.2232-
8.2233- (defun lisp-version-string ()
8.2234- "return a string that identifies the current Lisp implementation version"
8.2235- (let ((s (lisp-implementation-version)))
8.2236- (car ; as opposed to OR, this idiom prevents some unreachable code warning
8.2237- (list
8.2238- #+allegro
8.2239- (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
8.2240- excl::*common-lisp-version-number*
8.2241- ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
8.2242- (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
8.2243- ;; Note if not using International ACL
8.2244- ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
8.2245- (excl:ics-target-case (:-ics "8"))
8.2246- (and (member :smp *features*) "S"))
8.2247- #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
8.2248- #+clisp
8.2249- (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
8.2250- #+clozure
8.2251- (format nil "~d.~d-f~d" ; shorten for windows
8.2252- ccl::*openmcl-major-version*
8.2253- ccl::*openmcl-minor-version*
8.2254- (logand (ccl-fasl-version) #xFF))
8.2255- #+cmucl (substitute #\- #\/ s)
8.2256- #+scl (format nil "~A~A" s
8.2257- ;; ANSI upper case vs lower case.
8.2258- (ecase ext:*case-mode* (:upper "") (:lower "l")))
8.2259- #+ecl (format nil "~A~@[-~A~]" s
8.2260- (let ((vcs-id (ext:lisp-implementation-vcs-id)))
8.2261- (unless (equal vcs-id "UNKNOWN")
8.2262- (subseq vcs-id 0 (min (length vcs-id) 8)))))
8.2263- #+gcl (subseq s (1+ (position #\space s)))
8.2264- #+genera
8.2265- (multiple-value-bind (major minor) (sct:get-system-version "System")
8.2266- (format nil "~D.~D" major minor))
8.2267- #+mcl (subseq s 8) ; strip the leading "Version "
8.2268- #+mezzano (format nil "~A-~D"
8.2269- (subseq s 0 (position #\space s)) ; strip commit hash
8.2270- sys.int::*llf-version*)
8.2271- ;; seems like there should be a shorter way to do this, like ACALL.
8.2272- #+mkcl (or
8.2273- (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil)))
8.2274- (when (and fname (fboundp fname))
8.2275- (funcall fname)))
8.2276- s)
8.2277- s))))
8.2278-
8.2279- (defun implementation-identifier ()
8.2280- "Return a string that identifies the ABI of the current implementation,
8.2281-suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc."
8.2282- (substitute-if
8.2283- #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
8.2284- (format nil "~(~a~@{~@[-~a~]~}~)"
8.2285- (or (implementation-type) (lisp-implementation-type))
8.2286- (lisp-version-string)
8.2287- (or (operating-system) (software-type))
8.2288- (or (architecture) (machine-type))))))
8.2289-
8.2290-
8.2291-;;;; Other system information
8.2292-
8.2293-(with-upgradability ()
8.2294- (defun hostname ()
8.2295- "return the hostname of the current host"
8.2296- #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mezzano mkcl sbcl scl xcl) (machine-instance)
8.2297- #+cormanlisp "localhost" ;; is there a better way? Does it matter?
8.2298- #+allegro (symbol-call :excl.osi :gethostname)
8.2299- #+clisp (first (split-string (machine-instance) :separator " "))
8.2300- #+gcl (system:gethostname)))
8.2301-
8.2302-
8.2303-;;; Current directory
8.2304-(with-upgradability ()
8.2305-
8.2306- #+cmucl
8.2307- (defun parse-unix-namestring* (unix-namestring)
8.2308- "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
8.2309- (multiple-value-bind (host device directory name type version)
8.2310- (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
8.2311- (make-pathname :host (or host lisp::*unix-host*) :device device
8.2312- :directory directory :name name :type type :version version)))
8.2313-
8.2314- (defun getcwd ()
8.2315- "Get the current working directory as per POSIX getcwd(3), as a pathname object"
8.2316- (or #+(or abcl genera mezzano xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
8.2317- #+allegro (excl::current-directory)
8.2318- #+clisp (ext:default-directory)
8.2319- #+clozure (ccl:current-directory)
8.2320- #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring
8.2321- (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
8.2322- #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
8.2323- #+(or clasp ecl) (ext:getcwd)
8.2324- #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
8.2325- #+lispworks (hcl:get-working-directory)
8.2326- #+mkcl (mk-ext:getcwd)
8.2327- #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
8.2328- #+xcl (extensions:current-directory)
8.2329- (not-implemented-error 'getcwd)))
8.2330-
8.2331- (defun chdir (x)
8.2332- "Change current directory, as per POSIX chdir(2), to a given pathname object"
8.2333- (if-let (x (pathname x))
8.2334- #+(or abcl genera mezzano xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
8.2335- #+allegro (excl:chdir x)
8.2336- #+clisp (ext:cd x)
8.2337- #+clozure (setf (ccl:current-directory) x)
8.2338- #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x))
8.2339- #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
8.2340- (error "Could not set current directory to ~A" x))
8.2341- #+ecl (ext:chdir x)
8.2342- #+clasp (ext:chdir x t)
8.2343- #+gcl (system:chdir x)
8.2344- #+lispworks (hcl:change-directory x)
8.2345- #+mkcl (mk-ext:chdir x)
8.2346- #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
8.2347- #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
8.2348- (not-implemented-error 'chdir))))
8.2349-
8.2350-
8.2351-;;;; -----------------------------------------------------------------
8.2352-;;;; Windows shortcut support. Based on:
8.2353-;;;;
8.2354-;;;; Jesse Hager: The Windows Shortcut File Format.
8.2355-;;;; http://www.wotsit.org/list.asp?fc=13
8.2356-
8.2357-#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
8.2358-(with-upgradability ()
8.2359- (defparameter *link-initial-dword* 76)
8.2360- (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
8.2361-
8.2362- (defun read-null-terminated-string (s)
8.2363- "Read a null-terminated string from an octet stream S"
8.2364- ;; note: doesn't play well with UNICODE
8.2365- (with-output-to-string (out)
8.2366- (loop :for code = (read-byte s)
8.2367- :until (zerop code)
8.2368- :do (write-char (code-char code) out))))
8.2369-
8.2370- (defun read-little-endian (s &optional (bytes 4))
8.2371- "Read a number in little-endian format from an byte (octet) stream S,
8.2372-the number having BYTES octets (defaulting to 4)."
8.2373- (loop :for i :from 0 :below bytes
8.2374- :sum (ash (read-byte s) (* 8 i))))
8.2375-
8.2376- (defun parse-file-location-info (s)
8.2377- "helper to parse-windows-shortcut"
8.2378- (let ((start (file-position s))
8.2379- (total-length (read-little-endian s))
8.2380- (end-of-header (read-little-endian s))
8.2381- (fli-flags (read-little-endian s))
8.2382- (local-volume-offset (read-little-endian s))
8.2383- (local-offset (read-little-endian s))
8.2384- (network-volume-offset (read-little-endian s))
8.2385- (remaining-offset (read-little-endian s)))
8.2386- (declare (ignore total-length end-of-header local-volume-offset))
8.2387- (unless (zerop fli-flags)
8.2388- (cond
8.2389- ((logbitp 0 fli-flags)
8.2390- (file-position s (+ start local-offset)))
8.2391- ((logbitp 1 fli-flags)
8.2392- (file-position s (+ start
8.2393- network-volume-offset
8.2394- #x14))))
8.2395- (strcat (read-null-terminated-string s)
8.2396- (progn
8.2397- (file-position s (+ start remaining-offset))
8.2398- (read-null-terminated-string s))))))
8.2399-
8.2400- (defun parse-windows-shortcut (pathname)
8.2401- "From a .lnk windows shortcut, extract the pathname linked to"
8.2402- ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE.
8.2403- (with-open-file (s pathname :element-type '(unsigned-byte 8))
8.2404- (handler-case
8.2405- (when (and (= (read-little-endian s) *link-initial-dword*)
8.2406- (let ((header (make-array (length *link-guid*))))
8.2407- (read-sequence header s)
8.2408- (equalp header *link-guid*)))
8.2409- (let ((flags (read-little-endian s)))
8.2410- (file-position s 76) ;skip rest of header
8.2411- (when (logbitp 0 flags)
8.2412- ;; skip shell item id list
8.2413- (let ((length (read-little-endian s 2)))
8.2414- (file-position s (+ length (file-position s)))))
8.2415- (cond
8.2416- ((logbitp 1 flags)
8.2417- (parse-file-location-info s))
8.2418- (t
8.2419- (when (logbitp 2 flags)
8.2420- ;; skip description string
8.2421- (let ((length (read-little-endian s 2)))
8.2422- (file-position s (+ length (file-position s)))))
8.2423- (when (logbitp 3 flags)
8.2424- ;; finally, our pathname
8.2425- (let* ((length (read-little-endian s 2))
8.2426- (buffer (make-array length)))
8.2427- (read-sequence buffer s)
8.2428- (map 'string #'code-char buffer)))))))
8.2429- (end-of-file (c)
8.2430- (declare (ignore c))
8.2431- nil)))))
8.2432-
8.2433-
8.2434-;;;; -------------------------------------------------------------------------
8.2435-;;;; Portability layer around Common Lisp pathnames
8.2436-;; This layer allows for portable manipulation of pathname objects themselves,
8.2437-;; which all is necessary prior to any access the filesystem or environment.
8.2438-
8.2439-(uiop/package:define-package :uiop/pathname
8.2440- (:nicknames :asdf/pathname) ;; deprecated. Used by ceramic
8.2441- (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os)
8.2442- (:export
8.2443- ;; Making and merging pathnames, portably
8.2444- #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
8.2445- #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname*
8.2446- #:make-pathname-component-logical #:make-pathname-logical
8.2447- #:merge-pathnames*
8.2448- #:nil-pathname #:*nil-pathname* #:with-pathname-defaults
8.2449- ;; Predicates
8.2450- #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname
8.2451- #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
8.2452- ;; Directories
8.2453- #:pathname-directory-pathname #:pathname-parent-directory-pathname
8.2454- #:directory-pathname-p #:ensure-directory-pathname
8.2455- ;; Parsing filenames
8.2456- #:split-name-type #:parse-unix-namestring #:unix-namestring
8.2457- #:split-unix-namestring-directory-components
8.2458- ;; Absolute and relative pathnames
8.2459- #:subpathname #:subpathname*
8.2460- #:ensure-absolute-pathname
8.2461- #:pathname-root #:pathname-host-pathname
8.2462- #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname
8.2463- ;; Checking constraints
8.2464- #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
8.2465- ;; Wildcard pathnames
8.2466- #:*wild* #:*wild-file* #:*wild-file-for-directory* #:*wild-directory*
8.2467- #:*wild-inferiors* #:*wild-path* #:wilden
8.2468- ;; Translate a pathname
8.2469- #:relativize-directory-component #:relativize-pathname-directory
8.2470- #:directory-separator-for-host #:directorize-pathname-host-device
8.2471- #:translate-pathname*
8.2472- #:*output-translation-function*))
8.2473-(in-package :uiop/pathname)
8.2474-
8.2475-;;; Normalizing pathnames across implementations
8.2476-
8.2477-(with-upgradability ()
8.2478- (defun normalize-pathname-directory-component (directory)
8.2479- "Convert the DIRECTORY component from a format usable by the underlying
8.2480-implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
8.2481-that is a list and not a string."
8.2482- (cond
8.2483- #-(or cmucl sbcl scl) ;; these implementations already normalize directory components.
8.2484- ((stringp directory) `(:absolute ,directory))
8.2485- ((or (null directory)
8.2486- (and (consp directory) (member (first directory) '(:absolute :relative))))
8.2487- directory)
8.2488- #+gcl
8.2489- ((consp directory)
8.2490- (cons :relative directory))
8.2491- (t
8.2492- (parameter-error (compatfmt "~@<~S: Unrecognized pathname directory component ~S~@:>")
8.2493- 'normalize-pathname-directory-component directory))))
8.2494-
8.2495- (defun denormalize-pathname-directory-component (directory-component)
8.2496- "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
8.2497-by the underlying implementation's MAKE-PATHNAME and other primitives"
8.2498- directory-component)
8.2499-
8.2500- (defun merge-pathname-directory-components (specified defaults)
8.2501- "Helper for MERGE-PATHNAMES* that handles directory components"
8.2502- (let ((directory (normalize-pathname-directory-component specified)))
8.2503- (ecase (first directory)
8.2504- ((nil) defaults)
8.2505- (:absolute specified)
8.2506- (:relative
8.2507- (let ((defdir (normalize-pathname-directory-component defaults))
8.2508- (reldir (cdr directory)))
8.2509- (cond
8.2510- ((null defdir)
8.2511- directory)
8.2512- ((not (eq :back (first reldir)))
8.2513- (append defdir reldir))
8.2514- (t
8.2515- (loop :with defabs = (first defdir)
8.2516- :with defrev = (reverse (rest defdir))
8.2517- :while (and (eq :back (car reldir))
8.2518- (or (and (eq :absolute defabs) (null defrev))
8.2519- (stringp (car defrev))))
8.2520- :do (pop reldir) (pop defrev)
8.2521- :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
8.2522-
8.2523- ;; Giving :unspecific as :type argument to make-pathname is not portable.
8.2524- ;; See CLHS make-pathname and 19.2.2.2.3.
8.2525- ;; This will be :unspecific if supported, or NIL if not.
8.2526- (defparameter *unspecific-pathname-type*
8.2527- #+(or abcl allegro clozure cmucl lispworks sbcl scl) :unspecific
8.2528- #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil
8.2529- "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
8.2530-
8.2531- (defun make-pathname* (&rest keys &key directory host device name type version defaults
8.2532- #+scl &allow-other-keys)
8.2533- "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
8.2534- tries hard to make a pathname that will actually behave as documented,
8.2535- despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME."
8.2536- (declare (ignore host device directory name type version defaults))
8.2537- (apply 'make-pathname keys))
8.2538-
8.2539- (defun make-pathname-component-logical (x)
8.2540- "Make a pathname component suitable for use in a logical-pathname"
8.2541- (typecase x
8.2542- ((eql :unspecific) nil)
8.2543- #+clisp (string (string-upcase x))
8.2544- #+clisp (cons (mapcar 'make-pathname-component-logical x))
8.2545- (t x)))
8.2546-
8.2547- (defun make-pathname-logical (pathname host)
8.2548- "Take a PATHNAME's directory, name, type and version components,
8.2549-and make a new pathname with corresponding components and specified logical HOST"
8.2550- (make-pathname
8.2551- :host host
8.2552- :directory (make-pathname-component-logical (pathname-directory pathname))
8.2553- :name (make-pathname-component-logical (pathname-name pathname))
8.2554- :type (make-pathname-component-logical (pathname-type pathname))
8.2555- :version (make-pathname-component-logical (pathname-version pathname))))
8.2556-
8.2557- (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
8.2558- "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
8.2559-if the SPECIFIED pathname does not have an absolute directory,
8.2560-then the HOST and DEVICE both come from the DEFAULTS, whereas
8.2561-if the SPECIFIED pathname does have an absolute directory,
8.2562-then the HOST and DEVICE both come from the SPECIFIED pathname.
8.2563-This is what users want on a modern Unix or Windows operating system,
8.2564-unlike the MERGE-PATHNAMES behavior.
8.2565-Also, if either argument is NIL, then the other argument is returned unmodified;
8.2566-this is unlike MERGE-PATHNAMES which always merges with a pathname,
8.2567-by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
8.2568- (when (null specified) (return-from merge-pathnames* defaults))
8.2569- (when (null defaults) (return-from merge-pathnames* specified))
8.2570- #+scl
8.2571- (ext:resolve-pathname specified defaults)
8.2572- #-scl
8.2573- (let* ((specified (pathname specified))
8.2574- (defaults (pathname defaults))
8.2575- (directory (normalize-pathname-directory-component (pathname-directory specified)))
8.2576- (name (or (pathname-name specified) (pathname-name defaults)))
8.2577- (type (or (pathname-type specified) (pathname-type defaults)))
8.2578- (version (or (pathname-version specified) (pathname-version defaults))))
8.2579- (labels ((unspecific-handler (p)
8.2580- (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
8.2581- (multiple-value-bind (host device directory unspecific-handler)
8.2582- (ecase (first directory)
8.2583- ((:absolute)
8.2584- (values (pathname-host specified)
8.2585- (pathname-device specified)
8.2586- directory
8.2587- (unspecific-handler specified)))
8.2588- ((nil :relative)
8.2589- (values (pathname-host defaults)
8.2590- (pathname-device defaults)
8.2591- (merge-pathname-directory-components directory (pathname-directory defaults))
8.2592- (unspecific-handler defaults))))
8.2593- (make-pathname :host host :device device :directory directory
8.2594- :name (funcall unspecific-handler name)
8.2595- :type (funcall unspecific-handler type)
8.2596- :version (funcall unspecific-handler version))))))
8.2597-
8.2598- (defun logical-pathname-p (x)
8.2599- "is X a logical-pathname?"
8.2600- (typep x 'logical-pathname))
8.2601-
8.2602- (defun physical-pathname-p (x)
8.2603- "is X a pathname that is not a logical-pathname?"
8.2604- (and (pathnamep x) (not (logical-pathname-p x))))
8.2605-
8.2606- (defun physicalize-pathname (x)
8.2607- "if X is a logical pathname, use translate-logical-pathname on it."
8.2608- ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP
8.2609- (let ((p (when x (pathname x))))
8.2610- (if (logical-pathname-p p) (translate-logical-pathname p) p)))
8.2611-
8.2612- (defun nil-pathname (&optional (defaults *default-pathname-defaults*))
8.2613- "A pathname that is as neutral as possible for use as defaults
8.2614-when merging, making or parsing pathnames"
8.2615- ;; 19.2.2.2.1 says a NIL host can mean a default host;
8.2616- ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
8.2617- ;; strings and lists of strings or :unspecific
8.2618- ;; But CMUCL decides to die on NIL.
8.2619- ;; MCL has issues with make-pathname, nil and defaulting
8.2620- (declare (ignorable defaults))
8.2621- #.`(make-pathname :directory nil :name nil :type nil :version nil
8.2622- :device (or #+(and mkcl os-unix) :unspecific)
8.2623- :host (or #+cmucl lisp::*unix-host* #+(and mkcl os-unix) "localhost")
8.2624- #+scl ,@'(:scheme nil :scheme-specific-part nil
8.2625- :username nil :password nil :parameters nil :query nil :fragment nil)
8.2626- ;; the default shouldn't matter, but we really want something physical
8.2627- #-mcl ,@'(:defaults defaults)))
8.2628-
8.2629- (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname)))
8.2630- "A pathname that is as neutral as possible for use as defaults
8.2631-when merging, making or parsing pathnames")
8.2632-
8.2633- (defmacro with-pathname-defaults ((&optional defaults) &body body)
8.2634- "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified,
8.2635-where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except
8.2636-on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory."
8.2637- `(let ((*default-pathname-defaults*
8.2638- ,(or defaults
8.2639- #-(or abcl genera xcl) '*nil-pathname*
8.2640- #+(or abcl genera xcl) '*default-pathname-defaults*)))
8.2641- ,@body)))
8.2642-
8.2643-
8.2644-;;; Some pathname predicates
8.2645-(with-upgradability ()
8.2646- (defun pathname-equal (p1 p2)
8.2647- "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?"
8.2648- (when (stringp p1) (setf p1 (pathname p1)))
8.2649- (when (stringp p2) (setf p2 (pathname p2)))
8.2650- (flet ((normalize-component (x)
8.2651- (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
8.2652- x)))
8.2653- (macrolet ((=? (&rest accessors)
8.2654- (flet ((frob (x)
8.2655- (reduce 'list (cons 'normalize-component accessors)
8.2656- :initial-value x :from-end t)))
8.2657- `(equal ,(frob 'p1) ,(frob 'p2)))))
8.2658- (or (and (null p1) (null p2))
8.2659- (and (pathnamep p1) (pathnamep p2)
8.2660- (and (=? pathname-host)
8.2661- #-(and mkcl os-unix) (=? pathname-device)
8.2662- (=? normalize-pathname-directory-component pathname-directory)
8.2663- (=? pathname-name)
8.2664- (=? pathname-type)
8.2665- #-mkcl (=? pathname-version)))))))
8.2666-
8.2667- (defun absolute-pathname-p (pathspec)
8.2668- "If PATHSPEC is a pathname or namestring object that parses as a pathname
8.2669-possessing an :ABSOLUTE directory component, return the (parsed) pathname.
8.2670-Otherwise return NIL"
8.2671- (and pathspec
8.2672- (typep pathspec '(or null pathname string))
8.2673- (let ((pathname (pathname pathspec)))
8.2674- (and (eq :absolute (car (normalize-pathname-directory-component
8.2675- (pathname-directory pathname))))
8.2676- pathname))))
8.2677-
8.2678- (defun relative-pathname-p (pathspec)
8.2679- "If PATHSPEC is a pathname or namestring object that parses as a pathname
8.2680-possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
8.2681-Otherwise return NIL"
8.2682- (and pathspec
8.2683- (typep pathspec '(or null pathname string))
8.2684- (let* ((pathname (pathname pathspec))
8.2685- (directory (normalize-pathname-directory-component
8.2686- (pathname-directory pathname))))
8.2687- (when (or (null directory) (eq :relative (car directory)))
8.2688- pathname))))
8.2689-
8.2690- (defun hidden-pathname-p (pathname)
8.2691- "Return a boolean that is true if the pathname is hidden as per Unix style,
8.2692-i.e. its name starts with a dot."
8.2693- (and pathname (equal (first-char (pathname-name pathname)) #\.)))
8.2694-
8.2695- (defun file-pathname-p (pathname)
8.2696- "Does PATHNAME represent a file, i.e. has a non-null NAME component?
8.2697-
8.2698-Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
8.2699-
8.2700-Note that this does _not_ check to see that PATHNAME points to an
8.2701-actually-existing file.
8.2702-
8.2703-Returns the (parsed) PATHNAME when true"
8.2704- (when pathname
8.2705- (let ((pathname (pathname pathname)))
8.2706- (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal)
8.2707- (member (pathname-type pathname) '(nil :unspecific "") :test 'equal))
8.2708- pathname)))))
8.2709-
8.2710-
8.2711-;;; Directory pathnames
8.2712-(with-upgradability ()
8.2713- (defun pathname-directory-pathname (pathname)
8.2714- "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
8.2715-and NIL NAME, TYPE and VERSION components"
8.2716- (when pathname
8.2717- (make-pathname :name nil :type nil :version nil :defaults pathname)))
8.2718-
8.2719- (defun pathname-parent-directory-pathname (pathname)
8.2720- "Returns a new pathname that corresponds to the parent of the current pathname's directory,
8.2721-i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
8.2722-Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
8.2723- (when pathname
8.2724- (make-pathname :name nil :type nil :version nil
8.2725- :directory (merge-pathname-directory-components
8.2726- '(:relative :back) (pathname-directory pathname))
8.2727- :defaults pathname)))
8.2728-
8.2729- (defun directory-pathname-p (pathname)
8.2730- "Does PATHNAME represent a directory?
8.2731-
8.2732-A directory-pathname is a pathname _without_ a filename. The three
8.2733-ways that the filename components can be missing are for it to be NIL,
8.2734-:UNSPECIFIC or the empty string.
8.2735-
8.2736-Note that this does _not_ check to see that PATHNAME points to an
8.2737-actually-existing directory."
8.2738- (when pathname
8.2739- ;; I tried using Allegro's excl:file-directory-p, but this cannot be done,
8.2740- ;; because it rejects apparently legal pathnames as
8.2741- ;; ill-formed. [2014/02/10:rpg]
8.2742- (let ((pathname (pathname pathname)))
8.2743- (flet ((check-one (x)
8.2744- (member x '(nil :unspecific) :test 'equal)))
8.2745- (and (not (wild-pathname-p pathname))
8.2746- (check-one (pathname-name pathname))
8.2747- (check-one (pathname-type pathname))
8.2748- t)))))
8.2749-
8.2750- (defun ensure-directory-pathname (pathspec &optional (on-error 'error))
8.2751- "Converts the non-wild pathname designator PATHSPEC to directory form."
8.2752- (cond
8.2753- ((stringp pathspec)
8.2754- (ensure-directory-pathname (pathname pathspec)))
8.2755- ((not (pathnamep pathspec))
8.2756- (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
8.2757- ((wild-pathname-p pathspec)
8.2758- (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
8.2759- ((directory-pathname-p pathspec)
8.2760- pathspec)
8.2761- (t
8.2762- (handler-case
8.2763- (make-pathname :directory (append (or (normalize-pathname-directory-component
8.2764- (pathname-directory pathspec))
8.2765- (list :relative))
8.2766- (list #-genera (file-namestring pathspec)
8.2767- ;; On Genera's native filesystem (LMFS),
8.2768- ;; directories have a type and version
8.2769- ;; which must be ignored when converting
8.2770- ;; to a directory pathname
8.2771- #+genera (if (typep pathspec 'fs:lmfs-pathname)
8.2772- (pathname-name pathspec)
8.2773- (file-namestring pathspec))))
8.2774- :name nil :type nil :version nil :defaults pathspec)
8.2775- (error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c)))))))
8.2776-
8.2777-
8.2778-;;; Parsing filenames
8.2779-(with-upgradability ()
8.2780- (declaim (ftype function ensure-pathname)) ; forward reference
8.2781-
8.2782- (defun split-unix-namestring-directory-components
8.2783- (unix-namestring &key ensure-directory dot-dot)
8.2784- "Splits the path string UNIX-NAMESTRING, returning four values:
8.2785-A flag that is either :absolute or :relative, indicating
8.2786- how the rest of the values are to be interpreted.
8.2787-A directory path --- a list of strings and keywords, suitable for
8.2788- use with MAKE-PATHNAME when prepended with the flag value.
8.2789- Directory components with an empty name or the name . are removed.
8.2790- Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
8.2791-A last-component, either a file-namestring including type extension,
8.2792- or NIL in the case of a directory pathname.
8.2793-A flag that is true iff the unix-style-pathname was just
8.2794- a file-namestring without / path specification.
8.2795-ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
8.2796-the third return value will be NIL, and final component of the namestring
8.2797-will be treated as part of the directory path.
8.2798-
8.2799-An empty string is thus read as meaning a pathname object with all fields nil.
8.2800-
8.2801-Note that colon characters #\: will NOT be interpreted as host specification.
8.2802-Absolute pathnames are only appropriate on Unix-style systems.
8.2803-
8.2804-The intention of this function is to support structured component names,
8.2805-e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
8.2806- (check-type unix-namestring string)
8.2807- (check-type dot-dot (member nil :back :up))
8.2808- (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
8.2809- (plusp (length unix-namestring)))
8.2810- (values :relative () unix-namestring t)
8.2811- (let* ((components (split-string unix-namestring :separator "/"))
8.2812- (last-comp (car (last components))))
8.2813- (multiple-value-bind (relative components)
8.2814- (if (equal (first components) "")
8.2815- (if (equal (first-char unix-namestring) #\/)
8.2816- (values :absolute (cdr components))
8.2817- (values :relative nil))
8.2818- (values :relative components))
8.2819- (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
8.2820- components))
8.2821- (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
8.2822- (cond
8.2823- ((equal last-comp "")
8.2824- (values relative components nil nil)) ; "" already removed from components
8.2825- (ensure-directory
8.2826- (values relative components nil nil))
8.2827- (t
8.2828- (values relative (butlast components) last-comp nil)))))))
8.2829-
8.2830- (defun split-name-type (filename)
8.2831- "Split a filename into two values NAME and TYPE that are returned.
8.2832-We assume filename has no directory component.
8.2833-The last . if any separates name and type from from type,
8.2834-except that if there is only one . and it is in first position,
8.2835-the whole filename is the NAME with an empty type.
8.2836-NAME is always a string.
8.2837-For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
8.2838- (check-type filename string)
8.2839- (assert (plusp (length filename)))
8.2840- (destructuring-bind (name &optional (type *unspecific-pathname-type*))
8.2841- (split-string filename :max 2 :separator ".")
8.2842- (if (equal name "")
8.2843- (values filename *unspecific-pathname-type*)
8.2844- (values name type))))
8.2845-
8.2846- (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
8.2847- &allow-other-keys)
8.2848- "Coerce NAME into a PATHNAME using standard Unix syntax.
8.2849-
8.2850-Unix syntax is used whether or not the underlying system is Unix;
8.2851-on such non-Unix systems it is reliably usable only for relative pathnames.
8.2852-This function is especially useful to manipulate relative pathnames portably,
8.2853-where it is crucial to possess a portable pathname syntax independent of the underlying OS.
8.2854-This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
8.2855-
8.2856-When given a PATHNAME object, just return it untouched.
8.2857-When given NIL, just return NIL.
8.2858-When given a non-null SYMBOL, first downcase its name and treat it as a string.
8.2859-When given a STRING, portably decompose it into a pathname as below.
8.2860-
8.2861-#\\/ separates directory components.
8.2862-
8.2863-The last #\\/-separated substring is interpreted as follows:
8.2864-1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
8.2865- the string is made the last directory component, and NAME and TYPE are NIL.
8.2866- if the string is empty, it's the empty pathname with all slots NIL.
8.2867-2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE
8.2868- are separated by SPLIT-NAME-TYPE.
8.2869-3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
8.2870-
8.2871-Directory components with an empty name or the name \".\" are removed.
8.2872-Any directory named \"..\" is read as DOT-DOT,
8.2873-which must be one of :BACK or :UP and defaults to :BACK.
8.2874-
8.2875-HOST, DEVICE and VERSION components are taken from DEFAULTS,
8.2876-which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL.
8.2877-No host or device can be specified in the string itself,
8.2878-which makes it unsuitable for absolute pathnames outside Unix.
8.2879-
8.2880-For relative pathnames, these components (and hence the defaults) won't matter
8.2881-if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
8.2882-which is an important reason to always use MERGE-PATHNAMES*.
8.2883-
8.2884-Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
8.2885-with those keys, removing TYPE DEFAULTS and DOT-DOT.
8.2886-When you're manipulating pathnames that are supposed to make sense portably
8.2887-even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
8.2888-to throw an error if the pathname is absolute"
8.2889- (block nil
8.2890- (check-type type (or null string (eql :directory)))
8.2891- (when ensure-directory
8.2892- (setf type :directory))
8.2893- (etypecase name
8.2894- ((or null pathname) (return name))
8.2895- (symbol
8.2896- (setf name (string-downcase name)))
8.2897- (string))
8.2898- (multiple-value-bind (relative path filename file-only)
8.2899- (split-unix-namestring-directory-components
8.2900- name :dot-dot dot-dot :ensure-directory (eq type :directory))
8.2901- (multiple-value-bind (name type)
8.2902- (cond
8.2903- ((or (eq type :directory) (null filename))
8.2904- (values nil nil))
8.2905- (type
8.2906- (values filename type))
8.2907- (t
8.2908- (split-name-type filename)))
8.2909- (let* ((directory
8.2910- (unless file-only (cons relative path)))
8.2911- (pathname
8.2912- #-abcl
8.2913- (make-pathname
8.2914- :directory directory
8.2915- :name name :type type
8.2916- :defaults (or #-mcl defaults *nil-pathname*))
8.2917- #+abcl
8.2918- (if (and defaults
8.2919- (ext:pathname-jar-p defaults)
8.2920- (null directory))
8.2921- ;; When DEFAULTS is a jar, it will have the directory we want
8.2922- (make-pathname :name name :type type
8.2923- :defaults (or defaults *nil-pathname*))
8.2924- (make-pathname :name name :type type
8.2925- :defaults (or defaults *nil-pathname*)
8.2926- :directory directory))))
8.2927- (apply 'ensure-pathname
8.2928- pathname
8.2929- (remove-plist-keys '(:type :dot-dot :defaults) keys)))))))
8.2930-
8.2931- (defun unix-namestring (pathname)
8.2932- "Given a non-wild PATHNAME, return a Unix-style namestring for it.
8.2933-If the PATHNAME is NIL or a STRING, return it unchanged.
8.2934-
8.2935-This only considers the DIRECTORY, NAME and TYPE components of the pathname.
8.2936-This is a portable solution for representing relative pathnames,
8.2937-But unless you are running on a Unix system, it is not a general solution
8.2938-to representing native pathnames.
8.2939-
8.2940-An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
8.2941-or if it is a PATHNAME but some of its components are not recognized."
8.2942- (etypecase pathname
8.2943- ((or null string) pathname)
8.2944- (pathname
8.2945- (with-output-to-string (s)
8.2946- (flet ((err () (parameter-error "~S: invalid unix-namestring ~S"
8.2947- 'unix-namestring pathname)))
8.2948- (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
8.2949- (name (pathname-name pathname))
8.2950- (name (and (not (eq name :unspecific)) name))
8.2951- (type (pathname-type pathname))
8.2952- (type (and (not (eq type :unspecific)) type)))
8.2953- (cond
8.2954- ((member dir '(nil :unspecific)))
8.2955- ((eq dir '(:relative)) (princ "./" s))
8.2956- ((consp dir)
8.2957- (destructuring-bind (relabs &rest dirs) dir
8.2958- (or (member relabs '(:relative :absolute)) (err))
8.2959- (when (eq relabs :absolute) (princ #\/ s))
8.2960- (loop :for x :in dirs :do
8.2961- (cond
8.2962- ((member x '(:back :up)) (princ "../" s))
8.2963- ((equal x "") (err))
8.2964- ;;((member x '("." "..") :test 'equal) (err))
8.2965- ((stringp x) (format s "~A/" x))
8.2966- (t (err))))))
8.2967- (t (err)))
8.2968- (cond
8.2969- (name
8.2970- (unless (and (stringp name) (or (null type) (stringp type))) (err))
8.2971- (format s "~A~@[.~A~]" name type))
8.2972- (t
8.2973- (or (null type) (err)))))))))))
8.2974-
8.2975-;;; Absolute and relative pathnames
8.2976-(with-upgradability ()
8.2977- (defun subpathname (pathname subpath &key type)
8.2978- "This function takes a PATHNAME and a SUBPATH and a TYPE.
8.2979-If SUBPATH is already a PATHNAME object (not namestring),
8.2980-and is an absolute pathname at that, it is returned unchanged;
8.2981-otherwise, SUBPATH is turned into a relative pathname with given TYPE
8.2982-as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
8.2983-then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
8.2984- (or (and (pathnamep subpath) (absolute-pathname-p subpath))
8.2985- (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
8.2986- (pathname-directory-pathname pathname))))
8.2987-
8.2988- (defun subpathname* (pathname subpath &key type)
8.2989- "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
8.2990- (and pathname
8.2991- (subpathname (ensure-directory-pathname pathname) subpath :type type)))
8.2992-
8.2993- (defun pathname-root (pathname)
8.2994- "return the root directory for the host and device of given PATHNAME"
8.2995- (make-pathname :directory '(:absolute)
8.2996- :name nil :type nil :version nil
8.2997- :defaults pathname ;; host device, and on scl, *some*
8.2998- ;; scheme-specific parts: port username password, not others:
8.2999- . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
8.3000-
8.3001- (defun pathname-host-pathname (pathname)
8.3002- "return a pathname with the same host as given PATHNAME, and all other fields NIL"
8.3003- (make-pathname :directory nil
8.3004- :name nil :type nil :version nil :device nil
8.3005- :defaults pathname ;; host device, and on scl, *some*
8.3006- ;; scheme-specific parts: port username password, not others:
8.3007- . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
8.3008-
8.3009- (defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
8.3010- "Given a pathname designator PATH, return an absolute pathname as specified by PATH
8.3011-considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,
8.3012-with a format control-string and other arguments as arguments"
8.3013- (cond
8.3014- ((absolute-pathname-p path))
8.3015- ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
8.3016- ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
8.3017- ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
8.3018- (or (if (absolute-pathname-p default-pathname)
8.3019- (absolute-pathname-p (merge-pathnames* path default-pathname))
8.3020- (call-function on-error "Default pathname ~S is not an absolute pathname"
8.3021- default-pathname))
8.3022- (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
8.3023- path default-pathname))))
8.3024- (t (call-function on-error
8.3025- "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
8.3026- path defaults))))
8.3027-
8.3028- (defun subpathp (maybe-subpath base-pathname)
8.3029- "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
8.3030-when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
8.3031- (and (pathnamep maybe-subpath) (pathnamep base-pathname)
8.3032- (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
8.3033- (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
8.3034- (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
8.3035- (with-pathname-defaults (*nil-pathname*)
8.3036- (let ((enough (enough-namestring maybe-subpath base-pathname)))
8.3037- (and (relative-pathname-p enough) (pathname enough))))))
8.3038-
8.3039- (defun enough-pathname (maybe-subpath base-pathname)
8.3040- "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
8.3041-when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
8.3042- (let ((sub (when maybe-subpath (pathname maybe-subpath)))
8.3043- (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
8.3044- (or (and base (subpathp sub base)) sub)))
8.3045-
8.3046- (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk)
8.3047- "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null,
8.3048-or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH
8.3049-given DEFAULTS-PATHNAME as a base pathname."
8.3050- (let ((enough (enough-pathname maybe-subpath defaults-pathname))
8.3051- (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*)))
8.3052- (funcall thunk enough)))
8.3053-
8.3054- (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var)
8.3055- (defaults *default-pathname-defaults*))
8.3056- &body body)
8.3057- "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME"
8.3058- `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body))))
8.3059-
8.3060-
8.3061-;;; Wildcard pathnames
8.3062-(with-upgradability ()
8.3063- (defparameter *wild* (or #+cormanlisp "*" :wild)
8.3064- "Wild component for use with MAKE-PATHNAME")
8.3065- (defparameter *wild-directory-component* (or :wild)
8.3066- "Wild directory component for use with MAKE-PATHNAME")
8.3067- (defparameter *wild-inferiors-component* (or :wild-inferiors)
8.3068- "Wild-inferiors directory component for use with MAKE-PATHNAME")
8.3069- (defparameter *wild-file*
8.3070- (make-pathname :directory nil :name *wild* :type *wild*
8.3071- :version (or #-(or allegro abcl xcl) *wild*))
8.3072- "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME")
8.3073- (defparameter *wild-file-for-directory*
8.3074- (make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl) *wild*)
8.3075- :version (or #-(or allegro abcl clisp gcl xcl) *wild*))
8.3076- "A pathname object with wildcards for matching any file with DIRECTORY")
8.3077- (defparameter *wild-directory*
8.3078- (make-pathname :directory `(:relative ,*wild-directory-component*)
8.3079- :name nil :type nil :version nil)
8.3080- "A pathname object with wildcards for matching any subdirectory")
8.3081- (defparameter *wild-inferiors*
8.3082- (make-pathname :directory `(:relative ,*wild-inferiors-component*)
8.3083- :name nil :type nil :version nil)
8.3084- "A pathname object with wildcards for matching any recursive subdirectory")
8.3085- (defparameter *wild-path*
8.3086- (merge-pathnames* *wild-file* *wild-inferiors*)
8.3087- "A pathname object with wildcards for matching any file in any recursive subdirectory")
8.3088-
8.3089- (defun wilden (path)
8.3090- "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory"
8.3091- (merge-pathnames* *wild-path* path)))
8.3092-
8.3093-
8.3094-;;; Translate a pathname
8.3095-(with-upgradability ()
8.3096- (defun relativize-directory-component (directory-component)
8.3097- "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component"
8.3098- (let ((directory (normalize-pathname-directory-component directory-component)))
8.3099- (cond
8.3100- ((stringp directory)
8.3101- (list :relative directory))
8.3102- ((eq (car directory) :absolute)
8.3103- (cons :relative (cdr directory)))
8.3104- (t
8.3105- directory))))
8.3106-
8.3107- (defun relativize-pathname-directory (pathspec)
8.3108- "Given a PATHNAME, return a relative pathname with otherwise the same components"
8.3109- (let ((p (pathname pathspec)))
8.3110- (make-pathname
8.3111- :directory (relativize-directory-component (pathname-directory p))
8.3112- :defaults p)))
8.3113-
8.3114- (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
8.3115- "Given a PATHNAME, return the character used to delimit directory names on this host and device."
8.3116- (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
8.3117- (last-char (namestring foo))))
8.3118-
8.3119- #-scl
8.3120- (defun directorize-pathname-host-device (pathname)
8.3121- "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
8.3122-added to its DIRECTORY component. This is useful for output translations."
8.3123- (os-cond
8.3124- ((os-unix-p)
8.3125- (when (physical-pathname-p pathname)
8.3126- (return-from directorize-pathname-host-device pathname))))
8.3127- (let* ((root (pathname-root pathname))
8.3128- (wild-root (wilden root))
8.3129- (absolute-pathname (merge-pathnames* pathname root))
8.3130- (separator (directory-separator-for-host root))
8.3131- (root-namestring (namestring root))
8.3132- (root-string
8.3133- (substitute-if #\/
8.3134- #'(lambda (x) (or (eql x #\:)
8.3135- (eql x separator)))
8.3136- root-namestring)))
8.3137- (multiple-value-bind (relative path filename)
8.3138- (split-unix-namestring-directory-components root-string :ensure-directory t)
8.3139- (declare (ignore relative filename))
8.3140- (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path))))
8.3141- (translate-pathname absolute-pathname wild-root (wilden new-base))))))
8.3142-
8.3143- #+scl
8.3144- (defun directorize-pathname-host-device (pathname)
8.3145- (let ((scheme (ext:pathname-scheme pathname))
8.3146- (host (pathname-host pathname))
8.3147- (port (ext:pathname-port pathname))
8.3148- (directory (pathname-directory pathname)))
8.3149- (flet ((specificp (x) (and x (not (eq x :unspecific)))))
8.3150- (if (or (specificp port)
8.3151- (and (specificp host) (plusp (length host)))
8.3152- (specificp scheme))
8.3153- (let ((prefix ""))
8.3154- (when (specificp port)
8.3155- (setf prefix (format nil ":~D" port)))
8.3156- (when (and (specificp host) (plusp (length host)))
8.3157- (setf prefix (strcat host prefix)))
8.3158- (setf prefix (strcat ":" prefix))
8.3159- (when (specificp scheme)
8.3160- (setf prefix (strcat scheme prefix)))
8.3161- (assert (and directory (eq (first directory) :absolute)))
8.3162- (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
8.3163- :defaults pathname)))
8.3164- pathname)))
8.3165-
8.3166- (defun translate-pathname* (path absolute-source destination &optional root source)
8.3167- "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility.
8.3168-PATH is the pathname to be translated.
8.3169-ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname,
8.3170-DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE,
8.3171-or a relative pathname, to be merged with ROOT and used as destination for translate-pathname
8.3172-or an absolute pathname, to be used as destination for translate-pathname.
8.3173-In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE."
8.3174- (declare (ignore source))
8.3175- (cond
8.3176- ((functionp destination)
8.3177- (funcall destination path absolute-source))
8.3178- ((eq destination t)
8.3179- path)
8.3180- ((not (pathnamep destination))
8.3181- (parameter-error "~S: Invalid destination" 'translate-pathname*))
8.3182- ((not (absolute-pathname-p destination))
8.3183- (translate-pathname path absolute-source (merge-pathnames* destination root)))
8.3184- (root
8.3185- (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
8.3186- (t
8.3187- (translate-pathname path absolute-source destination))))
8.3188-
8.3189- (defvar *output-translation-function* 'identity
8.3190- "Hook for output translations.
8.3191-
8.3192-This function needs to be idempotent, so that actions can work
8.3193-whether their inputs were translated or not,
8.3194-which they will be if we are composing operations. e.g. if some
8.3195-create-lisp-op creates a lisp file from some higher-level input,
8.3196-you need to still be able to use compile-op on that lisp file."))
8.3197-;;;; -------------------------------------------------------------------------
8.3198-;;;; Portability layer around Common Lisp filesystem access
8.3199-
8.3200-(uiop/package:define-package :uiop/filesystem
8.3201- (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
8.3202- (:export
8.3203- ;; Native namestrings
8.3204- #:native-namestring #:parse-native-namestring
8.3205- ;; Probing the filesystem
8.3206- #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
8.3207- #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
8.3208- #:collect-sub*directories
8.3209- ;; Resolving symlinks somewhat
8.3210- #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
8.3211- ;; merging with cwd
8.3212- #:get-pathname-defaults #:call-with-current-directory #:with-current-directory
8.3213- ;; Environment pathnames
8.3214- #:inter-directory-separator #:split-native-pathnames-string
8.3215- #:getenv-pathname #:getenv-pathnames
8.3216- #:getenv-absolute-directory #:getenv-absolute-directories
8.3217- #:lisp-implementation-directory #:lisp-implementation-pathname-p
8.3218- ;; Simple filesystem operations
8.3219- #:ensure-all-directories-exist
8.3220- #:rename-file-overwriting-target
8.3221- #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
8.3222-(in-package :uiop/filesystem)
8.3223-
8.3224-;;; Native namestrings, as seen by the operating system calls rather than Lisp
8.3225-(with-upgradability ()
8.3226- (defun native-namestring (x)
8.3227- "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
8.3228- (when x
8.3229- (let ((p (pathname x)))
8.3230- #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
8.3231- #+(or cmucl scl) (ext:unix-namestring p nil)
8.3232- #+sbcl (sb-ext:native-namestring p)
8.3233- #-(or clozure cmucl sbcl scl)
8.3234- (os-cond
8.3235- ((os-unix-p) (unix-namestring p))
8.3236- (t (namestring p))))))
8.3237-
8.3238- (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
8.3239- "From a native namestring suitable for use by the operating system, return
8.3240-a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
8.3241- (check-type string (or string null))
8.3242- (let* ((pathname
8.3243- (when string
8.3244- (with-pathname-defaults ()
8.3245- #+clozure (ccl:native-to-pathname string)
8.3246- #+cmucl (uiop/os::parse-unix-namestring* string)
8.3247- #+sbcl (sb-ext:parse-native-namestring string)
8.3248- #+scl (lisp::parse-unix-namestring string)
8.3249- #-(or clozure cmucl sbcl scl)
8.3250- (os-cond
8.3251- ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory))
8.3252- (t (parse-namestring string))))))
8.3253- (pathname
8.3254- (if ensure-directory
8.3255- (and pathname (ensure-directory-pathname pathname))
8.3256- pathname)))
8.3257- (apply 'ensure-pathname pathname constraints))))
8.3258-
8.3259-
8.3260-;;; Probing the filesystem
8.3261-(with-upgradability ()
8.3262- (defun truename* (p)
8.3263- "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
8.3264- (when p
8.3265- (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p))))
8.3266- (values
8.3267- (or (ignore-errors (truename p))
8.3268- ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
8.3269- ;; a trailing directory separator, causes an error on some lisps.
8.3270- #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d)))
8.3271- ;; On Genera, truename of a directory pathname will probably fail as Genera
8.3272- ;; will merge in a filename/type/version from *default-pathname-defaults* and
8.3273- ;; will try to get the truename of a file that probably doesn't exist.
8.3274- #+genera (when (directory-pathname-p p)
8.3275- (let ((d (scl:send p :directory-pathname-as-file)))
8.3276- (ensure-directory-pathname (ignore-errors (truename d)) nil)))))))
8.3277-
8.3278- (defun safe-file-write-date (pathname)
8.3279- "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
8.3280- ;; If FILE-WRITE-DATE returns NIL, it's possible that
8.3281- ;; the user or some other agent has deleted an input file.
8.3282- ;; Also, generated files will not exist at the time planning is done
8.3283- ;; and calls compute-action-stamp which calls safe-file-write-date.
8.3284- ;; So it is very possible that we can't get a valid file-write-date,
8.3285- ;; and we can survive and we will continue the planning
8.3286- ;; as if the file were very old.
8.3287- ;; (or should we treat the case in a different, special way?)
8.3288- (and pathname
8.3289- (handler-case (file-write-date (physicalize-pathname pathname))
8.3290- (file-error () nil))))
8.3291-
8.3292- (defun probe-file* (p &key truename)
8.3293- "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
8.3294-probes the filesystem for a file or directory with given pathname.
8.3295-If it exists, return its truename if TRUENAME is true,
8.3296-or the original (parsed) pathname if it is false (the default)."
8.3297- (values
8.3298- (ignore-errors
8.3299- (setf p (funcall 'ensure-pathname p
8.3300- :namestring :lisp
8.3301- :ensure-physical t
8.3302- :ensure-absolute t :defaults 'get-pathname-defaults
8.3303- :want-non-wild t
8.3304- :on-error nil))
8.3305- (when p
8.3306- #+allegro
8.3307- (probe-file p :follow-symlinks truename)
8.3308- #+gcl
8.3309- (if truename
8.3310- (truename* p)
8.3311- (let ((kind (car (si::stat p))))
8.3312- (when (eq kind :link)
8.3313- (setf kind (ignore-errors (car (si::stat (truename* p))))))
8.3314- (ecase kind
8.3315- ((nil) nil)
8.3316- ((:file :link)
8.3317- (cond
8.3318- ((file-pathname-p p) p)
8.3319- ((directory-pathname-p p)
8.3320- (subpathname p (car (last (pathname-directory p)))))))
8.3321- (:directory (ensure-directory-pathname p)))))
8.3322- #+clisp
8.3323- #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
8.3324- (pp (find-symbol* '#:probe-pathname :ext nil)))
8.3325- `(if truename
8.3326- ,(if pp
8.3327- `(values (,pp p))
8.3328- '(or (truename* p)
8.3329- (truename* (ignore-errors (ensure-directory-pathname p)))))
8.3330- ,(cond
8.3331- (fs `(and (,fs p) p))
8.3332- (pp `(nth-value 1 (,pp p)))
8.3333- (t '(or (and (truename* p) p)
8.3334- (if-let (d (ensure-directory-pathname p))
8.3335- (and (truename* d) d)))))))
8.3336- #-(or allegro clisp gcl)
8.3337- (if truename
8.3338- (probe-file p)
8.3339- (and
8.3340- #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p))
8.3341- #+(and lispworks os-unix) (system:get-file-stat p)
8.3342- #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
8.3343- #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-date p)
8.3344- p))))))
8.3345-
8.3346- (defun directory-exists-p (x)
8.3347- "Is X the name of a directory that exists on the filesystem?"
8.3348- #+allegro
8.3349- (excl:probe-directory x)
8.3350- #+clisp
8.3351- (handler-case (ext:probe-directory x)
8.3352- (sys::simple-file-error ()
8.3353- nil))
8.3354- #-(or allegro clisp)
8.3355- (let ((p (probe-file* x :truename t)))
8.3356- (and (directory-pathname-p p) p)))
8.3357-
8.3358- (defun file-exists-p (x)
8.3359- "Is X the name of a file that exists on the filesystem?"
8.3360- (let ((p (probe-file* x :truename t)))
8.3361- (and (file-pathname-p p) p)))
8.3362-
8.3363- (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
8.3364- "Return a list of the entries in a directory by calling DIRECTORY.
8.3365-Try to override the defaults to not resolving symlinks, if implementation allows."
8.3366- (apply 'directory pathname-spec
8.3367- (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
8.3368- #+(or clozure digitool) '(:follow-links nil)
8.3369- #+clisp '(:circle t :if-does-not-exist :ignore)
8.3370- #+(or cmucl scl) '(:follow-links nil :truenamep nil)
8.3371- #+lispworks '(:link-transparency nil)
8.3372- #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
8.3373- '(:resolve-symlinks nil))))))
8.3374-
8.3375- (defun filter-logical-directory-results (directory entries merger)
8.3376- "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is,
8.3377-given ENTRIES in the DIRECTORY, remove the entries which are physical yet
8.3378-when transformed by MERGER have a different TRUENAME.
8.3379-Also remove duplicates as may appear with some translation rules.
8.3380-This function is used as a helper to DIRECTORY-FILES to avoid invalid entries
8.3381-when using logical-pathnames."
8.3382- (if (logical-pathname-p directory)
8.3383- (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
8.3384- ;; Try hard to not resolve logical-pathname into physical pathnames;
8.3385- ;; otherwise logical-pathname users/lovers will be disappointed.
8.3386- ;; If directory* could use some implementation-dependent magic,
8.3387- ;; we will have logical pathnames already; otherwise,
8.3388- ;; we only keep pathnames for which specifying the name and
8.3389- ;; translating the LPN commute.
8.3390- (loop :for f :in entries
8.3391- :for p = (or (and (logical-pathname-p f) f)
8.3392- (let* ((u (ignore-errors (call-function merger f))))
8.3393- ;; The first u avoids a cumbersome (truename u) error.
8.3394- ;; At this point f should already be a truename,
8.3395- ;; but isn't quite in CLISP, for it doesn't have :version :newest
8.3396- (and u (equal (truename* u) (truename* f)) u)))
8.3397- :when p :collect p)
8.3398- :test 'pathname-equal)
8.3399- entries))
8.3400-
8.3401- (defun directory-files (directory &optional (pattern *wild-file-for-directory*))
8.3402- "Return a list of the files in a directory according to the PATTERN.
8.3403-Subdirectories should NOT be returned.
8.3404- PATTERN defaults to a pattern carefully chosen based on the implementation;
8.3405-override the default at your own risk.
8.3406- DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this,
8.3407-but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
8.3408- (let ((dir (ensure-directory-pathname directory)))
8.3409- (when (logical-pathname-p dir)
8.3410- ;; Because of the filtering we do below,
8.3411- ;; logical pathnames have restrictions on wild patterns.
8.3412- ;; Not that the results are very portable when you use these patterns on physical pathnames.
8.3413- (when (wild-pathname-p dir)
8.3414- (parameter-error "~S: Invalid wild pattern in logical directory ~S"
8.3415- 'directory-files directory))
8.3416- (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
8.3417- (parameter-error "~S: Invalid file pattern ~S for logical directory ~S" 'directory-files pattern directory))
8.3418- (setf pattern (make-pathname-logical pattern (pathname-host dir))))
8.3419- (let* ((pat (merge-pathnames* pattern dir))
8.3420- (entries (ignore-errors (directory* pat))))
8.3421- (remove-if 'directory-pathname-p
8.3422- (filter-logical-directory-results
8.3423- directory entries
8.3424- #'(lambda (f)
8.3425- (make-pathname :defaults dir
8.3426- :name (make-pathname-component-logical (pathname-name f))
8.3427- :type (make-pathname-component-logical (pathname-type f))
8.3428- :version (make-pathname-component-logical (pathname-version f)))))))))
8.3429-
8.3430- (defun subdirectories (directory)
8.3431- "Given a DIRECTORY pathname designator, return a list of the subdirectories under it.
8.3432-The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
8.3433- (let* ((directory (ensure-directory-pathname directory))
8.3434- #-(or abcl cormanlisp genera xcl)
8.3435- (wild (merge-pathnames*
8.3436- #-(or abcl allegro cmucl lispworks sbcl scl xcl)
8.3437- *wild-directory*
8.3438- #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*"
8.3439- directory))
8.3440- (dirs
8.3441- #-(or abcl cormanlisp genera xcl)
8.3442- (ignore-errors
8.3443- (directory* wild . #.(or #+clozure '(:directories t :files nil)
8.3444- #+mcl '(:directories t))))
8.3445- #+(or abcl xcl) (system:list-directory directory)
8.3446- #+cormanlisp (cl::directory-subdirs directory)
8.3447- #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil)))
8.3448- #+(or abcl allegro cmucl genera lispworks sbcl scl xcl)
8.3449- (dirs (loop :for x :in dirs
8.3450- :for d = #+(or abcl xcl) (extensions:probe-directory x)
8.3451- #+allegro (excl:probe-directory x)
8.3452- #+(or cmucl sbcl scl) (directory-pathname-p x)
8.3453- #+genera (getf (cdr x) :directory)
8.3454- #+lispworks (lw:file-directory-p x)
8.3455- :when d :collect #+(or abcl allegro xcl) (ensure-directory-pathname d)
8.3456- #+genera (ensure-directory-pathname (first x))
8.3457- #+(or cmucl lispworks sbcl scl) x)))
8.3458- (filter-logical-directory-results
8.3459- directory dirs
8.3460- (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
8.3461- '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
8.3462- #'(lambda (d)
8.3463- (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
8.3464- (and (consp dir) (consp (cdr dir))
8.3465- (make-pathname
8.3466- :defaults directory :name nil :type nil :version nil
8.3467- :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
8.3468-
8.3469- (defun collect-sub*directories (directory collectp recursep collector)
8.3470- "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory,
8.3471-call-function the COLLECTOR function designator on the directory,
8.3472-and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them.
8.3473-This function will thus let you traverse a filesystem hierarchy,
8.3474-superseding the functionality of CL-FAD:WALK-DIRECTORY.
8.3475-The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
8.3476- (when (call-function collectp directory)
8.3477- (call-function collector directory)
8.3478- (dolist (subdir (subdirectories directory))
8.3479- (when (call-function recursep subdir)
8.3480- (collect-sub*directories subdir collectp recursep collector))))))
8.3481-
8.3482-;;; Resolving symlinks somewhat
8.3483-(with-upgradability ()
8.3484- (defun truenamize (pathname)
8.3485- "Resolve as much of a pathname as possible"
8.3486- (block nil
8.3487- (when (typep pathname '(or null logical-pathname)) (return pathname))
8.3488- (let ((p pathname))
8.3489- (unless (absolute-pathname-p p)
8.3490- (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
8.3491- (return p))))
8.3492- (when (logical-pathname-p p) (return p))
8.3493- (let ((found (probe-file* p :truename t)))
8.3494- (when found (return found)))
8.3495- (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
8.3496- (up-components (reverse (rest directory)))
8.3497- (down-components ()))
8.3498- (assert (eq :absolute (first directory)))
8.3499- (loop :while up-components :do
8.3500- (if-let (parent
8.3501- (ignore-errors
8.3502- (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components))
8.3503- :name nil :type nil :version nil :defaults p))))
8.3504- (if-let (simplified
8.3505- (ignore-errors
8.3506- (merge-pathnames*
8.3507- (make-pathname :directory `(:relative ,@down-components)
8.3508- :defaults p)
8.3509- (ensure-directory-pathname parent))))
8.3510- (return simplified)))
8.3511- (push (pop up-components) down-components)
8.3512- :finally (return p))))))
8.3513-
8.3514- (defun resolve-symlinks (path)
8.3515- "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
8.3516- #-allegro (truenamize path)
8.3517- #+allegro
8.3518- (if (physical-pathname-p path)
8.3519- (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
8.3520- path))
8.3521-
8.3522- (defvar *resolve-symlinks* t
8.3523- "Determine whether or not ASDF resolves symlinks when defining systems.
8.3524-Defaults to T.")
8.3525-
8.3526- (defun resolve-symlinks* (path)
8.3527- "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)."
8.3528- (if *resolve-symlinks*
8.3529- (and path (resolve-symlinks path))
8.3530- path)))
8.3531-
8.3532-
8.3533-;;; Check pathname constraints
8.3534-(with-upgradability ()
8.3535- (defun ensure-pathname
8.3536- (pathname &key
8.3537- on-error
8.3538- defaults type dot-dot namestring
8.3539- empty-is-nil
8.3540- want-pathname
8.3541- want-logical want-physical ensure-physical
8.3542- want-relative want-absolute ensure-absolute ensure-subpath
8.3543- want-non-wild want-wild wilden
8.3544- want-file want-directory ensure-directory
8.3545- want-existing ensure-directories-exist
8.3546- truename resolve-symlinks truenamize
8.3547- &aux (p pathname)) ;; mutable working copy, preserve original
8.3548- "Coerces its argument into a PATHNAME,
8.3549-optionally doing some transformations and checking specified constraints.
8.3550-
8.3551-If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
8.3552-
8.3553-If the argument is a STRING, it is first converted to a pathname via
8.3554-PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
8.3555-depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
8.3556-or else by using CALL-FUNCTION on the NAMESTRING argument;
8.3557-if :UNIX is specified (or NIL, the default, which specifies the same thing),
8.3558-then PARSE-UNIX-NAMESTRING it is called with the keywords
8.3559-DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
8.3560-the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
8.3561-
8.3562-The pathname passed or resulting from parsing the string
8.3563-is then subjected to all the checks and transformations below are run.
8.3564-
8.3565-Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
8.3566-The boolean T is an alias for ERROR.
8.3567-ERROR means that an error will be raised if the constraint is not satisfied.
8.3568-CERROR means that an continuable error will be raised if the constraint is not satisfied.
8.3569-IGNORE means just return NIL instead of the pathname.
8.3570-
8.3571-The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
8.3572-that will be called with the the following arguments:
8.3573-a generic format string for ensure pathname, the pathname,
8.3574-the keyword argument corresponding to the failed check or transformation,
8.3575-a format string for the reason ENSURE-PATHNAME failed,
8.3576-and a list with arguments to that format string.
8.3577-If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
8.3578-You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
8.3579-
8.3580-The transformations and constraint checks are done in this order,
8.3581-which is also the order in the lambda-list:
8.3582-
8.3583-EMPTY-IS-NIL returns NIL if the argument is an empty string.
8.3584-WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
8.3585-Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
8.3586-WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
8.3587-WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
8.3588-ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
8.3589-WANT-RELATIVE checks that pathname has a relative directory component
8.3590-WANT-ABSOLUTE checks that pathname does have an absolute directory component
8.3591-ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
8.3592-that the result absolute is an absolute pathname indeed.
8.3593-ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
8.3594-WANT-FILE checks that pathname has a non-nil FILE component
8.3595-WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
8.3596-ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
8.3597-any file and type components as being actually a last directory component.
8.3598-WANT-NON-WILD checks that pathname is not a wild pathname
8.3599-WANT-WILD checks that pathname is a wild pathname
8.3600-WILDEN merges the pathname with **/*.*.* if it is not wild
8.3601-WANT-EXISTING checks that a file (or directory) exists with that pathname.
8.3602-ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
8.3603-TRUENAME replaces the pathname by its truename, or errors if not possible.
8.3604-RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
8.3605-TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
8.3606- (block nil
8.3607- (flet ((report-error (keyword description &rest arguments)
8.3608- (call-function (or on-error 'error)
8.3609- "Invalid pathname ~S: ~*~?"
8.3610- pathname keyword description arguments)))
8.3611- (macrolet ((err (constraint &rest arguments)
8.3612- `(report-error ',(intern* constraint :keyword) ,@arguments))
8.3613- (check (constraint condition &rest arguments)
8.3614- `(when ,constraint
8.3615- (unless ,condition (err ,constraint ,@arguments))))
8.3616- (transform (transform condition expr)
8.3617- `(when ,transform
8.3618- (,@(if condition `(when ,condition) '(progn))
8.3619- (setf p ,expr)))))
8.3620- (etypecase p
8.3621- ((or null pathname))
8.3622- (string
8.3623- (when (and (emptyp p) empty-is-nil)
8.3624- (return-from ensure-pathname nil))
8.3625- (setf p (case namestring
8.3626- ((:unix nil)
8.3627- (parse-unix-namestring
8.3628- p :defaults defaults :type type :dot-dot dot-dot
8.3629- :ensure-directory ensure-directory :want-relative want-relative))
8.3630- ((:native)
8.3631- (parse-native-namestring p))
8.3632- ((:lisp)
8.3633- (parse-namestring p))
8.3634- (t
8.3635- (call-function namestring p))))))
8.3636- (etypecase p
8.3637- (pathname)
8.3638- (null
8.3639- (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
8.3640- (return nil)))
8.3641- (check want-logical (logical-pathname-p p) "Expected a logical pathname")
8.3642- (check want-physical (physical-pathname-p p) "Expected a physical pathname")
8.3643- (transform ensure-physical () (physicalize-pathname p))
8.3644- (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
8.3645- (check want-relative (relative-pathname-p p) "Expected a relative pathname")
8.3646- (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
8.3647- (transform ensure-absolute (not (absolute-pathname-p p))
8.3648- (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
8.3649- (check ensure-absolute (absolute-pathname-p p)
8.3650- "Could not make into an absolute pathname even after merging with ~S" defaults)
8.3651- (check ensure-subpath (absolute-pathname-p defaults)
8.3652- "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
8.3653- (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
8.3654- (check want-file (file-pathname-p p) "Expected a file pathname")
8.3655- (check want-directory (directory-pathname-p p) "Expected a directory pathname")
8.3656- (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
8.3657- (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
8.3658- (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
8.3659- (transform wilden (not (wild-pathname-p p)) (wilden p))
8.3660- (when want-existing
8.3661- (let ((existing (probe-file* p :truename truename)))
8.3662- (if existing
8.3663- (when truename
8.3664- (return existing))
8.3665- (err want-existing "Expected an existing pathname"))))
8.3666- (when ensure-directories-exist (ensure-directories-exist p))
8.3667- (when truename
8.3668- (let ((truename (truename* p)))
8.3669- (if truename
8.3670- (return truename)
8.3671- (err truename "Can't get a truename for pathname"))))
8.3672- (transform resolve-symlinks () (resolve-symlinks p))
8.3673- (transform truenamize () (truenamize p))
8.3674- p)))))
8.3675-
8.3676-
8.3677-;;; Pathname defaults
8.3678-(with-upgradability ()
8.3679- (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
8.3680- "Find the actual DEFAULTS to use for pathnames, including
8.3681-resolving them with respect to GETCWD if the DEFAULTS were relative"
8.3682- (or (absolute-pathname-p defaults)
8.3683- (merge-pathnames* defaults (getcwd))))
8.3684-
8.3685- (defun call-with-current-directory (dir thunk)
8.3686- "call the THUNK in a context where the current directory was changed to DIR, if not NIL.
8.3687-Note that this operation is usually NOT thread-safe."
8.3688- (if dir
8.3689- (let* ((dir (resolve-symlinks*
8.3690- (get-pathname-defaults
8.3691- (ensure-directory-pathname
8.3692- dir))))
8.3693- (cwd (getcwd))
8.3694- (*default-pathname-defaults* dir))
8.3695- (chdir dir)
8.3696- (unwind-protect
8.3697- (funcall thunk)
8.3698- (chdir cwd)))
8.3699- (funcall thunk)))
8.3700-
8.3701- (defmacro with-current-directory ((&optional dir) &body body)
8.3702- "Call BODY while the POSIX current working directory is set to DIR"
8.3703- `(call-with-current-directory ,dir #'(lambda () ,@body))))
8.3704-
8.3705-
8.3706-;;; Environment pathnames
8.3707-(with-upgradability ()
8.3708- (defun inter-directory-separator ()
8.3709- "What character does the current OS conventionally uses to separate directories?"
8.3710- (os-cond ((os-unix-p) #\:) (t #\;)))
8.3711-
8.3712- (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
8.3713- "Given a string of pathnames specified in native OS syntax, separate them in a list,
8.3714-check constraints and normalize each one as per ENSURE-PATHNAME,
8.3715-where an empty string denotes NIL."
8.3716- (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
8.3717- :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints))))
8.3718-
8.3719- (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
8.3720- "Extract a pathname from a user-configured environment variable, as per native OS,
8.3721-check constraints and normalize as per ENSURE-PATHNAME."
8.3722- ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
8.3723- (apply 'parse-native-namestring (getenvp x)
8.3724- :ensure-directory (or ensure-directory want-directory)
8.3725- :on-error (or on-error
8.3726- `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
8.3727- constraints))
8.3728- (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
8.3729- "Extract a list of pathname from a user-configured environment variable, as per native OS,
8.3730-check constraints and normalize each one as per ENSURE-PATHNAME.
8.3731- Any empty entries in the environment variable X will be returned as NILs."
8.3732- (unless (getf constraints :empty-is-nil t)
8.3733- (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-pathnames))
8.3734- (apply 'split-native-pathnames-string (getenvp x)
8.3735- :on-error (or on-error
8.3736- `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
8.3737- :empty-is-nil t
8.3738- constraints))
8.3739- (defun getenv-absolute-directory (x)
8.3740- "Extract an absolute directory pathname from a user-configured environment variable,
8.3741-as per native OS"
8.3742- (getenv-pathname x :want-absolute t :ensure-directory t))
8.3743- (defun getenv-absolute-directories (x)
8.3744- "Extract a list of absolute directories from a user-configured environment variable,
8.3745-as per native OS. Any empty entries in the environment variable X will be returned as
8.3746-NILs."
8.3747- (getenv-pathnames x :want-absolute t :ensure-directory t))
8.3748-
8.3749- (defun lisp-implementation-directory (&key truename)
8.3750- "Where are the system files of the current installation of the CL implementation?"
8.3751- (declare (ignorable truename))
8.3752- (let ((dir
8.3753- #+abcl extensions:*lisp-home*
8.3754- #+(or allegro clasp ecl mkcl) #p"SYS:"
8.3755- #+clisp custom:*lib-directory*
8.3756- #+clozure #p"ccl:"
8.3757- #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
8.3758- #+gcl system::*system-directory*
8.3759- #+lispworks lispworks:*lispworks-directory*
8.3760- #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
8.3761- (funcall it)
8.3762- (getenv-pathname "SBCL_HOME" :ensure-directory t))
8.3763- #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/")))
8.3764- #+xcl ext:*xcl-home*))
8.3765- (if (and dir truename)
8.3766- (truename* dir)
8.3767- dir)))
8.3768-
8.3769- (defun lisp-implementation-pathname-p (pathname)
8.3770- "Is the PATHNAME under the current installation of the CL implementation?"
8.3771- ;; Other builtin systems are those under the implementation directory
8.3772- (and (when pathname
8.3773- (if-let (impdir (lisp-implementation-directory))
8.3774- (or (subpathp pathname impdir)
8.3775- (when *resolve-symlinks*
8.3776- (if-let (truename (truename* pathname))
8.3777- (if-let (trueimpdir (truename* impdir))
8.3778- (subpathp truename trueimpdir)))))))
8.3779- t)))
8.3780-
8.3781-
8.3782-;;; Simple filesystem operations
8.3783-(with-upgradability ()
8.3784- (defun ensure-all-directories-exist (pathnames)
8.3785- "Ensure that for every pathname in PATHNAMES, we ensure its directories exist"
8.3786- (dolist (pathname pathnames)
8.3787- (when pathname
8.3788- (ensure-directories-exist (physicalize-pathname pathname)))))
8.3789-
8.3790- (defun delete-file-if-exists (x)
8.3791- "Delete a file X if it already exists"
8.3792- (when x (handler-case (delete-file x) (file-error () nil))))
8.3793-
8.3794- (defun rename-file-overwriting-target (source target)
8.3795- "Rename a file, overwriting any previous file with the TARGET name,
8.3796-in an atomic way if the implementation allows."
8.3797- (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t))
8.3798- (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t)))
8.3799- #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
8.3800- (progn (funcall 'require "syscalls")
8.3801- (symbol-call :posix :copy-file source target :method :rename))
8.3802- #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic
8.3803- #-clisp
8.3804- (rename-file source target
8.3805- #+(or clasp clozure ecl) :if-exists
8.3806- #+clozure :rename-and-delete #+(or clasp ecl) t)))
8.3807-
8.3808- (defun delete-empty-directory (directory-pathname)
8.3809- "Delete an empty directory"
8.3810- #+(or abcl digitool gcl) (delete-file directory-pathname)
8.3811- #+allegro (excl:delete-directory directory-pathname)
8.3812- #+clisp (ext:delete-directory directory-pathname)
8.3813- #+clozure (ccl::delete-empty-directory directory-pathname)
8.3814- #+(or cmucl scl) (multiple-value-bind (ok errno)
8.3815- (unix:unix-rmdir (native-namestring directory-pathname))
8.3816- (unless ok
8.3817- #+cmucl (error "Error number ~A when trying to delete directory ~A"
8.3818- errno directory-pathname)
8.3819- #+scl (error "~@<Error deleting ~S: ~A~@:>"
8.3820- directory-pathname (unix:get-unix-error-msg errno))))
8.3821- #+cormanlisp (win32:delete-directory directory-pathname)
8.3822- #+(or clasp ecl) (si:rmdir directory-pathname)
8.3823- #+genera (fs:delete-directory directory-pathname)
8.3824- #+lispworks (lw:delete-directory directory-pathname)
8.3825- #+mkcl (mkcl:rmdir directory-pathname)
8.3826- #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
8.3827- `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
8.3828- `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
8.3829- #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
8.3830- #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
8.3831- (not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera
8.3832-
8.3833- (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
8.3834- "Delete a directory including all its recursive contents, aka rm -rf.
8.3835-
8.3836-To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
8.3837-a physical non-wildcard directory pathname (not namestring).
8.3838-
8.3839-If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
8.3840-if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
8.3841-
8.3842-Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
8.3843-the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
8.3844-which in practice is thus compulsory, and validates by returning a non-NIL result.
8.3845-If you're suicidal or extremely confident, just use :VALIDATE T."
8.3846- (check-type if-does-not-exist (member :error :ignore))
8.3847- (setf directory-pathname (ensure-pathname directory-pathname
8.3848- :want-pathname t :want-non-wild t
8.3849- :want-physical t :want-directory t))
8.3850- (cond
8.3851- ((not validatep)
8.3852- (parameter-error "~S was asked to delete ~S but was not provided a validation predicate"
8.3853- 'delete-directory-tree directory-pathname))
8.3854- ((not (call-function validate directory-pathname))
8.3855- (parameter-error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
8.3856- 'delete-directory-tree directory-pathname validate))
8.3857- ((not (directory-exists-p directory-pathname))
8.3858- (ecase if-does-not-exist
8.3859- (:error
8.3860- (error "~S was asked to delete ~S but the directory does not exist"
8.3861- 'delete-directory-tree directory-pathname))
8.3862- (:ignore nil)))
8.3863- #-(or allegro cmucl clozure genera sbcl scl)
8.3864- ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
8.3865- ;; except on implementations where we can prevent DIRECTORY from following symlinks;
8.3866- ;; instead spawn a standard external program to do the dirty work.
8.3867- (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
8.3868- (t
8.3869- ;; On supported implementation, call supported system functions
8.3870- #+allegro (symbol-call :excl.osi :delete-directory-and-files
8.3871- directory-pathname :if-does-not-exist if-does-not-exist)
8.3872- #+clozure (ccl:delete-directory directory-pathname)
8.3873- #+genera (fs:delete-directory directory-pathname :confirm nil)
8.3874- #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
8.3875- `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
8.3876- '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
8.3877- ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
8.3878- ;; do things the hard way.
8.3879- #-(or allegro clozure genera sbcl)
8.3880- (let ((sub*directories
8.3881- (while-collecting (c)
8.3882- (collect-sub*directories directory-pathname t t #'c))))
8.3883- (dolist (d (nreverse sub*directories))
8.3884- (map () 'delete-file (directory-files d))
8.3885- (delete-empty-directory d)))))))
8.3886-;;;; ---------------------------------------------------------------------------
8.3887-;;;; Utilities related to streams
8.3888-
8.3889-(uiop/package:define-package :uiop/stream
8.3890- (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
8.3891- (:export
8.3892- #:*default-stream-element-type*
8.3893- #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr
8.3894- #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
8.3895- #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
8.3896- #:*default-encoding* #:*utf-8-external-format*
8.3897- #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
8.3898- #:with-output #:output-string #:with-input #:input-string
8.3899- #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
8.3900- #:null-device-pathname #:call-with-null-input #:with-null-input
8.3901- #:call-with-null-output #:with-null-output
8.3902- #:finish-outputs #:format! #:safe-format!
8.3903- #:copy-stream-to-stream #:concatenate-files #:copy-file
8.3904- #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
8.3905- #:slurp-stream-forms #:slurp-stream-form
8.3906- #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line
8.3907- #:read-file-forms #:read-file-form #:safe-read-file-form
8.3908- #:eval-input #:eval-thunk #:standard-eval-thunk
8.3909- #:println #:writeln
8.3910- #:file-stream-p #:file-or-synonym-stream-p
8.3911- ;; Temporary files
8.3912- #:*temporary-directory* #:temporary-directory #:default-temporary-directory
8.3913- #:setup-temporary-directory
8.3914- #:call-with-temporary-file #:with-temporary-file
8.3915- #:add-pathname-suffix #:tmpize-pathname
8.3916- #:call-with-staging-pathname #:with-staging-pathname))
8.3917-(in-package :uiop/stream)
8.3918-
8.3919-(with-upgradability ()
8.3920- (defvar *default-stream-element-type*
8.3921- (or #+(or abcl cmucl cormanlisp scl xcl) 'character
8.3922- #+lispworks 'lw:simple-char
8.3923- :default)
8.3924- "default element-type for open (depends on the current CL implementation)")
8.3925-
8.3926- (defvar *stdin* *standard-input*
8.3927- "the original standard input stream at startup")
8.3928-
8.3929- (defun setup-stdin ()
8.3930- (setf *stdin*
8.3931- #.(or #+clozure 'ccl::*stdin*
8.3932- #+(or cmucl scl) 'system:*stdin*
8.3933- #+(or clasp ecl) 'ext::+process-standard-input+
8.3934- #+sbcl 'sb-sys:*stdin*
8.3935- '*standard-input*)))
8.3936-
8.3937- (defvar *stdout* *standard-output*
8.3938- "the original standard output stream at startup")
8.3939-
8.3940- (defun setup-stdout ()
8.3941- (setf *stdout*
8.3942- #.(or #+clozure 'ccl::*stdout*
8.3943- #+(or cmucl scl) 'system:*stdout*
8.3944- #+(or clasp ecl) 'ext::+process-standard-output+
8.3945- #+sbcl 'sb-sys:*stdout*
8.3946- '*standard-output*)))
8.3947-
8.3948- (defvar *stderr* *error-output*
8.3949- "the original error output stream at startup")
8.3950-
8.3951- (defun setup-stderr ()
8.3952- (setf *stderr*
8.3953- #.(or #+allegro 'excl::*stderr*
8.3954- #+clozure 'ccl::*stderr*
8.3955- #+(or cmucl scl) 'system:*stderr*
8.3956- #+(or clasp ecl) 'ext::+process-error-output+
8.3957- #+sbcl 'sb-sys:*stderr*
8.3958- '*error-output*)))
8.3959-
8.3960- ;; Run them now. In image.lisp, we'll register them to be run at image restart.
8.3961- (setup-stdin) (setup-stdout) (setup-stderr))
8.3962-
8.3963-
8.3964-;;; Encodings (mostly hooks only; full support requires asdf-encodings)
8.3965-(with-upgradability ()
8.3966- (defparameter *default-encoding*
8.3967- ;; preserve explicit user changes to something other than the legacy default :default
8.3968- (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*)))
8.3969- (unless (eq previous :default) previous))
8.3970- :utf-8)
8.3971- "Default encoding for source files.
8.3972-The default value :utf-8 is the portable thing.
8.3973-The legacy behavior was :default.
8.3974-If you (asdf:load-system :asdf-encodings) then
8.3975-you will have autodetection via *encoding-detection-hook* below,
8.3976-reading emacs-style -*- coding: utf-8 -*- specifications,
8.3977-and falling back to utf-8 or latin1 if nothing is specified.")
8.3978-
8.3979- (defparameter *utf-8-external-format*
8.3980- (if (featurep :asdf-unicode)
8.3981- (or #+clisp charset:utf-8 :utf-8)
8.3982- :default)
8.3983- "Default :external-format argument to pass to CL:OPEN and also
8.3984-CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
8.3985-On modern implementations, this will decode UTF-8 code points as CL characters.
8.3986-On legacy implementations, it may fall back on some 8-bit encoding,
8.3987-with non-ASCII code points being read as several CL characters;
8.3988-hopefully, if done consistently, that won't affect program behavior too much.")
8.3989-
8.3990- (defun always-default-encoding (pathname)
8.3991- "Trivial function to use as *encoding-detection-hook*,
8.3992-always 'detects' the *default-encoding*"
8.3993- (declare (ignore pathname))
8.3994- *default-encoding*)
8.3995-
8.3996- (defvar *encoding-detection-hook* #'always-default-encoding
8.3997- "Hook for an extension to define a function to automatically detect a file's encoding")
8.3998-
8.3999- (defun detect-encoding (pathname)
8.4000- "Detects the encoding of a specified file, going through user-configurable hooks"
8.4001- (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
8.4002- (funcall *encoding-detection-hook* pathname)
8.4003- *default-encoding*))
8.4004-
8.4005- (defun default-encoding-external-format (encoding)
8.4006- "Default, ignorant, function to transform a character ENCODING as a
8.4007-portable keyword to an implementation-dependent EXTERNAL-FORMAT specification.
8.4008-Load system ASDF-ENCODINGS to hook in a better one."
8.4009- (case encoding
8.4010- (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
8.4011- (:utf-8 *utf-8-external-format*)
8.4012- (otherwise
8.4013- (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
8.4014- :default)))
8.4015-
8.4016- (defvar *encoding-external-format-hook*
8.4017- #'default-encoding-external-format
8.4018- "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping
8.4019-from non-default encodings to and implementation-defined external-format's")
8.4020-
8.4021- (defun encoding-external-format (encoding)
8.4022- "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT,
8.4023-going through all the proper hooks."
8.4024- (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
8.4025-
8.4026-
8.4027-;;; Safe syntax
8.4028-(with-upgradability ()
8.4029- (defvar *standard-readtable* (with-standard-io-syntax *readtable*)
8.4030- "The standard readtable, implementing the syntax specified by the CLHS.
8.4031-It must never be modified, though only good implementations will even enforce that.")
8.4032-
8.4033- (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
8.4034- "Establish safe CL reader options around the evaluation of BODY"
8.4035- `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
8.4036-
8.4037- (defun call-with-safe-io-syntax (thunk &key (package :cl))
8.4038- (with-standard-io-syntax
8.4039- (let ((*package* (find-package package))
8.4040- (*read-default-float-format* 'double-float)
8.4041- (*print-readably* nil)
8.4042- (*read-eval* nil))
8.4043- (funcall thunk))))
8.4044-
8.4045- (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
8.4046- "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX"
8.4047- (with-safe-io-syntax (:package package)
8.4048- (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
8.4049-
8.4050-;;; Output helpers
8.4051- (with-upgradability ()
8.4052- (defun call-with-output-file (pathname thunk
8.4053- &key
8.4054- (element-type *default-stream-element-type*)
8.4055- (external-format *utf-8-external-format*)
8.4056- (if-exists :error)
8.4057- (if-does-not-exist :create))
8.4058- "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
8.4059-Other keys are accepted but discarded."
8.4060- (with-open-file (s pathname :direction :output
8.4061- :element-type element-type
8.4062- :external-format external-format
8.4063- :if-exists if-exists
8.4064- :if-does-not-exist if-does-not-exist)
8.4065- (funcall thunk s)))
8.4066-
8.4067- (defmacro with-output-file ((var pathname &rest keys
8.4068- &key element-type external-format if-exists if-does-not-exist)
8.4069- &body body)
8.4070- (declare (ignore element-type external-format if-exists if-does-not-exist))
8.4071- `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys))
8.4072-
8.4073- (defun call-with-output (output function &key (element-type 'character))
8.4074- "Calls FUNCTION with an actual stream argument,
8.4075-behaving like FORMAT with respect to how stream designators are interpreted:
8.4076-If OUTPUT is a STREAM, use it as the stream.
8.4077-If OUTPUT is NIL, use a STRING-OUTPUT-STREAM of given ELEMENT-TYPE as the stream, and
8.4078-return the resulting string.
8.4079-If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
8.4080-If OUTPUT is a STRING with a fill-pointer, use it as a STRING-OUTPUT-STREAM of given ELEMENT-TYPE.
8.4081-If OUTPUT is a PATHNAME, open the file and write to it, passing ELEMENT-TYPE to WITH-OUTPUT-FILE
8.4082--- this latter as an extension since ASDF 3.1.
8.4083-\(Proper ELEMENT-TYPE treatment since ASDF 3.3.4 only.\)
8.4084-Otherwise, signal an error."
8.4085- (etypecase output
8.4086- (null
8.4087- (with-output-to-string (stream nil :element-type element-type) (funcall function stream)))
8.4088- ((eql t)
8.4089- (funcall function *standard-output*))
8.4090- (stream
8.4091- (funcall function output))
8.4092- (string
8.4093- (assert (fill-pointer output))
8.4094- (with-output-to-string (stream output :element-type element-type) (funcall function stream)))
8.4095- (pathname
8.4096- (call-with-output-file output function :element-type element-type)))))
8.4097-
8.4098-(with-upgradability ()
8.4099- (locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
8.4100- (handler-bind (#+sbcl (style-warning #'muffle-warning))
8.4101- (defmacro with-output ((output-var &optional (value output-var) &key element-type) &body body)
8.4102- "Bind OUTPUT-VAR to an output stream obtained from VALUE (default: previous binding
8.4103-of OUTPUT-VAR) treated as a stream designator per CALL-WITH-OUTPUT. Evaluate BODY in
8.4104-the scope of this binding."
8.4105- `(call-with-output ,value #'(lambda (,output-var) ,@body)
8.4106- ,@(when element-type `(:element-type ,element-type)))))))
8.4107-
8.4108-(defun output-string (string &optional output)
8.4109- "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
8.4110- (if output
8.4111- (with-output (output) (princ string output))
8.4112- string))
8.4113-
8.4114-
8.4115-;;; Input helpers
8.4116-(with-upgradability ()
8.4117- (defun call-with-input-file (pathname thunk
8.4118- &key
8.4119- (element-type *default-stream-element-type*)
8.4120- (external-format *utf-8-external-format*)
8.4121- (if-does-not-exist :error))
8.4122- "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
8.4123-Other keys are accepted but discarded."
8.4124- (with-open-file (s pathname :direction :input
8.4125- :element-type element-type
8.4126- :external-format external-format
8.4127- :if-does-not-exist if-does-not-exist)
8.4128- (funcall thunk s)))
8.4129-
8.4130- (defmacro with-input-file ((var pathname &rest keys
8.4131- &key element-type external-format if-does-not-exist)
8.4132- &body body)
8.4133- (declare (ignore element-type external-format if-does-not-exist))
8.4134- `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
8.4135-
8.4136- (defun call-with-input (input function &key keys)
8.4137- "Calls FUNCTION with an actual stream argument, interpreting
8.4138-stream designators like READ, but also coercing strings to STRING-INPUT-STREAM,
8.4139-and PATHNAME to FILE-STREAM.
8.4140-If INPUT is a STREAM, use it as the stream.
8.4141-If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
8.4142-If INPUT is T, use *TERMINAL-IO* as the stream.
8.4143-If INPUT is a STRING, use it as a string-input-stream.
8.4144-If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE
8.4145--- the latter is an extension since ASDF 3.1.
8.4146-Otherwise, signal an error."
8.4147- (etypecase input
8.4148- (null (funcall function *standard-input*))
8.4149- ((eql t) (funcall function *terminal-io*))
8.4150- (stream (funcall function input))
8.4151- (string (with-input-from-string (stream input) (funcall function stream)))
8.4152- (pathname (apply 'call-with-input-file input function keys))))
8.4153-
8.4154- (defmacro with-input ((input-var &optional (value input-var)) &body body)
8.4155- "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
8.4156-as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
8.4157- `(call-with-input ,value #'(lambda (,input-var) ,@body)))
8.4158-
8.4159- (defun input-string (&optional input)
8.4160- "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string
8.4161-and return that"
8.4162- (if (stringp input)
8.4163- input
8.4164- (with-input (input) (funcall 'slurp-stream-string input)))))
8.4165-
8.4166-;;; Null device
8.4167-(with-upgradability ()
8.4168- (defun null-device-pathname ()
8.4169- "Pathname to a bit bucket device that discards any information written to it
8.4170-and always returns EOF when read from"
8.4171- (os-cond
8.4172- ((os-unix-p) #p"/dev/null")
8.4173- ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
8.4174- (t (error "No /dev/null on your OS"))))
8.4175- (defun call-with-null-input (fun &key element-type external-format if-does-not-exist)
8.4176- "Call FUN with an input stream that always returns end of file.
8.4177-The keyword arguments are allowed for backward compatibility, but are ignored."
8.4178- (declare (ignore element-type external-format if-does-not-exist))
8.4179- (with-open-stream (input (make-concatenated-stream))
8.4180- (funcall fun input)))
8.4181- (defmacro with-null-input ((var &rest keys
8.4182- &key element-type external-format if-does-not-exist)
8.4183- &body body)
8.4184- (declare (ignore element-type external-format if-does-not-exist))
8.4185- "Evaluate BODY in a context when VAR is bound to an input stream that always returns end of file.
8.4186-The keyword arguments are allowed for backward compatibility, but are ignored."
8.4187- `(call-with-null-input #'(lambda (,var) ,@body) ,@keys))
8.4188- (defun call-with-null-output (fun
8.4189- &key (element-type *default-stream-element-type*)
8.4190- (external-format *utf-8-external-format*)
8.4191- (if-exists :overwrite)
8.4192- (if-does-not-exist :error))
8.4193- (declare (ignore element-type external-format if-exists if-does-not-exist))
8.4194- "Call FUN with an output stream that discards all output.
8.4195-The keyword arguments are allowed for backward compatibility, but are ignored."
8.4196- (with-open-stream (output (make-broadcast-stream))
8.4197- (funcall fun output)))
8.4198- (defmacro with-null-output ((var &rest keys
8.4199- &key element-type external-format if-does-not-exist if-exists)
8.4200- &body body)
8.4201- "Evaluate BODY in a context when VAR is bound to an output stream that discards all output.
8.4202-The keyword arguments are allowed for backward compatibility, but are ignored."
8.4203- (declare (ignore element-type external-format if-exists if-does-not-exist))
8.4204- `(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))
8.4205-
8.4206-;;; Ensure output buffers are flushed
8.4207-(with-upgradability ()
8.4208- (defun finish-outputs (&rest streams)
8.4209- "Finish output on the main output streams as well as any specified one.
8.4210-Useful for portably flushing I/O before user input or program exit."
8.4211- ;; CCL notably buffers its stream output by default.
8.4212- (dolist (s (append streams
8.4213- (list *stdout* *stderr* *error-output* *standard-output* *trace-output*
8.4214- *debug-io* *terminal-io* *query-io*)))
8.4215- (ignore-errors (finish-output s)))
8.4216- (values))
8.4217-
8.4218- (defun format! (stream format &rest args)
8.4219- "Just like format, but call finish-outputs before and after the output."
8.4220- (finish-outputs stream)
8.4221- (apply 'format stream format args)
8.4222- (finish-outputs stream))
8.4223-
8.4224- (defun safe-format! (stream format &rest args)
8.4225- "Variant of FORMAT that is safe against both
8.4226-dangerous syntax configuration and errors while printing."
8.4227- (with-safe-io-syntax ()
8.4228- (ignore-errors (apply 'format! stream format args))
8.4229- (finish-outputs stream)))) ; just in case format failed
8.4230-
8.4231-
8.4232-;;; Simple Whole-Stream processing
8.4233-(with-upgradability ()
8.4234- (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
8.4235- "Copy the contents of the INPUT stream into the OUTPUT stream.
8.4236-If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
8.4237-Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
8.4238- (with-open-stream (input input)
8.4239- (if linewise
8.4240- (loop :for (line eof) = (multiple-value-list (read-line input nil nil))
8.4241- :while line :do
8.4242- (when prefix (princ prefix output))
8.4243- (princ line output)
8.4244- (unless eof (terpri output))
8.4245- (finish-output output)
8.4246- (when eof (return)))
8.4247- (loop
8.4248- :with buffer-size = (or buffer-size 8192)
8.4249- :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
8.4250- :for end = (read-sequence buffer input)
8.4251- :until (zerop end)
8.4252- :do (write-sequence buffer output :end end)
8.4253- (when (< end buffer-size) (return))))))
8.4254-
8.4255- (defun concatenate-files (inputs output)
8.4256- "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
8.4257- (with-open-file (o output :element-type '(unsigned-byte 8)
8.4258- :direction :output :if-exists :rename-and-delete)
8.4259- (dolist (input inputs)
8.4260- (with-open-file (i input :element-type '(unsigned-byte 8)
8.4261- :direction :input :if-does-not-exist :error)
8.4262- (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
8.4263-
8.4264- (defun copy-file (input output)
8.4265- "Copy contents of the INPUT file to the OUTPUT file"
8.4266- ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
8.4267- #+allegro
8.4268- (excl.osi:copy-file input output)
8.4269- #+ecl
8.4270- (ext:copy-file input output)
8.4271- #-(or allegro ecl)
8.4272- (concatenate-files (list input) output))
8.4273-
8.4274- (defun slurp-stream-string (input &key (element-type 'character) stripped)
8.4275- "Read the contents of the INPUT stream as a string"
8.4276- (let ((string
8.4277- (with-open-stream (input input)
8.4278- (with-output-to-string (output nil :element-type element-type)
8.4279- (copy-stream-to-stream input output :element-type element-type)))))
8.4280- (if stripped (stripln string) string)))
8.4281-
8.4282- (defun slurp-stream-lines (input &key count)
8.4283- "Read the contents of the INPUT stream as a list of lines, return those lines.
8.4284-
8.4285-Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR
8.4286-from the line-ending if the file or stream had CR+LF but Lisp only removed LF.
8.4287-
8.4288-Read no more than COUNT lines."
8.4289- (check-type count (or null integer))
8.4290- (with-open-stream (input input)
8.4291- (loop :for n :from 0
8.4292- :for l = (and (or (not count) (< n count))
8.4293- (read-line input nil nil))
8.4294- ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF
8.4295- :while l :collect (stripln l))))
8.4296-
8.4297- (defun slurp-stream-line (input &key (at 0))
8.4298- "Read the contents of the INPUT stream as a list of lines,
8.4299-then return the ACCESS-AT of that list of lines using the AT specifier.
8.4300-PATH defaults to 0, i.e. return the first line.
8.4301-PATH is typically an integer, or a list of an integer and a function.
8.4302-If PATH is NIL, it will return all the lines in the file.
8.4303-
8.4304-The stream will not be read beyond the Nth lines,
8.4305-where N is the index specified by path
8.4306-if path is either an integer or a list that starts with an integer."
8.4307- (access-at (slurp-stream-lines input :count (access-at-count at)) at))
8.4308-
8.4309- (defun slurp-stream-forms (input &key count)
8.4310- "Read the contents of the INPUT stream as a list of forms,
8.4311-and return those forms.
8.4312-
8.4313-If COUNT is null, read to the end of the stream;
8.4314-if COUNT is an integer, stop after COUNT forms were read.
8.4315-
8.4316-BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
8.4317- (check-type count (or null integer))
8.4318- (loop :with eof = '#:eof
8.4319- :for n :from 0
8.4320- :for form = (if (and count (>= n count))
8.4321- eof
8.4322- (read-preserving-whitespace input nil eof))
8.4323- :until (eq form eof) :collect form))
8.4324-
8.4325- (defun slurp-stream-form (input &key (at 0))
8.4326- "Read the contents of the INPUT stream as a list of forms,
8.4327-then return the ACCESS-AT of these forms following the AT.
8.4328-AT defaults to 0, i.e. return the first form.
8.4329-AT is typically a list of integers.
8.4330-If AT is NIL, it will return all the forms in the file.
8.4331-
8.4332-The stream will not be read beyond the Nth form,
8.4333-where N is the index specified by path,
8.4334-if path is either an integer or a list that starts with an integer.
8.4335-
8.4336-BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
8.4337- (access-at (slurp-stream-forms input :count (access-at-count at)) at))
8.4338-
8.4339- (defun read-file-string (file &rest keys)
8.4340- "Open FILE with option KEYS, read its contents as a string"
8.4341- (apply 'call-with-input-file file 'slurp-stream-string keys))
8.4342-
8.4343- (defun read-file-lines (file &rest keys)
8.4344- "Open FILE with option KEYS, read its contents as a list of lines
8.4345-BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
8.4346- (apply 'call-with-input-file file 'slurp-stream-lines keys))
8.4347-
8.4348- (defun read-file-line (file &rest keys &key (at 0) &allow-other-keys)
8.4349- "Open input FILE with option KEYS (except AT),
8.4350-and read its contents as per SLURP-STREAM-LINE with given AT specifier.
8.4351-BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
8.4352- (apply 'call-with-input-file file
8.4353- #'(lambda (input) (slurp-stream-line input :at at))
8.4354- (remove-plist-key :at keys)))
8.4355-
8.4356- (defun read-file-forms (file &rest keys &key count &allow-other-keys)
8.4357- "Open input FILE with option KEYS (except COUNT),
8.4358-and read its contents as per SLURP-STREAM-FORMS with given COUNT.
8.4359-If COUNT is null, read to the end of the stream;
8.4360-if COUNT is an integer, stop after COUNT forms were read.
8.4361-BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
8.4362- (apply 'call-with-input-file file
8.4363- #'(lambda (input) (slurp-stream-forms input :count count))
8.4364- (remove-plist-key :count keys)))
8.4365-
8.4366- (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
8.4367- "Open input FILE with option KEYS (except AT),
8.4368-and read its contents as per SLURP-STREAM-FORM with given AT specifier.
8.4369-BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
8.4370- (apply 'call-with-input-file file
8.4371- #'(lambda (input) (slurp-stream-form input :at at))
8.4372- (remove-plist-key :at keys)))
8.4373-
8.4374- (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys)
8.4375- "Reads the specified line from the top of a file using a safe standardized syntax.
8.4376-Extracts the line using READ-FILE-LINE,
8.4377-within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
8.4378- (with-safe-io-syntax (:package package)
8.4379- (apply 'read-file-line pathname (remove-plist-key :package keys))))
8.4380-
8.4381- (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
8.4382- "Reads the specified form from the top of a file using a safe standardized syntax.
8.4383-Extracts the form using READ-FILE-FORM,
8.4384-within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
8.4385- (with-safe-io-syntax (:package package)
8.4386- (apply 'read-file-form pathname (remove-plist-key :package keys))))
8.4387-
8.4388- (defun eval-input (input)
8.4389- "Portably read and evaluate forms from INPUT, return the last values."
8.4390- (with-input (input)
8.4391- (loop :with results :with eof ='#:eof
8.4392- :for form = (read input nil eof)
8.4393- :until (eq form eof)
8.4394- :do (setf results (multiple-value-list (eval form)))
8.4395- :finally (return (values-list results)))))
8.4396-
8.4397- (defun eval-thunk (thunk)
8.4398- "Evaluate a THUNK of code:
8.4399-If a function, FUNCALL it without arguments.
8.4400-If a constant literal and not a sequence, return it.
8.4401-If a cons or a symbol, EVAL it.
8.4402-If a string, repeatedly read and evaluate from it, returning the last values."
8.4403- (etypecase thunk
8.4404- ((or boolean keyword number character pathname) thunk)
8.4405- ((or cons symbol) (eval thunk))
8.4406- (function (funcall thunk))
8.4407- (string (eval-input thunk))))
8.4408-
8.4409- (defun standard-eval-thunk (thunk &key (package :cl))
8.4410- "Like EVAL-THUNK, but in a more standardized evaluation context."
8.4411- ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
8.4412- (when thunk
8.4413- (with-safe-io-syntax (:package package)
8.4414- (let ((*read-eval* t))
8.4415- (eval-thunk thunk))))))
8.4416-
8.4417-(with-upgradability ()
8.4418- (defun println (x &optional (stream *standard-output*))
8.4419- "Variant of PRINC that also calls TERPRI afterwards"
8.4420- (princ x stream) (terpri stream) (finish-output stream) (values))
8.4421-
8.4422- (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys)
8.4423- "Variant of WRITE that also calls TERPRI afterwards"
8.4424- (apply 'write x keys) (terpri stream) (finish-output stream) (values)))
8.4425-
8.4426-
8.4427-;;; Using temporary files
8.4428-(with-upgradability ()
8.4429- (defun default-temporary-directory ()
8.4430- "Return a default directory to use for temporary files"
8.4431- (os-cond
8.4432- ((os-unix-p)
8.4433- (or (getenv-pathname "TMPDIR" :ensure-directory t)
8.4434- (parse-native-namestring "/tmp/")))
8.4435- ((os-windows-p)
8.4436- (getenv-pathname "TEMP" :ensure-directory t))
8.4437- (t (subpathname (user-homedir-pathname) "tmp/"))))
8.4438-
8.4439- (defvar *temporary-directory* nil "User-configurable location for temporary files")
8.4440-
8.4441- (defun temporary-directory ()
8.4442- "Return a directory to use for temporary files"
8.4443- (or *temporary-directory* (default-temporary-directory)))
8.4444-
8.4445- (defun setup-temporary-directory ()
8.4446- "Configure a default temporary directory to use."
8.4447- (setf *temporary-directory* (default-temporary-directory))
8.4448- #+gcl (setf system::*tmp-dir* *temporary-directory*))
8.4449-
8.4450- (defun call-with-temporary-file
8.4451- (thunk &key
8.4452- (want-stream-p t) (want-pathname-p t) (direction :io) keep after
8.4453- directory (type "tmp" typep) prefix (suffix (when typep "-tmp"))
8.4454- (element-type *default-stream-element-type*)
8.4455- (external-format *utf-8-external-format*))
8.4456- "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
8.4457-
8.4458-The temporary file's pathname will be based on concatenating
8.4459-PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string,
8.4460-and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
8.4461-and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
8.4462-within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
8.4463-
8.4464-The file will be open with specified DIRECTION (defaults to :IO),
8.4465-ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
8.4466-EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
8.4467-If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
8.4468-with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
8.4469-and stream will be closed after the THUNK exits (either normally or abnormally).
8.4470-If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
8.4471-THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
8.4472-Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
8.4473-If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
8.4474-Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
8.4475- #+xcl (declare (ignorable typep))
8.4476- (check-type direction (member :output :io))
8.4477- (assert (or want-stream-p want-pathname-p))
8.4478- (loop
8.4479- :with prefix-pn = (ensure-absolute-pathname
8.4480- (or prefix "tmp")
8.4481- (or (ensure-pathname
8.4482- directory
8.4483- :namestring :native
8.4484- :ensure-directory t
8.4485- :ensure-physical t)
8.4486- #'temporary-directory))
8.4487- :with prefix-nns = (native-namestring prefix-pn)
8.4488- :with results = (progn (ensure-directories-exist prefix-pn)
8.4489- ())
8.4490- :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
8.4491- :for pathname = (parse-native-namestring
8.4492- (format nil "~A~36R~@[~A~]~@[.~A~]"
8.4493- prefix-nns counter suffix (unless (eq type :unspecific) type)))
8.4494- :for okp = nil :do
8.4495- ;; TODO: on Unix, do something about umask
8.4496- ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
8.4497- ;; TODO: on Unix, use CFFI and mkstemp --
8.4498- ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
8.4499- ;; Can we at least design some hook?
8.4500- (unwind-protect
8.4501- (progn
8.4502- (ensure-directories-exist pathname)
8.4503- (with-open-file (stream pathname
8.4504- :direction direction
8.4505- :element-type element-type
8.4506- :external-format external-format
8.4507- :if-exists nil :if-does-not-exist :create)
8.4508- (when stream
8.4509- (setf okp pathname)
8.4510- (when want-stream-p
8.4511- ;; Note: can't return directly from within with-open-file
8.4512- ;; or the non-local return causes the file creation to be undone.
8.4513- (setf results (multiple-value-list
8.4514- (if want-pathname-p
8.4515- (call-function thunk stream pathname)
8.4516- (call-function thunk stream)))))))
8.4517- ;; if we don't want a stream, then we must call the thunk *after*
8.4518- ;; the stream is closed, but only if it was successfully opened.
8.4519- (when okp
8.4520- (when (and want-pathname-p (not want-stream-p))
8.4521- (setf results (multiple-value-list (call-function thunk okp))))
8.4522- ;; if the stream was successfully opened, then return a value,
8.4523- ;; either one computed already, or one from AFTER, if that exists.
8.4524- (if after
8.4525- (return (call-function after pathname))
8.4526- (return (values-list results)))))
8.4527- (when (and okp (not (call-function keep)))
8.4528- (ignore-errors (delete-file-if-exists okp))))))
8.4529-
8.4530- (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
8.4531- (pathname (gensym "PATHNAME") pathnamep)
8.4532- directory prefix suffix type
8.4533- keep direction element-type external-format)
8.4534- &body body)
8.4535- "Evaluate BODY where the symbols specified by keyword arguments
8.4536-STREAM and PATHNAME (if respectively specified) are bound corresponding
8.4537-to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
8.4538-At least one of STREAM or PATHNAME must be specified.
8.4539-If the STREAM is not specified, it will be closed before the BODY is evaluated.
8.4540-If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
8.4541-separates forms run before and after the stream is closed.
8.4542-The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
8.4543-Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
8.4544- (check-type stream symbol)
8.4545- (check-type pathname symbol)
8.4546- (assert (or streamp pathnamep))
8.4547- (let* ((afterp (position :close-stream body))
8.4548- (before (if afterp (subseq body 0 afterp) body))
8.4549- (after (when afterp (subseq body (1+ afterp))))
8.4550- (beforef (gensym "BEFORE"))
8.4551- (afterf (gensym "AFTER")))
8.4552- (when (eql afterp 0)
8.4553- (style-warn ":CLOSE-STREAM should not be the first form of BODY in WITH-TEMPORARY-FILE. Instead, do not provide a STREAM."))
8.4554- `(flet (,@(when before
8.4555- `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
8.4556- ,@(when after `((declare (ignorable ,pathname))))
8.4557- ,@before)))
8.4558- ,@(when after
8.4559- (assert pathnamep)
8.4560- `((,afterf (,pathname) ,@after))))
8.4561- #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf))))
8.4562- (call-with-temporary-file
8.4563- ,(when before `#',beforef)
8.4564- :want-stream-p ,streamp
8.4565- :want-pathname-p ,pathnamep
8.4566- ,@(when direction `(:direction ,direction))
8.4567- ,@(when directory `(:directory ,directory))
8.4568- ,@(when prefix `(:prefix ,prefix))
8.4569- ,@(when suffix `(:suffix ,suffix))
8.4570- ,@(when type `(:type ,type))
8.4571- ,@(when keep `(:keep ,keep))
8.4572- ,@(when after `(:after #',afterf))
8.4573- ,@(when element-type `(:element-type ,element-type))
8.4574- ,@(when external-format `(:external-format ,external-format))))))
8.4575-
8.4576- (defun get-temporary-file (&key directory prefix suffix type (keep t))
8.4577- (with-temporary-file (:pathname pn :keep keep
8.4578- :directory directory :prefix prefix :suffix suffix :type type)
8.4579- pn))
8.4580-
8.4581- ;; Temporary pathnames in simple cases where no contention is assumed
8.4582- (defun add-pathname-suffix (pathname suffix &rest keys)
8.4583- "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
8.4584-Further KEYS can be passed to MAKE-PATHNAME."
8.4585- (apply 'make-pathname :name (strcat (pathname-name pathname) suffix)
8.4586- :defaults pathname keys))
8.4587-
8.4588- (defun tmpize-pathname (x)
8.4589- "Return a new pathname modified from X by adding a trivial random suffix.
8.4590-A new empty file with said temporary pathname is created, to ensure there is no
8.4591-clash with any concurrent process attempting the same thing."
8.4592- (let* ((px (ensure-pathname x :ensure-physical t))
8.4593- (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp"))
8.4594- (directory (pathname-directory-pathname px)))
8.4595- ;; Genera uses versioned pathnames -- If we leave the empty file in place,
8.4596- ;; the system will create a new version of the file when the caller opens
8.4597- ;; it for output. That empty file will remain after the operation is completed.
8.4598- ;; As Genera is a single core processor, the possibility of a name conflict is
8.4599- ;; minimal if not nil. (And, in the event of a collision, the two processes
8.4600- ;; would be writing to different versions of the file.)
8.4601- (get-temporary-file :directory directory :prefix prefix :type (pathname-type px)
8.4602- #+genera :keep #+genera nil)))
8.4603-
8.4604- (defun call-with-staging-pathname (pathname fun)
8.4605- "Calls FUN with a staging pathname, and atomically
8.4606-renames the staging pathname to the PATHNAME in the end.
8.4607-NB: this protects only against failure of the program, not against concurrent attempts.
8.4608-For the latter case, we ought pick a random suffix and atomically open it."
8.4609- (let* ((pathname (pathname pathname))
8.4610- (staging (tmpize-pathname pathname)))
8.4611- (unwind-protect
8.4612- (multiple-value-prog1
8.4613- (funcall fun staging)
8.4614- (rename-file-overwriting-target staging pathname))
8.4615- (delete-file-if-exists staging))))
8.4616-
8.4617- (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
8.4618- "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
8.4619- `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
8.4620-
8.4621-(with-upgradability ()
8.4622- (defun file-stream-p (stream)
8.4623- (typep stream 'file-stream))
8.4624- (defun file-or-synonym-stream-p (stream)
8.4625- (or (file-stream-p stream)
8.4626- (and (typep stream 'synonym-stream)
8.4627- (file-or-synonym-stream-p
8.4628- (symbol-value (synonym-stream-symbol stream)))))))
8.4629-;;;; -------------------------------------------------------------------------
8.4630-;;;; Starting, Stopping, Dumping a Lisp image
8.4631-
8.4632-(uiop/package:define-package :uiop/image
8.4633- (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
8.4634- (:export
8.4635- #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
8.4636- #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0
8.4637- #:*lisp-interaction*
8.4638- #:fatal-condition #:fatal-condition-p
8.4639- #:handle-fatal-condition
8.4640- #:call-with-fatal-condition-handler #:with-fatal-condition-handler
8.4641- #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
8.4642- #:*image-postlude* #:*image-dump-hook*
8.4643- #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
8.4644- #:shell-boolean-exit
8.4645- #:register-image-restore-hook #:register-image-dump-hook
8.4646- #:call-image-restore-hook #:call-image-dump-hook
8.4647- #:restore-image #:dump-image #:create-image
8.4648-))
8.4649-(in-package :uiop/image)
8.4650-
8.4651-(with-upgradability ()
8.4652- (defvar *lisp-interaction* t
8.4653- "Is this an interactive Lisp environment, or is it batch processing?")
8.4654-
8.4655- (defvar *command-line-arguments* nil
8.4656- "Command-line arguments")
8.4657-
8.4658- (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
8.4659- "Is this a dumped image? As a standalone executable?")
8.4660-
8.4661- (defvar *image-restore-hook* nil
8.4662- "Functions to call (in reverse order) when the image is restored")
8.4663-
8.4664- (defvar *image-restored-p* nil
8.4665- "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
8.4666-
8.4667- (defvar *image-prelude* nil
8.4668- "a form to evaluate, or string containing forms to read and evaluate
8.4669-when the image is restarted, but before the entry point is called.")
8.4670-
8.4671- (defvar *image-entry-point* nil
8.4672- "a function with which to restart the dumped image when execution is restored from it.")
8.4673-
8.4674- (defvar *image-postlude* nil
8.4675- "a form to evaluate, or string containing forms to read and evaluate
8.4676-before the image dump hooks are called and before the image is dumped.")
8.4677-
8.4678- (defvar *image-dump-hook* nil
8.4679- "Functions to call (in order) when before an image is dumped"))
8.4680-
8.4681-(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
8.4682- (deftype fatal-condition ()
8.4683- `(and serious-condition #+clozure (not ccl:process-reset))))
8.4684-
8.4685-;;; Exiting properly or im-
8.4686-(with-upgradability ()
8.4687- (defun quit (&optional (code 0) (finish-output t))
8.4688- "Quits from the Lisp world, with the given exit status if provided.
8.4689-This is designed to abstract away the implementation specific quit forms."
8.4690- (when finish-output ;; essential, for ClozureCL, and for standard compliance.
8.4691- (finish-outputs))
8.4692- #+(or abcl xcl) (ext:quit :status code)
8.4693- #+allegro (excl:exit code :quiet t)
8.4694- #+(or clasp ecl) (si:quit code)
8.4695- #+clisp (ext:quit code)
8.4696- #+clozure (ccl:quit code)
8.4697- #+cormanlisp (win32:exitprocess code)
8.4698- #+(or cmucl scl) (unix:unix-exit code)
8.4699- #+gcl (system:quit code)
8.4700- #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
8.4701- #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
8.4702- #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
8.4703- #+mkcl (mk-ext:quit :exit-code code)
8.4704- #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
8.4705- (quit (find-symbol* :quit :sb-ext nil)))
8.4706- (cond
8.4707- (exit `(,exit :code code :abort (not finish-output)))
8.4708- (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
8.4709- #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
8.4710- (not-implemented-error 'quit "(called with exit code ~S)" code))
8.4711-
8.4712- (defun die (code format &rest arguments)
8.4713- "Die in error with some error message"
8.4714- (with-safe-io-syntax ()
8.4715- (ignore-errors
8.4716- (format! *stderr* "~&~?~&" format arguments)))
8.4717- (quit code))
8.4718-
8.4719- (defun raw-print-backtrace (&key (stream *debug-io*) count condition)
8.4720- "Print a backtrace, directly accessing the implementation"
8.4721- (declare (ignorable stream count condition))
8.4722- #+abcl
8.4723- (loop :for i :from 0
8.4724- :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
8.4725- (safe-format! stream "~&~D: ~A~%" i frame))
8.4726- #+allegro
8.4727- (let ((*terminal-io* stream)
8.4728- (*standard-output* stream)
8.4729- (tpl:*zoom-print-circle* *print-circle*)
8.4730- (tpl:*zoom-print-level* *print-level*)
8.4731- (tpl:*zoom-print-length* *print-length*))
8.4732- (tpl:do-command "zoom"
8.4733- :from-read-eval-print-loop nil
8.4734- :count (or count t)
8.4735- :all t))
8.4736- #+clasp
8.4737- (clasp-debug:print-backtrace :stream stream :count count)
8.4738- #+(or ecl mkcl)
8.4739- (let* ((top (si:ihs-top))
8.4740- (repeats (if count (min top count) top))
8.4741- (backtrace (loop :for ihs :from 0 :below top
8.4742- :collect (list (si::ihs-fun ihs)
8.4743- (si::ihs-env ihs)))))
8.4744- (loop :for i :from 0 :below repeats
8.4745- :for frame :in (nreverse backtrace) :do
8.4746- (safe-format! stream "~&~D: ~S~%" i frame)))
8.4747- #+clisp
8.4748- (system::print-backtrace :out stream :limit count)
8.4749- #+(or clozure mcl)
8.4750- (let ((*debug-io* stream))
8.4751- #+clozure (ccl:print-call-history :count count :start-frame-number 1)
8.4752- #+mcl (ccl:print-call-history :detailed-p nil)
8.4753- (finish-output stream))
8.4754- #+(or cmucl scl)
8.4755- (let ((debug:*debug-print-level* *print-level*)
8.4756- (debug:*debug-print-length* *print-length*))
8.4757- (debug:backtrace (or count most-positive-fixnum) stream))
8.4758- #+gcl
8.4759- (let ((*debug-io* stream))
8.4760- (ignore-errors
8.4761- (with-safe-io-syntax ()
8.4762- (if condition
8.4763- (conditions::condition-backtrace condition)
8.4764- (system::simple-backtrace)))))
8.4765- #+lispworks
8.4766- (let ((dbg::*debugger-stack*
8.4767- (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
8.4768- (*debug-io* stream)
8.4769- (dbg:*debug-print-level* *print-level*)
8.4770- (dbg:*debug-print-length* *print-length*))
8.4771- (dbg:bug-backtrace nil))
8.4772- #+mezzano
8.4773- (let ((*standard-output* stream))
8.4774- (sys.int::backtrace count))
8.4775- #+sbcl
8.4776- (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum))
8.4777- #+xcl
8.4778- (loop :for i :from 0 :below (or count most-positive-fixnum)
8.4779- :for frame :in (extensions:backtrace-as-list) :do
8.4780- (safe-format! stream "~&~D: ~S~%" i frame)))
8.4781-
8.4782- (defun print-backtrace (&rest keys &key stream count condition)
8.4783- "Print a backtrace"
8.4784- (declare (ignore stream count condition))
8.4785- (with-safe-io-syntax (:package :cl)
8.4786- (let ((*print-readably* nil)
8.4787- (*print-circle* t)
8.4788- (*print-miser-width* 75)
8.4789- (*print-length* nil)
8.4790- (*print-level* nil)
8.4791- (*print-pretty* t))
8.4792- (ignore-errors (apply 'raw-print-backtrace keys)))))
8.4793-
8.4794- (defun print-condition-backtrace (condition &key (stream *stderr*) count)
8.4795- "Print a condition after a backtrace triggered by that condition"
8.4796- ;; We print the condition *after* the backtrace,
8.4797- ;; for the sake of who sees the backtrace at a terminal.
8.4798- ;; It is up to the caller to print the condition *before*, with some context.
8.4799- (print-backtrace :stream stream :count count :condition condition)
8.4800- (when condition
8.4801- (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
8.4802- condition)))
8.4803-
8.4804- (defun fatal-condition-p (condition)
8.4805- "Is the CONDITION fatal?"
8.4806- (typep condition 'fatal-condition))
8.4807-
8.4808- (defun handle-fatal-condition (condition)
8.4809- "Handle a fatal CONDITION:
8.4810-depending on whether *LISP-INTERACTION* is set, enter debugger or die"
8.4811- (cond
8.4812- (*lisp-interaction*
8.4813- (invoke-debugger condition))
8.4814- (t
8.4815- (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
8.4816- (print-condition-backtrace condition :stream *stderr*)
8.4817- (die 99 "~A" condition))))
8.4818-
8.4819- (defun call-with-fatal-condition-handler (thunk)
8.4820- "Call THUNK in a context where fatal conditions are appropriately handled"
8.4821- (handler-bind ((fatal-condition #'handle-fatal-condition))
8.4822- (funcall thunk)))
8.4823-
8.4824- (defmacro with-fatal-condition-handler ((&optional) &body body)
8.4825- "Execute BODY in a context where fatal conditions are appropriately handled"
8.4826- `(call-with-fatal-condition-handler #'(lambda () ,@body)))
8.4827-
8.4828- (defun shell-boolean-exit (x)
8.4829- "Quit with a return code that is 0 iff argument X is true"
8.4830- (quit (if x 0 1))))
8.4831-
8.4832-
8.4833-;;; Using image hooks
8.4834-(with-upgradability ()
8.4835- (defun register-image-restore-hook (hook &optional (call-now-p t))
8.4836- "Regiter a hook function to be run when restoring a dumped image"
8.4837- (register-hook-function '*image-restore-hook* hook call-now-p))
8.4838-
8.4839- (defun register-image-dump-hook (hook &optional (call-now-p nil))
8.4840- "Register a the hook function to be run before to dump an image"
8.4841- (register-hook-function '*image-dump-hook* hook call-now-p))
8.4842-
8.4843- (defun call-image-restore-hook ()
8.4844- "Call the hook functions registered to be run when restoring a dumped image"
8.4845- (call-functions (reverse *image-restore-hook*)))
8.4846-
8.4847- (defun call-image-dump-hook ()
8.4848- "Call the hook functions registered to be run before to dump an image"
8.4849- (call-functions *image-dump-hook*)))
8.4850-
8.4851-
8.4852-;;; Proper command-line arguments
8.4853-(with-upgradability ()
8.4854- (defun raw-command-line-arguments ()
8.4855- "Find what the actual command line for this process was."
8.4856- #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
8.4857- #+allegro (sys:command-line-arguments) ; default: :application t
8.4858- #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
8.4859- #+clisp (coerce (ext:argv) 'list)
8.4860- #+clozure ccl:*command-line-argument-list*
8.4861- #+(or cmucl scl) extensions:*command-line-strings*
8.4862- #+gcl si:*command-args*
8.4863- #+(or genera mcl mezzano) nil
8.4864- #+lispworks sys:*line-arguments-list*
8.4865- #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i))
8.4866- #+sbcl sb-ext:*posix-argv*
8.4867- #+xcl system:*argv*
8.4868- #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
8.4869- (not-implemented-error 'raw-command-line-arguments))
8.4870-
8.4871- (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
8.4872- "Extract user arguments from command-line invocation of current process.
8.4873-Assume the calling conventions of a generated script that uses --
8.4874-if we are not called from a directly executable image."
8.4875- (block nil
8.4876- #+abcl (return arguments)
8.4877- ;; SBCL and Allegro already separate user arguments from implementation arguments.
8.4878- #-(or sbcl allegro)
8.4879- (unless (eq *image-dumped-p* :executable)
8.4880- ;; LispWorks command-line processing isn't transparent to the user
8.4881- ;; unless you create a standalone executable; in that case,
8.4882- ;; we rely on cl-launch or some other script to set the arguments for us.
8.4883- #+lispworks (return *command-line-arguments*)
8.4884- ;; On other implementations, on non-standalone executables,
8.4885- ;; we trust cl-launch or whichever script starts the program
8.4886- ;; to use -- as a delimiter between implementation arguments and user arguments.
8.4887- #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
8.4888- (rest arguments)))
8.4889-
8.4890- (defun argv0 ()
8.4891- "On supported implementations (most that matter), or when invoked by a proper wrapper script,
8.4892-return a string that for the name with which the program was invoked, i.e. argv[0] in C.
8.4893-Otherwise, return NIL."
8.4894- (cond
8.4895- ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 !
8.4896- ;; NB: not currently available on ABCL, Corman, Genera, MCL
8.4897- (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl)
8.4898- (first (raw-command-line-arguments))
8.4899- #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0)))
8.4900- (t ;; argv[0] is the name of the interpreter.
8.4901- ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
8.4902- (getenvp "__CL_ARGV0"))))
8.4903-
8.4904- (defun setup-command-line-arguments ()
8.4905- (setf *command-line-arguments* (command-line-arguments)))
8.4906-
8.4907- (defun restore-image (&key
8.4908- (lisp-interaction *lisp-interaction*)
8.4909- (restore-hook *image-restore-hook*)
8.4910- (prelude *image-prelude*)
8.4911- (entry-point *image-entry-point*)
8.4912- (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
8.4913- "From a freshly restarted Lisp image, restore the saved Lisp environment
8.4914-by setting appropriate variables, running various hooks, and calling any specified entry point.
8.4915-
8.4916-If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*,
8.4917-call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return
8.4918-immediately to the surrounding restore process if allowed to continue.
8.4919-
8.4920-Then, comes the restore process itself:
8.4921-First, call each function in the RESTORE-HOOK,
8.4922-in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
8.4923-Second, evaluate the prelude, which is often Lisp text that is read,
8.4924-as per EVAL-INPUT.
8.4925-Third, call the ENTRY-POINT function, if any is specified, with no argument.
8.4926-
8.4927-The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL,
8.4928-any unhandled error leads to a backtrace and an exit with an error status.
8.4929-If LISP-INTERACTION is NIL, the process also exits when no error occurs:
8.4930-if neither restart nor entry function is provided, the program will exit with status 0 (success);
8.4931-if a function was provided, the program will exit after the function returns (if it returns),
8.4932-with status 0 if and only if the primary return value of result is generalized boolean true,
8.4933-and with status 1 if this value is NIL.
8.4934-
8.4935-If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result
8.4936-of the function will be returned rather than interpreted as a boolean designating an exit code."
8.4937- (when *image-restored-p*
8.4938- (if if-already-restored
8.4939- (call-function if-already-restored "Image already ~:[being ~;~]restored"
8.4940- (eq *image-restored-p* t))
8.4941- (return-from restore-image)))
8.4942- (with-fatal-condition-handler ()
8.4943- (setf *lisp-interaction* lisp-interaction)
8.4944- (setf *image-restore-hook* restore-hook)
8.4945- (setf *image-prelude* prelude)
8.4946- (setf *image-restored-p* :in-progress)
8.4947- (call-image-restore-hook)
8.4948- (standard-eval-thunk prelude)
8.4949- (setf *image-restored-p* t)
8.4950- (let ((results (multiple-value-list
8.4951- (if entry-point
8.4952- (call-function entry-point)
8.4953- t))))
8.4954- (if lisp-interaction
8.4955- (values-list results)
8.4956- (shell-boolean-exit (first results)))))))
8.4957-
8.4958-
8.4959-;;; Dumping an image
8.4960-
8.4961-(with-upgradability ()
8.4962- (defun dump-image (filename &key output-name executable
8.4963- (postlude *image-postlude*)
8.4964- (dump-hook *image-dump-hook*)
8.4965- #+clozure prepend-symbols #+clozure (purify t)
8.4966- #+sbcl compression
8.4967- #+(and sbcl os-windows) application-type)
8.4968- "Dump an image of the current Lisp environment at pathname FILENAME, with various options.
8.4969-
8.4970-First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
8.4971- the functions in DUMP-HOOK, in reverse order of registration by REGISTER-IMAGE-DUMP-HOOK.
8.4972-
8.4973-If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup.
8.4974-
8.4975-Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL,
8.4976-or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
8.4977- ;; Note: at least SBCL saves only global values of variables in the heap image,
8.4978- ;; so make sure things you want to dump are NOT just local bindings shadowing the global values.
8.4979- (declare (ignorable filename output-name executable))
8.4980- (setf *image-dumped-p* (if executable :executable t))
8.4981- (setf *image-restored-p* :in-regress)
8.4982- (setf *image-postlude* postlude)
8.4983- (standard-eval-thunk *image-postlude*)
8.4984- (setf *image-dump-hook* dump-hook)
8.4985- (call-image-dump-hook)
8.4986- (setf *image-restored-p* nil)
8.4987- #-(or clisp clozure (and cmucl executable) lispworks sbcl scl)
8.4988- (when executable
8.4989- (not-implemented-error 'dump-image "dumping an executable"))
8.4990- #+allegro
8.4991- (progn
8.4992- (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
8.4993- (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
8.4994- #+clisp
8.4995- (apply #'ext:saveinitmem filename
8.4996- :quiet t
8.4997- :start-package *package*
8.4998- :keep-global-handlers nil
8.4999- ;; Faré explains the odd executable value (slightly paraphrased):
8.5000- ;; 0 is very different from t in clisp and there for a good reason:
8.5001- ;; 0 turns the executable into one that has its own command-line handling, so hackers can't
8.5002- ;; use the underlying -i or -x to turn your would-be restricted binary into an unrestricted evaluator.
8.5003- :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
8.5004- (when executable
8.5005- (list
8.5006- ;; :parse-options nil ;--- requires a non-standard patch to clisp.
8.5007- :norc t :script nil :init-function #'restore-image)))
8.5008- #+clozure
8.5009- (flet ((dump (prepend-kernel)
8.5010- (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
8.5011- :toplevel-function (when executable #'restore-image))))
8.5012- ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
8.5013- (if prepend-symbols
8.5014- (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
8.5015- (require 'elf)
8.5016- (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
8.5017- (dump path))
8.5018- (dump t)))
8.5019- #+(or cmucl scl)
8.5020- (progn
8.5021- (ext:gc :full t)
8.5022- (setf ext:*batch-mode* nil)
8.5023- (setf ext::*gc-run-time* 0)
8.5024- (apply 'ext:save-lisp filename
8.5025- :allow-other-keys t ;; hush SCL and old versions of CMUCL
8.5026- #+(and cmucl executable) :executable #+(and cmucl executable) t
8.5027- (when executable '(:init-function restore-image :process-command-line nil
8.5028- :quiet t :load-init-file nil :site-init nil))))
8.5029- #+gcl
8.5030- (progn
8.5031- (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
8.5032- (si::save-system filename))
8.5033- #+lispworks
8.5034- (if executable
8.5035- (lispworks:deliver 'restore-image filename 0 :interface nil)
8.5036- (hcl:save-image filename :environment nil))
8.5037- #+sbcl
8.5038- (progn
8.5039- ;;(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
8.5040- (setf sb-ext::*gc-run-time* 0)
8.5041- (apply 'sb-ext:save-lisp-and-die filename
8.5042- :executable t ;--- always include the runtime that goes with the core
8.5043- (append
8.5044- (when compression (list :compression compression))
8.5045- ;;--- only save runtime-options for standalone executables
8.5046- (when executable (list :toplevel #'restore-image :save-runtime-options t))
8.5047- #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window.
8.5048- ;; the default is :console - only works with SBCL 1.1.15 or later.
8.5049- (when application-type (list :application-type application-type)))))
8.5050- #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl)
8.5051- (not-implemented-error 'dump-image))
8.5052-
8.5053- (defun create-image (destination lisp-object-files
8.5054- &key kind output-name prologue-code epilogue-code extra-object-files
8.5055- (prelude () preludep) (postlude () postludep)
8.5056- (entry-point () entry-point-p) build-args no-uiop)
8.5057- (declare (ignorable destination lisp-object-files extra-object-files kind output-name
8.5058- prologue-code epilogue-code prelude preludep postlude postludep
8.5059- entry-point entry-point-p build-args no-uiop))
8.5060- "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
8.5061- ;; Is it meaningful to run these in the current environment?
8.5062- ;; only if we also track the object files that constitute the "current" image,
8.5063- ;; and otherwise simulate dump-image, including quitting at the end.
8.5064- #-(or clasp ecl mkcl) (not-implemented-error 'create-image)
8.5065- #+(or clasp ecl mkcl)
8.5066- (let ((epilogue-code
8.5067- (if no-uiop
8.5068- epilogue-code
8.5069- (let ((forms
8.5070- (append
8.5071- (when epilogue-code `(,epilogue-code))
8.5072- (when postludep `((setf *image-postlude* ',postlude)))
8.5073- (when preludep `((setf *image-prelude* ',prelude)))
8.5074- (when entry-point-p `((setf *image-entry-point* ',entry-point)))
8.5075- (case kind
8.5076- ((:image)
8.5077- (setf kind :program) ;; to ECL, it's just another program.
8.5078- `((setf *image-dumped-p* t)
8.5079- (si::top-level #+(or clasp ecl) t) (quit)))
8.5080- ((:program)
8.5081- `((setf *image-dumped-p* :executable)
8.5082- (shell-boolean-exit
8.5083- (restore-image))))))))
8.5084- (when forms `(progn ,@forms))))))
8.5085- (check-type kind (member :dll :shared-library :lib :static-library
8.5086- :fasl :fasb :program))
8.5087- (apply #+clasp 'cmp:builder #+clasp kind
8.5088- #+(or ecl mkcl)
8.5089- (ecase kind
8.5090- ((:dll :shared-library)
8.5091- #+ecl 'c::build-shared-library #+mkcl 'compiler:build-shared-library)
8.5092- ((:lib :static-library)
8.5093- #+ecl 'c::build-static-library #+mkcl 'compiler:build-static-library)
8.5094- ((:fasl #+ecl :fasb)
8.5095- #+ecl 'c::build-fasl #+mkcl 'compiler:build-fasl)
8.5096- #+mkcl ((:fasb) 'compiler:build-bundle)
8.5097- ((:program)
8.5098- #+ecl 'c::build-program #+mkcl 'compiler:build-program))
8.5099- (pathname destination)
8.5100- #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files
8.5101- (append lisp-object-files #+(or clasp ecl) extra-object-files)
8.5102- #+ecl :init-name
8.5103- #+ecl (getf build-args :init-name)
8.5104- (append
8.5105- (when prologue-code `(:prologue-code ,prologue-code))
8.5106- (when epilogue-code `(:epilogue-code ,epilogue-code))
8.5107- #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
8.5108- build-args)))))
8.5109-
8.5110-
8.5111-;;; Some universal image restore hooks
8.5112-(with-upgradability ()
8.5113- (map () 'register-image-restore-hook
8.5114- '(setup-stdin setup-stdout setup-stderr
8.5115- setup-command-line-arguments setup-temporary-directory
8.5116- #+abcl detect-os)))
8.5117-;;;; -------------------------------------------------------------------------
8.5118-;;;; Support to build (compile and load) Lisp files
8.5119-
8.5120-(uiop/package:define-package :uiop/lisp-build
8.5121- (:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp
8.5122- (:use :uiop/common-lisp :uiop/package :uiop/utility
8.5123- :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
8.5124- (:export
8.5125- ;; Variables
8.5126- #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
8.5127- #:*output-translation-function*
8.5128- #:*optimization-settings* #:*previous-optimization-settings*
8.5129- #:*base-build-directory*
8.5130- #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
8.5131- #:compile-warned-warning #:compile-failed-warning
8.5132- #:check-lisp-compile-results #:check-lisp-compile-warnings
8.5133- #:*uninteresting-conditions* #:*usual-uninteresting-conditions*
8.5134- #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
8.5135- ;; Types
8.5136- #+sbcl #:sb-grovel-unknown-constant-condition
8.5137- ;; Functions & Macros
8.5138- #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings
8.5139- #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
8.5140- #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
8.5141- #:reify-simple-sexp #:unreify-simple-sexp
8.5142- #:reify-deferred-warnings #:unreify-deferred-warnings
8.5143- #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
8.5144- #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
8.5145- #:enable-deferred-warnings-check #:disable-deferred-warnings-check
8.5146- #:current-lisp-file-pathname #:load-pathname
8.5147- #:lispize-pathname #:compile-file-type #:call-around-hook
8.5148- #:compile-file* #:compile-file-pathname* #:*compile-check*
8.5149- #:load* #:load-from-string #:combine-fasls)
8.5150- (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
8.5151-(in-package :uiop/lisp-build)
8.5152-
8.5153-(with-upgradability ()
8.5154- (defvar *compile-file-warnings-behaviour*
8.5155- (or #+clisp :ignore :warn)
8.5156- "How should ASDF react if it encounters a warning when compiling a file?
8.5157-Valid values are :error, :warn, and :ignore.")
8.5158-
8.5159- (defvar *compile-file-failure-behaviour*
8.5160- (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
8.5161- "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
8.5162-when compiling a file, which includes any non-style-warning warning.
8.5163-Valid values are :error, :warn, and :ignore.
8.5164-Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
8.5165-
8.5166- (defvar *base-build-directory* nil
8.5167- "When set to a non-null value, it should be an absolute directory pathname,
8.5168-which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE,
8.5169-what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it.
8.5170-This can help you produce more deterministic output for FASLs."))
8.5171-
8.5172-;;; Optimization settings
8.5173-(with-upgradability ()
8.5174- (defvar *optimization-settings* nil
8.5175- "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS")
8.5176- (defvar *previous-optimization-settings* nil
8.5177- "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
8.5178- (defparameter +optimization-variables+
8.5179- ;; TODO: allegro genera corman mcl
8.5180- (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*)
8.5181- #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents)
8.5182- #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety*
8.5183- ccl::*nx-debug* ccl::*nx-cspeed*)
8.5184- #+(or cmucl scl) '(c::*default-cookie*)
8.5185- #+clasp nil
8.5186- #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
8.5187- #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
8.5188- #+lispworks '(compiler::*optimization-level*)
8.5189- #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*)
8.5190- #+sbcl '(sb-c::*policy*)))
8.5191- (defun get-optimization-settings ()
8.5192- "Get current compiler optimization settings, ready to PROCLAIM again"
8.5193- #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
8.5194- (warn "~S does not support ~S. Please help me fix that."
8.5195- 'get-optimization-settings (implementation-type))
8.5196- #+clasp (cleavir-env:optimize (cleavir-env:optimize-info CLASP-CLEAVIR:*CLASP-ENV*))
8.5197- #+(or abcl allegro clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
8.5198- (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity)))
8.5199- #.`(loop #+(or allegro clozure)
8.5200- ,@'(:with info = #+allegro (sys:declaration-information 'optimize)
8.5201- #+clozure (ccl:declaration-information 'optimize nil))
8.5202- :for x :in settings
8.5203- ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
8.5204- :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
8.5205- #+clisp (gethash x system::*optimize* 1)
8.5206- #+(or abcl ecl mkcl xcl) (symbol-value v)
8.5207- #+(or cmucl scl) (slot-value c::*default-cookie*
8.5208- (case x (compilation-speed 'c::cspeed)
8.5209- (otherwise x)))
8.5210- #+lispworks (slot-value compiler::*optimization-level* x)
8.5211- #+sbcl (sb-c::policy-quality sb-c::*policy* x))
8.5212- :when y :collect (list x y))))
8.5213- (defun proclaim-optimization-settings ()
8.5214- "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
8.5215- (proclaim `(optimize ,@*optimization-settings*))
8.5216- (let ((settings (get-optimization-settings)))
8.5217- (unless (equal *previous-optimization-settings* settings)
8.5218- (setf *previous-optimization-settings* settings))))
8.5219- (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body)
8.5220- #+(or allegro clasp clisp)
8.5221- (let ((previous-settings (gensym "PREVIOUS-SETTINGS"))
8.5222- (reset-settings (gensym "RESET-SETTINGS")))
8.5223- `(let* ((,previous-settings (get-optimization-settings))
8.5224- (,reset-settings #+clasp (reverse ,previous-settings) #-clasp ,previous-settings))
8.5225- ,@(when settings `((proclaim `(optimize ,@,settings))))
8.5226- (unwind-protect (progn ,@body)
8.5227- (proclaim `(optimize ,@,reset-settings)))))
8.5228- #-(or allegro clasp clisp)
8.5229- `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v))
8.5230- ,@(when settings `((proclaim `(optimize ,@,settings))))
8.5231- ,@body)))
8.5232-
8.5233-
8.5234-;;; Condition control
8.5235-(with-upgradability ()
8.5236- #+sbcl
8.5237- (progn
8.5238- (defun sb-grovel-unknown-constant-condition-p (c)
8.5239- "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
8.5240- (ignore-errors
8.5241- (and (typep c 'sb-int:simple-style-warning)
8.5242- (string-enclosed-p
8.5243- "Couldn't grovel for "
8.5244- (simple-condition-format-control c)
8.5245- " (unknown to the C compiler)."))))
8.5246- (deftype sb-grovel-unknown-constant-condition ()
8.5247- '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
8.5248-
8.5249- (defvar *usual-uninteresting-conditions*
8.5250- (append
8.5251- ;;#+clozure '(ccl:compiler-warning)
8.5252- #+cmucl '("Deleting unreachable code.")
8.5253- #+lispworks '("~S being redefined in ~A (previously in ~A)."
8.5254- "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
8.5255- #+sbcl
8.5256- '(sb-c::simple-compiler-note
8.5257- "&OPTIONAL and &KEY found in the same lambda list: ~S"
8.5258- sb-kernel:undefined-alien-style-warning
8.5259- sb-grovel-unknown-constant-condition ; defined above.
8.5260- sb-ext:implicit-generic-function-warning ;; Controversial.
8.5261- sb-int:package-at-variance
8.5262- sb-kernel:uninteresting-redefinition
8.5263- ;; BEWARE: the below four are controversial to include here.
8.5264- sb-kernel:redefinition-with-defun
8.5265- sb-kernel:redefinition-with-defgeneric
8.5266- sb-kernel:redefinition-with-defmethod
8.5267- sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
8.5268- #+sbcl
8.5269- (let ((condition (find-symbol* '#:lexical-environment-too-complex :sb-kernel nil)))
8.5270- (when condition
8.5271- (list condition)))
8.5272- '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
8.5273- "A suggested value to which to set or bind *uninteresting-conditions*.")
8.5274-
8.5275- (defvar *uninteresting-conditions* '()
8.5276- "Conditions that may be skipped while compiling or loading Lisp code.")
8.5277- (defvar *uninteresting-compiler-conditions* '()
8.5278- "Additional conditions that may be skipped while compiling Lisp code.")
8.5279- (defvar *uninteresting-loader-conditions*
8.5280- (append
8.5281- '("Overwriting already existing readtable ~S." ;; from named-readtables
8.5282- #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
8.5283- #+clisp '(clos::simple-gf-replacing-method-warning))
8.5284- "Additional conditions that may be skipped while loading Lisp code."))
8.5285-
8.5286-;;;; ----- Filtering conditions while building -----
8.5287-(with-upgradability ()
8.5288- (defun call-with-muffled-compiler-conditions (thunk)
8.5289- "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
8.5290- (call-with-muffled-conditions
8.5291- thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
8.5292- (defmacro with-muffled-compiler-conditions ((&optional) &body body)
8.5293- "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS"
8.5294- `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
8.5295- (defun call-with-muffled-loader-conditions (thunk)
8.5296- "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
8.5297- (call-with-muffled-conditions
8.5298- thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
8.5299- (defmacro with-muffled-loader-conditions ((&optional) &body body)
8.5300- "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS"
8.5301- `(call-with-muffled-loader-conditions #'(lambda () ,@body))))
8.5302-
8.5303-
8.5304-;;;; Handle warnings and failures
8.5305-(with-upgradability ()
8.5306- (define-condition compile-condition (condition)
8.5307- ((context-format
8.5308- :initform nil :reader compile-condition-context-format :initarg :context-format)
8.5309- (context-arguments
8.5310- :initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
8.5311- (description
8.5312- :initform nil :reader compile-condition-description :initarg :description))
8.5313- (:report (lambda (c s)
8.5314- (format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
8.5315- (or (compile-condition-description c) (type-of c))
8.5316- (compile-condition-context-format c)
8.5317- (compile-condition-context-arguments c)))))
8.5318- (define-condition compile-file-error (compile-condition error) ())
8.5319- (define-condition compile-warned-warning (compile-condition warning) ())
8.5320- (define-condition compile-warned-error (compile-condition error) ())
8.5321- (define-condition compile-failed-warning (compile-condition warning) ())
8.5322- (define-condition compile-failed-error (compile-condition error) ())
8.5323-
8.5324- (defun check-lisp-compile-warnings (warnings-p failure-p
8.5325- &optional context-format context-arguments)
8.5326- "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
8.5327-raise an error or warning as appropriate"
8.5328- (when failure-p
8.5329- (case *compile-file-failure-behaviour*
8.5330- (:warn (warn 'compile-failed-warning
8.5331- :description "Lisp compilation failed"
8.5332- :context-format context-format
8.5333- :context-arguments context-arguments))
8.5334- (:error (error 'compile-failed-error
8.5335- :description "Lisp compilation failed"
8.5336- :context-format context-format
8.5337- :context-arguments context-arguments))
8.5338- (:ignore nil)))
8.5339- (when warnings-p
8.5340- (case *compile-file-warnings-behaviour*
8.5341- (:warn (warn 'compile-warned-warning
8.5342- :description "Lisp compilation had style-warnings"
8.5343- :context-format context-format
8.5344- :context-arguments context-arguments))
8.5345- (:error (error 'compile-warned-error
8.5346- :description "Lisp compilation had style-warnings"
8.5347- :context-format context-format
8.5348- :context-arguments context-arguments))
8.5349- (:ignore nil))))
8.5350-
8.5351- (defun check-lisp-compile-results (output warnings-p failure-p
8.5352- &optional context-format context-arguments)
8.5353- "Given the results of COMPILE-FILE, raise an error or warning as appropriate"
8.5354- (unless output
8.5355- (error 'compile-file-error :context-format context-format :context-arguments context-arguments))
8.5356- (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
8.5357-
8.5358-
8.5359-;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
8.5360-;;;
8.5361-;;; To support an implementation, three functions must be implemented:
8.5362-;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
8.5363-;;; See their respective docstrings.
8.5364-(with-upgradability ()
8.5365- (defun reify-simple-sexp (sexp)
8.5366- "Given a simple SEXP, return a representation of it as a portable SEXP.
8.5367-Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
8.5368- (etypecase sexp
8.5369- (symbol (reify-symbol sexp))
8.5370- ((or number character simple-string pathname) sexp)
8.5371- (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
8.5372- (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
8.5373-
8.5374- (defun unreify-simple-sexp (sexp)
8.5375- "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
8.5376- (etypecase sexp
8.5377- ((or symbol number character simple-string pathname) sexp)
8.5378- (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
8.5379- ((simple-vector 2) (unreify-symbol sexp))
8.5380- ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector))))
8.5381-
8.5382- #+clozure
8.5383- (progn
8.5384- (defun reify-source-note (source-note)
8.5385- (when source-note
8.5386- (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename)
8.5387- (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note
8.5388- (declare (ignorable source))
8.5389- (list :filename filename :start-pos start-pos :end-pos end-pos
8.5390- #|:source (reify-source-note source)|#))))
8.5391- (defun unreify-source-note (source-note)
8.5392- (when source-note
8.5393- (destructuring-bind (&key filename start-pos end-pos source) source-note
8.5394- (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
8.5395- :source (unreify-source-note source)))))
8.5396- (defun unsymbolify-function-name (name)
8.5397- (if-let (setfed (gethash name ccl::%setf-function-name-inverses%))
8.5398- `(setf ,setfed)
8.5399- name))
8.5400- (defun symbolify-function-name (name)
8.5401- (if (and (consp name) (eq (first name) 'setf))
8.5402- (let ((setfed (second name)))
8.5403- (gethash setfed ccl::%setf-function-names%))
8.5404- name))
8.5405- (defun reify-function-name (function-name)
8.5406- (let ((name (or (first function-name) ;; defun: extract the name
8.5407- (let ((sec (second function-name)))
8.5408- (or (and (atom sec) sec) ; scoped method: drop scope
8.5409- (first sec)))))) ; method: keep gf name, drop method specializers
8.5410- (list name)))
8.5411- (defun unreify-function-name (function-name)
8.5412- function-name)
8.5413- (defun nullify-non-literals (sexp)
8.5414- (typecase sexp
8.5415- ((or number character simple-string symbol pathname) sexp)
8.5416- (cons (cons (nullify-non-literals (car sexp))
8.5417- (nullify-non-literals (cdr sexp))))
8.5418- (t nil)))
8.5419- (defun reify-deferred-warning (deferred-warning)
8.5420- (with-accessors ((warning-type ccl::compiler-warning-warning-type)
8.5421- (args ccl::compiler-warning-args)
8.5422- (source-note ccl:compiler-warning-source-note)
8.5423- (function-name ccl:compiler-warning-function-name)) deferred-warning
8.5424- (list :warning-type warning-type :function-name (reify-function-name function-name)
8.5425- :source-note (reify-source-note source-note)
8.5426- :args (destructuring-bind (fun &rest more)
8.5427- args
8.5428- (cons (unsymbolify-function-name fun)
8.5429- (nullify-non-literals more))))))
8.5430- (defun unreify-deferred-warning (reified-deferred-warning)
8.5431- (destructuring-bind (&key warning-type function-name source-note args)
8.5432- reified-deferred-warning
8.5433- (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*))
8.5434- 'ccl::compiler-warning)
8.5435- :function-name (unreify-function-name function-name)
8.5436- :source-note (unreify-source-note source-note)
8.5437- :warning-type warning-type
8.5438- :args (destructuring-bind (fun . more) args
8.5439- (cons (symbolify-function-name fun) more))))))
8.5440- #+(or cmucl scl)
8.5441- (defun reify-undefined-warning (warning)
8.5442- ;; Extracting undefined-warnings from the compilation-unit
8.5443- ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
8.5444- (list*
8.5445- (c::undefined-warning-kind warning)
8.5446- (c::undefined-warning-name warning)
8.5447- (c::undefined-warning-count warning)
8.5448- (mapcar
8.5449- #'(lambda (frob)
8.5450- ;; the lexenv slot can be ignored for reporting purposes
8.5451- `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob)
8.5452- :source ,(c::compiler-error-context-source frob)
8.5453- :original-source ,(c::compiler-error-context-original-source frob)
8.5454- :context ,(c::compiler-error-context-context frob)
8.5455- :file-name ,(c::compiler-error-context-file-name frob) ; a pathname
8.5456- :file-position ,(c::compiler-error-context-file-position frob) ; an integer
8.5457- :original-source-path ,(c::compiler-error-context-original-source-path frob)))
8.5458- (c::undefined-warning-warnings warning))))
8.5459-
8.5460- #+sbcl
8.5461- (defun reify-undefined-warning (warning)
8.5462- ;; Extracting undefined-warnings from the compilation-unit
8.5463- ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
8.5464- (list*
8.5465- (sb-c::undefined-warning-kind warning)
8.5466- (sb-c::undefined-warning-name warning)
8.5467- (sb-c::undefined-warning-count warning)
8.5468- ;; the COMPILER-ERROR-CONTEXT struct has changed in SBCL, which means how we
8.5469- ;; handle deferred warnings must change... TODO: when enough time has
8.5470- ;; gone by, just assume all versions of SBCL are adequately
8.5471- ;; up-to-date, and cut this material.[2018/05/30:rpg]
8.5472- (mapcar
8.5473- #'(lambda (frob)
8.5474- ;; the lexenv slot can be ignored for reporting purposes
8.5475- `(
8.5476- #- #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c)
8.5477- ,@`(:enclosing-source
8.5478- ,(sb-c::compiler-error-context-enclosing-source frob)
8.5479- :source
8.5480- ,(sb-c::compiler-error-context-source frob)
8.5481- :original-source
8.5482- ,(sb-c::compiler-error-context-original-source frob))
8.5483- #+ #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c)
8.5484- ,@ `(:%enclosing-source
8.5485- ,(sb-c::compiler-error-context-enclosing-source frob)
8.5486- :%source
8.5487- ,(sb-c::compiler-error-context-source frob)
8.5488- :original-form
8.5489- ,(sb-c::compiler-error-context-original-form frob))
8.5490- :context ,(sb-c::compiler-error-context-context frob)
8.5491- :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
8.5492- :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
8.5493- :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
8.5494- (sb-c::undefined-warning-warnings warning))))
8.5495-
8.5496- (defun reify-deferred-warnings ()
8.5497- "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
8.5498-using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
8.5499-WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
8.5500- #+allegro
8.5501- (list :functions-defined excl::.functions-defined.
8.5502- :functions-called excl::.functions-called.)
8.5503- #+clozure
8.5504- (mapcar 'reify-deferred-warning
8.5505- (if-let (dw ccl::*outstanding-deferred-warnings*)
8.5506- (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
8.5507- (ccl::deferred-warnings.warnings mdw))))
8.5508- #+(or cmucl scl)
8.5509- (when lisp::*in-compilation-unit*
8.5510- ;; Try to send nothing through the pipe if nothing needs to be accumulated
8.5511- `(,@(when c::*undefined-warnings*
8.5512- `((c::*undefined-warnings*
8.5513- ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*))))
8.5514- ,@(loop :for what :in '(c::*compiler-error-count*
8.5515- c::*compiler-warning-count*
8.5516- c::*compiler-note-count*)
8.5517- :for value = (symbol-value what)
8.5518- :when (plusp value)
8.5519- :collect `(,what . ,value))))
8.5520- #+sbcl
8.5521- (when sb-c::*in-compilation-unit*
8.5522- ;; Try to send nothing through the pipe if nothing needs to be accumulated
8.5523- `(,@(when sb-c::*undefined-warnings*
8.5524- `((sb-c::*undefined-warnings*
8.5525- ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*))))
8.5526- ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
8.5527- sb-c::*compiler-error-count*
8.5528- sb-c::*compiler-warning-count*
8.5529- sb-c::*compiler-style-warning-count*
8.5530- sb-c::*compiler-note-count*)
8.5531- :for value = (symbol-value what)
8.5532- :when (plusp value)
8.5533- :collect `(,what . ,value)))))
8.5534-
8.5535- (defun unreify-deferred-warnings (reified-deferred-warnings)
8.5536- "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
8.5537-deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
8.5538-Handle any warning that has been resolved already,
8.5539-such as an undefined function that has been defined since.
8.5540-One of three functions required for deferred-warnings support in ASDF."
8.5541- (declare (ignorable reified-deferred-warnings))
8.5542- #+allegro
8.5543- (destructuring-bind (&key functions-defined functions-called)
8.5544- reified-deferred-warnings
8.5545- (setf excl::.functions-defined.
8.5546- (append functions-defined excl::.functions-defined.)
8.5547- excl::.functions-called.
8.5548- (append functions-called excl::.functions-called.)))
8.5549- #+clozure
8.5550- (let ((dw (or ccl::*outstanding-deferred-warnings*
8.5551- (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t)))))
8.5552- (appendf (ccl::deferred-warnings.warnings dw)
8.5553- (mapcar 'unreify-deferred-warning reified-deferred-warnings)))
8.5554- #+(or cmucl scl)
8.5555- (dolist (item reified-deferred-warnings)
8.5556- ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
8.5557- ;; For *undefined-warnings*, the adjustment is a list of initargs.
8.5558- ;; For everything else, it's an integer.
8.5559- (destructuring-bind (symbol . adjustment) item
8.5560- (case symbol
8.5561- ((c::*undefined-warnings*)
8.5562- (setf c::*undefined-warnings*
8.5563- (nconc (mapcan
8.5564- #'(lambda (stuff)
8.5565- (destructuring-bind (kind name count . rest) stuff
8.5566- (unless (case kind (:function (fboundp name)))
8.5567- (list
8.5568- (c::make-undefined-warning
8.5569- :name name
8.5570- :kind kind
8.5571- :count count
8.5572- :warnings
8.5573- (mapcar #'(lambda (x)
8.5574- (apply #'c::make-compiler-error-context x))
8.5575- rest))))))
8.5576- adjustment)
8.5577- c::*undefined-warnings*)))
8.5578- (otherwise
8.5579- (set symbol (+ (symbol-value symbol) adjustment))))))
8.5580- #+sbcl
8.5581- (dolist (item reified-deferred-warnings)
8.5582- ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
8.5583- ;; For *undefined-warnings*, the adjustment is a list of initargs.
8.5584- ;; For everything else, it's an integer.
8.5585- (destructuring-bind (symbol . adjustment) item
8.5586- (case symbol
8.5587- ((sb-c::*undefined-warnings*)
8.5588- (setf sb-c::*undefined-warnings*
8.5589- (nconc (mapcan
8.5590- #'(lambda (stuff)
8.5591- (destructuring-bind (kind name count . rest) stuff
8.5592- (unless (case kind (:function (fboundp name)))
8.5593- (list
8.5594- (sb-c::make-undefined-warning
8.5595- :name name
8.5596- :kind kind
8.5597- :count count
8.5598- :warnings
8.5599- (mapcar #'(lambda (x)
8.5600- (apply #'sb-c::make-compiler-error-context x))
8.5601- rest))))))
8.5602- adjustment)
8.5603- sb-c::*undefined-warnings*)))
8.5604- (otherwise
8.5605- (set symbol (+ (symbol-value symbol) adjustment)))))))
8.5606-
8.5607- (defun reset-deferred-warnings ()
8.5608- "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT.
8.5609-One of three functions required for deferred-warnings support in ASDF."
8.5610- #+allegro
8.5611- (setf excl::.functions-defined. nil
8.5612- excl::.functions-called. nil)
8.5613- #+clozure
8.5614- (if-let (dw ccl::*outstanding-deferred-warnings*)
8.5615- (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
8.5616- (setf (ccl::deferred-warnings.warnings mdw) nil)))
8.5617- #+(or cmucl scl)
8.5618- (when lisp::*in-compilation-unit*
8.5619- (setf c::*undefined-warnings* nil
8.5620- c::*compiler-error-count* 0
8.5621- c::*compiler-warning-count* 0
8.5622- c::*compiler-note-count* 0))
8.5623- #+sbcl
8.5624- (when sb-c::*in-compilation-unit*
8.5625- (setf sb-c::*undefined-warnings* nil
8.5626- sb-c::*aborted-compilation-unit-count* 0
8.5627- sb-c::*compiler-error-count* 0
8.5628- sb-c::*compiler-warning-count* 0
8.5629- sb-c::*compiler-style-warning-count* 0
8.5630- sb-c::*compiler-note-count* 0)))
8.5631-
8.5632- (defun save-deferred-warnings (warnings-file)
8.5633- "Save forward reference conditions so they may be issued at a latter time,
8.5634-possibly in a different process."
8.5635- (with-open-file (s warnings-file :direction :output :if-exists :supersede
8.5636- :element-type *default-stream-element-type*
8.5637- :external-format *utf-8-external-format*)
8.5638- (with-safe-io-syntax ()
8.5639- (let ((*read-eval* t))
8.5640- (write (reify-deferred-warnings) :stream s :pretty t :readably t))
8.5641- (terpri s))))
8.5642-
8.5643- (defun warnings-file-type (&optional implementation-type)
8.5644- "The pathname type for warnings files on given IMPLEMENTATION-TYPE,
8.5645-where NIL designates the current one"
8.5646- (case (or implementation-type *implementation-type*)
8.5647- ((:acl :allegro) "allegro-warnings")
8.5648- ;;((:clisp) "clisp-warnings")
8.5649- ((:cmu :cmucl) "cmucl-warnings")
8.5650- ((:sbcl) "sbcl-warnings")
8.5651- ((:clozure :ccl) "ccl-warnings")
8.5652- ((:scl) "scl-warnings")))
8.5653-
8.5654- (defvar *warnings-file-type* nil
8.5655- "Pathname type for warnings files, or NIL if disabled")
8.5656-
8.5657- (defun enable-deferred-warnings-check ()
8.5658- "Enable the saving of deferred warnings"
8.5659- (setf *warnings-file-type* (warnings-file-type)))
8.5660-
8.5661- (defun disable-deferred-warnings-check ()
8.5662- "Disable the saving of deferred warnings"
8.5663- (setf *warnings-file-type* nil))
8.5664-
8.5665- (defun warnings-file-p (file &optional implementation-type)
8.5666- "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
8.5667-If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
8.5668- (if-let (type (if implementation-type
8.5669- (warnings-file-type implementation-type)
8.5670- *warnings-file-type*))
8.5671- (equal (pathname-type file) type)))
8.5672-
8.5673- (defun check-deferred-warnings (files &optional context-format context-arguments)
8.5674- "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
8.5675-re-intern and raise any warnings that are still meaningful."
8.5676- (let ((file-errors nil)
8.5677- (failure-p nil)
8.5678- (warnings-p nil))
8.5679- (handler-bind
8.5680- ((warning #'(lambda (c)
8.5681- (setf warnings-p t)
8.5682- (unless (typep c 'style-warning)
8.5683- (setf failure-p t)))))
8.5684- (with-compilation-unit (:override t)
8.5685- (reset-deferred-warnings)
8.5686- (dolist (file files)
8.5687- (unreify-deferred-warnings
8.5688- (handler-case
8.5689- (with-safe-io-syntax ()
8.5690- (let ((*read-eval* t))
8.5691- (read-file-form file)))
8.5692- (error (c)
8.5693- ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
8.5694- (push c file-errors)
8.5695- nil))))))
8.5696- (dolist (error file-errors) (error error))
8.5697- (check-lisp-compile-warnings
8.5698- (or failure-p warnings-p) failure-p context-format context-arguments)))
8.5699-
8.5700- #|
8.5701- Mini-guide to adding support for deferred warnings on an implementation.
8.5702-
8.5703- First, look at what such a warning looks like:
8.5704-
8.5705- (describe
8.5706- (handler-case
8.5707- (and (eval '(lambda () (some-undefined-function))) nil)
8.5708- (t (c) c)))
8.5709-
8.5710- Then you can grep for the condition type in your compiler sources
8.5711- and see how to catch those that have been deferred,
8.5712- and/or read, clear and restore the deferred list.
8.5713-
8.5714- Also look at
8.5715- (macroexpand-1 '(with-compilation-unit () foo))
8.5716- |#
8.5717-
8.5718- (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring)
8.5719- "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
8.5720-and save those warnings to the given file for latter use,
8.5721-possibly in a different process. Otherwise just call THUNK."
8.5722- (declare (ignorable source-namestring))
8.5723- (if warnings-file
8.5724- (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring)
8.5725- (unwind-protect
8.5726- (let (#+sbcl (sb-c::*undefined-warnings* nil))
8.5727- (multiple-value-prog1
8.5728- (funcall thunk)
8.5729- (save-deferred-warnings warnings-file)))
8.5730- (reset-deferred-warnings)))
8.5731- (funcall thunk)))
8.5732-
8.5733- (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body)
8.5734- "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
8.5735- `(call-with-saved-deferred-warnings
8.5736- #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring)))
8.5737-
8.5738-
8.5739-;;; from ASDF
8.5740-(with-upgradability ()
8.5741- (defun current-lisp-file-pathname ()
8.5742- "Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
8.5743- (or *compile-file-pathname* *load-pathname*))
8.5744-
8.5745- (defun load-pathname ()
8.5746- "Portably return the LOAD-PATHNAME of the current source file or fasl.
8.5747- May return a relative pathname."
8.5748- *load-pathname*) ;; magic no longer needed for GCL.
8.5749-
8.5750- (defun lispize-pathname (input-file)
8.5751- "From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
8.5752- (make-pathname :type "lisp" :defaults input-file))
8.5753-
8.5754- (defun compile-file-type (&rest keys)
8.5755- "pathname TYPE for lisp FASt Loading files"
8.5756- (declare (ignorable keys))
8.5757- #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
8.5758- #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
8.5759-
8.5760- (defun call-around-hook (hook function)
8.5761- "Call a HOOK around the execution of FUNCTION"
8.5762- (call-function (or hook 'funcall) function))
8.5763-
8.5764- (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
8.5765- "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
8.5766- (let* ((keys
8.5767- (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format
8.5768- ,@(unless output-file '(:output-file))) keys)))
8.5769- (if (absolute-pathname-p output-file)
8.5770- ;; what cfp should be doing, w/ mp* instead of mp
8.5771- (let* ((type (pathname-type (apply 'compile-file-type keys)))
8.5772- (defaults (make-pathname
8.5773- :type type :defaults (merge-pathnames* input-file))))
8.5774- (merge-pathnames* output-file defaults))
8.5775- (funcall *output-translation-function*
8.5776- (apply 'compile-file-pathname input-file keys)))))
8.5777-
8.5778- (defvar *compile-check* nil
8.5779- "A hook for user-defined compile-time invariants")
8.5780-
8.5781- (defun compile-file* (input-file &rest keys
8.5782- &key (compile-check *compile-check*) output-file warnings-file
8.5783- #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl
8.5784- &allow-other-keys)
8.5785- "This function provides a portable wrapper around COMPILE-FILE.
8.5786-It ensures that the OUTPUT-FILE value is only returned and
8.5787-the file only actually created if the compilation was successful,
8.5788-even though your implementation may not do that. It also checks an optional
8.5789-user-provided consistency function COMPILE-CHECK to determine success;
8.5790-it will call this function if not NIL at the end of the compilation
8.5791-with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
8.5792-where TMP-FILE is the name of a temporary output-file.
8.5793-It also checks two flags (with legacy british spelling from ASDF1),
8.5794-*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
8.5795-with appropriate implementation-dependent defaults,
8.5796-and if a failure (respectively warnings) are reported by COMPILE-FILE,
8.5797-it will consider that an error unless the respective behaviour flag
8.5798-is one of :SUCCESS :WARN :IGNORE.
8.5799-If WARNINGS-FILE is defined, deferred warnings are saved to that file.
8.5800-On ECL or MKCL, it creates both the linkable object and loadable fasl files.
8.5801-On implementations that erroneously do not recognize standard keyword arguments,
8.5802-it will filter them appropriately."
8.5803- #+(or clasp ecl)
8.5804- (when (and object-file (equal (compile-file-type) (pathname object-file)))
8.5805- (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
8.5806- 'compile-file* output-file object-file)
8.5807- (rotatef output-file object-file))
8.5808- (let* ((keywords (remove-plist-keys
8.5809- `(:output-file :compile-check :warnings-file
8.5810- #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys))
8.5811- (output-file
8.5812- (or output-file
8.5813- (apply 'compile-file-pathname* input-file :output-file output-file keywords)))
8.5814- (physical-output-file (physicalize-pathname output-file))
8.5815- #+(or clasp ecl)
8.5816- (object-file
8.5817- (unless (use-ecl-byte-compiler-p)
8.5818- (or object-file
8.5819- #+ecl (compile-file-pathname output-file :type :object)
8.5820- #+clasp (compile-file-pathname output-file :output-type :object))))
8.5821- #+mkcl
8.5822- (object-file
8.5823- (or object-file
8.5824- (compile-file-pathname output-file :fasl-p nil)))
8.5825- (tmp-file (tmpize-pathname physical-output-file))
8.5826- #+clasp
8.5827- (tmp-object-file (compile-file-pathname tmp-file :output-type :object))
8.5828- #+sbcl
8.5829- (cfasl-file (etypecase emit-cfasl
8.5830- (null nil)
8.5831- ((eql t) (make-pathname :type "cfasl" :defaults physical-output-file))
8.5832- (string (parse-namestring emit-cfasl))
8.5833- (pathname emit-cfasl)))
8.5834- #+sbcl
8.5835- (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
8.5836- #+clisp
8.5837- (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
8.5838- (multiple-value-bind (output-truename warnings-p failure-p)
8.5839- (with-enough-pathname (input-file :defaults *base-build-directory*)
8.5840- (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
8.5841- (with-muffled-compiler-conditions ()
8.5842- (or #-(or clasp ecl mkcl)
8.5843- (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t))
8.5844- (apply 'compile-file input-file :output-file tmp-file
8.5845- #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
8.5846- #-sbcl keywords))
8.5847- #+ecl (apply 'compile-file input-file :output-file
8.5848- (if object-file
8.5849- (list* object-file :system-p t keywords)
8.5850- (list* tmp-file keywords)))
8.5851- #+clasp (apply 'compile-file input-file :output-file
8.5852- (if object-file
8.5853- (list* tmp-object-file :output-type :object #|:system-p t|# keywords)
8.5854- (list* tmp-file keywords)))
8.5855- #+mkcl (apply 'compile-file input-file
8.5856- :output-file object-file :fasl-p nil keywords)))))
8.5857- (cond
8.5858- ((and output-truename
8.5859- (flet ((check-flag (flag behaviour)
8.5860- (or (not flag) (member behaviour '(:success :warn :ignore)))))
8.5861- (and (check-flag failure-p *compile-file-failure-behaviour*)
8.5862- (check-flag warnings-p *compile-file-warnings-behaviour*)))
8.5863- (progn
8.5864- #+(or clasp ecl mkcl)
8.5865- (when (and #+(or clasp ecl) object-file)
8.5866- (setf output-truename
8.5867- (compiler::build-fasl tmp-file
8.5868- #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list #+clasp tmp-object-file #-clasp object-file))))
8.5869- (or (not compile-check)
8.5870- (apply compile-check input-file
8.5871- :output-file output-truename
8.5872- keywords))))
8.5873- (delete-file-if-exists physical-output-file)
8.5874- (when output-truename
8.5875- ;; see CLISP bug 677
8.5876- #+clisp
8.5877- (progn
8.5878- (setf tmp-lib (make-pathname :type "lib" :defaults output-truename))
8.5879- (unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file)))
8.5880- (rename-file-overwriting-target tmp-lib lib-file))
8.5881- #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
8.5882- #+clasp
8.5883- (progn
8.5884- ;;; the following 4 rename-file-overwriting-target better be atomic, but we can't implement this right now
8.5885- #+:target-os-darwin
8.5886- (let ((temp-dwarf (pathname (strcat (namestring output-truename) ".dwarf")))
8.5887- (target-dwarf (pathname (strcat (namestring physical-output-file) ".dwarf"))))
8.5888- (when (probe-file temp-dwarf)
8.5889- (rename-file-overwriting-target temp-dwarf target-dwarf)))
8.5890- ;;; need to rename the bc or ll file as well or test-bundle.script fails
8.5891- ;;; They might not exist with parallel compilation
8.5892- (let ((bitcode-src (compile-file-pathname tmp-file :output-type :bitcode))
8.5893- (bitcode-target (compile-file-pathname physical-output-file :output-type :bitcode)))
8.5894- (when (probe-file bitcode-src)
8.5895- (rename-file-overwriting-target bitcode-src bitcode-target)))
8.5896- (rename-file-overwriting-target tmp-object-file object-file))
8.5897- (rename-file-overwriting-target output-truename physical-output-file)
8.5898- (setf output-truename (truename physical-output-file)))
8.5899- #+clasp (delete-file-if-exists tmp-file)
8.5900- #+clisp (progn (delete-file-if-exists tmp-file) ;; this one works around clisp BUG 677
8.5901- (delete-file-if-exists tmp-lib))) ;; this one is "normal" defensive cleanup
8.5902- (t ;; error or failed check
8.5903- (delete-file-if-exists output-truename)
8.5904- #+clisp (delete-file-if-exists tmp-lib)
8.5905- #+sbcl (delete-file-if-exists tmp-cfasl)
8.5906- (setf output-truename nil)))
8.5907- (values output-truename warnings-p failure-p))))
8.5908-
8.5909- (defun load* (x &rest keys &key &allow-other-keys)
8.5910- "Portable wrapper around LOAD that properly handles loading from a stream."
8.5911- (with-muffled-loader-conditions ()
8.5912- (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t))
8.5913- (etypecase x
8.5914- ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
8.5915- (apply 'load x keys))
8.5916- ;; Genera can't load from a string-input-stream
8.5917- ;; ClozureCL 1.6 can only load from file input stream
8.5918- ;; Allegro 5, I don't remember but it must have been broken when I tested.
8.5919- #+(or allegro clozure genera)
8.5920- (stream ;; make do this way
8.5921- (let ((*package* *package*)
8.5922- (*readtable* *readtable*)
8.5923- (*load-pathname* nil)
8.5924- (*load-truename* nil))
8.5925- (eval-input x)))))))
8.5926-
8.5927- (defun load-from-string (string)
8.5928- "Portably read and evaluate forms from a STRING."
8.5929- (with-input-from-string (s string) (load* s))))
8.5930-
8.5931-;;; Links FASLs together
8.5932-(with-upgradability ()
8.5933- (defun combine-fasls (inputs output)
8.5934- "Combine a list of FASLs INPUTS into a single FASL OUTPUT"
8.5935- #-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl)
8.5936- (not-implemented-error 'combine-fasls "~%inputs: ~S~%output: ~S" inputs output)
8.5937- #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
8.5938- #+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output)
8.5939- #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
8.5940- #+lispworks
8.5941- (let (fasls)
8.5942- (unwind-protect
8.5943- (progn
8.5944- (loop :for i :in inputs
8.5945- :for n :from 1
8.5946- :for f = (add-pathname-suffix
8.5947- output (format nil "-FASL~D" n))
8.5948- :do (copy-file i f)
8.5949- (push f fasls))
8.5950- (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
8.5951- (eval `(scm:defsystem :fasls-to-concatenate
8.5952- (:default-pathname ,(pathname-directory-pathname output))
8.5953- :members
8.5954- ,(loop :for f :in (reverse fasls)
8.5955- :collect `(,(namestring f) :load-only t))))
8.5956- (scm:concatenate-system output :fasls-to-concatenate :force t))
8.5957- (loop :for f :in fasls :do (ignore-errors (delete-file f)))
8.5958- (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
8.5959-;;;; -------------------------------------------------------------------------
8.5960-;;;; launch-program - semi-portably spawn asynchronous subprocesses
8.5961-
8.5962-(uiop/package:define-package :uiop/launch-program
8.5963- (:use :uiop/common-lisp :uiop/package :uiop/utility
8.5964- :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream
8.5965- :uiop/version)
8.5966- (:export
8.5967- ;;; Escaping the command invocation madness
8.5968- #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
8.5969- #:escape-windows-token #:escape-windows-command
8.5970- #:escape-shell-token #:escape-shell-command
8.5971- #:escape-token #:escape-command
8.5972-
8.5973- ;;; launch-program
8.5974- #:launch-program
8.5975- #:close-streams #:process-alive-p #:terminate-process #:wait-process
8.5976- #:process-info
8.5977- #:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid))
8.5978-(in-package :uiop/launch-program)
8.5979-
8.5980-;;;; ----- Escaping strings for the shell -----
8.5981-(with-upgradability ()
8.5982- (defun requires-escaping-p (token &key good-chars bad-chars)
8.5983- "Does this token require escaping, given the specification of
8.5984-either good chars that don't need escaping or bad chars that do need escaping,
8.5985-as either a recognizing function or a sequence of characters."
8.5986- (some
8.5987- (cond
8.5988- ((and good-chars bad-chars)
8.5989- (parameter-error "~S: only one of good-chars and bad-chars can be provided"
8.5990- 'requires-escaping-p))
8.5991- ((typep good-chars 'function)
8.5992- (complement good-chars))
8.5993- ((typep bad-chars 'function)
8.5994- bad-chars)
8.5995- ((and good-chars (typep good-chars 'sequence))
8.5996- #'(lambda (c) (not (find c good-chars))))
8.5997- ((and bad-chars (typep bad-chars 'sequence))
8.5998- #'(lambda (c) (find c bad-chars)))
8.5999- (t (parameter-error "~S: no good-char criterion" 'requires-escaping-p)))
8.6000- token))
8.6001-
8.6002- (defun escape-token (token &key stream quote good-chars bad-chars escaper)
8.6003- "Call the ESCAPER function on TOKEN string if it needs escaping as per
8.6004-REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
8.6005-using STREAM as output (or returning result as a string if NIL)"
8.6006- (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
8.6007- (with-output (stream)
8.6008- (apply escaper token stream (when quote `(:quote ,quote))))
8.6009- (output-string token stream)))
8.6010-
8.6011- (defun escape-windows-token-within-double-quotes (x &optional s)
8.6012- "Escape a string token X within double-quotes
8.6013-for use within a MS Windows command-line, outputing to S."
8.6014- (labels ((issue (c) (princ c s))
8.6015- (issue-backslash (n) (loop :repeat n :do (issue #\\))))
8.6016- (loop
8.6017- :initially (issue #\") :finally (issue #\")
8.6018- :with l = (length x) :with i = 0
8.6019- :for i+1 = (1+ i) :while (< i l) :do
8.6020- (case (char x i)
8.6021- ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
8.6022- ((#\\)
8.6023- (let* ((j (and (< i+1 l) (position-if-not
8.6024- #'(lambda (c) (eql c #\\)) x :start i+1)))
8.6025- (n (- (or j l) i)))
8.6026- (cond
8.6027- ((null j)
8.6028- (issue-backslash (* 2 n)) (setf i l))
8.6029- ((and (< j l) (eql (char x j) #\"))
8.6030- (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
8.6031- (t
8.6032- (issue-backslash n) (setf i j)))))
8.6033- (otherwise
8.6034- (issue (char x i)) (setf i i+1))))))
8.6035-
8.6036- (defun easy-windows-character-p (x)
8.6037- "Is X an \"easy\" character that does not require quoting by the shell?"
8.6038- (or (alphanumericp x) (find x "+-_.,@:/=")))
8.6039-
8.6040- (defun escape-windows-token (token &optional s)
8.6041- "Escape a string TOKEN within double-quotes if needed
8.6042-for use within a MS Windows command-line, outputing to S."
8.6043- (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
8.6044- :escaper 'escape-windows-token-within-double-quotes))
8.6045-
8.6046- (defun escape-sh-token-within-double-quotes (x s &key (quote t))
8.6047- "Escape a string TOKEN within double-quotes
8.6048-for use within a POSIX Bourne shell, outputing to S;
8.6049-omit the outer double-quotes if key argument :QUOTE is NIL"
8.6050- (when quote (princ #\" s))
8.6051- (loop :for c :across x :do
8.6052- (when (find c "$`\\\"") (princ #\\ s))
8.6053- (princ c s))
8.6054- (when quote (princ #\" s)))
8.6055-
8.6056- (defun easy-sh-character-p (x)
8.6057- "Is X an \"easy\" character that does not require quoting by the shell?"
8.6058- (or (alphanumericp x) (find x "+-_.,%@:/=")))
8.6059-
8.6060- (defun escape-sh-token (token &optional s)
8.6061- "Escape a string TOKEN within double-quotes if needed
8.6062-for use within a POSIX Bourne shell, outputing to S."
8.6063- (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p
8.6064- :escaper 'escape-sh-token-within-double-quotes))
8.6065-
8.6066- (defun escape-shell-token (token &optional s)
8.6067- "Escape a token for the current operating system shell"
8.6068- (os-cond
8.6069- ((os-unix-p) (escape-sh-token token s))
8.6070- ((os-windows-p) (escape-windows-token token s))))
8.6071-
8.6072- (defun escape-command (command &optional s
8.6073- (escaper 'escape-shell-token))
8.6074- "Given a COMMAND as a list of tokens, return a string of the
8.6075-spaced, escaped tokens, using ESCAPER to escape."
8.6076- (etypecase command
8.6077- (string (output-string command s))
8.6078- (list (with-output (s)
8.6079- (loop :for first = t :then nil :for token :in command :do
8.6080- (unless first (princ #\space s))
8.6081- (funcall escaper token s))))))
8.6082-
8.6083- (defun escape-windows-command (command &optional s)
8.6084- "Escape a list of command-line arguments into a string suitable for parsing
8.6085-by CommandLineToArgv in MS Windows"
8.6086- ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
8.6087- ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
8.6088- (escape-command command s 'escape-windows-token))
8.6089-
8.6090- (defun escape-sh-command (command &optional s)
8.6091- "Escape a list of command-line arguments into a string suitable for parsing
8.6092-by /bin/sh in POSIX"
8.6093- (escape-command command s 'escape-sh-token))
8.6094-
8.6095- (defun escape-shell-command (command &optional stream)
8.6096- "Escape a command for the current operating system's shell"
8.6097- (escape-command command stream 'escape-shell-token)))
8.6098-
8.6099-
8.6100-(with-upgradability ()
8.6101- ;;; Internal helpers for run-program
8.6102- (defun %normalize-io-specifier (specifier &optional role)
8.6103- "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent
8.6104-argument to pass to the internal RUN-PROGRAM"
8.6105- (declare (ignorable role))
8.6106- (typecase specifier
8.6107- (null (or #+(or allegro lispworks) (null-device-pathname)))
8.6108- (string (parse-native-namestring specifier))
8.6109- (pathname specifier)
8.6110- (stream specifier)
8.6111- ((eql :stream) :stream)
8.6112- ((eql :interactive)
8.6113- #+(or allegro lispworks) nil
8.6114- #+clisp :terminal
8.6115- #+(or abcl clasp clozure cmucl ecl mkcl sbcl scl) t
8.6116- #-(or abcl clasp clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp)
8.6117- (not-implemented-error :interactive-output
8.6118- "On this lisp implementation, cannot interpret ~a value of ~a"
8.6119- specifier role))
8.6120- ((eql :output)
8.6121- (cond ((eq role :error-output)
8.6122- #+(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
8.6123- :output
8.6124- #-(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
8.6125- (not-implemented-error :error-output-redirect
8.6126- "Can't send ~a to ~a on this lisp implementation."
8.6127- role specifier))
8.6128- (t (parameter-error "~S IO specifier invalid for ~S" specifier role))))
8.6129- ((eql t)
8.6130- #+ (or lispworks abcl)
8.6131- (not-implemented-error :interactive-output
8.6132- "On this lisp implementation, cannot interpret ~a value of ~a"
8.6133- specifier role)
8.6134- #- (or lispworks abcl)
8.6135- (cond ((eq role :error-output) *error-output*)
8.6136- ((eq role :output) #+lispworks *terminal-io* #-lispworks *standard-output*)
8.6137- ((eq role :input) *standard-input*)))
8.6138- (otherwise
8.6139- (parameter-error "Incorrect I/O specifier ~S for ~S"
8.6140- specifier role))))
8.6141-
8.6142- (defun %interactivep (input output error-output)
8.6143- (member :interactive (list input output error-output)))
8.6144-
8.6145- (defun %signal-to-exit-code (signum)
8.6146- (+ 128 signum))
8.6147-
8.6148- (defun %code-to-status (exit-code signal-code)
8.6149- (cond ((null exit-code) :running)
8.6150- ((null signal-code) (values :exited exit-code))
8.6151- (t (values :signaled signal-code))))
8.6152-
8.6153- #+mkcl
8.6154- (defun %mkcl-signal-to-number (signal)
8.6155- (require :mk-unix)
8.6156- (symbol-value (find-symbol signal :mk-unix)))
8.6157-
8.6158- (defclass process-info ()
8.6159- (;; The process field is highly platform-, implementation-, and
8.6160- ;; even version-dependent.
8.6161- ;; Prior to LispWorks 7, the only information that
8.6162- ;; `sys:run-shell-command` with `:wait nil` was certain to return
8.6163- ;; is a PID (e.g. when all streams are nil), hence we stored it
8.6164- ;; and used `sys:pid-exit-status` to obtain an exit status
8.6165- ;; later. That is still what we do.
8.6166- ;; From LispWorks 7 on, if `sys:run-shell-command` does not
8.6167- ;; return a proper stream, we are instead given a dummy stream.
8.6168- ;; We can thus always store a stream and use
8.6169- ;; `sys:pipe-exit-status` to obtain an exit status later.
8.6170- ;; The advantage of dealing with streams instead of PID is the
8.6171- ;; availability of functions like `sys:pipe-kill-process`.
8.6172- (process :initform nil)
8.6173- (input-stream :initform nil)
8.6174- (output-stream :initform nil)
8.6175- (bidir-stream :initform nil)
8.6176- (error-output-stream :initform nil)
8.6177- ;; For backward-compatibility, to maintain the property (zerop
8.6178- ;; exit-code) <-> success, an exit in response to a signal is
8.6179- ;; encoded as 128+signum.
8.6180- (exit-code :initform nil)
8.6181- ;; If the platform allows it, distinguish exiting with a code
8.6182- ;; >128 from exiting in response to a signal by setting this code
8.6183- (signal-code :initform nil))
8.6184- (:documentation "This class should be treated as opaque by programmers, except for the
8.6185-exported PROCESS-INFO-* functions. It should never be directly instantiated by
8.6186-MAKE-INSTANCE. Primarily, it is being made available to enable type-checking."))
8.6187-
8.6188-;;;---------------------------------------------------------------------------
8.6189-;;; The following two helper functions take care of handling the IF-EXISTS and
8.6190-;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the
8.6191-;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master
8.6192-;;; function to treat input and output files unconditionally for reading and
8.6193-;;; writing.
8.6194-;;;---------------------------------------------------------------------------
8.6195-
8.6196- (defun %handle-if-exists (file if-exists)
8.6197- (when (or (stringp file) (pathnamep file))
8.6198- (ecase if-exists
8.6199- ((:append :supersede :error)
8.6200- (with-open-file (dummy file :direction :output :if-exists if-exists)
8.6201- (declare (ignorable dummy)))))))
8.6202-
8.6203- (defun %handle-if-does-not-exist (file if-does-not-exist)
8.6204- (when (or (stringp file) (pathnamep file))
8.6205- (ecase if-does-not-exist
8.6206- ((:create :error)
8.6207- (with-open-file (dummy file :direction :probe
8.6208- :if-does-not-exist if-does-not-exist)
8.6209- (declare (ignorable dummy)))))))
8.6210-
8.6211- (defun process-info-error-output (process-info)
8.6212- (slot-value process-info 'error-output-stream))
8.6213- (defun process-info-input (process-info)
8.6214- (or (slot-value process-info 'bidir-stream)
8.6215- (slot-value process-info 'input-stream)))
8.6216- (defun process-info-output (process-info)
8.6217- (or (slot-value process-info 'bidir-stream)
8.6218- (slot-value process-info 'output-stream)))
8.6219-
8.6220- (defun process-info-pid (process-info)
8.6221- (let ((process (slot-value process-info 'process)))
8.6222- (declare (ignorable process))
8.6223- #+abcl (symbol-call :sys :process-pid process)
8.6224- #+allegro process
8.6225- #+clasp (if (find-symbol* '#:external-process-pid :ext nil)
8.6226- (symbol-call :ext '#:external-process-pid process)
8.6227- (not-implemented-error 'process-info-pid))
8.6228- #+clozure (ccl:external-process-id process)
8.6229- #+ecl (ext:external-process-pid process)
8.6230- #+(or cmucl scl) (ext:process-pid process)
8.6231- #+lispworks7+ (sys:pipe-pid process)
8.6232- #+(and lispworks (not lispworks7+)) process
8.6233- #+mkcl (mkcl:process-id process)
8.6234- #+sbcl (sb-ext:process-pid process)
8.6235- #-(or abcl allegro clasp clozure cmucl ecl mkcl lispworks sbcl scl)
8.6236- (not-implemented-error 'process-info-pid)))
8.6237-
8.6238- (defun %process-status (process-info)
8.6239- (if-let (exit-code (slot-value process-info 'exit-code))
8.6240- (return-from %process-status
8.6241- (if-let (signal-code (slot-value process-info 'signal-code))
8.6242- (values :signaled signal-code)
8.6243- (values :exited exit-code))))
8.6244- #-(or allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
8.6245- (not-implemented-error '%process-status)
8.6246- (if-let (process (slot-value process-info 'process))
8.6247- (multiple-value-bind (status code)
8.6248- (progn
8.6249- #+allegro (multiple-value-bind (exit-code pid signal-code)
8.6250- (sys:reap-os-subprocess :pid process :wait nil)
8.6251- (assert pid)
8.6252- (%code-to-status exit-code signal-code))
8.6253- #+clasp (if (find-symbol* '#:external-process-status :ext nil)
8.6254- (symbol-call :ext '#:external-process-status process)
8.6255- (not-implemented-error '%process-status))
8.6256- #+clozure (ccl:external-process-status process)
8.6257- #+(or cmucl scl) (let ((status (ext:process-status process)))
8.6258- (if (member status '(:exited :signaled))
8.6259- ;; Calling ext:process-exit-code on
8.6260- ;; processes that are still alive
8.6261- ;; yields an undefined result
8.6262- (values status (ext:process-exit-code process))
8.6263- status))
8.6264- #+ecl (ext:external-process-status process)
8.6265- #+lispworks
8.6266- ;; a signal is only returned on LispWorks 7+
8.6267- (multiple-value-bind (exit-code signal-code)
8.6268- (symbol-call :sys
8.6269- #+lispworks7+ :pipe-exit-status
8.6270- #-lispworks7+ :pid-exit-status
8.6271- process :wait nil)
8.6272- (%code-to-status exit-code signal-code))
8.6273- #+mkcl (let ((status (mk-ext:process-status process)))
8.6274- (if (eq status :exited)
8.6275- ;; Only call mk-ext:process-exit-code when
8.6276- ;; necessary since it leads to another waitpid()
8.6277- (let ((code (mk-ext:process-exit-code process)))
8.6278- (if (stringp code)
8.6279- (values :signaled (%mkcl-signal-to-number code))
8.6280- (values :exited code)))
8.6281- status))
8.6282- #+sbcl (let ((status (sb-ext:process-status process)))
8.6283- (if (eq status :running)
8.6284- :running
8.6285- ;; sb-ext:process-exit-code can also be
8.6286- ;; called for stopped processes to determine
8.6287- ;; the signal that stopped them
8.6288- (values status (sb-ext:process-exit-code process)))))
8.6289- (case status
8.6290- (:exited (setf (slot-value process-info 'exit-code) code))
8.6291- (:signaled (let ((%code (%signal-to-exit-code code)))
8.6292- (setf (slot-value process-info 'exit-code) %code
8.6293- (slot-value process-info 'signal-code) code))))
8.6294- (if code
8.6295- (values status code)
8.6296- status))))
8.6297-
8.6298- (defun process-alive-p (process-info)
8.6299- "Check if a process has yet to exit."
8.6300- (unless (slot-value process-info 'exit-code)
8.6301- #+abcl (sys:process-alive-p (slot-value process-info 'process))
8.6302- #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
8.6303- #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
8.6304- #-(or abcl cmucl sbcl scl) (find (%process-status process-info)
8.6305- '(:running :stopped :continued :resumed))))
8.6306-
8.6307- (defun wait-process (process-info)
8.6308- "Wait for the process to terminate, if it is still running.
8.6309-Otherwise, return immediately. An exit code (a number) will be
8.6310-returned, with 0 indicating success, and anything else indicating
8.6311-failure. If the process exits after receiving a signal, the exit code
8.6312-will be the sum of 128 and the (positive) numeric signal code. A second
8.6313-value may be returned in this case: the numeric signal code itself.
8.6314-Any asynchronously spawned process requires this function to be run
8.6315-before it is garbage-collected in order to free up resources that
8.6316-might otherwise be irrevocably lost."
8.6317- (if-let (exit-code (slot-value process-info 'exit-code))
8.6318- (if-let (signal-code (slot-value process-info 'signal-code))
8.6319- (values exit-code signal-code)
8.6320- exit-code)
8.6321- (let ((process (slot-value process-info 'process)))
8.6322- #-(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
8.6323- (not-implemented-error 'wait-process)
8.6324- (when process
8.6325- ;; 1- wait
8.6326- #+clozure (ccl::external-process-wait process)
8.6327- #+(or cmucl scl) (ext:process-wait process)
8.6328- #+sbcl (sb-ext:process-wait process)
8.6329- ;; 2- extract result
8.6330- (multiple-value-bind (exit-code signal-code)
8.6331- (progn
8.6332- #+abcl (sys:process-wait process)
8.6333- #+allegro (multiple-value-bind (exit-code pid signal)
8.6334- (sys:reap-os-subprocess :pid process :wait t)
8.6335- (assert pid)
8.6336- (values exit-code signal))
8.6337- #+clasp (if (find-symbol* '#:external-process-wait :ext nil)
8.6338- (multiple-value-bind (status code)
8.6339- (symbol-call :ext '#:external-process-wait process t)
8.6340- (if (eq status :signaled)
8.6341- (values nil code)
8.6342- code))
8.6343- (not-implemented-error 'wait-process))
8.6344- #+clozure (multiple-value-bind (status code)
8.6345- (ccl:external-process-status process)
8.6346- (if (eq status :signaled)
8.6347- (values nil code)
8.6348- code))
8.6349- #+(or cmucl scl) (let ((status (ext:process-status process))
8.6350- (code (ext:process-exit-code process)))
8.6351- (if (eq status :signaled)
8.6352- (values nil code)
8.6353- code))
8.6354- #+ecl (multiple-value-bind (status code)
8.6355- (ext:external-process-wait process t)
8.6356- (if (eq status :signaled)
8.6357- (values nil code)
8.6358- code))
8.6359- #+lispworks (symbol-call :sys
8.6360- #+lispworks7+ :pipe-exit-status
8.6361- #-lispworks7+ :pid-exit-status
8.6362- process :wait t)
8.6363- #+mkcl (let ((code (mkcl:join-process process)))
8.6364- (if (stringp code)
8.6365- (values nil (%mkcl-signal-to-number code))
8.6366- code))
8.6367- #+sbcl (let ((status (sb-ext:process-status process))
8.6368- (code (sb-ext:process-exit-code process)))
8.6369- (if (eq status :signaled)
8.6370- (values nil code)
8.6371- code)))
8.6372- (if signal-code
8.6373- (let ((%exit-code (%signal-to-exit-code signal-code)))
8.6374- (setf (slot-value process-info 'exit-code) %exit-code
8.6375- (slot-value process-info 'signal-code) signal-code)
8.6376- (values %exit-code signal-code))
8.6377- (progn (setf (slot-value process-info 'exit-code) exit-code)
8.6378- exit-code)))))))
8.6379-
8.6380- ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
8.6381- ;; do what you expect it to. Sending SIGSTOP to a process spawned
8.6382- ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
8.6383- ;; to run the command (via `sh -c command`) but not the actual
8.6384- ;; command.
8.6385- #+os-unix
8.6386- (defun %posix-send-signal (process-info signal)
8.6387- #+allegro (excl.osi:kill (slot-value process-info 'process) signal)
8.6388- #+clozure (ccl:signal-external-process (slot-value process-info 'process)
8.6389- signal :error-if-exited nil)
8.6390- #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
8.6391- #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
8.6392- #-(or allegro clozure cmucl sbcl scl)
8.6393- (if-let (pid (process-info-pid process-info))
8.6394- (symbol-call :uiop :run-program
8.6395- (format nil "kill -~a ~a" signal pid) :ignore-error-status t)))
8.6396-
8.6397- ;;; this function never gets called on Windows, but the compiler cannot tell
8.6398- ;;; that. [2016/09/25:rpg]
8.6399- #+os-windows
8.6400- (defun %posix-send-signal (process-info signal)
8.6401- (declare (ignore process-info signal))
8.6402- (values))
8.6403-
8.6404- (defun terminate-process (process-info &key urgent)
8.6405- "Cause the process to exit. To that end, the process may or may
8.6406-not be sent a signal, which it will find harder (or even impossible)
8.6407-to ignore if URGENT is T. On some platforms, it may also be subject to
8.6408-race conditions."
8.6409- (declare (ignorable urgent))
8.6410- #+abcl (sys:process-kill (slot-value process-info 'process))
8.6411- ;; On ECL, this will only work on versions later than 2016-09-06,
8.6412- ;; but we still want to compile on earlier versions, so we use symbol-call
8.6413- #+(or clasp ecl) (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent)
8.6414- #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
8.6415- #+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
8.6416- :force urgent)
8.6417- #-(or abcl clasp ecl lispworks7+ mkcl)
8.6418- (os-cond
8.6419- ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
8.6420- ((os-windows-p) (if-let (pid (process-info-pid process-info))
8.6421- (symbol-call :uiop :run-program
8.6422- (format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid)
8.6423- :ignore-error-status t)))
8.6424- (t (not-implemented-error 'terminate-process))))
8.6425-
8.6426- (defun close-streams (process-info)
8.6427- "Close any stream that the process might own. Needs to be run
8.6428-whenever streams were requested by passing :stream to :input, :output,
8.6429-or :error-output."
8.6430- (dolist (stream
8.6431- (cons (slot-value process-info 'error-output-stream)
8.6432- (if-let (bidir-stream (slot-value process-info 'bidir-stream))
8.6433- (list bidir-stream)
8.6434- (list (slot-value process-info 'input-stream)
8.6435- (slot-value process-info 'output-stream)))))
8.6436- (when stream (close stream))))
8.6437-
8.6438- (defun launch-program (command &rest keys
8.6439- &key
8.6440- input (if-input-does-not-exist :error)
8.6441- output (if-output-exists :supersede)
8.6442- error-output (if-error-output-exists :supersede)
8.6443- (element-type #-clozure *default-stream-element-type*
8.6444- #+clozure 'character)
8.6445- (external-format *utf-8-external-format*)
8.6446- directory
8.6447- #+allegro separate-streams
8.6448- &allow-other-keys)
8.6449- "Launch program specified by COMMAND,
8.6450-either a list of strings specifying a program and list of arguments,
8.6451-or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
8.6452-Windows) _asynchronously_.
8.6453-
8.6454-If OUTPUT is a pathname, a string designating a pathname, or NIL (the
8.6455-default) designating the null device, the file at that path is used as
8.6456-output.
8.6457-If it's :INTERACTIVE, output is inherited from the current process;
8.6458-beware that this may be different from your *STANDARD-OUTPUT*, and
8.6459-under SLIME will be on your *inferior-lisp* buffer. If it's T, output
8.6460-goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new
8.6461-stream will be made available that can be accessed via
8.6462-PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
8.6463-that the underlying lisp implementation knows how to handle.
8.6464-
8.6465-IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
8.6466-pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
8.6467-default). The meaning of these values and their effect on the case
8.6468-where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
8.6469-to OPEN with :DIRECTION :OUTPUT.
8.6470-
8.6471-ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
8.6472-:OUTPUT means redirecting the error output to the output stream,
8.6473-and :STREAM causes a stream to be made available via
8.6474-PROCESS-INFO-ERROR-OUTPUT.
8.6475-
8.6476-IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
8.6477-affects ERROR-OUTPUT rather than OUTPUT.
8.6478-
8.6479-INPUT is similar to OUTPUT, except that T designates the
8.6480-*STANDARD-INPUT* and a stream requested through the :STREAM keyword
8.6481-would be available through PROCESS-INFO-INPUT.
8.6482-
8.6483-IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
8.6484-or a pathname, can take the values :CREATE and :ERROR (the
8.6485-default). The meaning of these values is analogous to the
8.6486-IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
8.6487-
8.6488-ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp
8.6489-implementation, when applicable, for creation of the output stream.
8.6490-
8.6491-LAUNCH-PROGRAM returns a PROCESS-INFO object.
8.6492-
8.6493-LAUNCH-PROGRAM currently does not smooth over all the differences between
8.6494-implementations. Of particular note is when streams are provided for OUTPUT or
8.6495-ERROR-OUTPUT. Some implementations don't support this at all, some support only
8.6496-certain subclasses of streams, and some support any arbitrary
8.6497-stream. Additionally, the implementations that support streams may have
8.6498-differing behavior on how those streams are filled with data. If data is not
8.6499-periodically read from the child process and sent to the stream, the child
8.6500-could block because its output buffers are full."
8.6501- #-(or abcl allegro clasp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
8.6502- (progn command keys input output error-output directory element-type external-format
8.6503- if-input-does-not-exist if-output-exists if-error-output-exists ;; ignore
8.6504- (not-implemented-error 'launch-program))
8.6505- #+allegro
8.6506- (when (some #'(lambda (stream)
8.6507- (and (streamp stream)
8.6508- (not (file-stream-p stream))))
8.6509- (list input output error-output))
8.6510- (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp"
8.6511- 'launch-program))
8.6512- #+(or abcl clisp lispworks)
8.6513- (when (some #'streamp (list input output error-output))
8.6514- (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
8.6515- 'launch-program))
8.6516- #+clisp
8.6517- (unless (eq error-output :interactive)
8.6518- (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
8.6519- 'launch-program :error-output :interactive))
8.6520- #+(or clasp ecl)
8.6521- (when (and #+ecl (version< (lisp-implementation-version) "20.4.24")
8.6522- (some #'(lambda (stream)
8.6523- (and (streamp stream)
8.6524- (not (file-or-synonym-stream-p stream))))
8.6525- (list input output error-output)))
8.6526- (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
8.6527- 'launch-program))
8.6528- #+(or abcl allegro clasp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
8.6529- (nest
8.6530- (progn ;; see comments for these functions
8.6531- (%handle-if-does-not-exist input if-input-does-not-exist)
8.6532- (%handle-if-exists output if-output-exists)
8.6533- (%handle-if-exists error-output if-error-output-exists))
8.6534- #+(or clasp ecl) (let ((*standard-input* *stdin*)
8.6535- (*standard-output* *stdout*)
8.6536- (*error-output* *stderr*)))
8.6537- (let ((process-info (make-instance 'process-info))
8.6538- (input (%normalize-io-specifier input :input))
8.6539- (output (%normalize-io-specifier output :output))
8.6540- (error-output (%normalize-io-specifier error-output :error-output))
8.6541- #+(and allegro os-windows) (interactive (%interactivep input output error-output))
8.6542- (command
8.6543- (etypecase command
8.6544- #+os-unix (string `("/bin/sh" "-c" ,command))
8.6545- #+os-unix (list command)
8.6546- #+os-windows
8.6547- (string
8.6548- ;; NB: On other Windows implementations, this is utterly bogus
8.6549- ;; except in the most trivial cases where no quoting is needed.
8.6550- ;; Use at your own risk.
8.6551- #-(or allegro clasp clisp clozure ecl)
8.6552- (nest
8.6553- #+(or clasp ecl sbcl) (unless (find-symbol* :escape-arguments #+(or clasp ecl) :ext #+sbcl :sb-impl nil))
8.6554- (parameter-error "~S doesn't support string commands on Windows on this Lisp"
8.6555- 'launch-program command))
8.6556- ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
8.6557- ;; when the command contains spaces or special characters:
8.6558- ;; IIUC, the system will use space as a separator,
8.6559- ;; but the C++ argv-decoding libraries won't, and
8.6560- ;; you're supposed to use an extra argument to CreateProcess to bridge the gap,
8.6561- ;; yet neither allegro nor clisp provide access to that argument.
8.6562- #+(or allegro clisp) (strcat "cmd /c " command)
8.6563- ;; On ClozureCL for Windows, we assume you are using
8.6564- ;; r15398 or later in 1.9 or later,
8.6565- ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
8.6566- ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304
8.6567- ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13)
8.6568- #+(or clasp clozure ecl sbcl) (cons "cmd" (strcat "/c " command)))
8.6569- #+os-windows
8.6570- (list
8.6571- #+allegro (escape-windows-command command)
8.6572- #-allegro command)))))
8.6573- #+(or abcl (and allegro os-unix) clasp clozure cmucl ecl mkcl sbcl)
8.6574- (let ((program (car command))
8.6575- #-allegro (arguments (cdr command))))
8.6576- #+(and (or clasp ecl sbcl) os-windows)
8.6577- (multiple-value-bind (arguments escape-arguments)
8.6578- (if (listp arguments)
8.6579- (values arguments t)
8.6580- (values (list arguments) nil)))
8.6581- #-(or allegro mkcl sbcl) (with-current-directory (directory))
8.6582- (multiple-value-bind
8.6583- #+(or abcl clozure cmucl sbcl scl) (process)
8.6584- #+allegro (in-or-io out-or-err err-or-pid pid-or-nil)
8.6585- #+(or clasp ecl) (stream code process)
8.6586- #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil)
8.6587- #+mkcl (stream process code)
8.6588- #.`(apply
8.6589- #+abcl 'sys:run-program
8.6590- #+allegro ,@'('excl:run-shell-command
8.6591- #+os-unix (coerce (cons program command) 'vector)
8.6592- #+os-windows command)
8.6593- #+clasp (if (find-symbol* '#:run-program :ext nil)
8.6594- (find-symbol* '#:run-program :ext nil)
8.6595- (not-implemented-error 'launch-program))
8.6596- #+clozure 'ccl:run-program
8.6597- #+(or cmucl ecl scl) 'ext:run-program
8.6598-
8.6599- #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed
8.6600- #+mkcl 'mk-ext:run-program
8.6601- #+sbcl 'sb-ext:run-program
8.6602- #+(or abcl clasp clozure cmucl ecl mkcl sbcl) ,@'(program arguments)
8.6603- #+(and (or clasp ecl sbcl) os-windows) ,@'(:escape-arguments escape-arguments)
8.6604- :input input :if-input-does-not-exist :error
8.6605- :output output :if-output-exists :append
8.6606- ,(or #+(or allegro lispworks) :error-output :error) error-output
8.6607- ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append
8.6608- :wait nil :element-type element-type :external-format external-format
8.6609- :allow-other-keys t
8.6610- #+allegro ,@`(:directory directory
8.6611- #+os-windows ,@'(:show-window (if interactive nil :hide)))
8.6612- #+lispworks ,@'(:save-exit-status t)
8.6613- #+mkcl ,@'(:directory (native-namestring directory))
8.6614- #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys
8.6615- #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys)))))
8.6616- (labels ((prop (key value) (setf (slot-value process-info key) value)))
8.6617- #+allegro
8.6618- (cond
8.6619- (separate-streams
8.6620- (prop 'process pid-or-nil)
8.6621- (when (eq input :stream) (prop 'input-stream in-or-io))
8.6622- (when (eq output :stream) (prop 'output-stream out-or-err))
8.6623- (when (eq error-output :stream) (prop 'error-output-stream err-or-pid)))
8.6624- (t
8.6625- (prop 'process err-or-pid)
8.6626- (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
8.6627- (0)
8.6628- (1 (prop 'input-stream in-or-io))
8.6629- (2 (prop 'output-stream in-or-io))
8.6630- (3 (prop 'bidir-stream in-or-io)))
8.6631- (when (eq error-output :stream)
8.6632- (prop 'error-output-stream out-or-err))))
8.6633- #+(or abcl clozure cmucl sbcl scl)
8.6634- (progn
8.6635- (prop 'process process)
8.6636- (when (eq input :stream)
8.6637- (nest
8.6638- (prop 'input-stream)
8.6639- #+abcl (symbol-call :sys :process-input)
8.6640- #+clozure (ccl:external-process-input-stream)
8.6641- #+(or cmucl scl) (ext:process-input)
8.6642- #+sbcl (sb-ext:process-input)
8.6643- process))
8.6644- (when (eq output :stream)
8.6645- (nest
8.6646- (prop 'output-stream)
8.6647- #+abcl (symbol-call :sys :process-output)
8.6648- #+clozure (ccl:external-process-output-stream)
8.6649- #+(or cmucl scl) (ext:process-output)
8.6650- #+sbcl (sb-ext:process-output)
8.6651- process))
8.6652- (when (eq error-output :stream)
8.6653- (nest
8.6654- (prop 'error-output-stream)
8.6655- #+abcl (symbol-call :sys :process-error)
8.6656- #+clozure (ccl:external-process-error-stream)
8.6657- #+(or cmucl scl) (ext:process-error)
8.6658- #+sbcl (sb-ext:process-error)
8.6659- process)))
8.6660- #+(or clasp ecl mkcl)
8.6661- (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
8.6662- code ;; ignore
8.6663- (unless (zerop mode)
8.6664- (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))
8.6665- (when (eq error-output :stream)
8.6666- (prop 'error-output-stream
8.6667- (if (and #+clasp nil #-clasp t (version< (lisp-implementation-version) "16.0.0"))
8.6668- (symbol-call :ext :external-process-error process)
8.6669- (symbol-call :ext :external-process-error-stream process))))
8.6670- (prop 'process process))
8.6671- #+lispworks
8.6672- ;; See also the comments on the process-info class
8.6673- (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
8.6674- (cond
8.6675- ((or (plusp mode) (eq error-output :stream))
8.6676- (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-nil)
8.6677- (when (plusp mode)
8.6678- (prop (ecase mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream))
8.6679- io-or-pid))
8.6680- (when (eq error-output :stream)
8.6681- (prop 'error-output-stream err-or-nil)))
8.6682- ;; Prior to Lispworks 7, this returned (pid); now it
8.6683- ;; returns (io err pid) of which we keep io.
8.6684- (t (prop 'process io-or-pid)))))
8.6685- process-info)))
8.6686-
8.6687-;;;; -------------------------------------------------------------------------
8.6688-;;;; run-program initially from xcvb-driver.
8.6689-
8.6690-(uiop/package:define-package :uiop/run-program
8.6691- (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv.
8.6692- (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version
8.6693- :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program)
8.6694- (:export
8.6695- #:run-program
8.6696- #:slurp-input-stream #:vomit-output-stream
8.6697- #:subprocess-error
8.6698- #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process)
8.6699- (:import-from :uiop/launch-program
8.6700- #:%handle-if-does-not-exist #:%handle-if-exists #:%interactivep
8.6701- #:input-stream #:output-stream #:error-output-stream))
8.6702-(in-package :uiop/run-program)
8.6703-
8.6704-;;;; Slurping a stream, typically the output of another program
8.6705-(with-upgradability ()
8.6706- (defun call-stream-processor (fun processor stream)
8.6707- "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
8.6708-a PROCESSOR specification which is either an atom or a list specifying
8.6709-a processor an keyword arguments, call the specified processor with
8.6710-the given STREAM as input"
8.6711- (if (consp processor)
8.6712- (apply fun (first processor) stream (rest processor))
8.6713- (funcall fun processor stream)))
8.6714-
8.6715- (defgeneric slurp-input-stream (processor input-stream &key)
8.6716- (:documentation
8.6717- "SLURP-INPUT-STREAM is a generic function with two positional arguments
8.6718-PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
8.6719-the contents of the INPUT-STREAM and processes them according to a method
8.6720-specified by PROCESSOR.
8.6721-
8.6722-Built-in methods include the following:
8.6723-* if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
8.6724-* if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the
8.6725- INPUT-STREAM and the rest of the list. That is (x . y) will be treated as
8.6726- \(APPLY x <stream> y\)
8.6727-* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
8.6728- per copy-stream-to-stream, with appropriate keyword arguments.
8.6729-* if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
8.6730- are returned as a string, as per SLURP-STREAM-STRING.
8.6731-* if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
8.6732-* if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
8.6733-* if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
8.6734-* if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
8.6735-* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
8.6736-
8.6737-Programmers are encouraged to define their own methods for this generic function."))
8.6738-
8.6739- #-genera
8.6740- (defmethod slurp-input-stream ((function function) input-stream &key)
8.6741- (funcall function input-stream))
8.6742-
8.6743- (defmethod slurp-input-stream ((list cons) input-stream &key)
8.6744- (apply (first list) input-stream (rest list)))
8.6745-
8.6746- #-genera
8.6747- (defmethod slurp-input-stream ((output-stream stream) input-stream
8.6748- &key linewise prefix (element-type 'character) buffer-size)
8.6749- (copy-stream-to-stream
8.6750- input-stream output-stream
8.6751- :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
8.6752-
8.6753- (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
8.6754- (slurp-stream-string stream :stripped stripped))
8.6755-
8.6756- (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
8.6757- (slurp-stream-string stream :stripped stripped))
8.6758-
8.6759- (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
8.6760- (slurp-stream-lines stream :count count))
8.6761-
8.6762- (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
8.6763- (slurp-stream-line stream :at at))
8.6764-
8.6765- (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
8.6766- (slurp-stream-forms stream :count count))
8.6767-
8.6768- (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
8.6769- (slurp-stream-form stream :at at))
8.6770-
8.6771- (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
8.6772- (apply 'slurp-input-stream *standard-output* stream keys))
8.6773-
8.6774- (defmethod slurp-input-stream ((x null) (stream t) &key)
8.6775- nil)
8.6776-
8.6777- (defmethod slurp-input-stream ((pathname pathname) input
8.6778- &key
8.6779- (element-type *default-stream-element-type*)
8.6780- (external-format *utf-8-external-format*)
8.6781- (if-exists :rename-and-delete)
8.6782- (if-does-not-exist :create)
8.6783- buffer-size
8.6784- linewise)
8.6785- (with-output-file (output pathname
8.6786- :element-type element-type
8.6787- :external-format external-format
8.6788- :if-exists if-exists
8.6789- :if-does-not-exist if-does-not-exist)
8.6790- (copy-stream-to-stream
8.6791- input output
8.6792- :element-type element-type :buffer-size buffer-size :linewise linewise)))
8.6793-
8.6794- (defmethod slurp-input-stream (x stream
8.6795- &key linewise prefix (element-type 'character) buffer-size)
8.6796- (declare (ignorable stream linewise prefix element-type buffer-size))
8.6797- (cond
8.6798- #+genera
8.6799- ((functionp x) (funcall x stream))
8.6800- #+genera
8.6801- ((output-stream-p x)
8.6802- (copy-stream-to-stream
8.6803- stream x
8.6804- :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
8.6805- (t
8.6806- (parameter-error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
8.6807-
8.6808-;;;; Vomiting a stream, typically into the input of another program.
8.6809-(with-upgradability ()
8.6810- (defgeneric vomit-output-stream (processor output-stream &key)
8.6811- (:documentation
8.6812- "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
8.6813-PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
8.6814-some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
8.6815-
8.6816-Built-in methods include the following:
8.6817-* if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
8.6818-* if PROCESSOR is a list, its first element should be a function.
8.6819- It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
8.6820- That is (x . y) will be treated as \(APPLY x <stream> y\)
8.6821-* if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
8.6822- per copy-stream-to-stream, with appropriate keyword arguments.
8.6823-* if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
8.6824-* if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.
8.6825-
8.6826-Programmers are encouraged to define their own methods for this generic function."))
8.6827-
8.6828- #-genera
8.6829- (defmethod vomit-output-stream ((function function) output-stream &key)
8.6830- (funcall function output-stream))
8.6831-
8.6832- (defmethod vomit-output-stream ((list cons) output-stream &key)
8.6833- (apply (first list) output-stream (rest list)))
8.6834-
8.6835- #-genera
8.6836- (defmethod vomit-output-stream ((input-stream stream) output-stream
8.6837- &key linewise prefix (element-type 'character) buffer-size)
8.6838- (copy-stream-to-stream
8.6839- input-stream output-stream
8.6840- :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
8.6841-
8.6842- (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
8.6843- (princ x stream)
8.6844- (when fresh-line (fresh-line stream))
8.6845- (when terpri (terpri stream))
8.6846- (values))
8.6847-
8.6848- (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
8.6849- (apply 'vomit-output-stream *standard-input* stream keys))
8.6850-
8.6851- (defmethod vomit-output-stream ((x null) (stream t) &key)
8.6852- (values))
8.6853-
8.6854- (defmethod vomit-output-stream ((pathname pathname) input
8.6855- &key
8.6856- (element-type *default-stream-element-type*)
8.6857- (external-format *utf-8-external-format*)
8.6858- (if-exists :rename-and-delete)
8.6859- (if-does-not-exist :create)
8.6860- buffer-size
8.6861- linewise)
8.6862- (with-output-file (output pathname
8.6863- :element-type element-type
8.6864- :external-format external-format
8.6865- :if-exists if-exists
8.6866- :if-does-not-exist if-does-not-exist)
8.6867- (copy-stream-to-stream
8.6868- input output
8.6869- :element-type element-type :buffer-size buffer-size :linewise linewise)))
8.6870-
8.6871- (defmethod vomit-output-stream (x stream
8.6872- &key linewise prefix (element-type 'character) buffer-size)
8.6873- (declare (ignorable stream linewise prefix element-type buffer-size))
8.6874- (cond
8.6875- #+genera
8.6876- ((functionp x) (funcall x stream))
8.6877- #+genera
8.6878- ((input-stream-p x)
8.6879- (copy-stream-to-stream
8.6880- x stream
8.6881- :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
8.6882- (t
8.6883- (parameter-error "Invalid ~S source ~S" 'vomit-output-stream x)))))
8.6884-
8.6885-
8.6886-;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output.
8.6887-(with-upgradability ()
8.6888- (define-condition subprocess-error (error)
8.6889- ((code :initform nil :initarg :code :reader subprocess-error-code)
8.6890- (command :initform nil :initarg :command :reader subprocess-error-command)
8.6891- (process :initform nil :initarg :process :reader subprocess-error-process))
8.6892- (:report (lambda (condition stream)
8.6893- (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
8.6894- (subprocess-error-process condition)
8.6895- (subprocess-error-command condition)
8.6896- (subprocess-error-code condition)))))
8.6897-
8.6898- (defun %check-result (exit-code &key command process ignore-error-status)
8.6899- (unless ignore-error-status
8.6900- (unless (eql exit-code 0)
8.6901- (cerror "IGNORE-ERROR-STATUS"
8.6902- 'subprocess-error :command command :code exit-code :process process)))
8.6903- exit-code)
8.6904-
8.6905- (defun %active-io-specifier-p (specifier)
8.6906- "Determines whether a run-program I/O specifier requires Lisp-side processing
8.6907-via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
8.6908-or whether it's already taken care of by the implementation's underlying run-program."
8.6909- (not (typep specifier '(or null string pathname (member :interactive :output)
8.6910- #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
8.6911- #+lispworks file-stream))))
8.6912-
8.6913- (defun %run-program (command &rest keys &key &allow-other-keys)
8.6914- "DEPRECATED. Use LAUNCH-PROGRAM instead."
8.6915- (apply 'launch-program command keys))
8.6916-
8.6917- (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
8.6918- &key
8.6919- (element-type #-clozure *default-stream-element-type* #+clozure 'character)
8.6920- (external-format *utf-8-external-format*) &allow-other-keys)
8.6921- ;; handle redirection for run-program and system
8.6922- ;; SPEC is the specification for the subprocess's input or output or error-output
8.6923- ;; TVAL is the value used if the spec is T
8.6924- ;; GF is the generic function to call to handle arbitrary values of SPEC
8.6925- ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
8.6926- ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
8.6927- ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
8.6928- ;; FUN is a function of the new reduced spec and an activity function to call with a stream
8.6929- ;; when the subprocess is active and communicating through that stream.
8.6930- ;; ACTIVEP is a boolean true if we will get to run code while the process is running
8.6931- ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
8.6932- ;; RETURNER is a function called with the value of the activity.
8.6933- ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
8.6934- (declare (ignorable stream-easy-p))
8.6935- (let* ((actual-spec (if (eq spec t) tval spec))
8.6936- (activity-spec (if (eq actual-spec :output)
8.6937- (ecase direction
8.6938- ((:input :output)
8.6939- (parameter-error "~S does not allow ~S as a ~S spec"
8.6940- 'run-program :output direction))
8.6941- ((:error-output)
8.6942- nil))
8.6943- actual-spec)))
8.6944- (labels ((activity (stream)
8.6945- (call-function returner (call-stream-processor gf activity-spec stream)))
8.6946- (easy-case ()
8.6947- (funcall fun actual-spec nil))
8.6948- (hard-case ()
8.6949- (if activep
8.6950- (funcall fun :stream #'activity)
8.6951- (with-temporary-file (:pathname tmp)
8.6952- (ecase direction
8.6953- (:input
8.6954- (with-output-file (s tmp :if-exists :overwrite
8.6955- :external-format external-format
8.6956- :element-type element-type)
8.6957- (activity s))
8.6958- (funcall fun tmp nil))
8.6959- ((:output :error-output)
8.6960- (multiple-value-prog1 (funcall fun tmp nil)
8.6961- (with-input-file (s tmp
8.6962- :external-format external-format
8.6963- :element-type element-type)
8.6964- (activity s)))))))))
8.6965- (typecase activity-spec
8.6966- ((or null string pathname (eql :interactive))
8.6967- (easy-case))
8.6968- #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
8.6969- (stream
8.6970- (if stream-easy-p (easy-case) (hard-case)))
8.6971- (t
8.6972- (hard-case))))))
8.6973-
8.6974- (defmacro place-setter (place)
8.6975- (when place
8.6976- (let ((value (gensym)))
8.6977- `#'(lambda (,value) (setf ,place ,value)))))
8.6978-
8.6979- (defmacro with-program-input (((reduced-input-var
8.6980- &optional (input-activity-var (gensym) iavp))
8.6981- input-form &key setf stream-easy-p active keys) &body body)
8.6982- `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p
8.6983- #'(lambda (,reduced-input-var ,input-activity-var)
8.6984- ,@(unless iavp `((declare (ignore ,input-activity-var))))
8.6985- ,@body)
8.6986- :input ,input-form ,active (place-setter ,setf) ,keys))
8.6987-
8.6988- (defmacro with-program-output (((reduced-output-var
8.6989- &optional (output-activity-var (gensym) oavp))
8.6990- output-form &key setf stream-easy-p active keys) &body body)
8.6991- `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p
8.6992- #'(lambda (,reduced-output-var ,output-activity-var)
8.6993- ,@(unless oavp `((declare (ignore ,output-activity-var))))
8.6994- ,@body)
8.6995- :output ,output-form ,active (place-setter ,setf) ,keys))
8.6996-
8.6997- (defmacro with-program-error-output (((reduced-error-output-var
8.6998- &optional (error-output-activity-var (gensym) eoavp))
8.6999- error-output-form &key setf stream-easy-p active keys)
8.7000- &body body)
8.7001- `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p
8.7002- #'(lambda (,reduced-error-output-var ,error-output-activity-var)
8.7003- ,@(unless eoavp `((declare (ignore ,error-output-activity-var))))
8.7004- ,@body)
8.7005- :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
8.7006-
8.7007- (defun %use-launch-program (command &rest keys
8.7008- &key input output error-output ignore-error-status &allow-other-keys)
8.7009- ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM
8.7010- #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl)
8.7011- (progn
8.7012- command keys input output error-output ignore-error-status ;; ignore
8.7013- (not-implemented-error '%use-launch-program))
8.7014- (when (member :stream (list input output error-output))
8.7015- (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
8.7016- 'run-program :stream))
8.7017- (let* ((active-input-p (%active-io-specifier-p input))
8.7018- (active-output-p (%active-io-specifier-p output))
8.7019- (active-error-output-p (%active-io-specifier-p error-output))
8.7020- (activity
8.7021- (cond
8.7022- (active-output-p :output)
8.7023- (active-input-p :input)
8.7024- (active-error-output-p :error-output)
8.7025- (t nil)))
8.7026- output-result error-output-result exit-code process-info)
8.7027- (with-program-output ((reduced-output output-activity)
8.7028- output :keys keys :setf output-result
8.7029- :stream-easy-p t :active (eq activity :output))
8.7030- (with-program-error-output ((reduced-error-output error-output-activity)
8.7031- error-output :keys keys :setf error-output-result
8.7032- :stream-easy-p t :active (eq activity :error-output))
8.7033- (with-program-input ((reduced-input input-activity)
8.7034- input :keys keys
8.7035- :stream-easy-p t :active (eq activity :input))
8.7036- (setf process-info
8.7037- (apply 'launch-program command
8.7038- :input reduced-input :output reduced-output
8.7039- :error-output (if (eq error-output :output) :output reduced-error-output)
8.7040- keys))
8.7041- (labels ((get-stream (stream-name &optional fallbackp)
8.7042- (or (slot-value process-info stream-name)
8.7043- (when fallbackp
8.7044- (slot-value process-info 'bidir-stream))))
8.7045- (run-activity (activity stream-name &optional fallbackp)
8.7046- (if-let (stream (get-stream stream-name fallbackp))
8.7047- (funcall activity stream)
8.7048- (error 'subprocess-error
8.7049- :code `(:missing ,stream-name)
8.7050- :command command :process process-info))))
8.7051- (unwind-protect
8.7052- (ecase activity
8.7053- ((nil))
8.7054- (:input (run-activity input-activity 'input-stream t))
8.7055- (:output (run-activity output-activity 'output-stream t))
8.7056- (:error-output (run-activity error-output-activity 'error-output-stream)))
8.7057- (close-streams process-info)
8.7058- (setf exit-code (wait-process process-info)))))))
8.7059- (%check-result exit-code
8.7060- :command command :process process-info
8.7061- :ignore-error-status ignore-error-status)
8.7062- (values output-result error-output-result exit-code)))
8.7063-
8.7064- (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
8.7065- (etypecase command
8.7066- (string command)
8.7067- (list (escape-shell-command
8.7068- (os-cond
8.7069- ((os-unix-p) (cons "exec" command))
8.7070- (t command))))))
8.7071-
8.7072- (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
8.7073- (flet ((redirect (spec operator)
8.7074- (let ((pathname
8.7075- (typecase spec
8.7076- (null (null-device-pathname))
8.7077- (string (parse-native-namestring spec))
8.7078- (pathname spec)
8.7079- ((eql :output)
8.7080- (unless (equal operator " 2>>")
8.7081- (parameter-error "~S: only the ~S argument can be ~S"
8.7082- 'run-program :error-output :output))
8.7083- (return-from redirect '(" 2>&1"))))))
8.7084- (when pathname
8.7085- (list operator " "
8.7086- (escape-shell-token (native-namestring pathname)))))))
8.7087- (let* ((redirections (append (redirect in " <") (redirect out " >>") (redirect err " 2>>")))
8.7088- (normalized (%normalize-system-command command))
8.7089- (directory (or directory #+(or abcl xcl) (getcwd)))
8.7090- (chdir (when directory
8.7091- (let ((dir-arg (escape-shell-token (native-namestring directory))))
8.7092- (os-cond
8.7093- ((os-unix-p) `("cd " ,dir-arg " ; "))
8.7094- ((os-windows-p) `("cd /d " ,dir-arg " & ")))))))
8.7095- (reduce/strcat
8.7096- (os-cond
8.7097- ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
8.7098- ((os-windows-p) `(,@redirections " (" ,@chdir ,normalized ")")))))))
8.7099-
8.7100- (defun %system (command &rest keys &key directory
8.7101- input (if-input-does-not-exist :error)
8.7102- output (if-output-exists :supersede)
8.7103- error-output (if-error-output-exists :supersede)
8.7104- &allow-other-keys)
8.7105- "A portable abstraction of a low-level call to libc's system()."
8.7106- (declare (ignorable keys directory input if-input-does-not-exist output
8.7107- if-output-exists error-output if-error-output-exists))
8.7108- (when (member :stream (list input output error-output))
8.7109- (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
8.7110- 'run-program :stream))
8.7111- #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
8.7112- (let (#+(or abcl ecl mkcl)
8.7113- (version (parse-version
8.7114- #-abcl
8.7115- (lisp-implementation-version)
8.7116- #+abcl
8.7117- (second (split-string (implementation-identifier) :separator '(#\-))))))
8.7118- (nest
8.7119- #+abcl (unless (lexicographic< '< version '(1 4 0)))
8.7120- #+ecl (unless (lexicographic<= '< version '(16 0 0)))
8.7121- #+mkcl (unless (lexicographic<= '< version '(1 1 9)))
8.7122- (return-from %system
8.7123- (wait-process
8.7124- (apply 'launch-program (%normalize-system-command command) keys)))))
8.7125- #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
8.7126- (let ((%command (%redirected-system-command command input output error-output directory)))
8.7127- ;; see comments for these functions
8.7128- (%handle-if-does-not-exist input if-input-does-not-exist)
8.7129- (%handle-if-exists output if-output-exists)
8.7130- (%handle-if-exists error-output if-error-output-exists)
8.7131- #+abcl (ext:run-shell-command %command)
8.7132- #+(or clasp ecl) (let ((*standard-input* *stdin*)
8.7133- (*standard-output* *stdout*)
8.7134- (*error-output* *stderr*))
8.7135- (ext:system %command))
8.7136- #+clisp
8.7137- (let ((raw-exit-code
8.7138- (or
8.7139- #.`(#+os-windows ,@'(ext:run-shell-command %command)
8.7140- #+os-unix ,@'(ext:run-program "/bin/sh" :arguments `("-c" ,%command))
8.7141- :wait t :input :terminal :output :terminal)
8.7142- 0)))
8.7143- (if (minusp raw-exit-code)
8.7144- (- 128 raw-exit-code)
8.7145- raw-exit-code))
8.7146- #+cormanlisp (win32:system %command)
8.7147- #+gcl (system:system %command)
8.7148- #+genera (not-implemented-error '%system)
8.7149- #+(and lispworks os-windows)
8.7150- (system:call-system %command :current-directory directory :wait t)
8.7151- #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
8.7152- #+mkcl (mkcl:system %command)
8.7153- #+xcl (system:%run-shell-command %command)))
8.7154-
8.7155- (defun %use-system (command &rest keys
8.7156- &key input output error-output ignore-error-status &allow-other-keys)
8.7157- ;; helper for RUN-PROGRAM when using %system
8.7158- (let (output-result error-output-result exit-code)
8.7159- (with-program-output ((reduced-output)
8.7160- output :keys keys :setf output-result)
8.7161- (with-program-error-output ((reduced-error-output)
8.7162- error-output :keys keys :setf error-output-result)
8.7163- (with-program-input ((reduced-input) input :keys keys)
8.7164- (setf exit-code (apply '%system command
8.7165- :input reduced-input :output reduced-output
8.7166- :error-output reduced-error-output keys)))))
8.7167- (%check-result exit-code
8.7168- :command command
8.7169- :ignore-error-status ignore-error-status)
8.7170- (values output-result error-output-result exit-code)))
8.7171-
8.7172- (defun run-program (command &rest keys
8.7173- &key ignore-error-status (force-shell nil force-shell-suppliedp)
8.7174- input (if-input-does-not-exist :error)
8.7175- output (if-output-exists :supersede)
8.7176- error-output (if-error-output-exists :supersede)
8.7177- (element-type #-clozure *default-stream-element-type* #+clozure 'character)
8.7178- (external-format *utf-8-external-format*)
8.7179- &allow-other-keys)
8.7180- "Run program specified by COMMAND,
8.7181-either a list of strings specifying a program and list of arguments,
8.7182-or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
8.7183-_synchronously_ process its output as specified and return the processing results
8.7184-when the program and its output processing are complete.
8.7185-
8.7186-Always call a shell (rather than directly execute the command when possible)
8.7187-if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is
8.7188-specified to be NIL.
8.7189-
8.7190-Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
8.7191-unless IGNORE-ERROR-STATUS is specified.
8.7192-
8.7193-If OUTPUT is a pathname, a string designating a pathname, or NIL (the default)
8.7194-designating the null device, the file at that path is used as output.
8.7195-If it's :INTERACTIVE, output is inherited from the current process;
8.7196-beware that this may be different from your *STANDARD-OUTPUT*,
8.7197-and under SLIME will be on your *inferior-lisp* buffer.
8.7198-If it's T, output goes to your current *STANDARD-OUTPUT* stream.
8.7199-Otherwise, OUTPUT should be a value that is a suitable first argument to
8.7200-SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
8.7201-In this case, RUN-PROGRAM will create a temporary stream for the program output;
8.7202-the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
8.7203-using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
8.7204-The primary value resulting from that call (or NIL if no call was needed)
8.7205-will be the first value returned by RUN-PROGRAM.
8.7206-E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
8.7207-And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
8.7208-stripped of any ending newline.
8.7209-
8.7210-IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
8.7211-pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
8.7212-default). The meaning of these values and their effect on the case
8.7213-where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
8.7214-to OPEN with :DIRECTION :OUTPUT.
8.7215-
8.7216-ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
8.7217-as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
8.7218-Also :OUTPUT means redirecting the error output to the output stream,
8.7219-in which case NIL is returned.
8.7220-
8.7221-IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
8.7222-affects ERROR-OUTPUT rather than OUTPUT.
8.7223-
8.7224-INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
8.7225-no value is returned, and T designates the *STANDARD-INPUT*.
8.7226-
8.7227-IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
8.7228-or a pathname, can take the values :CREATE and :ERROR (the
8.7229-default). The meaning of these values is analogous to the
8.7230-IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
8.7231-
8.7232-ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
8.7233-to your Lisp implementation, when applicable, for creation of the output stream.
8.7234-
8.7235-One and only one of the stream slurping or vomiting may or may not happen
8.7236-in parallel in parallel with the subprocess,
8.7237-depending on options and implementation,
8.7238-and with priority being given to output processing.
8.7239-Other streams are completely produced or consumed
8.7240-before or after the subprocess is spawned, using temporary files.
8.7241-
8.7242-RUN-PROGRAM returns 3 values:
8.7243-0- the result of the OUTPUT slurping if any, or NIL
8.7244-1- the result of the ERROR-OUTPUT slurping if any, or NIL
8.7245-2- either 0 if the subprocess exited with success status,
8.7246-or an indication of failure via the EXIT-CODE of the process"
8.7247- (declare (ignorable input output error-output if-input-does-not-exist if-output-exists
8.7248- if-error-output-exists element-type external-format ignore-error-status))
8.7249- #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
8.7250- (not-implemented-error 'run-program)
8.7251- (apply (if (or force-shell
8.7252- ;; Per doc string, set FORCE-SHELL to T if we get command as a string.
8.7253- ;; But don't override user's specified preference. [2015/06/29:rpg]
8.7254- (and (stringp command)
8.7255- (or (not force-shell-suppliedp)
8.7256- #-(or allegro clisp clozure sbcl) (os-cond ((os-windows-p) t))))
8.7257- #+(or clasp clisp cormanlisp gcl (and lispworks os-windows) mcl xcl) t
8.7258- ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
8.7259- #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
8.7260- (lexicographic<= '< ver '(16 0 0)))
8.7261- #+(and lispworks os-unix) (%interactivep input output error-output))
8.7262- '%use-system '%use-launch-program)
8.7263- command keys)))
8.7264-
8.7265-;;;; ---------------------------------------------------------------------------
8.7266-;;;; Generic support for configuration files
8.7267-
8.7268-(uiop/package:define-package :uiop/configuration
8.7269- (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27.
8.7270- (:use :uiop/package :uiop/common-lisp :uiop/utility
8.7271- :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
8.7272- (:export
8.7273- #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
8.7274- #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem
8.7275- #:get-folder-path
8.7276- #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
8.7277- #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
8.7278- #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames
8.7279- #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname
8.7280- #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
8.7281- #:configuration-inheritance-directive-p
8.7282- #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
8.7283- #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
8.7284- #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
8.7285- #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration
8.7286- #:uiop-directory))
8.7287-(in-package :uiop/configuration)
8.7288-
8.7289-(with-upgradability ()
8.7290- (define-condition invalid-configuration ()
8.7291- ((form :reader condition-form :initarg :form)
8.7292- (location :reader condition-location :initarg :location)
8.7293- (format :reader condition-format :initarg :format)
8.7294- (arguments :reader condition-arguments :initarg :arguments :initform nil))
8.7295- (:report (lambda (c s)
8.7296- (format s (compatfmt "~@<~? (will be skipped)~@:>")
8.7297- (condition-format c)
8.7298- (list* (condition-form c) (condition-location c)
8.7299- (condition-arguments c))))))
8.7300-
8.7301- (defun configuration-inheritance-directive-p (x)
8.7302- "Is X a configuration inheritance directive?"
8.7303- (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
8.7304- (or (member x kw)
8.7305- (and (length=n-p x 1) (member (car x) kw)))))
8.7306-
8.7307- (defun report-invalid-form (reporter &rest args)
8.7308- "Report an invalid form according to REPORTER and various ARGS"
8.7309- (etypecase reporter
8.7310- (null
8.7311- (apply 'error 'invalid-configuration args))
8.7312- (function
8.7313- (apply reporter args))
8.7314- ((or symbol string)
8.7315- (apply 'error reporter args))
8.7316- (cons
8.7317- (apply 'apply (append reporter args)))))
8.7318-
8.7319- (defvar *ignored-configuration-form* nil
8.7320- "Have configuration forms been ignored while parsing the configuration?")
8.7321-
8.7322- (defun validate-configuration-form (form tag directive-validator
8.7323- &key location invalid-form-reporter)
8.7324- "Validate a configuration FORM. By default it will raise an error if the
8.7325-FORM is not valid. Otherwise it will return the validated form.
8.7326- Arguments control the behavior:
8.7327- The configuration FORM should be of the form (TAG . <rest>)
8.7328- Each element of <rest> will be checked by first seeing if it's a configuration inheritance
8.7329-directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
8.7330-on it.
8.7331- In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
8.7332-reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
8.7333-the configuration form appeared."
8.7334- (unless (and (consp form) (eq (car form) tag))
8.7335- (setf *ignored-configuration-form* t)
8.7336- (report-invalid-form invalid-form-reporter :form form :location location)
8.7337- (return-from validate-configuration-form nil))
8.7338- (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
8.7339- :for directive :in (cdr form)
8.7340- :when (cond
8.7341- ((configuration-inheritance-directive-p directive)
8.7342- (incf inherit) t)
8.7343- ((eq directive :ignore-invalid-entries)
8.7344- (setf ignore-invalid-p t) t)
8.7345- ((funcall directive-validator directive)
8.7346- t)
8.7347- (ignore-invalid-p
8.7348- nil)
8.7349- (t
8.7350- (setf *ignored-configuration-form* t)
8.7351- (report-invalid-form invalid-form-reporter :form directive :location location)
8.7352- nil))
8.7353- :do (push directive x)
8.7354- :finally
8.7355- (unless (= inherit 1)
8.7356- (report-invalid-form invalid-form-reporter
8.7357- :form form :location location
8.7358- ;; we throw away the form and location arguments, hence the ~2*
8.7359- ;; this is necessary because of the report in INVALID-CONFIGURATION
8.7360- :format (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
8.7361- One and only one of ~S or ~S is required.~@:>")
8.7362- :arguments '(:inherit-configuration :ignore-inherited-configuration)))
8.7363- (return (nreverse x))))
8.7364-
8.7365- (defun validate-configuration-file (file validator &key description)
8.7366- "Validate a configuration FILE. The configuration file should have only one s-expression
8.7367-in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error
8.7368-reporting."
8.7369- (let ((forms (read-file-forms file)))
8.7370- (unless (length=n-p forms 1)
8.7371- (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
8.7372- description forms))
8.7373- (funcall validator (car forms) :location file)))
8.7374-
8.7375- (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter)
8.7376- "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
8.7377-be applied to the results to yield a configuration form. Current
8.7378-values of TAG include :source-registry and :output-translations."
8.7379- (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
8.7380- (remove-if
8.7381- 'hidden-pathname-p
8.7382- (directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
8.7383- #'string< :key #'namestring)))
8.7384- `(,tag
8.7385- ,@(loop :for file :in files :append
8.7386- (loop :with ignore-invalid-p = nil
8.7387- :for form :in (read-file-forms file)
8.7388- :when (eq form :ignore-invalid-entries)
8.7389- :do (setf ignore-invalid-p t)
8.7390- :else
8.7391- :when (funcall validator form)
8.7392- :collect form
8.7393- :else
8.7394- :when ignore-invalid-p
8.7395- :do (setf *ignored-configuration-form* t)
8.7396- :else
8.7397- :do (report-invalid-form invalid-form-reporter :form form :location file)))
8.7398- :inherit-configuration)))
8.7399-
8.7400- (defun resolve-relative-location (x &key ensure-directory wilden)
8.7401- "Given a designator X for an relative location, resolve it to a pathname."
8.7402- (ensure-pathname
8.7403- (etypecase x
8.7404- (null nil)
8.7405- (pathname x)
8.7406- (string (parse-unix-namestring
8.7407- x :ensure-directory ensure-directory))
8.7408- (cons
8.7409- (if (null (cdr x))
8.7410- (resolve-relative-location
8.7411- (car x) :ensure-directory ensure-directory :wilden wilden)
8.7412- (let* ((car (resolve-relative-location
8.7413- (car x) :ensure-directory t :wilden nil)))
8.7414- (merge-pathnames*
8.7415- (resolve-relative-location
8.7416- (cdr x) :ensure-directory ensure-directory :wilden wilden)
8.7417- car))))
8.7418- ((eql :*/) *wild-directory*)
8.7419- ((eql :**/) *wild-inferiors*)
8.7420- ((eql :*.*.*) *wild-file*)
8.7421- ((eql :implementation)
8.7422- (parse-unix-namestring
8.7423- (implementation-identifier) :ensure-directory t))
8.7424- ((eql :implementation-type)
8.7425- (parse-unix-namestring
8.7426- (string-downcase (implementation-type)) :ensure-directory t))
8.7427- ((eql :hostname)
8.7428- (parse-unix-namestring (hostname) :ensure-directory t)))
8.7429- :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
8.7430- :want-relative t))
8.7431-
8.7432- (defvar *here-directory* nil
8.7433- "This special variable is bound to the currect directory during calls to
8.7434-PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
8.7435-directive.")
8.7436-
8.7437- (defvar *user-cache* nil
8.7438- "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
8.7439-
8.7440- (defun resolve-absolute-location (x &key ensure-directory wilden)
8.7441- "Given a designator X for an absolute location, resolve it to a pathname"
8.7442- (ensure-pathname
8.7443- (etypecase x
8.7444- (null nil)
8.7445- (pathname x)
8.7446- (string
8.7447- (let ((p #-mcl (parse-namestring x)
8.7448- #+mcl (probe-posix x)))
8.7449- #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
8.7450- (if ensure-directory (ensure-directory-pathname p) p)))
8.7451- (cons
8.7452- (return-from resolve-absolute-location
8.7453- (if (null (cdr x))
8.7454- (resolve-absolute-location
8.7455- (car x) :ensure-directory ensure-directory :wilden wilden)
8.7456- (merge-pathnames*
8.7457- (resolve-relative-location
8.7458- (cdr x) :ensure-directory ensure-directory :wilden wilden)
8.7459- (resolve-absolute-location
8.7460- (car x) :ensure-directory t :wilden nil)))))
8.7461- ((eql :root)
8.7462- ;; special magic! we return a relative pathname,
8.7463- ;; but what it means to the output-translations is
8.7464- ;; "relative to the root of the source pathname's host and device".
8.7465- (return-from resolve-absolute-location
8.7466- (let ((p (make-pathname :directory '(:relative))))
8.7467- (if wilden (wilden p) p))))
8.7468- ((eql :home) (user-homedir-pathname))
8.7469- ((eql :here) (resolve-absolute-location
8.7470- (or *here-directory* (pathname-directory-pathname (truename (load-pathname))))
8.7471- :ensure-directory t :wilden nil))
8.7472- ((eql :user-cache) (resolve-absolute-location
8.7473- *user-cache* :ensure-directory t :wilden nil)))
8.7474- :wilden (and wilden (not (pathnamep x)))
8.7475- :resolve-symlinks *resolve-symlinks*
8.7476- :want-absolute t))
8.7477-
8.7478- ;; Try to override declaration in previous versions of ASDF.
8.7479- (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
8.7480- (:ensure-directory boolean)) t) resolve-location))
8.7481-
8.7482- (defun resolve-location (x &key ensure-directory wilden directory)
8.7483- "Resolve location designator X into a PATHNAME"
8.7484- ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
8.7485- (loop :with dirp = (or directory ensure-directory)
8.7486- :with (first . rest) = (if (atom x) (list x) x)
8.7487- :with path = (or (resolve-absolute-location
8.7488- first :ensure-directory (and (or dirp rest) t)
8.7489- :wilden (and wilden (null rest)))
8.7490- (return nil))
8.7491- :for (element . morep) :on rest
8.7492- :for dir = (and (or morep dirp) t)
8.7493- :for wild = (and wilden (not morep))
8.7494- :for sub = (merge-pathnames*
8.7495- (resolve-relative-location
8.7496- element :ensure-directory dir :wilden wild)
8.7497- path)
8.7498- :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
8.7499- :finally (return path)))
8.7500-
8.7501- (defun location-designator-p (x)
8.7502- "Is X a designator for a location?"
8.7503- ;; NIL means "skip this entry", or as an output translation, same as translation input.
8.7504- ;; T means "any input" for a translation, or as output, same as translation input.
8.7505- (flet ((absolute-component-p (c)
8.7506- (typep c '(or string pathname
8.7507- (member :root :home :here :user-cache))))
8.7508- (relative-component-p (c)
8.7509- (typep c '(or string pathname
8.7510- (member :*/ :**/ :*.*.* :implementation :implementation-type)))))
8.7511- (or (typep x 'boolean)
8.7512- (absolute-component-p x)
8.7513- (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
8.7514-
8.7515- (defun location-function-p (x)
8.7516- "Is X the specification of a location function?"
8.7517- ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
8.7518- (and (length=n-p x 2) (eq (car x) :function)))
8.7519-
8.7520- (defvar *clear-configuration-hook* '())
8.7521-
8.7522- (defun register-clear-configuration-hook (hook-function &optional call-now-p)
8.7523- "Register a function to be called when clearing configuration"
8.7524- (register-hook-function '*clear-configuration-hook* hook-function call-now-p))
8.7525-
8.7526- (defun clear-configuration ()
8.7527- "Call the functions in *CLEAR-CONFIGURATION-HOOK*"
8.7528- (call-functions *clear-configuration-hook*))
8.7529-
8.7530- (register-image-dump-hook 'clear-configuration)
8.7531-
8.7532- (defun upgrade-configuration ()
8.7533- "If a previous version of ASDF failed to read some configuration, try again now."
8.7534- (when *ignored-configuration-form*
8.7535- (clear-configuration)
8.7536- (setf *ignored-configuration-form* nil)))
8.7537-
8.7538-
8.7539- (defun get-folder-path (folder)
8.7540- "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
8.7541-this function tries to locate the Windows FOLDER for one of
8.7542-:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
8.7543- Returns NIL when the folder is not defined (e.g., not on Windows)."
8.7544- (or #+(and lispworks os-windows) (sys:get-folder-path folder)
8.7545- ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
8.7546- (ecase folder
8.7547- (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
8.7548- (subpathname* (get-folder-path :appdata) "Local")))
8.7549- (:appdata (getenv-absolute-directory "APPDATA"))
8.7550- (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
8.7551- (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
8.7552-
8.7553-
8.7554- ;; Support for the XDG Base Directory Specification
8.7555- (defun xdg-data-home (&rest more)
8.7556- "Returns an absolute pathname for the directory containing user-specific data files.
8.7557-MORE may contain specifications for a subpath relative to this directory: a
8.7558-subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
8.7559-also \"Configuration DSL\"\) in the ASDF manual."
8.7560- (resolve-absolute-location
8.7561- `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
8.7562- (os-cond
8.7563- ((os-windows-p) (get-folder-path :local-appdata))
8.7564- (t (subpathname (user-homedir-pathname) ".local/share/"))))
8.7565- ,more)))
8.7566-
8.7567- (defun xdg-config-home (&rest more)
8.7568- "Returns a pathname for the directory containing user-specific configuration files.
8.7569-MORE may contain specifications for a subpath relative to this directory: a
8.7570-subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
8.7571-also \"Configuration DSL\"\) in the ASDF manual."
8.7572- (resolve-absolute-location
8.7573- `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
8.7574- (os-cond
8.7575- ((os-windows-p) (xdg-data-home "config/"))
8.7576- (t (subpathname (user-homedir-pathname) ".config/"))))
8.7577- ,more)))
8.7578-
8.7579- (defun xdg-data-dirs (&rest more)
8.7580- "The preference-ordered set of additional paths to search for data files.
8.7581-Returns a list of absolute directory pathnames.
8.7582-MORE may contain specifications for a subpath relative to these directories: a
8.7583-subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
8.7584-also \"Configuration DSL\"\) in the ASDF manual."
8.7585- (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
8.7586- (or (remove nil (getenv-absolute-directories "XDG_DATA_DIRS"))
8.7587- (os-cond
8.7588- ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
8.7589- ;; macOS' separate read-only system volume means that the contents
8.7590- ;; of /usr/share are frozen by Apple. Unlike when running natively
8.7591- ;; on macOS, Genera must access the filesystem through NFS. Attempting
8.7592- ;; to export either the root (/) or /usr/share simply doesn't work.
8.7593- ;; (Genera will go into an infinite loop trying to access those mounts.)
8.7594- ;; So, when running Genera on macOS, only search /usr/local/share.
8.7595- ((os-genera-p)
8.7596- #+Genera (sys:system-case
8.7597- (darwin-vlm (mapcar 'parse-unix-namestring '("/usr/local/share/")))
8.7598- (otherwise (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))
8.7599- (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))))
8.7600-
8.7601- (defun xdg-config-dirs (&rest more)
8.7602- "The preference-ordered set of additional base paths to search for configuration files.
8.7603-Returns a list of absolute directory pathnames.
8.7604-MORE may contain specifications for a subpath relative to these directories:
8.7605-subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
8.7606-also \"Configuration DSL\"\) in the ASDF manual."
8.7607- (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
8.7608- (or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIRS"))
8.7609- (os-cond
8.7610- ((os-windows-p) (xdg-data-dirs "config/"))
8.7611- (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))
8.7612-
8.7613- (defun xdg-cache-home (&rest more)
8.7614- "The base directory relative to which user specific non-essential data files should be stored.
8.7615-Returns an absolute directory pathname.
8.7616-MORE may contain specifications for a subpath relative to this directory: a
8.7617-subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
8.7618-also \"Configuration DSL\"\) in the ASDF manual."
8.7619- (resolve-absolute-location
8.7620- `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
8.7621- (os-cond
8.7622- ((os-windows-p) (xdg-data-home "cache/"))
8.7623- (t (subpathname* (user-homedir-pathname) ".cache/"))))
8.7624- ,more)))
8.7625-
8.7626- (defun xdg-runtime-dir (&rest more)
8.7627- "Pathname for user-specific non-essential runtime files and other file objects,
8.7628-such as sockets, named pipes, etc.
8.7629-Returns an absolute directory pathname.
8.7630-MORE may contain specifications for a subpath relative to this directory: a
8.7631-subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
8.7632-also \"Configuration DSL\"\) in the ASDF manual."
8.7633- ;; The XDG spec says that if not provided by the login system, the application should
8.7634- ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
8.7635- (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
8.7636-
8.7637- ;;; NOTE: modified the docstring because "system user configuration
8.7638- ;;; directories" seems self-contradictory. I'm not sure my wording is right.
8.7639- (defun system-config-pathnames (&rest more)
8.7640- "Return a list of directories where are stored the system's default user configuration information.
8.7641-MORE may contain specifications for a subpath relative to these directories: a
8.7642-subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
8.7643-also \"Configuration DSL\"\) in the ASDF manual."
8.7644- (declare (ignorable more))
8.7645- (os-cond
8.7646- ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more))))))
8.7647-
8.7648- (defun filter-pathname-set (dirs)
8.7649- "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
8.7650- (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))
8.7651-
8.7652- (defun xdg-data-pathnames (&rest more)
8.7653- "Return a list of absolute pathnames for application data directories. With APP,
8.7654-returns directory for data for that application, without APP, returns the set of directories
8.7655-for storing all application configurations.
8.7656-MORE may contain specifications for a subpath relative to these directories: a
8.7657-subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
8.7658-also \"Configuration DSL\"\) in the ASDF manual."
8.7659- (filter-pathname-set
8.7660- `(,(xdg-data-home more)
8.7661- ,@(xdg-data-dirs more))))
8.7662-
8.7663- (defun xdg-config-pathnames (&rest more)
8.7664- "Return a list of pathnames for application configuration.
8.7665-MORE may contain specifications for a subpath relative to these directories: a
8.7666-subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
8.7667-also \"Configuration DSL\"\) in the ASDF manual."
8.7668- (filter-pathname-set
8.7669- `(,(xdg-config-home more)
8.7670- ,@(xdg-config-dirs more))))
8.7671-
8.7672- (defun find-preferred-file (files &key (direction :input))
8.7673- "Find first file in the list of FILES that exists (for direction :input or :probe)
8.7674-or just the first one (for direction :output or :io).
8.7675- Note that when we say \"file\" here, the files in question may be directories."
8.7676- (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))
8.7677-
8.7678- (defun xdg-data-pathname (&optional more (direction :input))
8.7679- (find-preferred-file (xdg-data-pathnames more) :direction direction))
8.7680-
8.7681- (defun xdg-config-pathname (&optional more (direction :input))
8.7682- (find-preferred-file (xdg-config-pathnames more) :direction direction))
8.7683-
8.7684- (defun compute-user-cache ()
8.7685- "Compute (and return) the location of the default user-cache for translate-output
8.7686-objects. Side-effects for cached file location computation."
8.7687- (setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
8.7688- (register-image-restore-hook 'compute-user-cache)
8.7689-
8.7690- (defun uiop-directory ()
8.7691- "Try to locate the UIOP source directory at runtime"
8.7692- (labels ((pf (x) (ignore-errors (probe-file* x)))
8.7693- (sub (x y) (pf (subpathname x y)))
8.7694- (ssd (x) (ignore-errors (symbol-call :asdf :system-source-directory x))))
8.7695- ;; NB: conspicuously *not* including searches based on #.(current-lisp-pathname)
8.7696- (or
8.7697- ;; Look under uiop if available as source override, under asdf if avaiable as source
8.7698- (ssd "uiop")
8.7699- (sub (ssd "asdf") "uiop/")
8.7700- ;; Look in recommended path for user-visible source installation
8.7701- (sub (user-homedir-pathname) "common-lisp/asdf/uiop/")
8.7702- ;; Look in XDG paths under known package names for user-invisible source installation
8.7703- (xdg-data-pathname "common-lisp/source/asdf/uiop/")
8.7704- (xdg-data-pathname "common-lisp/source/cl-asdf/uiop/") ; traditional Debian location
8.7705- ;; The last one below is useful for Fare, primary (sole?) known user
8.7706- (sub (user-homedir-pathname) "cl/asdf/uiop/")
8.7707- (cerror "Configure source registry to include UIOP source directory and retry."
8.7708- "Unable to find UIOP directory")
8.7709- (uiop-directory)))))
8.7710-;;; -------------------------------------------------------------------------
8.7711-;;; Hacks for backward-compatibility with older versions of UIOP
8.7712-
8.7713-(uiop/package:define-package :uiop/backward-driver
8.7714- (:recycle :uiop/backward-driver :asdf/backward-driver :uiop)
8.7715- (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version
8.7716- :uiop/pathname :uiop/stream :uiop/os :uiop/image
8.7717- :uiop/run-program :uiop/lisp-build :uiop/configuration)
8.7718- (:export
8.7719- #:coerce-pathname
8.7720- #:user-configuration-directories #:system-configuration-directories
8.7721- #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory
8.7722- #:version-compatible-p))
8.7723-(in-package :uiop/backward-driver)
8.7724-
8.7725-(eval-when (:compile-toplevel :load-toplevel :execute)
8.7726-(with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2" :warning "3.4"))
8.7727- ;; Backward compatibility with ASDF 2.000 to 2.26
8.7728-
8.7729- ;; For backward-compatibility only, for people using internals
8.7730- ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release)
8.7731- ;; Will be removed after 2015-12.
8.7732- (defun coerce-pathname (name &key type defaults)
8.7733- "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead."
8.7734- (parse-unix-namestring name :type type :defaults defaults))
8.7735-
8.7736- ;; Backward compatibility for ASDF 2.27 to 3.1.4
8.7737- (defun user-configuration-directories ()
8.7738- "Return the current user's list of user configuration directories
8.7739-for configuring common-lisp.
8.7740-DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead."
8.7741- (xdg-config-pathnames "common-lisp"))
8.7742- (defun system-configuration-directories ()
8.7743- "Return the list of system configuration directories for common-lisp.
8.7744-DEPRECATED. Use UIOP:SYSTEM-CONFIG-PATHNAMES (with argument \"common-lisp\"),
8.7745-instead."
8.7746- (system-config-pathnames "common-lisp"))
8.7747- (defun in-first-directory (dirs x &key (direction :input))
8.7748- "Finds the first appropriate file named X in the list of DIRS for I/O
8.7749-in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
8.7750-If direction is :INPUT or :PROBE, will return the first extant file named
8.7751-X in one of the DIRS.
8.7752-If direction is :OUTPUT or :IO, will simply return the file named X in the
8.7753-first element of DIRS that exists. DEPRECATED."
8.7754- (find-preferred-file
8.7755- (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs)
8.7756- :direction direction))
8.7757- (defun in-user-configuration-directory (x &key (direction :input))
8.7758- "Return the file named X in the user configuration directory for common-lisp.
8.7759-DEPRECATED."
8.7760- (xdg-config-pathname `("common-lisp" ,x) direction))
8.7761- (defun in-system-configuration-directory (x &key (direction :input))
8.7762- "Return the pathname for the file named X under the system configuration directory
8.7763-for common-lisp. DEPRECATED."
8.7764- (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction))
8.7765-
8.7766-
8.7767- ;; Backward compatibility with ASDF 1 to ASDF 2.32
8.7768-
8.7769- (defun version-compatible-p (provided-version required-version)
8.7770- "Is the provided version a compatible substitution for the required-version?
8.7771-If major versions differ, it's not compatible.
8.7772-If they are equal, then any later version is compatible,
8.7773-with later being determined by a lexicographical comparison of minor numbers.
8.7774-DEPRECATED."
8.7775- (let ((x (parse-version provided-version nil))
8.7776- (y (parse-version required-version nil)))
8.7777- (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))))
8.7778-
8.7779-;;;; ---------------------------------------------------------------------------
8.7780-;;;; Re-export all the functionality in UIOP
8.7781-
8.7782-(uiop/package:define-package :uiop/driver
8.7783- (:nicknames :uiop ;; Official name we recommend should be used for all references to uiop symbols.
8.7784- :asdf/driver) ;; DO NOT USE, a deprecated name, not supported anymore.
8.7785- ;; We should remove the name :asdf/driver at some point,
8.7786- ;; but not until it has been eradicated from Quicklisp for a year or two.
8.7787- ;; The last known user was cffi (PR merged in May 2020).
8.7788- (:use :uiop/common-lisp)
8.7789- ;; NB: We are not reexporting uiop/common-lisp
8.7790- ;; which include all of CL with compatibility modifications on select platforms,
8.7791- ;; because that would cause potential conflicts for packages that
8.7792- ;; might want to :use (:cl :uiop) or :use (:closer-common-lisp :uiop), etc.
8.7793- (:use-reexport
8.7794- :uiop/package* :uiop/utility :uiop/version
8.7795- :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image
8.7796- :uiop/launch-program :uiop/run-program
8.7797- :uiop/lisp-build :uiop/configuration :uiop/backward-driver))
8.7798-
8.7799-;; Provide both lowercase and uppercase, to satisfy more implementations.
8.7800-(provide "uiop") (provide "UIOP")
8.7801-;;;; -------------------------------------------------------------------------
8.7802-;;;; Handle upgrade as forward- and backward-compatibly as possible
8.7803-;; See https://bugs.launchpad.net/asdf/+bug/485687
8.7804-
8.7805-(uiop/package:define-package :asdf/upgrade
8.7806- (:recycle :asdf/upgrade :asdf)
8.7807- (:use :uiop/common-lisp :uiop)
8.7808- (:export
8.7809- #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
8.7810- #:asdf-message #:*verbose-out*
8.7811- #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter*
8.7812- #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf
8.7813- ;; There will be no symbol left behind!
8.7814- #:with-asdf-deprecation
8.7815- #:intern*)
8.7816- (:import-from :uiop/package #:intern* #:find-symbol*))
8.7817-(in-package :asdf/upgrade)
8.7818-
8.7819-;;; Special magic to detect if this is an upgrade
8.7820-
8.7821-(with-upgradability ()
8.7822- (defun asdf-version ()
8.7823- "Exported interface to the version of ASDF currently installed. A string.
8.7824-You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")."
8.7825- (when (find-package :asdf)
8.7826- (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
8.7827- (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf))
8.7828- (rev (and revsym (boundp revsym) (symbol-value revsym))))
8.7829- (etypecase rev
8.7830- (string rev)
8.7831- (cons (format nil "~{~D~^.~}" rev))
8.7832- (null "1.0"))))))
8.7833- ;; This (private) variable contains a list of versions of previously loaded variants of ASDF,
8.7834- ;; from which ASDF was upgraded.
8.7835- ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly.
8.7836- (defvar *previous-asdf-versions*
8.7837- (let ((previous (asdf-version)))
8.7838- (when previous
8.7839- ;; Punt on upgrade from ASDF1 or ASDF2, by renaming (or deleting) the package.
8.7840- (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature.
8.7841- (let ((away (format nil "~A-~A" :asdf previous)))
8.7842- (rename-package :asdf away)
8.7843- (when *load-verbose*
8.7844- (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))
8.7845- (list previous))))
8.7846- ;; This public variable will be bound shortly to the currently loaded version of ASDF.
8.7847- (defvar *asdf-version* nil)
8.7848- ;; We need to clear systems from versions older than the one in this (private) parameter.
8.7849- ;; The latest incompatible defclass is 2.32.13 renaming a slot in component,
8.7850- ;; or 3.2.0.2 for CCL (incompatibly changing some superclasses).
8.7851- ;; the latest incompatible gf change is in 3.1.7.20 (see redefined-functions below).
8.7852- (defparameter *oldest-forward-compatible-asdf-version* "3.2.0.2")
8.7853- ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages
8.7854- (defvar *verbose-out* nil)
8.7855- ;; Private function by which ASDF outputs progress messages and warning messages:
8.7856- (defun asdf-message (format-string &rest format-args)
8.7857- (when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
8.7858- ;; Private hook for functions to run after ASDF has upgraded itself from an older variant:
8.7859- (defvar *post-upgrade-cleanup-hook* ())
8.7860- ;; Private variable for post upgrade cleanup to communicate if an upgrade has
8.7861- ;; actually occured.
8.7862- (defvar *asdf-upgraded-p*)
8.7863- ;; Private function to detect whether the current upgrade counts as an incompatible
8.7864- ;; data schema upgrade implying the need to drop data.
8.7865- (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*))
8.7866- (and *previous-asdf-versions*
8.7867- (version< (first *previous-asdf-versions*) oldest-compatible-version)))
8.7868- ;; Private variant of defparameter that works in presence of incompatible upgrades:
8.7869- ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change),
8.7870- ;; but behaves like defparameter if in presence of an incompatible upgrade.
8.7871- (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*))
8.7872- (let* ((name (string-trim "*" var))
8.7873- (valfun (intern (format nil "%~A-~A-~A" :compute name :value))))
8.7874- `(progn
8.7875- (defun ,valfun () ,value)
8.7876- (defvar ,var (,valfun) ,@(ensure-list docstring))
8.7877- (when (upgrading-p ,version)
8.7878- (setf ,var (,valfun))))))
8.7879- ;; Private macro to declare sections of code that are only compiled and run when upgrading.
8.7880- ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects,
8.7881- ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs.
8.7882- (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*)
8.7883- (upgrading-p `(upgrading-p ,version)) when) &body body)
8.7884- "A wrapper macro for code that should only be run when upgrading a
8.7885-previously-loaded version of ASDF."
8.7886- `(with-upgradability ()
8.7887- (when (and ,upgrading-p ,@(when when `(,when)))
8.7888- (handler-bind ((style-warning #'muffle-warning))
8.7889- (eval '(progn ,@body))))))
8.7890- ;; Only now can we safely update the version.
8.7891- (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
8.7892- ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8
8.7893- ;; can help you do these changes in synch (look at the source for documentation).
8.7894- ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp.
8.7895- ;; "3.4" would be the general branch for major version 3, minor version 4.
8.7896- ;; "3.4.5" would be an official release in the 3.4 branch.
8.7897- ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
8.7898- ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
8.7899- ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
8.7900- (asdf-version "3.3.6")
8.7901- (existing-version (asdf-version)))
8.7902- (setf *asdf-version* asdf-version)
8.7903- (when (and existing-version (not (equal asdf-version existing-version)))
8.7904- (push existing-version *previous-asdf-versions*)
8.7905- (when (or *verbose-out* *load-verbose*)
8.7906- (format (or *verbose-out* *trace-output*)
8.7907- (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
8.7908- existing-version asdf-version)))))
8.7909-
8.7910-;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined
8.7911-(when-upgrading ()
8.7912- (let* ((previous-version (first *previous-asdf-versions*))
8.7913- (redefined-functions ;; List of functions that changed incompatibly since 2.27:
8.7914- ;; gf signature changed, defun that became a generic function (but not way around),
8.7915- ;; method removed that will mess up with new ones
8.7916- ;; (especially :around :before :after, more specific or call-next-method'ed method)
8.7917- ;; and/or semantics otherwise modified. Oops.
8.7918- ;; NB: it's too late to do anything about functions in UIOP!
8.7919- ;; If you introduce some critical incompatibility there, you MUST change the function name.
8.7920- ;; Note that we don't need do anything about functions that changed incompatibly
8.7921- ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade.
8.7922- ;; Also, the strong constraints apply most importantly for functions called from
8.7923- ;; the continuation of compiling or loading some of the code in ASDF or UIOP.
8.7924- ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36
8.7925- ;; and at https://gitlab.common-lisp.net/asdf/asdf/-/merge_requests/141
8.7926- `(,@(when (version< previous-version "2.31") '(#:normalize-version)) ;; pathname became &key
8.7927- ,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2
8.7928- ,@(when (version< previous-version "3.1.7.20") '(#:find-component)))) ;; added &key registered
8.7929- (redefined-classes
8.7930- ;; with the old ASDF during upgrade, and many implementations bork
8.7931- (when (or #+(or clozure mkcl) t)
8.7932- '((#:compile-concatenated-source-op (#:operation) ())
8.7933- (#:compile-bundle-op (#:operation) ())
8.7934- (#:concatenate-source-op (#:operation) ())
8.7935- (#:dll-op (#:operation) ())
8.7936- (#:lib-op (#:operation) ())
8.7937- (#:monolithic-compile-bundle-op (#:operation) ())
8.7938- (#:monolithic-concatenate-source-op (#:operation) ())))))
8.7939- (loop :for name :in redefined-functions
8.7940- :for sym = (find-symbol* name :asdf nil)
8.7941- :do (when sym (fmakunbound sym)))
8.7942- (labels ((asym (x) (multiple-value-bind (s p)
8.7943- (if (consp x) (values (car x) (cadr x)) (values x :asdf))
8.7944- (find-symbol* s p nil)))
8.7945- (asyms (l) (mapcar #'asym l)))
8.7946- (loop :for (name superclasses slots) :in redefined-classes
8.7947- :for sym = (find-symbol* name :asdf nil)
8.7948- :when (and sym (find-class sym))
8.7949- :do #+ccl (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))
8.7950- #-ccl (setf (find-class sym) nil))))) ;; mkcl
8.7951-
8.7952-;;; Self-upgrade functions
8.7953-(with-upgradability ()
8.7954- ;; This private function is called at the end of asdf/footer and ensures that,
8.7955- ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called.
8.7956- (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*)))
8.7957- (let ((new-version (asdf-version)))
8.7958- (unless (equal old-version new-version)
8.7959- (push new-version *previous-asdf-versions*)
8.7960- (when (boundp '*asdf-upgraded-p*)
8.7961- (setf *asdf-upgraded-p* t))
8.7962- (when old-version
8.7963- (if (version<= new-version old-version)
8.7964- (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
8.7965- old-version new-version)
8.7966- (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
8.7967- old-version new-version))
8.7968- ;; In case the previous version was too old to be forward-compatible, clear systems.
8.7969- ;; TODO: if needed, we may have to define a separate hook to run
8.7970- ;; in case of forward-compatible upgrade.
8.7971- ;; Or to move the tests forward-compatibility test inside each hook function?
8.7972- (unless (version<= *oldest-forward-compatible-asdf-version* old-version)
8.7973- (call-functions (reverse *post-upgrade-cleanup-hook*)))
8.7974- t))))
8.7975-
8.7976- (defun upgrade-asdf ()
8.7977- "Try to upgrade of ASDF. If a different version was used, return T.
8.7978- We need do that before we operate on anything that may possibly depend on ASDF."
8.7979- (let ((*load-print* nil)
8.7980- (*compile-print* nil)
8.7981- (*asdf-upgraded-p* nil))
8.7982- (handler-bind (((or style-warning) #'muffle-warning))
8.7983- (symbol-call :asdf :load-system :asdf :verbose nil))
8.7984- *asdf-upgraded-p*))
8.7985-
8.7986- (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body)
8.7987- `(with-upgradability ()
8.7988- (with-deprecation ((version-deprecation *asdf-version* ,@keys))
8.7989- ,@body))))
8.7990-;;;; -------------------------------------------------------------------------
8.7991-;;;; Session
8.7992-
8.7993-(uiop/package:define-package :asdf/session
8.7994- (:recycle :asdf/session :asdf/cache :asdf/component
8.7995- :asdf/action :asdf/find-system :asdf/plan :asdf)
8.7996- (:use :uiop/common-lisp :uiop :asdf/upgrade)
8.7997- (:export
8.7998- #:get-file-stamp #:compute-file-stamp #:register-file-stamp
8.7999- #:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
8.8000- #:do-asdf-cache #:normalize-namestring
8.8001- #:call-with-asdf-session #:with-asdf-session
8.8002- #:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session
8.8003- #:session-cache #:forcing #:asdf-upgraded-p
8.8004- #:visited-actions #:visiting-action-set #:visiting-action-list
8.8005- #:total-action-count #:planned-action-count #:planned-output-action-count
8.8006- #:clear-configuration-and-retry #:retry
8.8007- #:operate-level
8.8008- ;; conditions
8.8009- #:system-definition-error ;; top level, moved here because this is the earliest place for it.
8.8010- #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error))
8.8011-(in-package :asdf/session)
8.8012-
8.8013-
8.8014-(with-upgradability ()
8.8015- ;; The session variable.
8.8016- ;; NIL when outside a session.
8.8017- (defvar *asdf-session* nil)
8.8018- (defparameter* *asdf-session-class* 'session
8.8019- "The default class for sessions")
8.8020-
8.8021- (defclass session ()
8.8022- (;; The ASDF session cache is used to memoize some computations.
8.8023- ;; It is instrumental in achieving:
8.8024- ;; * Consistency in the view of the world relied on by ASDF within a given session.
8.8025- ;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
8.8026- ;; (a.k.a. stack overflows) and other erratic behavior.
8.8027- ;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
8.8028- ;; no expensive recomputations of transitive dependencies for input-files or output-files.
8.8029- ;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
8.8030- (ancestor
8.8031- :initform nil :initarg :ancestor :reader session-ancestor
8.8032- :documentation "Top level session that this is part of")
8.8033- (session-cache
8.8034- :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache
8.8035- :documentation "Memoize expensive computations")
8.8036- (operate-level
8.8037- :initform 0 :initarg :operate-level :accessor session-operate-level
8.8038- :documentation "Number of nested calls to operate we're under (for toplevel session only)")
8.8039- ;; shouldn't the below be superseded by the session-wide caching of action-status
8.8040- ;; for (load-op "asdf") ?
8.8041- (asdf-upgraded-p
8.8042- :initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p
8.8043- :documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.")
8.8044- (forcing
8.8045- :initform nil :initarg :forcing :accessor forcing
8.8046- :documentation "Forcing parameters for the session")
8.8047- ;; Table that to actions already visited while walking the dependencies associates status
8.8048- (visited-actions :initform (make-hash-table :test 'equal) :accessor visited-actions)
8.8049- ;; Actions that depend on those being currently walked through, to detect circularities
8.8050- (visiting-action-set ;; as a set
8.8051- :initform (make-hash-table :test 'equal) :accessor visiting-action-set)
8.8052- (visiting-action-list :initform () :accessor visiting-action-list) ;; as a list
8.8053- ;; Counts of total actions in plan
8.8054- (total-action-count :initform 0 :accessor total-action-count)
8.8055- ;; Count of actions that need to be performed
8.8056- (planned-action-count :initform 0 :accessor planned-action-count)
8.8057- ;; Count of actions that need to be performed that have a non-empty list of output-files.
8.8058- (planned-output-action-count :initform 0 :accessor planned-output-action-count))
8.8059- (:documentation "An ASDF session with a cache to memoize some computations"))
8.8060-
8.8061- (defun toplevel-asdf-session ()
8.8062- (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*)))
8.8063-
8.8064- (defun operate-level ()
8.8065- (session-operate-level (toplevel-asdf-session)))
8.8066-
8.8067- (defun (setf operate-level) (new-level)
8.8068- (setf (session-operate-level (toplevel-asdf-session)) new-level))
8.8069-
8.8070- (defun asdf-cache ()
8.8071- (session-cache *asdf-session*))
8.8072-
8.8073- ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
8.8074- ;; Return those values.
8.8075- (defun set-asdf-cache-entry (key value-list)
8.8076- (values-list (if *asdf-session*
8.8077- (setf (gethash key (asdf-cache)) value-list)
8.8078- value-list)))
8.8079-
8.8080- ;; Unset the session cache entry for KEY, when inside a session.
8.8081- (defun unset-asdf-cache-entry (key)
8.8082- (when *asdf-session*
8.8083- (remhash key (session-cache *asdf-session*))))
8.8084-
8.8085- ;; Consult the session cache entry for KEY if present and in a session;
8.8086- ;; if not present, compute it by calling the THUNK,
8.8087- ;; and set the session cache entry accordingly, if in a session.
8.8088- ;; Return the values from the cache and/or the thunk computation.
8.8089- (defun consult-asdf-cache (key &optional thunk)
8.8090- (if *asdf-session*
8.8091- (multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*))
8.8092- (if foundp
8.8093- (values-list results)
8.8094- (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
8.8095- (call-function thunk)))
8.8096-
8.8097- ;; Syntactic sugar for consult-asdf-cache
8.8098- (defmacro do-asdf-cache (key &body body)
8.8099- `(consult-asdf-cache ,key #'(lambda () ,@body)))
8.8100-
8.8101- ;; Compute inside a ASDF session with a cache.
8.8102- ;; First, make sure an ASDF session is underway, by binding the session cache variable
8.8103- ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true).
8.8104- ;; Second, if a new session was started, establish restarts for retrying the overall computation.
8.8105- ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache
8.8106- ;; entry isn't found, or just call the THUNK if no KEY was specified.
8.8107- (defun call-with-asdf-session (thunk &key override key override-cache override-forcing)
8.8108- (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
8.8109- (if (and (not override) *asdf-session*)
8.8110- (funcall fun)
8.8111- (loop
8.8112- (restart-case
8.8113- (let ((*asdf-session*
8.8114- (apply 'make-instance *asdf-session-class*
8.8115- (when *asdf-session*
8.8116- `(:ancestor ,(toplevel-asdf-session)
8.8117- ,@(unless override-forcing
8.8118- `(:forcing ,(forcing *asdf-session*)))
8.8119- ,@(unless override-cache
8.8120- `(:session-cache ,(session-cache *asdf-session*))))))))
8.8121- (return (funcall fun)))
8.8122- (retry ()
8.8123- :report (lambda (s)
8.8124- (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
8.8125- (clear-configuration-and-retry ()
8.8126- :report (lambda (s)
8.8127- (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
8.8128- (unless (null *asdf-session*)
8.8129- (clrhash (session-cache *asdf-session*)))
8.8130- (clear-configuration)))))))
8.8131-
8.8132- ;; Syntactic sugar for call-with-asdf-session
8.8133- (defmacro with-asdf-session ((&key key override override-cache override-forcing) &body body)
8.8134- `(call-with-asdf-session
8.8135- #'(lambda () ,@body)
8.8136- :override ,override :key ,key
8.8137- :override-cache ,override-cache :override-forcing ,override-forcing))
8.8138-
8.8139-
8.8140- ;;; Define specific accessor for file (date) stamp.
8.8141-
8.8142- ;; Normalize a namestring for use as a key in the session cache.
8.8143- (defun normalize-namestring (pathname)
8.8144- (let ((resolved (resolve-symlinks*
8.8145- (ensure-absolute-pathname
8.8146- (physicalize-pathname pathname)
8.8147- 'get-pathname-defaults))))
8.8148- (with-pathname-defaults () (namestring resolved))))
8.8149-
8.8150- ;; Compute the file stamp for a normalized namestring
8.8151- (defun compute-file-stamp (normalized-namestring)
8.8152- (with-pathname-defaults ()
8.8153- (or (safe-file-write-date normalized-namestring) t)))
8.8154-
8.8155- ;; Override the time STAMP associated to a given FILE in the session cache.
8.8156- ;; If no STAMP is specified, recompute a new one from the filesystem.
8.8157- (defun register-file-stamp (file &optional (stamp nil stampp))
8.8158- (let* ((namestring (normalize-namestring file))
8.8159- (stamp (if stampp stamp (compute-file-stamp namestring))))
8.8160- (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
8.8161-
8.8162- ;; Get or compute a memoized stamp for given FILE from the session cache.
8.8163- (defun get-file-stamp (file)
8.8164- (when file
8.8165- (let ((namestring (normalize-namestring file)))
8.8166- (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))
8.8167-
8.8168-
8.8169- ;;; Conditions
8.8170-
8.8171- (define-condition system-definition-error (error) ()
8.8172- ;; [this use of :report should be redundant, but unfortunately it's not.
8.8173- ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
8.8174- ;; over print-object; this is always conditions::%print-condition for
8.8175- ;; condition objects, which in turn does inheritance of :report options at
8.8176- ;; run-time. fortunately, inheritance means we only need this kludge here in
8.8177- ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
8.8178- #+cmucl (:report print-object))
8.8179-
8.8180- (define-condition formatted-system-definition-error (system-definition-error)
8.8181- ((format-control :initarg :format-control :reader format-control)
8.8182- (format-arguments :initarg :format-arguments :reader format-arguments))
8.8183- (:report (lambda (c s)
8.8184- (apply 'format s (format-control c) (format-arguments c)))))
8.8185-
8.8186- (defun sysdef-error (format &rest arguments)
8.8187- (error 'formatted-system-definition-error :format-control
8.8188- format :format-arguments arguments)))
8.8189-;;;; -------------------------------------------------------------------------
8.8190-;;;; Components
8.8191-
8.8192-(uiop/package:define-package :asdf/component
8.8193- (:recycle :asdf/component :asdf/find-component :asdf)
8.8194- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
8.8195- (:export
8.8196- #:component #:component-find-path
8.8197- #:find-component ;; methods defined in find-component
8.8198- #:component-name #:component-pathname #:component-relative-pathname
8.8199- #:component-parent #:component-system #:component-parent-pathname
8.8200- #:child-component #:parent-component #:module
8.8201- #:file-component
8.8202- #:source-file #:c-source-file #:java-source-file
8.8203- #:static-file #:doc-file #:html-file
8.8204- #:file-type
8.8205- #:source-file-type #:source-file-explicit-type ;; backward-compatibility
8.8206- #:component-in-order-to #:component-sideway-dependencies
8.8207- #:component-if-feature #:around-compile-hook
8.8208- #:component-description #:component-long-description
8.8209- #:component-version #:version-satisfies
8.8210- #:component-inline-methods ;; backward-compatibility only. DO NOT USE!
8.8211- #:component-operation-times ;; For internal use only.
8.8212- ;; portable ASDF encoding and implementation-specific external-format
8.8213- #:component-external-format #:component-encoding
8.8214- #:component-children-by-name #:component-children #:compute-children-by-name
8.8215- #:component-build-operation
8.8216- #:module-default-component-class
8.8217- #:module-components ;; backward-compatibility. DO NOT USE.
8.8218- #:sub-components
8.8219-
8.8220- ;; conditions
8.8221- #:duplicate-names
8.8222-
8.8223- ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
8.8224- #:name #:version #:description #:long-description #:author #:maintainer #:licence
8.8225- #:components-by-name #:components #:children #:children-by-name
8.8226- #:default-component-class #:source-file
8.8227- #:defsystem-depends-on ; This symbol retained for backward compatibility.
8.8228- #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
8.8229- #:relative-pathname #:absolute-pathname #:operation-times #:around-compile
8.8230- #:%encoding #:properties #:component-properties #:parent))
8.8231-(in-package :asdf/component)
8.8232-
8.8233-(with-upgradability ()
8.8234- (defgeneric component-name (component)
8.8235- (:documentation "Name of the COMPONENT, unique relative to its parent"))
8.8236- (defgeneric component-system (component)
8.8237- (:documentation "Top-level system containing the COMPONENT"))
8.8238- (defgeneric component-pathname (component)
8.8239- (:documentation "Pathname of the COMPONENT if any, or NIL."))
8.8240- (defgeneric component-relative-pathname (component)
8.8241- ;; in ASDF4, rename that to component-specified-pathname ?
8.8242- (:documentation "Specified pathname of the COMPONENT,
8.8243-intended to be merged with the pathname of that component's parent if any, using merged-pathnames*.
8.8244-Despite the function's name, the return value can be an absolute pathname, in which case the merge
8.8245-will leave it unmodified."))
8.8246- (defgeneric component-external-format (component)
8.8247- (:documentation "The external-format of the COMPONENT.
8.8248-By default, deduced from the COMPONENT-ENCODING."))
8.8249- (defgeneric component-encoding (component)
8.8250- (:documentation "The encoding of the COMPONENT. By default, only :utf-8 is supported.
8.8251-Use asdf-encodings to support more encodings."))
8.8252- (defgeneric version-satisfies (component version)
8.8253- (:documentation "Check whether a COMPONENT satisfies the constraint of being at least as recent
8.8254-as the specified VERSION, which must be a string of dot-separated natural numbers, or NIL."))
8.8255- (defgeneric component-version (component)
8.8256- (:documentation "Return the version of a COMPONENT, which must be a string of dot-separated
8.8257-natural numbers, or NIL."))
8.8258- (defgeneric (setf component-version) (new-version component)
8.8259- (:documentation "Updates the version of a COMPONENT, which must be a string of dot-separated
8.8260-natural numbers, or NIL."))
8.8261- (defgeneric component-parent (component)
8.8262- (:documentation "The parent of a child COMPONENT,
8.8263-or NIL for top-level components (a.k.a. systems)"))
8.8264- ;; NIL is a designator for the absence of a component, in which case the parent is also absent.
8.8265- (defmethod component-parent ((component null)) nil)
8.8266-
8.8267- ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component.
8.8268- (with-asdf-deprecation (:style-warning "3.4")
8.8269- (defgeneric source-file-type (component system)
8.8270- (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead.")))
8.8271-
8.8272- (define-condition duplicate-names (system-definition-error)
8.8273- ((name :initarg :name :reader duplicate-names-name))
8.8274- (:report (lambda (c s)
8.8275- (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
8.8276- (duplicate-names-name c))))))
8.8277-
8.8278-
8.8279-(with-upgradability ()
8.8280- (defclass component ()
8.8281- ((name :accessor component-name :initarg :name :type string :documentation
8.8282- "Component name: designator for a string composed of portable pathname characters")
8.8283- ;; We might want to constrain version with
8.8284- ;; :type (and string (satisfies parse-version))
8.8285- ;; but we cannot until we fix all systems that don't use it correctly!
8.8286- (version :accessor component-version :initarg :version :initform nil)
8.8287- (description :accessor component-description :initarg :description :initform nil)
8.8288- (long-description :accessor component-long-description :initarg :long-description :initform nil)
8.8289- (sideway-dependencies :accessor component-sideway-dependencies :initform nil)
8.8290- (if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
8.8291- ;; In the ASDF object model, dependencies exist between *actions*,
8.8292- ;; where an action is a pair of an operation and a component.
8.8293- ;; Dependencies are represented as alists of operations
8.8294- ;; to a list where each entry is a pair of an operation and a list of component specifiers.
8.8295- ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies:
8.8296- ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to.
8.8297- ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl)
8.8298- ;; and do-first things that modify the current image (such as loading a fasl).
8.8299- ;; These are now unified because we now correctly propagate timestamps between dependencies.
8.8300- ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017,
8.8301- ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains.
8.8302- ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52!
8.8303- ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
8.8304- ;; Maybe rename the slots in ASDF? But that's not very backward-compatible.
8.8305- ;; See our ASDF 2 paper for more complete explanations.
8.8306- (in-order-to :initform nil :initarg :in-order-to
8.8307- :accessor component-in-order-to)
8.8308- ;; Methods defined using the "inline" style inside a defsystem form:
8.8309- ;; we store them here so we can delete them when the system is re-evaluated.
8.8310- (inline-methods :accessor component-inline-methods :initform nil)
8.8311- ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative.
8.8312- ;; There is no initform and no direct accessor for this specified pathname,
8.8313- ;; so we only access the information through appropriate methods, after it has been processed.
8.8314- ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4.
8.8315- (relative-pathname :initarg :pathname)
8.8316- ;; The absolute-pathname is computed based on relative-pathname and parent pathname.
8.8317- ;; The slot is but a cache used by component-pathname.
8.8318- (absolute-pathname)
8.8319- (operation-times :initform (make-hash-table)
8.8320- :accessor component-operation-times)
8.8321- (around-compile :initarg :around-compile)
8.8322- ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE!
8.8323- (properties :accessor component-properties :initarg :properties
8.8324- :initform nil)
8.8325- (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
8.8326- ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it.
8.8327- (parent :initarg :parent :initform nil :reader component-parent)
8.8328- (build-operation
8.8329- :initarg :build-operation :initform nil :reader component-build-operation)
8.8330- ;; Cache for ADDITIONAL-INPUT-FILES function.
8.8331- (additional-input-files :accessor %additional-input-files :initform nil))
8.8332- (:documentation "Base class for all components of a build"))
8.8333-
8.8334- (defgeneric find-component (base path &key registered)
8.8335- (:documentation "Find a component by resolving the PATH starting from BASE parent.
8.8336-If REGISTERED is true, only search currently registered systems."))
8.8337-
8.8338- (defun component-find-path (component)
8.8339- "Return a path from a root system to the COMPONENT.
8.8340-The return value is a list of component NAMES; a list of strings."
8.8341- (check-type component (or null component))
8.8342- (reverse
8.8343- (loop :for c = component :then (component-parent c)
8.8344- :while c :collect (component-name c))))
8.8345-
8.8346- (defmethod print-object ((c component) stream)
8.8347- (print-unreadable-object (c stream :type t :identity nil)
8.8348- (format stream "~{~S~^ ~}" (component-find-path c))))
8.8349-
8.8350- (defmethod component-system ((component component))
8.8351- (if-let (system (component-parent component))
8.8352- (component-system system)
8.8353- component)))
8.8354-
8.8355-
8.8356-;;;; Component hierarchy within a system
8.8357-;; The tree typically but not necessarily follows the filesystem hierarchy.
8.8358-(with-upgradability ()
8.8359- (defclass child-component (component) ()
8.8360- (:documentation "A CHILD-COMPONENT is a COMPONENT that may be part of
8.8361-a PARENT-COMPONENT."))
8.8362-
8.8363- (defclass file-component (child-component)
8.8364- ((type :accessor file-type :initarg :type)) ; no default
8.8365- (:documentation "a COMPONENT that represents a file"))
8.8366- (defclass source-file (file-component)
8.8367- ((type :accessor source-file-explicit-type ;; backward-compatibility
8.8368- :initform nil))) ;; NB: many systems have come to rely on this default.
8.8369- (defclass c-source-file (source-file)
8.8370- ((type :initform "c")))
8.8371- (defclass java-source-file (source-file)
8.8372- ((type :initform "java")))
8.8373- (defclass static-file (source-file)
8.8374- ((type :initform nil))
8.8375- (:documentation "Component for a file to be included as is in the build output"))
8.8376- (defclass doc-file (static-file) ())
8.8377- (defclass html-file (doc-file)
8.8378- ((type :initform "html")))
8.8379-
8.8380- (defclass parent-component (component)
8.8381- ((children
8.8382- :initform nil
8.8383- :initarg :components
8.8384- :reader module-components ; backward-compatibility
8.8385- :accessor component-children)
8.8386- (children-by-name
8.8387- :reader module-components-by-name ; backward-compatibility
8.8388- :accessor component-children-by-name)
8.8389- (default-component-class
8.8390- :initform nil
8.8391- :initarg :default-component-class
8.8392- :accessor module-default-component-class))
8.8393- (:documentation "A PARENT-COMPONENT is a component that may have children.")))
8.8394-
8.8395-(with-upgradability ()
8.8396- ;; (Private) Function that given a PARENT component,
8.8397- ;; the list of children of which has been initialized,
8.8398- ;; compute the hash-table in slot children-by-name that allows to retrieve its children by name.
8.8399- ;; If ONLY-IF-NEEDED-P is defined, skip any (re)computation if the slot is already populated.
8.8400- (defun compute-children-by-name (parent &key only-if-needed-p)
8.8401- (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
8.8402- (let ((hash (make-hash-table :test 'equal)))
8.8403- (setf (component-children-by-name parent) hash)
8.8404- (loop :for c :in (component-children parent)
8.8405- :for name = (component-name c)
8.8406- :for previous = (gethash name hash)
8.8407- :do (when previous (error 'duplicate-names :name name))
8.8408- (setf (gethash name hash) c))
8.8409- hash))))
8.8410-
8.8411-(with-upgradability ()
8.8412- (defclass module (child-component parent-component)
8.8413- (#+clisp (components)) ;; backward compatibility during upgrade only
8.8414- (:documentation "A module is a intermediate component with both a parent and children,
8.8415-typically but not necessarily representing the files in a subdirectory of the build source.")))
8.8416-
8.8417-
8.8418-;;;; component pathnames
8.8419-(with-upgradability ()
8.8420- (defgeneric component-parent-pathname (component)
8.8421- (:documentation "The pathname of the COMPONENT's parent, if any, or NIL"))
8.8422- (defmethod component-parent-pathname (component)
8.8423- (component-pathname (component-parent component)))
8.8424-
8.8425- ;; The default method for component-pathname tries to extract a cached precomputed
8.8426- ;; absolute-pathname from the relevant slot, and if not, computes it by merging the
8.8427- ;; component-relative-pathname (which should be component-specified-pathname, it can be absolute)
8.8428- ;; with the directory of the component-parent-pathname.
8.8429- (defmethod component-pathname ((component component))
8.8430- (if (slot-boundp component 'absolute-pathname)
8.8431- (slot-value component 'absolute-pathname)
8.8432- (let ((pathname
8.8433- (merge-pathnames*
8.8434- (component-relative-pathname component)
8.8435- (pathname-directory-pathname (component-parent-pathname component)))))
8.8436- (unless (or (null pathname) (absolute-pathname-p pathname))
8.8437- (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
8.8438- pathname (component-find-path component)))
8.8439- (setf (slot-value component 'absolute-pathname) pathname)
8.8440- pathname)))
8.8441-
8.8442- ;; Default method for component-relative-pathname:
8.8443- ;; combine the contents of slot relative-pathname (from specified initarg :pathname)
8.8444- ;; with the appropriate source-file-type, which defaults to the file-type of the component.
8.8445- (defmethod component-relative-pathname ((component component))
8.8446- ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
8.8447- ;; We ought to be able to extract this from the component alone with FILE-TYPE.
8.8448- ;; TODO: track who uses it in Quicklisp, and have them not use it anymore;
8.8449- ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
8.8450- (let (#+abcl
8.8451- (parent
8.8452- (component-parent-pathname component)))
8.8453- (parse-unix-namestring
8.8454- (or (and (slot-boundp component 'relative-pathname)
8.8455- (slot-value component 'relative-pathname))
8.8456- (component-name component))
8.8457- :want-relative
8.8458- #-abcl t
8.8459- ;; JAR-PATHNAMES always have absolute directories
8.8460- #+abcl (not (ext:pathname-jar-p parent))
8.8461- :type (source-file-type component (component-system component))
8.8462- :defaults (component-parent-pathname component))))
8.8463-
8.8464- (defmethod source-file-type ((component parent-component) (system parent-component))
8.8465- :directory)
8.8466-
8.8467- (defmethod source-file-type ((component file-component) (system parent-component))
8.8468- (file-type component)))
8.8469-
8.8470-
8.8471-;;;; Encodings
8.8472-(with-upgradability ()
8.8473- (defmethod component-encoding ((c component))
8.8474- (or (loop :for x = c :then (component-parent x)
8.8475- :while x :thereis (%component-encoding x))
8.8476- (detect-encoding (component-pathname c))))
8.8477-
8.8478- (defmethod component-external-format ((c component))
8.8479- (encoding-external-format (component-encoding c))))
8.8480-
8.8481-
8.8482-;;;; around-compile-hook
8.8483-(with-upgradability ()
8.8484- (defgeneric around-compile-hook (component)
8.8485- (:documentation "An optional hook function that will be called with one argument, a thunk.
8.8486-The hook function must call the thunk, that will compile code from the component, and may or may not
8.8487-also evaluate the compiled results. The hook function may establish dynamic variable bindings around
8.8488-this compilation, or check its results, etc."))
8.8489- (defmethod around-compile-hook ((c component))
8.8490- (cond
8.8491- ((slot-boundp c 'around-compile)
8.8492- (slot-value c 'around-compile))
8.8493- ((component-parent c)
8.8494- (around-compile-hook (component-parent c))))))
8.8495-
8.8496-
8.8497-;;;; version-satisfies
8.8498-(with-upgradability ()
8.8499- ;; short-circuit testing of null version specifications.
8.8500- ;; this is an all-pass, without warning
8.8501- (defmethod version-satisfies :around ((c t) (version null))
8.8502- t)
8.8503- (defmethod version-satisfies ((c component) version)
8.8504- (unless (and version (slot-boundp c 'version) (component-version c))
8.8505- (when version
8.8506- (warn "Requested version ~S but ~S has no version" version c))
8.8507- (return-from version-satisfies nil))
8.8508- (version-satisfies (component-version c) version))
8.8509-
8.8510- (defmethod version-satisfies ((cver string) version)
8.8511- (version<= version cver)))
8.8512-
8.8513-
8.8514-;;; all sub-components (of a given type)
8.8515-(with-upgradability ()
8.8516- (defun sub-components (component &key (type t))
8.8517- "Compute the transitive sub-components of given COMPONENT that are of given TYPE"
8.8518- (while-collecting (c)
8.8519- (labels ((recurse (x)
8.8520- (when (if-let (it (component-if-feature x)) (featurep it) t)
8.8521- (when (typep x type)
8.8522- (c x))
8.8523- (when (typep x 'parent-component)
8.8524- (map () #'recurse (component-children x))))))
8.8525- (recurse component)))))
8.8526-
8.8527-;;;; -------------------------------------------------------------------------
8.8528-;;;; Operations
8.8529-
8.8530-(uiop/package:define-package :asdf/operation
8.8531- (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
8.8532- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
8.8533- (:export
8.8534- #:operation
8.8535- #:*operations* #:make-operation #:find-operation
8.8536- #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature.
8.8537-(in-package :asdf/operation)
8.8538-
8.8539-;;; Operation Classes
8.8540-(when-upgrading (:version "2.27" :when (find-class 'operation nil))
8.8541- ;; override any obsolete shared-initialize method when upgrading from ASDF2.
8.8542- (defmethod shared-initialize :after ((o operation) (slot-names t) &key)
8.8543- (values)))
8.8544-
8.8545-(with-upgradability ()
8.8546- (defclass operation ()
8.8547- ()
8.8548- (:documentation "The base class for all ASDF operations.
8.8549-
8.8550-ASDF does NOT and never did distinguish between multiple operations of the same class.
8.8551-Therefore, all slots of all operations MUST have :allocation :class and no initargs. No exceptions.
8.8552-"))
8.8553-
8.8554- (defvar *in-make-operation* nil)
8.8555-
8.8556- (defun check-operation-constructor ()
8.8557- "Enforce that OPERATION instances must be created with MAKE-OPERATION."
8.8558- (unless *in-make-operation*
8.8559- (sysdef-error "OPERATION instances must only be created through MAKE-OPERATION.")))
8.8560-
8.8561- (defmethod print-object ((o operation) stream)
8.8562- (print-unreadable-object (o stream :type t :identity nil)))
8.8563-
8.8564- ;;; Override previous methods (from 3.1.7 and earlier) and add proper error checking.
8.8565- #-genera ;; Genera adds its own system initargs, e.g. clos-internals:storage-area 8
8.8566- (defmethod initialize-instance :after ((o operation) &rest initargs &key &allow-other-keys)
8.8567- (unless (null initargs)
8.8568- (parameter-error "~S does not accept initargs" 'operation))))
8.8569-
8.8570-
8.8571-;;; make-operation, find-operation
8.8572-
8.8573-(with-upgradability ()
8.8574- ;; A table to memoize instances of a given operation. There shall be only one.
8.8575- (defparameter* *operations* (make-hash-table :test 'equal))
8.8576-
8.8577- ;; A memoizing way of creating instances of operation.
8.8578- (defun make-operation (operation-class)
8.8579- "This function creates and memoizes an instance of OPERATION-CLASS.
8.8580-All operation instances MUST be created through this function.
8.8581-
8.8582-Use of INITARGS is not supported at this time."
8.8583- (let ((class (coerce-class operation-class
8.8584- :package :asdf/interface :super 'operation :error 'sysdef-error))
8.8585- (*in-make-operation* t))
8.8586- (ensure-gethash class *operations* `(make-instance ,class))))
8.8587-
8.8588- ;; This function is mostly for backward and forward compatibility:
8.8589- ;; operations used to preserve the operation-original-initargs of the context,
8.8590- ;; and may in the future preserve some operation-canonical-initargs.
8.8591- ;; Still, the treatment of NIL as a disabling context is useful in some cases.
8.8592- (defgeneric find-operation (context spec)
8.8593- (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
8.8594- (defmethod find-operation ((context t) (spec operation))
8.8595- spec)
8.8596- (defmethod find-operation ((context t) (spec symbol))
8.8597- (when spec ;; NIL designates itself, i.e. absence of operation
8.8598- (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context)
8.8599- (defmethod find-operation ((context t) (spec string))
8.8600- (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context)
8.8601-
8.8602-;;;; -------------------------------------------------------------------------
8.8603-;;;; Systems
8.8604-
8.8605-(uiop/package:define-package :asdf/system
8.8606- (:recycle :asdf :asdf/system :asdf/find-system)
8.8607- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component)
8.8608- (:export
8.8609- #:system #:proto-system #:undefined-system #:reset-system-class
8.8610- #:system-source-file #:system-source-directory #:system-relative-pathname
8.8611- #:system-description #:system-long-description
8.8612- #:system-author #:system-maintainer #:system-licence #:system-license
8.8613- #:system-version
8.8614- #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on
8.8615- #:system-depends-on #:system-weakly-depends-on
8.8616- #:component-build-pathname #:build-pathname
8.8617- #:component-entry-point #:entry-point
8.8618- #:homepage #:system-homepage
8.8619- #:bug-tracker #:system-bug-tracker
8.8620- #:mailto #:system-mailto
8.8621- #:long-name #:system-long-name
8.8622- #:source-control #:system-source-control
8.8623- #:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename
8.8624- #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system
8.8625-(in-package :asdf/system)
8.8626-
8.8627-(with-upgradability ()
8.8628- ;; The method is actually defined in asdf/find-system,
8.8629- ;; but we declare the function here to avoid a forward reference.
8.8630- (defgeneric find-system (system &optional error-p)
8.8631- (:documentation "Given a system designator, find the actual corresponding system object.
8.8632-If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL.
8.8633-A system designator is usually a string (conventionally all lowercase) or a symbol, designating
8.8634-the same system as its downcased name; it can also be a system object (designating itself)."))
8.8635-
8.8636- (defgeneric system-source-file (system)
8.8637- (:documentation "Return the source file in which system is defined."))
8.8638-
8.8639- ;; This is bad design, but was the easiest kluge I found to let the user specify that
8.8640- ;; some special actions create outputs at locations controled by the user that are not affected
8.8641- ;; by the usual output-translations.
8.8642- ;; TODO: Fix operate to stop passing flags to operation (which in the current design shouldn't
8.8643- ;; have any flags, since the stamp cache, etc., can't distinguish them), and instead insert
8.8644- ;; *there* the ability of specifying special output paths, not in the system definition.
8.8645- (defgeneric component-build-pathname (component)
8.8646- (:documentation "The COMPONENT-BUILD-PATHNAME, when defined and not null, specifies the
8.8647-output pathname for the action using the COMPONENT-BUILD-OPERATION.
8.8648-
8.8649-NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
8.8650-
8.8651- ;; TODO: Should this have been made a SYSTEM-ENTRY-POINT instead?
8.8652- (defgeneric component-entry-point (component)
8.8653- (:documentation "The COMPONENT-ENTRY-POINT, when defined, specifies what function to call
8.8654-(with no argument) when running an image dumped from the COMPONENT.
8.8655-
8.8656-NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
8.8657-
8.8658- (defmethod component-entry-point ((c component))
8.8659- nil))
8.8660-
8.8661-
8.8662-;;;; The system class
8.8663-
8.8664-(with-upgradability ()
8.8665- (defclass proto-system () ; slots to keep when resetting a system
8.8666- ;; To preserve identity for all objects, we'd need keep the components slots
8.8667- ;; but also to modify parse-component-form to reset the recycled objects.
8.8668- ((name)
8.8669- (source-file)
8.8670- ;; These two slots contains the *inferred* dependencies of define-op,
8.8671- ;; from loading the .asd file, as list and as set.
8.8672- (definition-dependency-list
8.8673- :initform nil :accessor definition-dependency-list)
8.8674- (definition-dependency-set
8.8675- :initform (list-to-hash-set nil) :accessor definition-dependency-set))
8.8676- (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when
8.8677-a SYSTEM is redefined and its class is modified."))
8.8678-
8.8679- (defclass system (module proto-system)
8.8680- ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component.
8.8681- (;; {,long-}description is now inherited from component, but we add the legacy accessors
8.8682- (description :writer (setf system-description))
8.8683- (long-description :writer (setf system-long-description))
8.8684- (author :writer (setf system-author) :initarg :author :initform nil)
8.8685- (maintainer :writer (setf system-maintainer) :initarg :maintainer :initform nil)
8.8686- (licence :writer (setf system-licence) :initarg :licence
8.8687- :writer (setf system-license) :initarg :license
8.8688- :initform nil)
8.8689- (homepage :writer (setf system-homepage) :initarg :homepage :initform nil)
8.8690- (bug-tracker :writer (setf system-bug-tracker) :initarg :bug-tracker :initform nil)
8.8691- (mailto :writer (setf system-mailto) :initarg :mailto :initform nil)
8.8692- (long-name :writer (setf system-long-name) :initarg :long-name :initform nil)
8.8693- ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced.
8.8694- ;; I'm introducing the slot before the conventions are set for maximum compatibility.
8.8695- (source-control :writer (setf system-source-control) :initarg :source-control :initform nil)
8.8696-
8.8697- (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)
8.8698- (build-pathname
8.8699- :initform nil :initarg :build-pathname :accessor component-build-pathname)
8.8700- (entry-point
8.8701- :initform nil :initarg :entry-point :accessor component-entry-point)
8.8702- (source-file :initform nil :initarg :source-file :accessor system-source-file)
8.8703- ;; This slot contains the *declared* defsystem-depends-on dependencies
8.8704- (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
8.8705- :initform nil)
8.8706- ;; these two are specially set in parse-component-form, so have no :INITARGs.
8.8707- (depends-on :reader system-depends-on :initform nil)
8.8708- (weakly-depends-on :reader system-weakly-depends-on :initform nil))
8.8709- (:documentation "SYSTEM is the base class for top-level components that users may request
8.8710-ASDF to build."))
8.8711-
8.8712- (defclass undefined-system (system) ()
8.8713- (:documentation "System that was not defined yet."))
8.8714-
8.8715- (defun reset-system-class (system new-class &rest keys &key &allow-other-keys)
8.8716- "Erase any data from a SYSTEM except its basic identity, then reinitialize it
8.8717-based on supplied KEYS."
8.8718- (change-class (change-class system 'proto-system) new-class)
8.8719- (apply 'reinitialize-instance system keys)))
8.8720-
8.8721-
8.8722-;;; Canonicalizing system names
8.8723-
8.8724-(with-upgradability ()
8.8725- (defun coerce-name (name)
8.8726- "Given a designator for a component NAME, return the name as a string.
8.8727-The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component),
8.8728-a SYMBOL (designing its name, downcased), or a STRING (designing itself)."
8.8729- (typecase name
8.8730- (component (component-name name))
8.8731- (symbol (string-downcase name))
8.8732- (string name)
8.8733- (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
8.8734-
8.8735- (defun primary-system-name (system-designator)
8.8736- "Given a system designator NAME, return the name of the corresponding
8.8737-primary system, after which the .asd file in which it is defined is named.
8.8738-If given a string or symbol (to downcase), do it syntactically
8.8739- by stripping anything from the first slash on.
8.8740-If given a component, do it semantically by extracting
8.8741-the system-primary-system-name of its system from its source-file if any,
8.8742-falling back to the syntactic criterion if none."
8.8743- (etypecase system-designator
8.8744- (string (if-let (p (position #\/ system-designator))
8.8745- (subseq system-designator 0 p) system-designator))
8.8746- (symbol (primary-system-name (coerce-name system-designator)))
8.8747- (component (let* ((system (component-system system-designator))
8.8748- (source-file (physicalize-pathname (system-source-file system))))
8.8749- (if source-file
8.8750- (and (equal (pathname-type source-file) "asd")
8.8751- (pathname-name source-file))
8.8752- (primary-system-name (component-name system)))))))
8.8753-
8.8754- (defun primary-system-p (system)
8.8755- "Given a system designator SYSTEM, return T if it designates a primary system, or else NIL.
8.8756-If given a string, do it syntactically and return true if the name does not contain a slash.
8.8757-If given a symbol, downcase to a string then fallback to previous case (NB: for NIL return T).
8.8758-If given a component, do it semantically and return T if it's a SYSTEM and its primary-system-name
8.8759-is the same as its component-name."
8.8760- (etypecase system
8.8761- (string (not (find #\/ system)))
8.8762- (symbol (primary-system-p (coerce-name system)))
8.8763- (component (and (typep system 'system)
8.8764- (equal (component-name system) (primary-system-name system))))))
8.8765-
8.8766- (defun coerce-filename (name)
8.8767- "Coerce a system designator NAME into a string suitable as a filename component.
8.8768-The (current) transformation is to replace characters /:\\ each by --,
8.8769-the former being forbidden in a filename component.
8.8770-NB: The onus is unhappily on the user to avoid clashes."
8.8771- (frob-substrings (coerce-name name) '("/" ":" "\\") "--")))
8.8772-
8.8773-
8.8774-;;; System virtual slot readers, recursing to the primary system if needed.
8.8775-(with-upgradability ()
8.8776- (defvar *system-virtual-slots* '(long-name description long-description
8.8777- author maintainer mailto
8.8778- homepage source-control
8.8779- licence version bug-tracker)
8.8780- "The list of system virtual slot names.")
8.8781- (defun system-virtual-slot-value (system slot-name)
8.8782- "Return SYSTEM's virtual SLOT-NAME value.
8.8783-If SYSTEM's SLOT-NAME value is NIL and SYSTEM is a secondary system, look in
8.8784-the primary one."
8.8785- (or (slot-value system slot-name)
8.8786- (unless (primary-system-p system)
8.8787- (slot-value (find-system (primary-system-name system))
8.8788- slot-name))))
8.8789- (defmacro define-system-virtual-slot-reader (slot-name)
8.8790- (let ((name (intern (strcat (string :system-) (string slot-name)))))
8.8791- `(progn
8.8792- (fmakunbound ',name) ;; These were gf from defgeneric before 3.3.2.11
8.8793- (declaim (notinline ,name))
8.8794- (defun ,name (system) (system-virtual-slot-value system ',slot-name)))))
8.8795- (defmacro define-system-virtual-slot-readers ()
8.8796- `(progn ,@(mapcar (lambda (slot-name)
8.8797- `(define-system-virtual-slot-reader ,slot-name))
8.8798- *system-virtual-slots*)))
8.8799- (define-system-virtual-slot-readers)
8.8800- (defun system-license (system)
8.8801- (system-virtual-slot-value system 'licence)))
8.8802-
8.8803-
8.8804-;;;; Pathnames
8.8805-
8.8806-(with-upgradability ()
8.8807- ;; Resolve a system designator to a system before extracting its system-source-file
8.8808- (defmethod system-source-file ((system-name string))
8.8809- (system-source-file (find-system system-name)))
8.8810- (defmethod system-source-file ((system-name symbol))
8.8811- (when system-name
8.8812- (system-source-file (find-system system-name))))
8.8813-
8.8814- (defun system-source-directory (system-designator)
8.8815- "Return a pathname object corresponding to the directory
8.8816-in which the system specification (.asd file) is located."
8.8817- (pathname-directory-pathname (system-source-file system-designator)))
8.8818-
8.8819- (defun system-relative-pathname (system name &key type)
8.8820- "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
8.8821-return the absolute pathname of a corresponding file under that system's source code pathname."
8.8822- (subpathname (system-source-directory system) name :type type))
8.8823-
8.8824- (defmethod component-pathname ((system system))
8.8825- "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
8.8826-return the absolute pathname of a corresponding file under that system's source code pathname."
8.8827- (let ((pathname (or (call-next-method) (system-source-directory system))))
8.8828- (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age
8.8829- (slot-value system 'relative-pathname)) ;; systems that directly access this slot.
8.8830- (setf (slot-value system 'relative-pathname) pathname))
8.8831- pathname))
8.8832-
8.8833- ;; The default method of component-relative-pathname for a system:
8.8834- ;; if a pathname was specified in the .asd file, it must be relative to the .asd file
8.8835- ;; (actually, to its truename* if *resolve-symlinks* it true, the default).
8.8836- ;; The method will return an *absolute* pathname, once again showing that the historical name
8.8837- ;; component-relative-pathname is misleading and should have been component-specified-pathname.
8.8838- (defmethod component-relative-pathname ((system system))
8.8839- (parse-unix-namestring
8.8840- (and (slot-boundp system 'relative-pathname)
8.8841- (slot-value system 'relative-pathname))
8.8842- :want-relative t
8.8843- :type :directory
8.8844- :ensure-absolute t
8.8845- :defaults (system-source-directory system)))
8.8846-
8.8847- ;; A system has no parent; if some method wants to make a path "relative to its parent",
8.8848- ;; it will instead be relative to the system itself.
8.8849- (defmethod component-parent-pathname ((system system))
8.8850- (system-source-directory system))
8.8851-
8.8852- ;; Most components don't have a specified component-build-pathname, and therefore
8.8853- ;; no magic redirection of their output that disregards the output-translations.
8.8854- (defmethod component-build-pathname ((c component))
8.8855- nil))
8.8856-
8.8857-;;;; -------------------------------------------------------------------------
8.8858-;;;; Finding systems
8.8859-
8.8860-(uiop/package:define-package :asdf/system-registry
8.8861- (:recycle :asdf/system-registry :asdf/find-system :asdf)
8.8862- (:use :uiop/common-lisp :uiop :asdf/upgrade
8.8863- :asdf/session :asdf/component :asdf/system)
8.8864- (:export
8.8865- #:remove-entry-from-registry #:coerce-entry-to-directory
8.8866- #:registered-system #:register-system
8.8867- #:registered-systems* #:registered-systems
8.8868- #:clear-system #:map-systems
8.8869- #:*system-definition-search-functions* #:search-for-system-definition
8.8870- #:*central-registry* #:probe-asd #:sysdef-central-registry-search
8.8871- #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
8.8872- #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
8.8873- #:find-system-if-being-defined #:mark-component-preloaded ;; forward references to asdf/find-system
8.8874- #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems*
8.8875- #:*registered-systems* #:clear-registered-systems
8.8876- ;; defined in source-registry, but specially mentioned here:
8.8877- #:sysdef-source-registry-search))
8.8878-(in-package :asdf/system-registry)
8.8879-
8.8880-(with-upgradability ()
8.8881- ;;; Registry of Defined Systems
8.8882-
8.8883- (defvar *registered-systems* (make-hash-table :test 'equal)
8.8884- "This is a hash table whose keys are strings -- the names of systems --
8.8885-and whose values are systems.
8.8886-A system is referred to as \"registered\" if it is present in this table.")
8.8887-
8.8888- (defun registered-system (name)
8.8889- "Return a system of given NAME that was registered already,
8.8890-if such a system exists. NAME is a system designator, to be
8.8891-normalized by COERCE-NAME. The value returned is a system object,
8.8892-or NIL if not found."
8.8893- (gethash (coerce-name name) *registered-systems*))
8.8894-
8.8895- (defun registered-systems* ()
8.8896- "Return a list containing every registered system (as a system object)."
8.8897- (loop :for registered :being :the :hash-values :of *registered-systems*
8.8898- :collect registered))
8.8899-
8.8900- (defun registered-systems ()
8.8901- "Return a list of the names of every registered system."
8.8902- (mapcar 'coerce-name (registered-systems*)))
8.8903-
8.8904- (defun register-system (system)
8.8905- "Given a SYSTEM object, register it."
8.8906- (check-type system system)
8.8907- (let ((name (component-name system)))
8.8908- (check-type name string)
8.8909- (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name)
8.8910- (setf (gethash name *registered-systems*) system)))
8.8911-
8.8912- (defun map-systems (fn)
8.8913- "Apply FN to each defined system.
8.8914-
8.8915-FN should be a function of one argument. It will be
8.8916-called with an object of type asdf:system."
8.8917- (loop :for registered :being :the :hash-values :of *registered-systems*
8.8918- :do (funcall fn registered)))
8.8919-
8.8920-
8.8921- ;;; Preloaded systems: in the image even if you can't find source files backing them.
8.8922-
8.8923- (defvar *preloaded-systems* (make-hash-table :test 'equal)
8.8924- "Registration table for preloaded systems.")
8.8925-
8.8926- (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/find-system
8.8927-
8.8928- (defun make-preloaded-system (name keys)
8.8929- "Make a preloaded system of given NAME with build information from KEYS"
8.8930- (let ((system (apply 'make-instance (getf keys :class 'system)
8.8931- :name name :source-file (getf keys :source-file)
8.8932- (remove-plist-keys '(:class :name :source-file) keys))))
8.8933- (mark-component-preloaded system)
8.8934- system))
8.8935-
8.8936- (defun sysdef-preloaded-system-search (requested)
8.8937- "If REQUESTED names a system registered as preloaded, return a new system
8.8938-with its registration information."
8.8939- (let ((name (coerce-name requested)))
8.8940- (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
8.8941- (when foundp
8.8942- (make-preloaded-system name keys)))))
8.8943-
8.8944- (defun ensure-preloaded-system-registered (name)
8.8945- "If there isn't a registered _defined_ system of given NAME,
8.8946-and a there is a registered _preloaded_ system of given NAME,
8.8947-then define and register said preloaded system."
8.8948- (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name)))
8.8949- (register-system system)))
8.8950-
8.8951- (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys)
8.8952- "Register a system as being preloaded. If the system has not been loaded from the filesystem
8.8953-yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be
8.8954-registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION).
8.8955-If VERSION is the default T, and a system was already loaded, then its version will be preserved."
8.8956- (let ((name (coerce-name system-name)))
8.8957- (when (eql version t)
8.8958- (if-let (system (registered-system name))
8.8959- (setf (getf keys :version) (component-version system))))
8.8960- (setf (gethash name *preloaded-systems*) keys)
8.8961- (ensure-preloaded-system-registered system-name)))
8.8962-
8.8963-
8.8964- ;;; Immutable systems: in the image and can't be reloaded from source.
8.8965-
8.8966- (defvar *immutable-systems* nil
8.8967- "A hash-set (equal hash-table mapping keys to T) of systems that are immutable,
8.8968-i.e. already loaded in memory and not to be refreshed from the filesystem.
8.8969-They will be treated specially by find-system, and passed as :force-not argument to make-plan.
8.8970-
8.8971-For instance, to can deliver an image with many systems precompiled, that *will not* check the
8.8972-filesystem for them every time a user loads an extension, what more risk a problematic upgrade
8.8973- or catastrophic downgrade, before you dump an image, you may use:
8.8974- (map () 'asdf:register-immutable-system (asdf:already-loaded-systems))
8.8975-
8.8976-Note that direct access to this variable from outside ASDF is not supported.
8.8977-Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and
8.8978-contact maintainers if you need a stable API to do more than that.")
8.8979-
8.8980- (defun sysdef-immutable-system-search (requested)
8.8981- (let ((name (coerce-name requested)))
8.8982- (when (and *immutable-systems* (gethash name *immutable-systems*))
8.8983- (or (registered-system requested)
8.8984- (error 'formatted-system-definition-error
8.8985- :format-control "Requested system ~A registered as an immutable-system, ~
8.8986-but not even registered as defined"
8.8987- :format-arguments (list name))))))
8.8988-
8.8989- (defun register-immutable-system (system-name &rest keys)
8.8990- "Register SYSTEM-NAME as preloaded and immutable.
8.8991-It will automatically be considered as passed to FORCE-NOT in a plan."
8.8992- (let ((system-name (coerce-name system-name)))
8.8993- (apply 'register-preloaded-system system-name keys)
8.8994- (unless *immutable-systems*
8.8995- (setf *immutable-systems* (list-to-hash-set nil)))
8.8996- (setf (gethash system-name *immutable-systems*) t)))
8.8997-
8.8998-
8.8999- ;;; Making systems undefined.
8.9000-
8.9001- (defun clear-system (system)
8.9002- "Clear the entry for a SYSTEM in the database of systems previously defined.
8.9003-However if the system was registered as PRELOADED (which it is if it is IMMUTABLE),
8.9004-then a new system with the same name will be defined and registered in its place
8.9005-from which build details will have been cleared.
8.9006-Note that this does NOT in any way cause any of the code of the system to be unloaded.
8.9007-Returns T if system was or is now undefined, NIL if a new preloaded system was redefined."
8.9008- ;; There is no "unload" operation in Common Lisp, and
8.9009- ;; a general such operation cannot be portably written,
8.9010- ;; considering how much CL relies on side-effects to global data structures.
8.9011- (let ((name (coerce-name system)))
8.9012- (remhash name *registered-systems*)
8.9013- (unset-asdf-cache-entry `(find-system ,name))
8.9014- (not (ensure-preloaded-system-registered name))))
8.9015-
8.9016- (defun clear-registered-systems ()
8.9017- "Clear all currently registered defined systems.
8.9018-Preloaded systems (including immutable ones) will be reset, other systems will be de-registered."
8.9019- (map () 'clear-system (registered-systems)))
8.9020-
8.9021-
8.9022- ;;; Searching for system definitions
8.9023-
8.9024- ;; For the sake of keeping things reasonably neat, we adopt a convention that
8.9025- ;; only symbols are to be pushed to this list (rather than e.g. function objects),
8.9026- ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF-
8.9027- (defvar *system-definition-search-functions* '()
8.9028- "A list that controls the ways that ASDF looks for system definitions.
8.9029-It contains symbols to be funcalled in order, with a requested system name as argument,
8.9030-until one returns a non-NIL result (if any), which must then be a fully initialized system object
8.9031-with that name.")
8.9032-
8.9033- ;; Initialize and/or upgrade the *system-definition-search-functions*
8.9034- ;; so it doesn't contain obsolete symbols, and does contain the current ones.
8.9035- (defun cleanup-system-definition-search-functions ()
8.9036- (setf *system-definition-search-functions*
8.9037- (append
8.9038- ;; Remove known-incompatible sysdef functions from old versions of asdf.
8.9039- ;; Order matters, so we can't just use set-difference.
8.9040- (let ((obsolete
8.9041- '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search)))
8.9042- (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*))
8.9043- ;; Tuck our defaults at the end of the list if they were absent.
8.9044- ;; This is imperfect, in case they were removed on purpose,
8.9045- ;; but then it will be the responsibility of whoever removes these symmbols
8.9046- ;; to upgrade asdf before he does such a thing rather than after.
8.9047- (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
8.9048- '(sysdef-central-registry-search
8.9049- sysdef-source-registry-search)))))
8.9050- (cleanup-system-definition-search-functions)
8.9051-
8.9052- ;; This (private) function does the search for a system definition using *s-d-s-f*;
8.9053- ;; it is to be called by locate-system.
8.9054- (defun search-for-system-definition (system)
8.9055- ;; Search for valid definitions of the system available in the current session.
8.9056- ;; Previous definitions as registered in *registered-systems* MUST NOT be considered;
8.9057- ;; they will be reconciled by locate-system then find-system.
8.9058- ;; There are two special treatments: first, specially search for objects being defined
8.9059- ;; in the current session, to avoid definition races between several files;
8.9060- ;; second, specially search for immutable systems, so they cannot be redefined.
8.9061- ;; Finally, use the search functions specified in *system-definition-search-functions*.
8.9062- (let ((name (coerce-name system)))
8.9063- (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
8.9064- (try 'find-system-if-being-defined)
8.9065- (try 'sysdef-immutable-system-search)
8.9066- (map () #'try *system-definition-search-functions*))))
8.9067-
8.9068-
8.9069- ;;; The legacy way of finding a system: the *central-registry*
8.9070-
8.9071- ;; This variable contains a list of directories to be lazily searched for the requested asd
8.9072- ;; by sysdef-central-registry-search.
8.9073- (defvar *central-registry* nil
8.9074- "A list of 'system directory designators' ASDF uses to find systems.
8.9075-
8.9076-A 'system directory designator' is a pathname or an expression
8.9077-which evaluates to a pathname. For example:
8.9078-
8.9079- (setf asdf:*central-registry*
8.9080- (list '*default-pathname-defaults*
8.9081- #p\"/home/me/cl/systems/\"
8.9082- #p\"/usr/share/common-lisp/systems/\"))
8.9083-
8.9084-This variable is for backward compatibility.
8.9085-Going forward, we recommend new users should be using the source-registry.")
8.9086-
8.9087- ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS.
8.9088- ;; Return the truename of that file if it is found and TRUENAME is true.
8.9089- ;; Return NIL if the file is not found.
8.9090- ;; On Windows, follow shortcuts to .asd files.
8.9091- (defun probe-asd (name defaults &key truename)
8.9092- (block nil
8.9093- (when (directory-pathname-p defaults)
8.9094- (if-let (file (probe-file*
8.9095- (ensure-absolute-pathname
8.9096- (parse-unix-namestring name :type "asd")
8.9097- #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil))
8.9098- nil)
8.9099- :truename truename))
8.9100- (return file))
8.9101- #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
8.9102- (os-cond
8.9103- ((os-windows-p)
8.9104- (when (physical-pathname-p defaults)
8.9105- (let ((shortcut
8.9106- (make-pathname
8.9107- :defaults defaults :case :local
8.9108- :name (strcat name ".asd")
8.9109- :type "lnk")))
8.9110- (when (probe-file* shortcut)
8.9111- (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))))
8.9112-
8.9113- ;; Function to push onto *s-d-s-f* to use the *central-registry*
8.9114- (defun sysdef-central-registry-search (system)
8.9115- (let ((name (primary-system-name system))
8.9116- (to-remove nil)
8.9117- (to-replace nil))
8.9118- (block nil
8.9119- (unwind-protect
8.9120- (dolist (dir *central-registry*)
8.9121- (let ((defaults (eval dir))
8.9122- directorized)
8.9123- (when defaults
8.9124- (cond ((directory-pathname-p defaults)
8.9125- (let* ((file (probe-asd name defaults :truename *resolve-symlinks*)))
8.9126- (when file
8.9127- (return file))))
8.9128- (t
8.9129- (restart-case
8.9130- (let* ((*print-circle* nil)
8.9131- (message
8.9132- (format nil
8.9133- (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.~@:>")
8.9134- system dir defaults)))
8.9135- (error message))
8.9136- (remove-entry-from-registry ()
8.9137- :report "Remove entry from *central-registry* and continue"
8.9138- (push dir to-remove))
8.9139- (coerce-entry-to-directory ()
8.9140- :test (lambda (c) (declare (ignore c))
8.9141- (and (not (directory-pathname-p defaults))
8.9142- (directory-pathname-p
8.9143- (setf directorized
8.9144- (ensure-directory-pathname defaults)))))
8.9145- :report (lambda (s)
8.9146- (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
8.9147- directorized dir))
8.9148- (push (cons dir directorized) to-replace))))))))
8.9149- ;; cleanup
8.9150- (dolist (dir to-remove)
8.9151- (setf *central-registry* (remove dir *central-registry*)))
8.9152- (dolist (pair to-replace)
8.9153- (let* ((current (car pair))
8.9154- (new (cdr pair))
8.9155- (position (position current *central-registry*)))
8.9156- (setf *central-registry*
8.9157- (append (subseq *central-registry* 0 position)
8.9158- (list new)
8.9159- (subseq *central-registry* (1+ position)))))))))))
8.9160-
8.9161-;;;; -------------------------------------------------------------------------
8.9162-;;;; Actions
8.9163-
8.9164-(uiop/package:define-package :asdf/action
8.9165- (:nicknames :asdf-action)
8.9166- (:recycle :asdf/action :asdf/plan :asdf)
8.9167- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation)
8.9168- (:import-from :asdf/operation #:check-operation-constructor)
8.9169- (:import-from :asdf/component #:%additional-input-files)
8.9170- (:export
8.9171- #:action #:define-convenience-action-methods
8.9172- #:action-description #:format-action
8.9173- #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
8.9174- #:non-propagating-operation
8.9175- #:component-depends-on
8.9176- #:input-files #:output-files #:output-file #:operation-done-p
8.9177- #:action-operation #:action-component #:make-action
8.9178- #:component-operation-time #:mark-operation-done #:compute-action-stamp
8.9179- #:perform #:perform-with-restarts #:retry #:accept
8.9180- #:action-path #:find-action
8.9181- #:operation-definition-warning #:operation-definition-error ;; condition
8.9182- #:action-valid-p
8.9183- #:circular-dependency #:circular-dependency-actions
8.9184- #:call-while-visiting-action #:while-visiting-action
8.9185- #:additional-input-files))
8.9186-(in-package :asdf/action)
8.9187-
8.9188-(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
8.9189-
8.9190- (deftype action ()
8.9191- "A pair of operation and component uniquely identifies a node in the dependency graph
8.9192-of steps to be performed while building a system."
8.9193- '(cons operation component))
8.9194-
8.9195- (deftype operation-designator ()
8.9196- "An operation designates itself. NIL designates a context-dependent current operation,
8.9197-and a class-name or class designates the canonical instance of the designated class."
8.9198- '(or operation null symbol class)))
8.9199-
8.9200-;;; these are pseudo accessors -- let us abstract away the CONS cell representation of plan
8.9201-;;; actions.
8.9202-(with-upgradability ()
8.9203- (defun make-action (operation component)
8.9204- (cons operation component))
8.9205- (defun action-operation (action)
8.9206- (car action))
8.9207- (defun action-component (action)
8.9208- (cdr action)))
8.9209-
8.9210-;;;; Reified representation for storage or debugging. Note: an action is identified by its class.
8.9211-(with-upgradability ()
8.9212- (defun action-path (action)
8.9213- "A readable data structure that identifies the action."
8.9214- (when action
8.9215- (let ((o (action-operation action))
8.9216- (c (action-component action)))
8.9217- (cons (type-of o) (component-find-path c)))))
8.9218- (defun find-action (path)
8.9219- "Reconstitute an action from its action-path"
8.9220- (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c)))))
8.9221-
8.9222-;;;; Convenience methods
8.9223-(with-upgradability ()
8.9224- ;; A macro that defines convenience methods for a generic function (gf) that
8.9225- ;; dispatches on operation and component. The convenience methods allow users
8.9226- ;; to call the gf with operation and/or component designators, that the
8.9227- ;; methods will resolve into actual operation and component objects, so that
8.9228- ;; the users can interact using readable designators, but developers only have
8.9229- ;; to write methods that handle operation and component objects.
8.9230- ;; FUNCTION is the generic function name
8.9231- ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT.
8.9232- ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found.
8.9233- ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found.
8.9234- (defmacro define-convenience-action-methods
8.9235- (function formals &key if-no-operation if-no-component)
8.9236- (let* ((rest (gensym "REST"))
8.9237- (found (gensym "FOUND"))
8.9238- (keyp (equal (last formals) '(&key)))
8.9239- (formals-no-key (if keyp (butlast formals) formals))
8.9240- (len (length formals-no-key))
8.9241- (operation 'operation)
8.9242- (component 'component)
8.9243- (opix (position operation formals))
8.9244- (coix (position component formals))
8.9245- (prefix (subseq formals 0 opix))
8.9246- (suffix (subseq formals (1+ coix) len))
8.9247- (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
8.9248- (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
8.9249- (flet ((next-method (o c)
8.9250- (if keyp
8.9251- `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
8.9252- `(,function ,@prefix ,o ,c ,@suffix))))
8.9253- `(progn
8.9254- (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args)
8.9255- (declare (notinline ,function))
8.9256- (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on
8.9257- ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component)))
8.9258- (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args)
8.9259- (declare (notinline ,function))
8.9260- (if ,operation
8.9261- ,(next-method
8.9262- `(make-operation ,operation)
8.9263- `(or (find-component () ,component) ,if-no-component))
8.9264- ,if-no-operation))
8.9265- (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
8.9266- (declare (notinline ,function))
8.9267- (if (typep ,component 'component)
8.9268- (error "No defined method for ~S on ~/asdf-action:format-action/"
8.9269- ',function (make-action ,operation ,component))
8.9270- (if-let (,found (find-component () ,component))
8.9271- ,(next-method operation found)
8.9272- ,if-no-component))))))))
8.9273-
8.9274-
8.9275-;;;; Self-description
8.9276-(with-upgradability ()
8.9277- (defgeneric action-description (operation component)
8.9278- (:documentation "returns a phrase that describes performing this operation
8.9279-on this component, e.g. \"loading /a/b/c\".
8.9280-You can put together sentences using this phrase."))
8.9281- (defmethod action-description (operation component)
8.9282- (format nil (compatfmt "~@<~A on ~A~@:>")
8.9283- operation component))
8.9284-
8.9285- (defun format-action (stream action &optional colon-p at-sign-p)
8.9286- "FORMAT helper to display an action's action-description.
8.9287-Use it in FORMAT control strings as ~/asdf-action:format-action/"
8.9288- (assert (null colon-p)) (assert (null at-sign-p))
8.9289- (destructuring-bind (operation . component) action
8.9290- (princ (action-description operation component) stream))))
8.9291-
8.9292-
8.9293-;;;; Detection of circular dependencies
8.9294-(with-upgradability ()
8.9295- (defun action-valid-p (operation component)
8.9296- "Is this action valid to include amongst dependencies?"
8.9297- ;; If either the operation or component was resolved to nil, the action is invalid.
8.9298- ;; :if-feature will invalidate actions on components for which the features don't apply.
8.9299- (and operation component
8.9300- (if-let (it (component-if-feature component)) (featurep it) t)))
8.9301-
8.9302- (define-condition circular-dependency (system-definition-error)
8.9303- ((actions :initarg :actions :reader circular-dependency-actions))
8.9304- (:report (lambda (c s)
8.9305- (format s (compatfmt "~@<Circular dependency of ~s on: ~3i~_~S~@:>")
8.9306- (first (circular-dependency-actions c))
8.9307- (circular-dependency-actions c)))))
8.9308-
8.9309- (defun call-while-visiting-action (operation component fun)
8.9310- "Detect circular dependencies"
8.9311- (with-asdf-session ()
8.9312- (with-accessors ((action-set visiting-action-set)
8.9313- (action-list visiting-action-list)) *asdf-session*
8.9314- (let ((action (cons operation component)))
8.9315- (when (gethash action action-set)
8.9316- (error 'circular-dependency :actions
8.9317- (member action (reverse action-list) :test 'equal)))
8.9318- (setf (gethash action action-set) t)
8.9319- (push action action-list)
8.9320- (unwind-protect
8.9321- (funcall fun)
8.9322- (pop action-list)
8.9323- (setf (gethash action action-set) nil))))))
8.9324-
8.9325- ;; Syntactic sugar for call-while-visiting-action
8.9326- (defmacro while-visiting-action ((o c) &body body)
8.9327- `(call-while-visiting-action ,o ,c #'(lambda () ,@body))))
8.9328-
8.9329-
8.9330-;;;; Dependencies
8.9331-(with-upgradability ()
8.9332- (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
8.9333- (:documentation
8.9334- "Returns a list of dependencies needed by the component to perform
8.9335- the operation. A dependency has one of the following forms:
8.9336-
8.9337- (<operation> <component>*), where <operation> is an operation designator
8.9338- with respect to FIND-OPERATION in the context of the OPERATION argument,
8.9339- and each <component> is a component designator with respect to
8.9340- FIND-COMPONENT in the context of the COMPONENT argument,
8.9341- and means that the component depends on
8.9342- <operation> having been performed on each <component>;
8.9343-
8.9344- [Note: an <operation> is an operation designator -- it can be either an
8.9345- operation name or an operation object. Similarly, a <component> may be
8.9346- a component name or a component object. Also note that, the degenerate
8.9347- case of (<operation>) is a no-op.]
8.9348-
8.9349- Methods specialized on subclasses of existing component types
8.9350- should usually append the results of CALL-NEXT-METHOD to the list."))
8.9351- (define-convenience-action-methods component-depends-on (operation component))
8.9352-
8.9353- (defmethod component-depends-on :around ((o operation) (c component))
8.9354- (do-asdf-cache `(component-depends-on ,o ,c)
8.9355- (call-next-method))))
8.9356-
8.9357-
8.9358-;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
8.9359-;; These together handle actions that propagate along the component hierarchy or operation universe.
8.9360-(with-upgradability ()
8.9361- (defclass downward-operation (operation)
8.9362- ((downward-operation
8.9363- :initform nil :reader downward-operation
8.9364- :type operation-designator :allocation :class))
8.9365- (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy.
8.9366-I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then
8.9367-the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M.
8.9368-The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself.
8.9369-E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the
8.9370-children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP."))
8.9371- (defun downward-operation-depends-on (o c)
8.9372- `((,(or (downward-operation o) o) ,@(component-children c))))
8.9373- (defmethod component-depends-on ((o downward-operation) (c parent-component))
8.9374- `(,@(downward-operation-depends-on o c) ,@(call-next-method)))
8.9375-
8.9376- (defclass upward-operation (operation)
8.9377- ((upward-operation
8.9378- :initform nil :reader upward-operation
8.9379- :type operation-designator :allocation :class))
8.9380- (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy.
8.9381-I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U,
8.9382-then the action (O . C) of O on a component C that has the parent P will depends on (U . P).
8.9383-The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself.
8.9384-E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT
8.9385-must first be prepared for loading or compiling with PREPARE-OP."))
8.9386- ;; For backward-compatibility reasons, a system inherits from module and is a child-component
8.9387- ;; so we must guard against this case. ASDF4: remove that.
8.9388- (defun upward-operation-depends-on (o c)
8.9389- (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))))
8.9390- (defmethod component-depends-on ((o upward-operation) (c child-component))
8.9391- `(,@(upward-operation-depends-on o c) ,@(call-next-method)))
8.9392-
8.9393- (defclass sideway-operation (operation)
8.9394- ((sideway-operation
8.9395- :initform nil :reader sideway-operation
8.9396- :type operation-designator :allocation :class))
8.9397- (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings
8.9398-that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot
8.9399-designates operation S (where NIL designates O itself), then the action (O . C) of O on component C
8.9400-depends on each of (S . D) where D is a declared dependency of C.
8.9401-E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP,
8.9402-each of its declared dependencies must first be loaded as by LOAD-OP."))
8.9403- (defun sideway-operation-depends-on (o c)
8.9404- `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c))))
8.9405- (defmethod component-depends-on ((o sideway-operation) (c component))
8.9406- `(,@(sideway-operation-depends-on o c) ,@(call-next-method)))
8.9407-
8.9408- (defclass selfward-operation (operation)
8.9409- ((selfward-operation
8.9410- ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which
8.9411- :type (or operation-designator list) :reader selfward-operation :allocation :class))
8.9412- (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
8.9413-I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L,
8.9414-then the action (O . C) of O on component C depends on each (S . C) for S in L.
8.9415-E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
8.9416-A operation-designator designates a singleton list of the designated operation;
8.9417-a list of operation-designators designates the list of designated operations;
8.9418-NIL is not a valid operation designator in that context. Note that any dependency
8.9419-ordering between the operations in a list of SELFWARD-OPERATION should be specified separately
8.9420-in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly."))
8.9421- (defun selfward-operation-depends-on (o c)
8.9422- (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)))
8.9423- (defmethod component-depends-on ((o selfward-operation) (c component))
8.9424- `(,@(selfward-operation-depends-on o c) ,@(call-next-method)))
8.9425-
8.9426- (defclass non-propagating-operation (operation)
8.9427- ()
8.9428- (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
8.9429-no dependencies whatsoever. It is supplied in order that the programmer be able
8.9430-to specify that s/he is intentionally specifying an operation which invokes no
8.9431-dependencies.")))
8.9432-
8.9433-
8.9434-;;;---------------------------------------------------------------------------
8.9435-;;; Help programmers catch obsolete OPERATION subclasses
8.9436-;;;---------------------------------------------------------------------------
8.9437-(with-upgradability ()
8.9438- (define-condition operation-definition-warning (simple-warning)
8.9439- ()
8.9440- (:documentation "Warning condition related to definition of obsolete OPERATION objects."))
8.9441-
8.9442- (define-condition operation-definition-error (simple-error)
8.9443- ()
8.9444- (:documentation "Error condition related to definition of incorrect OPERATION objects."))
8.9445-
8.9446- (defmethod initialize-instance :before ((o operation) &key)
8.9447- (check-operation-constructor)
8.9448- (unless (typep o '(or downward-operation upward-operation sideway-operation
8.9449- selfward-operation non-propagating-operation))
8.9450- (warn 'operation-definition-warning
8.9451- :format-control
8.9452- "No dependency propagating scheme specified for operation class ~S.
8.9453-The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins."
8.9454- :format-arguments (list (type-of o)))))
8.9455-
8.9456- (defmethod initialize-instance :before ((o non-propagating-operation) &key)
8.9457- (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation))
8.9458- (error 'operation-definition-error
8.9459- :format-control
8.9460- "Inconsistent class: ~S
8.9461- NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses."
8.9462- :format-arguments
8.9463- (list (type-of o)))))
8.9464-
8.9465- (defun backward-compatible-depends-on (o c)
8.9466- "DEPRECATED: all subclasses of OPERATION used in ASDF should inherit from one of
8.9467- DOWNWARD-OPERATION UPWARD-OPERATION SIDEWAY-OPERATION SELFWARD-OPERATION NON-PROPAGATING-OPERATION.
8.9468- The function BACKWARD-COMPATIBLE-DEPENDS-ON temporarily provides ASDF2 behaviour for those that
8.9469- don't. In the future this functionality will be removed, and the default will be no propagation."
8.9470- (uiop/version::notify-deprecated-function
8.9471- (version-deprecation *asdf-version* :style-warning "3.2")
8.9472- `(backward-compatible-depends-on :for-operation ,o))
8.9473- `(,@(sideway-operation-depends-on o c)
8.9474- ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))
8.9475-
8.9476- (defmethod component-depends-on ((o operation) (c component))
8.9477- `(;; Normal behavior, to allow user-specified in-order-to dependencies
8.9478- ,@(cdr (assoc (type-of o) (component-in-order-to c)))
8.9479- ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation
8.9480- ;; or non-propagation through an appropriate mixin will be downward and sideway.
8.9481- ,@(unless (typep o '(or downward-operation upward-operation sideway-operation
8.9482- selfward-operation non-propagating-operation))
8.9483- (backward-compatible-depends-on o c))))
8.9484-
8.9485- (defmethod downward-operation ((o operation)) nil)
8.9486- (defmethod sideway-operation ((o operation)) nil))
8.9487-
8.9488-
8.9489-;;;---------------------------------------------------------------------------
8.9490-;;; End of OPERATION class checking
8.9491-;;;---------------------------------------------------------------------------
8.9492-
8.9493-
8.9494-;;;; Inputs, Outputs, and invisible dependencies
8.9495-(with-upgradability ()
8.9496- (defgeneric output-files (operation component)
8.9497- (:documentation "Methods for this function return two values: a list of output files
8.9498-corresponding to this action, and a boolean indicating if they have already been subjected
8.9499-to relevant output translations and should not be further translated.
8.9500-
8.9501-Methods on PERFORM *must* call this function to determine where their outputs are to be located.
8.9502-They may rely on the order of the files to discriminate between outputs.
8.9503-"))
8.9504- (defgeneric input-files (operation component)
8.9505- (:documentation "A list of input files corresponding to this action.
8.9506-
8.9507-Methods on PERFORM *must* call this function to determine where their inputs are located.
8.9508-They may rely on the order of the files to discriminate between inputs.
8.9509-"))
8.9510- (defgeneric operation-done-p (operation component)
8.9511- (:documentation "Returns a boolean which is NIL if the action must be performed (again)."))
8.9512- (define-convenience-action-methods output-files (operation component))
8.9513- (define-convenience-action-methods input-files (operation component))
8.9514- (define-convenience-action-methods operation-done-p (operation component))
8.9515-
8.9516- (defmethod operation-done-p ((o operation) (c component))
8.9517- t)
8.9518-
8.9519- ;; Translate output files, unless asked not to. Memoize the result.
8.9520- (defmethod output-files :around ((operation t) (component t))
8.9521- (do-asdf-cache `(output-files ,operation ,component)
8.9522- (values
8.9523- (multiple-value-bind (pathnames fixedp) (call-next-method)
8.9524- ;; 1- Make sure we have absolute pathnames
8.9525- (let* ((directory (pathname-directory-pathname
8.9526- (component-pathname (find-component () component))))
8.9527- (absolute-pathnames
8.9528- (loop
8.9529- :for pathname :in pathnames
8.9530- :collect (ensure-absolute-pathname pathname directory))))
8.9531- ;; 2- Translate those pathnames as required
8.9532- (if fixedp
8.9533- absolute-pathnames
8.9534- (mapcar *output-translation-function* absolute-pathnames))))
8.9535- t)))
8.9536- (defmethod output-files ((o operation) (c component))
8.9537- nil)
8.9538- (defun output-file (operation component)
8.9539- "The unique output file of performing OPERATION on COMPONENT"
8.9540- (let ((files (output-files operation component)))
8.9541- (assert (length=n-p files 1))
8.9542- (first files)))
8.9543-
8.9544- (defgeneric additional-input-files (operation component)
8.9545- (:documentation "Additional input files for the operation on this
8.9546- component. These are files that are inferred, rather than
8.9547- explicitly specified, and these are typically NOT files that
8.9548- undergo operations directly. Instead, they are files that it is
8.9549- important for ASDF to know about in order to compute operation times,etc."))
8.9550- (define-convenience-action-methods additional-input-files (operation component))
8.9551- (defmethod additional-input-files ((op operation) (comp component))
8.9552- (cdr (assoc op (%additional-input-files comp))))
8.9553-
8.9554- ;; Memoize input files.
8.9555- (defmethod input-files :around (operation component)
8.9556- (do-asdf-cache `(input-files ,operation ,component)
8.9557- ;; get the additional input files, if any
8.9558- (append (call-next-method)
8.9559- ;; must come after the first, for other code that
8.9560- ;; assumes the first will be the "key" file
8.9561- (additional-input-files operation component))))
8.9562-
8.9563- ;; By default an action has no input-files.
8.9564- (defmethod input-files ((o operation) (c component))
8.9565- nil)
8.9566-
8.9567- ;; An action with a selfward-operation by default gets its input-files from the output-files of
8.9568- ;; the actions using selfward-operations it depends on (and the same component),
8.9569- ;; or if there are none, on the component-pathname of the component if it's a file
8.9570- ;; -- and then on the results of the next-method.
8.9571- (defmethod input-files ((o selfward-operation) (c component))
8.9572- `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
8.9573- :append (or (output-files dep-o c) (input-files dep-o c)))
8.9574- (if-let ((pathname (component-pathname c)))
8.9575- (and (file-pathname-p pathname) (list pathname))))
8.9576- ,@(call-next-method))))
8.9577-
8.9578-
8.9579-;;;; Done performing
8.9580-(with-upgradability ()
8.9581- ;; ASDF4: hide it behind plan-action-stamp
8.9582- (defgeneric component-operation-time (operation component)
8.9583- (:documentation "Return the timestamp for when an action was last performed"))
8.9584- (defgeneric (setf component-operation-time) (time operation component)
8.9585- (:documentation "Update the timestamp for when an action was last performed"))
8.9586- (define-convenience-action-methods component-operation-time (operation component))
8.9587-
8.9588- ;; ASDF4: hide it behind (setf plan-action-stamp)
8.9589- (defgeneric mark-operation-done (operation component)
8.9590- (:documentation "Mark a action as having been just done.
8.9591-
8.9592-Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP
8.9593-using the JUST-DONE flag."))
8.9594- (defgeneric compute-action-stamp (plan- operation component &key just-done)
8.9595- ;; NB: using plan- rather than plan above allows clisp to upgrade from 2.26(!)
8.9596- (:documentation "Has this action been successfully done already,
8.9597-and at what known timestamp has it been done at or will it be done at?
8.9598-* PLAN is a plan object modelling future effects of actions,
8.9599- or NIL to denote what actually happened.
8.9600-* OPERATION and COMPONENT denote the action.
8.9601-Takes keyword JUST-DONE:
8.9602-* JUST-DONE is a boolean that is true if the action was just successfully performed,
8.9603- at which point we want compute the actual stamp and warn if files are missing;
8.9604- otherwise we are making plans, anticipating the effects of the action.
8.9605-Returns two values:
8.9606-* a STAMP saying when it was done or will be done,
8.9607- or T if the action involves files that need to be recomputed.
8.9608-* a boolean DONE-P that indicates whether the action has actually been done,
8.9609- and both its output-files and its in-image side-effects are up to date."))
8.9610-
8.9611- (defmethod component-operation-time ((o operation) (c component))
8.9612- (gethash o (component-operation-times c)))
8.9613-
8.9614- (defmethod (setf component-operation-time) (stamp (o operation) (c component))
8.9615- (assert stamp () "invalid null stamp for ~A" (action-description o c))
8.9616- (setf (gethash o (component-operation-times c)) stamp))
8.9617-
8.9618- (defmethod mark-operation-done ((o operation) (c component))
8.9619- (let ((stamp (compute-action-stamp nil o c :just-done t)))
8.9620- (assert stamp () "Failed to compute a stamp for completed action ~A" (action-description o c))1
8.9621- (setf (component-operation-time o c) stamp))))
8.9622-
8.9623-
8.9624-;;;; Perform
8.9625-(with-upgradability ()
8.9626- (defgeneric perform (operation component)
8.9627- (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
8.9628- (define-convenience-action-methods perform (operation component))
8.9629-
8.9630- (defmethod perform :around ((o operation) (c component))
8.9631- (while-visiting-action (o c) (call-next-method)))
8.9632- (defmethod perform :before ((o operation) (c component))
8.9633- (ensure-all-directories-exist (output-files o c)))
8.9634- (defmethod perform :after ((o operation) (c component))
8.9635- (mark-operation-done o c))
8.9636- (defmethod perform ((o operation) (c parent-component))
8.9637- nil)
8.9638- (defmethod perform ((o operation) (c source-file))
8.9639- ;; For backward compatibility, don't error on operations that don't specify propagation.
8.9640- (when (typep o '(or downward-operation upward-operation sideway-operation
8.9641- selfward-operation non-propagating-operation))
8.9642- (sysdef-error
8.9643- (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>")
8.9644- 'perform (make-action o c))))
8.9645-
8.9646- ;; The restarts of the perform-with-restarts variant matter in an interactive context.
8.9647- ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build
8.9648- ;; may call perform directly rather than call p-w-r.
8.9649- (defgeneric perform-with-restarts (operation component)
8.9650- (:documentation "PERFORM an action in a context where suitable restarts are in place."))
8.9651- (defmethod perform-with-restarts (operation component)
8.9652- (perform operation component))
8.9653- (defmethod perform-with-restarts :around (operation component)
8.9654- (loop
8.9655- (restart-case
8.9656- (return (call-next-method))
8.9657- (retry ()
8.9658- :report
8.9659- (lambda (s)
8.9660- (format s (compatfmt "~@<Retry ~A.~@:>")
8.9661- (action-description operation component))))
8.9662- (accept ()
8.9663- :report
8.9664- (lambda (s)
8.9665- (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
8.9666- (action-description operation component)))
8.9667- (mark-operation-done operation component)
8.9668- (return))))))
8.9669-;;;; -------------------------------------------------------------------------
8.9670-;;;; Actions to build Common Lisp software
8.9671-
8.9672-(uiop/package:define-package :asdf/lisp-action
8.9673- (:recycle :asdf/lisp-action :asdf)
8.9674- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
8.9675- :asdf/component :asdf/system :asdf/operation :asdf/action)
8.9676- (:export
8.9677- #:try-recompiling
8.9678- #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
8.9679- #:basic-load-op #:basic-compile-op
8.9680- #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
8.9681- #:call-with-around-compile-hook
8.9682- #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source
8.9683- #:lisp-compilation-output-files))
8.9684-(in-package :asdf/lisp-action)
8.9685-
8.9686-
8.9687-;;;; Component classes
8.9688-(with-upgradability ()
8.9689- (defclass cl-source-file (source-file)
8.9690- ((type :initform "lisp"))
8.9691- (:documentation "Component class for a Common Lisp source file (using type \"lisp\")"))
8.9692- (defclass cl-source-file.cl (cl-source-file)
8.9693- ((type :initform "cl"))
8.9694- (:documentation "Component class for a Common Lisp source file using type \"cl\""))
8.9695- (defclass cl-source-file.lsp (cl-source-file)
8.9696- ((type :initform "lsp"))
8.9697- (:documentation "Component class for a Common Lisp source file using type \"lsp\"")))
8.9698-
8.9699-
8.9700-;;;; Operation classes
8.9701-(with-upgradability ()
8.9702- (defclass basic-load-op (operation) ()
8.9703- (:documentation "Base class for operations that apply the load-time effects of a file"))
8.9704- (defclass basic-compile-op (operation) ()
8.9705- (:documentation "Base class for operations that apply the compile-time effects of a file")))
8.9706-
8.9707-
8.9708-;;; Our default operations: loading into the current lisp image
8.9709-(with-upgradability ()
8.9710- (defclass prepare-op (upward-operation sideway-operation)
8.9711- ((sideway-operation :initform 'load-op :allocation :class))
8.9712- (:documentation "Load the dependencies for the COMPILE-OP or LOAD-OP of a given COMPONENT."))
8.9713- (defclass load-op (basic-load-op downward-operation selfward-operation)
8.9714- ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
8.9715- ;; so we need to directly depend on prepare-op for its side-effects in the current image.
8.9716- ((selfward-operation :initform '(prepare-op compile-op) :allocation :class))
8.9717- (:documentation "Operation for loading the compiled FASL for a Lisp file"))
8.9718- (defclass compile-op (basic-compile-op downward-operation selfward-operation)
8.9719- ((selfward-operation :initform 'prepare-op :allocation :class))
8.9720- (:documentation "Operation for compiling a Lisp file to a FASL"))
8.9721-
8.9722-
8.9723- (defclass prepare-source-op (upward-operation sideway-operation)
8.9724- ((sideway-operation :initform 'load-source-op :allocation :class))
8.9725- (:documentation "Operation for loading the dependencies of a Lisp file as source."))
8.9726- (defclass load-source-op (basic-load-op downward-operation selfward-operation)
8.9727- ((selfward-operation :initform 'prepare-source-op :allocation :class))
8.9728- (:documentation "Operation for loading a Lisp file as source."))
8.9729-
8.9730- (defclass test-op (selfward-operation)
8.9731- ((selfward-operation :initform 'load-op :allocation :class))
8.9732- (:documentation "Operation for running the tests for system.
8.9733-If the tests fail, an error will be signaled.")))
8.9734-
8.9735-
8.9736-;;;; Methods for prepare-op, compile-op and load-op
8.9737-
8.9738-;;; prepare-op
8.9739-(with-upgradability ()
8.9740- (defmethod action-description ((o prepare-op) (c component))
8.9741- (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
8.9742- (defmethod perform ((o prepare-op) (c component))
8.9743- nil)
8.9744- (defmethod input-files ((o prepare-op) (s system))
8.9745- (if-let (it (system-source-file s)) (list it))))
8.9746-
8.9747-;;; compile-op
8.9748-(with-upgradability ()
8.9749- (defmethod action-description ((o compile-op) (c component))
8.9750- (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
8.9751- (defmethod action-description ((o compile-op) (c parent-component))
8.9752- (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
8.9753- (defgeneric call-with-around-compile-hook (component thunk)
8.9754- (:documentation "A method to be called around the PERFORM'ing of actions that apply the
8.9755-compile-time side-effects of file (i.e., COMPILE-OP or LOAD-SOURCE-OP). This method can be used
8.9756-to setup readtables and other variables that control reading, macroexpanding, and compiling, etc.
8.9757-Note that it will NOT be called around the performing of LOAD-OP."))
8.9758- (defmethod call-with-around-compile-hook ((c component) function)
8.9759- (call-around-hook (around-compile-hook c) function))
8.9760- (defun perform-lisp-compilation (o c)
8.9761- "Perform the compilation of the Lisp file associated to the specified action (O . C)."
8.9762- (let (;; Before 2.26.53, that was unfortunately component-pathname. Now,
8.9763- ;; we consult input-files, the first of which should be the one to compile-file
8.9764- (input-file (first (input-files o c)))
8.9765- ;; On some implementations, there are more than one output-file,
8.9766- ;; but the first one should always be the primary fasl that gets loaded.
8.9767- (outputs (output-files o c)))
8.9768- (multiple-value-bind (output warnings-p failure-p)
8.9769- (destructuring-bind
8.9770- (output-file
8.9771- &optional
8.9772- #+(or clasp ecl mkcl) object-file
8.9773- #+clisp lib-file
8.9774- warnings-file &rest rest) outputs
8.9775- ;; Allow for extra outputs that are not of type warnings-file
8.9776- ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional.
8.9777- (declare (ignore rest))
8.9778- (when warnings-file
8.9779- (unless (equal (pathname-type warnings-file) (warnings-file-type))
8.9780- (setf warnings-file nil)))
8.9781- (let ((*package* (find-package* '#:common-lisp-user)))
8.9782- (call-with-around-compile-hook
8.9783- c #'(lambda (&rest flags)
8.9784- (apply 'compile-file* input-file
8.9785- :output-file output-file
8.9786- :external-format (component-external-format c)
8.9787- :warnings-file warnings-file
8.9788- (append
8.9789- #+clisp (list :lib-file lib-file)
8.9790- #+(or clasp ecl mkcl) (list :object-file object-file)
8.9791- flags))))))
8.9792- (check-lisp-compile-results output warnings-p failure-p
8.9793- "~/asdf-action::format-action/" (list (cons o c))))))
8.9794- (defun report-file-p (f)
8.9795- "Is F a build report file containing, e.g., warnings to check?"
8.9796- (equalp (pathname-type f) "build-report"))
8.9797- (defun perform-lisp-warnings-check (o c)
8.9798- "Check the warnings associated with the dependencies of an action."
8.9799- (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c)))
8.9800- (actual-warnings-files (loop :for w :in expected-warnings-files
8.9801- :when (get-file-stamp w)
8.9802- :collect w
8.9803- :else :do (warn "Missing warnings file ~S while ~A"
8.9804- w (action-description o c)))))
8.9805- (check-deferred-warnings actual-warnings-files)
8.9806- (let* ((output (output-files o c))
8.9807- (report (find-if #'report-file-p output)))
8.9808- (when report
8.9809- (with-open-file (s report :direction :output :if-exists :supersede)
8.9810- (format s ":success~%"))))))
8.9811- (defmethod perform ((o compile-op) (c cl-source-file))
8.9812- (perform-lisp-compilation o c))
8.9813- (defun lisp-compilation-output-files (o c)
8.9814- "Compute the output-files for compiling the Lisp file for the specified action (O . C),
8.9815-an OPERATION and a COMPONENT."
8.9816- (let* ((i (first (input-files o c)))
8.9817- (f (compile-file-pathname
8.9818- i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl
8.9819- #+mkcl :fasl-p #+mkcl t)))
8.9820- `(,f ;; the fasl is the primary output, in first position
8.9821- #+clasp
8.9822- ,@(unless nil ;; was (use-ecl-byte-compiler-p)
8.9823- `(,(compile-file-pathname i :output-type :object)))
8.9824- #+clisp
8.9825- ,@`(,(make-pathname :type "lib" :defaults f))
8.9826- #+ecl
8.9827- ,@(unless (use-ecl-byte-compiler-p)
8.9828- `(,(compile-file-pathname i :type :object)))
8.9829- #+mkcl
8.9830- ,(compile-file-pathname i :fasl-p nil) ;; object file
8.9831- ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c))))
8.9832- `(,(make-pathname :type *warnings-file-type* :defaults f))))))
8.9833- (defmethod output-files ((o compile-op) (c cl-source-file))
8.9834- (lisp-compilation-output-files o c))
8.9835- (defmethod perform ((o compile-op) (c static-file))
8.9836- nil)
8.9837-
8.9838- ;; Performing compile-op on a system will check the deferred warnings for the system
8.9839- (defmethod perform ((o compile-op) (c system))
8.9840- (when (and *warnings-file-type* (not (builtin-system-p c)))
8.9841- (perform-lisp-warnings-check o c)))
8.9842- (defmethod input-files ((o compile-op) (c system))
8.9843- (when (and *warnings-file-type* (not (builtin-system-p c)))
8.9844- ;; The most correct way to do it would be to use:
8.9845- ;; (collect-dependencies o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file)
8.9846- ;; but it's expensive and we don't care too much about file order or ASDF extensions.
8.9847- (loop :for sub :in (sub-components c :type 'cl-source-file)
8.9848- :nconc (remove-if-not 'warnings-file-p (output-files o sub)))))
8.9849- (defmethod output-files ((o compile-op) (c system))
8.9850- (when (and *warnings-file-type* (not (builtin-system-p c)))
8.9851- (if-let ((pathname (component-pathname c)))
8.9852- (list (subpathname pathname (coerce-filename c) :type "build-report"))))))
8.9853-
8.9854-;;; load-op
8.9855-(with-upgradability ()
8.9856- (defmethod action-description ((o load-op) (c cl-source-file))
8.9857- (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
8.9858- (defmethod action-description ((o load-op) (c parent-component))
8.9859- (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
8.9860- (defmethod action-description ((o load-op) (c component))
8.9861- (format nil (compatfmt "~@<loading ~3i~_~A~@:>") c))
8.9862- (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
8.9863- (loop
8.9864- (restart-case
8.9865- (return (call-next-method))
8.9866- (try-recompiling ()
8.9867- :report (lambda (s)
8.9868- (format s "Recompile ~a and try loading it again"
8.9869- (component-name c)))
8.9870- (perform (find-operation o 'compile-op) c)))))
8.9871- (defun perform-lisp-load-fasl (o c)
8.9872- "Perform the loading of a FASL associated to specified action (O . C),
8.9873-an OPERATION and a COMPONENT."
8.9874- (if-let (fasl (first (input-files o c)))
8.9875- (let ((*package* (find-package '#:common-lisp-user)))
8.9876- (load* fasl))))
8.9877- (defmethod perform ((o load-op) (c cl-source-file))
8.9878- (perform-lisp-load-fasl o c))
8.9879- (defmethod perform ((o load-op) (c static-file))
8.9880- nil))
8.9881-
8.9882-
8.9883-;;;; prepare-source-op, load-source-op
8.9884-
8.9885-;;; prepare-source-op
8.9886-(with-upgradability ()
8.9887- (defmethod action-description ((o prepare-source-op) (c component))
8.9888- (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
8.9889- (defmethod input-files ((o prepare-source-op) (s system))
8.9890- (if-let (it (system-source-file s)) (list it)))
8.9891- (defmethod perform ((o prepare-source-op) (c component))
8.9892- nil))
8.9893-
8.9894-;;; load-source-op
8.9895-(with-upgradability ()
8.9896- (defmethod action-description ((o load-source-op) (c component))
8.9897- (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
8.9898- (defmethod action-description ((o load-source-op) (c parent-component))
8.9899- (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
8.9900- (defun perform-lisp-load-source (o c)
8.9901- "Perform the loading of a Lisp file as associated to specified action (O . C)"
8.9902- (call-with-around-compile-hook
8.9903- c #'(lambda ()
8.9904- (load* (first (input-files o c))
8.9905- :external-format (component-external-format c)))))
8.9906-
8.9907- (defmethod perform ((o load-source-op) (c cl-source-file))
8.9908- (perform-lisp-load-source o c))
8.9909- (defmethod perform ((o load-source-op) (c static-file))
8.9910- nil))
8.9911-
8.9912-
8.9913-;;;; test-op
8.9914-(with-upgradability ()
8.9915- (defmethod perform ((o test-op) (c component))
8.9916- nil)
8.9917- (defmethod operation-done-p ((o test-op) (c system))
8.9918- "Testing a system is _never_ done."
8.9919- nil))
8.9920-;;;; -------------------------------------------------------------------------
8.9921-;;;; Finding components
8.9922-
8.9923-(uiop/package:define-package :asdf/find-component
8.9924- (:recycle :asdf/find-component :asdf/find-system :asdf)
8.9925- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
8.9926- :asdf/component :asdf/system :asdf/system-registry)
8.9927- (:export
8.9928- #:find-component
8.9929- #:resolve-dependency-name #:resolve-dependency-spec
8.9930- #:resolve-dependency-combination
8.9931- ;; Conditions
8.9932- #:missing-component #:missing-requires #:missing-parent #:missing-component-of-version #:retry
8.9933- #:missing-dependency #:missing-dependency-of-version
8.9934- #:missing-requires #:missing-parent
8.9935- #:missing-required-by #:missing-version))
8.9936-(in-package :asdf/find-component)
8.9937-
8.9938-;;;; Missing component conditions
8.9939-
8.9940-(with-upgradability ()
8.9941- (define-condition missing-component (system-definition-error)
8.9942- ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
8.9943- (parent :initform nil :reader missing-parent :initarg :parent)))
8.9944-
8.9945- (define-condition missing-component-of-version (missing-component)
8.9946- ((version :initform nil :reader missing-version :initarg :version)))
8.9947-
8.9948- (define-condition missing-dependency (missing-component)
8.9949- ((required-by :initarg :required-by :reader missing-required-by)))
8.9950-
8.9951- (defmethod print-object ((c missing-dependency) s)
8.9952- (format s (compatfmt "~@<~A, required by ~A~@:>")
8.9953- (call-next-method c nil) (missing-required-by c)))
8.9954-
8.9955- (define-condition missing-dependency-of-version (missing-dependency
8.9956- missing-component-of-version)
8.9957- ())
8.9958-
8.9959- (defmethod print-object ((c missing-component) s)
8.9960- (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
8.9961- (missing-requires c)
8.9962- (when (missing-parent c)
8.9963- (coerce-name (missing-parent c)))))
8.9964-
8.9965- (defmethod print-object ((c missing-component-of-version) s)
8.9966- (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
8.9967- (missing-requires c)
8.9968- (missing-version c)
8.9969- (when (missing-parent c)
8.9970- (coerce-name (missing-parent c))))))
8.9971-
8.9972-
8.9973-;;;; Finding components
8.9974-
8.9975-(with-upgradability ()
8.9976- (defgeneric resolve-dependency-combination (component combinator arguments)
8.9977- (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS)
8.9978-in the context of COMPONENT"))
8.9979-
8.9980- ;; Methods for find-component
8.9981-
8.9982- ;; If the base component is a string, resolve it as a system, then if not nil follow the path.
8.9983- (defmethod find-component ((base string) path &key registered)
8.9984- (if-let ((s (if registered
8.9985- (registered-system base)
8.9986- (find-system base nil))))
8.9987- (find-component s path :registered registered)))
8.9988-
8.9989- ;; If the base component is a symbol, coerce it to a name if not nil, and resolve that.
8.9990- ;; If nil, use the path as base if not nil, or else return nil.
8.9991- (defmethod find-component ((base symbol) path &key registered)
8.9992- (cond
8.9993- (base (find-component (coerce-name base) path :registered registered))
8.9994- (path (find-component path nil :registered registered))
8.9995- (t nil)))
8.9996-
8.9997- ;; If the base component is a cons cell, resolve its car, and add its cdr to the path.
8.9998- (defmethod find-component ((base cons) path &key registered)
8.9999- (find-component (car base) (cons (cdr base) path) :registered registered))
8.10000-
8.10001- ;; If the base component is a parent-component and the path a string, find the named child.
8.10002- (defmethod find-component ((parent parent-component) (name string) &key registered)
8.10003- (declare (ignorable registered))
8.10004- (compute-children-by-name parent :only-if-needed-p t)
8.10005- (values (gethash name (component-children-by-name parent))))
8.10006-
8.10007- ;; If the path is a symbol, coerce it to a name if non-nil, or else just return the base.
8.10008- (defmethod find-component (base (name symbol) &key registered)
8.10009- (if name
8.10010- (find-component base (coerce-name name) :registered registered)
8.10011- base))
8.10012-
8.10013- ;; If the path is a cons, first resolve its car as path, then its cdr.
8.10014- (defmethod find-component ((c component) (name cons) &key registered)
8.10015- (find-component (find-component c (car name) :registered registered)
8.10016- (cdr name) :registered registered))
8.10017-
8.10018- ;; If the path is a component, return it, disregarding the base.
8.10019- (defmethod find-component ((base t) (actual component) &key registered)
8.10020- (declare (ignorable registered))
8.10021- actual)
8.10022-
8.10023- ;; Resolve dependency NAME in the context of a COMPONENT, with given optional VERSION constraint.
8.10024- ;; This (private) function is used below by RESOLVE-DEPENDENCY-SPEC and by the :VERSION spec.
8.10025- (defun resolve-dependency-name (component name &optional version)
8.10026- (loop
8.10027- (restart-case
8.10028- (return
8.10029- (let ((comp (find-component (component-parent component) name)))
8.10030- (unless comp
8.10031- (error 'missing-dependency
8.10032- :required-by component
8.10033- :requires name))
8.10034- (when version
8.10035- (unless (version-satisfies comp version)
8.10036- (error 'missing-dependency-of-version
8.10037- :required-by component
8.10038- :version version
8.10039- :requires name)))
8.10040- comp))
8.10041- (retry ()
8.10042- :report (lambda (s)
8.10043- (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
8.10044- :test
8.10045- (lambda (c)
8.10046- (or (null c)
8.10047- (and (typep c 'missing-dependency)
8.10048- (eq (missing-required-by c) component)
8.10049- (equal (missing-requires c) name))))
8.10050- (unless (component-parent component)
8.10051- (let ((name (coerce-name name)))
8.10052- (unset-asdf-cache-entry `(find-system ,name))))))))
8.10053-
8.10054- ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT.
8.10055- ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON
8.10056- ;; and by PARSE-DEFSYSTEM to process DEFSYSTEM-DEPENDS-ON.
8.10057- (defun resolve-dependency-spec (component dep-spec)
8.10058- (let ((component (find-component () component)))
8.10059- (if (atom dep-spec)
8.10060- (resolve-dependency-name component dep-spec)
8.10061- (resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))))
8.10062-
8.10063- ;; Methods for RESOLVE-DEPENDENCY-COMBINATION to parse lists as dependency specifications.
8.10064- (defmethod resolve-dependency-combination (component combinator arguments)
8.10065- (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S~@:>")
8.10066- 'resolve-dependency-combination (cons combinator arguments) component))
8.10067-
8.10068- (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
8.10069- (when (featurep (first arguments))
8.10070- (resolve-dependency-spec component (second arguments))))
8.10071-
8.10072- (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
8.10073- (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788
8.10074-
8.10075-;;;; -------------------------------------------------------------------------
8.10076-;;;; Forcing
8.10077-
8.10078-(uiop/package:define-package :asdf/forcing
8.10079- (:recycle :asdf/forcing :asdf/plan :asdf)
8.10080- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
8.10081- :asdf/component :asdf/operation :asdf/system :asdf/system-registry)
8.10082- (:export
8.10083- #:forcing #:make-forcing #:forced #:forced-not #:performable-p
8.10084- #:normalize-forced-systems #:normalize-forced-not-systems
8.10085- #:action-forced-p #:action-forced-not-p))
8.10086-(in-package :asdf/forcing)
8.10087-
8.10088-;;;; Forcing
8.10089-(with-upgradability ()
8.10090- (defclass forcing ()
8.10091- (;; Can plans using this forcing be PERFORMed? A plan that has different force and force-not
8.10092- ;; settings than the session can only be used for read-only queries that do not cause the
8.10093- ;; status of any action to be raised.
8.10094- (performable-p :initform nil :initarg :performable-p :reader performable-p)
8.10095- ;; Parameters
8.10096- (parameters :initform nil :initarg :parameters :reader parameters)
8.10097- ;; Table of systems specified via :force arguments
8.10098- (forced :initarg :forced :reader forced)
8.10099- ;; Table of systems specified via :force-not argument (and/or immutable)
8.10100- (forced-not :initarg :forced-not :reader forced-not)))
8.10101-
8.10102- (defgeneric action-forced-p (forcing operation component)
8.10103- (:documentation "Is this action forced to happen in this plan?"))
8.10104- (defgeneric action-forced-not-p (forcing operation component)
8.10105- (:documentation "Is this action forced to not happen in this plan?
8.10106-Takes precedence over action-forced-p."))
8.10107-
8.10108- (defun normalize-forced-systems (force system)
8.10109- "Given a SYSTEM on which operate is called and the specified FORCE argument,
8.10110-extract a hash-set of systems that are forced, or a predicate on system names,
8.10111-or NIL if none are forced, or :ALL if all are."
8.10112- (etypecase force
8.10113- ((or (member nil :all) hash-table function) force)
8.10114- (cons (list-to-hash-set (mapcar #'coerce-name force)))
8.10115- ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
8.10116-
8.10117- (defun normalize-forced-not-systems (force-not system)
8.10118- "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument,
8.10119-and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not,
8.10120-or predicate on system names, or NIL if none are forced, or :ALL if all are."
8.10121- (let ((requested
8.10122- (etypecase force-not
8.10123- ((or (member nil :all) hash-table function) force-not)
8.10124- (cons (list-to-hash-set (mapcar #'coerce-name force-not)))
8.10125- ((eql t) (if system (let ((name (coerce-name system)))
8.10126- #'(lambda (x) (not (equal x name))))
8.10127- :all)))))
8.10128- (if (and *immutable-systems* requested)
8.10129- #'(lambda (x) (or (call-function requested x)
8.10130- (call-function *immutable-systems* x)))
8.10131- (or *immutable-systems* requested))))
8.10132-
8.10133- ;; TODO: shouldn't we be looking up the primary system name, rather than the system name?
8.10134- (defun action-override-p (forcing operation component override-accessor)
8.10135- "Given a plan, an action, and a function that given the plan accesses a set of overrides,
8.10136-i.e. force or force-not, see if the override applies to the current action."
8.10137- (declare (ignore operation))
8.10138- (call-function (funcall override-accessor forcing)
8.10139- (coerce-name (component-system (find-component () component)))))
8.10140-
8.10141- (defmethod action-forced-p (forcing operation component)
8.10142- (and
8.10143- ;; Did the user ask us to re-perform the action?
8.10144- (action-override-p forcing operation component 'forced)
8.10145- ;; You really can't force a builtin system and :all doesn't apply to it.
8.10146- (not (builtin-system-p (component-system component)))))
8.10147-
8.10148- (defmethod action-forced-not-p (forcing operation component)
8.10149- ;; Did the user ask us to not re-perform the action?
8.10150- ;; NB: force-not takes precedence over force, as it should
8.10151- (action-override-p forcing operation component 'forced-not))
8.10152-
8.10153- ;; Null forcing means no forcing either way
8.10154- (defmethod action-forced-p ((forcing null) (operation operation) (component component))
8.10155- nil)
8.10156- (defmethod action-forced-not-p ((forcing null) (operation operation) (component component))
8.10157- nil)
8.10158-
8.10159- (defun or-function (fun1 fun2)
8.10160- (cond
8.10161- ((or (null fun2) (eq fun1 :all)) fun1)
8.10162- ((or (null fun1) (eq fun2 :all)) fun2)
8.10163- (t #'(lambda (x) (or (call-function fun1 x) (call-function fun2 x))))))
8.10164-
8.10165- (defun make-forcing (&key performable-p system
8.10166- (force nil force-p) (force-not nil force-not-p) &allow-other-keys)
8.10167- (let* ((session-forcing (when *asdf-session* (forcing *asdf-session*)))
8.10168- (system (and system (coerce-name system)))
8.10169- (forced (normalize-forced-systems force system))
8.10170- (forced-not (normalize-forced-not-systems force-not system))
8.10171- (parameters `(,@(when force `(:force ,force))
8.10172- ,@(when force-not `(:force-not ,force-not))
8.10173- ,@(when (or (eq force t) (eq force-not t)) `(:system ,system))
8.10174- ,@(when performable-p `(:performable-p t))))
8.10175- forcing)
8.10176- (cond
8.10177- ((not session-forcing)
8.10178- (setf forcing (make-instance 'forcing
8.10179- :performable-p performable-p :parameters parameters
8.10180- :forced forced :forced-not forced-not))
8.10181- (when (and performable-p *asdf-session*)
8.10182- (setf (forcing *asdf-session*) forcing)))
8.10183- (performable-p
8.10184- (when (and (not (equal parameters (parameters session-forcing)))
8.10185- (or force-p force-not-p))
8.10186- (parameter-error "~*~S and ~S arguments not allowed in a nested call to ~3:*~S ~
8.10187-unless identically to toplevel"
8.10188- (find-symbol* :operate :asdf) :force :force-not))
8.10189- (setf forcing session-forcing))
8.10190- (t
8.10191- (setf forcing (make-instance 'forcing
8.10192- ;; Combine force and force-not with values from the toplevel-plan
8.10193- :parameters `(,@parameters :on-top-of ,(parameters session-forcing))
8.10194- :forced (or-function (forced session-forcing) forced)
8.10195- :forced-not (or-function (forced-not session-forcing) forced-not)))))
8.10196- forcing))
8.10197-
8.10198- (defmethod print-object ((forcing forcing) stream)
8.10199- (print-unreadable-object (forcing stream :type t)
8.10200- (format stream "~{~S~^ ~}" (parameters forcing))))
8.10201-
8.10202- ;; During upgrade, the *asdf-session* may legitimately be NIL, so we must handle that case.
8.10203- (defmethod forcing ((x null))
8.10204- (if-let (session (toplevel-asdf-session))
8.10205- (forcing session)
8.10206- (make-forcing :performable-p t)))
8.10207-
8.10208- ;; When performing a plan that is a list of actions, use the toplevel asdf sesssion forcing.
8.10209- (defmethod forcing ((x cons)) (forcing (toplevel-asdf-session))))
8.10210-;;;; -------------------------------------------------------------------------
8.10211-;;;; Plan
8.10212-
8.10213-(uiop/package:define-package :asdf/plan
8.10214- ;; asdf/action below is needed for required-components, traverse-action and traverse-sub-actions
8.10215- ;; that used to live there before 3.2.0.
8.10216- (:recycle :asdf/plan :asdf/action :asdf)
8.10217- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
8.10218- :asdf/component :asdf/operation :asdf/action :asdf/lisp-action
8.10219- :asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing)
8.10220- (:export
8.10221- #:plan #:plan-traversal #:sequential-plan #:*plan-class*
8.10222- #:action-status #:status-stamp #:status-index #:status-done-p #:status-keep-p #:status-need-p
8.10223- #:action-already-done-p
8.10224- #:+status-good+ #:+status-todo+ #:+status-void+
8.10225- #:system-out-of-date #:action-up-to-date-p
8.10226- #:circular-dependency #:circular-dependency-actions
8.10227- #:needed-in-image-p
8.10228- #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
8.10229- #:compute-action-stamp #:traverse-action #:record-dependency
8.10230- #:make-plan #:plan-actions #:plan-actions-r #:perform-plan #:mark-as-done
8.10231- #:required-components #:filtered-sequential-plan
8.10232- #:plan-component-type #:plan-keep-operation #:plan-keep-component))
8.10233-(in-package :asdf/plan)
8.10234-
8.10235-;;;; Generic plan traversal class
8.10236-(with-upgradability ()
8.10237- (defclass plan () ()
8.10238- (:documentation "Base class for a plan based on which ASDF can build a system"))
8.10239- (defclass plan-traversal (plan)
8.10240- (;; The forcing parameters for this plan. Also indicates whether the plan is performable,
8.10241- ;; in which case the forcing is the same as for the entire session.
8.10242- (forcing :initform (forcing (toplevel-asdf-session)) :initarg :forcing :reader forcing))
8.10243- (:documentation "Base class for plans that simply traverse dependencies"))
8.10244- ;; Sequential plans (the default)
8.10245- (defclass sequential-plan (plan-traversal)
8.10246- ((actions-r :initform nil :accessor plan-actions-r))
8.10247- (:documentation "Simplest, default plan class, accumulating a sequence of actions"))
8.10248-
8.10249- (defgeneric plan-actions (plan)
8.10250- (:documentation "Extract from a plan a list of actions to perform in sequence"))
8.10251- (defmethod plan-actions ((plan list))
8.10252- plan)
8.10253- (defmethod plan-actions ((plan sequential-plan))
8.10254- (reverse (plan-actions-r plan)))
8.10255-
8.10256- (defgeneric record-dependency (plan operation component)
8.10257- (:documentation "Record that, within PLAN, performing OPERATION on COMPONENT depends on all
8.10258-of the (OPERATION . COMPONENT) actions in the current ASDF session's VISITING-ACTION-LIST.
8.10259-
8.10260-You can get a single action which dominates the set of dependencies corresponding to this call with
8.10261-(first (visiting-action-list *asdf-session*))
8.10262-since VISITING-ACTION-LIST is a stack whose top action depends directly on its second action,
8.10263-and whose second action depends directly on its third action, and so forth."))
8.10264-
8.10265- ;; No need to record a dependency to build a full graph, just accumulate nodes in order.
8.10266- (defmethod record-dependency ((plan sequential-plan) (o operation) (c component))
8.10267- (values)))
8.10268-
8.10269-(when-upgrading (:version "3.3.0")
8.10270- (defmethod initialize-instance :after ((plan plan-traversal) &key &allow-other-keys)))
8.10271-
8.10272-
8.10273-;;;; Planned action status
8.10274-(with-upgradability ()
8.10275- (defclass action-status ()
8.10276- ((bits
8.10277- :type fixnum :initarg :bits :reader status-bits
8.10278- :documentation "bitmap describing the status of the action.")
8.10279- (stamp
8.10280- :type (or integer boolean) :initarg :stamp :reader status-stamp
8.10281- :documentation "STAMP associated with the ACTION if it has been completed already in some
8.10282-previous session or image, T if it was done and builtin the image, or NIL if it needs to be done.")
8.10283- (level
8.10284- :type fixnum :initarg :level :initform 0 :reader status-level
8.10285- :documentation "the highest (operate-level) at which the action was needed")
8.10286- (index
8.10287- :type (or integer null) :initarg :index :initform nil :reader status-index
8.10288- :documentation "INDEX associated with the ACTION in the current session,
8.10289-or NIL if no the status is considered outside of a specific plan."))
8.10290- (:documentation "Status of an action in a plan"))
8.10291-
8.10292- ;; STAMP KEEP-P DONE-P NEED-P symbol bitmap previously currently
8.10293- ;; not-nil T T T => GOOD 7 up-to-date done (e.g. file previously loaded)
8.10294- ;; not-nil T T NIL => HERE 6 up-to-date unplanned yet done
8.10295- ;; not-nil T NIL T => REDO 5 up-to-date planned (e.g. file to load)
8.10296- ;; not-nil T NIL NIL => SKIP 4 up-to-date unplanned (e.g. file compiled)
8.10297- ;; not-nil NIL T T => DONE 3 out-of-date done
8.10298- ;; not-nil NIL T NIL => WHAT 2 out-of-date unplanned yet done(?)
8.10299- ;; NIL NIL NIL T => TODO 1 out-of-date planned
8.10300- ;; NIL NIL NIL NIL => VOID 0 out-of-date unplanned
8.10301- ;;
8.10302- ;; Note that a VOID status cannot happen as part of a transitive dependency of a wanted node
8.10303- ;; while traversing a node with TRAVERSE-ACTION; it can only happen while checking whether an
8.10304- ;; action is up-to-date with ACTION-UP-TO-DATE-P.
8.10305- ;;
8.10306- ;; When calling TRAVERSE-ACTION, the +need-bit+ is set,
8.10307- ;; unless the action is up-to-date and not needed-in-image (HERE, SKIP).
8.10308- ;; When PERFORMing an action, the +done-bit+ is set.
8.10309- ;; When the +need-bit+ is set but not the +done-bit+, the level slot indicates which level of
8.10310- ;; OPERATE it was last marked needed for; if it happens to be needed at a higher-level, then
8.10311- ;; its urgency (and that of its transitive dependencies) must be escalated so that it will be
8.10312- ;; done before the end of this level of operate.
8.10313- ;;
8.10314- ;; Also, when no ACTION-STATUS is associated to an action yet, NIL serves as a bottom value.
8.10315- ;;
8.10316- (defparameter +keep-bit+ 4)
8.10317- (defparameter +done-bit+ 2)
8.10318- (defparameter +need-bit+ 1)
8.10319- (defparameter +good-bits+ 7)
8.10320- (defparameter +todo-bits+ 1)
8.10321- (defparameter +void-bits+ 0)
8.10322-
8.10323- (defparameter +status-good+
8.10324- (make-instance 'action-status :bits +good-bits+ :stamp t))
8.10325- (defparameter +status-todo+
8.10326- (make-instance 'action-status :bits +todo-bits+ :stamp nil))
8.10327- (defparameter +status-void+
8.10328- (make-instance 'action-status :bits +void-bits+ :stamp nil)))
8.10329-
8.10330-(with-upgradability ()
8.10331- (defun make-action-status (&key bits stamp (level 0) index)
8.10332- (check-type bits (integer 0 7))
8.10333- (check-type stamp (or integer boolean))
8.10334- (check-type level (integer 0 #.most-positive-fixnum))
8.10335- (check-type index (or integer null))
8.10336- (assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) ()
8.10337- "Bad action-status :bits ~S :stamp ~S" bits stamp)
8.10338- (block nil
8.10339- (when (and (null index) (zerop level))
8.10340- (case bits
8.10341- (#.+void-bits+ (return +status-void+))
8.10342- (#.+todo-bits+ (return +status-todo+))
8.10343- (#.+good-bits+ (when (eq stamp t) (return +status-good+)))))
8.10344- (make-instance 'action-status :bits bits :stamp stamp :level level :index index)))
8.10345-
8.10346- (defun status-keep-p (status)
8.10347- (plusp (logand (status-bits status) #.+keep-bit+)))
8.10348- (defun status-done-p (status)
8.10349- (plusp (logand (status-bits status) #.+done-bit+)))
8.10350- (defun status-need-p (status)
8.10351- (plusp (logand (status-bits status) #.+need-bit+)))
8.10352-
8.10353- (defun merge-action-status (status1 status2) ;; status-and
8.10354- "Return the earliest status later than both status1 and status2"
8.10355- (make-action-status
8.10356- :bits (logand (status-bits status1) (status-bits status2))
8.10357- :stamp (latest-timestamp (status-stamp status1) (status-stamp status2))
8.10358- :level (min (status-level status1) (status-level status2))
8.10359- :index (or (status-index status1) (status-index status2))))
8.10360-
8.10361- (defun mark-status-needed (status &optional (level (operate-level))) ;; limited status-or
8.10362- "Return the same status but with the need bit set, for the given level"
8.10363- (if (and (status-need-p status)
8.10364- (>= (status-level status) level))
8.10365- status
8.10366- (make-action-status
8.10367- :bits (logior (status-bits status) +need-bit+)
8.10368- :level (max level (status-level status))
8.10369- :stamp (status-stamp status)
8.10370- :index (status-index status))))
8.10371-
8.10372- (defmethod print-object ((status action-status) stream)
8.10373- (print-unreadable-object (status stream :type t)
8.10374- (with-slots (bits stamp level index) status
8.10375- (format stream "~{~S~^ ~}" `(:bits ,bits :stamp ,stamp :level ,level :index ,index)))))
8.10376-
8.10377- (defgeneric action-status (plan operation component)
8.10378- (:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT
8.10379-in the PLAN, or NIL if the action wasn't visited yet as part of the PLAN."))
8.10380-
8.10381- (defgeneric (setf action-status) (new-status plan operation component)
8.10382- (:documentation "Sets the ACTION-STATUS associated to
8.10383-the action of OPERATION on COMPONENT in the PLAN"))
8.10384-
8.10385- (defmethod action-status ((plan null) (o operation) (c component))
8.10386- (multiple-value-bind (stamp done-p) (component-operation-time o c)
8.10387- (if done-p
8.10388- (make-action-status :bits #.+keep-bit+ :stamp stamp)
8.10389- +status-void+)))
8.10390-
8.10391- (defmethod (setf action-status) (new-status (plan null) (o operation) (c component))
8.10392- (let ((times (component-operation-times c)))
8.10393- (if (status-done-p new-status)
8.10394- (setf (gethash o times) (status-stamp new-status))
8.10395- (remhash o times)))
8.10396- new-status)
8.10397-
8.10398- ;; Handle FORCED-NOT: it makes an action return its current timestamp as status
8.10399- (defmethod action-status ((p plan) (o operation) (c component))
8.10400- ;; TODO: should we instead test something like:
8.10401- ;; (action-forced-not-p plan operation (primary-system component))
8.10402- (or (gethash (make-action o c) (visited-actions *asdf-session*))
8.10403- (when (action-forced-not-p (forcing p) o c)
8.10404- (let ((status (action-status nil o c)))
8.10405- (setf (gethash (make-action o c) (visited-actions *asdf-session*))
8.10406- (make-action-status
8.10407- :bits +good-bits+
8.10408- :stamp (or (and status (status-stamp status)) t)
8.10409- :index (incf (total-action-count *asdf-session*))))))))
8.10410-
8.10411- (defmethod (setf action-status) (new-status (p plan) (o operation) (c component))
8.10412- (setf (gethash (make-action o c) (visited-actions *asdf-session*)) new-status))
8.10413-
8.10414- (defmethod (setf action-status) :after
8.10415- (new-status (p sequential-plan) (o operation) (c component))
8.10416- (unless (status-done-p new-status)
8.10417- (push (make-action o c) (plan-actions-r p)))))
8.10418-
8.10419-
8.10420-;;;; Is the action needed in this image?
8.10421-(with-upgradability ()
8.10422- (defgeneric needed-in-image-p (operation component)
8.10423- (:documentation "Is the action of OPERATION on COMPONENT needed in the current image
8.10424-to be meaningful, or could it just as well have been done in another Lisp image?"))
8.10425-
8.10426- (defmethod needed-in-image-p ((o operation) (c component))
8.10427- ;; We presume that actions that modify the filesystem don't need be run
8.10428- ;; in the current image if they have already been done in another,
8.10429- ;; and can be run in another process (e.g. a fork),
8.10430- ;; whereas those that don't are meant to side-effect the current image and can't.
8.10431- (not (output-files o c))))
8.10432-
8.10433-
8.10434-;;;; Visiting dependencies of an action and computing action stamps
8.10435-(with-upgradability ()
8.10436- (defun map-direct-dependencies (operation component fun)
8.10437- "Call FUN on all the valid dependencies of the given action in the given plan"
8.10438- (loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
8.10439- :for dep-o = (find-operation operation dep-o-spec)
8.10440- :when dep-o
8.10441- :do (loop :for dep-c-spec :in dep-c-specs
8.10442- :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
8.10443- :when (action-valid-p dep-o dep-c)
8.10444- :do (funcall fun dep-o dep-c))))
8.10445-
8.10446- (defun reduce-direct-dependencies (operation component combinator seed)
8.10447- "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR
8.10448-for each dependency action on the dependency's operation and component and an accumulator
8.10449-initialized with SEED."
8.10450- (map-direct-dependencies
8.10451- operation component
8.10452- #'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed))))
8.10453- seed)
8.10454-
8.10455- (defun direct-dependencies (operation component)
8.10456- "Compute a list of the direct dependencies of the action within the plan"
8.10457- (reverse (reduce-direct-dependencies operation component #'acons nil)))
8.10458-
8.10459- ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp
8.10460- ;; shall also be parametrized by the plan, or by a second model object,
8.10461- ;; so they need not refer to the state of the filesystem,
8.10462- ;; and the stamps could be cryptographic checksums rather than timestamps.
8.10463- ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP.
8.10464- (define-condition dependency-not-done (warning)
8.10465- ((op
8.10466- :initarg :op)
8.10467- (component
8.10468- :initarg :component)
8.10469- (dep-op
8.10470- :initarg :dep-op)
8.10471- (dep-component
8.10472- :initarg :dep-component)
8.10473- (plan
8.10474- :initarg :plan
8.10475- :initform nil))
8.10476- (:report (lambda (condition stream)
8.10477- (with-slots (op component dep-op dep-component plan) condition
8.10478- (format stream "Computing just-done stamp ~@[in plan ~S~] for action ~S, but dependency ~S wasn't done yet!"
8.10479- plan
8.10480- (action-path (make-action op component))
8.10481- (action-path (make-action dep-op dep-component)))))))
8.10482-
8.10483- (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
8.10484- ;; Given an action, figure out at what time in the past it has been done,
8.10485- ;; or if it has just been done, return the time that it has.
8.10486- ;; Returns two values:
8.10487- ;; 1- the TIMESTAMP of the action if it has already been done and is up to date,
8.10488- ;; or NIL is either hasn't been done or is out of date.
8.10489- ;; (An ASDF extension could use a cryptographic digest instead.)
8.10490- ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done
8.10491- ;; in the current image, or NIL if it hasn't.
8.10492- ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but
8.10493- ;; hasn't been done in the current image yet, then it can have a non-NIL timestamp,
8.10494- ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded,
8.10495- ;; i.e. that of the input-files.
8.10496- ;; If just-done is NIL, these values return are the notional fields of
8.10497- ;; a KEEP, REDO or TODO status (VOID is possible, but probably an error).
8.10498- ;; If just-done is T, they are the notional fields of DONE status
8.10499- ;; (or, if something went wrong, TODO).
8.10500- (nest
8.10501- (block ())
8.10502- (let* ((dep-status ; collect timestamp from dependencies (or T if forced or out-of-date)
8.10503- (reduce-direct-dependencies
8.10504- o c
8.10505- #'(lambda (do dc status)
8.10506- ;; out-of-date dependency: don't bother looking further
8.10507- (let ((action-status (action-status plan do dc)))
8.10508- (cond
8.10509- ((and action-status (or (status-keep-p action-status)
8.10510- (and just-done (status-stamp action-status))))
8.10511- (merge-action-status action-status status))
8.10512- (just-done
8.10513- ;; It's OK to lose some ASDF action stamps during self-upgrade
8.10514- (unless (equal "asdf" (primary-system-name dc))
8.10515- (warn 'dependency-not-done
8.10516- :plan plan
8.10517- :op o :component c
8.10518- :dep-op do :dep-component dc))
8.10519- status)
8.10520- (t
8.10521- (return (values nil nil))))))
8.10522- +status-good+))
8.10523- (dep-stamp (status-stamp dep-status))))
8.10524- (let* (;; collect timestamps from inputs, and exit early if any is missing
8.10525- (in-files (input-files o c))
8.10526- (in-stamps (mapcar #'get-file-stamp in-files))
8.10527- (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
8.10528- (latest-in (timestamps-latest (cons dep-stamp in-stamps))))
8.10529- (when (and missing-in (not just-done)) (return (values nil nil))))
8.10530- (let* (;; collect timestamps from outputs, and exit early if any is missing
8.10531- (out-files (remove-if 'null (output-files o c)))
8.10532- (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
8.10533- (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
8.10534- (earliest-out (timestamps-earliest out-stamps)))
8.10535- (when (and missing-out (not just-done)) (return (values nil nil))))
8.10536- (let (;; Time stamps from the files at hand, and whether any is missing
8.10537- (all-present (not (or missing-in missing-out)))
8.10538- ;; Has any input changed since we last generated the files?
8.10539- ;; Note that we use timestamp<= instead of timestamp< to play nice with generated files.
8.10540- ;; Any race condition is intrinsic to the limited timestamp resolution.
8.10541- (up-to-date-p (timestamp<= latest-in earliest-out))
8.10542- ;; If everything is up to date, the latest of inputs and outputs is our stamp
8.10543- (done-stamp (timestamps-latest (cons latest-in out-stamps))))
8.10544- ;; Warn if some files are missing:
8.10545- ;; either our model is wrong or some other process is messing with our files.
8.10546- (when (and just-done (not all-present))
8.10547- ;; Shouldn't that be an error instead?
8.10548- (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
8.10549- ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
8.10550- (action-description o c)
8.10551- missing-in (length missing-in) (and missing-in missing-out)
8.10552- missing-out (length missing-out))))
8.10553- (let (;; There are three kinds of actions:
8.10554- (out-op (and out-files t)) ; those that create files on the filesystem
8.10555- ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
8.10556- ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
8.10557- ))
8.10558- (if (or just-done ;; The done-stamp is valid: if we're just done, or
8.10559- (and all-present ;; if all filesystem effects are up-to-date
8.10560- up-to-date-p
8.10561- (operation-done-p o c) ;; and there's no invalidating reason.
8.10562- (not (action-forced-p (forcing (or plan *asdf-session*)) o c))))
8.10563- (values done-stamp ;; return the hard-earned timestamp
8.10564- (or just-done
8.10565- out-op ;; A file-creating op is done when all files are up to date.
8.10566- ;; An image-effecting operation is done when
8.10567- (and (status-done-p dep-status) ;; all the dependencies were done, and
8.10568- (multiple-value-bind (perform-stamp perform-done-p)
8.10569- (component-operation-time o c)
8.10570- (and perform-done-p ;; the op was actually run,
8.10571- (equal perform-stamp done-stamp)))))) ;; with a matching stamp.
8.10572- ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
8.10573- (values nil nil)))))
8.10574-
8.10575-
8.10576-;;;; The four different actual traversals:
8.10577-;; * TRAVERSE-ACTION o c T: Ensure all dependencies are either up-to-date in-image, or planned
8.10578-;; * TRAVERSE-ACTION o c NIL: Ensure all dependencies are up-to-date or planned, in-image or not
8.10579-;; * ACTION-UP-TO-DATE-P: Check whether some (defsystem-depends-on ?) dependencies are up to date
8.10580-;; * COLLECT-ACTION-DEPENDENCIES: Get the dependencies (filtered), don't change any status
8.10581-(with-upgradability ()
8.10582-
8.10583- ;; Compute the action status for a newly visited action.
8.10584- (defun compute-action-status (plan operation component need-p)
8.10585- (multiple-value-bind (stamp done-p)
8.10586- (compute-action-stamp plan operation component)
8.10587- (assert (or stamp (not done-p)))
8.10588- (make-action-status
8.10589- :bits (logior (if stamp #.+keep-bit+ 0)
8.10590- (if done-p #.+done-bit+ 0)
8.10591- (if need-p #.+need-bit+ 0))
8.10592- :stamp stamp
8.10593- :level (operate-level)
8.10594- :index (incf (total-action-count *asdf-session*)))))
8.10595-
8.10596- ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data,
8.10597- ;; visits the action defined by its OPERATION and COMPONENT arguments,
8.10598- ;; and all its transitive dependencies (unless already visited),
8.10599- ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P,
8.10600- ;; i.e. needs to be done in the current image vs merely have been done in a previous image.
8.10601- ;;
8.10602- ;; TRAVERSE-ACTION updates the VISITED-ACTIONS entries for the action and for all its
8.10603- ;; transitive dependencies (that haven't been sufficiently visited so far).
8.10604- ;; It does not return any usable value.
8.10605- ;;
8.10606- ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action,
8.10607- ;; the below method would be insufficient, since it assumes a single image
8.10608- ;; to traverse each node at most twice; non-niip actions would be traversed only once,
8.10609- ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action.
8.10610-
8.10611- (defun traverse-action (plan operation component needed-in-image-p)
8.10612- (block nil
8.10613- (unless (action-valid-p operation component) (return))
8.10614- ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph,
8.10615- ;; instead of just a dependency order as in vanilla ASDF.
8.10616- ;; TODO: It is also needed to detect OPERATE-in-PERFORM.
8.10617- (record-dependency plan operation component)
8.10618- (while-visiting-action (operation component) ; maintain context, handle circularity.
8.10619- ;; needed-in-image distinguishes b/w things that must happen in the
8.10620- ;; current image and those things that simply need to have been done in a previous one.
8.10621- (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image
8.10622- ;; effective niip: meaningful for the action and required by the plan as traversed
8.10623- (eniip (and aniip needed-in-image-p))
8.10624- ;; status: have we traversed that action previously, and if so what was its status?
8.10625- (status (action-status plan operation component))
8.10626- (level (operate-level)))
8.10627- (when (and status
8.10628- (or (status-done-p status) ;; all done
8.10629- (and (status-need-p status) (<= level (status-level status))) ;; already visited
8.10630- (and (status-keep-p status) (not eniip)))) ;; up-to-date and not eniip
8.10631- (return)) ; Already visited with sufficient need-in-image level!
8.10632- (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T
8.10633- (map-direct-dependencies ; recursively traverse dependencies
8.10634- operation component #'(lambda (o c) (traverse-action plan o c niip)))
8.10635- ;; AFTER dependencies have been traversed, compute action stamp
8.10636- (let* ((status (if status
8.10637- (mark-status-needed status level)
8.10638- (compute-action-status plan operation component t)))
8.10639- (out-of-date-p (not (status-keep-p status)))
8.10640- (to-perform-p (or out-of-date-p (and niip (not (status-done-p status))))))
8.10641- (cond ; it needs be done if it's out of date or needed in image but absent
8.10642- ((and out-of-date-p (not niip)) ; if we need to do it,
8.10643- (visit-action t)) ; then we need to do it *in the (current) image*!
8.10644- (t
8.10645- (setf (action-status plan operation component) status)
8.10646- (when (status-done-p status)
8.10647- (setf (component-operation-time operation component)
8.10648- (status-stamp status)))
8.10649- (when to-perform-p ; if it needs to be added to the plan, count it
8.10650- (incf (planned-action-count *asdf-session*))
8.10651- (unless aniip ; if it's output-producing, count it
8.10652- (incf (planned-output-action-count *asdf-session*)))))))))
8.10653- (visit-action eniip)))))) ; visit the action
8.10654-
8.10655- ;; NB: This is not an error, not a warning, but a normal expected condition,
8.10656- ;; to be to signaled by FIND-SYSTEM when it detects an out-of-date system,
8.10657- ;; *before* it tries to replace it with a new definition.
8.10658- (define-condition system-out-of-date (condition)
8.10659- ((name :initarg :name :reader component-name))
8.10660- (:documentation "condition signaled when a system is detected as being out of date")
8.10661- (:report (lambda (c s)
8.10662- (format s "system ~A is out of date" (component-name c)))))
8.10663-
8.10664- (defun action-up-to-date-p (plan operation component)
8.10665- "Check whether an action was up-to-date at the beginning of the session.
8.10666-Update the VISITED-ACTIONS table with the known status, but don't add anything to the PLAN."
8.10667- (block nil
8.10668- (unless (action-valid-p operation component) (return t))
8.10669- (while-visiting-action (operation component) ; maintain context, handle circularity.
8.10670- ;; Do NOT record the dependency: it might be out of date.
8.10671- (let ((status (or (action-status plan operation component)
8.10672- (setf (action-status plan operation component)
8.10673- (let ((dependencies-up-to-date-p
8.10674- (handler-case
8.10675- (block nil
8.10676- (map-direct-dependencies
8.10677- operation component
8.10678- #'(lambda (o c)
8.10679- (unless (action-up-to-date-p plan o c)
8.10680- (return nil))))
8.10681- t)
8.10682- (system-out-of-date () nil))))
8.10683- (if dependencies-up-to-date-p
8.10684- (compute-action-status plan operation component nil)
8.10685- +status-void+))))))
8.10686- (and (status-keep-p status) (status-stamp status)))))))
8.10687-
8.10688-
8.10689-;;;; Incidental traversals
8.10690-
8.10691-;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source
8.10692-;;; files required by a bundling operation.
8.10693-(with-upgradability ()
8.10694- (defclass filtered-sequential-plan (sequential-plan)
8.10695- ((component-type :initform t :initarg :component-type :reader plan-component-type)
8.10696- (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation)
8.10697- (keep-component :initform t :initarg :keep-component :reader plan-keep-component))
8.10698- (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions."))
8.10699-
8.10700- (defmethod initialize-instance :after ((plan filtered-sequential-plan)
8.10701- &key system other-systems)
8.10702- ;; Ignore force and force-not, rely on other-systems:
8.10703- ;; force traversal of what we're interested in, i.e. current system or also others;
8.10704- ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems.
8.10705- (setf (slot-value plan 'forcing)
8.10706- (make-forcing :system system :force :all :force-not (if other-systems nil t))))
8.10707-
8.10708- (defmethod plan-actions ((plan filtered-sequential-plan))
8.10709- (with-slots (keep-operation keep-component) plan
8.10710- (loop :for action :in (call-next-method)
8.10711- :as o = (action-operation action)
8.10712- :as c = (action-component action)
8.10713- :when (and (typep o keep-operation) (typep c keep-component))
8.10714- :collect (make-action o c))))
8.10715-
8.10716- (defun collect-action-dependencies (plan operation component)
8.10717- (when (action-valid-p operation component)
8.10718- (while-visiting-action (operation component) ; maintain context, handle circularity.
8.10719- (let ((action (make-action operation component)))
8.10720- (unless (nth-value 1 (gethash action (visited-actions *asdf-session*)))
8.10721- (setf (gethash action (visited-actions *asdf-session*)) nil)
8.10722- (when (and (typep component (plan-component-type plan))
8.10723- (not (action-forced-not-p (forcing plan) operation component)))
8.10724- (map-direct-dependencies operation component
8.10725- #'(lambda (o c) (collect-action-dependencies plan o c)))
8.10726- (push action (plan-actions-r plan))))))))
8.10727-
8.10728- (defgeneric collect-dependencies (operation component &key &allow-other-keys)
8.10729- (:documentation "Given an action, build a plan for all of its dependencies."))
8.10730- (define-convenience-action-methods collect-dependencies (operation component &key))
8.10731- (defmethod collect-dependencies ((operation operation) (component component)
8.10732- &rest keys &key &allow-other-keys)
8.10733- (let ((plan (apply 'make-instance 'filtered-sequential-plan
8.10734- :system (component-system component) keys)))
8.10735- (loop :for action :in (direct-dependencies operation component)
8.10736- :do (collect-action-dependencies plan (action-operation action) (action-component action)))
8.10737- (plan-actions plan)))
8.10738-
8.10739- (defun required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
8.10740- "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and
8.10741-return a list of the components involved in building the desired action."
8.10742- (with-asdf-session (:override t)
8.10743- (remove-duplicates
8.10744- (mapcar 'action-component
8.10745- (apply 'collect-dependencies goal-operation system
8.10746- (remove-plist-key :goal-operation keys)))
8.10747- :from-end t))))
8.10748-
8.10749-
8.10750-;;;; High-level interface: make-plan, perform-plan
8.10751-(with-upgradability ()
8.10752- (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
8.10753- (:documentation "Generate and return a plan for performing OPERATION on COMPONENT."))
8.10754- (define-convenience-action-methods make-plan (plan-class operation component &key))
8.10755-
8.10756- (defgeneric mark-as-done (plan-class operation component)
8.10757- (:documentation "Mark an action as done in a plan, after performing it."))
8.10758- (define-convenience-action-methods mark-as-done (plan-class operation component))
8.10759-
8.10760- (defgeneric perform-plan (plan &key)
8.10761- (:documentation "Actually perform a plan and build the requested actions"))
8.10762-
8.10763- (defparameter* *plan-class* 'sequential-plan
8.10764- "The default plan class to use when building with ASDF")
8.10765-
8.10766- (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
8.10767- (with-asdf-session ()
8.10768- (let ((plan (apply 'make-instance (or plan-class *plan-class*) keys)))
8.10769- (traverse-action plan o c t)
8.10770- plan)))
8.10771-
8.10772- (defmethod perform-plan :around ((plan t) &key)
8.10773- (assert (performable-p (forcing plan)) () "plan not performable")
8.10774- (let ((*package* *package*)
8.10775- (*readtable* *readtable*))
8.10776- (with-compilation-unit () ;; backward-compatibility.
8.10777- (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
8.10778-
8.10779- (defun action-already-done-p (plan operation component)
8.10780- (if-let (status (action-status plan operation component))
8.10781- (status-done-p status)))
8.10782-
8.10783- (defmethod perform-plan ((plan t) &key)
8.10784- (loop :for action :in (plan-actions plan)
8.10785- :as o = (action-operation action)
8.10786- :as c = (action-component action) :do
8.10787- (unless (action-already-done-p plan o c)
8.10788- (perform-with-restarts o c)
8.10789- (mark-as-done plan o c))))
8.10790-
8.10791- (defmethod mark-as-done ((plan plan) (o operation) (c component))
8.10792- (let ((plan-status (action-status plan o c))
8.10793- (perform-status (action-status nil o c)))
8.10794- (assert (and (status-stamp perform-status) (status-keep-p perform-status)) ()
8.10795- "Just performed ~A but failed to mark it done" (action-description o c))
8.10796- (setf (action-status plan o c)
8.10797- (make-action-status
8.10798- :bits (logior (status-bits plan-status) +done-bit+)
8.10799- :stamp (status-stamp perform-status)
8.10800- :level (status-level plan-status)
8.10801- :index (status-index plan-status))))))
8.10802-;;;; -------------------------------------------------------------------------
8.10803-;;;; Invoking Operations
8.10804-
8.10805-(uiop/package:define-package :asdf/operate
8.10806- (:recycle :asdf/operate :asdf)
8.10807- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
8.10808- :asdf/component :asdf/system :asdf/system-registry :asdf/find-component
8.10809- :asdf/operation :asdf/action :asdf/lisp-action :asdf/forcing :asdf/plan)
8.10810- (:export
8.10811- #:operate #:oos #:build-op #:make
8.10812- #:load-system #:load-systems #:load-systems*
8.10813- #:compile-system #:test-system #:require-system #:module-provide-asdf
8.10814- #:component-loaded-p #:already-loaded-systems
8.10815- #:recursive-operate))
8.10816-(in-package :asdf/operate)
8.10817-
8.10818-(with-upgradability ()
8.10819- (defgeneric operate (operation component &key)
8.10820- (:documentation
8.10821- "Operate does mainly four things for the user:
8.10822-
8.10823-1. Resolves the OPERATION designator into an operation object.
8.10824- OPERATION is typically a symbol denoting an operation class, instantiated with MAKE-OPERATION.
8.10825-2. Resolves the COMPONENT designator into a component object.
8.10826- COMPONENT is typically a string or symbol naming a system, loaded from disk using FIND-SYSTEM.
8.10827-3. It then calls MAKE-PLAN with the operation and system as arguments.
8.10828-4. Finally calls PERFORM-PLAN on the resulting plan to actually build the system.
8.10829-
8.10830-The entire computation is wrapped in WITH-COMPILATION-UNIT and error handling code.
8.10831-If a VERSION argument is supplied, then operate also ensures that the system found satisfies it
8.10832-using the VERSION-SATISFIES method.
8.10833-If a PLAN-CLASS argument is supplied, that class is used for the plan.
8.10834-If a PLAN-OPTIONS argument is supplied, the options are passed to the plan.
8.10835-
8.10836-The :FORCE or :FORCE-NOT argument to OPERATE can be:
8.10837- T to force the inside of the specified system to be rebuilt (resp. not),
8.10838- without recursively forcing the other systems we depend on.
8.10839- :ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
8.10840- (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
8.10841-:FORCE-NOT has precedence over :FORCE; builtin systems cannot be forced.
8.10842-
8.10843-For backward compatibility, all keyword arguments are passed to MAKE-OPERATION
8.10844-when instantiating a new operation, that will in turn be inherited by new operations.
8.10845-But do NOT depend on it, for this is deprecated behavior."))
8.10846-
8.10847- (define-convenience-action-methods operate (operation component &key)
8.10848- :if-no-component (error 'missing-component :requires component))
8.10849-
8.10850- ;; This method ensures that an ASDF upgrade is attempted as the very first thing,
8.10851- ;; with suitable state preservation in case in case it actually happens,
8.10852- ;; and that a few suitable dynamic bindings are established.
8.10853- (defmethod operate :around (operation component &rest keys
8.10854- &key verbose
8.10855- (on-warnings *compile-file-warnings-behaviour*)
8.10856- (on-failure *compile-file-failure-behaviour*))
8.10857- (nest
8.10858- (with-asdf-session ())
8.10859- (let* ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
8.10860- (etypecase operation
8.10861- (operation (let ((name (type-of operation)))
8.10862- #'(lambda () (make-operation name))))
8.10863- ((or symbol string) (constantly operation))))
8.10864- (component-path (typecase component ;; to remake the component after ASDF upgrade
8.10865- (component (component-find-path component))
8.10866- (t component)))
8.10867- (system-name (labels ((first-name (x)
8.10868- (etypecase x
8.10869- ((or string symbol) x) ; NB: includes the NIL case.
8.10870- (cons (or (first-name (car x)) (first-name (cdr x)))))))
8.10871- (coerce-name (first-name component-path)))))
8.10872- (apply 'make-forcing :performable-p t :system system-name keys)
8.10873- ;; Before we operate on any system, make sure ASDF is up-to-date,
8.10874- ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
8.10875- (unless (asdf-upgraded-p (toplevel-asdf-session))
8.10876- (setf (asdf-upgraded-p (toplevel-asdf-session)) t)
8.10877- (when (upgrade-asdf)
8.10878- ;; If we were upgraded, restart OPERATE the hardest of ways, for
8.10879- ;; its function may have been redefined.
8.10880- (return-from operate
8.10881- (with-asdf-session (:override t :override-cache t)
8.10882- (apply 'operate (funcall operation-remaker) component-path keys))))))
8.10883- ;; Setup proper bindings around any operate call.
8.10884- (let* ((*verbose-out* (and verbose *standard-output*))
8.10885- (*compile-file-warnings-behaviour* on-warnings)
8.10886- (*compile-file-failure-behaviour* on-failure)))
8.10887- (unwind-protect
8.10888- (progn
8.10889- (incf (operate-level))
8.10890- (call-next-method))
8.10891- (decf (operate-level)))))
8.10892-
8.10893- (defmethod operate :before ((operation operation) (component component)
8.10894- &key version)
8.10895- (unless (version-satisfies component version)
8.10896- (error 'missing-component-of-version :requires component :version version))
8.10897- (record-dependency nil operation component))
8.10898-
8.10899- (defmethod operate ((operation operation) (component component)
8.10900- &key plan-class plan-options)
8.10901- (let ((plan (apply 'make-plan plan-class operation component
8.10902- :forcing (forcing *asdf-session*) plan-options)))
8.10903- (perform-plan plan)
8.10904- (values operation plan)))
8.10905-
8.10906- (defun oos (operation component &rest args &key &allow-other-keys)
8.10907- (apply 'operate operation component args))
8.10908-
8.10909- (setf (documentation 'oos 'function)
8.10910- (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
8.10911- (documentation 'operate 'function)))
8.10912-
8.10913- (define-condition recursive-operate (warning)
8.10914- ((operation :initarg :operation :reader condition-operation)
8.10915- (component :initarg :component :reader condition-component)
8.10916- (action :initarg :action :reader condition-action))
8.10917- (:report (lambda (c s)
8.10918- (format s (compatfmt "~@<Deprecated recursive use of (~S '~S '~S) while visiting ~S ~
8.10919-- please use proper dependencies instead~@:>")
8.10920- 'operate
8.10921- (type-of (condition-operation c))
8.10922- (component-find-path (condition-component c))
8.10923- (action-path (condition-action c)))))))
8.10924-
8.10925-;;;; Common operations
8.10926-(when-upgrading ()
8.10927- (defmethod component-depends-on ((o prepare-op) (s system))
8.10928- (call-next-method)))
8.10929-(with-upgradability ()
8.10930- (defclass build-op (non-propagating-operation) ()
8.10931- (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
8.10932-to operate by default on a system or component, via the function BUILD.
8.10933-Its meaning is configurable via the :BUILD-OPERATION option of a component.
8.10934-which typically specifies the name of a specific operation to which to delegate the build,
8.10935-as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on);
8.10936-if NIL is specified (the default), BUILD-OP falls back to LOAD-OP,
8.10937-that will load the system in the current image."))
8.10938- (defmethod component-depends-on ((o build-op) (c component))
8.10939- `((,(or (component-build-operation c) 'load-op) ,c)
8.10940- ,@(call-next-method)))
8.10941-
8.10942- (defun make (system &rest keys)
8.10943- "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO).
8.10944-It will build system FOO using the operation BUILD-OP,
8.10945-the meaning of which is configurable by the system, and
8.10946-defaults to LOAD-OP, to load it in current image."
8.10947- (apply 'operate 'build-op system keys)
8.10948- t)
8.10949-
8.10950- (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys)
8.10951- "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details."
8.10952- (declare (ignore force force-not verbose version))
8.10953- (apply 'operate 'load-op system keys)
8.10954- t)
8.10955-
8.10956- (defun load-systems* (systems &rest keys)
8.10957- "Loading multiple systems at once."
8.10958- (dolist (s systems) (apply 'load-system s keys)))
8.10959-
8.10960- (defun load-systems (&rest systems)
8.10961- "Loading multiple systems at once."
8.10962- (load-systems* systems))
8.10963-
8.10964- (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys)
8.10965- "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details."
8.10966- (declare (ignore force force-not verbose version))
8.10967- (apply 'operate 'compile-op system args)
8.10968- t)
8.10969-
8.10970- (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys)
8.10971- "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details."
8.10972- (declare (ignore force force-not verbose version))
8.10973- (apply 'operate 'test-op system args)
8.10974- t))
8.10975-
8.10976-;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE,
8.10977-;; only tries to load its specified target if it's not loaded yet.
8.10978-(with-upgradability ()
8.10979- (defun component-loaded-p (component)
8.10980- "Has the given COMPONENT been successfully loaded in the current image (yet)?
8.10981-Note that this returns true even if the component is not up to date."
8.10982- (if-let ((component (find-component component () :registered t)))
8.10983- (nth-value 1 (component-operation-time (make-operation 'load-op) component))))
8.10984-
8.10985- (defun already-loaded-systems ()
8.10986- "return a list of the names of the systems that have been successfully loaded so far"
8.10987- (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*)))))
8.10988-
8.10989-
8.10990-;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
8.10991-;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
8.10992-;; Note that despite the two being homonyms, the _function_ require-system
8.10993-;; and the _class_ require-system are quite distinct entities, fulfilling independent purposes.
8.10994-(with-upgradability ()
8.10995- (defvar *modules-being-required* nil)
8.10996-
8.10997- (defclass require-system (system)
8.10998- ((module :initarg :module :initform nil :accessor required-module))
8.10999- (:documentation "A SYSTEM subclass whose processing is handled by
8.11000-the implementation's REQUIRE rather than by internal ASDF mechanisms."))
8.11001-
8.11002- (defmethod perform ((o compile-op) (c require-system))
8.11003- nil)
8.11004-
8.11005- (defmethod perform ((o load-op) (s require-system))
8.11006- (let* ((module (or (required-module s) (coerce-name s)))
8.11007- (*modules-being-required* (cons module *modules-being-required*)))
8.11008- (assert (null (component-children s)))
8.11009- (require module)))
8.11010-
8.11011- (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
8.11012- (unless (and (length=n-p arguments 1)
8.11013- (typep (car arguments) '(or string (and symbol (not null)))))
8.11014- (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S. ~S takes one argument, a string or non-null symbol~@:>")
8.11015- 'resolve-dependency-combination
8.11016- (cons combinator arguments) component combinator))
8.11017- ;; :require must be prepared for some implementations providing modules using ASDF,
8.11018- ;; as SBCL used to do, and others may might do. Thus, the system provided in the end
8.11019- ;; would be a downcased name as per module-provide-asdf above. For the same reason,
8.11020- ;; we cannot assume that the system in the end will be of type require-system,
8.11021- ;; but must check whether we can use find-system and short-circuit cl:require.
8.11022- ;; Otherwise, calling cl:require could result in nasty reentrant calls between
8.11023- ;; cl:require and asdf:operate that could potentially blow up the stack,
8.11024- ;; all the while defeating the consistency of the dependency graph.
8.11025- (let* ((module (car arguments)) ;; NB: we already checked that it was not null
8.11026- ;; CMUCL, MKCL, SBCL like their module names to be all upcase.
8.11027- (module-name (string module))
8.11028- (system-name (string-downcase module))
8.11029- (system (find-system system-name nil)))
8.11030- (or system (let ((system (make-instance 'require-system :name system-name :module module-name)))
8.11031- (register-system system)
8.11032- system))))
8.11033-
8.11034- (defun module-provide-asdf (name)
8.11035- ;; We must use string-downcase, because modules are traditionally specified as symbols,
8.11036- ;; that implementations traditionally normalize as uppercase, for which we seek a system
8.11037- ;; with a name that is traditionally in lowercase. Case is lost along the way. That's fine.
8.11038- ;; We could make complex, non-portable rules to try to preserve case, and just documenting
8.11039- ;; them would be a hell that it would be a disservice to inflict on users.
8.11040- (let ((module-name (string name))
8.11041- (system-name (string-downcase name)))
8.11042- (unless (member module-name *modules-being-required* :test 'equal)
8.11043- (let ((*modules-being-required* (cons module-name *modules-being-required*))
8.11044- #+sbcl (sb-impl::*requiring* (remove module-name sb-impl::*requiring* :test 'equal)))
8.11045- (handler-bind
8.11046- (((or style-warning recursive-operate) #'muffle-warning)
8.11047- (missing-component (constantly nil))
8.11048- (fatal-condition
8.11049- #'(lambda (e)
8.11050- (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
8.11051- name e))))
8.11052- (let ((*verbose-out* (make-broadcast-stream)))
8.11053- (let ((system (find-system system-name nil)))
8.11054- (when system
8.11055- ;; Do not use require-system after all, use load-system:
8.11056- ;; on the one hand, REQUIRE already uses *MODULES* not to load something twice,
8.11057- ;; on the other hand, REQUIRE-SYSTEM uses FORCE-NOT which may conflict with
8.11058- ;; the toplevel session forcing settings.
8.11059- (load-system system :verbose nil)
8.11060- t)))))))))
8.11061-
8.11062-
8.11063-;;;; Some upgrade magic
8.11064-(with-upgradability ()
8.11065- (defun restart-upgraded-asdf ()
8.11066- ;; If we're in the middle of something, restart it.
8.11067- (let ((systems-being-defined
8.11068- (when *asdf-session*
8.11069- (prog1
8.11070- (loop :for k :being :the hash-keys :of (asdf-cache)
8.11071- :when (eq (first k) 'find-system) :collect (second k))
8.11072- (clrhash (asdf-cache))))))
8.11073- ;; Regardless, clear defined systems, since they might be invalid
8.11074- ;; after an incompatible ASDF upgrade.
8.11075- (clear-registered-systems)
8.11076- ;; The configuration also may have to be upgraded.
8.11077- (upgrade-configuration)
8.11078- ;; If we were in the middle of an operation, be sure to restore the system being defined.
8.11079- (dolist (s systems-being-defined) (find-system s nil))))
8.11080- (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf))
8.11081-;;;; -------------------------------------------------------------------------
8.11082-;;;; Finding systems
8.11083-
8.11084-(uiop/package:define-package :asdf/find-system
8.11085- (:recycle :asdf/find-system :asdf)
8.11086- (:use :uiop/common-lisp :uiop :asdf/upgrade
8.11087- :asdf/session :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-action
8.11088- :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate)
8.11089- (:import-from #:asdf/component #:%additional-input-files)
8.11090- (:export
8.11091- #:find-system #:locate-system #:load-asd #:define-op
8.11092- #:load-system-definition-error #:error-name #:error-pathname #:error-condition))
8.11093-(in-package :asdf/find-system)
8.11094-
8.11095-(with-upgradability ()
8.11096- (define-condition load-system-definition-error (system-definition-error)
8.11097- ((name :initarg :name :reader error-name)
8.11098- (pathname :initarg :pathname :reader error-pathname)
8.11099- (condition :initarg :condition :reader error-condition))
8.11100- (:report (lambda (c s)
8.11101- (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
8.11102- (error-name c) (error-pathname c) (error-condition c)))))
8.11103-
8.11104-
8.11105- ;;; Methods for find-system
8.11106-
8.11107- ;; Reject NIL as a system designator.
8.11108- (defmethod find-system ((name null) &optional (error-p t))
8.11109- (when error-p
8.11110- (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
8.11111-
8.11112- ;; Default method for find-system: resolve the argument using COERCE-NAME.
8.11113- (defmethod find-system (name &optional (error-p t))
8.11114- (find-system (coerce-name name) error-p))
8.11115-
8.11116- (defun find-system-if-being-defined (name)
8.11117- ;; This function finds systems being defined *in the current ASDF session*, as embodied by
8.11118- ;; its session cache, even before they are fully defined and registered in *registered-systems*.
8.11119- ;; The purpose of this function is to prevent races between two files that might otherwise
8.11120- ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow.
8.11121- ;; This function explicitly MUST NOT find definitions merely registered in previous sessions.
8.11122- ;; NB: this function depends on a corresponding side-effect in parse-defsystem;
8.11123- ;; the precise protocol between the two functions may change in the future (or not).
8.11124- (first (gethash `(find-system ,(coerce-name name)) (asdf-cache))))
8.11125-
8.11126- (defclass define-op (non-propagating-operation) ()
8.11127- (:documentation "An operation to record dependencies on loading a .asd file."))
8.11128-
8.11129- (defmethod record-dependency ((plan null) (operation t) (component t))
8.11130- (unless (or (typep operation 'define-op)
8.11131- (and (typep operation 'load-op)
8.11132- (typep component 'system)
8.11133- (equal "asdf" (coerce-name component))))
8.11134- (if-let ((action (first (visiting-action-list *asdf-session*))))
8.11135- (let ((parent-operation (action-operation action))
8.11136- (parent-component (action-component action)))
8.11137- (cond
8.11138- ((and (typep parent-operation 'define-op)
8.11139- (typep parent-component 'system))
8.11140- (let ((action (cons operation component)))
8.11141- (unless (gethash action (definition-dependency-set parent-component))
8.11142- (push (cons operation component) (definition-dependency-list parent-component))
8.11143- (setf (gethash action (definition-dependency-set parent-component)) t))))
8.11144- (t
8.11145- (warn 'recursive-operate
8.11146- :operation operation :component component :action action)))))))
8.11147-
8.11148- (defmethod component-depends-on ((o define-op) (s system))
8.11149- `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below.
8.11150- ;; 2- We don't call-next-method to avoid other methods
8.11151- ,@(loop :for (o . c) :in (definition-dependency-list s) :collect (list o c))))
8.11152-
8.11153- (defmethod component-depends-on ((o operation) (s system))
8.11154- `(,@(when (and (not (typep o 'define-op))
8.11155- (or (system-source-file s) (definition-dependency-list s)))
8.11156- `((define-op ,(primary-system-name s))))
8.11157- ,@(call-next-method)))
8.11158-
8.11159- (defmethod perform ((o operation) (c undefined-system))
8.11160- (sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c)))
8.11161-
8.11162- ;; TODO: could this file be refactored so that locate-system is merely
8.11163- ;; the cache-priming call to input-files here?
8.11164- (defmethod input-files ((o define-op) (s system))
8.11165- (if-let ((asd (system-source-file s))) (list asd)))
8.11166-
8.11167- (defmethod perform ((o define-op) (s system))
8.11168- (nest
8.11169- (if-let ((pathname (first (input-files o s)))))
8.11170- (let ((readtable *readtable*) ;; save outer syntax tables. TODO: proper syntax-control
8.11171- (print-pprint-dispatch *print-pprint-dispatch*)))
8.11172- (with-standard-io-syntax)
8.11173- (let ((*print-readably* nil)
8.11174- ;; Note that our backward-compatible *readtable* is
8.11175- ;; a global readtable that gets globally side-effected. Ouch.
8.11176- ;; Same for the *print-pprint-dispatch* table.
8.11177- ;; We should do something about that for ASDF3 if possible, or else ASDF4.
8.11178- (*readtable* readtable) ;; restore inside syntax table
8.11179- (*print-pprint-dispatch* print-pprint-dispatch)
8.11180- (*package* (find-package :asdf-user))
8.11181- (*default-pathname-defaults*
8.11182- ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
8.11183- (pathname-directory-pathname (physicalize-pathname pathname)))))
8.11184- (handler-bind
8.11185- (((and error (not missing-component))
8.11186- #'(lambda (condition)
8.11187- (error 'load-system-definition-error
8.11188- :name (coerce-name s) :pathname pathname :condition condition))))
8.11189- (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
8.11190- (coerce-name s) pathname)
8.11191- ;; dependencies will depend on what's loaded via definition-dependency-list
8.11192- (unset-asdf-cache-entry `(component-depends-on ,o ,s))
8.11193- (unset-asdf-cache-entry `(input-files ,o ,s)))
8.11194- (load* pathname :external-format (encoding-external-format (detect-encoding pathname)))))
8.11195-
8.11196- (defun load-asd (pathname &key name)
8.11197- "Load system definitions from PATHNAME.
8.11198-NAME if supplied is the name of a system expected to be defined in that file.
8.11199-
8.11200-Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
8.11201- (with-asdf-session ()
8.11202- ;; TODO: use OPERATE, so we consult the cache and only load once per session.
8.11203- (flet ((do-it (o c) (operate o c)))
8.11204- (let ((primary-name (primary-system-name (or name (pathname-name pathname))))
8.11205- (operation (make-operation 'define-op)))
8.11206- (if-let (system (registered-system primary-name))
8.11207- (progn
8.11208- ;; We already determine this to be obsolete ---
8.11209- ;; or should we move some tests from find-system to check for up-to-date-ness here?
8.11210- (setf (component-operation-time operation system) t
8.11211- (definition-dependency-list system) nil
8.11212- (definition-dependency-set system) (list-to-hash-set nil))
8.11213- (do-it operation system))
8.11214- (let ((system (make-instance 'undefined-system
8.11215- :name primary-name :source-file pathname)))
8.11216- (register-system system)
8.11217- (unwind-protect (do-it operation system)
8.11218- (when (typep system 'undefined-system)
8.11219- (clear-system system)))))))))
8.11220-
8.11221- (defvar *old-asdf-systems* (make-hash-table :test 'equal))
8.11222-
8.11223- ;; (Private) function to check that a system that was found isn't an asdf downgrade.
8.11224- ;; Returns T if everything went right, NIL if the system was an ASDF at an older version,
8.11225- ;; or UIOP of the same or older version, that shall not be loaded.
8.11226- ;; Also issue a warning if it was a strictly older version of ASDF.
8.11227- (defun check-not-old-asdf-system (name pathname)
8.11228- (or (not (member name '("asdf" "uiop") :test 'equal))
8.11229- (null pathname)
8.11230- (let* ((asdfp (equal name "asdf")) ;; otherwise, it's uiop
8.11231- (version-pathname
8.11232- (subpathname pathname "version" :type (if asdfp "lisp-expr" "lisp")))
8.11233- (version (and (probe-file* version-pathname :truename nil)
8.11234- (read-file-form version-pathname :at (if asdfp '(0) '(2 2 2)))))
8.11235- (old-version (asdf-version)))
8.11236- (cond
8.11237- ;; Same version is OK for ASDF, to allow loading from modified source.
8.11238- ;; However, do *not* load UIOP of the exact same version:
8.11239- ;; it was already loaded it as part of ASDF and would only be double-loading.
8.11240- ;; Be quiet about it, though, since it's a normal situation.
8.11241- ((equal old-version version) asdfp)
8.11242- ((version< old-version version) t) ;; newer version: Good!
8.11243- (t ;; old version: bad
8.11244- (ensure-gethash
8.11245- (list (namestring pathname) version) *old-asdf-systems*
8.11246- #'(lambda ()
8.11247- (let ((old-pathname (system-source-file (registered-system "asdf"))))
8.11248- (if asdfp
8.11249- (warn "~@<~
8.11250- You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
8.11251- or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
8.11252- ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~
8.11253- Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~
8.11254- and having an old version registered is a configuration error. ~
8.11255- ASDF will ignore this configured system rather than downgrade itself. ~
8.11256- In the future, you may want to either: ~
8.11257- (a) upgrade this configured ASDF to a newer version, ~
8.11258- (b) install a newer ASDF and register it in front of the former in your configuration, or ~
8.11259- (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~
8.11260- Note that the older ASDF might be registered implicitly through configuration inherited ~
8.11261- from your system installation, in which case you might have to specify ~
8.11262- :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~
8.11263- or other source-registry configuration file, environment variable or lisp parameter. ~
8.11264- Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~
8.11265- that you might want to upgrade (if a recent enough version is available) ~
8.11266- or else remove altogether (since most implementations ship with a recent asdf); ~
8.11267- if you lack the system administration rights to upgrade or remove this package, ~
8.11268- then you might indeed want to either install and register a more recent version, ~
8.11269- or use :ignore-inherited-configuration to avoid registering the old one. ~
8.11270- Please consult ASDF documentation and/or experts.~@:>~%"
8.11271- old-version old-pathname version pathname)
8.11272- ;; NB: for UIOP, don't warn, just ignore.
8.11273- (warn "ASDF ~A (from ~A), UIOP ~A (from ~A)"
8.11274- old-version old-pathname version pathname)
8.11275- ))))
8.11276- nil))))) ;; only issue the warning the first time, but always return nil
8.11277-
8.11278- (defun locate-system (name)
8.11279- "Given a system NAME designator, try to locate where to load the system from.
8.11280-Returns six values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME PREVIOUS-PRIMARY
8.11281-FOUNDP is true when a system was found,
8.11282-either a new unregistered one or a previously registered one.
8.11283-FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed.
8.11284-PATHNAME when not null is a path from which to load the system,
8.11285-either associated with FOUND-SYSTEM, or with the PREVIOUS system.
8.11286-PREVIOUS when not null is a previously loaded SYSTEM object of same name.
8.11287-PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
8.11288-PREVIOUS-PRIMARY when not null is the primary system for the PREVIOUS system."
8.11289- (with-asdf-session () ;; NB: We don't cache the results. We once used to, but it wasn't useful,
8.11290- ;; and keeping a negative cache was a bug (see lp#1335323), which required
8.11291- ;; explicit invalidation in clear-system and find-system (when unsucccessful).
8.11292- (let* ((name (coerce-name name))
8.11293- (previous (registered-system name)) ; load from disk if absent or newer on disk
8.11294- (previous-primary-name (and previous (primary-system-name previous)))
8.11295- (previous-primary-system (and previous-primary-name
8.11296- (registered-system previous-primary-name)))
8.11297- (previous-time (and previous-primary-system
8.11298- (component-operation-time 'define-op previous-primary-system)))
8.11299- (found (search-for-system-definition name))
8.11300- (found-system (and (typep found 'system) found))
8.11301- (pathname (ensure-pathname
8.11302- (or (and (typep found '(or pathname string)) (pathname found))
8.11303- (system-source-file found-system)
8.11304- (system-source-file previous))
8.11305- :want-absolute t :resolve-symlinks *resolve-symlinks*))
8.11306- (foundp (and (or found-system pathname previous) t)))
8.11307- (check-type found (or null pathname system))
8.11308- (unless (check-not-old-asdf-system name pathname)
8.11309- (check-type previous system) ;; asdf is preloaded, so there should be a previous one.
8.11310- (setf found-system nil pathname nil))
8.11311- (values foundp found-system pathname previous previous-time previous-primary-system))))
8.11312-
8.11313- ;; TODO: make a prepare-define-op node for this
8.11314- ;; so we can properly cache the answer rather than recompute it.
8.11315- (defun definition-dependencies-up-to-date-p (system)
8.11316- (check-type system system)
8.11317- (or (not (primary-system-p system))
8.11318- (handler-case
8.11319- (loop :with plan = (make-instance *plan-class*)
8.11320- :for action :in (definition-dependency-list system)
8.11321- :always (action-up-to-date-p
8.11322- plan (action-operation action) (action-component action))
8.11323- :finally
8.11324- (let ((o (make-operation 'define-op)))
8.11325- (multiple-value-bind (stamp done-p)
8.11326- (compute-action-stamp plan o system)
8.11327- (return (and (timestamp<= stamp (component-operation-time o system))
8.11328- done-p)))))
8.11329- (system-out-of-date () nil))))
8.11330-
8.11331- ;; Main method for find-system: first, make sure the computation is memoized in a session cache.
8.11332- ;; Unless the system is immutable, use locate-system to find the primary system;
8.11333- ;; reconcile the finding (if any) with any previous definition (in a previous session,
8.11334- ;; preloaded, with a previous configuration, or before filesystem changes), and
8.11335- ;; load a found .asd if appropriate. Finally, update registration table and return results.
8.11336- (defmethod find-system ((name string) &optional (error-p t))
8.11337- (nest
8.11338- (with-asdf-session (:key `(find-system ,name)))
8.11339- (let ((name-primary-p (primary-system-p name)))
8.11340- (unless name-primary-p (find-system (primary-system-name name) nil)))
8.11341- (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)))
8.11342- (multiple-value-bind (foundp found-system pathname previous previous-time previous-primary)
8.11343- (locate-system name)
8.11344- (assert (eq foundp (and (or found-system pathname previous) t))))
8.11345- (let ((previous-pathname (system-source-file previous))
8.11346- (system (or previous found-system)))
8.11347- (when (and found-system (not previous))
8.11348- (register-system found-system))
8.11349- (when (and system pathname)
8.11350- (setf (system-source-file system) pathname))
8.11351- (if-let ((stamp (get-file-stamp pathname)))
8.11352- (let ((up-to-date-p
8.11353- (and previous previous-primary
8.11354- (or (pathname-equal pathname previous-pathname)
8.11355- (and pathname previous-pathname
8.11356- (pathname-equal
8.11357- (physicalize-pathname pathname)
8.11358- (physicalize-pathname previous-pathname))))
8.11359- (timestamp<= stamp previous-time)
8.11360- ;; Check that all previous definition-dependencies are up-to-date,
8.11361- ;; traversing them without triggering the adding of nodes to the plan.
8.11362- ;; TODO: actually have a prepare-define-op, extract its timestamp,
8.11363- ;; and check that it is less than the stamp of the previous define-op ?
8.11364- (definition-dependencies-up-to-date-p previous-primary))))
8.11365- (unless up-to-date-p
8.11366- (restart-case
8.11367- (signal 'system-out-of-date :name name)
8.11368- (continue () :report "continue"))
8.11369- (load-asd pathname :name name)))))
8.11370- ;; Try again after having loaded from disk if needed
8.11371- (or (registered-system name)
8.11372- (when error-p (error 'missing-component :requires name)))))
8.11373-
8.11374- ;; Resolved forward reference for asdf/system-registry.
8.11375- (defun mark-component-preloaded (component)
8.11376- "Mark a component as preloaded."
8.11377- (let ((component (find-component component nil :registered t)))
8.11378- ;; Recurse to children, so asdf/plan will hopefully be happy.
8.11379- (map () 'mark-component-preloaded (component-children component))
8.11380- ;; Mark the timestamps of the common lisp-action operations as 0.
8.11381- (let ((cot (component-operation-times component)))
8.11382- (dolist (o `(,@(when (primary-system-p component) '(define-op))
8.11383- prepare-op compile-op load-op))
8.11384- (setf (gethash (make-operation o) cot) 0))))))
8.11385-;;;; -------------------------------------------------------------------------
8.11386-;;;; Defsystem
8.11387-
8.11388-(uiop/package:define-package :asdf/parse-defsystem
8.11389- (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
8.11390- (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
8.11391- (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
8.11392- :asdf/session :asdf/component :asdf/system :asdf/system-registry
8.11393- :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
8.11394- (:import-from :asdf/system #:depends-on #:weakly-depends-on)
8.11395- ;; these needed for record-additional-system-input-file
8.11396- (:import-from :asdf/operation #:make-operation)
8.11397- (:import-from :asdf/component #:%additional-input-files)
8.11398- (:import-from :asdf/find-system #:define-op)
8.11399- (:export
8.11400- #:defsystem #:register-system-definition
8.11401- #:*default-component-class*
8.11402- #:determine-system-directory #:parse-component-form
8.11403- #:non-toplevel-system #:non-system-system #:bad-system-name
8.11404- #:*known-systems-with-bad-secondary-system-names*
8.11405- #:known-system-with-bad-secondary-system-names-p
8.11406- #:sysdef-error-component #:check-component-input
8.11407- #:explain
8.11408- ;; for extending the component types
8.11409- #:compute-component-children
8.11410- #:class-for-type))
8.11411-(in-package :asdf/parse-defsystem)
8.11412-
8.11413-;;; Pathname
8.11414-(with-upgradability ()
8.11415- (defun determine-system-directory (pathname)
8.11416- ;; The defsystem macro calls this function to determine the pathname of a system as follows:
8.11417- ;; 1. If the pathname argument is an pathname object (NOT a namestring),
8.11418- ;; that is already an absolute pathname, return it.
8.11419- ;; 2. Otherwise, the directory containing the LOAD-PATHNAME
8.11420- ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
8.11421- ;; if it is indeed available and an absolute pathname, then
8.11422- ;; the PATHNAME argument is normalized to a relative pathname
8.11423- ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
8.11424- ;; and merged into that DIRECTORY as per SUBPATHNAME.
8.11425- ;; Note: avoid *COMPILE-FILE-PATHNAME* because the .asd is loaded as source,
8.11426- ;; but may be from within the EVAL-WHEN of a file compilation.
8.11427- ;; If no absolute pathname was found, we return NIL.
8.11428- (check-type pathname (or null string pathname))
8.11429- (pathname-directory-pathname
8.11430- (resolve-symlinks*
8.11431- (ensure-absolute-pathname
8.11432- (parse-unix-namestring pathname :type :directory)
8.11433- #'(lambda () (ensure-absolute-pathname
8.11434- (load-pathname) 'get-pathname-defaults nil))
8.11435- nil)))))
8.11436-
8.11437-
8.11438-(when-upgrading (:version "3.3.4.17")
8.11439- ;; This turned into a generic function in 3.3.4.17
8.11440- (fmakunbound 'class-for-type))
8.11441-
8.11442-;;; Component class
8.11443-(with-upgradability ()
8.11444- ;; What :file gets interpreted as, unless overridden by a :default-component-class
8.11445- (defvar *default-component-class* 'cl-source-file)
8.11446-
8.11447- (defgeneric class-for-type (parent type-designator)
8.11448- (:documentation
8.11449- "Return a CLASS object to be used to instantiate components specified by TYPE-DESIGNATOR in the context of PARENT."))
8.11450-
8.11451- (defmethod class-for-type ((parent null) type)
8.11452- "If the PARENT is NIL, then TYPE must designate a subclass of SYSTEM."
8.11453- (or (coerce-class type :package :asdf/interface :super 'system :error nil)
8.11454- (sysdef-error "don't recognize component type ~S in the context of no parent" type)))
8.11455-
8.11456- (defmethod class-for-type ((parent parent-component) type)
8.11457- (or (coerce-class type :package :asdf/interface :super 'component :error nil)
8.11458- (and (eq type :file)
8.11459- (coerce-class
8.11460- (or (loop :for p = parent :then (component-parent p) :while p
8.11461- :thereis (module-default-component-class p))
8.11462- *default-component-class*)
8.11463- :package :asdf/interface :super 'component :error nil))
8.11464- (sysdef-error "don't recognize component type ~S" type))))
8.11465-
8.11466-
8.11467-;;; Check inputs
8.11468-(with-upgradability ()
8.11469- (define-condition non-system-system (system-definition-error)
8.11470- ((name :initarg :name :reader non-system-system-name)
8.11471- (class-name :initarg :class-name :reader non-system-system-class-name))
8.11472- (:report (lambda (c s)
8.11473- (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
8.11474- (non-system-system-name c) (non-system-system-class-name c) 'system))))
8.11475-
8.11476- (define-condition non-toplevel-system (system-definition-error)
8.11477- ((parent :initarg :parent :reader non-toplevel-system-parent)
8.11478- (name :initarg :name :reader non-toplevel-system-name))
8.11479- (:report (lambda (c s)
8.11480- (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
8.11481- (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
8.11482-
8.11483- (define-condition bad-system-name (warning)
8.11484- ((name :initarg :name :reader component-name)
8.11485- (source-file :initarg :source-file :reader system-source-file))
8.11486- (:report (lambda (c s)
8.11487- (let* ((file (system-source-file c))
8.11488- (name (component-name c))
8.11489- (asd (pathname-name file)))
8.11490- (format s (compatfmt "~@<System definition file ~S contains definition for system ~S. ~
8.11491-Please only define ~S and secondary systems with a name starting with ~S (e.g. ~S) in that file.~@:>")
8.11492- file name asd (strcat asd "/") (strcat asd "/test"))))))
8.11493-
8.11494- (defun sysdef-error-component (msg type name value)
8.11495- (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
8.11496- type name value))
8.11497-
8.11498- (defun check-component-input (type name weakly-depends-on
8.11499- depends-on components)
8.11500- "A partial test of the values of a component."
8.11501- (unless (listp depends-on)
8.11502- (sysdef-error-component ":depends-on must be a list."
8.11503- type name depends-on))
8.11504- (unless (listp weakly-depends-on)
8.11505- (sysdef-error-component ":weakly-depends-on must be a list."
8.11506- type name weakly-depends-on))
8.11507- (unless (listp components)
8.11508- (sysdef-error-component ":components must be NIL or a list of components."
8.11509- type name components)))
8.11510-
8.11511-
8.11512- (defun record-additional-system-input-file (pathname component parent)
8.11513- (let* ((record-on (if parent
8.11514- (loop :with retval
8.11515- :for par = parent :then (component-parent par)
8.11516- :while par
8.11517- :do (setf retval par)
8.11518- :finally (return retval))
8.11519- component))
8.11520- (comp (if (typep record-on 'component)
8.11521- record-on
8.11522- ;; at this point there will be no parent for RECORD-ON
8.11523- (find-component record-on nil)))
8.11524- (op (make-operation 'define-op))
8.11525- (cell (or (assoc op (%additional-input-files comp))
8.11526- (let ((new-cell (list op)))
8.11527- (push new-cell (%additional-input-files comp))
8.11528- new-cell))))
8.11529- (pushnew pathname (cdr cell) :test 'pathname-equal)
8.11530- (values)))
8.11531-
8.11532- ;; Given a form used as :version specification, in the context of a system definition
8.11533- ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form
8.11534- ;; to an acceptable ASDF-format version.
8.11535- (fmakunbound 'normalize-version) ;; signature changed between 2.27 and 2.31
8.11536- (defun normalize-version (form &key pathname component parent)
8.11537- (labels ((invalid (&optional (continuation "using NIL instead"))
8.11538- (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
8.11539- form component parent pathname continuation))
8.11540- (invalid-parse (control &rest args)
8.11541- (unless (if-let (target (find-component parent component)) (builtin-system-p target))
8.11542- (apply 'warn control args)
8.11543- (invalid))))
8.11544- (if-let (v (typecase form
8.11545- ((or string null) form)
8.11546- (real
8.11547- (invalid "Substituting a string")
8.11548- (format nil "~D" form)) ;; 1.0 becomes "1.0"
8.11549- (cons
8.11550- (case (first form)
8.11551- ((:read-file-form)
8.11552- (destructuring-bind (subpath &key (at 0)) (rest form)
8.11553- (let ((path (subpathname pathname subpath)))
8.11554- (record-additional-system-input-file path component parent)
8.11555- (safe-read-file-form path
8.11556- :at at :package :asdf-user))))
8.11557- ((:read-file-line)
8.11558- (destructuring-bind (subpath &key (at 0)) (rest form)
8.11559- (let ((path (subpathname pathname subpath)))
8.11560- (record-additional-system-input-file path component parent)
8.11561- (safe-read-file-line (subpathname pathname subpath)
8.11562- :at at))))
8.11563- (otherwise
8.11564- (invalid))))
8.11565- (t
8.11566- (invalid))))
8.11567- (if-let (pv (parse-version v #'invalid-parse))
8.11568- (unparse-version pv)
8.11569- (invalid))))))
8.11570-
8.11571-
8.11572-;;; "inline methods"
8.11573-(with-upgradability ()
8.11574- (defparameter* +asdf-methods+
8.11575- '(perform-with-restarts perform explain output-files operation-done-p))
8.11576-
8.11577- (defun %remove-component-inline-methods (component)
8.11578- (dolist (name +asdf-methods+)
8.11579- (map ()
8.11580- ;; this is inefficient as most of the stored
8.11581- ;; methods will not be for this particular gf
8.11582- ;; But this is hardly performance-critical
8.11583- #'(lambda (m)
8.11584- (remove-method (symbol-function name) m))
8.11585- (component-inline-methods component)))
8.11586- (component-inline-methods component) nil)
8.11587-
8.11588- (defparameter *standard-method-combination-qualifiers*
8.11589- '(:around :before :after))
8.11590-
8.11591-;;; Find inline method definitions of the form
8.11592-;;;
8.11593-;;; :perform (test-op :before (operation component) ...)
8.11594-;;;
8.11595-;;; in REST (which is the plist of all DEFSYSTEM initargs) and define the specified methods.
8.11596- (defun %define-component-inline-methods (ret rest)
8.11597- ;; find key-value pairs that look like inline method definitions in REST. For each identified
8.11598- ;; definition, parse it and, if it is well-formed, define the method.
8.11599- (loop :for (key value) :on rest :by #'cddr
8.11600- :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
8.11601- :when name :do
8.11602- ;; parse VALUE as an inline method definition of the form
8.11603- ;;
8.11604- ;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY)
8.11605- (destructuring-bind (operation-name &rest rest) value
8.11606- (let ((qualifiers '()))
8.11607- ;; ensure that OPERATION-NAME is a symbol.
8.11608- (unless (and (symbolp operation-name) (not (null operation-name)))
8.11609- (sysdef-error "Ill-formed inline method: ~S. The first element is not a symbol ~
8.11610- designating an operation but ~S."
8.11611- value operation-name))
8.11612- ;; ensure that REST starts with either a cons (potential lambda list, further checked
8.11613- ;; below) or a qualifier accepted by the standard method combination. Everything else
8.11614- ;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely
8.11615- ;; has to start with the lambda list.
8.11616- (cond
8.11617- ((consp (car rest)))
8.11618- ((not (member (car rest)
8.11619- *standard-method-combination-qualifiers*))
8.11620- (sysdef-error "Ill-formed inline method: ~S. Only a single of the standard ~
8.11621- qualifiers ~{~S~^ ~} is allowed, not ~S."
8.11622- value *standard-method-combination-qualifiers* (car rest)))
8.11623- (t
8.11624- (setf qualifiers (list (pop rest)))))
8.11625- ;; REST must start with a two-element lambda list.
8.11626- (unless (and (listp (car rest))
8.11627- (length=n-p (car rest) 2)
8.11628- (null (cddar rest)))
8.11629- (sysdef-error "Ill-formed inline method: ~S. The operation name ~S is not followed by ~
8.11630- a lambda-list of the form (OPERATION COMPONENT) and a method body."
8.11631- value operation-name))
8.11632- ;; define the method.
8.11633- (destructuring-bind ((o c) &rest body) rest
8.11634- (pushnew
8.11635- (eval `(defmethod ,name ,@qualifiers ((,o ,operation-name) (,c (eql ,ret))) ,@body))
8.11636- (component-inline-methods ret)))))))
8.11637-
8.11638- (defun %refresh-component-inline-methods (component rest)
8.11639- ;; clear methods, then add the new ones
8.11640- (%remove-component-inline-methods component)
8.11641- (%define-component-inline-methods component rest)))
8.11642-
8.11643-
8.11644-;;; Main parsing function
8.11645-(with-upgradability ()
8.11646- (defun parse-dependency-def (dd)
8.11647- (if (listp dd)
8.11648- (case (first dd)
8.11649- (:feature
8.11650- (unless (= (length dd) 3)
8.11651- (sysdef-error "Ill-formed feature dependency: ~s" dd))
8.11652- (let ((embedded (parse-dependency-def (third dd))))
8.11653- `(:feature ,(second dd) ,embedded)))
8.11654- (feature
8.11655- (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd))
8.11656- (:require
8.11657- (unless (= (length dd) 2)
8.11658- (sysdef-error "Ill-formed require dependency: ~s" dd))
8.11659- dd)
8.11660- (:version
8.11661- (unless (= (length dd) 3)
8.11662- (sysdef-error "Ill-formed version dependency: ~s" dd))
8.11663- `(:version ,(coerce-name (second dd)) ,(third dd)))
8.11664- (otherwise (sysdef-error "Ill-formed dependency: ~s" dd)))
8.11665- (coerce-name dd)))
8.11666-
8.11667- (defun parse-dependency-defs (dd-list)
8.11668- "Parse the dependency defs in DD-LIST into canonical form by translating all
8.11669-system names contained using COERCE-NAME. Return the result."
8.11670- (mapcar 'parse-dependency-def dd-list))
8.11671-
8.11672- (defgeneric compute-component-children (component components serial-p)
8.11673- (:documentation
8.11674- "Return a list of children for COMPONENT.
8.11675-
8.11676-COMPONENTS is a list of the explicitly defined children descriptions.
8.11677-
8.11678-SERIAL-P is non-NIL if each child in COMPONENTS should depend on the previous
8.11679-children."))
8.11680-
8.11681- (defun stable-union (s1 s2 &key (test #'eql) (key 'identity))
8.11682- (append s1
8.11683- (remove-if #'(lambda (e2) (member (funcall key e2) (funcall key s1) :test test)) s2)))
8.11684-
8.11685- (defun parse-component-form (parent options &key previous-serial-components)
8.11686- (destructuring-bind
8.11687- (type name &rest rest &key
8.11688- (builtin-system-p () bspp)
8.11689- ;; the following list of keywords is reproduced below in the
8.11690- ;; remove-plist-keys form. important to keep them in sync
8.11691- components pathname perform explain output-files operation-done-p
8.11692- weakly-depends-on depends-on serial
8.11693- do-first if-component-dep-fails version
8.11694- ;; list ends
8.11695- &allow-other-keys) options
8.11696- (declare (ignore perform explain output-files operation-done-p builtin-system-p))
8.11697- (check-component-input type name weakly-depends-on depends-on components)
8.11698- (when (and parent
8.11699- (find-component parent name)
8.11700- (not ;; ignore the same object when rereading the defsystem
8.11701- (typep (find-component parent name)
8.11702- (class-for-type parent type))))
8.11703- (error 'duplicate-names :name name))
8.11704- (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
8.11705- (let* ((name (coerce-name name))
8.11706- (args `(:name ,name
8.11707- :pathname ,pathname
8.11708- ,@(when parent `(:parent ,parent))
8.11709- ,@(remove-plist-keys
8.11710- '(:components :pathname :if-component-dep-fails :version
8.11711- :perform :explain :output-files :operation-done-p
8.11712- :weakly-depends-on :depends-on :serial)
8.11713- rest)))
8.11714- (component (find-component parent name))
8.11715- (class (class-for-type parent type)))
8.11716- (when (and parent (subtypep class 'system))
8.11717- (error 'non-toplevel-system :parent parent :name name))
8.11718- (if component ; preserve identity
8.11719- (apply 'reinitialize-instance component args)
8.11720- (setf component (apply 'make-instance class args)))
8.11721- (component-pathname component) ; eagerly compute the absolute pathname
8.11722- (when (typep component 'system)
8.11723- ;; cache information for introspection
8.11724- (setf (slot-value component 'depends-on)
8.11725- (parse-dependency-defs depends-on)
8.11726- (slot-value component 'weakly-depends-on)
8.11727- ;; these must be a list of systems, cannot be features or versioned systems
8.11728- (mapcar 'coerce-name weakly-depends-on)))
8.11729- (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
8.11730- (when (and (typep component 'system) (not bspp))
8.11731- (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
8.11732- (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
8.11733- ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
8.11734- ;; A better fix is required.
8.11735- (setf (slot-value component 'version) version)
8.11736- (when (typep component 'parent-component)
8.11737- (setf (component-children component) (compute-component-children component components serial))
8.11738- (compute-children-by-name component))
8.11739- (when previous-serial-components
8.11740- (setf depends-on (stable-union depends-on previous-serial-components :test #'equal)))
8.11741- (when weakly-depends-on
8.11742- ;; ASDF4: deprecate this feature and remove it.
8.11743- (appendf depends-on
8.11744- (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
8.11745- ;; Used by POIU. ASDF4: rename to component-depends-on?
8.11746- (setf (component-sideway-dependencies component) depends-on)
8.11747- (%refresh-component-inline-methods component rest)
8.11748- (when if-component-dep-fails
8.11749- (error "The system definition for ~S uses deprecated ~
8.11750- ASDF option :IF-COMPONENT-DEP-FAILS. ~
8.11751- Starting with ASDF 3, please use :IF-FEATURE instead"
8.11752- (coerce-name (component-system component))))
8.11753- component)))
8.11754-
8.11755- (defmethod compute-component-children ((component parent-component) components serial-p)
8.11756- (loop
8.11757- :with previous-components = nil ; list of strings
8.11758- :for c-form :in components
8.11759- :for c = (parse-component-form component c-form
8.11760- :previous-serial-components previous-components)
8.11761- :for name :of-type string = (component-name c)
8.11762- :when serial-p
8.11763- ;; if this is an if-feature component, we need to make a serial link
8.11764- ;; from previous components to following components -- otherwise should
8.11765- ;; the IF-FEATURE component drop out, the chain of serial dependencies will be
8.11766- ;; broken.
8.11767- :unless (component-if-feature c)
8.11768- :do (setf previous-components nil)
8.11769- :end
8.11770- :and
8.11771- :do (push name previous-components)
8.11772- :end
8.11773- :collect c))
8.11774-
8.11775- ;; the following are all systems that Stas Boukarev maintains and refuses to fix,
8.11776- ;; hoping instead to make my life miserable. Instead, I just make ASDF ignore them.
8.11777- (defparameter* *known-systems-with-bad-secondary-system-names*
8.11778- (list-to-hash-set '("cl-ppcre" "cl-interpol")))
8.11779- (defun known-system-with-bad-secondary-system-names-p (asd-name)
8.11780- ;; Does .asd file with name ASD-NAME contain known exceptions
8.11781- ;; that should be screened out of checking for BAD-SYSTEM-NAME?
8.11782- (gethash asd-name *known-systems-with-bad-secondary-system-names*))
8.11783-
8.11784- (defun register-system-definition
8.11785- (name &rest options &key pathname (class 'system) (source-file () sfp)
8.11786- defsystem-depends-on &allow-other-keys)
8.11787- ;; The system must be registered before we parse the body,
8.11788- ;; otherwise we recur when trying to find an existing system
8.11789- ;; of the same name to reuse options (e.g. pathname) from.
8.11790- ;; To avoid infinite recursion in cases where you defsystem a system
8.11791- ;; that is registered to a different location to find-system,
8.11792- ;; we also need to remember it in the asdf-cache.
8.11793- (nest
8.11794- (with-asdf-session ())
8.11795- (let* ((name (coerce-name name))
8.11796- (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))))
8.11797- (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x))))
8.11798- (let* ((asd-name (and source-file
8.11799- (equal "asd" (fix-case (pathname-type source-file)))
8.11800- (fix-case (pathname-name source-file))))
8.11801- ;; note that PRIMARY-NAME is a *syntactically* primary name
8.11802- (primary-name (primary-system-name name)))
8.11803- (when (and asd-name
8.11804- (not (equal asd-name primary-name))
8.11805- (not (known-system-with-bad-secondary-system-names-p asd-name)))
8.11806- (warn (make-condition 'bad-system-name :source-file source-file :name name))))
8.11807- (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object,
8.11808- ;; so that in case it fails, there is no incomplete object polluting the build.
8.11809- (checked-defsystem-depends-on
8.11810- (let* ((dep-forms (parse-dependency-defs defsystem-depends-on))
8.11811- (deps (loop :for spec :in dep-forms
8.11812- :when (resolve-dependency-spec nil spec)
8.11813- :collect :it)))
8.11814- (load-systems* deps)
8.11815- dep-forms))
8.11816- (system (or (find-system-if-being-defined name)
8.11817- (if-let (registered (registered-system name))
8.11818- (reset-system-class registered 'undefined-system
8.11819- :name name :source-file source-file)
8.11820- (register-system (make-instance 'undefined-system
8.11821- :name name :source-file source-file)))))
8.11822- (component-options
8.11823- (append
8.11824- (remove-plist-keys '(:defsystem-depends-on :class) options)
8.11825- ;; cache defsystem-depends-on in canonical form
8.11826- (when checked-defsystem-depends-on
8.11827- `(:defsystem-depends-on ,checked-defsystem-depends-on))))
8.11828- (directory (determine-system-directory pathname)))
8.11829- ;; This works hand in hand with asdf/find-system:find-system-if-being-defined:
8.11830- (set-asdf-cache-entry `(find-system ,name) (list system)))
8.11831- ;; We change-class AFTER we loaded the defsystem-depends-on
8.11832- ;; since the class might be defined as part of those.
8.11833- (let ((class (class-for-type nil class)))
8.11834- (unless (subtypep class 'system)
8.11835- (error 'non-system-system :name name :class-name (class-name class)))
8.11836- (unless (eq (type-of system) class)
8.11837- (reset-system-class system class)))
8.11838- (parse-component-form nil (list* :system name :pathname directory component-options))))
8.11839-
8.11840- (defmacro defsystem (name &body options)
8.11841- `(apply 'register-system-definition ',name ',options)))
8.11842-;;;; -------------------------------------------------------------------------
8.11843-;;;; ASDF-Bundle
8.11844-
8.11845-(uiop/package:define-package :asdf/bundle
8.11846- (:recycle :asdf/bundle :asdf)
8.11847- (:use :uiop/common-lisp :uiop :asdf/upgrade
8.11848- :asdf/component :asdf/system :asdf/operation
8.11849- :asdf/find-component ;; used by ECL
8.11850- :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem)
8.11851- (:export
8.11852- #:bundle-op #:bundle-type #:program-system
8.11853- #:bundle-system #:bundle-pathname-type #:direct-dependency-files
8.11854- #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
8.11855- #:basic-compile-bundle-op #:prepare-bundle-op
8.11856- #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
8.11857- #:lib-op #:monolithic-lib-op
8.11858- #:dll-op #:monolithic-dll-op
8.11859- #:deliver-asd-op #:monolithic-deliver-asd-op
8.11860- #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
8.11861- #:user-system-p #:user-system #:trivial-system-p
8.11862- #:prologue-code #:epilogue-code #:static-library))
8.11863-(in-package :asdf/bundle)
8.11864-
8.11865-(with-upgradability ()
8.11866- (defclass bundle-op (operation) ()
8.11867- (:documentation "base class for operations that bundle outputs from multiple components"))
8.11868- (defgeneric bundle-type (bundle-op))
8.11869-
8.11870- (defclass monolithic-op (operation) ()
8.11871- (:documentation "A MONOLITHIC operation operates on a system *and all of its
8.11872-dependencies*. So, for example, a monolithic concatenate operation will
8.11873-concatenate together a system's components and all of its dependencies, but a
8.11874-simple concatenate operation will concatenate only the components of the system
8.11875-itself."))
8.11876-
8.11877- (defclass monolithic-bundle-op (bundle-op monolithic-op)
8.11878- ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.
8.11879- ;; DEPRECATED. Supported replacement: Define slots on program-system instead.
8.11880- ((prologue-code :initform nil :accessor prologue-code)
8.11881- (epilogue-code :initform nil :accessor epilogue-code))
8.11882- (:documentation "operations that are both monolithic-op and bundle-op"))
8.11883-
8.11884- (defclass program-system (system)
8.11885- ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
8.11886- ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
8.11887- (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
8.11888- (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
8.11889- (prefix-lisp-object-files :initarg :prefix-lisp-object-files
8.11890- :initform nil :accessor prefix-lisp-object-files)
8.11891- (postfix-lisp-object-files :initarg :postfix-lisp-object-files
8.11892- :initform nil :accessor postfix-lisp-object-files)
8.11893- (extra-object-files :initarg :extra-object-files
8.11894- :initform nil :accessor extra-object-files)
8.11895- (extra-build-args :initarg :extra-build-args
8.11896- :initform nil :accessor extra-build-args)))
8.11897-
8.11898- (defmethod prologue-code ((x system)) nil)
8.11899- (defmethod epilogue-code ((x system)) nil)
8.11900- (defmethod no-uiop ((x system)) nil)
8.11901- (defmethod prefix-lisp-object-files ((x system)) nil)
8.11902- (defmethod postfix-lisp-object-files ((x system)) nil)
8.11903- (defmethod extra-object-files ((x system)) nil)
8.11904- (defmethod extra-build-args ((x system)) nil)
8.11905-
8.11906- (defclass link-op (bundle-op) ()
8.11907- (:documentation "Abstract operation for linking files together"))
8.11908-
8.11909- (defclass gather-operation (bundle-op) ()
8.11910- (:documentation "Abstract operation for gathering many input files from a system"))
8.11911- (defgeneric gather-operation (gather-operation))
8.11912- (defmethod gather-operation ((o gather-operation)) nil)
8.11913- (defgeneric gather-type (gather-operation))
8.11914-
8.11915- (defun operation-monolithic-p (op)
8.11916- (typep op 'monolithic-op))
8.11917-
8.11918- ;; Dependencies of a gather-op are the actions of the dependent operation
8.11919- ;; for all the (sorted) required components for loading the system.
8.11920- ;; Monolithic operations typically use lib-op as the dependent operation,
8.11921- ;; and all system-level dependencies as required components.
8.11922- ;; Non-monolithic operations typically use compile-op as the dependent operation,
8.11923- ;; and all transitive sub-components as required components (excluding other systems).
8.11924- (defmethod component-depends-on ((o gather-operation) (s system))
8.11925- (let* ((mono (operation-monolithic-p o))
8.11926- (go (make-operation (or (gather-operation o) 'compile-op)))
8.11927- (bundle-p (typep go 'bundle-op))
8.11928- ;; In a non-mono operation, don't recurse to other systems.
8.11929- ;; In a mono operation gathering bundles, don't recurse inside systems.
8.11930- (component-type (if mono (if bundle-p 'system t) '(not system)))
8.11931- ;; In the end, only keep system bundles or non-system bundles, depending.
8.11932- (keep-component (if bundle-p 'system '(not system)))
8.11933- (deps
8.11934- ;; Required-components only looks at the dependencies of an action, excluding the action
8.11935- ;; itself, so it may be safely used by an action recursing on its dependencies (which
8.11936- ;; may or may not be an overdesigned API, since in practice we never use it that way).
8.11937- ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks
8.11938- ;; cleaner, we will miss the load-op on the requested system itself, which doesn't
8.11939- ;; matter for a regular system, but matters, a lot, for a package-inferred-system.
8.11940- ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works
8.11941- ;; for our needs of gathering all the files we want to include in a bundle.
8.11942- ;; Note that we use basic-compile-op rather than compile-op so it will still work on
8.11943- ;; systems that would somehow load dependencies with load-bundle-op.
8.11944- (required-components
8.11945- s :other-systems mono :component-type component-type :keep-component keep-component
8.11946- :goal-operation 'load-op :keep-operation 'basic-compile-op)))
8.11947- `((,go ,@deps) ,@(call-next-method))))
8.11948-
8.11949- ;; Create a single fasl for the entire library
8.11950- (defclass basic-compile-bundle-op (bundle-op basic-compile-op) ()
8.11951- (:documentation "Base class for compiling into a bundle"))
8.11952- (defmethod bundle-type ((o basic-compile-bundle-op)) :fasb)
8.11953- (defmethod gather-type ((o basic-compile-bundle-op))
8.11954- #-(or clasp ecl mkcl) :fasl
8.11955- #+(or clasp ecl mkcl) :object)
8.11956-
8.11957- ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op
8.11958- (defclass prepare-bundle-op (sideway-operation)
8.11959- ((sideway-operation
8.11960- :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
8.11961- :allocation :class))
8.11962- (:documentation "Operation class for loading the bundles of a system's dependencies"))
8.11963-
8.11964- (defclass lib-op (link-op gather-operation non-propagating-operation) ()
8.11965- (:documentation "Compile the system and produce a linkable static library (.a/.lib)
8.11966-for all the linkable object files associated with the system. Compare with DLL-OP.
8.11967-
8.11968-On most implementations, these object files only include extensions to the runtime
8.11969-written in C or another language with a compiler producing linkable object files.
8.11970-On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
8.11971-themselves. In any case, this operation will produce what you need to further build
8.11972-a static runtime for your system, or a dynamic library to load in an existing runtime."))
8.11973- (defmethod bundle-type ((o lib-op)) :lib)
8.11974- (defmethod gather-type ((o lib-op)) :object)
8.11975-
8.11976- ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so;
8.11977- ;; on other implementations, we combine (usually concatenate) the .fasl files into one.
8.11978- (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation
8.11979- #+(or clasp ecl mkcl) link-op)
8.11980- ((selfward-operation :initform '(prepare-bundle-op) :allocation :class))
8.11981- (:documentation "This operator is an alternative to COMPILE-OP. Build a system
8.11982-and all of its dependencies, but build only a single (\"monolithic\") FASL, instead
8.11983-of one per source file, which may be more resource efficient. That monolithic
8.11984-FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP."))
8.11985-
8.11986- (defclass load-bundle-op (basic-load-op selfward-operation)
8.11987- ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))
8.11988- (:documentation "This operator is an alternative to LOAD-OP. Build a system
8.11989-and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with
8.11990-respect to LOAD-OP is that it builds only a single FASL, which may be
8.11991-faster and more resource efficient."))
8.11992-
8.11993- ;; NB: since the monolithic-op's can't be sideway-operation's,
8.11994- ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's,
8.11995- ;; we'd have to have the monolithic-op not inherit from the main op,
8.11996- ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above.
8.11997-
8.11998- (defclass dll-op (link-op gather-operation non-propagating-operation) ()
8.11999- (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
8.12000-for all the linkable object files associated with the system. Compare with LIB-OP."))
8.12001- (defmethod bundle-type ((o dll-op)) :dll)
8.12002- (defmethod gather-type ((o dll-op)) :object)
8.12003-
8.12004- (defclass deliver-asd-op (basic-compile-op selfward-operation)
8.12005- ((selfward-operation
8.12006- ;; TODO: implement link-op on all implementations, and make that
8.12007- ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op)
8.12008- :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op)
8.12009- :allocation :class))
8.12010- (:documentation "produce an asd file for delivering the system as a single fasl"))
8.12011-
8.12012-
8.12013- (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op)
8.12014- ((selfward-operation
8.12015- ;; TODO: implement link-op on all implementations, and make that
8.12016- ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
8.12017- :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
8.12018- :allocation :class))
8.12019- (:documentation "produce fasl and asd files for combined system and dependencies."))
8.12020-
8.12021- (defclass monolithic-compile-bundle-op
8.12022- (basic-compile-bundle-op monolithic-bundle-op
8.12023- #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
8.12024- ()
8.12025- (:documentation "Create a single fasl for the system and its dependencies."))
8.12026-
8.12027- (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op)
8.12028- ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
8.12029- (:documentation "Load a single fasl for the system and its dependencies."))
8.12030-
8.12031- (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation) ()
8.12032- (:documentation "Compile the system and produce a linkable static library (.a/.lib)
8.12033-for all the linkable object files associated with the system or its dependencies. See LIB-OP."))
8.12034-
8.12035- (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation) ()
8.12036- (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
8.12037-for all the linkable object files associated with the system or its dependencies. See LIB-OP"))
8.12038-
8.12039- (defclass image-op (monolithic-bundle-op selfward-operation
8.12040- #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
8.12041- ((selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
8.12042- (:documentation "create an image file from the system and its dependencies"))
8.12043- (defmethod bundle-type ((o image-op)) :image)
8.12044- #+(or clasp ecl mkcl) (defmethod gather-operation ((o image-op)) 'lib-op)
8.12045- #+(or clasp ecl mkcl) (defmethod gather-type ((o image-op)) :static-library)
8.12046-
8.12047- (defclass program-op (image-op) ()
8.12048- (:documentation "create an executable file from the system and its dependencies"))
8.12049- (defmethod bundle-type ((o program-op)) :program)
8.12050-
8.12051- ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.
8.12052- (defun bundle-pathname-type (bundle-type)
8.12053- (etypecase bundle-type
8.12054- ((or null string) ;; pass through nil or string literal
8.12055- bundle-type)
8.12056- ((eql :no-output-file) ;; marker for a bundle-type that has NO output file
8.12057- (error "No output file, therefore no pathname type"))
8.12058- ((eql :fasl) ;; the type of a fasl
8.12059- (compile-file-type)) ; on image-based platforms, used as input and output
8.12060- ((eql :fasb) ;; the type of a fasl
8.12061- #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output
8.12062- #+(or ecl mkcl) "fasb"
8.12063- #+clasp "fasp") ; on C-linking platforms, only used as output for system bundles
8.12064- ((member :image)
8.12065- #+allegro "dxl"
8.12066- #+(and clisp os-windows) "exe"
8.12067- #-(or allegro (and clisp os-windows)) "image")
8.12068- ;; NB: on CLASP and ECL these implementations, we better agree with
8.12069- ;; (compile-file-type :type bundle-type))
8.12070- ((eql :object) ;; the type of a linkable object file
8.12071- (os-cond ((os-unix-p)
8.12072- #+clasp "fasp" ;(core:build-extension cmp:*default-object-type*)
8.12073- #-clasp "o")
8.12074- ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj"))))
8.12075- ((member :lib :static-library) ;; the type of a linkable library
8.12076- (os-cond ((os-unix-p) "a")
8.12077- ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
8.12078- ((member :dll :shared-library) ;; the type of a shared library
8.12079- (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
8.12080- ((eql :program) ;; the type of an executable program
8.12081- (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
8.12082-
8.12083- ;; Compute the output-files for a given bundle action
8.12084- (defun bundle-output-files (o c)
8.12085- (let ((bundle-type (bundle-type o)))
8.12086- (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
8.12087- (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
8.12088- (let ((name (or (component-build-pathname c)
8.12089- (let ((suffix
8.12090- (unless (typep o 'program-op)
8.12091- ;; "." is no good separator for Logical Pathnames, so we use "--"
8.12092- (if (operation-monolithic-p o)
8.12093- "--all-systems"
8.12094- ;; These use a different type .fasb or .a instead of .fasl
8.12095- #-(or clasp ecl mkcl) "--system"))))
8.12096- (format nil "~A~@[~A~]" (coerce-filename (component-name c)) suffix))))
8.12097- (type (bundle-pathname-type bundle-type)))
8.12098- (values (list (subpathname (component-pathname c) name :type type))
8.12099- (eq (class-of o) (coerce-class (component-build-operation c)
8.12100- :package :asdf/interface
8.12101- :super 'operation
8.12102- :error nil)))))))
8.12103-
8.12104- (defmethod output-files ((o bundle-op) (c system))
8.12105- (bundle-output-files o c))
8.12106-
8.12107- #-(or clasp ecl mkcl)
8.12108- (progn
8.12109- (defmethod perform ((o image-op) (c system))
8.12110- (dump-image (output-file o c) :executable (typep o 'program-op)))
8.12111- (defmethod perform :before ((o program-op) (c system))
8.12112- (setf *image-entry-point* (ensure-function (component-entry-point c)))))
8.12113-
8.12114- (defclass compiled-file (file-component)
8.12115- ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb"))
8.12116- (:documentation "Class for a file that is already compiled,
8.12117-e.g. as part of the implementation, of an outer build system that calls into ASDF,
8.12118-or of opaque libraries shipped along the source code."))
8.12119-
8.12120- (defclass precompiled-system (system)
8.12121- ((build-pathname :initarg :fasb :initarg :fasl))
8.12122- (:documentation "Class For a system that is delivered as a precompiled fasl"))
8.12123-
8.12124- (defclass prebuilt-system (system)
8.12125- ((build-pathname :initarg :static-library :initarg :lib
8.12126- :accessor prebuilt-system-static-library))
8.12127- (:documentation "Class for a system delivered with a linkable static library (.a/.lib)")))
8.12128-
8.12129-
8.12130-;;;
8.12131-;;; BUNDLE-OP
8.12132-;;;
8.12133-;;; This operation takes all components from one or more systems and
8.12134-;;; creates a single output file, which may be
8.12135-;;; a FASL, a statically linked library, a shared library, etc.
8.12136-;;; The different targets are defined by specialization.
8.12137-;;;
8.12138-(when-upgrading (:version "3.2.0")
8.12139- ;; Cancel any previously defined method
8.12140- (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)
8.12141- (declare (ignore initargs))))
8.12142-
8.12143-(with-upgradability ()
8.12144- (defgeneric trivial-system-p (component))
8.12145-
8.12146- (defun user-system-p (s)
8.12147- (and (typep s 'system)
8.12148- (not (builtin-system-p s))
8.12149- (not (trivial-system-p s)))))
8.12150-
8.12151-(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
8.12152- (deftype user-system () '(and system (satisfies user-system-p))))
8.12153-
8.12154-;;;
8.12155-;;; First we handle monolithic bundles.
8.12156-;;; These are standalone systems which contain everything,
8.12157-;;; including other ASDF systems required by the current one.
8.12158-;;; A PROGRAM is always monolithic.
8.12159-;;;
8.12160-;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
8.12161-;;;
8.12162-(with-upgradability ()
8.12163- (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
8.12164- ;; This function selects output files from direct dependencies;
8.12165- ;; your component-depends-on method must gather the correct dependencies in the correct order.
8.12166- (while-collecting (collect)
8.12167- (map-direct-dependencies
8.12168- o c #'(lambda (sub-o sub-c)
8.12169- (loop :for f :in (funcall key sub-o sub-c)
8.12170- :when (funcall test f) :do (collect f))))))
8.12171-
8.12172- (defun pathname-type-equal-function (type)
8.12173- #'(lambda (p) (equalp (pathname-type p) type)))
8.12174-
8.12175- (defmethod input-files ((o gather-operation) (c system))
8.12176- (unless (eq (bundle-type o) :no-output-file)
8.12177- (direct-dependency-files
8.12178- o c :key 'output-files
8.12179- :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
8.12180-
8.12181- ;; Find the operation that produces a given bundle-type
8.12182- (defun select-bundle-operation (type &optional monolithic)
8.12183- (ecase type
8.12184- ((:dll :shared-library)
8.12185- (if monolithic 'monolithic-dll-op 'dll-op))
8.12186- ((:lib :static-library)
8.12187- (if monolithic 'monolithic-lib-op 'lib-op))
8.12188- ((:fasb)
8.12189- (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
8.12190- ((:image)
8.12191- 'image-op)
8.12192- ((:program)
8.12193- 'program-op))))
8.12194-
8.12195-;;;
8.12196-;;; LOAD-BUNDLE-OP
8.12197-;;;
8.12198-;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
8.12199-;;;
8.12200-(with-upgradability ()
8.12201- (defmethod component-depends-on ((o load-bundle-op) (c system))
8.12202- `((,o ,@(component-sideway-dependencies c))
8.12203- (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
8.12204- ,@(call-next-method)))
8.12205-
8.12206- (defmethod input-files ((o load-bundle-op) (c system))
8.12207- (when (user-system-p c)
8.12208- (output-files (find-operation o 'compile-bundle-op) c)))
8.12209-
8.12210- (defmethod perform ((o load-bundle-op) (c system))
8.12211- (when (input-files o c)
8.12212- (perform-lisp-load-fasl o c)))
8.12213-
8.12214- (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
8.12215- (mark-operation-done (find-operation o 'load-op) c)))
8.12216-
8.12217-;;;
8.12218-;;; PRECOMPILED FILES
8.12219-;;;
8.12220-;;; This component can be used to distribute ASDF systems in precompiled form.
8.12221-;;; Only useful when the dependencies have also been precompiled.
8.12222-;;;
8.12223-(with-upgradability ()
8.12224- (defmethod trivial-system-p ((s system))
8.12225- (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
8.12226-
8.12227- (defmethod input-files ((o operation) (c compiled-file))
8.12228- (list (component-pathname c)))
8.12229- (defmethod perform ((o load-op) (c compiled-file))
8.12230- (perform-lisp-load-fasl o c))
8.12231- (defmethod perform ((o load-source-op) (c compiled-file))
8.12232- (perform (find-operation o 'load-op) c))
8.12233- (defmethod perform ((o operation) (c compiled-file))
8.12234- nil))
8.12235-
8.12236-;;;
8.12237-;;; Pre-built systems
8.12238-;;;
8.12239-(with-upgradability ()
8.12240- (defmethod trivial-system-p ((s prebuilt-system))
8.12241- t)
8.12242-
8.12243- (defmethod perform ((o link-op) (c prebuilt-system))
8.12244- nil)
8.12245-
8.12246- (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
8.12247- nil)
8.12248-
8.12249- (defmethod perform ((o lib-op) (c prebuilt-system))
8.12250- nil)
8.12251-
8.12252- (defmethod perform ((o dll-op) (c prebuilt-system))
8.12253- nil)
8.12254-
8.12255- (defmethod component-depends-on ((o gather-operation) (c prebuilt-system))
8.12256- nil)
8.12257-
8.12258- (defmethod output-files ((o lib-op) (c prebuilt-system))
8.12259- (values (list (prebuilt-system-static-library c)) t)))
8.12260-
8.12261-
8.12262-;;;
8.12263-;;; PREBUILT SYSTEM CREATOR
8.12264-;;;
8.12265-(with-upgradability ()
8.12266- (defmethod output-files ((o deliver-asd-op) (s system))
8.12267- (list (make-pathname :name (coerce-filename (component-name s)) :type "asd"
8.12268- :defaults (component-pathname s))))
8.12269-
8.12270- ;; because of name collisions between the output files of different
8.12271- ;; subclasses of DELIVER-ASD-OP, we cannot trust the file system to
8.12272- ;; tell us if the output file is up-to-date, so just treat the
8.12273- ;; operation as never being done.
8.12274- (defmethod operation-done-p ((o deliver-asd-op) (s system))
8.12275- (declare (ignorable o s))
8.12276- nil)
8.12277-
8.12278- (defun space-for-crlf (s)
8.12279- (substitute-if #\space #'(lambda (x) (find x +crlf+)) s))
8.12280-
8.12281- (defmethod perform ((o deliver-asd-op) (s system))
8.12282- "Write an ASDF system definition for loading S as a delivered system."
8.12283- (let* ((inputs (input-files o s))
8.12284- (fasl (first inputs))
8.12285- (library (second inputs))
8.12286- (asd (output-file o s))
8.12287- (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
8.12288- (version (component-version s))
8.12289- (dependencies
8.12290- (if (operation-monolithic-p o)
8.12291- ;; We want only dependencies, and we use basic-load-op rather than load-op so that
8.12292- ;; this will keep working on systems that load dependencies with load-bundle-op
8.12293- (remove-if-not 'builtin-system-p
8.12294- (required-components s :component-type 'system
8.12295- :keep-operation 'basic-load-op))
8.12296- (while-collecting (x) ;; resolve the sideway-dependencies of s
8.12297- (map-direct-dependencies
8.12298- 'prepare-op s
8.12299- #'(lambda (o c)
8.12300- (when (and (typep o 'load-op) (typep c 'system))
8.12301- (x c)))))))
8.12302- (depends-on (mapcar 'coerce-name dependencies)))
8.12303- (when (pathname-equal asd (system-source-file s))
8.12304- (cerror "overwrite the asd file"
8.12305- "~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~
8.12306-which is probably not what you want; you probably need to tweak your output translations."
8.12307- (cons o s) asd))
8.12308- (with-open-file (s asd :direction :output :if-exists :supersede
8.12309- :if-does-not-exist :create)
8.12310- (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
8.12311- (operation-monolithic-p o) name)
8.12312- ;; this can cause bugs in cases where one of the functions returns a multi-line
8.12313- ;; string
8.12314- (let ((description-string (format nil ";;; Built for ~A ~A on a ~A/~A ~A"
8.12315- (lisp-implementation-type)
8.12316- (lisp-implementation-version)
8.12317- (software-type)
8.12318- (machine-type)
8.12319- (software-version))))
8.12320- ;; ensure the whole thing is on one line
8.12321- (println (space-for-crlf description-string) s))
8.12322- (let ((*package* (find-package :asdf-user)))
8.12323- (pprint `(defsystem ,name
8.12324- :class prebuilt-system
8.12325- :version ,version
8.12326- :depends-on ,depends-on
8.12327- :components ((:compiled-file ,(pathname-name fasl)))
8.12328- ,@(when library `(:lib ,(file-namestring library))))
8.12329- s)
8.12330- (terpri s)))))
8.12331-
8.12332- #-(or clasp ecl mkcl)
8.12333- (defmethod perform ((o basic-compile-bundle-op) (c system))
8.12334- (let* ((input-files (input-files o c))
8.12335- (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
8.12336- (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
8.12337- (output-files (output-files o c)) ; can't use OUTPUT-FILE fn because possibility it's NIL
8.12338- (output-file (first output-files)))
8.12339- (assert (eq (not input-files) (not output-files)))
8.12340- (when input-files
8.12341- (when non-fasl-files
8.12342- (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
8.12343- (implementation-type) non-fasl-files))
8.12344- (when (or (prologue-code c) (epilogue-code c))
8.12345- (error "prologue-code and epilogue-code are not supported on ~A"
8.12346- (implementation-type)))
8.12347- (with-staging-pathname (output-file)
8.12348- (combine-fasls fasl-files output-file)))))
8.12349-
8.12350- (defmethod input-files ((o load-op) (s precompiled-system))
8.12351- (bundle-output-files (find-operation o 'compile-bundle-op) s))
8.12352-
8.12353- (defmethod perform ((o load-op) (s precompiled-system))
8.12354- (perform-lisp-load-fasl o s))
8.12355-
8.12356- (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
8.12357- `((load-op ,s) ,@(call-next-method))))
8.12358-
8.12359-#| ;; Example use:
8.12360-(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
8.12361-(asdf:load-system :precompiled-asdf-utils)
8.12362-|#
8.12363-
8.12364-#+(or clasp ecl mkcl)
8.12365-(with-upgradability ()
8.12366- (defun system-module-pathname (module)
8.12367- (let ((name (coerce-name module)))
8.12368- (some
8.12369- 'file-exists-p
8.12370- (list
8.12371- #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object)
8.12372- #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib)
8.12373- #+ecl (compile-file-pathname (make-pathname :name (strcat "lib" name) :defaults "sys:") :type :lib)
8.12374- #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object)
8.12375- #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:")
8.12376- #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;")))))
8.12377-
8.12378- (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name)))
8.12379- "Creates a prebuilt-system if PATHNAME isn't NIL."
8.12380- (when pathname
8.12381- (make-instance 'prebuilt-system
8.12382- :name (coerce-name name)
8.12383- :static-library (resolve-symlinks* pathname))))
8.12384-
8.12385- (defun linkable-system (x)
8.12386- (or ;; If the system is available as source, use it.
8.12387- (if-let (s (find-system x))
8.12388- (and (output-files 'lib-op s) s))
8.12389- ;; If an ASDF upgrade is available from source, but not a UIOP upgrade to that,
8.12390- ;; then use the asdf/driver system instead of
8.12391- ;; the UIOP that was disabled by check-not-old-asdf-system.
8.12392- (if-let (s (and (equal (coerce-name x) "uiop")
8.12393- (output-files 'lib-op "asdf")
8.12394- (find-system "asdf/driver")))
8.12395- (and (output-files 'lib-op s) s))
8.12396- ;; If there was no source upgrade, look for modules provided by the implementation.
8.12397- (if-let (p (system-module-pathname (coerce-name x)))
8.12398- (make-prebuilt-system x p))))
8.12399-
8.12400- (defmethod component-depends-on :around ((o image-op) (c system))
8.12401- (let* ((next (call-next-method))
8.12402- (deps (make-hash-table :test 'equal))
8.12403- (linkable (loop :for (do . dcs) :in next :collect
8.12404- (cons do
8.12405- (loop :for dc :in dcs
8.12406- :for dep = (and dc (resolve-dependency-spec c dc))
8.12407- :when dep
8.12408- :do (setf (gethash (coerce-name (component-system dep)) deps) t)
8.12409- :collect (or (and (typep dep 'system) (linkable-system dep)) dep))))))
8.12410- `((lib-op
8.12411- ,@(unless (no-uiop c)
8.12412- (list (linkable-system "cmp")
8.12413- (unless (or (and (gethash "uiop" deps) (linkable-system "uiop"))
8.12414- (and (gethash "asdf" deps) (linkable-system "asdf")))
8.12415- (or (linkable-system "uiop")
8.12416- (linkable-system "asdf")
8.12417- "asdf")))))
8.12418- ,@linkable)))
8.12419-
8.12420- (defmethod perform ((o link-op) (c system))
8.12421- (let* ((object-files (input-files o c))
8.12422- (output (output-files o c))
8.12423- (bundle (first output))
8.12424- (programp (typep o 'program-op))
8.12425- (kind (bundle-type o)))
8.12426- (when output
8.12427- (apply 'create-image
8.12428- bundle (append
8.12429- (when programp (prefix-lisp-object-files c))
8.12430- object-files
8.12431- (when programp (postfix-lisp-object-files c)))
8.12432- :kind kind
8.12433- :prologue-code (when programp (prologue-code c))
8.12434- :epilogue-code (when programp (epilogue-code c))
8.12435- :build-args (when programp (extra-build-args c))
8.12436- :extra-object-files (when programp (extra-object-files c))
8.12437- :no-uiop (no-uiop c)
8.12438- (when programp `(:entry-point ,(component-entry-point c))))))))
8.12439-;;;; -------------------------------------------------------------------------
8.12440-;;;; Concatenate-source
8.12441-
8.12442-(uiop/package:define-package :asdf/concatenate-source
8.12443- (:recycle :asdf/concatenate-source :asdf)
8.12444- (:use :uiop/common-lisp :uiop :asdf/upgrade
8.12445- :asdf/component :asdf/operation
8.12446- :asdf/system
8.12447- :asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle)
8.12448- (:export
8.12449- #:concatenate-source-op
8.12450- #:load-concatenated-source-op
8.12451- #:compile-concatenated-source-op
8.12452- #:load-compiled-concatenated-source-op
8.12453- #:monolithic-concatenate-source-op
8.12454- #:monolithic-load-concatenated-source-op
8.12455- #:monolithic-compile-concatenated-source-op
8.12456- #:monolithic-load-compiled-concatenated-source-op))
8.12457-(in-package :asdf/concatenate-source)
8.12458-
8.12459-;;;
8.12460-;;; Concatenate sources
8.12461-;;;
8.12462-(with-upgradability ()
8.12463- ;; Base classes for both regular and monolithic concatenate-source operations
8.12464- (defclass basic-concatenate-source-op (bundle-op) ())
8.12465- (defmethod bundle-type ((o basic-concatenate-source-op)) "lisp")
8.12466- (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
8.12467- (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
8.12468- (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
8.12469-
8.12470- ;; Regular concatenate-source operations
8.12471- (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ()
8.12472- (:documentation "Operation to concatenate all sources in a system into a single file"))
8.12473- (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
8.12474- ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))
8.12475- (:documentation "Operation to load the result of concatenate-source-op as source"))
8.12476- (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
8.12477- ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))
8.12478- (:documentation "Operation to compile the result of concatenate-source-op"))
8.12479- (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
8.12480- ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class))
8.12481- (:documentation "Operation to load the result of compile-concatenated-source-op"))
8.12482-
8.12483- (defclass monolithic-concatenate-source-op
8.12484- (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ()
8.12485- (:documentation "Operation to concatenate all sources in a system and its dependencies
8.12486-into a single file"))
8.12487- (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
8.12488- ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))
8.12489- (:documentation "Operation to load the result of monolithic-concatenate-source-op as source"))
8.12490- (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
8.12491- ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))
8.12492- (:documentation "Operation to compile the result of monolithic-concatenate-source-op"))
8.12493- (defclass monolithic-load-compiled-concatenated-source-op
8.12494- (basic-load-compiled-concatenated-source-op)
8.12495- ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class))
8.12496- (:documentation "Operation to load the result of monolithic-compile-concatenated-source-op"))
8.12497-
8.12498- (defmethod input-files ((operation basic-concatenate-source-op) (s system))
8.12499- (loop :with encoding = (or (component-encoding s) *default-encoding*)
8.12500- :with other-encodings = '()
8.12501- :with around-compile = (around-compile-hook s)
8.12502- :with other-around-compile = '()
8.12503- :for c :in (required-components ;; see note about similar call to required-components
8.12504- s :goal-operation 'load-op ;; in bundle.lisp
8.12505- :keep-operation 'basic-compile-op
8.12506- :other-systems (operation-monolithic-p operation))
8.12507- :append
8.12508- (when (typep c 'cl-source-file)
8.12509- (let ((e (component-encoding c)))
8.12510- (unless (or (equal e encoding)
8.12511- (and (equal e :ASCII) (equal encoding :UTF-8)))
8.12512- (let ((a (assoc e other-encodings)))
8.12513- (if a (push (component-find-path c) (cdr a))
8.12514- (push (list e (component-find-path c)) other-encodings)))))
8.12515- (unless (equal around-compile (around-compile-hook c))
8.12516- (push (component-find-path c) other-around-compile))
8.12517- (input-files (make-operation 'compile-op) c)) :into inputs
8.12518- :finally
8.12519- (when other-encodings
8.12520- (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}"
8.12521- operation encoding
8.12522- (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x)))))
8.12523- other-encodings)))
8.12524- (when other-around-compile
8.12525- (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
8.12526- operation around-compile other-around-compile))
8.12527- (return inputs)))
8.12528- (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
8.12529- (lisp-compilation-output-files o s))
8.12530-
8.12531- (defmethod perform ((o basic-concatenate-source-op) (s system))
8.12532- (let* ((ins (input-files o s))
8.12533- (out (output-file o s))
8.12534- (tmp (tmpize-pathname out)))
8.12535- (concatenate-files ins tmp)
8.12536- (rename-file-overwriting-target tmp out)))
8.12537- (defmethod perform ((o basic-load-concatenated-source-op) (s system))
8.12538- (perform-lisp-load-source o s))
8.12539- (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
8.12540- (perform-lisp-compilation o s))
8.12541- (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
8.12542- (perform-lisp-load-fasl o s)))
8.12543-
8.12544-;;;; -------------------------------------------------------------------------
8.12545-;;;; Package systems in the style of quick-build or faslpath
8.12546-
8.12547-(uiop:define-package :asdf/package-inferred-system
8.12548- (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
8.12549- (:use :uiop/common-lisp :uiop
8.12550- :asdf/upgrade :asdf/session
8.12551- :asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action
8.12552- :asdf/parse-defsystem)
8.12553- (:export
8.12554- #:package-inferred-system #:sysdef-package-inferred-system-search
8.12555- #:package-system ;; backward compatibility only. To be removed.
8.12556- #:register-system-packages
8.12557- #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
8.12558-(in-package :asdf/package-inferred-system)
8.12559-
8.12560-(with-upgradability ()
8.12561- ;; The names of the recognized defpackage forms.
8.12562- (defparameter *defpackage-forms* '(defpackage define-package))
8.12563-
8.12564- (defun initial-package-inferred-systems-table ()
8.12565- ;; Mark all existing packages are preloaded.
8.12566- (let ((h (make-hash-table :test 'equal)))
8.12567- (dolist (p (list-all-packages))
8.12568- (dolist (n (package-names p))
8.12569- (setf (gethash n h) t)))
8.12570- h))
8.12571-
8.12572- ;; Mapping from package names to systems that provide them.
8.12573- (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
8.12574-
8.12575- (defclass package-inferred-system (system)
8.12576- ()
8.12577- (:documentation "Class for primary systems for which secondary systems are automatically
8.12578-in the one-file, one-file, one-system style: system names are mapped to files under the primary
8.12579-system's system-source-directory, dependencies are inferred from the first defpackage form in
8.12580-every such file"))
8.12581-
8.12582- ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release:
8.12583- (defclass package-system (package-inferred-system) ())
8.12584-
8.12585- ;; Is a given form recognizable as a defpackage form?
8.12586- (defun defpackage-form-p (form)
8.12587- (and (consp form)
8.12588- (member (car form) *defpackage-forms*)))
8.12589-
8.12590- ;; Find the first defpackage form in a stream, if any
8.12591- (defun stream-defpackage-form (stream)
8.12592- (loop :for form = (read stream nil nil) :while form
8.12593- :when (defpackage-form-p form) :return form))
8.12594-
8.12595- (defun file-defpackage-form (file)
8.12596- "Return the first DEFPACKAGE form in FILE."
8.12597- (with-input-file (f file)
8.12598- (stream-defpackage-form f)))
8.12599-
8.12600- (define-condition package-inferred-system-missing-package-error (system-definition-error)
8.12601- ((system :initarg :system :reader error-system)
8.12602- (pathname :initarg :pathname :reader error-pathname))
8.12603- (:report (lambda (c s)
8.12604- (format s (compatfmt "~@<No package form found while ~
8.12605- trying to define package-inferred-system ~A from file ~A~>")
8.12606- (error-system c) (error-pathname c)))))
8.12607-
8.12608- (defun package-dependencies (defpackage-form)
8.12609- "Return a list of packages depended on by the package
8.12610-defined in DEFPACKAGE-FORM. A package is depended upon if
8.12611-the DEFPACKAGE-FORM uses it or imports a symbol from it."
8.12612- (assert (defpackage-form-p defpackage-form))
8.12613- (remove-duplicates
8.12614- (while-collecting (dep)
8.12615- (loop :for (option . arguments) :in (cddr defpackage-form) :do
8.12616- (ecase option
8.12617- ((:use :mix :reexport :use-reexport :mix-reexport)
8.12618- (dolist (p arguments) (dep (string p))))
8.12619- ((:import-from :shadowing-import-from)
8.12620- (dep (string (first arguments))))
8.12621- #+package-local-nicknames
8.12622- ((:local-nicknames)
8.12623- (loop :for (nil actual-package-name) :in arguments :do
8.12624- (dep (string actual-package-name))))
8.12625- ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
8.12626- :from-end t :test 'equal))
8.12627-
8.12628- (defun package-designator-name (package)
8.12629- "Normalize a package designator to a string"
8.12630- (etypecase package
8.12631- (package (package-name package))
8.12632- (string package)
8.12633- (symbol (string package))))
8.12634-
8.12635- (defun register-system-packages (system packages)
8.12636- "Register SYSTEM as providing PACKAGES."
8.12637- (let ((name (or (eq system t) (coerce-name system))))
8.12638- (dolist (p (ensure-list packages))
8.12639- (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
8.12640-
8.12641- (defun package-name-system (package-name)
8.12642- "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
8.12643-otherwise return a default system name computed from PACKAGE-NAME."
8.12644- (check-type package-name string)
8.12645- (or (gethash package-name *package-inferred-systems*)
8.12646- (string-downcase package-name)))
8.12647-
8.12648- ;; Given a file in package-inferred-system style, find its dependencies
8.12649- (defun package-inferred-system-file-dependencies (file &optional system)
8.12650- (if-let (defpackage-form (file-defpackage-form file))
8.12651- (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
8.12652- (error 'package-inferred-system-missing-package-error :system system :pathname file)))
8.12653-
8.12654- ;; Given package-inferred-system object, check whether its specification matches
8.12655- ;; the provided parameters
8.12656- (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies)
8.12657- (and (eq (type-of system) 'package-inferred-system)
8.12658- (equal (component-name system) name)
8.12659- (pathname-equal directory (component-pathname system))
8.12660- (equal dependencies (component-sideway-dependencies system))
8.12661- (equal around-compile (around-compile-hook system))
8.12662- (let ((children (component-children system)))
8.12663- (and (length=n-p children 1)
8.12664- (let ((child (first children)))
8.12665- (and (eq (type-of child) 'cl-source-file)
8.12666- (equal (component-name child) "lisp")
8.12667- (and (slot-boundp child 'relative-pathname)
8.12668- (equal (slot-value child 'relative-pathname) subpath))))))))
8.12669-
8.12670- ;; sysdef search function to push into *system-definition-search-functions*
8.12671- (defun sysdef-package-inferred-system-search (system-name)
8.12672- "Takes SYSTEM-NAME and returns an initialized SYSTEM object, or NIL. Made to be added to
8.12673-*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*."
8.12674- (let ((primary (primary-system-name system-name)))
8.12675- ;; this function ONLY does something if the primary system name is NOT the same as
8.12676- ;; SYSTEM-NAME. It is used to find the systems with names that are relative to
8.12677- ;; the primary system's name, and that are not explicitly specified in the system
8.12678- ;; definition
8.12679- (unless (equal primary system-name)
8.12680- (let ((top (find-system primary nil)))
8.12681- (when (typep top 'package-inferred-system)
8.12682- (if-let (dir (component-pathname top))
8.12683- (let* ((sub (subseq system-name (1+ (length primary))))
8.12684- (component-type (class-for-type top :file))
8.12685- (file-type (file-type (make-instance component-type)))
8.12686- (f (probe-file* (subpathname dir sub :type file-type)
8.12687- :truename *resolve-symlinks*)))
8.12688- (when (file-pathname-p f)
8.12689- (let ((dependencies (package-inferred-system-file-dependencies f system-name))
8.12690- (previous (registered-system system-name))
8.12691- (around-compile (around-compile-hook top)))
8.12692- (if (same-package-inferred-system-p previous system-name dir sub around-compile dependencies)
8.12693- previous
8.12694- (eval `(defsystem ,system-name
8.12695- :class package-inferred-system
8.12696- :default-component-class ,component-type
8.12697- :source-file ,(system-source-file top)
8.12698- :pathname ,dir
8.12699- :depends-on ,dependencies
8.12700- :around-compile ,around-compile
8.12701- :components ((,component-type file-type :pathname ,sub)))))))))))))))
8.12702-
8.12703-(with-upgradability ()
8.12704- (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
8.12705- (setf *system-definition-search-functions*
8.12706- (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
8.12707- *system-definition-search-functions*)))
8.12708-;;;; ---------------------------------------------------------------------------
8.12709-;;;; asdf-output-translations
8.12710-
8.12711-(uiop/package:define-package :asdf/output-translations
8.12712- (:recycle :asdf/output-translations :asdf)
8.12713- (:use :uiop/common-lisp :uiop :asdf/upgrade)
8.12714- (:export
8.12715- #:*output-translations* #:*output-translations-parameter*
8.12716- #:invalid-output-translation
8.12717- #:output-translations #:output-translations-initialized-p
8.12718- #:initialize-output-translations #:clear-output-translations
8.12719- #:disable-output-translations #:ensure-output-translations
8.12720- #:apply-output-translations
8.12721- #:validate-output-translations-directive #:validate-output-translations-form
8.12722- #:validate-output-translations-file #:validate-output-translations-directory
8.12723- #:parse-output-translations-string #:wrapping-output-translations
8.12724- #:user-output-translations-pathname #:system-output-translations-pathname
8.12725- #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
8.12726- #:environment-output-translations #:process-output-translations
8.12727- #:compute-output-translations
8.12728- #+abcl #:translate-jar-pathname
8.12729- ))
8.12730-(in-package :asdf/output-translations)
8.12731-
8.12732-;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro
8.12733-;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us.
8.12734-(when-upgrading (:version "3.1.2") (fmakunbound '(setf output-translations)))
8.12735-
8.12736-(with-upgradability ()
8.12737- (define-condition invalid-output-translation (invalid-configuration warning)
8.12738- ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
8.12739-
8.12740- (defvar *output-translations* ()
8.12741- "Either NIL (for uninitialized), or a list of one element,
8.12742-said element itself being a sorted list of mappings.
8.12743-Each mapping is a pair of a source pathname and destination pathname,
8.12744-and the order is by decreasing length of namestring of the source pathname.")
8.12745-
8.12746- (defun output-translations ()
8.12747- "Return the configured output-translations, if any"
8.12748- (car *output-translations*))
8.12749-
8.12750- ;; Set the output-translations, by sorting the provided new-value.
8.12751- (defun set-output-translations (new-value)
8.12752- (setf *output-translations*
8.12753- (list
8.12754- (stable-sort (copy-list new-value) #'>
8.12755- :key #'(lambda (x)
8.12756- (etypecase (car x)
8.12757- ((eql t) -1)
8.12758- (pathname
8.12759- (let ((directory
8.12760- (normalize-pathname-directory-component
8.12761- (pathname-directory (car x)))))
8.12762- (if (listp directory) (length directory) 0))))))))
8.12763- new-value)
8.12764- (defun (setf output-translations) (new-value) (set-output-translations new-value))
8.12765-
8.12766- (defun output-translations-initialized-p ()
8.12767- "Have the output-translations been initialized yet?"
8.12768- (and *output-translations* t))
8.12769-
8.12770- (defun clear-output-translations ()
8.12771- "Undoes any initialization of the output translations."
8.12772- (setf *output-translations* '())
8.12773- (values))
8.12774- (register-clear-configuration-hook 'clear-output-translations)
8.12775-
8.12776-
8.12777- ;;; Validation of the configuration directives...
8.12778-
8.12779- (defun validate-output-translations-directive (directive)
8.12780- (or (member directive '(:enable-user-cache :disable-cache nil))
8.12781- (and (consp directive)
8.12782- (or (and (length=n-p directive 2)
8.12783- (or (and (eq (first directive) :include)
8.12784- (typep (second directive) '(or string pathname null)))
8.12785- (and (location-designator-p (first directive))
8.12786- (or (location-designator-p (second directive))
8.12787- (location-function-p (second directive))))))
8.12788- (and (length=n-p directive 1)
8.12789- (location-designator-p (first directive)))))))
8.12790-
8.12791- (defun validate-output-translations-form (form &key location)
8.12792- (validate-configuration-form
8.12793- form
8.12794- :output-translations
8.12795- 'validate-output-translations-directive
8.12796- :location location :invalid-form-reporter 'invalid-output-translation))
8.12797-
8.12798- (defun validate-output-translations-file (file)
8.12799- (validate-configuration-file
8.12800- file 'validate-output-translations-form :description "output translations"))
8.12801-
8.12802- (defun validate-output-translations-directory (directory)
8.12803- (validate-configuration-directory
8.12804- directory :output-translations 'validate-output-translations-directive
8.12805- :invalid-form-reporter 'invalid-output-translation))
8.12806-
8.12807-
8.12808- ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents
8.12809- (defun parse-output-translations-string (string &key location)
8.12810- (cond
8.12811- ((or (null string) (equal string ""))
8.12812- '(:output-translations :inherit-configuration))
8.12813- ((not (stringp string))
8.12814- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
8.12815- ((eql (char string 0) #\")
8.12816- (parse-output-translations-string (read-from-string string) :location location))
8.12817- ((eql (char string 0) #\()
8.12818- (validate-output-translations-form (read-from-string string) :location location))
8.12819- (t
8.12820- (loop
8.12821- :with inherit = nil
8.12822- :with directives = ()
8.12823- :with start = 0
8.12824- :with end = (length string)
8.12825- :with source = nil
8.12826- :with separator = (inter-directory-separator)
8.12827- :for i = (or (position separator string :start start) end) :do
8.12828- (let ((s (subseq string start i)))
8.12829- (cond
8.12830- (source
8.12831- (push (list source (if (equal "" s) nil s)) directives)
8.12832- (setf source nil))
8.12833- ((equal "" s)
8.12834- (when inherit
8.12835- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
8.12836- string))
8.12837- (setf inherit t)
8.12838- (push :inherit-configuration directives))
8.12839- (t
8.12840- (setf source s)))
8.12841- (setf start (1+ i))
8.12842- (when (> start end)
8.12843- (when source
8.12844- (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
8.12845- string))
8.12846- (unless inherit
8.12847- (push :ignore-inherited-configuration directives))
8.12848- (return `(:output-translations ,@(nreverse directives)))))))))
8.12849-
8.12850-
8.12851- ;; The default sources of configuration for output-translations
8.12852- (defparameter* *default-output-translations*
8.12853- '(environment-output-translations
8.12854- user-output-translations-pathname
8.12855- user-output-translations-directory-pathname
8.12856- system-output-translations-pathname
8.12857- system-output-translations-directory-pathname))
8.12858-
8.12859- ;; Compulsory implementation-dependent wrapping for the translations:
8.12860- ;; handle implementation-provided systems.
8.12861- (defun wrapping-output-translations ()
8.12862- `(:output-translations
8.12863- ;; Some implementations have precompiled ASDF systems,
8.12864- ;; so we must disable translations for implementation paths.
8.12865- #+(or clasp #|clozure|# ecl mkcl sbcl)
8.12866- ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
8.12867- (when h `(((,h ,*wild-path*) ()))))
8.12868- #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
8.12869- ;; All-import, here is where we want user stuff to be:
8.12870- :inherit-configuration
8.12871- ;; These are for convenience, and can be overridden by the user:
8.12872- #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
8.12873- #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
8.12874- ;; We enable the user cache by default, and here is the place we do:
8.12875- :enable-user-cache))
8.12876-
8.12877- ;; Relative pathnames of output-translations configuration to XDG configuration directory
8.12878- (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
8.12879- (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
8.12880-
8.12881- ;; Locating various configuration pathnames, depending on input or output intent.
8.12882- (defun user-output-translations-pathname (&key (direction :input))
8.12883- (xdg-config-pathname *output-translations-file* direction))
8.12884- (defun system-output-translations-pathname (&key (direction :input))
8.12885- (find-preferred-file (system-config-pathnames *output-translations-file*)
8.12886- :direction direction))
8.12887- (defun user-output-translations-directory-pathname (&key (direction :input))
8.12888- (xdg-config-pathname *output-translations-directory* direction))
8.12889- (defun system-output-translations-directory-pathname (&key (direction :input))
8.12890- (find-preferred-file (system-config-pathnames *output-translations-directory*)
8.12891- :direction direction))
8.12892- (defun environment-output-translations ()
8.12893- (getenv "ASDF_OUTPUT_TRANSLATIONS"))
8.12894-
8.12895-
8.12896- ;;; Processing the configuration.
8.12897-
8.12898- (defgeneric process-output-translations (spec &key inherit collect))
8.12899-
8.12900- (defun inherit-output-translations (inherit &key collect)
8.12901- (when inherit
8.12902- (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
8.12903-
8.12904- (defun process-output-translations-directive (directive &key inherit collect)
8.12905- (if (atom directive)
8.12906- (ecase directive
8.12907- ((:enable-user-cache)
8.12908- (process-output-translations-directive '(t :user-cache) :collect collect))
8.12909- ((:disable-cache)
8.12910- (process-output-translations-directive '(t t) :collect collect))
8.12911- ((:inherit-configuration)
8.12912- (inherit-output-translations inherit :collect collect))
8.12913- ((:ignore-inherited-configuration :ignore-invalid-entries nil)
8.12914- nil))
8.12915- (let ((src (first directive))
8.12916- (dst (second directive)))
8.12917- (if (eq src :include)
8.12918- (when dst
8.12919- (process-output-translations (pathname dst) :inherit nil :collect collect))
8.12920- (when src
8.12921- (let ((trusrc (or (eql src t)
8.12922- (let ((loc (resolve-location src :ensure-directory t :wilden t)))
8.12923- (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
8.12924- (cond
8.12925- ((location-function-p dst)
8.12926- (funcall collect
8.12927- (list trusrc (ensure-function (second dst)))))
8.12928- ((typep dst 'boolean)
8.12929- (funcall collect (list trusrc t)))
8.12930- (t
8.12931- (let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
8.12932- (funcall collect (list trudst t))
8.12933- (funcall collect (list trusrc trudst)))))))))))
8.12934-
8.12935- (defmethod process-output-translations ((x symbol) &key
8.12936- (inherit *default-output-translations*)
8.12937- collect)
8.12938- (process-output-translations (funcall x) :inherit inherit :collect collect))
8.12939- (defmethod process-output-translations ((pathname pathname) &key inherit collect)
8.12940- (cond
8.12941- ((directory-pathname-p pathname)
8.12942- (process-output-translations (validate-output-translations-directory pathname)
8.12943- :inherit inherit :collect collect))
8.12944- ((probe-file* pathname :truename *resolve-symlinks*)
8.12945- (process-output-translations (validate-output-translations-file pathname)
8.12946- :inherit inherit :collect collect))
8.12947- (t
8.12948- (inherit-output-translations inherit :collect collect))))
8.12949- (defmethod process-output-translations ((string string) &key inherit collect)
8.12950- (process-output-translations (parse-output-translations-string string)
8.12951- :inherit inherit :collect collect))
8.12952- (defmethod process-output-translations ((x null) &key inherit collect)
8.12953- (inherit-output-translations inherit :collect collect))
8.12954- (defmethod process-output-translations ((form cons) &key inherit collect)
8.12955- (dolist (directive (cdr (validate-output-translations-form form)))
8.12956- (process-output-translations-directive directive :inherit inherit :collect collect)))
8.12957-
8.12958-
8.12959- ;;; Top-level entry-points to configure output-translations
8.12960-
8.12961- (defun compute-output-translations (&optional parameter)
8.12962- "read the configuration, return it"
8.12963- (remove-duplicates
8.12964- (while-collecting (c)
8.12965- (inherit-output-translations
8.12966- `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
8.12967- :test 'equal :from-end t))
8.12968-
8.12969- ;; Saving the user-provided parameter to output-translations, if any,
8.12970- ;; so we can recompute the translations after code upgrade.
8.12971- (defvar *output-translations-parameter* nil)
8.12972-
8.12973- ;; Main entry-point for users.
8.12974- (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
8.12975- "read the configuration, initialize the internal configuration variable,
8.12976-return the configuration"
8.12977- (setf *output-translations-parameter* parameter
8.12978- (output-translations) (compute-output-translations parameter)))
8.12979-
8.12980- (defun disable-output-translations ()
8.12981- "Initialize output translations in a way that maps every file to itself,
8.12982-effectively disabling the output translation facility."
8.12983- (initialize-output-translations
8.12984- '(:output-translations :disable-cache :ignore-inherited-configuration)))
8.12985-
8.12986- ;; checks an initial variable to see whether the state is initialized
8.12987- ;; or cleared. In the former case, return current configuration; in
8.12988- ;; the latter, initialize. ASDF will call this function at the start
8.12989- ;; of (asdf:find-system).
8.12990- (defun ensure-output-translations ()
8.12991- (if (output-translations-initialized-p)
8.12992- (output-translations)
8.12993- (initialize-output-translations)))
8.12994-
8.12995-
8.12996- ;; Top-level entry-point to _use_ output-translations
8.12997- (defun apply-output-translations (path)
8.12998- (etypecase path
8.12999- (logical-pathname
8.13000- path)
8.13001- ((or pathname string)
8.13002- (ensure-output-translations)
8.13003- (loop :with p = (resolve-symlinks* path)
8.13004- :for (source destination) :in (car *output-translations*)
8.13005- :for root = (when (or (eq source t)
8.13006- (and (pathnamep source)
8.13007- (not (absolute-pathname-p source))))
8.13008- (pathname-root p))
8.13009- :for absolute-source = (cond
8.13010- ((eq source t) (wilden root))
8.13011- (root (merge-pathnames* source root))
8.13012- (t source))
8.13013- :when (or (eq source t) (pathname-match-p p absolute-source))
8.13014- :return (translate-pathname* p absolute-source destination root source)
8.13015- :finally (return p)))))
8.13016-
8.13017-
8.13018- ;; Hook into uiop's output-translation mechanism
8.13019- #-cormanlisp
8.13020- (setf *output-translation-function* 'apply-output-translations)
8.13021-
8.13022-
8.13023- ;;; Implementation-dependent hacks
8.13024- #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar.
8.13025- (defun translate-jar-pathname (source wildcard)
8.13026- (declare (ignore wildcard))
8.13027- (flet ((normalize-device (pathname)
8.13028- (if (find :windows *features*)
8.13029- pathname
8.13030- (make-pathname :defaults pathname :device :unspecific))))
8.13031- (let* ((jar
8.13032- (pathname (first (pathname-device source))))
8.13033- (target-root-directory-namestring
8.13034- (format nil "/___jar___file___root___/~@[~A/~]"
8.13035- (and (find :windows *features*)
8.13036- (pathname-device jar))))
8.13037- (relative-source
8.13038- (relativize-pathname-directory source))
8.13039- (relative-jar
8.13040- (relativize-pathname-directory (ensure-directory-pathname jar)))
8.13041- (target-root-directory
8.13042- (normalize-device
8.13043- (pathname-directory-pathname
8.13044- (parse-namestring target-root-directory-namestring))))
8.13045- (target-root
8.13046- (merge-pathnames* relative-jar target-root-directory))
8.13047- (target
8.13048- (merge-pathnames* relative-source target-root)))
8.13049- (normalize-device (apply-output-translations target))))))
8.13050-
8.13051-;;;; -----------------------------------------------------------------
8.13052-;;;; Source Registry Configuration, by Francois-Rene Rideau
8.13053-;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
8.13054-
8.13055-(uiop/package:define-package :asdf/source-registry
8.13056- ;; NB: asdf/find-system allows upgrade from <=3.2.1 that have initialize-source-registry there
8.13057- (:recycle :asdf/source-registry :asdf/find-system :asdf)
8.13058- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/system-registry)
8.13059- (:export
8.13060- #:*source-registry-parameter* #:*default-source-registries*
8.13061- #:invalid-source-registry
8.13062- #:source-registry-initialized-p
8.13063- #:initialize-source-registry #:clear-source-registry #:*source-registry*
8.13064- #:ensure-source-registry #:*source-registry-parameter*
8.13065- #:*default-source-registry-exclusions* #:*source-registry-exclusions*
8.13066- #:*wild-asd* #:directory-asd-files #:register-asd-directory
8.13067- #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files
8.13068- #:validate-source-registry-directive #:validate-source-registry-form
8.13069- #:validate-source-registry-file #:validate-source-registry-directory
8.13070- #:parse-source-registry-string #:wrapping-source-registry
8.13071- #:default-user-source-registry #:default-system-source-registry
8.13072- #:user-source-registry #:system-source-registry
8.13073- #:user-source-registry-directory #:system-source-registry-directory
8.13074- #:environment-source-registry #:process-source-registry #:inherit-source-registry
8.13075- #:compute-source-registry #:flatten-source-registry
8.13076- #:sysdef-source-registry-search))
8.13077-(in-package :asdf/source-registry)
8.13078-
8.13079-(with-upgradability ()
8.13080- (define-condition invalid-source-registry (invalid-configuration warning)
8.13081- ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
8.13082-
8.13083- ;; Default list of directories under which the source-registry tree search won't recurse
8.13084- (defvar *default-source-registry-exclusions*
8.13085- '(;;-- Using ack 1.2 exclusions
8.13086- ".bzr" ".cdv"
8.13087- ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
8.13088- ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
8.13089- "_sgbak" "autom4te.cache" "cover_db" "_build"
8.13090- ;;-- debian often builds stuff under the debian directory... BAD.
8.13091- "debian"))
8.13092-
8.13093- ;; Actual list of directories under which the source-registry tree search won't recurse
8.13094- (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
8.13095-
8.13096- ;; The state of the source-registry after search in configured locations
8.13097- (defvar *source-registry* nil
8.13098- "Either NIL (for uninitialized), or an equal hash-table, mapping
8.13099-system names to pathnames of .asd files")
8.13100-
8.13101- ;; Saving the user-provided parameter to the source-registry, if any,
8.13102- ;; so we can recompute the source-registry after code upgrade.
8.13103- (defvar *source-registry-parameter* nil)
8.13104-
8.13105- (defun source-registry-initialized-p ()
8.13106- (typep *source-registry* 'hash-table))
8.13107-
8.13108- (defun clear-source-registry ()
8.13109- "Undoes any initialization of the source registry."
8.13110- (setf *source-registry* nil)
8.13111- (values))
8.13112- (register-clear-configuration-hook 'clear-source-registry)
8.13113-
8.13114- (defparameter *wild-asd*
8.13115- (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
8.13116-
8.13117- (defun directory-asd-files (directory)
8.13118- (directory-files directory *wild-asd*))
8.13119-
8.13120- (defun collect-asds-in-directory (directory collect)
8.13121- (let ((asds (directory-asd-files directory)))
8.13122- (map () collect asds)
8.13123- asds))
8.13124-
8.13125- (defvar *recurse-beyond-asds* t
8.13126- "Should :tree entries of the source-registry recurse in subdirectories
8.13127-after having found a .asd file? True by default.")
8.13128-
8.13129- ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache,
8.13130- ;; read its contents instead of further recursively querying the filesystem.
8.13131- (defun process-source-registry-cache (directory collect)
8.13132- (let ((cache (ignore-errors
8.13133- (safe-read-file-form (subpathname directory ".cl-source-registry.cache")))))
8.13134- (when (and (listp cache) (eq :source-registry-cache (first cache)))
8.13135- (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s)))
8.13136- t)))
8.13137-
8.13138- (defun collect-sub*directories-asd-files
8.13139- (directory &key (exclude *default-source-registry-exclusions*) collect
8.13140- (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache)
8.13141- (let ((visited (make-hash-table :test 'equalp)))
8.13142- (flet ((collectp (dir)
8.13143- (unless (and (not ignore-cache) (process-source-registry-cache dir collect))
8.13144- (let ((asds (collect-asds-in-directory dir collect)))
8.13145- (or recurse-beyond-asds (not asds)))))
8.13146- (recursep (x) ; x will be a directory pathname
8.13147- (and
8.13148- (not (member (car (last (pathname-directory x))) exclude :test #'equal))
8.13149- (flet ((pathname-key (x)
8.13150- (namestring (truename* x))))
8.13151- (let ((visitedp (gethash (pathname-key x) visited)))
8.13152- (if visitedp nil
8.13153- (setf (gethash (pathname-key x) visited) t)))))))
8.13154- (collect-sub*directories directory #'collectp #'recursep (constantly nil)))))
8.13155-
8.13156-
8.13157- ;;; Validate the configuration forms
8.13158-
8.13159- (defun validate-source-registry-directive (directive)
8.13160- (or (member directive '(:default-registry))
8.13161- (and (consp directive)
8.13162- (let ((rest (rest directive)))
8.13163- (case (first directive)
8.13164- ((:include :directory :tree)
8.13165- (and (length=n-p rest 1)
8.13166- (location-designator-p (first rest))))
8.13167- ((:exclude :also-exclude)
8.13168- (every #'stringp rest))
8.13169- ((:default-registry)
8.13170- (null rest)))))))
8.13171-
8.13172- (defun validate-source-registry-form (form &key location)
8.13173- (validate-configuration-form
8.13174- form :source-registry 'validate-source-registry-directive
8.13175- :location location :invalid-form-reporter 'invalid-source-registry))
8.13176-
8.13177- (defun validate-source-registry-file (file)
8.13178- (validate-configuration-file
8.13179- file 'validate-source-registry-form :description "a source registry"))
8.13180-
8.13181- (defun validate-source-registry-directory (directory)
8.13182- (validate-configuration-directory
8.13183- directory :source-registry 'validate-source-registry-directive
8.13184- :invalid-form-reporter 'invalid-source-registry))
8.13185-
8.13186-
8.13187- ;;; Parse the configuration string
8.13188-
8.13189- (defun parse-source-registry-string (string &key location)
8.13190- (cond
8.13191- ((or (null string) (equal string ""))
8.13192- '(:source-registry :inherit-configuration))
8.13193- ((not (stringp string))
8.13194- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
8.13195- ((find (char string 0) "\"(")
8.13196- (validate-source-registry-form (read-from-string string) :location location))
8.13197- (t
8.13198- (loop
8.13199- :with inherit = nil
8.13200- :with directives = ()
8.13201- :with start = 0
8.13202- :with end = (length string)
8.13203- :with separator = (inter-directory-separator)
8.13204- :for pos = (position separator string :start start) :do
8.13205- (let ((s (subseq string start (or pos end))))
8.13206- (flet ((check (dir)
8.13207- (unless (absolute-pathname-p dir)
8.13208- (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
8.13209- dir))
8.13210- (cond
8.13211- ((equal "" s) ; empty element: inherit
8.13212- (when inherit
8.13213- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
8.13214- string))
8.13215- (setf inherit t)
8.13216- (push ':inherit-configuration directives))
8.13217- ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
8.13218- (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
8.13219- (t
8.13220- (push `(:directory ,(check s)) directives))))
8.13221- (cond
8.13222- (pos
8.13223- (setf start (1+ pos)))
8.13224- (t
8.13225- (unless inherit
8.13226- (push '(:ignore-inherited-configuration) directives))
8.13227- (return `(:source-registry ,@(nreverse directives))))))))))
8.13228-
8.13229- (defun register-asd-directory (directory &key recurse exclude collect)
8.13230- (if (not recurse)
8.13231- (collect-asds-in-directory directory collect)
8.13232- (collect-sub*directories-asd-files
8.13233- directory :exclude exclude :collect collect)))
8.13234-
8.13235- (defparameter* *default-source-registries*
8.13236- '(environment-source-registry
8.13237- user-source-registry
8.13238- user-source-registry-directory
8.13239- default-user-source-registry
8.13240- system-source-registry
8.13241- system-source-registry-directory
8.13242- default-system-source-registry)
8.13243- "List of default source registries" "3.1.0.102")
8.13244-
8.13245- (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
8.13246- (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
8.13247-
8.13248- (defun wrapping-source-registry ()
8.13249- `(:source-registry
8.13250- #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
8.13251- :inherit-configuration
8.13252- #+mkcl (:tree ,(translate-logical-pathname "SYS:"))
8.13253- #+cmucl (:tree #p"modules:")
8.13254- #+scl (:tree #p"file://modules/")))
8.13255- (defun default-user-source-registry ()
8.13256- `(:source-registry
8.13257- (:tree (:home "common-lisp/"))
8.13258- #+sbcl (:directory (:home ".sbcl/systems/"))
8.13259- (:directory ,(xdg-data-home "common-lisp/systems/"))
8.13260- (:tree ,(xdg-data-home "common-lisp/source/"))
8.13261- :inherit-configuration))
8.13262- (defun default-system-source-registry ()
8.13263- `(:source-registry
8.13264- ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
8.13265- :collect `(:directory (,dir "systems/"))
8.13266- :collect `(:tree (,dir "source/")))
8.13267- :inherit-configuration))
8.13268- (defun user-source-registry (&key (direction :input))
8.13269- (xdg-config-pathname *source-registry-file* direction))
8.13270- (defun system-source-registry (&key (direction :input))
8.13271- (find-preferred-file (system-config-pathnames *source-registry-file*)
8.13272- :direction direction))
8.13273- (defun user-source-registry-directory (&key (direction :input))
8.13274- (xdg-config-pathname *source-registry-directory* direction))
8.13275- (defun system-source-registry-directory (&key (direction :input))
8.13276- (find-preferred-file (system-config-pathnames *source-registry-directory*)
8.13277- :direction direction))
8.13278- (defun environment-source-registry ()
8.13279- (getenv "CL_SOURCE_REGISTRY"))
8.13280-
8.13281-
8.13282- ;;; Process the source-registry configuration
8.13283-
8.13284- (defgeneric process-source-registry (spec &key inherit register))
8.13285-
8.13286- (defun inherit-source-registry (inherit &key register)
8.13287- (when inherit
8.13288- (process-source-registry (first inherit) :register register :inherit (rest inherit))))
8.13289-
8.13290- (defun process-source-registry-directive (directive &key inherit register)
8.13291- (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
8.13292- (ecase kw
8.13293- ((:include)
8.13294- (destructuring-bind (pathname) rest
8.13295- (process-source-registry (resolve-location pathname) :inherit nil :register register)))
8.13296- ((:directory)
8.13297- (destructuring-bind (pathname) rest
8.13298- (when pathname
8.13299- (funcall register (resolve-location pathname :ensure-directory t)))))
8.13300- ((:tree)
8.13301- (destructuring-bind (pathname) rest
8.13302- (when pathname
8.13303- (funcall register (resolve-location pathname :ensure-directory t)
8.13304- :recurse t :exclude *source-registry-exclusions*))))
8.13305- ((:exclude)
8.13306- (setf *source-registry-exclusions* rest))
8.13307- ((:also-exclude)
8.13308- (appendf *source-registry-exclusions* rest))
8.13309- ((:default-registry)
8.13310- (inherit-source-registry
8.13311- '(default-user-source-registry default-system-source-registry) :register register))
8.13312- ((:inherit-configuration)
8.13313- (inherit-source-registry inherit :register register))
8.13314- ((:ignore-inherited-configuration)
8.13315- nil)))
8.13316- nil)
8.13317-
8.13318- (defmethod process-source-registry ((x symbol) &key inherit register)
8.13319- (process-source-registry (funcall x) :inherit inherit :register register))
8.13320- (defmethod process-source-registry ((pathname pathname) &key inherit register)
8.13321- (cond
8.13322- ((directory-pathname-p pathname)
8.13323- (let ((*here-directory* (resolve-symlinks* pathname)))
8.13324- (process-source-registry (validate-source-registry-directory pathname)
8.13325- :inherit inherit :register register)))
8.13326- ((probe-file* pathname :truename *resolve-symlinks*)
8.13327- (let ((*here-directory* (pathname-directory-pathname pathname)))
8.13328- (process-source-registry (validate-source-registry-file pathname)
8.13329- :inherit inherit :register register)))
8.13330- (t
8.13331- (inherit-source-registry inherit :register register))))
8.13332- (defmethod process-source-registry ((string string) &key inherit register)
8.13333- (process-source-registry (parse-source-registry-string string)
8.13334- :inherit inherit :register register))
8.13335- (defmethod process-source-registry ((x null) &key inherit register)
8.13336- (inherit-source-registry inherit :register register))
8.13337- (defmethod process-source-registry ((form cons) &key inherit register)
8.13338- (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
8.13339- (dolist (directive (cdr (validate-source-registry-form form)))
8.13340- (process-source-registry-directive directive :inherit inherit :register register))))
8.13341-
8.13342-
8.13343- ;; Flatten the user-provided configuration into an ordered list of directories and trees
8.13344- (defun flatten-source-registry (&optional (parameter *source-registry-parameter*))
8.13345- (remove-duplicates
8.13346- (while-collecting (collect)
8.13347- (with-pathname-defaults () ;; be location-independent
8.13348- (inherit-source-registry
8.13349- `(wrapping-source-registry
8.13350- ,parameter
8.13351- ,@*default-source-registries*)
8.13352- :register #'(lambda (directory &key recurse exclude)
8.13353- (collect (list directory :recurse recurse :exclude exclude))))))
8.13354- :test 'equal :from-end t))
8.13355-
8.13356- ;; MAYBE: move this utility function to uiop/pathname and export it?
8.13357- (defun pathname-directory-depth (p)
8.13358- (length (normalize-pathname-directory-component (pathname-directory p))))
8.13359-
8.13360- (defun preferred-source-path-p (x y)
8.13361- "Return T iff X is to be preferred over Y as a source path"
8.13362- (let ((lx (pathname-directory-depth x))
8.13363- (ly (pathname-directory-depth y)))
8.13364- (or (< lx ly)
8.13365- (and (= lx ly)
8.13366- (string< (namestring x)
8.13367- (namestring y))))))
8.13368-
8.13369- ;; Will read the configuration and initialize all internal variables.
8.13370- (defun compute-source-registry (&optional (parameter *source-registry-parameter*)
8.13371- (registry *source-registry*))
8.13372- (dolist (entry (flatten-source-registry parameter))
8.13373- (destructuring-bind (directory &key recurse exclude) entry
8.13374- (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
8.13375- (register-asd-directory
8.13376- directory :recurse recurse :exclude exclude :collect
8.13377- #'(lambda (asd)
8.13378- (let* ((name (pathname-name asd))
8.13379- (name (if (typep asd 'logical-pathname)
8.13380- ;; logical pathnames are upper-case,
8.13381- ;; at least in the CLHS and on SBCL,
8.13382- ;; yet (coerce-name :foo) is lower-case.
8.13383- ;; won't work well with (load-system "Foo")
8.13384- ;; instead of (load-system 'foo)
8.13385- (string-downcase name)
8.13386- name)))
8.13387- (unless (gethash name registry) ; already shadowed by something else
8.13388- (if-let (old (gethash name h))
8.13389- ;; If the name appears multiple times,
8.13390- ;; prefer the one with the shallowest directory,
8.13391- ;; or if they have same depth, compare unix-namestring with string<
8.13392- (multiple-value-bind (better worse)
8.13393- (if (preferred-source-path-p asd old)
8.13394- (progn (setf (gethash name h) asd) (values asd old))
8.13395- (values old asd))
8.13396- (when *verbose-out*
8.13397- (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
8.13398- found several entries for ~A - picking ~S over ~S~:>")
8.13399- directory recurse name better worse)))
8.13400- (setf (gethash name h) asd))))))
8.13401- (maphash #'(lambda (k v) (setf (gethash k registry) v)) h))))
8.13402- (values))
8.13403-
8.13404- (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
8.13405- ;; Record the parameter used to configure the registry
8.13406- (setf *source-registry-parameter* parameter)
8.13407- ;; Clear the previous registry database:
8.13408- (setf *source-registry* (make-hash-table :test 'equal))
8.13409- ;; Do it!
8.13410- (compute-source-registry parameter))
8.13411-
8.13412- ;; Checks an initial variable to see whether the state is initialized
8.13413- ;; or cleared. In the former case, return current configuration; in
8.13414- ;; the latter, initialize. ASDF will call this function at the start
8.13415- ;; of (asdf:find-system) to make sure the source registry is initialized.
8.13416- ;; However, it will do so *without* a parameter, at which point it
8.13417- ;; will be too late to provide a parameter to this function, though
8.13418- ;; you may override the configuration explicitly by calling
8.13419- ;; initialize-source-registry directly with your parameter.
8.13420- (defun ensure-source-registry (&optional parameter)
8.13421- (unless (source-registry-initialized-p)
8.13422- (initialize-source-registry parameter))
8.13423- (values))
8.13424-
8.13425- (defun sysdef-source-registry-search (system)
8.13426- (ensure-source-registry)
8.13427- (values (gethash (primary-system-name system) *source-registry*))))
8.13428-
8.13429-
8.13430-;;;; -------------------------------------------------------------------------
8.13431-;;; Internal hacks for backward-compatibility
8.13432-
8.13433-(uiop/package:define-package :asdf/backward-internals
8.13434- (:recycle :asdf/backward-internals :asdf)
8.13435- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
8.13436- (:export #:load-sysdef))
8.13437-(in-package :asdf/backward-internals)
8.13438-
8.13439-(with-asdf-deprecation (:style-warning "3.2" :warning "3.4")
8.13440- (defun load-sysdef (name pathname)
8.13441- (declare (ignore name pathname))
8.13442- ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older.
8.13443- (error "Use asdf:load-asd instead of asdf::load-sysdef")))
8.13444-;;;; -------------------------------------------------------------------------
8.13445-;;; Backward-compatible interfaces
8.13446-
8.13447-(uiop/package:define-package :asdf/backward-interface
8.13448- (:recycle :asdf/backward-interface :asdf)
8.13449- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
8.13450- :asdf/component :asdf/system :asdf/system-registry :asdf/operation :asdf/action
8.13451- :asdf/lisp-action :asdf/plan :asdf/operate
8.13452- :asdf/find-system :asdf/parse-defsystem :asdf/output-translations :asdf/bundle)
8.13453- (:export
8.13454- #:*asdf-verbose*
8.13455- #:operation-error #:compile-error #:compile-failed #:compile-warned
8.13456- #:error-component #:error-operation #:traverse
8.13457- #:component-load-dependencies
8.13458- #:enable-asdf-binary-locations-compatibility
8.13459- #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
8.13460- #:component-property
8.13461- #:run-shell-command
8.13462- #:system-definition-pathname #:system-registered-p #:require-system
8.13463- #:explain
8.13464- #+ecl #:make-build))
8.13465-(in-package :asdf/backward-interface)
8.13466-
8.13467-;; NB: the warning status of these functions may have to be distinguished later,
8.13468-;; as some get removed faster than the others in client code.
8.13469-(with-asdf-deprecation (:style-warning "3.2" :warning "3.4")
8.13470-
8.13471- ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp;
8.13472- ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition
8.13473- ;; that do not involve ASDF actions.
8.13474- ;; TODO: find the offenders and stop them.
8.13475- (progn
8.13476- (define-condition operation-error (error) ;; Bad, backward-compatible name
8.13477- ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
8.13478- ((component :reader error-component :initarg :component)
8.13479- (operation :reader error-operation :initarg :operation))
8.13480- (:report (lambda (c s)
8.13481- (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
8.13482- (type-of c) (error-operation c) (error-component c)))))
8.13483- (define-condition compile-error (operation-error) ())
8.13484- (define-condition compile-failed (compile-error) ())
8.13485- (define-condition compile-warned (compile-error) ()))
8.13486-
8.13487- ;; In Quicklisp 2015-05, still used by lisp-executable, staple, repl-utilities, cffi
8.13488- (defun component-load-dependencies (component) ;; from ASDF 2.000 to 2.26
8.13489- "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead; or better,
8.13490-define your operations with proper use of SIDEWAY-OPERATION, SELFWARD-OPERATION,
8.13491-or define methods on PREPARE-OP, etc."
8.13492- ;; Old deprecated name for the same thing. Please update your software.
8.13493- (component-sideway-dependencies component))
8.13494-
8.13495- ;; These old interfaces from ASDF1 have never been very meaningful
8.13496- ;; but are still used in obscure places.
8.13497- ;; In Quicklisp 2015-05, still used by cl-protobufs and clx.
8.13498- (defgeneric operation-on-warnings (operation)
8.13499- (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead."))
8.13500- (defgeneric operation-on-failure (operation)
8.13501- (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead."))
8.13502- (defgeneric (setf operation-on-warnings) (x operation)
8.13503- (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead."))
8.13504- (defgeneric (setf operation-on-failure) (x operation)
8.13505- (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead."))
8.13506- (progn
8.13507- (defmethod operation-on-warnings ((o operation))
8.13508- *compile-file-warnings-behaviour*)
8.13509- (defmethod operation-on-failure ((o operation))
8.13510- *compile-file-failure-behaviour*)
8.13511- (defmethod (setf operation-on-warnings) (x (o operation))
8.13512- (setf *compile-file-warnings-behaviour* x))
8.13513- (defmethod (setf operation-on-failure) (x (o operation))
8.13514- (setf *compile-file-failure-behaviour* x)))
8.13515-
8.13516- ;; Quicklisp 2015-05: Still used by SLIME's swank-asdf (!), common-lisp-stat,
8.13517- ;; js-parser, osicat, babel, staple, weblocks, cl-png, plain-odbc, autoproject,
8.13518- ;; cl-blapack, com.informatimago, cells-gtk3, asdf-dependency-grovel,
8.13519- ;; cl-glfw, cffi, jwacs, montezuma
8.13520- (defun system-definition-pathname (x)
8.13521- ;; As of 2.014.8, we mean to make this function obsolete,
8.13522- ;; but that won't happen until all clients have been updated.
8.13523- "DEPRECATED. This function used to expose ASDF internals with subtle
8.13524-differences with respect to user expectations, that have been refactored
8.13525-away since. We recommend you use ASDF:SYSTEM-SOURCE-FILE instead for a
8.13526-mostly compatible replacement that we're supporting, or even
8.13527-ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
8.13528-if that's whay you mean." ;;)
8.13529- (system-source-file x))
8.13530-
8.13531- ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2.
8.13532- ;; It was never officially exposed but some people still used it.
8.13533- (defgeneric traverse (operation component &key &allow-other-keys)
8.13534- (:documentation
8.13535- "DEPRECATED. Use MAKE-PLAN and PLAN-ACTIONS, or REQUIRED-COMPONENTS,
8.13536-or some other supported interface instead.
8.13537-
8.13538-Generate and return a plan for performing OPERATION on COMPONENT.
8.13539-
8.13540-The plan returned is a list of dotted-pairs. Each pair is the CONS
8.13541-of ASDF operation object and a COMPONENT object. The pairs will be
8.13542-processed in order by OPERATE."))
8.13543- (progn
8.13544- (define-convenience-action-methods traverse (operation component &key)))
8.13545- (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
8.13546- (plan-actions (apply 'make-plan plan-class o c keys)))
8.13547-
8.13548-
8.13549- ;; ASDF-Binary-Locations compatibility
8.13550- ;; This remains supported for legacy user, but not recommended for new users.
8.13551- ;; We suspect there are no more legacy users in 2016.
8.13552- (defun enable-asdf-binary-locations-compatibility
8.13553- (&key
8.13554- (centralize-lisp-binaries nil)
8.13555- (default-toplevel-directory
8.13556- ;; Use ".cache/common-lisp/" instead ???
8.13557- (subpathname (user-homedir-pathname) ".fasls/"))
8.13558- (include-per-user-information nil)
8.13559- (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil))
8.13560- (source-to-target-mappings nil)
8.13561- (file-types `(,(compile-file-type)
8.13562- "build-report"
8.13563- #+clasp (compile-file-type :output-type :object)
8.13564- #+ecl (compile-file-type :type :object)
8.13565- #+mkcl (compile-file-type :fasl-p nil)
8.13566- #+clisp "lib" #+sbcl "cfasl"
8.13567- #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
8.13568- "DEPRECATED. Use asdf-output-translations instead."
8.13569- #+(or clasp clisp ecl mkcl)
8.13570- (when (null map-all-source-files)
8.13571- (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
8.13572- (let* ((patterns (if map-all-source-files (list *wild-file*)
8.13573- (loop :for type :in file-types
8.13574- :collect (make-pathname :type type :defaults *wild-file*))))
8.13575- (destination-directory
8.13576- (if centralize-lisp-binaries
8.13577- `(,default-toplevel-directory
8.13578- ,@(when include-per-user-information
8.13579- (cdr (pathname-directory (user-homedir-pathname))))
8.13580- :implementation ,*wild-inferiors*)
8.13581- `(:root ,*wild-inferiors* :implementation))))
8.13582- (initialize-output-translations
8.13583- `(:output-translations
8.13584- ,@source-to-target-mappings
8.13585- #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
8.13586- #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
8.13587- ,@(loop :for pattern :in patterns
8.13588- :collect `((:root ,*wild-inferiors* ,pattern)
8.13589- (,@destination-directory ,pattern)))
8.13590- (t t)
8.13591- :ignore-inherited-configuration))))
8.13592- (progn
8.13593- (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
8.13594- (declare (ignore operation-class system args))
8.13595- (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
8.13596- (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
8.13597-ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
8.13598-which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
8.13599-and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
8.13600-In case you insist on preserving your previous A-B-L configuration, but
8.13601-do not know how to achieve the same effect with A-O-T, you may use function
8.13602-ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
8.13603-call that function where you would otherwise have loaded and configured A-B-L."))))
8.13604-
8.13605-
8.13606- ;; run-shell-command from ASDF 2, lightly fixed from ASDF 1, copied from MK-DEFSYSTEM. Die!
8.13607- (defun run-shell-command (control-string &rest args)
8.13608- "PLEASE DO NOT USE. This function is not just DEPRECATED, but also dysfunctional.
8.13609-Please use UIOP:RUN-PROGRAM instead."
8.13610- #-(and ecl os-windows)
8.13611- (let ((command (apply 'format nil control-string args)))
8.13612- (asdf-message "; $ ~A~%" command)
8.13613- (let ((exit-code
8.13614- (ignore-errors
8.13615- (nth-value 2 (run-program command :force-shell t :ignore-error-status t
8.13616- :output *verbose-out*)))))
8.13617- (typecase exit-code
8.13618- ((integer 0 255) exit-code)
8.13619- (t 255))))
8.13620- #+(and ecl os-windows)
8.13621- (not-implemented-error "run-shell-command" "for ECL on Windows."))
8.13622-
8.13623- ;; HOW do we get rid of variables??? With a symbol-macro that issues a warning?
8.13624- ;; In Quicklisp 2015-05, cl-protobufs still uses it, but that should be fixed in next version.
8.13625- (progn
8.13626- (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
8.13627-
8.13628- ;; Do NOT use in new code. NOT SUPPORTED.
8.13629- ;; NB: When this goes away, remove the slot PROPERTY in COMPONENT.
8.13630- ;; In Quicklisp 2014-05, it's still used by yaclml, amazon-ecs, blackthorn-engine, cl-tidy.
8.13631- ;; See TODO for further cleanups required before to get rid of it.
8.13632- (defgeneric component-property (component property))
8.13633- (defgeneric (setf component-property) (new-value component property))
8.13634-
8.13635- (defmethod component-property ((c component) property)
8.13636- (cdr (assoc property (slot-value c 'properties) :test #'equal)))
8.13637-
8.13638- (defmethod (setf component-property) (new-value (c component) property)
8.13639- (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
8.13640- (if a
8.13641- (setf (cdr a) new-value)
8.13642- (setf (slot-value c 'properties)
8.13643- (acons property new-value (slot-value c 'properties)))))
8.13644- new-value)
8.13645-
8.13646-
8.13647- ;; This method survives from ASDF 1, but really it is superseded by action-description.
8.13648- (defgeneric explain (operation component)
8.13649- (:documentation "Display a message describing an action.
8.13650-
8.13651-DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead."))
8.13652- (progn
8.13653- (define-convenience-action-methods explain (operation component)))
8.13654- (defmethod explain ((o operation) (c component))
8.13655- (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))))
8.13656-
8.13657-(with-asdf-deprecation (:style-warning "3.3")
8.13658- (defun system-registered-p (name)
8.13659- "DEPRECATED. Return a generalized boolean that is true if a system of given NAME was registered already.
8.13660-NAME is a system designator, to be normalized by COERCE-NAME.
8.13661-The value returned if true is a pair of a timestamp and a system object."
8.13662- (if-let (system (registered-system name))
8.13663- (cons (if-let (primary-system (registered-system (primary-system-name name)))
8.13664- (component-operation-time 'define-op primary-system))
8.13665- system)))
8.13666-
8.13667- (defun require-system (system &rest keys &key &allow-other-keys)
8.13668- "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the
8.13669-system or its dependencies if it has already been loaded."
8.13670- (declare (ignore keys))
8.13671- (unless (component-loaded-p system)
8.13672- (load-system system))))
8.13673-
8.13674-;;; This function is for backward compatibility with ECL only.
8.13675-#+ecl
8.13676-(with-asdf-deprecation (:style-warning "3.2" :warning "9999")
8.13677- (defun make-build (system &rest args
8.13678- &key (monolithic nil) (type :fasl) (move-here nil move-here-p)
8.13679- prologue-code epilogue-code no-uiop
8.13680- prefix-lisp-object-files postfix-lisp-object-files extra-object-files
8.13681- &allow-other-keys)
8.13682- (let* ((operation (asdf/bundle::select-bundle-operation type monolithic))
8.13683- (move-here-path (if (and move-here
8.13684- (typep move-here '(or pathname string)))
8.13685- (ensure-pathname move-here :namestring :lisp :ensure-directory t)
8.13686- (system-relative-pathname system "asdf-output/")))
8.13687- (extra-build-args (remove-plist-keys
8.13688- '(:monolithic :type :move-here
8.13689- :prologue-code :epilogue-code :no-uiop
8.13690- :prefix-lisp-object-files :postfix-lisp-object-files
8.13691- :extra-object-files)
8.13692- args))
8.13693- (build-system (if (subtypep operation 'image-op)
8.13694- (eval `(defsystem "asdf.make-build"
8.13695- :class program-system
8.13696- :source-file nil
8.13697- :pathname ,(system-source-directory system)
8.13698- :build-operation ,operation
8.13699- :build-pathname ,(subpathname move-here-path
8.13700- (file-namestring (first (output-files operation system))))
8.13701- :depends-on (,(coerce-name system))
8.13702- :prologue-code ,prologue-code
8.13703- :epilogue-code ,epilogue-code
8.13704- :no-uiop ,no-uiop
8.13705- :prefix-lisp-object-files ,prefix-lisp-object-files
8.13706- :postfix-lisp-object-files ,postfix-lisp-object-files
8.13707- :extra-object-files ,extra-object-files
8.13708- :extra-build-args ,extra-build-args))
8.13709- system))
8.13710- (files (output-files operation build-system)))
8.13711- (operate operation build-system)
8.13712- (if (or move-here
8.13713- (and (null move-here-p) (member operation '(program-op image-op))))
8.13714- (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
8.13715- :for f :in files
8.13716- :for new-f = (make-pathname :name (pathname-name f)
8.13717- :type (pathname-type f)
8.13718- :defaults dest-path)
8.13719- :do (rename-file-overwriting-target f new-f)
8.13720- :collect new-f)
8.13721- files))))
8.13722-;;;; ---------------------------------------------------------------------------
8.13723-;;;; Handle ASDF package upgrade, including implementation-dependent magic.
8.13724-
8.13725-(uiop/package:define-package :asdf/interface
8.13726- (:nicknames :asdf :asdf-utilities)
8.13727- (:recycle :asdf/interface :asdf)
8.13728- (:unintern
8.13729- #:loaded-systems ; makes for annoying SLIME completion
8.13730- #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL
8.13731- (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
8.13732- :asdf/component :asdf/system :asdf/system-registry :asdf/find-component
8.13733- :asdf/operation :asdf/action :asdf/lisp-action
8.13734- :asdf/output-translations :asdf/source-registry
8.13735- :asdf/forcing :asdf/plan :asdf/operate :asdf/find-system :asdf/parse-defsystem
8.13736- :asdf/bundle :asdf/concatenate-source
8.13737- :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system)
8.13738- ;; Note: (1) we are NOT automatically reexporting everything from previous packages.
8.13739- ;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
8.13740- (:export
8.13741- #:defsystem #:find-system #:load-asd #:locate-system #:coerce-name
8.13742- #:primary-system-name #:primary-system-p
8.13743- #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
8.13744- #:system-definition-pathname
8.13745- #:search-for-system-definition #:find-component #:component-find-path
8.13746- #:compile-system #:load-system #:load-systems #:load-systems*
8.13747- #:require-system #:test-system #:clear-system
8.13748- #:operation #:make-operation #:find-operation
8.13749- #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation
8.13750- #:non-propagating-operation
8.13751- #:build-op #:make
8.13752- #:load-op #:prepare-op #:compile-op
8.13753- #:prepare-source-op #:load-source-op #:test-op #:define-op
8.13754- #:feature #:version #:version-satisfies #:upgrade-asdf
8.13755- #:implementation-identifier #:implementation-type #:hostname
8.13756- #:component-depends-on ; backward-compatible name rather than action-depends-on
8.13757- #:input-files #:additional-input-files
8.13758- #:output-files #:output-file #:perform #:perform-with-restarts
8.13759- #:operation-done-p #:explain #:action-description #:component-sideway-dependencies
8.13760- #:needed-in-image-p
8.13761- #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
8.13762- #:program-system
8.13763- #:basic-compile-bundle-op #:prepare-bundle-op
8.13764- #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
8.13765- #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op
8.13766- #:monolithic-lib-op #:monolithic-dll-op #:monolithic-deliver-asd-op
8.13767- #:concatenate-source-op
8.13768- #:load-concatenated-source-op
8.13769- #:compile-concatenated-source-op
8.13770- #:load-compiled-concatenated-source-op
8.13771- #:monolithic-concatenate-source-op
8.13772- #:monolithic-load-concatenated-source-op
8.13773- #:monolithic-compile-concatenated-source-op
8.13774- #:monolithic-load-compiled-concatenated-source-op
8.13775- #:operation-monolithic-p
8.13776- #:required-components
8.13777- #:component-loaded-p
8.13778- #:component #:parent-component #:child-component #:system #:module
8.13779- #:file-component #:source-file #:c-source-file #:java-source-file
8.13780- #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
8.13781- #:static-file #:doc-file #:html-file
8.13782- #:file-type #:source-file-type
8.13783- #:register-preloaded-system #:sysdef-preloaded-system-search
8.13784- #:register-immutable-system #:sysdef-immutable-system-search
8.13785- #:package-inferred-system #:register-system-packages
8.13786- #:component-children
8.13787- #:component-children-by-name
8.13788- #:component-pathname
8.13789- #:component-relative-pathname
8.13790- #:component-name
8.13791- #:component-version
8.13792- #:component-parent
8.13793- #:component-system
8.13794- #:component-encoding
8.13795- #:component-external-format
8.13796- #:system-description
8.13797- #:system-long-description
8.13798- #:system-author
8.13799- #:system-maintainer
8.13800- #:system-license
8.13801- #:system-licence
8.13802- #:system-version
8.13803- #:system-source-file
8.13804- #:system-source-directory
8.13805- #:system-relative-pathname
8.13806- #:system-homepage
8.13807- #:system-mailto
8.13808- #:system-bug-tracker
8.13809- #:system-long-name
8.13810- #:system-source-control
8.13811- #:map-systems
8.13812- #:system-defsystem-depends-on
8.13813- #:system-depends-on
8.13814- #:system-weakly-depends-on
8.13815- #:*system-definition-search-functions* ; variables
8.13816- #:*central-registry*
8.13817- #:*compile-file-warnings-behaviour*
8.13818- #:*compile-file-failure-behaviour*
8.13819- #:*resolve-symlinks*
8.13820- #:*verbose-out*
8.13821- #:asdf-version
8.13822- #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
8.13823- #:compile-warned-warning #:compile-failed-warning
8.13824- #:error-name
8.13825- #:error-pathname
8.13826- #:load-system-definition-error
8.13827- #:error-component #:error-operation
8.13828- #:system-definition-error
8.13829- #:missing-component
8.13830- #:missing-component-of-version
8.13831- #:missing-dependency
8.13832- #:missing-dependency-of-version
8.13833- #:circular-dependency ; errors
8.13834- #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name #:system-out-of-date
8.13835- #:package-inferred-system-missing-package-error
8.13836- #:operation-definition-warning #:operation-definition-error
8.13837- #:try-recompiling ; restarts
8.13838- #:retry
8.13839- #:accept
8.13840- #:coerce-entry-to-directory
8.13841- #:remove-entry-from-registry
8.13842- #:clear-configuration-and-retry
8.13843- #:*encoding-detection-hook*
8.13844- #:*encoding-external-format-hook*
8.13845- #:*default-encoding*
8.13846- #:*utf-8-external-format*
8.13847- #:clear-configuration
8.13848- #:*output-translations-parameter*
8.13849- #:initialize-output-translations
8.13850- #:disable-output-translations
8.13851- #:clear-output-translations
8.13852- #:ensure-output-translations
8.13853- #:apply-output-translations
8.13854- #:compile-file*
8.13855- #:compile-file-pathname*
8.13856- #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check
8.13857- #:enable-asdf-binary-locations-compatibility
8.13858- #:*default-source-registries*
8.13859- #:*source-registry-parameter*
8.13860- #:initialize-source-registry
8.13861- #:compute-source-registry
8.13862- #:clear-source-registry
8.13863- #:ensure-source-registry
8.13864- #:process-source-registry
8.13865- #:registered-system #:registered-systems #:already-loaded-systems
8.13866- #:resolve-location
8.13867- #:asdf-message
8.13868- #:*user-cache*
8.13869- #:user-output-translations-pathname
8.13870- #:system-output-translations-pathname
8.13871- #:user-output-translations-directory-pathname
8.13872- #:system-output-translations-directory-pathname
8.13873- #:user-source-registry
8.13874- #:system-source-registry
8.13875- #:user-source-registry-directory
8.13876- #:system-source-registry-directory
8.13877-
8.13878- ;; The symbols below are all DEPRECATED, do not use. To be removed in a further release.
8.13879- #:*asdf-verbose* #:run-shell-command
8.13880- #:component-load-dependencies #:system-registered-p #:package-system
8.13881- #+ecl #:make-build
8.13882- #:operation-on-warnings #:operation-on-failure #:operation-error
8.13883- #:compile-failed #:compile-warned #:compile-error
8.13884- #:module-components #:component-property #:traverse))
8.13885-;;;; ---------------------------------------------------------------------------
8.13886-;;;; ASDF-USER, where the action happens.
8.13887-
8.13888-(uiop/package:define-package :asdf/user
8.13889- (:nicknames :asdf-user)
8.13890- ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below.
8.13891- ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop.
8.13892- ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo.
8.13893- ;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package
8.13894- ;; that only :use's :cl and :asdf
8.13895- (:use :uiop/common-lisp :uiop :asdf/interface))
8.13896-;;;; -----------------------------------------------------------------------
8.13897-;;;; ASDF Footer: last words and cleanup
8.13898-
8.13899-(uiop/package:define-package :asdf/footer
8.13900- (:recycle :asdf/footer :asdf)
8.13901- (:use :uiop/common-lisp :uiop
8.13902- :asdf/system ;; used by ECL
8.13903- :asdf/upgrade :asdf/system-registry :asdf/operate :asdf/bundle)
8.13904- ;; Happily, all those implementations all have the same module-provider hook interface.
8.13905- #+(or abcl clasp cmucl clozure ecl mezzano mkcl sbcl)
8.13906- (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext #+mezzano :sys.int
8.13907- #:*module-provider-functions*
8.13908- #+ecl #:*load-hooks*)
8.13909- #+(or clasp mkcl) (:import-from :si #:*load-hooks*))
8.13910-
8.13911-(in-package :asdf/footer)
8.13912-
8.13913-;;;; Register ASDF itself and all its subsystems as preloaded.
8.13914-(with-upgradability ()
8.13915- (dolist (s '("asdf" "asdf-package-system"))
8.13916- ;; Don't bother with these system names, no one relies on them anymore:
8.13917- ;; "asdf-utils" "asdf-bundle" "asdf-driver" "asdf-defsystem"
8.13918- (register-preloaded-system s :version *asdf-version*))
8.13919- (register-preloaded-system "uiop" :version *uiop-version*))
8.13920-
8.13921-;;;; Ensure that the version slot on the registered preloaded systems are
8.13922-;;;; correct, by CLEARing the system. However, we do not CLEAR-SYSTEM
8.13923-;;;; unconditionally. This is because it's possible the user has upgraded the
8.13924-;;;; systems using ASDF itself, meaning that the registered systems have real
8.13925-;;;; data from the file system that we want to preserve instead of blasting
8.13926-;;;; away and replacing with a blank preloaded system.
8.13927-(with-upgradability ()
8.13928- (unless (equal (system-version (registered-system "asdf")) (asdf-version))
8.13929- (clear-system "asdf"))
8.13930- ;; 3.1.2 is the last version where asdf-package-system was a separate system.
8.13931- (when (version< "3.1.2" (system-version (registered-system "asdf-package-system")))
8.13932- (clear-system "asdf-package-system"))
8.13933- (unless (equal (system-version (registered-system "uiop")) *uiop-version*)
8.13934- (clear-system "uiop")))
8.13935-
8.13936-;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
8.13937-#+(or abcl clasp clisp clozure cmucl ecl mezzano mkcl sbcl)
8.13938-(with-upgradability ()
8.13939- ;; Hook into CL:REQUIRE.
8.13940- #-clisp (pushnew 'module-provide-asdf *module-provider-functions*)
8.13941- #+clisp (if-let (x (find-symbol* '#:*module-provider-functions* :custom nil))
8.13942- (eval `(pushnew 'module-provide-asdf ,x)))
8.13943-
8.13944- #+(or clasp ecl mkcl)
8.13945- (progn
8.13946- (pushnew '("fasb" . si::load-binary) *load-hooks* :test 'equal :key 'car)
8.13947-
8.13948- #+os-windows
8.13949- (unless (assoc "asd" *load-hooks* :test 'equal)
8.13950- (appendf *load-hooks* '(("asd" . si::load-source))))
8.13951-
8.13952- ;; Wrap module provider functions in an idempotent, upgrade friendly way
8.13953- (defvar *wrapped-module-provider* (make-hash-table))
8.13954- (setf (gethash 'module-provide-asdf *wrapped-module-provider*) 'module-provide-asdf)
8.13955- (defun wrap-module-provider (provider name)
8.13956- (let ((results (multiple-value-list (funcall provider name))))
8.13957- (when (first results) (register-preloaded-system (coerce-name name)))
8.13958- (values-list results)))
8.13959- (defun wrap-module-provider-function (provider)
8.13960- (ensure-gethash provider *wrapped-module-provider*
8.13961- (constantly
8.13962- #'(lambda (module-name)
8.13963- (wrap-module-provider provider module-name)))))
8.13964- (setf *module-provider-functions*
8.13965- (mapcar #'wrap-module-provider-function *module-provider-functions*))))
8.13966-
8.13967-#+cmucl ;; Hook into the CMUCL herald.
8.13968-(with-upgradability ()
8.13969- (defun herald-asdf (stream)
8.13970- (format stream " ASDF ~A" (asdf-version)))
8.13971- (setf (getf ext:*herald-items* :asdf) '(herald-asdf)))
8.13972-
8.13973-
8.13974-;;;; Done!
8.13975-(with-upgradability ()
8.13976- #+allegro ;; restore *w-o-n-r-c* setting as saved in uiop/common-lisp
8.13977- (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
8.13978- (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*))
8.13979-
8.13980- ;; Advertise the features we provide.
8.13981- (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf3.3)) (pushnew f *features*))
8.13982-
8.13983- ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users.
8.13984- (provide "asdf") (provide "ASDF")
8.13985-
8.13986- ;; Finally, call a function that will cleanup in case this is an upgrade of an older ASDF.
8.13987- (cleanup-upgraded-asdf))
8.13988-
8.13989-(when *load-verbose*
8.13990- (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
9.1--- a/tools/prepare-image.lisp Thu Jun 15 22:01:40 2023 -0400
9.2+++ b/tools/prepare-image.lisp Sun Jun 18 22:25:28 2023 -0400
9.3@@ -3,30 +3,15 @@
9.4 ;; For SBCL, if you don't have SBCL_HOME set, then we won't be able to require this later.
9.5 #+sbcl
9.6 (require 'sb-introspect)
9.7-
9.8-(when (probe-file "tools/asdf.lisp")
9.9- (format t "Compiling asdf..~%")
9.10- (let ((output (compile-file "tools/asdf.lisp" :verbose nil :print nil)))
9.11- (load output))
9.12- (provide "asdf"))
9.13-
9.14+#-sbcl
9.15 (require "asdf")
9.16
9.17 #+sbcl
9.18 (require "sb-sprof")
9.19
9.20-#+nil
9.21-(push (pathname (format nil "~a/local-projects/poiu/" (namestring (uiop:getcwd))))
9.22- asdf:*central-registry*)
9.23-
9.24-(defvar *asdf-root-guesser* nil)
9.25-
9.26-(defparameter *cwd* (merge-pathnames
9.27- *default-pathname-defaults*
9.28- (uiop:getcwd)))
9.29+(defvar *cwd* (uiop:getcwd))
9.30
9.31 (defun update-output-translations (root)
9.32- "This function is called dynamically from deliver-utils/common.lisp!"
9.33 (asdf:initialize-output-translations
9.34 `(:output-translations
9.35 :inherit-configuration
9.36@@ -43,69 +28,6 @@
9.37 (asdf:register-preloaded-system :sb-rotate-byte)
9.38 (asdf:register-preloaded-system :sb-cltl2))
9.39
9.40-(defun %read-version (file)
9.41- (let ((key "version: "))
9.42- (loop for line in (uiop:read-file-lines file)
9.43- if (string= key line :end2 (length key))
9.44- return (subseq line (length key)))))
9.45-
9.46-(defun init-quicklisp ()
9.47- (let ((version (%read-version "quicklisp/dists/quicklisp/distinfo.txt")))
9.48- (let ((quicklisp-loc (ensure-directories-exist
9.49- (merge-pathnames
9.50- (format nil "build/quicklisp/~a/" version)
9.51- *cwd*)))
9.52- (src (merge-pathnames
9.53- "quicklisp/"
9.54- *cwd*)))
9.55- (flet ((safe-copy-file (path &optional (dest path))
9.56- (let ((src (merge-pathnames
9.57- path
9.58- "quicklisp/"))
9.59- (dest (merge-pathnames
9.60- dest
9.61- quicklisp-loc)))
9.62- (format t "Copying: ~a to ~a~%" src dest)
9.63-
9.64- (when (equal src dest)
9.65- (error "Trying to overwrite the same file"))
9.66- (unless (uiop:file-exists-p dest)
9.67- (uiop:copy-file
9.68- src
9.69- (ensure-directories-exist
9.70- dest))))))
9.71- (loop for name in
9.72- (append (directory
9.73- (merge-pathnames
9.74- "quicklisp/quicklisp/*.lisp"
9.75- *cwd*))
9.76- (directory
9.77- (merge-pathnames
9.78- "quicklisp/quicklisp/*.asd"
9.79- *cwd*)))
9.80- do (safe-copy-file name
9.81- (format nil "quicklisp/~a.~a"
9.82- (pathname-name name)
9.83- (pathname-type name))))
9.84- (loop for name in (directory
9.85- (merge-pathnames
9.86- "quicklisp/*.lisp"
9.87- *cwd*))
9.88- do (safe-copy-file name
9.89- (format nil "~a.lisp"
9.90- (pathname-name name))))
9.91- (safe-copy-file "setup.lisp")
9.92- (safe-copy-file "quicklisp/version.txt")
9.93- (safe-copy-file "dists/quicklisp/distinfo.txt")
9.94- (safe-copy-file "dists/quicklisp/enabled.txt")
9.95- (safe-copy-file "dists/quicklisp/preference.txt"))
9.96- (load (merge-pathnames
9.97- "setup.lisp"
9.98- quicklisp-loc)))))
9.99-
9.100-(init-quicklisp)
9.101-
9.102-#+nil
9.103 (ql:update-all-dists :prompt nil)
9.104
9.105 ;; is the package name already loaded as a feature? uhh look it up
9.106@@ -117,28 +39,11 @@
9.107 (when (probe-file dir)
9.108 (push dir ql:*local-project-directories*)))))
9.109 #-demo
9.110- (push-src-dir "local-projects")
9.111- (push-src-dir "src")
9.112- (push-src-dir "third-party")
9.113- (push-src-dir "lisp")))
9.114-
9.115-
9.116-(defun update-root (cwd)
9.117- (update-output-translations cwd)
9.118- (update-project-directories cwd))
9.119+ (push-src-dir ".")
9.120+ (push-src-dir "vendor")))
9.121
9.122 (update-project-directories *cwd*)
9.123
9.124-(defun maybe-asdf-prepare ()
9.125- (when *asdf-root-guesser*
9.126- (update-root (funcall *asdf-root-guesser*))))
9.127-
9.128-(compile 'maybe-asdf-prepare)
9.129-
9.130-(defun unprepare-asdf (root-guesser)
9.131- "This function is called dynamically from deliver-utils/common.lisp!"
9.132- (setf *asdf-root-guesser* root-guesser))
9.133-
9.134 (defun maybe-configure-proxy ()
9.135 (let ((proxy (uiop:getenv "HTTP_PROXY")))
9.136 (when (and proxy (> (length proxy) 0))
9.137@@ -146,15 +51,9 @@
9.138
9.139 (maybe-configure-proxy)
9.140
9.141-
9.142 (ql:quickload "log4cl")
9.143 (ql:quickload "prove-asdf")
9.144
9.145 (log:info "*local-project-directories: ~S" ql:*local-project-directories*)
9.146
9.147-;; (ql:quickload :cl-ppcre)
9.148-;; make sure we have build asd
9.149-#+nil
9.150-(push (pathname (format nil "~a/build-utils/" *cwd*))
9.151- asdf:*central-registry*)
9.152 (ql:register-local-projects)
