1.1--- a/Cargo.toml Sun Jun 04 00:56:02 2023 -0400
1.2+++ b/Cargo.toml Mon Jun 05 19:59:26 2023 -0400
1.3@@ -1,2 +1,2 @@
1.4 [workspace]
1.5-members = ["src/crates/obj","src/crates/ui"]
1.6+members = ["src/crates/obj","src/crates/ui","src/crates/service"]
2.1--- a/default.cfg Sun Jun 04 00:56:02 2023 -0400
2.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
2.3@@ -1,11 +0,0 @@
2.4-;;; default-config.se --- Default demo configuration -*- mode: lisp-data -*-
2.5-
2.6-;; The configuration for this demo is specified in S-Expressions.
2.7-;; Check 'docs/config.org' for available options.
2.8-(:service "weather"
2.9- :host "localhost"
2.10- :port 8888
2.11- :client (:name "guest"
2.12- :type "docker"
2.13- :mode "release"
2.14- :theme "dark"))
3.1--- a/demo.asd Sun Jun 04 00:56:02 2023 -0400
3.2+++ b/demo.asd Mon Jun 05 19:59:26 2023 -0400
3.3@@ -1,5 +1,8 @@
3.4-(asdf:defsystem "demo"
3.5- :version "1.0.0"
3.6+;;; demo.asd
3.7+(in-package #:asdf-user)
3.8+
3.9+(defsystem "demo"
3.10+ :version "0.1.0"
3.11 :author "ellis <ellis@rwest.io>"
3.12 :maintainer "ellis <ellis@rwest.io>"
3.13 :description ""
3.14@@ -7,32 +10,43 @@
3.15 :bug-tracker "https://gitlab.rwest.io/ellis/demo/issues"
3.16 :source-control (:hg "https://gitlab.rwest.io/ellis/demo")
3.17 :license "WTFPL"
3.18- :depends-on (:bordeaux-threads
3.19- #+(or ccl sbcl)
3.20- :clack
3.21- :clog
3.22-;; :cl-rocksdb
3.23- :verbose
3.24- :alexandria
3.25- :cl-ppcre
3.26- :cffi
3.27- :clingon)
3.28- :serial T
3.29- :components ((:file "pkg")
3.30-;; (:file "ffi")
3.31- (:file "tk")
3.32- (:file "cfg")
3.33-;; (:file "db")
3.34- (:file "ui")
3.35- (:file "demo"))
3.36- ;; :in-order-to ((test-op (test-op "demo/tests")))
3.37- :defsystem-depends-on (:deploy)
3.38- :build-operation "deploy-op"
3.39- :build-pathname "demo"
3.40- :entry-point "demo:main")
3.41+ :depends-on ("demo/sys" "demo/db" "demo/ui" "demo/cli")
3.42+ :in-order-to ((test-op (test-op "src/test")))
3.43+ :build-pathname "demo")
3.44+
3.45+(defsystem "demo/sys"
3.46+ :depends-on (:sxql :log4cl)
3.47+ :components ((:file "src/packages")
3.48+ (:module "tk"
3.49+ :pathname "src/tk"
3.50+ :serial t
3.51+ :components ((:file "tk")
3.52+ (:file "rs" :depends-on ("tk"))))))
3.53+
3.54+(defmethod perform :after ((op load-op) (c (eql (find-system :demo))))
3.55+ (pushnew :demo *features*))
3.56
3.57-;; (asdf:defsystem "demo.tests"
3.58- ;; :depends-on ("demo" "fiveam")
3.59- ;; :components ((:file "tests"))
3.60- ;; :perform (test-op (o c) (symbol-call :fiveam '#:run! "demo:main"))
3.61- ;; )
3.62+(defsystem "demo/cli"
3.63+ :depends-on (:clingon "demo/sys" "demo/ui" "demo/db")
3.64+ :components ((:file "src/cli")))
3.65+(defsystem "demo/ui"
3.66+ :depends-on (:clog "demo/sys" "demo/db")
3.67+ :components ((:file "src/ui")))
3.68+(defsystem "demo/db"
3.69+ :depends-on (:cl-dbi "demo/sys")
3.70+ :components ((:file "src/db")))
3.71+
3.72+(defsystem "demo/tests"
3.73+ :depends-on ("demo" "fiveam")
3.74+ :components ((:module "src/tests"
3.75+ :serial t
3.76+ :components
3.77+ ((:file "package")
3.78+ (:file "utils")
3.79+ (:module "clients"
3.80+ :serial t
3.81+ :components
3.82+ ((:file "cli")
3.83+ (:file "web"))))))
3.84+ :perform (test-op (op component)
3.85+ (uiop:symbol-call '#:demo-tests '#:run-tests)))
4.1--- a/docs/notes.org Sun Jun 04 00:56:02 2023 -0400
4.2+++ b/docs/notes.org Mon Jun 05 19:59:26 2023 -0400
4.3@@ -4,6 +4,7 @@
4.4 parallel to time, as if expansions occur in sequence. Thus things
4.5 like tags don't feel quite right.
4.6 * research
4.7+for libraries, always prefer [[https://common-lisp-libraries.readthedocs.io/][defacto libs]]
4.8 ** [[https://github.com/screenshotbot/screenshotbot-oss][screenshotbot-oss]]
4.9 - monolithic repo, includes third-party dependencies
4.10 - full quicklisp source
4.11@@ -27,8 +28,14 @@
4.12 sqlx = { version = "0.7", features = [ "runtime-tokio", "tls-rustls", "any", "chrono" ] }
4.13 #+end_src
4.14 ** LOGGING
4.15-*** [[https://github.com/sharplispers/log4cl/][log4cl]]
4.16+*** CLIENT
4.17+**** [[https://github.com/sharplispers/log4cl/][log4cl]]
4.18 supports slime well
4.19+*** SERVICE
4.20+**** [[https://crates.io/crates/tracing][tracing]]
4.21+**** [[https://crates.io/crates/tokio-console][tokio-console]] - monitoring tool
4.22+works with tracing using the [[https://crates.io/crates/console-subscriber][console-subscriber]] crate
4.23 ** UI
4.24 [[https://mcclim.common-lisp.dev/][mcclim]]
4.25-
4.26+[[https://slint-ui.com/][slint-ui]]
4.27+[[https://github.com/rabbibotton/clog][clog]]
5.1--- a/package.lisp Sun Jun 04 00:56:02 2023 -0400
5.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
5.3@@ -1,75 +0,0 @@
5.4-;; demo package.lisp
5.5-(defpackage :demo
5.6- (:use #:cl #:cffi)
5.7- (:local-nicknames
5.8- ;; (#:rdb #:cl-rocksdb)
5.9- (#:v #:org.shirakumo.verbose)
5.10- (#:bt #:bordeaux-threads)
5.11- (#:cli #:clingon))
5.12- ;; db.lisp
5.13- ;; (:export
5.14- ;; #:create-options
5.15- ;; #:destroy-options
5.16- ;; #:increase-parallelism
5.17- ;; #:optimize-level-style-compaction
5.18- ;; #:set-create-if-missing
5.19- ;; #:create-writeoptions
5.20- ;; #:destroy-writeoptions
5.21- ;; #:create-readoptions
5.22- ;; #:destroy-readoptions
5.23- ;; #:open-db
5.24- ;; #:close-db
5.25- ;; #:cancel-all-background-work
5.26- ;; #:put-kv
5.27- ;; #:put-kv-str
5.28- ;; #:get-kv
5.29- ;; #:get-kv-str
5.30- ;; #:create-iter
5.31- ;; #:destroy-iter
5.32- ;; #:move-iter-to-first
5.33- ;; #:move-iter-forward
5.34- ;; #:move-iter-backword
5.35- ;; #:valid-iter-p
5.36- ;; #:iter-key
5.37- ;; #:iter-key-str
5.38- ;; #:iter-value
5.39- ;; #:iter-value-str
5.40- ;; #:with-open-db
5.41- ;; #:with-iter)
5.42- ;; demo.lisp
5.43- (:export
5.44- #:main
5.45- #:demo-path
5.46- #:db-path
5.47- #:cli-opts
5.48- #:cli-handler
5.49- #:cli-cmd)
5.50- ;; ui.lisp
5.51- (:export
5.52- #:on-new-window
5.53- #:start-ui)
5.54- ;; tk.lisp
5.55- (:export
5.56- #:source-dir
5.57- #:random-id
5.58- #:scan-dir
5.59- #:mkstr
5.60- #:symb
5.61- #:sbq-reader)
5.62- ;; rs.lisp
5.63- (:export
5.64- #:*cargo-target*
5.65- #:*rs-macros*
5.66- #:rs-defmacro
5.67- #:rs-macroexpand-1
5.68- #:rs-macroexpand)
5.69- ;; ffi.lisp
5.70- ;; (:export
5.71- ;; #:quiche-lib-path
5.72- ;; #:rocksdb-lib-path
5.73- ;; #:demo-lib-path
5.74- ;; #:find-rs-cdylib
5.75- ;; #:install-demo-lib
5.76- ;; #:install-quiche-lib
5.77- ;; #:install-rocksdb-lib)
5.78-)
6.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2+++ b/run.lisp Mon Jun 05 19:59:26 2023 -0400
6.3@@ -0,0 +1,2 @@
6.4+(load "tools/prepare-image")
6.5+(load "tools/init")
7.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2+++ b/src/cli/cli.lisp Mon Jun 05 19:59:26 2023 -0400
7.3@@ -0,0 +1,45 @@
7.4+;; cli.lisp
7.5+(in-package :demo-cli)
7.6+
7.7+(defparameter demo-path (merge-pathnames "demo" (uiop:temporary-directory)))
7.8+
7.9+(defvar db-path (merge-pathnames "db" demo-path))
7.10+
7.11+(defun cli-opts ()
7.12+ "Returns the top-level CLI options."
7.13+ (list
7.14+ (cli:make-option
7.15+ :string
7.16+ :description "demo app to run"
7.17+ :short-name #\x
7.18+ :long-name "app"
7.19+ :initial-value "client"
7.20+ :env-vars '("DEMO_APP")
7.21+ :key :app)
7.22+ (cli:make-option
7.23+ :string
7.24+ :description "path to config"
7.25+ :short-name #\c
7.26+ :long-name "config"
7.27+ :initial-value "$DEMO_PATH/.fig"
7.28+ :env-vars '("DEMO_CONFIG"))))
7.29+
7.30+(defun cli-handler (cmd)
7.31+ "Handler for the `demo' command."
7.32+ (let ((app (cli:getopt cmd :app)))
7.33+ (format t "running: ~A!~%" app)))
7.34+
7.35+(defun cli-cmd ()
7.36+ "Our demo command."
7.37+ (cli:make-command
7.38+ :name "demo"
7.39+ :description "A collection of demos"
7.40+ :version "1.0.0"
7.41+ :authors '("ellis <ellis@rwest.io>")
7.42+ :license "WTFPL"
7.43+ :options (cli-opts)
7.44+ :handler #'cli-handler))
7.45+
7.46+(defun run-cli ()
7.47+ "A demo of some common-lisp functionality."
7.48+ (cli:run (cli-cmd)))
8.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2+++ b/src/crates/service/Cargo.toml Mon Jun 05 19:59:26 2023 -0400
8.3@@ -0,0 +1,21 @@
8.4+[package]
8.5+name = "demo_service"
8.6+version = "0.1.0"
8.7+edition = "2021"
8.8+[lib]
8.9+path = "lib.rs"
8.10+[[bin]]
8.11+name = "demo-service"
8.12+path = "main.rs"
8.13+[[test]]
8.14+name = "tests"
8.15+path = "tests.rs"
8.16+
8.17+[dependencies]
8.18+obj = { version = "0.1.0", path = "../obj" }
8.19+tokio = { version = "1.28.2", features = ["full"] }
8.20+sqlx = { version = "0.6.3", features = ["runtime-tokio-rustls", "any", "postgres"] }
8.21+axum = { version = "0.6.18" }
8.22+tracing-subscriber = { version = "0.3.17", features = ["env-filter"] }
8.23+tracing = "0.1.37"
8.24+
10.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2+++ b/src/crates/service/main.rs Mon Jun 05 19:59:26 2023 -0400
10.3@@ -0,0 +1,17 @@
10.4+use tracing_subscriber::{layer::SubscriberExt, util::SubscriberInitExt};
10.5+use tokio::net::TcpListener;
10.6+use sqlx::postgres::{PgPool, PgPoolOptions};
10.7+
10.8+#[tokio::main]
10.9+async fn main() {
10.10+ tracing_subscriber::registry()
10.11+ .with(
10.12+ tracing_subscriber::EnvFilter::try_from_default_env()
10.13+ .unwrap_or_else(|_| "demo_service=debug".into()),
10.14+ )
10.15+ .with(tracing_subscriber::fmt::layer())
10.16+ .init();
10.17+
10.18+ let listener = TcpListener::bind("127.0.0.1:8888").await.unwrap();
10.19+ tracing::debug!("listening on {}", listener.local_addr().unwrap());
10.20+}
12.1--- a/src/db.lisp Sun Jun 04 00:56:02 2023 -0400
12.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
12.3@@ -1,197 +0,0 @@
12.4-(in-package :demo)
12.5-
12.6-(define-foreign-library rocksdb
12.7- (:win32 "rocksdb")
12.8- (t (:default "librocksdb")))
12.9-
12.10-(use-foreign-library rocksdb)
12.11-
12.12-(defcfun ("rocksdb_options_create" create-options) :pointer)
12.13-(defcfun ("rocksdb_options_destroy" destroy-options) :void (options :pointer))
12.14-(defcfun ("rocksdb_options_increase_parallelism" increase-parallelism) :void (opt :pointer) (total-threads :int))
12.15-(defcfun ("rocksdb_options_optimize_level_style_compaction" optimize-level-style-compaction) :void (opt :pointer) (memtable_memory_budget :uint64))
12.16-(defcfun ("rocksdb_options_set_create_if_missing" set-create-if-missing) :void (opt :pointer) (val :boolean))
12.17-
12.18-(defcfun ("rocksdb_writeoptions_create" create-writeoptions) :pointer)
12.19-(defcfun ("rocksdb_writeoptions_destroy" destroy-writeoptions) :void (opt :pointer))
12.20-(defcfun ("rocksdb_readoptions_create" create-readoptions) :pointer)
12.21-(defcfun ("rocksdb_readoptions_destroy" destroy-readoptions) :void (opt :pointer))
12.22-
12.23-(defcfun ("rocksdb_open" open-db*) :pointer (opt :pointer) (name :string) (errptr :pointer))
12.24-(defcfun ("rocksdb_close" close-db) :void (opt :pointer))
12.25-(defcfun ("rocksdb_cancel_all_background_work" cancel-all-background-work) :void (db :pointer) (wait :boolean))
12.26-
12.27-(defcfun ("rocksdb_put" put*) :void (db :pointer) (options :pointer) (key :pointer) (keylen :unsigned-int) (val :pointer) (vallen :unsigned-int) (errptr :pointer))
12.28-(defcfun ("rocksdb_get" get*) :pointer (db :pointer) (options :pointer) (key :pointer) (keylen :unsigned-int) (vallen :pointer) (errptr :pointer))
12.29-
12.30-(defcfun ("rocksdb_create_iterator" create-iter*) :pointer (db :pointer) (opt :pointer))
12.31-(defcfun ("rocksdb_iter_destroy" destroy-iter) :void (iter :pointer))
12.32-(defcfun ("rocksdb_iter_seek_to_first" move-iter-to-first) :void (iter :pointer))
12.33-(defcfun ("rocksdb_iter_valid" valid-iter-p) :boolean (iter :pointer))
12.34-(defcfun ("rocksdb_iter_next" move-iter-forward) :void (iter :pointer))
12.35-(defcfun ("rocksdb_iter_prev" move-iter-backward) :void (iter :pointer))
12.36-(defcfun ("rocksdb_iter_key" iter-key*) :pointer (iter :pointer) (klen-ptr :pointer))
12.37-(defcfun ("rocksdb_iter_value" iter-value*) :pointer (iter :pointer) (vlen-ptr :pointer))
12.38-
12.39-(define-condition unable-to-open-db (error)
12.40- ((db-path :initarg :db-path
12.41- :reader db-path)
12.42- (error-message :initarg :error-message
12.43- :reader error-message)))
12.44-
12.45-(defmethod print-object ((obj unable-to-open-db) stream)
12.46- (print-unreadable-object (obj stream :type t :identity t)
12.47- (format stream "error-message=~A" (error-message obj))))
12.48-
12.49-(define-condition unable-to-put-key-value-to-db (error)
12.50- ((db :initarg :db
12.51- :reader db)
12.52- (key :initarg :key
12.53- :reader key)
12.54- (val :initarg :val
12.55- :reader val)
12.56- (error-message :initarg :error-message
12.57- :reader error-message)))
12.58-
12.59-(define-condition unable-to-get-value-to-db (error)
12.60- ((db :initarg :db
12.61- :reader db)
12.62- (key :initarg :key
12.63- :reader key)
12.64- (error-message :initarg :error-message
12.65- :reader error-message)))
12.66-
12.67-(defun open-db (db-path &optional opt)
12.68- (unless opt
12.69- (setq opt (create-options)))
12.70- (let ((errptr (foreign-alloc :pointer)))
12.71- (setf (mem-ref errptr :pointer) (null-pointer))
12.72- (let* ((db-path (if (pathnamep db-path)
12.73- (namestring db-path)
12.74- db-path))
12.75- (db (open-db* opt db-path errptr))
12.76- (err (mem-ref errptr :pointer)))
12.77- (unless (null-pointer-p err)
12.78- (error 'unable-to-open-db
12.79- :db-path db-path
12.80- :error-message (foreign-string-to-lisp err)))
12.81- db)))
12.82-
12.83-(defmacro clone-octets-to-foreign (lisp-array foreign-array)
12.84- (let ((i (gensym)))
12.85- `(loop for ,i from 0 below (length ,lisp-array)
12.86- do (setf (mem-aref ,foreign-array :unsigned-char ,i)
12.87- (aref ,lisp-array ,i)))))
12.88-
12.89-(defmacro clone-octets-from-foreign (foreign-array lisp-array len)
12.90- (let ((i (gensym)))
12.91- `(loop for ,i from 0 below ,len
12.92- do (setf (aref ,lisp-array ,i)
12.93- (mem-aref ,foreign-array :unsigned-char ,i)))))
12.94-
12.95-(defun put-kv (db key val &optional opt)
12.96- (unless opt
12.97- (setq opt (create-writeoptions)))
12.98- (with-foreign-objects ((errptr :pointer)
12.99- (key* :unsigned-char (length key))
12.100- (val* :unsigned-char (length val)))
12.101- (clone-octets-to-foreign key key*)
12.102- (clone-octets-to-foreign val val*)
12.103- (setf (mem-ref errptr :pointer) (null-pointer))
12.104- (put* db
12.105- opt
12.106- key*
12.107- (length key)
12.108- val*
12.109- (length val)
12.110- errptr)
12.111- (let ((err (mem-ref errptr :pointer)))
12.112- (unless (null-pointer-p err)
12.113- (error 'unable-to-put-key-value-to-db
12.114- :db db
12.115- :key key
12.116- :val val
12.117- :error-message (foreign-string-to-lisp err))))))
12.118-
12.119-(defun put-kv-str (db key val &optional opt)
12.120- (let ((key-octets (babel:string-to-octets key))
12.121- (val-octets (babel:string-to-octets val)))
12.122- (put-kv db key-octets val-octets opt)))
12.123-
12.124-(defun get-kv (db key &optional opt)
12.125- (unless opt
12.126- (setq opt (create-readoptions)))
12.127-
12.128- (with-foreign-objects ((val-len-ptr :unsigned-int)
12.129- (errptr :pointer)
12.130- (key* :unsigned-char (length key)))
12.131- (clone-octets-to-foreign key key*)
12.132- (setf (mem-ref errptr :pointer) (null-pointer))
12.133- (let ((val (get* db
12.134- opt
12.135- key*
12.136- (length key)
12.137- val-len-ptr
12.138- errptr)))
12.139- (let ((err (mem-ref errptr :pointer)))
12.140- (unless (null-pointer-p err)
12.141- (error 'unable-to-get-value-to-db
12.142- :db db
12.143- :key key
12.144- :error-message (foreign-string-to-lisp err)))
12.145-
12.146- (unless (null-pointer-p val)
12.147- (let* ((val-len (mem-ref val-len-ptr :unsigned-int))
12.148- (val* (make-array val-len
12.149- :element-type '(unsigned-byte 8))))
12.150- (clone-octets-from-foreign val val* val-len)
12.151- val*))))))
12.152-
12.153-(defun get-kv-str (db key &optional opt)
12.154- (let ((key-octets (babel:string-to-octets key)))
12.155- (let ((#1=val-octets (get-kv db key-octets opt)))
12.156- (when #1#
12.157- (babel:octets-to-string #1#)))))
12.158-
12.159-(defun create-iter (db &optional opt)
12.160- (unless opt
12.161- (setq opt (create-readoptions)))
12.162- (create-iter* db opt))
12.163-
12.164-(defun iter-key (iter)
12.165- (with-foreign-objects ((klen-ptr :unsigned-int))
12.166- (setf (mem-ref klen-ptr :unsigned-int) 0)
12.167- (let* ((key-ptr (iter-key* iter klen-ptr))
12.168- (klen (mem-ref klen-ptr :unsigned-int))
12.169- (key (make-array klen :element-type '(unsigned-byte 8))))
12.170- (clone-octets-from-foreign key-ptr key klen)
12.171- key)))
12.172-
12.173-(defun iter-key-str (iter)
12.174- (let ((#1=key-octets (iter-key iter)))
12.175- (when #1#
12.176- (babel:octets-to-string #1#))))
12.177-
12.178-(defun iter-value (iter)
12.179- (with-foreign-objects ((len-ptr :unsigned-int))
12.180- (setf (mem-ref len-ptr :unsigned-int) 0)
12.181- (let* ((value-ptr (iter-value* iter len-ptr))
12.182- (vlen (mem-ref len-ptr :unsigned-int))
12.183- (value* (make-array vlen :element-type '(unsigned-byte 8))))
12.184- (clone-octets-from-foreign value-ptr value* vlen)
12.185- value*)))
12.186-
12.187-(defun iter-value-str (iter)
12.188- (let ((#1=val-octets (iter-value iter)))
12.189- (when #1#
12.190- (babel:octets-to-string #1#))))
12.191-
12.192-(defmacro with-open-db ((db-var db-path &optional opt) &body body)
12.193- `(let ((,db-var (open-db ,db-path ,opt)))
12.194- (unwind-protect (progn ,@body)
12.195- (close-db ,db-var))))
12.196-
12.197-(defmacro with-iter ((iter-var db &optional opt) &body body)
12.198- `(let ((,iter-var (create-iter ,db ,opt)))
12.199- (unwind-protect (progn ,@body)
12.200- (destroy-iter ,iter-var))))
13.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
13.2+++ b/src/db/db.lisp Mon Jun 05 19:59:26 2023 -0400
13.3@@ -0,0 +1,197 @@
13.4+(in-package :demo)
13.5+
13.6+(define-foreign-library rocksdb
13.7+ (:win32 "rocksdb")
13.8+ (t (:default "librocksdb")))
13.9+
13.10+(use-foreign-library rocksdb)
13.11+
13.12+(defcfun ("rocksdb_options_create" create-options) :pointer)
13.13+(defcfun ("rocksdb_options_destroy" destroy-options) :void (options :pointer))
13.14+(defcfun ("rocksdb_options_increase_parallelism" increase-parallelism) :void (opt :pointer) (total-threads :int))
13.15+(defcfun ("rocksdb_options_optimize_level_style_compaction" optimize-level-style-compaction) :void (opt :pointer) (memtable_memory_budget :uint64))
13.16+(defcfun ("rocksdb_options_set_create_if_missing" set-create-if-missing) :void (opt :pointer) (val :boolean))
13.17+
13.18+(defcfun ("rocksdb_writeoptions_create" create-writeoptions) :pointer)
13.19+(defcfun ("rocksdb_writeoptions_destroy" destroy-writeoptions) :void (opt :pointer))
13.20+(defcfun ("rocksdb_readoptions_create" create-readoptions) :pointer)
13.21+(defcfun ("rocksdb_readoptions_destroy" destroy-readoptions) :void (opt :pointer))
13.22+
13.23+(defcfun ("rocksdb_open" open-db*) :pointer (opt :pointer) (name :string) (errptr :pointer))
13.24+(defcfun ("rocksdb_close" close-db) :void (opt :pointer))
13.25+(defcfun ("rocksdb_cancel_all_background_work" cancel-all-background-work) :void (db :pointer) (wait :boolean))
13.26+
13.27+(defcfun ("rocksdb_put" put*) :void (db :pointer) (options :pointer) (key :pointer) (keylen :unsigned-int) (val :pointer) (vallen :unsigned-int) (errptr :pointer))
13.28+(defcfun ("rocksdb_get" get*) :pointer (db :pointer) (options :pointer) (key :pointer) (keylen :unsigned-int) (vallen :pointer) (errptr :pointer))
13.29+
13.30+(defcfun ("rocksdb_create_iterator" create-iter*) :pointer (db :pointer) (opt :pointer))
13.31+(defcfun ("rocksdb_iter_destroy" destroy-iter) :void (iter :pointer))
13.32+(defcfun ("rocksdb_iter_seek_to_first" move-iter-to-first) :void (iter :pointer))
13.33+(defcfun ("rocksdb_iter_valid" valid-iter-p) :boolean (iter :pointer))
13.34+(defcfun ("rocksdb_iter_next" move-iter-forward) :void (iter :pointer))
13.35+(defcfun ("rocksdb_iter_prev" move-iter-backward) :void (iter :pointer))
13.36+(defcfun ("rocksdb_iter_key" iter-key*) :pointer (iter :pointer) (klen-ptr :pointer))
13.37+(defcfun ("rocksdb_iter_value" iter-value*) :pointer (iter :pointer) (vlen-ptr :pointer))
13.38+
13.39+(define-condition unable-to-open-db (error)
13.40+ ((db-path :initarg :db-path
13.41+ :reader db-path)
13.42+ (error-message :initarg :error-message
13.43+ :reader error-message)))
13.44+
13.45+(defmethod print-object ((obj unable-to-open-db) stream)
13.46+ (print-unreadable-object (obj stream :type t :identity t)
13.47+ (format stream "error-message=~A" (error-message obj))))
13.48+
13.49+(define-condition unable-to-put-key-value-to-db (error)
13.50+ ((db :initarg :db
13.51+ :reader db)
13.52+ (key :initarg :key
13.53+ :reader key)
13.54+ (val :initarg :val
13.55+ :reader val)
13.56+ (error-message :initarg :error-message
13.57+ :reader error-message)))
13.58+
13.59+(define-condition unable-to-get-value-to-db (error)
13.60+ ((db :initarg :db
13.61+ :reader db)
13.62+ (key :initarg :key
13.63+ :reader key)
13.64+ (error-message :initarg :error-message
13.65+ :reader error-message)))
13.66+
13.67+(defun open-db (db-path &optional opt)
13.68+ (unless opt
13.69+ (setq opt (create-options)))
13.70+ (let ((errptr (foreign-alloc :pointer)))
13.71+ (setf (mem-ref errptr :pointer) (null-pointer))
13.72+ (let* ((db-path (if (pathnamep db-path)
13.73+ (namestring db-path)
13.74+ db-path))
13.75+ (db (open-db* opt db-path errptr))
13.76+ (err (mem-ref errptr :pointer)))
13.77+ (unless (null-pointer-p err)
13.78+ (error 'unable-to-open-db
13.79+ :db-path db-path
13.80+ :error-message (foreign-string-to-lisp err)))
13.81+ db)))
13.82+
13.83+(defmacro clone-octets-to-foreign (lisp-array foreign-array)
13.84+ (let ((i (gensym)))
13.85+ `(loop for ,i from 0 below (length ,lisp-array)
13.86+ do (setf (mem-aref ,foreign-array :unsigned-char ,i)
13.87+ (aref ,lisp-array ,i)))))
13.88+
13.89+(defmacro clone-octets-from-foreign (foreign-array lisp-array len)
13.90+ (let ((i (gensym)))
13.91+ `(loop for ,i from 0 below ,len
13.92+ do (setf (aref ,lisp-array ,i)
13.93+ (mem-aref ,foreign-array :unsigned-char ,i)))))
13.94+
13.95+(defun put-kv (db key val &optional opt)
13.96+ (unless opt
13.97+ (setq opt (create-writeoptions)))
13.98+ (with-foreign-objects ((errptr :pointer)
13.99+ (key* :unsigned-char (length key))
13.100+ (val* :unsigned-char (length val)))
13.101+ (clone-octets-to-foreign key key*)
13.102+ (clone-octets-to-foreign val val*)
13.103+ (setf (mem-ref errptr :pointer) (null-pointer))
13.104+ (put* db
13.105+ opt
13.106+ key*
13.107+ (length key)
13.108+ val*
13.109+ (length val)
13.110+ errptr)
13.111+ (let ((err (mem-ref errptr :pointer)))
13.112+ (unless (null-pointer-p err)
13.113+ (error 'unable-to-put-key-value-to-db
13.114+ :db db
13.115+ :key key
13.116+ :val val
13.117+ :error-message (foreign-string-to-lisp err))))))
13.118+
13.119+(defun put-kv-str (db key val &optional opt)
13.120+ (let ((key-octets (babel:string-to-octets key))
13.121+ (val-octets (babel:string-to-octets val)))
13.122+ (put-kv db key-octets val-octets opt)))
13.123+
13.124+(defun get-kv (db key &optional opt)
13.125+ (unless opt
13.126+ (setq opt (create-readoptions)))
13.127+
13.128+ (with-foreign-objects ((val-len-ptr :unsigned-int)
13.129+ (errptr :pointer)
13.130+ (key* :unsigned-char (length key)))
13.131+ (clone-octets-to-foreign key key*)
13.132+ (setf (mem-ref errptr :pointer) (null-pointer))
13.133+ (let ((val (get* db
13.134+ opt
13.135+ key*
13.136+ (length key)
13.137+ val-len-ptr
13.138+ errptr)))
13.139+ (let ((err (mem-ref errptr :pointer)))
13.140+ (unless (null-pointer-p err)
13.141+ (error 'unable-to-get-value-to-db
13.142+ :db db
13.143+ :key key
13.144+ :error-message (foreign-string-to-lisp err)))
13.145+
13.146+ (unless (null-pointer-p val)
13.147+ (let* ((val-len (mem-ref val-len-ptr :unsigned-int))
13.148+ (val* (make-array val-len
13.149+ :element-type '(unsigned-byte 8))))
13.150+ (clone-octets-from-foreign val val* val-len)
13.151+ val*))))))
13.152+
13.153+(defun get-kv-str (db key &optional opt)
13.154+ (let ((key-octets (babel:string-to-octets key)))
13.155+ (let ((#1=val-octets (get-kv db key-octets opt)))
13.156+ (when #1#
13.157+ (babel:octets-to-string #1#)))))
13.158+
13.159+(defun create-iter (db &optional opt)
13.160+ (unless opt
13.161+ (setq opt (create-readoptions)))
13.162+ (create-iter* db opt))
13.163+
13.164+(defun iter-key (iter)
13.165+ (with-foreign-objects ((klen-ptr :unsigned-int))
13.166+ (setf (mem-ref klen-ptr :unsigned-int) 0)
13.167+ (let* ((key-ptr (iter-key* iter klen-ptr))
13.168+ (klen (mem-ref klen-ptr :unsigned-int))
13.169+ (key (make-array klen :element-type '(unsigned-byte 8))))
13.170+ (clone-octets-from-foreign key-ptr key klen)
13.171+ key)))
13.172+
13.173+(defun iter-key-str (iter)
13.174+ (let ((#1=key-octets (iter-key iter)))
13.175+ (when #1#
13.176+ (babel:octets-to-string #1#))))
13.177+
13.178+(defun iter-value (iter)
13.179+ (with-foreign-objects ((len-ptr :unsigned-int))
13.180+ (setf (mem-ref len-ptr :unsigned-int) 0)
13.181+ (let* ((value-ptr (iter-value* iter len-ptr))
13.182+ (vlen (mem-ref len-ptr :unsigned-int))
13.183+ (value* (make-array vlen :element-type '(unsigned-byte 8))))
13.184+ (clone-octets-from-foreign value-ptr value* vlen)
13.185+ value*)))
13.186+
13.187+(defun iter-value-str (iter)
13.188+ (let ((#1=val-octets (iter-value iter)))
13.189+ (when #1#
13.190+ (babel:octets-to-string #1#))))
13.191+
13.192+(defmacro with-open-db ((db-var db-path &optional opt) &body body)
13.193+ `(let ((,db-var (open-db ,db-path ,opt)))
13.194+ (unwind-protect (progn ,@body)
13.195+ (close-db ,db-var))))
13.196+
13.197+(defmacro with-iter ((iter-var db &optional opt) &body body)
13.198+ `(let ((,iter-var (create-iter ,db ,opt)))
13.199+ (unwind-protect (progn ,@body)
13.200+ (destroy-iter ,iter-var))))
14.1--- a/src/demo.lisp Sun Jun 04 00:56:02 2023 -0400
14.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
14.3@@ -1,45 +0,0 @@
14.4-;; demo.lisp
14.5-(in-package :demo)
14.6-
14.7-(defparameter demo-path (merge-pathnames "cl-demo" (uiop:temporary-directory)))
14.8-
14.9-(defvar db-path (merge-pathnames "db" demo-path))
14.10-
14.11-(defun cli-opts ()
14.12- "Returns the top-level CLI options."
14.13- (list
14.14- (cli:make-option
14.15- :string
14.16- :description "demo app to run"
14.17- :short-name #\x
14.18- :long-name "app"
14.19- :initial-value "client"
14.20- :env-vars '("DEMO_APP")
14.21- :key :app)
14.22- (cli:make-option
14.23- :string
14.24- :description "path to config"
14.25- :short-name #\c
14.26- :long-name "config"
14.27- :initial-value "$DEMO_PATH/.fig"
14.28- :env-vars '("DEMO_CONFIG"))))
14.29-
14.30-(defun cli-handler (cmd)
14.31- "Handler for the `demo' command."
14.32- (let ((app (cli:getopt cmd :app)))
14.33- (format t "running: ~A!~%" app)))
14.34-
14.35-(defun cli-cmd ()
14.36- "Our demo command."
14.37- (cli:make-command
14.38- :name "demo"
14.39- :description "A collection of demos"
14.40- :version "1.0.0"
14.41- :authors '("ellis <ellis@rwest.io>")
14.42- :license "WTFPL"
14.43- :options (cli-opts)
14.44- :handler #'cli-handler))
14.45-
14.46-(defun main ()
14.47- "A demo of some common-lisp functionality."
14.48- (cli:run (cli-cmd)))
15.1--- a/src/ffi.lisp Sun Jun 04 00:56:02 2023 -0400
15.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
15.3@@ -1,28 +0,0 @@
15.4-(in-package :demo)
15.5-(defparameter quiche-lib-path #p"./ffi/libquiche.dylib")
15.6-;;(defparameter rocksdb-lib-path #p"./ffi/librocksdb.dylib")
15.7-(defparameter demo-lib-path (find-rs-cdylib "libdemo.dylib"))
15.8-(defmacro find-rs-cdylib (name &optional debug)
15.9- "Find the rust dll specified by NAME."
15.10- (cond
15.11- ((uiop:directory-exists-p (merge-pathnames *cargo-target* "release"))
15.12- `,(mkstr "./target/release/" name))
15.13- ((uiop:directory-exists-p (merge-pathnames *cargo-target* "debug"))
15.14- `,(mkstr "./target/debug/" name))
15.15- (t `(progn
15.16- ,(uiop:run-program '("cargo" "build" (unless debug "--release")) :output t)
15.17- (find-rs-cdylib ,name ,debug)))))
15.18-
15.19-(define-foreign-library demo
15.20- (:win32 (:default "demo"))
15.21- (t (:default "libdemo")))
15.22-(define-foreign-library quiche
15.23- (:win32 (:default "quiche"))
15.24- (t (:default "libquiche")))
15.25-;; (define-foreign-library rocksdb
15.26-;; (:win32 (:default "rocksdb"))
15.27-;; (t (:default "librocksdb")))
15.28-
15.29-(defun load-libdemo () (load-foreign-library (find-rs-cdylib "libdemo.dylib")))
15.30-(defun install-quiche-lib (&optional path) (load-foreign-library (or path quiche-lib-path)))
15.31-;; (defun install-rocksdb-lib (&optional path) (load-foreign-library (or path rocksdb-lib-path)))
16.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
16.2+++ b/src/packages.lisp Mon Jun 05 19:59:26 2023 -0400
16.3@@ -0,0 +1,43 @@
16.4+;; demo packages.lisp
16.5+(defpackage :demo-user
16.6+ (:use :demo))
16.7+
16.8+(defpackage :demo
16.9+ (:use #:cl #:demo-ui #:demo-cli #:demo-tk #:demo-db)
16.10+ (:local-nicknames
16.11+ (#:v #:org.shirakumo.verbose)
16.12+ (#:bt #:bordeaux-threads)
16.13+ (#:cli #:clingon)))
16.14+
16.15+(defpackage :demo-ui
16.16+ (:use)
16.17+ (:export
16.18+ #:on-new-window
16.19+ #:start-ui))
16.20+(defpackage :demo-tk
16.21+ (:use)
16.22+ (:export
16.23+ #:source-dir
16.24+ #:random-id
16.25+ #:scan-dir
16.26+ #:mkstr
16.27+ #:symb
16.28+ #:sbq-reader)
16.29+ (:export
16.30+ #:*cargo-target*
16.31+ #:*rs-macros*
16.32+ #:rs-defmacro
16.33+ #:rs-macroexpand-1
16.34+ #:rs-macroexpand))
16.35+(defpackage :demo-cli
16.36+ (:use)
16.37+ (:local-nick
16.38+ (:export
16.39+ #:run-cli
16.40+ #:demo-path
16.41+ #:db-path
16.42+ #:cli-opts
16.43+ #:cli-handler
16.44+ #:cli-cmd))
16.45+(defpackage :demo-db
16.46+ (:use))
17.1--- a/src/rs.lisp Sun Jun 04 00:56:02 2023 -0400
17.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
17.3@@ -1,78 +0,0 @@
17.4-;;; RUST DSL
17.5-
17.6-;; So basically, this was born out of personal frustration with how
17.7-;; cbindgen and Rust macros work (they don't). Rust macros in general
17.8-;; are something of a pain in my opinion, so I thought why not just
17.9-;; generate Rust code from Lisp instead?
17.10-
17.11-(in-package :demo)
17.12-
17.13-(defvar *cargo-target* #p"/Users/ellis/dev/otom8/demo/target/")
17.14-(defvar *rs-macros* nil)
17.15-
17.16-;; TODO gensyms
17.17-(defmacro rs-defmacro (name args &body body)
17.18- "Define a macro which can be used within the body of a 'with-rs' form."
17.19- `(prog1
17.20- (defmacro ,name ,@(mapcar #`(,a1) args) ,@body)
17.21- (push ',name *rs-macros*)))
17.22-
17.23-(defun rs-mod-form (crate &optional mods pub)
17.24- "Generate a basic mod form (CRATE . [MODS] [PUB])"
17.25- `(,crate ,mods ,pub))
17.26-
17.27-(defmacro with-rs-env (imports &body body)
17.28- "Generate an environment for use within a Rust generator macro."
17.29- `(let ((imports ,(mapcar #'rs-mod-form imports)))
17.30- (format nil "~A~&~A" imports ',body)))
17.31-
17.32-(defun rs-use (crate &optional mods pub)
17.33- "Generate a single Rust use statement."
17.34- (concatenate
17.35- 'string
17.36- (if pub "pub " "")
17.37- "use " crate "::{"
17.38- (cond
17.39- ((consp mods)
17.40- (reduce
17.41- (lambda (x y) (format nil "~A,~A" x y))
17.42- mods))
17.43- (t mods))
17.44- "};"))
17.45-
17.46-(defun rs-mod (mod &optional pub)
17.47- "Generate a single Rust mod statement."
17.48- (concatenate
17.49- 'string
17.50- (if pub "pub " "")
17.51- "mod " mod ";"))
17.52-
17.53-(defun rs-imports (&rest imports)
17.54- "Generate a string of Rust 'use' statements."
17.55- (cond
17.56- ((consp imports)
17.57- (mapcar (lambda (x) (apply #'rs-use (apply #'rs-mod-form x))) imports))
17.58- (t imports)))
17.59-
17.60-(defmacro rs-extern-c-fn (name args &optional pub unsafe no-mangle &body body)
17.61- "Generate a Rust extern 'C' fn."
17.62- `(concatenate
17.63- 'string
17.64- ,(when no-mangle (format nil "#[no_mangle]~&"))
17.65- ,(when pub "pub ")
17.66- ,(when unsafe "unsafe ")
17.67- "extern \"C\" fn " ,name "("
17.68- ,(cond
17.69- ((consp args) (reduce (lambda (x y) (format nil "~A,~A" x y)) args))
17.70- (t args))
17.71- ")" "{" ,@body "}"))
17.72-
17.73-(defun rs-obj-impl (obj)
17.74- "Implement Objective for give OBJ."
17.75- (format nil "impl Objective for ~A {};" obj))
17.76-
17.77-;; (defun rs-macroexpand-1 (form &optional env))
17.78-
17.79-;; (defun rs-macroexpand (env &rest body)
17.80-
17.81-;;;
18.1--- a/src/tests.lisp Sun Jun 04 00:56:02 2023 -0400
18.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
18.3@@ -1,1 +0,0 @@
18.4-(in-package :demo)
19.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
19.2+++ b/src/tests/clients/cli.lisp Mon Jun 05 19:59:26 2023 -0400
19.3@@ -0,0 +1,7 @@
19.4+(in-package #:demo-tests)
19.5+
19.6+(def-suite* :demo.cli
19.7+ :in :demo)
19.8+
19.9+(test cli.args
19.10+ (is (= 2 2)))
20.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
20.2+++ b/src/tests/clients/web.lisp Mon Jun 05 19:59:26 2023 -0400
20.3@@ -0,0 +1,7 @@
20.4+(in-package #:demo-tests)
20.5+
20.6+(def-suite* :demo.web
20.7+ :in :demo)
20.8+
20.9+(test web.index
20.10+ (is (= 2 2)))
21.1--- a/src/tests/demo_test.c Sun Jun 04 00:56:02 2023 -0400
21.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
21.3@@ -1,8 +0,0 @@
21.4-#include <stdio.h>
21.5-#include "demo.h"
21.6-
21.7-int main() {
21.8- Service *srv = service_from_string("weather");
21.9- printf!("%s\n",service_to_json_str(srv));
21.10- free_service(srv);
21.11-}
22.1--- a/src/tests/demo_test.py Sun Jun 04 00:56:02 2023 -0400
22.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
22.3@@ -1,1 +0,0 @@
22.4-from _demo import lib
23.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
23.2+++ b/src/tests/package.lisp Mon Jun 05 19:59:26 2023 -0400
23.3@@ -0,0 +1,11 @@
23.4+(defpackage #:demo-tests
23.5+ (:use #:demo #:fiveam)
23.6+ (:shadowing-import-from #:fiveam #:test)
23.7+ (:export #:run-tests))
23.8+
23.9+(in-package #:demo-tests)
23.10+
23.11+(def-suite :demo)
23.12+
23.13+(defun run-tests ()
23.14+ (run! :demo))
24.1--- a/src/tests/prime-test.lisp Sun Jun 04 00:56:02 2023 -0400
24.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
24.3@@ -1,67 +0,0 @@
24.4-;; (defun is-prime(n)
24.5-;; (do ((num 2 (+ num 1)))
24.6-;; ((> num (/ n 2)) t)
24.7-;; (if (= 0 (mod n num))
24.8-;; (return-from is-prime nil))))
24.9-
24.10-;; (defun kth-prime(k)
24.11-;; (do ((candidate 2 (+ candidate 1)))
24.12-;; ((< k 1) (- candidate 1))
24.13-;; (when (is-prime candidate)
24.14-;; (decf k))))
24.15-
24.16-;; (time (kth-prime 10000))
24.17-
24.18-;; (declaim (inline is-prime))
24.19-;; (defun is-prime (n)
24.20-;; (loop for num of-type fixnum from 3 to (isqrt n) by 2
24.21-;; when (zerop (mod n num))
24.22-;; return nil
24.23-;; finally (return t)))
24.24-
24.25-;; (defun kth-prime (k)
24.26-;; (declare (optimize (speed 3) (safety 0))
24.27-;; (fixnum k))
24.28-;; (if (zerop k)
24.29-;; 2
24.30-;; (loop for candidate of-type fixnum from 3 by 2
24.31-;; when (<= k 0) return (- candidate 2)
24.32-;; when (is-prime candidate) do (decf k))))
24.33-
24.34-;; (declaim
24.35-;; (optimize (speed 3) (safety 0))
24.36-;; (inline is-prime))
24.37-
24.38-;; (defun is-prime(n)
24.39-;; (declare (fixnum n))
24.40-;; (do ((num 2 (+ num 1)))
24.41-;; ((> num (floor n 2)) t)
24.42-;; (declare (fixnum num))
24.43-;; (if (= 0 (mod n num))
24.44-;; (return-from is-prime nil))))
24.45-
24.46-;; (defun kth-prime(k)
24.47-;; (declare (fixnum k))
24.48-;; (do ((candidate 2 (+ candidate 1)))
24.49-;; ((< k 1) (- candidate 1))
24.50-;; (declare (fixnum candidate))
24.51-;; (when (is-prime candidate)
24.52-;; (decf k))))
24.53-
24.54-;; (time (kth-prime 10000))
24.55-
24.56-(declaim (inline is-prime))
24.57-(defun is-prime (n)
24.58- (loop for num of-type fixnum from 2 to (ash n -1)
24.59- when (zerop (mod n num))
24.60- return nil
24.61- finally (return t)))
24.62-
24.63-(defun kth-prime (k)
24.64- (declare (optimize (speed 3) (safety 0))
24.65- (fixnum k))
24.66- (loop for candidate of-type fixnum from 2
24.67- when (<= k 0) return (1- candidate)
24.68- when (is-prime candidate) do (decf k)))
24.69-
24.70-(time (kth-prime 10000))
26.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
26.2+++ b/src/tests/utils.lisp Mon Jun 05 19:59:26 2023 -0400
26.3@@ -0,0 +1,46 @@
26.4+(in-package #:demo-tests)
26.5+
26.6+(def-suite* :demo.utils
26.7+ :in :demo)
26.8+
26.9+(defun gen-word ()
26.10+ (gen-one-element "lorem" "ipsum"))
26.11+
26.12+(defun gen-text-element ()
26.13+ (let ((word (gen-word)))
26.14+ (lambda ()
26.15+ (case (random 10)
26.16+ (9 #\Newline)
26.17+ (t (funcall word))))))
26.18+
26.19+(defun gen-text (&key (length (gen-integer :min 1 :max 20))
26.20+ (element (gen-text-element)))
26.21+ (let ((elements (gen-list :length length :elements element)))
26.22+ (lambda ()
26.23+ (with-output-to-string (stream)
26.24+ (loop for previous = nil then element
26.25+ for element in (funcall elements)
26.26+ do (cond ((and previous (not (eql previous #\Newline)) (not (eql element #\Newline)))
26.27+ (write-char #\Space stream)
26.28+ (write-string element stream))
26.29+ (t ; (and (eql previous #\Newline) (not (eql element #\Newline)))
26.30+ (princ element stream))))))))
26.31+
26.32+(defun gen-offset (&key (integer (gen-integer :min -10 :max 10)))
26.33+ (lambda ()
26.34+ (case (random 10)
26.35+ ((8 9 10) nil)
26.36+ (t (funcall integer)))))
26.37+
26.38+(defun gen-margin (&key (integer (gen-integer :min 1 :max 10)))
26.39+ (lambda ()
26.40+ (case (random 10)
26.41+ ((8 9 10) nil)
26.42+ (t (funcall integer)))))
26.43+
26.44+(defun gen-count (&key (integer (gen-integer :min 1 :max 10)))
26.45+ (lambda ()
26.46+ (case (random 10)
26.47+ ((8 9 10) nil)
26.48+ (t (funcall integer)))))
26.49+
27.1--- a/src/tk.lisp Sun Jun 04 00:56:02 2023 -0400
27.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
27.3@@ -1,28 +0,0 @@
27.4-(in-package :demo)
27.5-
27.6-(defun mkstr (&rest args)
27.7- (with-output-to-string (s)
27.8- (dolist (a args) (princ a s))))
27.9-
27.10-(defun symb (&rest args)
27.11- (values (intern (apply #'mkstr args))))
27.12-
27.13-(defun random-id ()
27.14- (format NIL "~8,'0x-~8,'0x" (random #xFFFFFFFF) (get-universal-time)))
27.15-
27.16-(defun scan-dir (dir filename callback)
27.17- (dolist (path (directory (merge-pathnames (merge-pathnames filename "**/") dir)))
27.18- (funcall callback path)))
27.19-
27.20-(defun sbq-reader (stream sub-char numarg)
27.21- "The anaphoric sharp-backquote reader: #`((,a1))"
27.22- (declare (ignore sub-char))
27.23- (unless numarg (setq numarg 1))
27.24- `(lambda ,(loop for i from 1 to numarg
27.25- collect (symb 'a i))
27.26- ,(funcall
27.27- (get-macro-character #\`) stream nil)))
27.28-
27.29-(eval-when (:load-toplevel)
27.30- (set-dispatch-macro-character
27.31- #\# #\` #'demo:sbq-reader))
28.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
28.2+++ b/src/tk/rs.lisp Mon Jun 05 19:59:26 2023 -0400
28.3@@ -0,0 +1,78 @@
28.4+;;; RUST DSL
28.5+
28.6+;; So basically, this was born out of personal frustration with how
28.7+;; cbindgen and Rust macros work (they don't). Rust macros in general
28.8+;; are something of a pain in my opinion, so I thought why not just
28.9+;; generate Rust code from Lisp instead?
28.10+
28.11+(in-package :demo)
28.12+
28.13+(defvar *cargo-target* #p"/Users/ellis/dev/otom8/demo/target/")
28.14+(defvar *rs-macros* nil)
28.15+
28.16+;; TODO gensyms
28.17+(defmacro rs-defmacro (name args &body body)
28.18+ "Define a macro which can be used within the body of a 'with-rs' form."
28.19+ `(prog1
28.20+ (defmacro ,name ,@(mapcar #`(,a1) args) ,@body)
28.21+ (push ',name *rs-macros*)))
28.22+
28.23+(defun rs-mod-form (crate &optional mods pub)
28.24+ "Generate a basic mod form (CRATE . [MODS] [PUB])"
28.25+ `(,crate ,mods ,pub))
28.26+
28.27+(defmacro with-rs-env (imports &body body)
28.28+ "Generate an environment for use within a Rust generator macro."
28.29+ `(let ((imports ,(mapcar #'rs-mod-form imports)))
28.30+ (format nil "~A~&~A" imports ',body)))
28.31+
28.32+(defun rs-use (crate &optional mods pub)
28.33+ "Generate a single Rust use statement."
28.34+ (concatenate
28.35+ 'string
28.36+ (if pub "pub " "")
28.37+ "use " crate "::{"
28.38+ (cond
28.39+ ((consp mods)
28.40+ (reduce
28.41+ (lambda (x y) (format nil "~A,~A" x y))
28.42+ mods))
28.43+ (t mods))
28.44+ "};"))
28.45+
28.46+(defun rs-mod (mod &optional pub)
28.47+ "Generate a single Rust mod statement."
28.48+ (concatenate
28.49+ 'string
28.50+ (if pub "pub " "")
28.51+ "mod " mod ";"))
28.52+
28.53+(defun rs-imports (&rest imports)
28.54+ "Generate a string of Rust 'use' statements."
28.55+ (cond
28.56+ ((consp imports)
28.57+ (mapcar (lambda (x) (apply #'rs-use (apply #'rs-mod-form x))) imports))
28.58+ (t imports)))
28.59+
28.60+(defmacro rs-extern-c-fn (name args &optional pub unsafe no-mangle &body body)
28.61+ "Generate a Rust extern 'C' fn."
28.62+ `(concatenate
28.63+ 'string
28.64+ ,(when no-mangle (format nil "#[no_mangle]~&"))
28.65+ ,(when pub "pub ")
28.66+ ,(when unsafe "unsafe ")
28.67+ "extern \"C\" fn " ,name "("
28.68+ ,(cond
28.69+ ((consp args) (reduce (lambda (x y) (format nil "~A,~A" x y)) args))
28.70+ (t args))
28.71+ ")" "{" ,@body "}"))
28.72+
28.73+(defun rs-obj-impl (obj)
28.74+ "Implement Objective for give OBJ."
28.75+ (format nil "impl Objective for ~A {};" obj))
28.76+
28.77+;; (defun rs-macroexpand-1 (form &optional env))
28.78+
28.79+;; (defun rs-macroexpand (env &rest body)
28.80+
28.81+;;;
29.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
29.2+++ b/src/tk/tk.lisp Mon Jun 05 19:59:26 2023 -0400
29.3@@ -0,0 +1,28 @@
29.4+(in-package :demo)
29.5+
29.6+(defun mkstr (&rest args)
29.7+ (with-output-to-string (s)
29.8+ (dolist (a args) (princ a s))))
29.9+
29.10+(defun symb (&rest args)
29.11+ (values (intern (apply #'mkstr args))))
29.12+
29.13+(defun random-id ()
29.14+ (format NIL "~8,'0x-~8,'0x" (random #xFFFFFFFF) (get-universal-time)))
29.15+
29.16+(defun scan-dir (dir filename callback)
29.17+ (dolist (path (directory (merge-pathnames (merge-pathnames filename "**/") dir)))
29.18+ (funcall callback path)))
29.19+
29.20+(defun sbq-reader (stream sub-char numarg)
29.21+ "The anaphoric sharp-backquote reader: #`((,a1))"
29.22+ (declare (ignore sub-char))
29.23+ (unless numarg (setq numarg 1))
29.24+ `(lambda ,(loop for i from 1 to numarg
29.25+ collect (symb 'a i))
29.26+ ,(funcall
29.27+ (get-macro-character #\`) stream nil)))
29.28+
29.29+(eval-when (:load-toplevel)
29.30+ (set-dispatch-macro-character
29.31+ #\# #\` #'demo:sbq-reader))
30.1--- a/src/ui.lisp Sun Jun 04 00:56:02 2023 -0400
30.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
30.3@@ -1,43 +0,0 @@
30.4-(in-package :demo)
30.5-
30.6-(defparameter ui-server-port 8080)
30.7-(defparameter ui-server-host "0.0.0.0")
30.8-
30.9-(defclass ui-element (clog-element) ()
30.10- (:documentation "UI Element Object."))
30.11-
30.12-(defgeneric create-ui-element (obj &key hidden class id mode)
30.13- (:documentation "Create a new ui-element as a child of OBJ."))
30.14-(defmethod create-ui-element ((obj clog:clog-obj)
30.15- &key (class nil)
30.16- (hidden nil)
30.17- (id nil)
30.18- (mode 'auto))
30.19- (let ((new (clog:create-div obj
30.20- :class class
30.21- :hidden hidden
30.22- :id id
30.23- :mode mode)))
30.24- (clog:set-geometry new :width 200 :height 100)
30.25- (change-class new 'ui-element)))
30.26-
30.27-(defun on-new-window (body)
30.28- "Handle new window event."
30.29- (clog:debug-mode body)
30.30- (let ((elt (clog:create-child body "<h1>foobar</h1>")))
30.31- (clog:set-on-click
30.32- elt
30.33- (lambda (o)
30.34- (setf (clog:color elt) "green")))))
30.35-
30.36-(defun start-ui ()
30.37- "Start the UI."
30.38- (clog:initialize #'on-new-window
30.39- :extended-routing t
30.40- :host ui-server-host
30.41- :port ui-server-port)
30.42- (clog:open-browser))
30.43-
30.44-(defun stop-ui ()
30.45- "Stop the UI."
30.46- (clog:shutdown))
31.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
31.2+++ b/src/ui/ui.lisp Mon Jun 05 19:59:26 2023 -0400
31.3@@ -0,0 +1,43 @@
31.4+(in-package :demo)
31.5+
31.6+(defparameter ui-server-port 8080)
31.7+(defparameter ui-server-host "0.0.0.0")
31.8+
31.9+(defclass ui-element (clog-element) ()
31.10+ (:documentation "UI Element Object."))
31.11+
31.12+(defgeneric create-ui-element (obj &key hidden class id mode)
31.13+ (:documentation "Create a new ui-element as a child of OBJ."))
31.14+(defmethod create-ui-element ((obj clog:clog-obj)
31.15+ &key (class nil)
31.16+ (hidden nil)
31.17+ (id nil)
31.18+ (mode 'auto))
31.19+ (let ((new (clog:create-div obj
31.20+ :class class
31.21+ :hidden hidden
31.22+ :id id
31.23+ :mode mode)))
31.24+ (clog:set-geometry new :width 200 :height 100)
31.25+ (change-class new 'ui-element)))
31.26+
31.27+(defun on-new-window (body)
31.28+ "Handle new window event."
31.29+ (clog:debug-mode body)
31.30+ (let ((elt (clog:create-child body "<h1>foobar</h1>")))
31.31+ (clog:set-on-click
31.32+ elt
31.33+ (lambda (o)
31.34+ (setf (clog:color elt) "green")))))
31.35+
31.36+(defun start-ui ()
31.37+ "Start the UI."
31.38+ (clog:initialize #'on-new-window
31.39+ :extended-routing t
31.40+ :host ui-server-host
31.41+ :port ui-server-port)
31.42+ (clog:open-browser))
31.43+
31.44+(defun stop-ui ()
31.45+ "Stop the UI."
31.46+ (clog:shutdown))
32.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
32.2+++ b/tools/asdf.lisp Mon Jun 05 19:59:26 2023 -0400
32.3@@ -0,0 +1,13987 @@
32.4+;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; Package: CL-USER ; buffer-read-only: t; -*-
32.5+;;; This is ASDF 3.3.6: Another System Definition Facility.
32.6+;;;
32.7+;;; Feedback, bug reports, and patches are all welcome:
32.8+;;; please mail to <asdf-devel@common-lisp.net>.
32.9+;;; Note first that the canonical source for ASDF is presently
32.10+;;; <URL:http://common-lisp.net/project/asdf/>.
32.11+;;;
32.12+;;; If you obtained this copy from anywhere else, and you experience
32.13+;;; trouble using it, or find bugs, you may want to check at the
32.14+;;; location above for a more recent version (and for documentation
32.15+;;; and test files, if your copy came without them) before reporting
32.16+;;; bugs. There are usually two "supported" revisions - the git master
32.17+;;; branch is the latest development version, whereas the git release
32.18+;;; branch may be slightly older but is considered `stable'
32.19+
32.20+;;; -- LICENSE START
32.21+;;; (This is the MIT / X Consortium license as taken from
32.22+;;; http://www.opensource.org/licenses/mit-license.html on or about
32.23+;;; Monday; July 13, 2009)
32.24+;;;
32.25+;;; Copyright (c) 2001-2019 Daniel Barlow and contributors
32.26+;;;
32.27+;;; Permission is hereby granted, free of charge, to any person obtaining
32.28+;;; a copy of this software and associated documentation files (the
32.29+;;; "Software"), to deal in the Software without restriction, including
32.30+;;; without limitation the rights to use, copy, modify, merge, publish,
32.31+;;; distribute, sublicense, and/or sell copies of the Software, and to
32.32+;;; permit persons to whom the Software is furnished to do so, subject to
32.33+;;; the following conditions:
32.34+;;;
32.35+;;; The above copyright notice and this permission notice shall be
32.36+;;; included in all copies or substantial portions of the Software.
32.37+;;;
32.38+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
32.39+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
32.40+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
32.41+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
32.42+;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
32.43+;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
32.44+;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
32.45+;;;
32.46+;;; -- LICENSE END
32.47+
32.48+;;; The problem with writing a defsystem replacement is bootstrapping:
32.49+;;; we can't use defsystem to compile it. Hence, all in one file.
32.50+
32.51+#+genera
32.52+(eval-when (:compile-toplevel :load-toplevel :execute)
32.53+ (multiple-value-bind (system-major system-minor)
32.54+ (sct:get-system-version)
32.55+ (multiple-value-bind (is-major is-minor)
32.56+ (sct:get-system-version "Intel-Support")
32.57+ (unless (or (> system-major 452)
32.58+ (and is-major
32.59+ (or (> is-major 3)
32.60+ (and (= is-major 3) (> is-minor 86)))))
32.61+ (error "ASDF requires either System 453 or later or Intel Support 3.87 or later")))))
32.62+;;;; ---------------------------------------------------------------------------
32.63+;;;; ASDF package upgrade, including implementation-dependent magic.
32.64+;;
32.65+;; See https://bugs.launchpad.net/asdf/+bug/485687
32.66+;;
32.67+
32.68+;; CAUTION: The definition of the UIOP/PACKAGE package MUST NOT CHANGE,
32.69+;; NOT NOW, NOT EVER, NOT UNDER ANY CIRCUMSTANCE. NEVER.
32.70+;; ... and the same goes for UIOP/PACKAGE-LOCAL-NICKNAMES.
32.71+;;
32.72+;; The entire point of UIOP/PACKAGE is to address the fact that the CL standard
32.73+;; *leaves it unspecified what happens when a package is redefined incompatibly*.
32.74+;; For instance, SBCL 1.4.2 will signal a full WARNING when this happens,
32.75+;; throwing a wrench in upgrading code with ASDF itself, while continuing to
32.76+;; export old symbols it now shouldn't as it also exports new ones,
32.77+;; causing problems with code that relies on the new/current exports.
32.78+;; CLISP and CCL also exports both sets of symbols, though without any WARNING.
32.79+;; ABCL 1.6.1 will plainly ignore the new definition.
32.80+;; Other implementations may do whatever they want and change their behavior at any time.
32.81+;; ***Using DEFPACKAGE twice with different definitions is nasal-demon territory.***
32.82+;;
32.83+;; Thus we define UIOP/PACKAGE:DEFINE-PACKAGE with which packages can be defined
32.84+;; in an upgrade-friendly way: the new definition is authoritative, and
32.85+;; the package will define and export exactly those symbols in the new definition,
32.86+;; no more and no fewer, whereas it is well-defined what happens to previous symbols.
32.87+;; However, for obvious bootstrap reasons, we cannot use DEFINE-PACKAGE
32.88+;; to define UIOP/PACKAGE itself, only DEFPACKAGE.
32.89+;; Therefore, unlike the other packages in ASDF, UIOP/PACKAGE is immutable,
32.90+;; now and forever. It is frozen for the aeons to come, like the CL package itself,
32.91+;; to the same exact state it was defined at its inception, in ASDF 2.27 in 2013.
32.92+;; The same goes for UIOP/PACKAGE-LOCAL-NICKNAMES, that we use internally.
32.93+;;
32.94+;; If you ever must define new symbols in this file, you can and must
32.95+;; export them from a different package, possibly defined in the same file,
32.96+;; say a package UIOP/PACKAGE* defined at the end of this file with DEFINE-PACKAGE,
32.97+;; that might use :import-from to import the symbols from UIOP/PACKAGE,
32.98+;; if you must somehow define them in UIOP/PACKAGE.
32.99+
32.100+(defpackage :uiop/package ;;; THOU SHALT NOT modify this definition, EVER. See explanations above.
32.101+ (:use :common-lisp)
32.102+ (:export
32.103+ #:find-package* #:find-symbol* #:symbol-call
32.104+ #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
32.105+ #:symbol-shadowing-p #:home-package-p
32.106+ #:symbol-package-name #:standard-common-lisp-symbol-p
32.107+ #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
32.108+ #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol
32.109+ #:ensure-package-unused #:delete-package*
32.110+ #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
32.111+ #:package-definition-form #:parse-define-package-form
32.112+ #:ensure-package #:define-package
32.113+ ))
32.114+
32.115+(in-package :uiop/package)
32.116+
32.117+;;; package local nicknames feature.
32.118+;;; This can't be deferred until common-lisp.lisp, where most such features are set.
32.119+;;; ABCL and CCL already define this feature appropriately.
32.120+;;; Seems to be unconditionally present for SBCL, ACL, and CLASP
32.121+;;; Don't know about ECL, or others
32.122+(eval-when (:load-toplevel :compile-toplevel :execute)
32.123+ ;; ABCL pushes :package-local-nicknames without UIOP interfering,
32.124+ ;; and Lispworks will do so
32.125+ #+(or sbcl clasp)
32.126+ (pushnew :package-local-nicknames *features*)
32.127+ #+allegro
32.128+ (let ((fname (find-symbol (symbol-name '#:add-package-local-nickname) '#:excl)))
32.129+ (when (and fname (fboundp fname))
32.130+ (pushnew :package-local-nicknames *features*))))
32.131+
32.132+;;; THOU SHALT NOT modify this definition, EVER, *EXCEPT* to add a new implementation.
32.133+;; If you somehow need to modify the API in any way,
32.134+;; you will need to create another, differently named, and just as immutable package.
32.135+#+package-local-nicknames
32.136+(defpackage :uiop/package-local-nicknames
32.137+ (:use :cl)
32.138+ (:import-from
32.139+ #+allegro #:excl
32.140+ #+sbcl #:sb-ext
32.141+ #+(or clasp abcl ecl) #:ext
32.142+ #+ccl #:ccl
32.143+ #+lispworks #:hcl
32.144+ #-(or allegro sbcl clasp abcl ccl lispworks ecl)
32.145+ (error "Don't know from which package this lisp supplies the local-package-nicknames API.")
32.146+ #:remove-package-local-nickname #:package-local-nicknames #:add-package-local-nickname)
32.147+ (:export
32.148+ #:add-package-local-nickname #:remove-package-local-nickname #:package-local-nicknames))
32.149+
32.150+;;;; General purpose package utilities
32.151+
32.152+(eval-when (:load-toplevel :compile-toplevel :execute)
32.153+ (deftype package-designator () '(and (or package character string symbol) (satisfies find-package)))
32.154+ (define-condition no-such-package-error (type-error)
32.155+ ()
32.156+ (:default-initargs :expected-type 'package-designator)
32.157+ (:report (lambda (c s)
32.158+ (format s "No package named ~a" (string (type-error-datum c))))))
32.159+
32.160+ (defmethod package-designator ((c no-such-package-error))
32.161+ (type-error-datum c))
32.162+
32.163+ (defun find-package* (package-designator &optional (errorp t))
32.164+ "Like CL:FIND-PACKAGE, but by default raises a UIOP:NO-SUCH-PACKAGE-ERROR if the
32.165+ package is not found."
32.166+ (let ((package (find-package package-designator)))
32.167+ (cond
32.168+ (package package)
32.169+ (errorp (error 'no-such-package-error :datum package-designator))
32.170+ (t nil))))
32.171+
32.172+ (defun find-symbol* (name package-designator &optional (error t))
32.173+ "Find a symbol in a package of given string'ified NAME;
32.174+unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
32.175+by letting you supply a symbol or keyword for the name;
32.176+also works well when the package is not present.
32.177+If optional ERROR argument is NIL, return NIL instead of an error
32.178+when the symbol is not found."
32.179+ (block nil
32.180+ (let ((package (find-package* package-designator error)))
32.181+ (when package ;; package error handled by find-package* already
32.182+ (multiple-value-bind (symbol status) (find-symbol (string name) package)
32.183+ (cond
32.184+ (status (return (values symbol status)))
32.185+ (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
32.186+ (values nil nil))))
32.187+ (defun symbol-call (package name &rest args)
32.188+ "Call a function associated with symbol of given name in given package,
32.189+with given ARGS. Useful when the call is read before the package is loaded,
32.190+or when loading the package is optional."
32.191+ (apply (find-symbol* name package) args))
32.192+ (defun intern* (name package-designator &optional (error t))
32.193+ (intern (string name) (find-package* package-designator error)))
32.194+ (defun export* (name package-designator)
32.195+ (let* ((package (find-package* package-designator))
32.196+ (symbol (intern* name package)))
32.197+ (export (or symbol (list symbol)) package)))
32.198+ (defun import* (symbol package-designator)
32.199+ (import (or symbol (list symbol)) (find-package* package-designator)))
32.200+ (defun shadowing-import* (symbol package-designator)
32.201+ (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
32.202+ (defun shadow* (name package-designator)
32.203+ (shadow (list (string name)) (find-package* package-designator)))
32.204+ (defun make-symbol* (name)
32.205+ (etypecase name
32.206+ (string (make-symbol name))
32.207+ (symbol (copy-symbol name))))
32.208+ (defun unintern* (name package-designator &optional (error t))
32.209+ (block nil
32.210+ (let ((package (find-package* package-designator error)))
32.211+ (when package
32.212+ (multiple-value-bind (symbol status) (find-symbol* name package error)
32.213+ (cond
32.214+ (status (unintern symbol package)
32.215+ (return (values symbol status)))
32.216+ (error (error "symbol ~A not present in package ~A"
32.217+ (string symbol) (package-name package))))))
32.218+ (values nil nil))))
32.219+ (defun symbol-shadowing-p (symbol package)
32.220+ (and (member symbol (package-shadowing-symbols package)) t))
32.221+ (defun home-package-p (symbol package)
32.222+ (and package (let ((sp (symbol-package symbol)))
32.223+ (and sp (let ((pp (find-package* package)))
32.224+ (and pp (eq sp pp))))))))
32.225+
32.226+
32.227+(eval-when (:load-toplevel :compile-toplevel :execute)
32.228+ (defun symbol-package-name (symbol)
32.229+ (let ((package (symbol-package symbol)))
32.230+ (and package (package-name package))))
32.231+ (defun standard-common-lisp-symbol-p (symbol)
32.232+ (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
32.233+ (and (eq sym symbol) (eq status :external))))
32.234+ (defun reify-package (package &optional package-context)
32.235+ (if (eq package package-context) t
32.236+ (etypecase package
32.237+ (null nil)
32.238+ ((eql (find-package :cl)) :cl)
32.239+ (package (package-name package)))))
32.240+ (defun unreify-package (package &optional package-context)
32.241+ (etypecase package
32.242+ (null nil)
32.243+ ((eql t) package-context)
32.244+ ((or symbol string) (find-package package))))
32.245+ (defun reify-symbol (symbol &optional package-context)
32.246+ (etypecase symbol
32.247+ ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
32.248+ (symbol (vector (symbol-name symbol)
32.249+ (reify-package (symbol-package symbol) package-context)))))
32.250+ (defun unreify-symbol (symbol &optional package-context)
32.251+ (etypecase symbol
32.252+ (symbol symbol)
32.253+ ((simple-vector 2)
32.254+ (let* ((symbol-name (svref symbol 0))
32.255+ (package-foo (svref symbol 1))
32.256+ (package (unreify-package package-foo package-context)))
32.257+ (if package (intern* symbol-name package)
32.258+ (make-symbol* symbol-name)))))))
32.259+
32.260+(eval-when (:load-toplevel :compile-toplevel :execute)
32.261+ (defvar *all-package-happiness* '())
32.262+ (defvar *all-package-fishiness* (list t))
32.263+ (defun record-fishy (info)
32.264+ ;;(format t "~&FISHY: ~S~%" info)
32.265+ (push info *all-package-fishiness*))
32.266+ (defmacro when-package-fishiness (&body body)
32.267+ `(when *all-package-fishiness* ,@body))
32.268+ (defmacro note-package-fishiness (&rest info)
32.269+ `(when-package-fishiness (record-fishy (list ,@info)))))
32.270+
32.271+(eval-when (:load-toplevel :compile-toplevel :execute)
32.272+ #+(or clisp clozure)
32.273+ (defun get-setf-function-symbol (symbol)
32.274+ #+clisp (let ((sym (get symbol 'system::setf-function)))
32.275+ (if sym (values sym :setf-function)
32.276+ (let ((sym (get symbol 'system::setf-expander)))
32.277+ (if sym (values sym :setf-expander)
32.278+ (values nil nil)))))
32.279+ #+clozure (gethash symbol ccl::%setf-function-names%))
32.280+ #+(or clisp clozure)
32.281+ (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
32.282+ #+clisp (assert (member kind '(:setf-function :setf-expander)))
32.283+ #+clozure (assert (eq kind t))
32.284+ #+clisp
32.285+ (cond
32.286+ ((null new-setf-symbol)
32.287+ (remprop symbol 'system::setf-function)
32.288+ (remprop symbol 'system::setf-expander))
32.289+ ((eq kind :setf-function)
32.290+ (setf (get symbol 'system::setf-function) new-setf-symbol))
32.291+ ((eq kind :setf-expander)
32.292+ (setf (get symbol 'system::setf-expander) new-setf-symbol))
32.293+ (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
32.294+ kind symbol new-setf-symbol)))
32.295+ #+clozure
32.296+ (progn
32.297+ (gethash symbol ccl::%setf-function-names%) new-setf-symbol
32.298+ (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
32.299+ #+(or clisp clozure)
32.300+ (defun create-setf-function-symbol (symbol)
32.301+ #+clisp (system::setf-symbol symbol)
32.302+ #+clozure (ccl::construct-setf-function-name symbol))
32.303+ (defun set-dummy-symbol (symbol reason other-symbol)
32.304+ (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
32.305+ (defun make-dummy-symbol (symbol)
32.306+ (let ((dummy (copy-symbol symbol)))
32.307+ (set-dummy-symbol dummy 'replacing symbol)
32.308+ (set-dummy-symbol symbol 'replaced-by dummy)
32.309+ dummy))
32.310+ (defun dummy-symbol (symbol)
32.311+ (get symbol 'dummy-symbol))
32.312+ (defun get-dummy-symbol (symbol)
32.313+ (let ((existing (dummy-symbol symbol)))
32.314+ (if existing (values (cdr existing) (car existing))
32.315+ (make-dummy-symbol symbol))))
32.316+ (defun nuke-symbol-in-package (symbol package-designator)
32.317+ (let ((package (find-package* package-designator))
32.318+ (name (symbol-name symbol)))
32.319+ (multiple-value-bind (sym stat) (find-symbol name package)
32.320+ (when (and (member stat '(:internal :external)) (eq symbol sym))
32.321+ (if (symbol-shadowing-p symbol package)
32.322+ (shadowing-import* (get-dummy-symbol symbol) package)
32.323+ (unintern* symbol package))))))
32.324+ (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
32.325+ #+(or clisp clozure)
32.326+ (multiple-value-bind (setf-symbol kind)
32.327+ (get-setf-function-symbol symbol)
32.328+ (when kind (nuke-symbol setf-symbol)))
32.329+ (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
32.330+ (defun rehome-symbol (symbol package-designator)
32.331+ "Changes the home package of a symbol, also leaving it present in its old home if any"
32.332+ (let* ((name (symbol-name symbol))
32.333+ (package (find-package* package-designator))
32.334+ (old-package (symbol-package symbol))
32.335+ (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
32.336+ (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
32.337+ (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
32.338+ (unless (eq package old-package)
32.339+ (let ((overwritten-symbol-shadowing-p
32.340+ (and overwritten-symbol-status
32.341+ (symbol-shadowing-p overwritten-symbol package))))
32.342+ (note-package-fishiness
32.343+ :rehome-symbol name
32.344+ (when old-package (package-name old-package)) old-status (and shadowing t)
32.345+ (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
32.346+ (when old-package
32.347+ (if shadowing
32.348+ (shadowing-import* shadowing old-package))
32.349+ (unintern* symbol old-package))
32.350+ (cond
32.351+ (overwritten-symbol-shadowing-p
32.352+ (shadowing-import* symbol package))
32.353+ (t
32.354+ (when overwritten-symbol-status
32.355+ (unintern* overwritten-symbol package))
32.356+ (import* symbol package)))
32.357+ (if shadowing
32.358+ (shadowing-import* symbol old-package)
32.359+ (import* symbol old-package))
32.360+ #+(or clisp clozure)
32.361+ (multiple-value-bind (setf-symbol kind)
32.362+ (get-setf-function-symbol symbol)
32.363+ (when kind
32.364+ (let* ((setf-function (fdefinition setf-symbol))
32.365+ (new-setf-symbol (create-setf-function-symbol symbol)))
32.366+ (note-package-fishiness
32.367+ :setf-function
32.368+ name (package-name package)
32.369+ (symbol-name setf-symbol) (symbol-package-name setf-symbol)
32.370+ (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
32.371+ (when (symbol-package setf-symbol)
32.372+ (unintern* setf-symbol (symbol-package setf-symbol)))
32.373+ (setf (fdefinition new-setf-symbol) setf-function)
32.374+ (set-setf-function-symbol new-setf-symbol symbol kind))))
32.375+ #+(or clisp clozure)
32.376+ (multiple-value-bind (overwritten-setf foundp)
32.377+ (get-setf-function-symbol overwritten-symbol)
32.378+ (when foundp
32.379+ (unintern overwritten-setf)))
32.380+ (when (eq old-status :external)
32.381+ (export* symbol old-package))
32.382+ (when (eq overwritten-symbol-status :external)
32.383+ (export* symbol package))))
32.384+ (values overwritten-symbol overwritten-symbol-status))))
32.385+ (defun ensure-package-unused (package)
32.386+ (loop :for p :in (package-used-by-list package) :do
32.387+ (unuse-package package p)))
32.388+ (defun delete-package* (package &key nuke)
32.389+ (let ((p (find-package package)))
32.390+ (when p
32.391+ (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
32.392+ (ensure-package-unused p)
32.393+ (delete-package package))))
32.394+ (defun package-names (package)
32.395+ (cons (package-name package) (package-nicknames package)))
32.396+ (defun packages-from-names (names)
32.397+ (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
32.398+ (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
32.399+ separator
32.400+ (index (random most-positive-fixnum)))
32.401+ (loop :for i :from index
32.402+ :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
32.403+ :thereis (and (not (find-package n)) n)))
32.404+ (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
32.405+ (let ((new-name
32.406+ (apply 'fresh-package-name
32.407+ :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
32.408+ (record-fishy (list :rename-away (package-names p) new-name))
32.409+ (rename-package p new-name))))
32.410+
32.411+
32.412+;;; Communicable representation of symbol and package information
32.413+
32.414+(eval-when (:load-toplevel :compile-toplevel :execute)
32.415+ (defun package-definition-form (package-designator
32.416+ &key (nicknamesp t) (usep t)
32.417+ (shadowp t) (shadowing-import-p t)
32.418+ (exportp t) (importp t) internp (error t))
32.419+ (let* ((package (or (find-package* package-designator error)
32.420+ (return-from package-definition-form nil)))
32.421+ (name (package-name package))
32.422+ (nicknames (package-nicknames package))
32.423+ (use (mapcar #'package-name (package-use-list package)))
32.424+ (shadow ())
32.425+ (shadowing-import (make-hash-table :test 'equal))
32.426+ (import (make-hash-table :test 'equal))
32.427+ (export ())
32.428+ (intern ()))
32.429+ (when package
32.430+ (loop :for sym :being :the :symbols :in package
32.431+ :for status = (nth-value 1 (find-symbol* sym package)) :do
32.432+ (ecase status
32.433+ ((nil :inherited))
32.434+ ((:internal :external)
32.435+ (let* ((name (symbol-name sym))
32.436+ (external (eq status :external))
32.437+ (home (symbol-package sym))
32.438+ (home-name (package-name home))
32.439+ (imported (not (eq home package)))
32.440+ (shadowing (symbol-shadowing-p sym package)))
32.441+ (cond
32.442+ ((and shadowing imported)
32.443+ (push name (gethash home-name shadowing-import)))
32.444+ (shadowing
32.445+ (push name shadow))
32.446+ (imported
32.447+ (push name (gethash home-name import))))
32.448+ (cond
32.449+ (external
32.450+ (push name export))
32.451+ (imported)
32.452+ (t (push name intern)))))))
32.453+ (labels ((sort-names (names)
32.454+ (sort (copy-list names) #'string<))
32.455+ (table-keys (table)
32.456+ (loop :for k :being :the :hash-keys :of table :collect k))
32.457+ (when-relevant (key value)
32.458+ (when value (list (cons key value))))
32.459+ (import-options (key table)
32.460+ (loop :for i :in (sort-names (table-keys table))
32.461+ :collect `(,key ,i ,@(sort-names (gethash i table))))))
32.462+ `(defpackage ,name
32.463+ ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
32.464+ (:use ,@(and usep (sort-names use)))
32.465+ ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
32.466+ ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
32.467+ ,@(import-options :import-from (and importp import))
32.468+ ,@(when-relevant :export (and exportp (sort-names export)))
32.469+ ,@(when-relevant :intern (and internp (sort-names intern)))))))))
32.470+
32.471+
32.472+;;; ensure-package, define-package
32.473+(eval-when (:load-toplevel :compile-toplevel :execute)
32.474+ ;; We already have UIOP:SIMPLE-STYLE-WARNING, but it comes from a later
32.475+ ;; package.
32.476+ (define-condition define-package-style-warning
32.477+ #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning)
32.478+ ())
32.479+ (defun ensure-shadowing-import (name to-package from-package shadowed imported)
32.480+ (check-type name string)
32.481+ (check-type to-package package)
32.482+ (check-type from-package package)
32.483+ (check-type shadowed hash-table)
32.484+ (check-type imported hash-table)
32.485+ (let ((import-me (find-symbol* name from-package)))
32.486+ (multiple-value-bind (existing status) (find-symbol name to-package)
32.487+ (cond
32.488+ ((gethash name shadowed)
32.489+ (unless (eq import-me existing)
32.490+ (error "Conflicting shadowings for ~A" name)))
32.491+ (t
32.492+ (setf (gethash name shadowed) t)
32.493+ (setf (gethash name imported) t)
32.494+ (unless (or (null status)
32.495+ (and (member status '(:internal :external))
32.496+ (eq existing import-me)
32.497+ (symbol-shadowing-p existing to-package)))
32.498+ (note-package-fishiness
32.499+ :shadowing-import name
32.500+ (package-name from-package)
32.501+ (or (home-package-p import-me from-package) (symbol-package-name import-me))
32.502+ (package-name to-package) status
32.503+ (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
32.504+ (shadowing-import* import-me to-package))))))
32.505+ (defun ensure-imported (import-me into-package &optional from-package)
32.506+ (check-type import-me symbol)
32.507+ (check-type into-package package)
32.508+ (check-type from-package (or null package))
32.509+ (let ((name (symbol-name import-me)))
32.510+ (multiple-value-bind (existing status) (find-symbol name into-package)
32.511+ (cond
32.512+ ((not status)
32.513+ (import* import-me into-package))
32.514+ ((eq import-me existing))
32.515+ (t
32.516+ (let ((shadowing-p (symbol-shadowing-p existing into-package)))
32.517+ (note-package-fishiness
32.518+ :ensure-imported name
32.519+ (and from-package (package-name from-package))
32.520+ (or (home-package-p import-me from-package) (symbol-package-name import-me))
32.521+ (package-name into-package)
32.522+ status
32.523+ (and status (or (home-package-p existing into-package) (symbol-package-name existing)))
32.524+ shadowing-p)
32.525+ (cond
32.526+ ((or shadowing-p (eq status :inherited))
32.527+ (shadowing-import* import-me into-package))
32.528+ (t
32.529+ (unintern* existing into-package)
32.530+ (import* import-me into-package))))))))
32.531+ (values))
32.532+ (defun ensure-import (name to-package from-package shadowed imported)
32.533+ (check-type name string)
32.534+ (check-type to-package package)
32.535+ (check-type from-package package)
32.536+ (check-type shadowed hash-table)
32.537+ (check-type imported hash-table)
32.538+ (multiple-value-bind (import-me import-status) (find-symbol name from-package)
32.539+ (when (null import-status)
32.540+ (note-package-fishiness
32.541+ :import-uninterned name (package-name from-package) (package-name to-package))
32.542+ (setf import-me (intern* name from-package)))
32.543+ (multiple-value-bind (existing status) (find-symbol name to-package)
32.544+ (cond
32.545+ ((and imported (gethash name imported))
32.546+ (unless (and status (eq import-me existing))
32.547+ (error "Can't import ~S from both ~S and ~S"
32.548+ name (package-name (symbol-package existing)) (package-name from-package))))
32.549+ ((gethash name shadowed)
32.550+ (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
32.551+ (t
32.552+ (setf (gethash name imported) t))))
32.553+ (ensure-imported import-me to-package from-package)))
32.554+ (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
32.555+ (check-type name string)
32.556+ (check-type symbol symbol)
32.557+ (check-type to-package package)
32.558+ (check-type from-package package)
32.559+ (check-type mixp (member nil t)) ; no cl:boolean on Genera
32.560+ (check-type shadowed hash-table)
32.561+ (check-type imported hash-table)
32.562+ (check-type inherited hash-table)
32.563+ (multiple-value-bind (existing status) (find-symbol name to-package)
32.564+ (let* ((sp (symbol-package symbol))
32.565+ (in (gethash name inherited))
32.566+ (xp (and status (symbol-package existing))))
32.567+ (when (null sp)
32.568+ (note-package-fishiness
32.569+ :import-uninterned name
32.570+ (package-name from-package) (package-name to-package) mixp)
32.571+ (import* symbol from-package)
32.572+ (setf sp (package-name from-package)))
32.573+ (cond
32.574+ ((gethash name shadowed))
32.575+ (in
32.576+ (unless (equal sp (first in))
32.577+ (if mixp
32.578+ (ensure-shadowing-import name to-package (second in) shadowed imported)
32.579+ (error "Can't inherit ~S from ~S, it is inherited from ~S"
32.580+ name (package-name sp) (package-name (first in))))))
32.581+ ((gethash name imported)
32.582+ (unless (eq symbol existing)
32.583+ (error "Can't inherit ~S from ~S, it is imported from ~S"
32.584+ name (package-name sp) (package-name xp))))
32.585+ (t
32.586+ (setf (gethash name inherited) (list sp from-package))
32.587+ (when (and status (not (eq sp xp)))
32.588+ (let ((shadowing (symbol-shadowing-p existing to-package)))
32.589+ (note-package-fishiness
32.590+ :inherited name
32.591+ (package-name from-package)
32.592+ (or (home-package-p symbol from-package) (symbol-package-name symbol))
32.593+ (package-name to-package)
32.594+ (or (home-package-p existing to-package) (symbol-package-name existing)))
32.595+ (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
32.596+ (unintern* existing to-package)))))))))
32.597+ (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
32.598+ (check-type name string)
32.599+ (check-type symbol symbol)
32.600+ (check-type to-package package)
32.601+ (check-type from-package package)
32.602+ (check-type shadowed hash-table)
32.603+ (check-type imported hash-table)
32.604+ (check-type inherited hash-table)
32.605+ (unless (gethash name shadowed)
32.606+ (multiple-value-bind (existing status) (find-symbol name to-package)
32.607+ (let* ((sp (symbol-package symbol))
32.608+ (im (gethash name imported))
32.609+ (in (gethash name inherited)))
32.610+ (cond
32.611+ ((or (null status)
32.612+ (and status (eq symbol existing))
32.613+ (and in (eq sp (first in))))
32.614+ (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
32.615+ (in
32.616+ (remhash name inherited)
32.617+ (ensure-shadowing-import name to-package (second in) shadowed imported))
32.618+ (im
32.619+ (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
32.620+ name (package-name from-package)
32.621+ (home-package-p symbol from-package) (symbol-package-name symbol)
32.622+ (package-name to-package)
32.623+ (home-package-p existing to-package) (symbol-package-name existing)))
32.624+ (t
32.625+ (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
32.626+
32.627+ (defun recycle-symbol (name recycle exported)
32.628+ ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
32.629+ ;; packages, and a hash-table of names (strings) of symbols scheduled to be
32.630+ ;; EXPORTED from the package being defined. It returns two values, the
32.631+ ;; symbol found (if any, or else NIL), and a boolean flag indicating whether
32.632+ ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the
32.633+ ;; re-homing of the symbol, etc.
32.634+ (check-type name string)
32.635+ (check-type recycle list)
32.636+ (check-type exported hash-table)
32.637+ (when (gethash name exported) ;; don't bother recycling private symbols
32.638+ (let (recycled foundp)
32.639+ (dolist (r recycle (values recycled foundp))
32.640+ (multiple-value-bind (symbol status) (find-symbol name r)
32.641+ (when (and status (home-package-p symbol r))
32.642+ (cond
32.643+ (foundp
32.644+ ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
32.645+ (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
32.646+ (t
32.647+ (setf recycled symbol foundp r)))))))))
32.648+ (defun symbol-recycled-p (sym recycle)
32.649+ (check-type sym symbol)
32.650+ (check-type recycle list)
32.651+ (and (member (symbol-package sym) recycle) t))
32.652+ (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
32.653+ (check-type name string)
32.654+ (check-type package package)
32.655+ (check-type intern (member nil t)) ; no cl:boolean on Genera
32.656+ (check-type shadowed hash-table)
32.657+ (check-type imported hash-table)
32.658+ (check-type inherited hash-table)
32.659+ (unless (or (gethash name shadowed)
32.660+ (gethash name imported)
32.661+ (gethash name inherited))
32.662+ (multiple-value-bind (existing status)
32.663+ (find-symbol name package)
32.664+ (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
32.665+ (cond
32.666+ ((and status (eq existing recycled) (eq previous package)))
32.667+ (previous
32.668+ (rehome-symbol recycled package))
32.669+ ((and status (eq package (symbol-package existing))))
32.670+ (t
32.671+ (when status
32.672+ (note-package-fishiness
32.673+ :ensure-symbol name
32.674+ (reify-package (symbol-package existing) package)
32.675+ status intern)
32.676+ (unintern existing))
32.677+ (when intern
32.678+ (intern* name package))))))))
32.679+ (declaim (ftype (function (t t t &optional t) t) ensure-exported))
32.680+ (defun ensure-exported-to-user (name symbol to-package &optional recycle)
32.681+ (check-type name string)
32.682+ (check-type symbol symbol)
32.683+ (check-type to-package package)
32.684+ (check-type recycle list)
32.685+ (assert (equal name (symbol-name symbol)))
32.686+ (multiple-value-bind (existing status) (find-symbol name to-package)
32.687+ (unless (and status (eq symbol existing))
32.688+ (let ((accessible
32.689+ (or (null status)
32.690+ (let ((shadowing (symbol-shadowing-p existing to-package))
32.691+ (recycled (symbol-recycled-p existing recycle)))
32.692+ (unless (and shadowing (not recycled))
32.693+ (note-package-fishiness
32.694+ :ensure-export name (symbol-package-name symbol)
32.695+ (package-name to-package)
32.696+ (or (home-package-p existing to-package) (symbol-package-name existing))
32.697+ status shadowing)
32.698+ (if (or (eq status :inherited) shadowing)
32.699+ (shadowing-import* symbol to-package)
32.700+ (unintern existing to-package))
32.701+ t)))))
32.702+ (when (and accessible (eq status :external))
32.703+ (ensure-exported name symbol to-package recycle))))))
32.704+ (defun ensure-exported (name symbol from-package &optional recycle)
32.705+ (dolist (to-package (package-used-by-list from-package))
32.706+ (ensure-exported-to-user name symbol to-package recycle))
32.707+ (unless (eq from-package (symbol-package symbol))
32.708+ (ensure-imported symbol from-package))
32.709+ (export* name from-package))
32.710+ (defun ensure-export (name from-package &optional recycle)
32.711+ (multiple-value-bind (symbol status) (find-symbol* name from-package)
32.712+ (unless (eq status :external)
32.713+ (ensure-exported name symbol from-package recycle))))
32.714+
32.715+ #+package-local-nicknames
32.716+ (defun install-package-local-nicknames (destination-package new-nicknames)
32.717+ ;; First, remove all package-local nicknames. (We'll reinstall any desired ones later.)
32.718+ (dolist (pair-to-remove (uiop/package-local-nicknames:package-local-nicknames destination-package))
32.719+ (uiop/package-local-nicknames:remove-package-local-nickname
32.720+ (string (car pair-to-remove)) destination-package))
32.721+ ;; Then, install all desired nicknames.
32.722+ (loop :for (nickname package) :in new-nicknames
32.723+ :do (uiop/package-local-nicknames:add-package-local-nickname
32.724+ (string nickname)
32.725+ (find-package package)
32.726+ destination-package)))
32.727+
32.728+ (defun ensure-package (name &key
32.729+ nicknames documentation use
32.730+ shadow shadowing-import-from
32.731+ import-from export intern
32.732+ recycle mix reexport
32.733+ unintern local-nicknames)
32.734+ #+genera (declare (ignore documentation))
32.735+ (let* ((package-name (string name))
32.736+ (nicknames (mapcar #'string nicknames))
32.737+ (names (cons package-name nicknames))
32.738+ (previous (packages-from-names names))
32.739+ (discarded (cdr previous))
32.740+ (to-delete ())
32.741+ (package (or (first previous) (make-package package-name :nicknames nicknames)))
32.742+ (recycle (packages-from-names recycle))
32.743+ (use (mapcar 'find-package* use))
32.744+ (mix (mapcar 'find-package* mix))
32.745+ (reexport (mapcar 'find-package* reexport))
32.746+ (shadow (mapcar 'string shadow))
32.747+ (export (mapcar 'string export))
32.748+ (intern (mapcar 'string intern))
32.749+ (unintern (mapcar 'string unintern))
32.750+ (local-nicknames (mapcar #'(lambda (pair) (mapcar 'string pair)) local-nicknames))
32.751+ (shadowed (make-hash-table :test 'equal)) ; string to bool
32.752+ (imported (make-hash-table :test 'equal)) ; string to bool
32.753+ (exported (make-hash-table :test 'equal)) ; string to bool
32.754+ ;; string to list home package and use package:
32.755+ (inherited (make-hash-table :test 'equal)))
32.756+ #-package-local-nicknames
32.757+ (declare (ignore local-nicknames)) ; if not supported
32.758+ (when-package-fishiness (record-fishy package-name))
32.759+ ;; if supported, put package documentation
32.760+ #-genera
32.761+ (when documentation (setf (documentation package t) documentation))
32.762+ ;; remove unwanted packages from use list
32.763+ (loop :for p :in (set-difference (package-use-list package) (append mix use))
32.764+ :do (note-package-fishiness :over-use name (package-names p))
32.765+ (unuse-package p package))
32.766+ ;; mark unwanted packages for deletion
32.767+ (loop :for p :in discarded
32.768+ :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
32.769+ (package-names p))
32.770+ :do (note-package-fishiness :nickname name (package-names p))
32.771+ (cond (n (rename-package p (first n) (rest n)))
32.772+ (t (rename-package-away p)
32.773+ (push p to-delete))))
32.774+ ;; give package its desired name
32.775+ (rename-package package package-name nicknames)
32.776+ ;; Handle local nicknames
32.777+ #+package-local-nicknames
32.778+ (install-package-local-nicknames package local-nicknames)
32.779+ (dolist (name unintern)
32.780+ (multiple-value-bind (existing status) (find-symbol name package)
32.781+ (when status
32.782+ (unless (eq status :inherited)
32.783+ (note-package-fishiness
32.784+ :unintern (package-name package) name (symbol-package-name existing) status)
32.785+ (unintern* name package nil)))))
32.786+ ;; handle exports
32.787+ (dolist (name export)
32.788+ (setf (gethash name exported) t))
32.789+ ;; handle reexportss
32.790+ (dolist (p reexport)
32.791+ (do-external-symbols (sym p)
32.792+ (setf (gethash (string sym) exported) t)))
32.793+ ;; unexport symbols not listed in (re)export
32.794+ (do-external-symbols (sym package)
32.795+ (let ((name (symbol-name sym)))
32.796+ (unless (gethash name exported)
32.797+ (note-package-fishiness
32.798+ :over-export (package-name package) name
32.799+ (or (home-package-p sym package) (symbol-package-name sym)))
32.800+ (unexport sym package))))
32.801+ ;; handle explicitly listed shadowed ssymbols
32.802+ (dolist (name shadow)
32.803+ (setf (gethash name shadowed) t)
32.804+ (multiple-value-bind (existing status) (find-symbol name package)
32.805+ (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
32.806+ (let ((shadowing (and status (symbol-shadowing-p existing package))))
32.807+ (cond
32.808+ ((eq previous package))
32.809+ (previous
32.810+ (rehome-symbol recycled package))
32.811+ ((or (member status '(nil :inherited))
32.812+ (home-package-p existing package)))
32.813+ (t
32.814+ (let ((dummy (make-symbol name)))
32.815+ (note-package-fishiness
32.816+ :shadow-imported (package-name package) name
32.817+ (symbol-package-name existing) status shadowing)
32.818+ (shadowing-import* dummy package)
32.819+ (import* dummy package)))))))
32.820+ (shadow* name package))
32.821+ ;; handle shadowing imports
32.822+ (loop :for (p . syms) :in shadowing-import-from
32.823+ :for pp = (find-package* p) :do
32.824+ (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
32.825+ ;; handle mixed packages
32.826+ (loop :for p :in mix
32.827+ :for pp = (find-package* p) :do
32.828+ (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
32.829+ ;; handle import-from packages
32.830+ (loop :for (p . syms) :in import-from
32.831+ ;; FOR NOW suppress errors in the case where the :import-from
32.832+ ;; symbol list is empty (used only to establish a dependency by
32.833+ ;; package-inferred-system users).
32.834+ :for pp = (find-package* p syms) :do
32.835+ (when (null pp)
32.836+ ;; TODO: ASDF 3.4 Change to a full warning.
32.837+ (warn 'define-package-style-warning
32.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."
32.839+ :format-arguments (list name p)))
32.840+ (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
32.841+ ;; handle use-list and mix
32.842+ (dolist (p (append use mix))
32.843+ (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
32.844+ (use-package p package))
32.845+ (loop :for name :being :the :hash-keys :of exported :do
32.846+ (ensure-symbol name package t recycle shadowed imported inherited exported)
32.847+ (ensure-export name package recycle))
32.848+ ;; intern dessired symbols
32.849+ (dolist (name intern)
32.850+ (ensure-symbol name package t recycle shadowed imported inherited exported))
32.851+ (do-symbols (sym package)
32.852+ (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
32.853+ ;; delete now-deceased packages
32.854+ (map () 'delete-package* to-delete)
32.855+ package)))
32.856+
32.857+
32.858+(eval-when (:load-toplevel :compile-toplevel :execute)
32.859+ (defun parse-define-package-form (package clauses)
32.860+ (loop
32.861+ :with use-p = nil :with recycle-p = nil
32.862+ :with documentation = nil
32.863+ :for (kw . args) :in clauses
32.864+ :when (eq kw :nicknames) :append args :into nicknames :else
32.865+ :when (eq kw :documentation)
32.866+ :do (cond
32.867+ (documentation (error "define-package: can't define documentation twice"))
32.868+ ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
32.869+ (t (setf documentation (car args)))) :else
32.870+ :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
32.871+ :when (eq kw :shadow) :append args :into shadow :else
32.872+ :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
32.873+ :when (eq kw :import-from) :collect args :into import-from :else
32.874+ :when (eq kw :export) :append args :into export :else
32.875+ :when (eq kw :intern) :append args :into intern :else
32.876+ :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
32.877+ :when (eq kw :mix) :append args :into mix :else
32.878+ :when (eq kw :reexport) :append args :into reexport :else
32.879+ :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
32.880+ :and :do (setf use-p t) :else
32.881+ :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
32.882+ :and :do (setf use-p t) :else
32.883+ :when (eq kw :unintern) :append args :into unintern :else
32.884+ :when (eq kw :local-nicknames)
32.885+ :if (symbol-call '#:uiop '#:featurep :package-local-nicknames)
32.886+ :append args :into local-nicknames
32.887+ :else
32.888+ :do (error ":LOCAL-NICKAMES option is not supported on this lisp implementation.")
32.889+ :end
32.890+ :else
32.891+ :do (error "unrecognized define-package keyword ~S" kw)
32.892+ :finally (return `(',package
32.893+ :nicknames ',nicknames :documentation ',documentation
32.894+ :use ',(if use-p use '(:common-lisp))
32.895+ :shadow ',shadow :shadowing-import-from ',shadowing-import-from
32.896+ :import-from ',import-from :export ',export :intern ',intern
32.897+ :recycle ',(if recycle-p recycle (cons package nicknames))
32.898+ :mix ',mix :reexport ',reexport :unintern ',unintern
32.899+ ,@(when local-nicknames
32.900+ `(:local-nicknames ',local-nicknames)))))))
32.901+
32.902+(defmacro define-package (package &rest clauses)
32.903+ "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
32.904+\(KEYWORD . ARGS\).
32.905+DEFINE-PACKAGE supports the following keywords:
32.906+SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN, NICKNAMES,
32.907+DOCUMENTATION -- as per CL:DEFPACKAGE.
32.908+USE -- as per CL:DEFPACKAGE, but if neither USE, USE-REEXPORT, MIX,
32.909+nor MIX-REEXPORT is supplied, then it is equivalent to specifying
32.910+(:USE :COMMON-LISP). This is unlike CL:DEFPACKAGE for which the
32.911+behavior of a form without USE is implementation-dependent.
32.912+RECYCLE -- Recycle the package's exported symbols from the specified packages,
32.913+in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE,
32.914+either through an :EXPORT option or a :REEXPORT option, if the symbol exists in
32.915+one of the :RECYCLE packages, the first such symbol is re-homed to the package
32.916+being defined.
32.917+For the sake of idempotence, it is important that the package being defined
32.918+should appear in first position if it already exists, and even if it doesn't,
32.919+ahead of any package that is not going to be deleted afterwards and never
32.920+created again. In short, except for special cases, always make it the first
32.921+package on the list if the list is not empty.
32.922+MIX -- Takes a list of package designators. MIX behaves like
32.923+\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
32.924+resolve conflicts in favor of the first found symbol. It may still yield
32.925+an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
32.926+REEXPORT -- Takes a list of package designators. For each package, p, in the list,
32.927+export symbols with the same name as those exported from p. Note that in the case
32.928+of shadowing, etc. the symbols with the same name may not be the same symbols.
32.929+UNINTERN -- Remove symbols here from PACKAGE. Note that this is primarily useful
32.930+when *redefining* a previously-existing package in the current image (e.g., when
32.931+upgrading ASDF). Most programmers will have no use for this option.
32.932+LOCAL-NICKNAMES -- If the host implementation supports package local nicknames
32.933+\(check for the :PACKAGE-LOCAL-NICKNAMES feature\), then this should be a list of
32.934+nickname and package name pairs. Using this option will cause an error if the
32.935+host CL implementation does not support it.
32.936+USE-REEXPORT, MIX-REEXPORT -- Use or mix the specified packages as per the USE or
32.937+MIX directives, and reexport their contents as per the REEXPORT directive."
32.938+ (let ((ensure-form
32.939+ `(prog1
32.940+ (funcall 'ensure-package ,@(parse-define-package-form package clauses))
32.941+ #+sbcl (setf (sb-impl::package-source-location (find-package ',package))
32.942+ (sb-c:source-location)))))
32.943+ `(progn
32.944+ #+(or clasp ecl gcl mkcl) (defpackage ,package (:use))
32.945+ (eval-when (:compile-toplevel :load-toplevel :execute)
32.946+ ,ensure-form))))
32.947+
32.948+;; This package, unlike UIOP/PACKAGE, is allowed to evolve and acquire new symbols or drop old ones.
32.949+(define-package :uiop/package*
32.950+ (:use-reexport :uiop/package
32.951+ #+package-local-nicknames :uiop/package-local-nicknames)
32.952+ (:import-from :uiop/package
32.953+ #:define-package-style-warning
32.954+ #:no-such-package-error
32.955+ #:package-designator)
32.956+ (:export #:define-package-style-warning
32.957+ #:no-such-package-error
32.958+ #:package-designator))
32.959+;;;; -------------------------------------------------------------------------
32.960+;;;; Handle compatibility with multiple implementations.
32.961+;;; This file is for papering over the deficiencies and peculiarities
32.962+;;; of various Common Lisp implementations.
32.963+;;; For implementation-specific access to the system, see os.lisp instead.
32.964+;;; A few functions are defined here, but actually exported from utility;
32.965+;;; from this package only common-lisp symbols are exported.
32.966+
32.967+(uiop/package:define-package :uiop/common-lisp
32.968+ (:nicknames :uiop/cl)
32.969+ (:use :uiop/package)
32.970+ (:use-reexport #-genera :common-lisp #+genera :future-common-lisp)
32.971+ #+allegro (:intern #:*acl-warn-save*)
32.972+ #+cormanlisp (:shadow #:user-homedir-pathname)
32.973+ #+cormanlisp
32.974+ (:export
32.975+ #:logical-pathname #:translate-logical-pathname
32.976+ #:make-broadcast-stream #:file-namestring)
32.977+ #+genera (:shadowing-import-from :scl #:boolean)
32.978+ #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence)
32.979+ #+(or mcl cmucl) (:shadow #:user-homedir-pathname))
32.980+(in-package :uiop/common-lisp)
32.981+
32.982+#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
32.983+(error "ASDF is not supported on your implementation. Please help us port it.")
32.984+
32.985+;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
32.986+
32.987+
32.988+;;;; Early meta-level tweaks
32.989+
32.990+#+(or allegro clasp clisp clozure cmucl ecl lispworks mezzano mkcl sbcl abcl)
32.991+(eval-when (:load-toplevel :compile-toplevel :execute)
32.992+ (when (and #+allegro (member :ics *features*)
32.993+ #+(or clasp clisp cmucl ecl lispworks mkcl) (member :unicode *features*)
32.994+ #+clozure (member :openmcl-unicode-strings *features*)
32.995+ #+sbcl (member :sb-unicode *features*)
32.996+ #+abcl t)
32.997+ ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
32.998+ ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie.
32.999+ (pushnew :asdf-unicode *features*)))
32.1000+
32.1001+#+allegro
32.1002+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1003+ ;; We need to disable autoloading BEFORE any mention of package ASDF.
32.1004+ ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file
32.1005+ ;; or any previous file.
32.1006+ (setf excl::*autoload-package-name-alist*
32.1007+ (remove "asdf" excl::*autoload-package-name-alist*
32.1008+ :test 'equalp :key 'car))
32.1009+ (defparameter *acl-warn-save*
32.1010+ (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
32.1011+ excl:*warn-on-nested-reader-conditionals*))
32.1012+ (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
32.1013+ (setf excl:*warn-on-nested-reader-conditionals* nil))
32.1014+ (setf *print-readably* nil))
32.1015+
32.1016+#+clasp
32.1017+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1018+ (setf *load-verbose* nil)
32.1019+ (defun use-ecl-byte-compiler-p () nil))
32.1020+
32.1021+#+clozure (in-package :ccl)
32.1022+#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117
32.1023+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1024+ (unless (fboundp 'external-process-wait)
32.1025+ (in-development-mode
32.1026+ (defun external-process-wait (proc)
32.1027+ (when (and (external-process-pid proc) (eq (external-process-%status proc) :running))
32.1028+ (with-interrupts-enabled
32.1029+ (wait-on-semaphore (external-process-completed proc))))
32.1030+ (values (external-process-%exit-code proc)
32.1031+ (external-process-%status proc))))))
32.1032+#+clozure (in-package :uiop/common-lisp) ;; back in this package.
32.1033+
32.1034+#+cmucl
32.1035+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1036+ (setf ext:*gc-verbose* nil)
32.1037+ (defun user-homedir-pathname ()
32.1038+ (first (ext:search-list (cl:user-homedir-pathname)))))
32.1039+
32.1040+#+cormanlisp
32.1041+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1042+ (deftype logical-pathname () nil)
32.1043+ (defun make-broadcast-stream () *error-output*)
32.1044+ (defun translate-logical-pathname (x) x)
32.1045+ (defun user-homedir-pathname (&optional host)
32.1046+ (declare (ignore host))
32.1047+ (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
32.1048+ (defun file-namestring (p)
32.1049+ (setf p (pathname p))
32.1050+ (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
32.1051+
32.1052+#+ecl
32.1053+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1054+ (setf *load-verbose* nil)
32.1055+ (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
32.1056+ (unless (use-ecl-byte-compiler-p) (require :cmp)))
32.1057+
32.1058+#+gcl
32.1059+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1060+ (unless (member :ansi-cl *features*)
32.1061+ (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
32.1062+ (setf compiler::*compiler-default-type* (pathname "")
32.1063+ compiler::*lsp-ext* "")
32.1064+ #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later.
32.1065+ (cond
32.1066+ #+gcl
32.1067+ ((or (< system::*gcl-major-version* 2)
32.1068+ (and (= system::*gcl-major-version* 2)
32.1069+ (< system::*gcl-minor-version* 7)))
32.1070+ '(error "GCL 2.7 or later required to use ASDF")))))
32.1071+ (eval code)
32.1072+ code))
32.1073+
32.1074+#+genera
32.1075+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1076+ (unless (fboundp 'lambda)
32.1077+ (defmacro lambda (&whole form &rest bvl-decls-and-body)
32.1078+ (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1))
32.1079+ `#',(cons 'lisp::lambda (cdr form))))
32.1080+ (unless (fboundp 'ensure-directories-exist)
32.1081+ (defun ensure-directories-exist (path)
32.1082+ (fs:create-directories-recursively (pathname path))))
32.1083+ (unless (fboundp 'read-sequence)
32.1084+ (defun read-sequence (sequence stream &key (start 0) end)
32.1085+ (scl:send stream :string-in nil sequence start end)))
32.1086+ (unless (fboundp 'write-sequence)
32.1087+ (defun write-sequence (sequence stream &key (start 0) end)
32.1088+ (scl:send stream :string-out sequence start end)
32.1089+ sequence)))
32.1090+
32.1091+#+lispworks
32.1092+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1093+ ;; lispworks 3 and earlier cannot be checked for so we always assume
32.1094+ ;; at least version 4
32.1095+ (unless (member :lispworks4 *features*)
32.1096+ (pushnew :lispworks5+ *features*)
32.1097+ (unless (member :lispworks5 *features*)
32.1098+ (pushnew :lispworks6+ *features*)
32.1099+ (unless (member :lispworks6 *features*)
32.1100+ (pushnew :lispworks7+ *features*)))))
32.1101+
32.1102+
32.1103+#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
32.1104+ (read-from-string
32.1105+ "(eval-when (:load-toplevel :compile-toplevel :execute)
32.1106+ (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
32.1107+ (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
32.1108+ ;; Note: ASDF may expect user-homedir-pathname to provide
32.1109+ ;; the pathname of the current user's home directory, whereas
32.1110+ ;; MCL by default provides the directory from which MCL was started.
32.1111+ ;; See http://code.google.com/p/mcl/wiki/Portability
32.1112+ (defun user-homedir-pathname ()
32.1113+ (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
32.1114+ (defun probe-posix (posix-namestring)
32.1115+ \"If a file exists for the posix namestring, return the pathname\"
32.1116+ (ccl::with-cstrs ((cpath posix-namestring))
32.1117+ (ccl::rlet ((is-dir :boolean)
32.1118+ (fsref :fsref))
32.1119+ (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
32.1120+ (ccl::%path-from-fsref fsref is-dir))))))"))
32.1121+
32.1122+#+mkcl
32.1123+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1124+ (require :cmp)
32.1125+ (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
32.1126+
32.1127+
32.1128+;;;; compatfmt: avoid fancy format directives when unsupported
32.1129+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1130+ (defun frob-substrings (string substrings &optional frob)
32.1131+ "for each substring in SUBSTRINGS, find occurrences of it within STRING
32.1132+that don't use parts of matched occurrences of previous strings, and
32.1133+FROB them, that is to say, remove them if FROB is NIL,
32.1134+replace by FROB if FROB is a STRING, or if FROB is a FUNCTION,
32.1135+call FROB with the match and a function that emits a string in the output.
32.1136+Return a string made of the parts not omitted or emitted by FROB."
32.1137+ (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3)))
32.1138+ (let ((length (length string)) (stream nil))
32.1139+ (labels ((emit-string (x &optional (start 0) (end (length x)))
32.1140+ (when (< start end)
32.1141+ (unless stream (setf stream (make-string-output-stream)))
32.1142+ (write-string x stream :start start :end end)))
32.1143+ (emit-substring (start end)
32.1144+ (when (and (zerop start) (= end length))
32.1145+ (return-from frob-substrings string))
32.1146+ (emit-string string start end))
32.1147+ (recurse (substrings start end)
32.1148+ (cond
32.1149+ ((>= start end))
32.1150+ ((null substrings) (emit-substring start end))
32.1151+ (t (let* ((sub-spec (first substrings))
32.1152+ (sub (if (consp sub-spec) (car sub-spec) sub-spec))
32.1153+ (fun (if (consp sub-spec) (cdr sub-spec) frob))
32.1154+ (found (search sub string :start2 start :end2 end))
32.1155+ (more (rest substrings)))
32.1156+ (cond
32.1157+ (found
32.1158+ (recurse more start found)
32.1159+ (etypecase fun
32.1160+ (null)
32.1161+ (string (emit-string fun))
32.1162+ (function (funcall fun sub #'emit-string)))
32.1163+ (recurse substrings (+ found (length sub)) end))
32.1164+ (t
32.1165+ (recurse more start end))))))))
32.1166+ (recurse substrings 0 length))
32.1167+ (if stream (get-output-stream-string stream) "")))
32.1168+
32.1169+ (defmacro compatfmt (format)
32.1170+ #+(or gcl genera)
32.1171+ (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>")))
32.1172+ #-(or gcl genera) format))
32.1173+;;;; -------------------------------------------------------------------------
32.1174+;;;; General Purpose Utilities for ASDF
32.1175+
32.1176+(uiop/package:define-package :uiop/utility
32.1177+ (:use :uiop/common-lisp :uiop/package)
32.1178+ ;; import and reexport a few things defined in :uiop/common-lisp
32.1179+ (:import-from :uiop/common-lisp #:compatfmt #:frob-substrings
32.1180+ #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
32.1181+ (:export #:compatfmt #:frob-substrings #:compatfmt
32.1182+ #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
32.1183+ (:export
32.1184+ ;; magic helper to define debugging functions:
32.1185+ #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
32.1186+ #:with-upgradability ;; (un)defining functions in an upgrade-friendly way
32.1187+ #:nest #:if-let ;; basic flow control
32.1188+ #:parse-body ;; macro definition helper
32.1189+ #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
32.1190+ #:remove-plist-keys #:remove-plist-key ;; plists
32.1191+ #:emptyp ;; sequences
32.1192+ #:+non-base-chars-exist-p+ ;; characters
32.1193+ #:+max-character-type-index+ #:character-type-index #:+character-types+
32.1194+ #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
32.1195+ #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
32.1196+ #:string-prefix-p #:string-enclosed-p #:string-suffix-p
32.1197+ #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols
32.1198+ #:coerce-class ;; CLOS
32.1199+ #:timestamp< #:timestamps< #:timestamp*< #:timestamp<= ;; timestamps
32.1200+ #:earlier-timestamp #:timestamps-earliest #:earliest-timestamp
32.1201+ #:later-timestamp #:timestamps-latest #:latest-timestamp #:latest-timestamp-f
32.1202+ #:list-to-hash-set #:ensure-gethash ;; hash-table
32.1203+ #:ensure-function #:access-at #:access-at-count ;; functions
32.1204+ #:call-function #:call-functions #:register-hook-function
32.1205+ #:lexicographic< #:lexicographic<= ;; version
32.1206+ #:simple-style-warning #:style-warn ;; simple style warnings
32.1207+ #:match-condition-p #:match-any-condition-p ;; conditions
32.1208+ #:call-with-muffled-conditions #:with-muffled-conditions
32.1209+ #:not-implemented-error #:parameter-error
32.1210+ #:symbol-test-to-feature-expression
32.1211+ #:boolean-to-feature-expression))
32.1212+(in-package :uiop/utility)
32.1213+
32.1214+;;;; Defining functions in a way compatible with hot-upgrade:
32.1215+;; - The WTIH-UPGRADABILITY infrastructure below ensures that functions are declared NOTINLINE,
32.1216+;; so that new definitions are always seen by all callers, even those up the stack.
32.1217+;; - WITH-UPGRADABILITY also uses EVAL-WHEN so that definitions used by ASDF are in a limbo state
32.1218+;; (especially for gf's) in between the COMPILE-OP and LOAD-OP operations on the defining file.
32.1219+;; - THOU SHALT NOT redefine a function with a backward-incompatible semantics without renaming it,
32.1220+;; at least if that function is used by ASDF while performing the plan to load ASDF.
32.1221+;; - THOU SHALT change the name of a function whenever thou makest an incompatible change.
32.1222+;; - For instance, when the meanings of NIL and T for timestamps was inverted,
32.1223+;; functions in the STAMP<, STAMP<=, etc. family had to be renamed to TIMESTAMP<, TIMESTAMP<=, etc.,
32.1224+;; because the change other caused a huge incompatibility during upgrade.
32.1225+;; - Whenever a function goes from a DEFUN to a DEFGENERIC, or the DEFGENERIC signature changes, etc.,
32.1226+;; even in a backward-compatible way, you MUST precede the definition by FMAKUNBOUND.
32.1227+;; - Since FMAKUNBOUND will remove all the methods on the generic function, make sure that
32.1228+;; all the methods required for ASDF to successfully continue compiling itself
32.1229+;; shall be defined in the same file as the one with the FMAKUNBOUND, *after* the DEFGENERIC.
32.1230+;; - When a function goes from DEFGENERIC to DEFUN, you may omit to use FMAKUNBOUND.
32.1231+;; - For safety, you shall put the FMAKUNBOUND just before the DEFUN or DEFGENERIC,
32.1232+;; in the same WITH-UPGRADABILITY form (and its implicit EVAL-WHEN).
32.1233+;; - Any time you change a signature, please keep a comment specifying the first release after the change;
32.1234+;; put that comment on the same line as FMAKUNBOUND, it you use FMAKUNBOUND.
32.1235+(eval-when (:load-toplevel :compile-toplevel :execute)
32.1236+ (defun ensure-function-notinline (definition &aux (name (second definition)))
32.1237+ (assert (member (first definition) '(defun defgeneric)))
32.1238+ `(progn
32.1239+ ,(when (and #+(or clasp ecl) (symbolp name)) ; NB: fails for (SETF functions) on ECL
32.1240+ `(declaim (notinline ,name)))
32.1241+ ,definition))
32.1242+ (defmacro with-upgradability ((&optional) &body body)
32.1243+ "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
32.1244+to also declare the functions NOTINLINE and to accept a wrapping the function name
32.1245+specification into a list with keyword argument SUPERSEDE (which defaults to T if the name
32.1246+is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION
32.1247+to supersede any previous definition."
32.1248+ `(eval-when (:compile-toplevel :load-toplevel :execute)
32.1249+ ,@(loop :for form :in body :collect
32.1250+ (if (consp form)
32.1251+ (case (first form)
32.1252+ ((defun defgeneric) (ensure-function-notinline form))
32.1253+ (otherwise form))
32.1254+ form)))))
32.1255+
32.1256+;;; Magic debugging help. See contrib/debug.lisp
32.1257+(with-upgradability ()
32.1258+ (defvar *uiop-debug-utility*
32.1259+ '(symbol-call :uiop :subpathname (symbol-call :uiop :uiop-directory) "contrib/debug.lisp")
32.1260+ "form that evaluates to the pathname to your favorite debugging utilities")
32.1261+
32.1262+ (defmacro uiop-debug (&rest keys)
32.1263+ "Load the UIOP debug utility at compile-time as well as runtime"
32.1264+ `(eval-when (:compile-toplevel :load-toplevel :execute)
32.1265+ (load-uiop-debug-utility ,@keys)))
32.1266+
32.1267+ (defun load-uiop-debug-utility (&key package utility-file)
32.1268+ "Load the UIOP debug utility in given PACKAGE (default *PACKAGE*).
32.1269+Beware: The utility is located by EVAL'uating the UTILITY-FILE form (default *UIOP-DEBUG-UTILITY*)."
32.1270+ (let* ((*package* (if package (find-package package) *package*))
32.1271+ (keyword (read-from-string
32.1272+ (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
32.1273+ (unless (member keyword *features*)
32.1274+ (let* ((utility-file (or utility-file *uiop-debug-utility*))
32.1275+ (file (ignore-errors (probe-file (eval utility-file)))))
32.1276+ (if file (load file)
32.1277+ (error "Failed to locate debug utility file: ~S" utility-file)))))))
32.1278+
32.1279+;;; Flow control
32.1280+(with-upgradability ()
32.1281+ (defmacro nest (&rest things)
32.1282+ "Macro to keep code nesting and indentation under control." ;; Thanks to mbaringer
32.1283+ (reduce #'(lambda (outer inner) `(,@outer ,inner))
32.1284+ things :from-end t))
32.1285+
32.1286+ (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
32.1287+ ;; bindings can be (var form) or ((var1 form1) ...)
32.1288+ (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
32.1289+ (list bindings)
32.1290+ bindings))
32.1291+ (variables (mapcar #'car binding-list)))
32.1292+ `(let ,binding-list
32.1293+ (if (and ,@variables)
32.1294+ ,then-form
32.1295+ ,else-form)))))
32.1296+
32.1297+;;; Macro definition helper
32.1298+(with-upgradability ()
32.1299+ (defun parse-body (body &key documentation whole) ;; from alexandria
32.1300+ "Parses BODY into (values remaining-forms declarations doc-string).
32.1301+Documentation strings are recognized only if DOCUMENTATION is true.
32.1302+Syntax errors in body are signalled and WHOLE is used in the signal
32.1303+arguments when given."
32.1304+ (let ((doc nil)
32.1305+ (decls nil)
32.1306+ (current nil))
32.1307+ (tagbody
32.1308+ :declarations
32.1309+ (setf current (car body))
32.1310+ (when (and documentation (stringp current) (cdr body))
32.1311+ (if doc
32.1312+ (error "Too many documentation strings in ~S." (or whole body))
32.1313+ (setf doc (pop body)))
32.1314+ (go :declarations))
32.1315+ (when (and (listp current) (eql (first current) 'declare))
32.1316+ (push (pop body) decls)
32.1317+ (go :declarations)))
32.1318+ (values body (nreverse decls) doc))))
32.1319+
32.1320+
32.1321+;;; List manipulation
32.1322+(with-upgradability ()
32.1323+ (defmacro while-collecting ((&rest collectors) &body body)
32.1324+ "COLLECTORS should be a list of names for collections. A collector
32.1325+defines a function that, when applied to an argument inside BODY, will
32.1326+add its argument to the corresponding collection. Returns multiple values,
32.1327+a list for each collection, in order.
32.1328+ E.g.,
32.1329+\(while-collecting \(foo bar\)
32.1330+ \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
32.1331+ \(foo \(first x\)\)
32.1332+ \(bar \(second x\)\)\)\)
32.1333+Returns two values: \(A B C\) and \(1 2 3\)."
32.1334+ (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
32.1335+ (initial-values (mapcar (constantly nil) collectors)))
32.1336+ `(let ,(mapcar #'list vars initial-values)
32.1337+ (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
32.1338+ ,@body
32.1339+ (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
32.1340+
32.1341+ (define-modify-macro appendf (&rest args)
32.1342+ append "Append onto list") ;; only to be used on short lists.
32.1343+
32.1344+ (defun length=n-p (x n) ;is it that (= (length x) n) ?
32.1345+ (check-type n (integer 0 *))
32.1346+ (loop
32.1347+ :for l = x :then (cdr l)
32.1348+ :for i :downfrom n :do
32.1349+ (cond
32.1350+ ((zerop i) (return (null l)))
32.1351+ ((not (consp l)) (return nil)))))
32.1352+
32.1353+ (defun ensure-list (x)
32.1354+ (if (listp x) x (list x))))
32.1355+
32.1356+
32.1357+;;; Remove a key from a plist, i.e. for keyword argument cleanup
32.1358+(with-upgradability ()
32.1359+ (defun remove-plist-key (key plist)
32.1360+ "Remove a single key from a plist"
32.1361+ (loop :for (k v) :on plist :by #'cddr
32.1362+ :unless (eq k key)
32.1363+ :append (list k v)))
32.1364+
32.1365+ (defun remove-plist-keys (keys plist)
32.1366+ "Remove a list of keys from a plist"
32.1367+ (loop :for (k v) :on plist :by #'cddr
32.1368+ :unless (member k keys)
32.1369+ :append (list k v))))
32.1370+
32.1371+
32.1372+;;; Sequences
32.1373+(with-upgradability ()
32.1374+ (defun emptyp (x)
32.1375+ "Predicate that is true for an empty sequence"
32.1376+ (or (null x) (and (vectorp x) (zerop (length x))))))
32.1377+
32.1378+
32.1379+;;; Characters
32.1380+(with-upgradability ()
32.1381+ ;; base-char != character on ECL, LW, SBCL, Genera.
32.1382+ ;; NB: We assume a total order on character types.
32.1383+ ;; If that's not true... this code will need to be updated.
32.1384+ (defparameter +character-types+ ;; assuming a simple hierarchy
32.1385+ #.(coerce (loop :for (type next) :on
32.1386+ '(;; In SCL, all characters seem to be 16-bit base-char
32.1387+ ;; Yet somehow character fails to be a subtype of base-char
32.1388+ #-scl base-char
32.1389+ ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
32.1390+ ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
32.1391+ #+lispworks7+ lw:bmp-char
32.1392+ #+lispworks lw:simple-char
32.1393+ character)
32.1394+ :unless (and next (subtypep next type))
32.1395+ :collect type) 'vector))
32.1396+ (defparameter +max-character-type-index+ (1- (length +character-types+)))
32.1397+ (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+))
32.1398+ (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
32.1399+
32.1400+(with-upgradability ()
32.1401+ (defun character-type-index (x)
32.1402+ (declare (ignorable x))
32.1403+ #.(case +max-character-type-index+
32.1404+ (0 0)
32.1405+ (1 '(etypecase x
32.1406+ (character (if (typep x 'base-char) 0 1))
32.1407+ (symbol (if (subtypep x 'base-char) 0 1))))
32.1408+ (otherwise
32.1409+ '(or (position-if (etypecase x
32.1410+ (character #'(lambda (type) (typep x type)))
32.1411+ (symbol #'(lambda (type) (subtypep x type))))
32.1412+ +character-types+)
32.1413+ (error "Not a character or character type: ~S" x))))))
32.1414+
32.1415+
32.1416+;;; Strings
32.1417+(with-upgradability ()
32.1418+ (defun base-string-p (string)
32.1419+ "Does the STRING only contain BASE-CHARs?"
32.1420+ (declare (ignorable string))
32.1421+ (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
32.1422+
32.1423+ (defun strings-common-element-type (strings)
32.1424+ "What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
32.1425+ (declare (ignorable strings))
32.1426+ #.(if +non-base-chars-exist-p+
32.1427+ `(aref +character-types+
32.1428+ (loop :with index = 0 :for s :in strings :do
32.1429+ (flet ((consider (i)
32.1430+ (cond ((= i ,+max-character-type-index+) (return i))
32.1431+ ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i)))))))
32.1432+ (cond
32.1433+ ((emptyp s)) ;; NIL or empty string
32.1434+ ((characterp s) (consider (character-type-index s)))
32.1435+ ((stringp s) (let ((string-type-index
32.1436+ (character-type-index (array-element-type s))))
32.1437+ (unless (>= index string-type-index)
32.1438+ (loop :for c :across s :for i = (character-type-index c)
32.1439+ :do (consider i)
32.1440+ ,@(when (> +max-character-type-index+ 1)
32.1441+ `((when (= i string-type-index) (return))))))))
32.1442+ (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))))
32.1443+ :finally (return index)))
32.1444+ ''character))
32.1445+
32.1446+ (defun reduce/strcat (strings &key key start end)
32.1447+ "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
32.1448+NIL is interpreted as an empty string. A character is interpreted as a string of length one."
32.1449+ (when (or start end) (setf strings (subseq strings start end)))
32.1450+ (when key (setf strings (mapcar key strings)))
32.1451+ (loop :with output = (make-string (loop :for s :in strings
32.1452+ :sum (if (characterp s) 1 (length s)))
32.1453+ :element-type (strings-common-element-type strings))
32.1454+ :with pos = 0
32.1455+ :for input :in strings
32.1456+ :do (etypecase input
32.1457+ (null)
32.1458+ (character (setf (char output pos) input) (incf pos))
32.1459+ (string (replace output input :start1 pos) (incf pos (length input))))
32.1460+ :finally (return output)))
32.1461+
32.1462+ (defun strcat (&rest strings)
32.1463+ "Concatenate strings.
32.1464+NIL is interpreted as an empty string, a character as a string of length one."
32.1465+ (reduce/strcat strings))
32.1466+
32.1467+ (defun first-char (s)
32.1468+ "Return the first character of a non-empty string S, or NIL"
32.1469+ (and (stringp s) (plusp (length s)) (char s 0)))
32.1470+
32.1471+ (defun last-char (s)
32.1472+ "Return the last character of a non-empty string S, or NIL"
32.1473+ (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
32.1474+
32.1475+ (defun split-string (string &key max (separator '(#\Space #\Tab)))
32.1476+ "Split STRING into a list of components separated by
32.1477+any of the characters in the sequence SEPARATOR.
32.1478+If MAX is specified, then no more than max(1,MAX) components will be returned,
32.1479+starting the separation from the end, e.g. when called with arguments
32.1480+ \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
32.1481+ (block ()
32.1482+ (let ((list nil) (words 0) (end (length string)))
32.1483+ (when (zerop end) (return nil))
32.1484+ (flet ((separatorp (char) (find char separator))
32.1485+ (done () (return (cons (subseq string 0 end) list))))
32.1486+ (loop
32.1487+ :for start = (if (and max (>= words (1- max)))
32.1488+ (done)
32.1489+ (position-if #'separatorp string :end end :from-end t))
32.1490+ :do (when (null start) (done))
32.1491+ (push (subseq string (1+ start) end) list)
32.1492+ (incf words)
32.1493+ (setf end start))))))
32.1494+
32.1495+ (defun string-prefix-p (prefix string)
32.1496+ "Does STRING begin with PREFIX?"
32.1497+ (let* ((x (string prefix))
32.1498+ (y (string string))
32.1499+ (lx (length x))
32.1500+ (ly (length y)))
32.1501+ (and (<= lx ly) (string= x y :end2 lx))))
32.1502+
32.1503+ (defun string-suffix-p (string suffix)
32.1504+ "Does STRING end with SUFFIX?"
32.1505+ (let* ((x (string string))
32.1506+ (y (string suffix))
32.1507+ (lx (length x))
32.1508+ (ly (length y)))
32.1509+ (and (<= ly lx) (string= x y :start1 (- lx ly)))))
32.1510+
32.1511+ (defun string-enclosed-p (prefix string suffix)
32.1512+ "Does STRING begin with PREFIX and end with SUFFIX?"
32.1513+ (and (string-prefix-p prefix string)
32.1514+ (string-suffix-p string suffix)))
32.1515+
32.1516+ (defvar +cr+ (coerce #(#\Return) 'string))
32.1517+ (defvar +lf+ (coerce #(#\Linefeed) 'string))
32.1518+ (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string))
32.1519+
32.1520+ (defun stripln (x)
32.1521+ "Strip a string X from any ending CR, LF or CRLF.
32.1522+Return two values, the stripped string and the ending that was stripped,
32.1523+or the original value and NIL if no stripping took place.
32.1524+Since our STRCAT accepts NIL as empty string designator,
32.1525+the two results passed to STRCAT always reconstitute the original string"
32.1526+ (check-type x string)
32.1527+ (block nil
32.1528+ (flet ((c (end) (when (string-suffix-p x end)
32.1529+ (return (values (subseq x 0 (- (length x) (length end))) end)))))
32.1530+ (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil)))))
32.1531+
32.1532+ (defun standard-case-symbol-name (name-designator)
32.1533+ "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING;
32.1534+if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\"
32.1535+platform such as Allegro with modern syntax."
32.1536+ (check-type name-designator (or string symbol))
32.1537+ (cond
32.1538+ ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower))
32.1539+ (string name-designator))
32.1540+ ;; Should we be doing something on CLISP?
32.1541+ (t (string-upcase name-designator))))
32.1542+
32.1543+ (defun find-standard-case-symbol (name-designator package-designator &optional (error t))
32.1544+ "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR,
32.1545+where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings.
32.1546+If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
32.1547+ (find-symbol* (standard-case-symbol-name name-designator)
32.1548+ (etypecase package-designator
32.1549+ ((or package symbol) package-designator)
32.1550+ (string (standard-case-symbol-name package-designator)))
32.1551+ error)))
32.1552+
32.1553+;;; timestamps: a REAL or a boolean where T=-infinity, NIL=+infinity
32.1554+(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
32.1555+ (deftype timestamp () '(or real boolean)))
32.1556+(with-upgradability ()
32.1557+ (defun timestamp< (x y)
32.1558+ (etypecase x
32.1559+ ((eql t) (not (eql y t)))
32.1560+ (real (etypecase y
32.1561+ ((eql t) nil)
32.1562+ (real (< x y))
32.1563+ (null t)))
32.1564+ (null nil)))
32.1565+ (defun timestamps< (list) (loop :for y :in list :for x = nil :then y :always (timestamp< x y)))
32.1566+ (defun timestamp*< (&rest list) (timestamps< list))
32.1567+ (defun timestamp<= (x y) (not (timestamp< y x)))
32.1568+ (defun earlier-timestamp (x y) (if (timestamp< x y) x y))
32.1569+ (defun timestamps-earliest (list) (reduce 'earlier-timestamp list :initial-value nil))
32.1570+ (defun earliest-timestamp (&rest list) (timestamps-earliest list))
32.1571+ (defun later-timestamp (x y) (if (timestamp< x y) y x))
32.1572+ (defun timestamps-latest (list) (reduce 'later-timestamp list :initial-value t))
32.1573+ (defun latest-timestamp (&rest list) (timestamps-latest list))
32.1574+ (define-modify-macro latest-timestamp-f (&rest timestamps) latest-timestamp))
32.1575+
32.1576+
32.1577+;;; Function designators
32.1578+(with-upgradability ()
32.1579+ (defun ensure-function (fun &key (package :cl))
32.1580+ "Coerce the object FUN into a function.
32.1581+
32.1582+If FUN is a FUNCTION, return it.
32.1583+If the FUN is a non-sequence literal constant, return constantly that,
32.1584+i.e. for a boolean keyword character number or pathname.
32.1585+Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
32.1586+If FUN is a CONS, return the function that applies its CAR
32.1587+to the appended list of the rest of its CDR and the arguments,
32.1588+unless the CAR is LAMBDA, in which case the expression is evaluated.
32.1589+If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
32.1590+and EVAL that in a (FUNCTION ...) context."
32.1591+ (etypecase fun
32.1592+ (function fun)
32.1593+ ((or boolean keyword character number pathname) (constantly fun))
32.1594+ (hash-table #'(lambda (x) (gethash x fun)))
32.1595+ (symbol (fdefinition fun))
32.1596+ (cons (if (eq 'lambda (car fun))
32.1597+ (eval fun)
32.1598+ #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))))
32.1599+ (string (eval `(function ,(with-standard-io-syntax
32.1600+ (let ((*package* (find-package package)))
32.1601+ (read-from-string fun))))))))
32.1602+
32.1603+ (defun access-at (object at)
32.1604+ "Given an OBJECT and an AT specifier, list of successive accessors,
32.1605+call each accessor on the result of the previous calls.
32.1606+An accessor may be an integer, meaning a call to ELT,
32.1607+a keyword, meaning a call to GETF,
32.1608+NIL, meaning identity,
32.1609+a function or other symbol, meaning itself,
32.1610+or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
32.1611+As a degenerate case, the AT specifier may be an atom of a single such accessor
32.1612+instead of a list."
32.1613+ (flet ((access (object accessor)
32.1614+ (etypecase accessor
32.1615+ (function (funcall accessor object))
32.1616+ (integer (elt object accessor))
32.1617+ (keyword (getf object accessor))
32.1618+ (null object)
32.1619+ (symbol (funcall accessor object))
32.1620+ (cons (funcall (ensure-function accessor) object)))))
32.1621+ (if (listp at)
32.1622+ (dolist (accessor at object)
32.1623+ (setf object (access object accessor)))
32.1624+ (access object at))))
32.1625+
32.1626+ (defun access-at-count (at)
32.1627+ "From an AT specification, extract a COUNT of maximum number
32.1628+of sub-objects to read as per ACCESS-AT"
32.1629+ (cond
32.1630+ ((integerp at)
32.1631+ (1+ at))
32.1632+ ((and (consp at) (integerp (first at)))
32.1633+ (1+ (first at)))))
32.1634+
32.1635+ (defun call-function (function-spec &rest arguments)
32.1636+ "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION,
32.1637+with the given ARGUMENTS"
32.1638+ (apply (ensure-function function-spec) arguments))
32.1639+
32.1640+ (defun call-functions (function-specs)
32.1641+ "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION"
32.1642+ (map () 'call-function function-specs))
32.1643+
32.1644+ (defun register-hook-function (variable hook &optional call-now-p)
32.1645+ "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE.
32.1646+When CALL-NOW-P is true, also call the function immediately."
32.1647+ (pushnew hook (symbol-value variable) :test 'equal)
32.1648+ (when call-now-p (call-function hook))))
32.1649+
32.1650+
32.1651+;;; CLOS
32.1652+(with-upgradability ()
32.1653+ (defun coerce-class (class &key (package :cl) (super t) (error 'error))
32.1654+ "Coerce CLASS to a class that is subclass of SUPER if specified,
32.1655+or invoke ERROR handler as per CALL-FUNCTION.
32.1656+
32.1657+A keyword designates the name a symbol, which when found in either PACKAGE, designates a class.
32.1658+-- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future.
32.1659+A string is read as a symbol while in PACKAGE, the symbol designates a class.
32.1660+
32.1661+A class object designates itself.
32.1662+NIL designates itself (no class).
32.1663+A symbol otherwise designates a class by name."
32.1664+ (let* ((normalized
32.1665+ (typecase class
32.1666+ (keyword (or (find-symbol* class package nil)
32.1667+ (find-symbol* class *package* nil)))
32.1668+ (string (symbol-call :uiop :safe-read-from-string class :package package))
32.1669+ (t class)))
32.1670+ (found
32.1671+ (etypecase normalized
32.1672+ ((or standard-class built-in-class) normalized)
32.1673+ ((or null keyword) nil)
32.1674+ (symbol (find-class normalized nil nil))))
32.1675+ (super-class
32.1676+ (etypecase super
32.1677+ ((or standard-class built-in-class) super)
32.1678+ ((or null keyword) nil)
32.1679+ (symbol (find-class super nil nil)))))
32.1680+ #+allegro (when found (mop:finalize-inheritance found))
32.1681+ (or (and found
32.1682+ (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class))
32.1683+ found)
32.1684+ (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super)))))
32.1685+
32.1686+
32.1687+;;; Hash-tables
32.1688+(with-upgradability ()
32.1689+ (defun ensure-gethash (key table default)
32.1690+ "Lookup the TABLE for a KEY as by GETHASH, but if not present,
32.1691+call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION,
32.1692+set the corresponding entry to the result in the table.
32.1693+Return two values: the entry after its optional computation, and whether it was found"
32.1694+ (multiple-value-bind (value foundp) (gethash key table)
32.1695+ (values
32.1696+ (if foundp
32.1697+ value
32.1698+ (setf (gethash key table) (call-function default)))
32.1699+ foundp)))
32.1700+
32.1701+ (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
32.1702+ "Convert a LIST into hash-table that has the same elements when viewed as a set,
32.1703+up to the given equality TEST"
32.1704+ (dolist (x list h) (setf (gethash x h) t))))
32.1705+
32.1706+
32.1707+;;; Lexicographic comparison of lists of numbers
32.1708+(with-upgradability ()
32.1709+ (defun lexicographic< (element< x y)
32.1710+ "Lexicographically compare two lists of using the function element< to compare elements.
32.1711+element< is a strict total order; the resulting order on X and Y will also be strict."
32.1712+ (cond ((null y) nil)
32.1713+ ((null x) t)
32.1714+ ((funcall element< (car x) (car y)) t)
32.1715+ ((funcall element< (car y) (car x)) nil)
32.1716+ (t (lexicographic< element< (cdr x) (cdr y)))))
32.1717+
32.1718+ (defun lexicographic<= (element< x y)
32.1719+ "Lexicographically compare two lists of using the function element< to compare elements.
32.1720+element< is a strict total order; the resulting order on X and Y will be a non-strict total order."
32.1721+ (not (lexicographic< element< y x))))
32.1722+
32.1723+
32.1724+;;; Simple style warnings
32.1725+(with-upgradability ()
32.1726+ (define-condition simple-style-warning
32.1727+ #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning)
32.1728+ ())
32.1729+
32.1730+ (defun style-warn (datum &rest arguments)
32.1731+ (etypecase datum
32.1732+ (string (warn (make-condition 'simple-style-warning :format-control datum :format-arguments arguments)))
32.1733+ (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments))
32.1734+ (style-warning (apply 'warn datum arguments)))))
32.1735+
32.1736+
32.1737+;;; Condition control
32.1738+
32.1739+(with-upgradability ()
32.1740+ (defparameter +simple-condition-format-control-slot+
32.1741+ #+abcl 'system::format-control
32.1742+ #+allegro 'excl::format-control
32.1743+ #+(or clasp ecl mkcl) 'si::format-control
32.1744+ #+clisp 'system::$format-control
32.1745+ #+clozure 'ccl::format-control
32.1746+ #+(or cmucl scl) 'conditions::format-control
32.1747+ #+(or gcl lispworks) 'conditions::format-string
32.1748+ #+sbcl 'sb-kernel:format-control
32.1749+ #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil
32.1750+ "Name of the slot for FORMAT-CONTROL in simple-condition")
32.1751+
32.1752+ (defun match-condition-p (x condition)
32.1753+ "Compare received CONDITION to some pattern X:
32.1754+a symbol naming a condition class,
32.1755+a simple vector of length 2, arguments to find-symbol* with result as above,
32.1756+or a string describing the format-control of a simple-condition."
32.1757+ (etypecase x
32.1758+ (symbol (typep condition x))
32.1759+ ((simple-vector 2)
32.1760+ (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
32.1761+ (function (funcall x condition))
32.1762+ (string (and (typep condition 'simple-condition)
32.1763+ ;; On SBCL, it's always set and the check triggers a warning
32.1764+ #+(or allegro clozure cmucl lispworks scl)
32.1765+ (slot-boundp condition +simple-condition-format-control-slot+)
32.1766+ (ignore-errors (equal (simple-condition-format-control condition) x))))))
32.1767+
32.1768+ (defun match-any-condition-p (condition conditions)
32.1769+ "match CONDITION against any of the patterns of CONDITIONS supplied"
32.1770+ (loop :for x :in conditions :thereis (match-condition-p x condition)))
32.1771+
32.1772+ (defun call-with-muffled-conditions (thunk conditions)
32.1773+ "calls the THUNK in a context where the CONDITIONS are muffled"
32.1774+ (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
32.1775+ (muffle-warning c)))))
32.1776+ (funcall thunk)))
32.1777+
32.1778+ (defmacro with-muffled-conditions ((conditions) &body body)
32.1779+ "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
32.1780+ `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
32.1781+
32.1782+;;; Conditions
32.1783+
32.1784+(with-upgradability ()
32.1785+ (define-condition not-implemented-error (error)
32.1786+ ((functionality :initarg :functionality)
32.1787+ (format-control :initarg :format-control)
32.1788+ (format-arguments :initarg :format-arguments))
32.1789+ (:report (lambda (condition stream)
32.1790+ (format stream "Not (currently) implemented on ~A: ~S~@[ ~?~]"
32.1791+ (nth-value 1 (symbol-call :uiop :implementation-type))
32.1792+ (slot-value condition 'functionality)
32.1793+ (slot-value condition 'format-control)
32.1794+ (slot-value condition 'format-arguments)))))
32.1795+
32.1796+ (defun not-implemented-error (functionality &optional format-control &rest format-arguments)
32.1797+ "Signal an error because some FUNCTIONALITY is not implemented in the current version
32.1798+of the software on the current platform; it may or may not be implemented in different combinations
32.1799+of version of the software and of the underlying platform. Optionally, report a formatted error
32.1800+message."
32.1801+ (error 'not-implemented-error
32.1802+ :functionality functionality
32.1803+ :format-control format-control
32.1804+ :format-arguments format-arguments))
32.1805+
32.1806+ (define-condition parameter-error (error)
32.1807+ ((functionality :initarg :functionality)
32.1808+ (format-control :initarg :format-control)
32.1809+ (format-arguments :initarg :format-arguments))
32.1810+ (:report (lambda (condition stream)
32.1811+ (apply 'format stream
32.1812+ (slot-value condition 'format-control)
32.1813+ (slot-value condition 'functionality)
32.1814+ (slot-value condition 'format-arguments)))))
32.1815+
32.1816+ ;; Note that functionality MUST be passed as the second argument to parameter-error, just after
32.1817+ ;; the format-control. If you want it to not appear in first position in actual message, use
32.1818+ ;; ~* and ~:* to adjust parameter order.
32.1819+ (defun parameter-error (format-control functionality &rest format-arguments)
32.1820+ "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying
32.1821+platform does not accept a given parameter or combination of parameters. Report a formatted error
32.1822+message, that takes the functionality as its first argument (that can be skipped with ~*)."
32.1823+ (error 'parameter-error
32.1824+ :functionality functionality
32.1825+ :format-control format-control
32.1826+ :format-arguments format-arguments)))
32.1827+
32.1828+(with-upgradability ()
32.1829+ (defun boolean-to-feature-expression (value)
32.1830+ "Converts a boolean VALUE to a form suitable for testing with #+."
32.1831+ (if value
32.1832+ '(:and)
32.1833+ '(:or)))
32.1834+
32.1835+ (defun symbol-test-to-feature-expression (name package)
32.1836+ "Check if a symbol with a given NAME exists in PACKAGE and returns a
32.1837+form suitable for testing with #+."
32.1838+ (boolean-to-feature-expression
32.1839+ (find-symbol* name package nil))))
32.1840+(uiop/package:define-package :uiop/version
32.1841+ (:recycle :uiop/version :uiop/utility :asdf)
32.1842+ (:use :uiop/common-lisp :uiop/package :uiop/utility)
32.1843+ (:export
32.1844+ #:*uiop-version*
32.1845+ #:parse-version #:unparse-version #:version< #:version<= #:version= ;; version support, moved from uiop/utility
32.1846+ #:next-version
32.1847+ #:deprecated-function-condition #:deprecated-function-name ;; deprecation control
32.1848+ #:deprecated-function-style-warning #:deprecated-function-warning
32.1849+ #:deprecated-function-error #:deprecated-function-should-be-deleted
32.1850+ #:version-deprecation #:with-deprecation))
32.1851+(in-package :uiop/version)
32.1852+
32.1853+(with-upgradability ()
32.1854+ (defparameter *uiop-version* "3.3.6")
32.1855+
32.1856+ (defun unparse-version (version-list)
32.1857+ "From a parsed version (a list of natural numbers), compute the version string"
32.1858+ (format nil "~{~D~^.~}" version-list))
32.1859+
32.1860+ (defun parse-version (version-string &optional on-error)
32.1861+ "Parse a VERSION-STRING as a series of natural numbers separated by dots.
32.1862+Return a (non-null) list of integers if the string is valid;
32.1863+otherwise return NIL.
32.1864+
32.1865+When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
32.1866+with format arguments explaining why the version is invalid.
32.1867+ON-ERROR is also called if the version is not canonical
32.1868+in that it doesn't print back to itself, but the list is returned anyway."
32.1869+ (block nil
32.1870+ (unless (stringp version-string)
32.1871+ (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
32.1872+ (return))
32.1873+ (unless (loop :for prev = nil :then c :for c :across version-string
32.1874+ :always (or (digit-char-p c)
32.1875+ (and (eql c #\.) prev (not (eql prev #\.))))
32.1876+ :finally (return (and c (digit-char-p c))))
32.1877+ (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
32.1878+ 'parse-version version-string)
32.1879+ (return))
32.1880+ (let* ((version-list
32.1881+ (mapcar #'parse-integer (split-string version-string :separator ".")))
32.1882+ (normalized-version (unparse-version version-list)))
32.1883+ (unless (equal version-string normalized-version)
32.1884+ (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
32.1885+ version-list)))
32.1886+
32.1887+ (defun next-version (version)
32.1888+ "When VERSION is not nil, it is a string, then parse it as a version, compute the next version
32.1889+and return it as a string."
32.1890+ (when version
32.1891+ (let ((version-list (parse-version version)))
32.1892+ (incf (car (last version-list)))
32.1893+ (unparse-version version-list))))
32.1894+
32.1895+ (defun version< (version1 version2)
32.1896+ "Given two version strings, return T if the second is strictly newer"
32.1897+ (let ((v1 (parse-version version1 nil))
32.1898+ (v2 (parse-version version2 nil)))
32.1899+ (lexicographic< '< v1 v2)))
32.1900+
32.1901+ (defun version<= (version1 version2)
32.1902+ "Given two version strings, return T if the second is newer or the same"
32.1903+ (not (version< version2 version1))))
32.1904+
32.1905+ (defun version= (version1 version2)
32.1906+ "Given two version strings, return T if the first is newer or the same and
32.1907+the second is also newer or the same."
32.1908+ (and (version<= version1 version2)
32.1909+ (version<= version2 version1)))
32.1910+
32.1911+
32.1912+(with-upgradability ()
32.1913+ (define-condition deprecated-function-condition (condition)
32.1914+ ((name :initarg :name :reader deprecated-function-name)))
32.1915+ (define-condition deprecated-function-style-warning (deprecated-function-condition style-warning) ())
32.1916+ (define-condition deprecated-function-warning (deprecated-function-condition warning) ())
32.1917+ (define-condition deprecated-function-error (deprecated-function-condition error) ())
32.1918+ (define-condition deprecated-function-should-be-deleted (deprecated-function-condition error) ())
32.1919+
32.1920+ (defun deprecated-function-condition-kind (type)
32.1921+ (ecase type
32.1922+ ((deprecated-function-style-warning) :style-warning)
32.1923+ ((deprecated-function-warning) :warning)
32.1924+ ((deprecated-function-error) :error)
32.1925+ ((deprecated-function-should-be-deleted) :delete)))
32.1926+
32.1927+ (defmethod print-object ((c deprecated-function-condition) stream)
32.1928+ (let ((name (deprecated-function-name c)))
32.1929+ (cond
32.1930+ (*print-readably*
32.1931+ (let ((fmt "#.(make-condition '~S :name ~S)")
32.1932+ (args (list (type-of c) name)))
32.1933+ (if *read-eval*
32.1934+ (apply 'format stream fmt args)
32.1935+ (error "Can't print ~?" fmt args))))
32.1936+ (*print-escape*
32.1937+ (print-unreadable-object (c stream :type t) (format stream ":name ~S" name)))
32.1938+ (t
32.1939+ (let ((*package* (find-package :cl))
32.1940+ (type (type-of c)))
32.1941+ (format stream
32.1942+ (if (eq type 'deprecated-function-should-be-deleted)
32.1943+ "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete"
32.1944+ "~A: Using deprecated function ~S -- please update your code to use a newer API.~
32.1945+~@[~%The docstring for this function says:~%~A~%~]")
32.1946+ type name (when (symbolp name) (documentation name 'function))))))))
32.1947+
32.1948+ (defun notify-deprecated-function (status name)
32.1949+ (ecase status
32.1950+ ((nil) nil)
32.1951+ ((:style-warning) (style-warn 'deprecated-function-style-warning :name name))
32.1952+ ((:warning) (warn 'deprecated-function-warning :name name))
32.1953+ ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error :name name))))
32.1954+
32.1955+ (defun version-deprecation (version &key (style-warning nil)
32.1956+ (warning (next-version style-warning))
32.1957+ (error (next-version warning))
32.1958+ (delete (next-version error)))
32.1959+ "Given a VERSION string, and the starting versions for notifying the programmer of
32.1960+various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION
32.1961+that is the highest level that has a declared version older than the specified version.
32.1962+Each start version for a level of deprecation can be specified by a keyword argument, or
32.1963+if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation."
32.1964+ (cond
32.1965+ ((and delete (version<= delete version)) :delete)
32.1966+ ((and error (version<= error version)) :error)
32.1967+ ((and warning (version<= warning version)) :warning)
32.1968+ ((and style-warning (version<= style-warning version)) :style-warning)))
32.1969+
32.1970+ (defmacro with-deprecation ((level) &body definitions)
32.1971+ "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the
32.1972+DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function
32.1973+when it is compiled or called.
32.1974+
32.1975+Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet),
32.1976+:STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used),
32.1977+:ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while
32.1978+at that level).
32.1979+
32.1980+Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD
32.1981+from instrumentation by enclosing it in a PROGN."
32.1982+ (let ((level (eval level)))
32.1983+ (check-type level (member nil :style-warning :warning :error :delete))
32.1984+ (when (eq level :delete)
32.1985+ (error 'deprecated-function-should-be-deleted :name
32.1986+ (mapcar 'second
32.1987+ (remove-if-not #'(lambda (x) (member x '(defun defmethod)))
32.1988+ definitions :key 'first))))
32.1989+ (labels ((instrument (name head body whole)
32.1990+ (if level
32.1991+ (let ((notifiedp
32.1992+ (intern (format nil "*~A-~A-~A-~A*"
32.1993+ :deprecated-function level name :notified-p))))
32.1994+ (multiple-value-bind (remaining-forms declarations doc-string)
32.1995+ (parse-body body :documentation t :whole whole)
32.1996+ `(progn
32.1997+ (defparameter ,notifiedp nil)
32.1998+ ;; tell some implementations to use the compiler-macro
32.1999+ (declaim (inline ,name))
32.2000+ (define-compiler-macro ,name (&whole form &rest args)
32.2001+ (declare (ignore args))
32.2002+ (notify-deprecated-function ,level ',name)
32.2003+ form)
32.2004+ (,@head ,@(when doc-string (list doc-string)) ,@declarations
32.2005+ (unless ,notifiedp
32.2006+ (setf ,notifiedp t)
32.2007+ (notify-deprecated-function ,level ',name))
32.2008+ ,@remaining-forms))))
32.2009+ `(progn
32.2010+ (eval-when (:compile-toplevel :load-toplevel :execute)
32.2011+ (setf (compiler-macro-function ',name) nil))
32.2012+ (declaim (notinline ,name))
32.2013+ (,@head ,@body)))))
32.2014+ `(progn
32.2015+ ,@(loop :for form :in definitions :collect
32.2016+ (cond
32.2017+ ((and (consp form) (eq (car form) 'defun))
32.2018+ (instrument (second form) (subseq form 0 3) (subseq form 3) form))
32.2019+ ((and (consp form) (eq (car form) 'defmethod))
32.2020+ (let ((body-start (if (listp (third form)) 3 4)))
32.2021+ (instrument (second form)
32.2022+ (subseq form 0 body-start)
32.2023+ (subseq form body-start)
32.2024+ form)))
32.2025+ (t
32.2026+ form))))))))
32.2027+;;;; ---------------------------------------------------------------------------
32.2028+;;;; Access to the Operating System
32.2029+
32.2030+(uiop/package:define-package :uiop/os
32.2031+ (:use :uiop/common-lisp :uiop/package :uiop/utility)
32.2032+ (:export
32.2033+ #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features
32.2034+ #:os-cond
32.2035+ #:getenv #:getenvp ;; environment variables
32.2036+ #:implementation-identifier ;; implementation identifier
32.2037+ #:implementation-type #:*implementation-type*
32.2038+ #:operating-system #:architecture #:lisp-version-string
32.2039+ #:hostname #:getcwd #:chdir
32.2040+ ;; Windows shortcut support
32.2041+ #:read-null-terminated-string #:read-little-endian
32.2042+ #:parse-file-location-info #:parse-windows-shortcut))
32.2043+(in-package :uiop/os)
32.2044+
32.2045+;;; Features
32.2046+(with-upgradability ()
32.2047+ (defun featurep (x &optional (*features* *features*))
32.2048+ "Checks whether a feature expression X is true with respect to the *FEATURES* set,
32.2049+as per the CLHS standard for #+ and #-. Beware that just like the CLHS,
32.2050+we assume symbols from the KEYWORD package are used, but that unless you're using #+/#-
32.2051+your reader will not have magically used the KEYWORD package, so you need specify
32.2052+keywords explicitly."
32.2053+ (cond
32.2054+ ((atom x) (and (member x *features*) t))
32.2055+ ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
32.2056+ ((eq :or (car x)) (some #'featurep (cdr x)))
32.2057+ ((eq :and (car x)) (every #'featurep (cdr x)))
32.2058+ (t (parameter-error "~S: malformed feature specification ~S" 'featurep x))))
32.2059+
32.2060+ ;; Starting with UIOP 3.1.5, these are runtime tests.
32.2061+ ;; You may bind *features* with a copy of what your target system offers to test its properties.
32.2062+ (defun os-macosx-p ()
32.2063+ "Is the underlying operating system MacOS X?"
32.2064+ ;; OS-MACOSX is not mutually exclusive with OS-UNIX,
32.2065+ ;; in fact the former implies the latter.
32.2066+ (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos))))
32.2067+
32.2068+ (defun os-unix-p ()
32.2069+ "Is the underlying operating system some Unix variant?"
32.2070+ (or (featurep '(:or :unix :cygwin :haiku)) (os-macosx-p)))
32.2071+
32.2072+ (defun os-windows-p ()
32.2073+ "Is the underlying operating system Microsoft Windows?"
32.2074+ (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32 :mingw64))))
32.2075+
32.2076+ (defun os-genera-p ()
32.2077+ "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
32.2078+ (featurep :genera))
32.2079+
32.2080+ (defun os-oldmac-p ()
32.2081+ "Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
32.2082+ (featurep :mcl))
32.2083+
32.2084+ (defun os-haiku-p ()
32.2085+ "Is the underlying operating system Haiku?"
32.2086+ (featurep :haiku))
32.2087+
32.2088+ (defun os-mezzano-p ()
32.2089+ "Is the underlying operating system Mezzano?"
32.2090+ (featurep :mezzano))
32.2091+
32.2092+ (defun detect-os ()
32.2093+ "Detects the current operating system. Only needs be run at compile-time,
32.2094+except on ABCL where it might change between FASL compilation and runtime."
32.2095+ (loop :with o
32.2096+ :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
32.2097+ (:os-windows . os-windows-p)
32.2098+ (:os-genera . os-genera-p) (:os-oldmac . os-oldmac-p)
32.2099+ (:os-haiku . os-haiku-p)
32.2100+ (:os-mezzano . os-mezzano-p))
32.2101+ :when (and (or (not o) (eq feature :os-macosx) (eq feature :os-haiku)) (funcall detect))
32.2102+ :do (setf o feature) (pushnew feature *features*)
32.2103+ :else :do (setf *features* (remove feature *features*))
32.2104+ :finally
32.2105+ (return (or o (error "Congratulations for trying ASDF on an operating system~%~
32.2106+that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
32.2107+
32.2108+ (defmacro os-cond (&rest clauses)
32.2109+ #+abcl `(cond ,@clauses)
32.2110+ #-abcl (loop :for (test . body) :in clauses :when (eval test) :return `(progn ,@body)))
32.2111+
32.2112+ (detect-os))
32.2113+
32.2114+;;;; Environment variables: getting them, and parsing them.
32.2115+(with-upgradability ()
32.2116+ (defun getenv (x)
32.2117+ "Query the environment, as in C getenv.
32.2118+Beware: may return empty string if a variable is present but empty;
32.2119+use getenvp to return NIL in such a case."
32.2120+ (declare (ignorable x))
32.2121+ #+(or abcl clasp clisp ecl xcl) (ext:getenv x)
32.2122+ #+allegro (sys:getenv x)
32.2123+ #+clozure (ccl:getenv x)
32.2124+ #+cmucl (unix:unix-getenv x)
32.2125+ #+scl (cdr (assoc x ext:*environment-list* :test #'string=))
32.2126+ #+cormanlisp
32.2127+ (let* ((buffer (ct:malloc 1))
32.2128+ (cname (ct:lisp-string-to-c-string x))
32.2129+ (needed-size (win:getenvironmentvariable cname buffer 0))
32.2130+ (buffer1 (ct:malloc (1+ needed-size))))
32.2131+ (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
32.2132+ nil
32.2133+ (ct:c-string-to-lisp-string buffer1))
32.2134+ (ct:free buffer)
32.2135+ (ct:free buffer1)))
32.2136+ #+gcl (system:getenv x)
32.2137+ #+(or genera mezzano) nil
32.2138+ #+lispworks (lispworks:environment-variable x)
32.2139+ #+mcl (ccl:with-cstrs ((name x))
32.2140+ (let ((value (_getenv name)))
32.2141+ (unless (ccl:%null-ptr-p value)
32.2142+ (ccl:%get-cstring value))))
32.2143+ #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
32.2144+ #+sbcl (sb-ext:posix-getenv x)
32.2145+ #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
32.2146+ (not-implemented-error 'getenv))
32.2147+
32.2148+ (defsetf getenv (x) (val)
32.2149+ "Set an environment variable."
32.2150+ (declare (ignorable x val))
32.2151+ #+allegro `(setf (sys:getenv ,x) ,val)
32.2152+ #+clasp `(ext:setenv ,x ,val)
32.2153+ #+clisp `(system::setenv ,x ,val)
32.2154+ #+clozure `(ccl:setenv ,x ,val)
32.2155+ #+cmucl `(unix:unix-setenv ,x ,val 1)
32.2156+ #+(or ecl clasp) `(ext:setenv ,x ,val)
32.2157+ #+lispworks `(setf (lispworks:environment-variable ,x) ,val)
32.2158+ #+mkcl `(mkcl:setenv ,x ,val)
32.2159+ #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
32.2160+ #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl)
32.2161+ '(not-implemented-error '(setf getenv)))
32.2162+
32.2163+ (defun getenvp (x)
32.2164+ "Predicate that is true if the named variable is present in the libc environment,
32.2165+then returning the non-empty string value of the variable"
32.2166+ (let ((g (getenv x))) (and (not (emptyp g)) g))))
32.2167+
32.2168+
32.2169+;;;; implementation-identifier
32.2170+;;
32.2171+;; produce a string to identify current implementation.
32.2172+;; Initially stolen from SLIME's SWANK, completely rewritten since.
32.2173+;; We're back to runtime checking, for the sake of e.g. ABCL.
32.2174+
32.2175+(with-upgradability ()
32.2176+ (defun first-feature (feature-sets)
32.2177+ "A helper for various feature detection functions"
32.2178+ (dolist (x feature-sets)
32.2179+ (multiple-value-bind (short long feature-expr)
32.2180+ (if (consp x)
32.2181+ (values (first x) (second x) (cons :or (rest x)))
32.2182+ (values x x x))
32.2183+ (when (featurep feature-expr)
32.2184+ (return (values short long))))))
32.2185+
32.2186+ (defun implementation-type ()
32.2187+ "The type of Lisp implementation used, as a short UIOP-standardized keyword"
32.2188+ (first-feature
32.2189+ '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
32.2190+ (:cmu :cmucl :cmu) :clasp :ecl :gcl
32.2191+ (:lwpe :lispworks-personal-edition) (:lw :lispworks)
32.2192+ :mcl :mezzano :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
32.2193+
32.2194+ (defvar *implementation-type* (implementation-type)
32.2195+ "The type of Lisp implementation used, as a short UIOP-standardized keyword")
32.2196+
32.2197+ (defun operating-system ()
32.2198+ "The operating system of the current host"
32.2199+ (first-feature
32.2200+ '(:cygwin
32.2201+ (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
32.2202+ (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
32.2203+ (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
32.2204+ (:solaris :solaris :sunos)
32.2205+ (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly)
32.2206+ :unix
32.2207+ :genera
32.2208+ :mezzano)))
32.2209+
32.2210+ (defun architecture ()
32.2211+ "The CPU architecture of the current host"
32.2212+ (first-feature
32.2213+ '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
32.2214+ (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
32.2215+ (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
32.2216+ :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
32.2217+ :mipsel :mipseb :mips :alpha
32.2218+ (:arm64 :arm64 :aarch64 :armv8l :armv8b :aarch64_be :|aarch64|)
32.2219+ (:arm :arm :arm-target) :vlm :imach
32.2220+ ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
32.2221+ ;; we may have to segregate the code still by architecture.
32.2222+ (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
32.2223+
32.2224+ #+clozure
32.2225+ (defun ccl-fasl-version ()
32.2226+ ;; the fasl version is target-dependent from CCL 1.8 on.
32.2227+ (or (let ((s 'ccl::target-fasl-version))
32.2228+ (and (fboundp s) (funcall s)))
32.2229+ (and (boundp 'ccl::fasl-version)
32.2230+ (symbol-value 'ccl::fasl-version))
32.2231+ (error "Can't determine fasl version.")))
32.2232+
32.2233+ (defun lisp-version-string ()
32.2234+ "return a string that identifies the current Lisp implementation version"
32.2235+ (let ((s (lisp-implementation-version)))
32.2236+ (car ; as opposed to OR, this idiom prevents some unreachable code warning
32.2237+ (list
32.2238+ #+allegro
32.2239+ (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
32.2240+ excl::*common-lisp-version-number*
32.2241+ ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
32.2242+ (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
32.2243+ ;; Note if not using International ACL
32.2244+ ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
32.2245+ (excl:ics-target-case (:-ics "8"))
32.2246+ (and (member :smp *features*) "S"))
32.2247+ #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
32.2248+ #+clisp
32.2249+ (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
32.2250+ #+clozure
32.2251+ (format nil "~d.~d-f~d" ; shorten for windows
32.2252+ ccl::*openmcl-major-version*
32.2253+ ccl::*openmcl-minor-version*
32.2254+ (logand (ccl-fasl-version) #xFF))
32.2255+ #+cmucl (substitute #\- #\/ s)
32.2256+ #+scl (format nil "~A~A" s
32.2257+ ;; ANSI upper case vs lower case.
32.2258+ (ecase ext:*case-mode* (:upper "") (:lower "l")))
32.2259+ #+ecl (format nil "~A~@[-~A~]" s
32.2260+ (let ((vcs-id (ext:lisp-implementation-vcs-id)))
32.2261+ (unless (equal vcs-id "UNKNOWN")
32.2262+ (subseq vcs-id 0 (min (length vcs-id) 8)))))
32.2263+ #+gcl (subseq s (1+ (position #\space s)))
32.2264+ #+genera
32.2265+ (multiple-value-bind (major minor) (sct:get-system-version "System")
32.2266+ (format nil "~D.~D" major minor))
32.2267+ #+mcl (subseq s 8) ; strip the leading "Version "
32.2268+ #+mezzano (format nil "~A-~D"
32.2269+ (subseq s 0 (position #\space s)) ; strip commit hash
32.2270+ sys.int::*llf-version*)
32.2271+ ;; seems like there should be a shorter way to do this, like ACALL.
32.2272+ #+mkcl (or
32.2273+ (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil)))
32.2274+ (when (and fname (fboundp fname))
32.2275+ (funcall fname)))
32.2276+ s)
32.2277+ s))))
32.2278+
32.2279+ (defun implementation-identifier ()
32.2280+ "Return a string that identifies the ABI of the current implementation,
32.2281+suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc."
32.2282+ (substitute-if
32.2283+ #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
32.2284+ (format nil "~(~a~@{~@[-~a~]~}~)"
32.2285+ (or (implementation-type) (lisp-implementation-type))
32.2286+ (lisp-version-string)
32.2287+ (or (operating-system) (software-type))
32.2288+ (or (architecture) (machine-type))))))
32.2289+
32.2290+
32.2291+;;;; Other system information
32.2292+
32.2293+(with-upgradability ()
32.2294+ (defun hostname ()
32.2295+ "return the hostname of the current host"
32.2296+ #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mezzano mkcl sbcl scl xcl) (machine-instance)
32.2297+ #+cormanlisp "localhost" ;; is there a better way? Does it matter?
32.2298+ #+allegro (symbol-call :excl.osi :gethostname)
32.2299+ #+clisp (first (split-string (machine-instance) :separator " "))
32.2300+ #+gcl (system:gethostname)))
32.2301+
32.2302+
32.2303+;;; Current directory
32.2304+(with-upgradability ()
32.2305+
32.2306+ #+cmucl
32.2307+ (defun parse-unix-namestring* (unix-namestring)
32.2308+ "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
32.2309+ (multiple-value-bind (host device directory name type version)
32.2310+ (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
32.2311+ (make-pathname :host (or host lisp::*unix-host*) :device device
32.2312+ :directory directory :name name :type type :version version)))
32.2313+
32.2314+ (defun getcwd ()
32.2315+ "Get the current working directory as per POSIX getcwd(3), as a pathname object"
32.2316+ (or #+(or abcl genera mezzano xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
32.2317+ #+allegro (excl::current-directory)
32.2318+ #+clisp (ext:default-directory)
32.2319+ #+clozure (ccl:current-directory)
32.2320+ #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring
32.2321+ (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
32.2322+ #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
32.2323+ #+(or clasp ecl) (ext:getcwd)
32.2324+ #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
32.2325+ #+lispworks (hcl:get-working-directory)
32.2326+ #+mkcl (mk-ext:getcwd)
32.2327+ #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
32.2328+ #+xcl (extensions:current-directory)
32.2329+ (not-implemented-error 'getcwd)))
32.2330+
32.2331+ (defun chdir (x)
32.2332+ "Change current directory, as per POSIX chdir(2), to a given pathname object"
32.2333+ (if-let (x (pathname x))
32.2334+ #+(or abcl genera mezzano xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
32.2335+ #+allegro (excl:chdir x)
32.2336+ #+clisp (ext:cd x)
32.2337+ #+clozure (setf (ccl:current-directory) x)
32.2338+ #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x))
32.2339+ #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
32.2340+ (error "Could not set current directory to ~A" x))
32.2341+ #+ecl (ext:chdir x)
32.2342+ #+clasp (ext:chdir x t)
32.2343+ #+gcl (system:chdir x)
32.2344+ #+lispworks (hcl:change-directory x)
32.2345+ #+mkcl (mk-ext:chdir x)
32.2346+ #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
32.2347+ #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
32.2348+ (not-implemented-error 'chdir))))
32.2349+
32.2350+
32.2351+;;;; -----------------------------------------------------------------
32.2352+;;;; Windows shortcut support. Based on:
32.2353+;;;;
32.2354+;;;; Jesse Hager: The Windows Shortcut File Format.
32.2355+;;;; http://www.wotsit.org/list.asp?fc=13
32.2356+
32.2357+#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
32.2358+(with-upgradability ()
32.2359+ (defparameter *link-initial-dword* 76)
32.2360+ (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
32.2361+
32.2362+ (defun read-null-terminated-string (s)
32.2363+ "Read a null-terminated string from an octet stream S"
32.2364+ ;; note: doesn't play well with UNICODE
32.2365+ (with-output-to-string (out)
32.2366+ (loop :for code = (read-byte s)
32.2367+ :until (zerop code)
32.2368+ :do (write-char (code-char code) out))))
32.2369+
32.2370+ (defun read-little-endian (s &optional (bytes 4))
32.2371+ "Read a number in little-endian format from an byte (octet) stream S,
32.2372+the number having BYTES octets (defaulting to 4)."
32.2373+ (loop :for i :from 0 :below bytes
32.2374+ :sum (ash (read-byte s) (* 8 i))))
32.2375+
32.2376+ (defun parse-file-location-info (s)
32.2377+ "helper to parse-windows-shortcut"
32.2378+ (let ((start (file-position s))
32.2379+ (total-length (read-little-endian s))
32.2380+ (end-of-header (read-little-endian s))
32.2381+ (fli-flags (read-little-endian s))
32.2382+ (local-volume-offset (read-little-endian s))
32.2383+ (local-offset (read-little-endian s))
32.2384+ (network-volume-offset (read-little-endian s))
32.2385+ (remaining-offset (read-little-endian s)))
32.2386+ (declare (ignore total-length end-of-header local-volume-offset))
32.2387+ (unless (zerop fli-flags)
32.2388+ (cond
32.2389+ ((logbitp 0 fli-flags)
32.2390+ (file-position s (+ start local-offset)))
32.2391+ ((logbitp 1 fli-flags)
32.2392+ (file-position s (+ start
32.2393+ network-volume-offset
32.2394+ #x14))))
32.2395+ (strcat (read-null-terminated-string s)
32.2396+ (progn
32.2397+ (file-position s (+ start remaining-offset))
32.2398+ (read-null-terminated-string s))))))
32.2399+
32.2400+ (defun parse-windows-shortcut (pathname)
32.2401+ "From a .lnk windows shortcut, extract the pathname linked to"
32.2402+ ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE.
32.2403+ (with-open-file (s pathname :element-type '(unsigned-byte 8))
32.2404+ (handler-case
32.2405+ (when (and (= (read-little-endian s) *link-initial-dword*)
32.2406+ (let ((header (make-array (length *link-guid*))))
32.2407+ (read-sequence header s)
32.2408+ (equalp header *link-guid*)))
32.2409+ (let ((flags (read-little-endian s)))
32.2410+ (file-position s 76) ;skip rest of header
32.2411+ (when (logbitp 0 flags)
32.2412+ ;; skip shell item id list
32.2413+ (let ((length (read-little-endian s 2)))
32.2414+ (file-position s (+ length (file-position s)))))
32.2415+ (cond
32.2416+ ((logbitp 1 flags)
32.2417+ (parse-file-location-info s))
32.2418+ (t
32.2419+ (when (logbitp 2 flags)
32.2420+ ;; skip description string
32.2421+ (let ((length (read-little-endian s 2)))
32.2422+ (file-position s (+ length (file-position s)))))
32.2423+ (when (logbitp 3 flags)
32.2424+ ;; finally, our pathname
32.2425+ (let* ((length (read-little-endian s 2))
32.2426+ (buffer (make-array length)))
32.2427+ (read-sequence buffer s)
32.2428+ (map 'string #'code-char buffer)))))))
32.2429+ (end-of-file (c)
32.2430+ (declare (ignore c))
32.2431+ nil)))))
32.2432+
32.2433+
32.2434+;;;; -------------------------------------------------------------------------
32.2435+;;;; Portability layer around Common Lisp pathnames
32.2436+;; This layer allows for portable manipulation of pathname objects themselves,
32.2437+;; which all is necessary prior to any access the filesystem or environment.
32.2438+
32.2439+(uiop/package:define-package :uiop/pathname
32.2440+ (:nicknames :asdf/pathname) ;; deprecated. Used by ceramic
32.2441+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os)
32.2442+ (:export
32.2443+ ;; Making and merging pathnames, portably
32.2444+ #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
32.2445+ #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname*
32.2446+ #:make-pathname-component-logical #:make-pathname-logical
32.2447+ #:merge-pathnames*
32.2448+ #:nil-pathname #:*nil-pathname* #:with-pathname-defaults
32.2449+ ;; Predicates
32.2450+ #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname
32.2451+ #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
32.2452+ ;; Directories
32.2453+ #:pathname-directory-pathname #:pathname-parent-directory-pathname
32.2454+ #:directory-pathname-p #:ensure-directory-pathname
32.2455+ ;; Parsing filenames
32.2456+ #:split-name-type #:parse-unix-namestring #:unix-namestring
32.2457+ #:split-unix-namestring-directory-components
32.2458+ ;; Absolute and relative pathnames
32.2459+ #:subpathname #:subpathname*
32.2460+ #:ensure-absolute-pathname
32.2461+ #:pathname-root #:pathname-host-pathname
32.2462+ #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname
32.2463+ ;; Checking constraints
32.2464+ #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
32.2465+ ;; Wildcard pathnames
32.2466+ #:*wild* #:*wild-file* #:*wild-file-for-directory* #:*wild-directory*
32.2467+ #:*wild-inferiors* #:*wild-path* #:wilden
32.2468+ ;; Translate a pathname
32.2469+ #:relativize-directory-component #:relativize-pathname-directory
32.2470+ #:directory-separator-for-host #:directorize-pathname-host-device
32.2471+ #:translate-pathname*
32.2472+ #:*output-translation-function*))
32.2473+(in-package :uiop/pathname)
32.2474+
32.2475+;;; Normalizing pathnames across implementations
32.2476+
32.2477+(with-upgradability ()
32.2478+ (defun normalize-pathname-directory-component (directory)
32.2479+ "Convert the DIRECTORY component from a format usable by the underlying
32.2480+implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
32.2481+that is a list and not a string."
32.2482+ (cond
32.2483+ #-(or cmucl sbcl scl) ;; these implementations already normalize directory components.
32.2484+ ((stringp directory) `(:absolute ,directory))
32.2485+ ((or (null directory)
32.2486+ (and (consp directory) (member (first directory) '(:absolute :relative))))
32.2487+ directory)
32.2488+ #+gcl
32.2489+ ((consp directory)
32.2490+ (cons :relative directory))
32.2491+ (t
32.2492+ (parameter-error (compatfmt "~@<~S: Unrecognized pathname directory component ~S~@:>")
32.2493+ 'normalize-pathname-directory-component directory))))
32.2494+
32.2495+ (defun denormalize-pathname-directory-component (directory-component)
32.2496+ "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
32.2497+by the underlying implementation's MAKE-PATHNAME and other primitives"
32.2498+ directory-component)
32.2499+
32.2500+ (defun merge-pathname-directory-components (specified defaults)
32.2501+ "Helper for MERGE-PATHNAMES* that handles directory components"
32.2502+ (let ((directory (normalize-pathname-directory-component specified)))
32.2503+ (ecase (first directory)
32.2504+ ((nil) defaults)
32.2505+ (:absolute specified)
32.2506+ (:relative
32.2507+ (let ((defdir (normalize-pathname-directory-component defaults))
32.2508+ (reldir (cdr directory)))
32.2509+ (cond
32.2510+ ((null defdir)
32.2511+ directory)
32.2512+ ((not (eq :back (first reldir)))
32.2513+ (append defdir reldir))
32.2514+ (t
32.2515+ (loop :with defabs = (first defdir)
32.2516+ :with defrev = (reverse (rest defdir))
32.2517+ :while (and (eq :back (car reldir))
32.2518+ (or (and (eq :absolute defabs) (null defrev))
32.2519+ (stringp (car defrev))))
32.2520+ :do (pop reldir) (pop defrev)
32.2521+ :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
32.2522+
32.2523+ ;; Giving :unspecific as :type argument to make-pathname is not portable.
32.2524+ ;; See CLHS make-pathname and 19.2.2.2.3.
32.2525+ ;; This will be :unspecific if supported, or NIL if not.
32.2526+ (defparameter *unspecific-pathname-type*
32.2527+ #+(or abcl allegro clozure cmucl lispworks sbcl scl) :unspecific
32.2528+ #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil
32.2529+ "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
32.2530+
32.2531+ (defun make-pathname* (&rest keys &key directory host device name type version defaults
32.2532+ #+scl &allow-other-keys)
32.2533+ "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
32.2534+ tries hard to make a pathname that will actually behave as documented,
32.2535+ despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME."
32.2536+ (declare (ignore host device directory name type version defaults))
32.2537+ (apply 'make-pathname keys))
32.2538+
32.2539+ (defun make-pathname-component-logical (x)
32.2540+ "Make a pathname component suitable for use in a logical-pathname"
32.2541+ (typecase x
32.2542+ ((eql :unspecific) nil)
32.2543+ #+clisp (string (string-upcase x))
32.2544+ #+clisp (cons (mapcar 'make-pathname-component-logical x))
32.2545+ (t x)))
32.2546+
32.2547+ (defun make-pathname-logical (pathname host)
32.2548+ "Take a PATHNAME's directory, name, type and version components,
32.2549+and make a new pathname with corresponding components and specified logical HOST"
32.2550+ (make-pathname
32.2551+ :host host
32.2552+ :directory (make-pathname-component-logical (pathname-directory pathname))
32.2553+ :name (make-pathname-component-logical (pathname-name pathname))
32.2554+ :type (make-pathname-component-logical (pathname-type pathname))
32.2555+ :version (make-pathname-component-logical (pathname-version pathname))))
32.2556+
32.2557+ (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
32.2558+ "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
32.2559+if the SPECIFIED pathname does not have an absolute directory,
32.2560+then the HOST and DEVICE both come from the DEFAULTS, whereas
32.2561+if the SPECIFIED pathname does have an absolute directory,
32.2562+then the HOST and DEVICE both come from the SPECIFIED pathname.
32.2563+This is what users want on a modern Unix or Windows operating system,
32.2564+unlike the MERGE-PATHNAMES behavior.
32.2565+Also, if either argument is NIL, then the other argument is returned unmodified;
32.2566+this is unlike MERGE-PATHNAMES which always merges with a pathname,
32.2567+by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
32.2568+ (when (null specified) (return-from merge-pathnames* defaults))
32.2569+ (when (null defaults) (return-from merge-pathnames* specified))
32.2570+ #+scl
32.2571+ (ext:resolve-pathname specified defaults)
32.2572+ #-scl
32.2573+ (let* ((specified (pathname specified))
32.2574+ (defaults (pathname defaults))
32.2575+ (directory (normalize-pathname-directory-component (pathname-directory specified)))
32.2576+ (name (or (pathname-name specified) (pathname-name defaults)))
32.2577+ (type (or (pathname-type specified) (pathname-type defaults)))
32.2578+ (version (or (pathname-version specified) (pathname-version defaults))))
32.2579+ (labels ((unspecific-handler (p)
32.2580+ (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
32.2581+ (multiple-value-bind (host device directory unspecific-handler)
32.2582+ (ecase (first directory)
32.2583+ ((:absolute)
32.2584+ (values (pathname-host specified)
32.2585+ (pathname-device specified)
32.2586+ directory
32.2587+ (unspecific-handler specified)))
32.2588+ ((nil :relative)
32.2589+ (values (pathname-host defaults)
32.2590+ (pathname-device defaults)
32.2591+ (merge-pathname-directory-components directory (pathname-directory defaults))
32.2592+ (unspecific-handler defaults))))
32.2593+ (make-pathname :host host :device device :directory directory
32.2594+ :name (funcall unspecific-handler name)
32.2595+ :type (funcall unspecific-handler type)
32.2596+ :version (funcall unspecific-handler version))))))
32.2597+
32.2598+ (defun logical-pathname-p (x)
32.2599+ "is X a logical-pathname?"
32.2600+ (typep x 'logical-pathname))
32.2601+
32.2602+ (defun physical-pathname-p (x)
32.2603+ "is X a pathname that is not a logical-pathname?"
32.2604+ (and (pathnamep x) (not (logical-pathname-p x))))
32.2605+
32.2606+ (defun physicalize-pathname (x)
32.2607+ "if X is a logical pathname, use translate-logical-pathname on it."
32.2608+ ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP
32.2609+ (let ((p (when x (pathname x))))
32.2610+ (if (logical-pathname-p p) (translate-logical-pathname p) p)))
32.2611+
32.2612+ (defun nil-pathname (&optional (defaults *default-pathname-defaults*))
32.2613+ "A pathname that is as neutral as possible for use as defaults
32.2614+when merging, making or parsing pathnames"
32.2615+ ;; 19.2.2.2.1 says a NIL host can mean a default host;
32.2616+ ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
32.2617+ ;; strings and lists of strings or :unspecific
32.2618+ ;; But CMUCL decides to die on NIL.
32.2619+ ;; MCL has issues with make-pathname, nil and defaulting
32.2620+ (declare (ignorable defaults))
32.2621+ #.`(make-pathname :directory nil :name nil :type nil :version nil
32.2622+ :device (or #+(and mkcl os-unix) :unspecific)
32.2623+ :host (or #+cmucl lisp::*unix-host* #+(and mkcl os-unix) "localhost")
32.2624+ #+scl ,@'(:scheme nil :scheme-specific-part nil
32.2625+ :username nil :password nil :parameters nil :query nil :fragment nil)
32.2626+ ;; the default shouldn't matter, but we really want something physical
32.2627+ #-mcl ,@'(:defaults defaults)))
32.2628+
32.2629+ (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname)))
32.2630+ "A pathname that is as neutral as possible for use as defaults
32.2631+when merging, making or parsing pathnames")
32.2632+
32.2633+ (defmacro with-pathname-defaults ((&optional defaults) &body body)
32.2634+ "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified,
32.2635+where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except
32.2636+on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory."
32.2637+ `(let ((*default-pathname-defaults*
32.2638+ ,(or defaults
32.2639+ #-(or abcl genera xcl) '*nil-pathname*
32.2640+ #+(or abcl genera xcl) '*default-pathname-defaults*)))
32.2641+ ,@body)))
32.2642+
32.2643+
32.2644+;;; Some pathname predicates
32.2645+(with-upgradability ()
32.2646+ (defun pathname-equal (p1 p2)
32.2647+ "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?"
32.2648+ (when (stringp p1) (setf p1 (pathname p1)))
32.2649+ (when (stringp p2) (setf p2 (pathname p2)))
32.2650+ (flet ((normalize-component (x)
32.2651+ (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
32.2652+ x)))
32.2653+ (macrolet ((=? (&rest accessors)
32.2654+ (flet ((frob (x)
32.2655+ (reduce 'list (cons 'normalize-component accessors)
32.2656+ :initial-value x :from-end t)))
32.2657+ `(equal ,(frob 'p1) ,(frob 'p2)))))
32.2658+ (or (and (null p1) (null p2))
32.2659+ (and (pathnamep p1) (pathnamep p2)
32.2660+ (and (=? pathname-host)
32.2661+ #-(and mkcl os-unix) (=? pathname-device)
32.2662+ (=? normalize-pathname-directory-component pathname-directory)
32.2663+ (=? pathname-name)
32.2664+ (=? pathname-type)
32.2665+ #-mkcl (=? pathname-version)))))))
32.2666+
32.2667+ (defun absolute-pathname-p (pathspec)
32.2668+ "If PATHSPEC is a pathname or namestring object that parses as a pathname
32.2669+possessing an :ABSOLUTE directory component, return the (parsed) pathname.
32.2670+Otherwise return NIL"
32.2671+ (and pathspec
32.2672+ (typep pathspec '(or null pathname string))
32.2673+ (let ((pathname (pathname pathspec)))
32.2674+ (and (eq :absolute (car (normalize-pathname-directory-component
32.2675+ (pathname-directory pathname))))
32.2676+ pathname))))
32.2677+
32.2678+ (defun relative-pathname-p (pathspec)
32.2679+ "If PATHSPEC is a pathname or namestring object that parses as a pathname
32.2680+possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
32.2681+Otherwise return NIL"
32.2682+ (and pathspec
32.2683+ (typep pathspec '(or null pathname string))
32.2684+ (let* ((pathname (pathname pathspec))
32.2685+ (directory (normalize-pathname-directory-component
32.2686+ (pathname-directory pathname))))
32.2687+ (when (or (null directory) (eq :relative (car directory)))
32.2688+ pathname))))
32.2689+
32.2690+ (defun hidden-pathname-p (pathname)
32.2691+ "Return a boolean that is true if the pathname is hidden as per Unix style,
32.2692+i.e. its name starts with a dot."
32.2693+ (and pathname (equal (first-char (pathname-name pathname)) #\.)))
32.2694+
32.2695+ (defun file-pathname-p (pathname)
32.2696+ "Does PATHNAME represent a file, i.e. has a non-null NAME component?
32.2697+
32.2698+Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
32.2699+
32.2700+Note that this does _not_ check to see that PATHNAME points to an
32.2701+actually-existing file.
32.2702+
32.2703+Returns the (parsed) PATHNAME when true"
32.2704+ (when pathname
32.2705+ (let ((pathname (pathname pathname)))
32.2706+ (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal)
32.2707+ (member (pathname-type pathname) '(nil :unspecific "") :test 'equal))
32.2708+ pathname)))))
32.2709+
32.2710+
32.2711+;;; Directory pathnames
32.2712+(with-upgradability ()
32.2713+ (defun pathname-directory-pathname (pathname)
32.2714+ "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
32.2715+and NIL NAME, TYPE and VERSION components"
32.2716+ (when pathname
32.2717+ (make-pathname :name nil :type nil :version nil :defaults pathname)))
32.2718+
32.2719+ (defun pathname-parent-directory-pathname (pathname)
32.2720+ "Returns a new pathname that corresponds to the parent of the current pathname's directory,
32.2721+i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
32.2722+Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
32.2723+ (when pathname
32.2724+ (make-pathname :name nil :type nil :version nil
32.2725+ :directory (merge-pathname-directory-components
32.2726+ '(:relative :back) (pathname-directory pathname))
32.2727+ :defaults pathname)))
32.2728+
32.2729+ (defun directory-pathname-p (pathname)
32.2730+ "Does PATHNAME represent a directory?
32.2731+
32.2732+A directory-pathname is a pathname _without_ a filename. The three
32.2733+ways that the filename components can be missing are for it to be NIL,
32.2734+:UNSPECIFIC or the empty string.
32.2735+
32.2736+Note that this does _not_ check to see that PATHNAME points to an
32.2737+actually-existing directory."
32.2738+ (when pathname
32.2739+ ;; I tried using Allegro's excl:file-directory-p, but this cannot be done,
32.2740+ ;; because it rejects apparently legal pathnames as
32.2741+ ;; ill-formed. [2014/02/10:rpg]
32.2742+ (let ((pathname (pathname pathname)))
32.2743+ (flet ((check-one (x)
32.2744+ (member x '(nil :unspecific) :test 'equal)))
32.2745+ (and (not (wild-pathname-p pathname))
32.2746+ (check-one (pathname-name pathname))
32.2747+ (check-one (pathname-type pathname))
32.2748+ t)))))
32.2749+
32.2750+ (defun ensure-directory-pathname (pathspec &optional (on-error 'error))
32.2751+ "Converts the non-wild pathname designator PATHSPEC to directory form."
32.2752+ (cond
32.2753+ ((stringp pathspec)
32.2754+ (ensure-directory-pathname (pathname pathspec)))
32.2755+ ((not (pathnamep pathspec))
32.2756+ (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
32.2757+ ((wild-pathname-p pathspec)
32.2758+ (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
32.2759+ ((directory-pathname-p pathspec)
32.2760+ pathspec)
32.2761+ (t
32.2762+ (handler-case
32.2763+ (make-pathname :directory (append (or (normalize-pathname-directory-component
32.2764+ (pathname-directory pathspec))
32.2765+ (list :relative))
32.2766+ (list #-genera (file-namestring pathspec)
32.2767+ ;; On Genera's native filesystem (LMFS),
32.2768+ ;; directories have a type and version
32.2769+ ;; which must be ignored when converting
32.2770+ ;; to a directory pathname
32.2771+ #+genera (if (typep pathspec 'fs:lmfs-pathname)
32.2772+ (pathname-name pathspec)
32.2773+ (file-namestring pathspec))))
32.2774+ :name nil :type nil :version nil :defaults pathspec)
32.2775+ (error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c)))))))
32.2776+
32.2777+
32.2778+;;; Parsing filenames
32.2779+(with-upgradability ()
32.2780+ (declaim (ftype function ensure-pathname)) ; forward reference
32.2781+
32.2782+ (defun split-unix-namestring-directory-components
32.2783+ (unix-namestring &key ensure-directory dot-dot)
32.2784+ "Splits the path string UNIX-NAMESTRING, returning four values:
32.2785+A flag that is either :absolute or :relative, indicating
32.2786+ how the rest of the values are to be interpreted.
32.2787+A directory path --- a list of strings and keywords, suitable for
32.2788+ use with MAKE-PATHNAME when prepended with the flag value.
32.2789+ Directory components with an empty name or the name . are removed.
32.2790+ Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
32.2791+A last-component, either a file-namestring including type extension,
32.2792+ or NIL in the case of a directory pathname.
32.2793+A flag that is true iff the unix-style-pathname was just
32.2794+ a file-namestring without / path specification.
32.2795+ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
32.2796+the third return value will be NIL, and final component of the namestring
32.2797+will be treated as part of the directory path.
32.2798+
32.2799+An empty string is thus read as meaning a pathname object with all fields nil.
32.2800+
32.2801+Note that colon characters #\: will NOT be interpreted as host specification.
32.2802+Absolute pathnames are only appropriate on Unix-style systems.
32.2803+
32.2804+The intention of this function is to support structured component names,
32.2805+e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
32.2806+ (check-type unix-namestring string)
32.2807+ (check-type dot-dot (member nil :back :up))
32.2808+ (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
32.2809+ (plusp (length unix-namestring)))
32.2810+ (values :relative () unix-namestring t)
32.2811+ (let* ((components (split-string unix-namestring :separator "/"))
32.2812+ (last-comp (car (last components))))
32.2813+ (multiple-value-bind (relative components)
32.2814+ (if (equal (first components) "")
32.2815+ (if (equal (first-char unix-namestring) #\/)
32.2816+ (values :absolute (cdr components))
32.2817+ (values :relative nil))
32.2818+ (values :relative components))
32.2819+ (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
32.2820+ components))
32.2821+ (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
32.2822+ (cond
32.2823+ ((equal last-comp "")
32.2824+ (values relative components nil nil)) ; "" already removed from components
32.2825+ (ensure-directory
32.2826+ (values relative components nil nil))
32.2827+ (t
32.2828+ (values relative (butlast components) last-comp nil)))))))
32.2829+
32.2830+ (defun split-name-type (filename)
32.2831+ "Split a filename into two values NAME and TYPE that are returned.
32.2832+We assume filename has no directory component.
32.2833+The last . if any separates name and type from from type,
32.2834+except that if there is only one . and it is in first position,
32.2835+the whole filename is the NAME with an empty type.
32.2836+NAME is always a string.
32.2837+For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
32.2838+ (check-type filename string)
32.2839+ (assert (plusp (length filename)))
32.2840+ (destructuring-bind (name &optional (type *unspecific-pathname-type*))
32.2841+ (split-string filename :max 2 :separator ".")
32.2842+ (if (equal name "")
32.2843+ (values filename *unspecific-pathname-type*)
32.2844+ (values name type))))
32.2845+
32.2846+ (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
32.2847+ &allow-other-keys)
32.2848+ "Coerce NAME into a PATHNAME using standard Unix syntax.
32.2849+
32.2850+Unix syntax is used whether or not the underlying system is Unix;
32.2851+on such non-Unix systems it is reliably usable only for relative pathnames.
32.2852+This function is especially useful to manipulate relative pathnames portably,
32.2853+where it is crucial to possess a portable pathname syntax independent of the underlying OS.
32.2854+This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
32.2855+
32.2856+When given a PATHNAME object, just return it untouched.
32.2857+When given NIL, just return NIL.
32.2858+When given a non-null SYMBOL, first downcase its name and treat it as a string.
32.2859+When given a STRING, portably decompose it into a pathname as below.
32.2860+
32.2861+#\\/ separates directory components.
32.2862+
32.2863+The last #\\/-separated substring is interpreted as follows:
32.2864+1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
32.2865+ the string is made the last directory component, and NAME and TYPE are NIL.
32.2866+ if the string is empty, it's the empty pathname with all slots NIL.
32.2867+2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE
32.2868+ are separated by SPLIT-NAME-TYPE.
32.2869+3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
32.2870+
32.2871+Directory components with an empty name or the name \".\" are removed.
32.2872+Any directory named \"..\" is read as DOT-DOT,
32.2873+which must be one of :BACK or :UP and defaults to :BACK.
32.2874+
32.2875+HOST, DEVICE and VERSION components are taken from DEFAULTS,
32.2876+which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL.
32.2877+No host or device can be specified in the string itself,
32.2878+which makes it unsuitable for absolute pathnames outside Unix.
32.2879+
32.2880+For relative pathnames, these components (and hence the defaults) won't matter
32.2881+if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
32.2882+which is an important reason to always use MERGE-PATHNAMES*.
32.2883+
32.2884+Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
32.2885+with those keys, removing TYPE DEFAULTS and DOT-DOT.
32.2886+When you're manipulating pathnames that are supposed to make sense portably
32.2887+even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
32.2888+to throw an error if the pathname is absolute"
32.2889+ (block nil
32.2890+ (check-type type (or null string (eql :directory)))
32.2891+ (when ensure-directory
32.2892+ (setf type :directory))
32.2893+ (etypecase name
32.2894+ ((or null pathname) (return name))
32.2895+ (symbol
32.2896+ (setf name (string-downcase name)))
32.2897+ (string))
32.2898+ (multiple-value-bind (relative path filename file-only)
32.2899+ (split-unix-namestring-directory-components
32.2900+ name :dot-dot dot-dot :ensure-directory (eq type :directory))
32.2901+ (multiple-value-bind (name type)
32.2902+ (cond
32.2903+ ((or (eq type :directory) (null filename))
32.2904+ (values nil nil))
32.2905+ (type
32.2906+ (values filename type))
32.2907+ (t
32.2908+ (split-name-type filename)))
32.2909+ (let* ((directory
32.2910+ (unless file-only (cons relative path)))
32.2911+ (pathname
32.2912+ #-abcl
32.2913+ (make-pathname
32.2914+ :directory directory
32.2915+ :name name :type type
32.2916+ :defaults (or #-mcl defaults *nil-pathname*))
32.2917+ #+abcl
32.2918+ (if (and defaults
32.2919+ (ext:pathname-jar-p defaults)
32.2920+ (null directory))
32.2921+ ;; When DEFAULTS is a jar, it will have the directory we want
32.2922+ (make-pathname :name name :type type
32.2923+ :defaults (or defaults *nil-pathname*))
32.2924+ (make-pathname :name name :type type
32.2925+ :defaults (or defaults *nil-pathname*)
32.2926+ :directory directory))))
32.2927+ (apply 'ensure-pathname
32.2928+ pathname
32.2929+ (remove-plist-keys '(:type :dot-dot :defaults) keys)))))))
32.2930+
32.2931+ (defun unix-namestring (pathname)
32.2932+ "Given a non-wild PATHNAME, return a Unix-style namestring for it.
32.2933+If the PATHNAME is NIL or a STRING, return it unchanged.
32.2934+
32.2935+This only considers the DIRECTORY, NAME and TYPE components of the pathname.
32.2936+This is a portable solution for representing relative pathnames,
32.2937+But unless you are running on a Unix system, it is not a general solution
32.2938+to representing native pathnames.
32.2939+
32.2940+An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
32.2941+or if it is a PATHNAME but some of its components are not recognized."
32.2942+ (etypecase pathname
32.2943+ ((or null string) pathname)
32.2944+ (pathname
32.2945+ (with-output-to-string (s)
32.2946+ (flet ((err () (parameter-error "~S: invalid unix-namestring ~S"
32.2947+ 'unix-namestring pathname)))
32.2948+ (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
32.2949+ (name (pathname-name pathname))
32.2950+ (name (and (not (eq name :unspecific)) name))
32.2951+ (type (pathname-type pathname))
32.2952+ (type (and (not (eq type :unspecific)) type)))
32.2953+ (cond
32.2954+ ((member dir '(nil :unspecific)))
32.2955+ ((eq dir '(:relative)) (princ "./" s))
32.2956+ ((consp dir)
32.2957+ (destructuring-bind (relabs &rest dirs) dir
32.2958+ (or (member relabs '(:relative :absolute)) (err))
32.2959+ (when (eq relabs :absolute) (princ #\/ s))
32.2960+ (loop :for x :in dirs :do
32.2961+ (cond
32.2962+ ((member x '(:back :up)) (princ "../" s))
32.2963+ ((equal x "") (err))
32.2964+ ;;((member x '("." "..") :test 'equal) (err))
32.2965+ ((stringp x) (format s "~A/" x))
32.2966+ (t (err))))))
32.2967+ (t (err)))
32.2968+ (cond
32.2969+ (name
32.2970+ (unless (and (stringp name) (or (null type) (stringp type))) (err))
32.2971+ (format s "~A~@[.~A~]" name type))
32.2972+ (t
32.2973+ (or (null type) (err)))))))))))
32.2974+
32.2975+;;; Absolute and relative pathnames
32.2976+(with-upgradability ()
32.2977+ (defun subpathname (pathname subpath &key type)
32.2978+ "This function takes a PATHNAME and a SUBPATH and a TYPE.
32.2979+If SUBPATH is already a PATHNAME object (not namestring),
32.2980+and is an absolute pathname at that, it is returned unchanged;
32.2981+otherwise, SUBPATH is turned into a relative pathname with given TYPE
32.2982+as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
32.2983+then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
32.2984+ (or (and (pathnamep subpath) (absolute-pathname-p subpath))
32.2985+ (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
32.2986+ (pathname-directory-pathname pathname))))
32.2987+
32.2988+ (defun subpathname* (pathname subpath &key type)
32.2989+ "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
32.2990+ (and pathname
32.2991+ (subpathname (ensure-directory-pathname pathname) subpath :type type)))
32.2992+
32.2993+ (defun pathname-root (pathname)
32.2994+ "return the root directory for the host and device of given PATHNAME"
32.2995+ (make-pathname :directory '(:absolute)
32.2996+ :name nil :type nil :version nil
32.2997+ :defaults pathname ;; host device, and on scl, *some*
32.2998+ ;; scheme-specific parts: port username password, not others:
32.2999+ . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
32.3000+
32.3001+ (defun pathname-host-pathname (pathname)
32.3002+ "return a pathname with the same host as given PATHNAME, and all other fields NIL"
32.3003+ (make-pathname :directory nil
32.3004+ :name nil :type nil :version nil :device nil
32.3005+ :defaults pathname ;; host device, and on scl, *some*
32.3006+ ;; scheme-specific parts: port username password, not others:
32.3007+ . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
32.3008+
32.3009+ (defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
32.3010+ "Given a pathname designator PATH, return an absolute pathname as specified by PATH
32.3011+considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,
32.3012+with a format control-string and other arguments as arguments"
32.3013+ (cond
32.3014+ ((absolute-pathname-p path))
32.3015+ ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
32.3016+ ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
32.3017+ ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
32.3018+ (or (if (absolute-pathname-p default-pathname)
32.3019+ (absolute-pathname-p (merge-pathnames* path default-pathname))
32.3020+ (call-function on-error "Default pathname ~S is not an absolute pathname"
32.3021+ default-pathname))
32.3022+ (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
32.3023+ path default-pathname))))
32.3024+ (t (call-function on-error
32.3025+ "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
32.3026+ path defaults))))
32.3027+
32.3028+ (defun subpathp (maybe-subpath base-pathname)
32.3029+ "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
32.3030+when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
32.3031+ (and (pathnamep maybe-subpath) (pathnamep base-pathname)
32.3032+ (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
32.3033+ (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
32.3034+ (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
32.3035+ (with-pathname-defaults (*nil-pathname*)
32.3036+ (let ((enough (enough-namestring maybe-subpath base-pathname)))
32.3037+ (and (relative-pathname-p enough) (pathname enough))))))
32.3038+
32.3039+ (defun enough-pathname (maybe-subpath base-pathname)
32.3040+ "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
32.3041+when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
32.3042+ (let ((sub (when maybe-subpath (pathname maybe-subpath)))
32.3043+ (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
32.3044+ (or (and base (subpathp sub base)) sub)))
32.3045+
32.3046+ (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk)
32.3047+ "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null,
32.3048+or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH
32.3049+given DEFAULTS-PATHNAME as a base pathname."
32.3050+ (let ((enough (enough-pathname maybe-subpath defaults-pathname))
32.3051+ (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*)))
32.3052+ (funcall thunk enough)))
32.3053+
32.3054+ (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var)
32.3055+ (defaults *default-pathname-defaults*))
32.3056+ &body body)
32.3057+ "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME"
32.3058+ `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body))))
32.3059+
32.3060+
32.3061+;;; Wildcard pathnames
32.3062+(with-upgradability ()
32.3063+ (defparameter *wild* (or #+cormanlisp "*" :wild)
32.3064+ "Wild component for use with MAKE-PATHNAME")
32.3065+ (defparameter *wild-directory-component* (or :wild)
32.3066+ "Wild directory component for use with MAKE-PATHNAME")
32.3067+ (defparameter *wild-inferiors-component* (or :wild-inferiors)
32.3068+ "Wild-inferiors directory component for use with MAKE-PATHNAME")
32.3069+ (defparameter *wild-file*
32.3070+ (make-pathname :directory nil :name *wild* :type *wild*
32.3071+ :version (or #-(or allegro abcl xcl) *wild*))
32.3072+ "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME")
32.3073+ (defparameter *wild-file-for-directory*
32.3074+ (make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl) *wild*)
32.3075+ :version (or #-(or allegro abcl clisp gcl xcl) *wild*))
32.3076+ "A pathname object with wildcards for matching any file with DIRECTORY")
32.3077+ (defparameter *wild-directory*
32.3078+ (make-pathname :directory `(:relative ,*wild-directory-component*)
32.3079+ :name nil :type nil :version nil)
32.3080+ "A pathname object with wildcards for matching any subdirectory")
32.3081+ (defparameter *wild-inferiors*
32.3082+ (make-pathname :directory `(:relative ,*wild-inferiors-component*)
32.3083+ :name nil :type nil :version nil)
32.3084+ "A pathname object with wildcards for matching any recursive subdirectory")
32.3085+ (defparameter *wild-path*
32.3086+ (merge-pathnames* *wild-file* *wild-inferiors*)
32.3087+ "A pathname object with wildcards for matching any file in any recursive subdirectory")
32.3088+
32.3089+ (defun wilden (path)
32.3090+ "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory"
32.3091+ (merge-pathnames* *wild-path* path)))
32.3092+
32.3093+
32.3094+;;; Translate a pathname
32.3095+(with-upgradability ()
32.3096+ (defun relativize-directory-component (directory-component)
32.3097+ "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component"
32.3098+ (let ((directory (normalize-pathname-directory-component directory-component)))
32.3099+ (cond
32.3100+ ((stringp directory)
32.3101+ (list :relative directory))
32.3102+ ((eq (car directory) :absolute)
32.3103+ (cons :relative (cdr directory)))
32.3104+ (t
32.3105+ directory))))
32.3106+
32.3107+ (defun relativize-pathname-directory (pathspec)
32.3108+ "Given a PATHNAME, return a relative pathname with otherwise the same components"
32.3109+ (let ((p (pathname pathspec)))
32.3110+ (make-pathname
32.3111+ :directory (relativize-directory-component (pathname-directory p))
32.3112+ :defaults p)))
32.3113+
32.3114+ (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
32.3115+ "Given a PATHNAME, return the character used to delimit directory names on this host and device."
32.3116+ (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
32.3117+ (last-char (namestring foo))))
32.3118+
32.3119+ #-scl
32.3120+ (defun directorize-pathname-host-device (pathname)
32.3121+ "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
32.3122+added to its DIRECTORY component. This is useful for output translations."
32.3123+ (os-cond
32.3124+ ((os-unix-p)
32.3125+ (when (physical-pathname-p pathname)
32.3126+ (return-from directorize-pathname-host-device pathname))))
32.3127+ (let* ((root (pathname-root pathname))
32.3128+ (wild-root (wilden root))
32.3129+ (absolute-pathname (merge-pathnames* pathname root))
32.3130+ (separator (directory-separator-for-host root))
32.3131+ (root-namestring (namestring root))
32.3132+ (root-string
32.3133+ (substitute-if #\/
32.3134+ #'(lambda (x) (or (eql x #\:)
32.3135+ (eql x separator)))
32.3136+ root-namestring)))
32.3137+ (multiple-value-bind (relative path filename)
32.3138+ (split-unix-namestring-directory-components root-string :ensure-directory t)
32.3139+ (declare (ignore relative filename))
32.3140+ (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path))))
32.3141+ (translate-pathname absolute-pathname wild-root (wilden new-base))))))
32.3142+
32.3143+ #+scl
32.3144+ (defun directorize-pathname-host-device (pathname)
32.3145+ (let ((scheme (ext:pathname-scheme pathname))
32.3146+ (host (pathname-host pathname))
32.3147+ (port (ext:pathname-port pathname))
32.3148+ (directory (pathname-directory pathname)))
32.3149+ (flet ((specificp (x) (and x (not (eq x :unspecific)))))
32.3150+ (if (or (specificp port)
32.3151+ (and (specificp host) (plusp (length host)))
32.3152+ (specificp scheme))
32.3153+ (let ((prefix ""))
32.3154+ (when (specificp port)
32.3155+ (setf prefix (format nil ":~D" port)))
32.3156+ (when (and (specificp host) (plusp (length host)))
32.3157+ (setf prefix (strcat host prefix)))
32.3158+ (setf prefix (strcat ":" prefix))
32.3159+ (when (specificp scheme)
32.3160+ (setf prefix (strcat scheme prefix)))
32.3161+ (assert (and directory (eq (first directory) :absolute)))
32.3162+ (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
32.3163+ :defaults pathname)))
32.3164+ pathname)))
32.3165+
32.3166+ (defun translate-pathname* (path absolute-source destination &optional root source)
32.3167+ "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility.
32.3168+PATH is the pathname to be translated.
32.3169+ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname,
32.3170+DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE,
32.3171+or a relative pathname, to be merged with ROOT and used as destination for translate-pathname
32.3172+or an absolute pathname, to be used as destination for translate-pathname.
32.3173+In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE."
32.3174+ (declare (ignore source))
32.3175+ (cond
32.3176+ ((functionp destination)
32.3177+ (funcall destination path absolute-source))
32.3178+ ((eq destination t)
32.3179+ path)
32.3180+ ((not (pathnamep destination))
32.3181+ (parameter-error "~S: Invalid destination" 'translate-pathname*))
32.3182+ ((not (absolute-pathname-p destination))
32.3183+ (translate-pathname path absolute-source (merge-pathnames* destination root)))
32.3184+ (root
32.3185+ (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
32.3186+ (t
32.3187+ (translate-pathname path absolute-source destination))))
32.3188+
32.3189+ (defvar *output-translation-function* 'identity
32.3190+ "Hook for output translations.
32.3191+
32.3192+This function needs to be idempotent, so that actions can work
32.3193+whether their inputs were translated or not,
32.3194+which they will be if we are composing operations. e.g. if some
32.3195+create-lisp-op creates a lisp file from some higher-level input,
32.3196+you need to still be able to use compile-op on that lisp file."))
32.3197+;;;; -------------------------------------------------------------------------
32.3198+;;;; Portability layer around Common Lisp filesystem access
32.3199+
32.3200+(uiop/package:define-package :uiop/filesystem
32.3201+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
32.3202+ (:export
32.3203+ ;; Native namestrings
32.3204+ #:native-namestring #:parse-native-namestring
32.3205+ ;; Probing the filesystem
32.3206+ #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
32.3207+ #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
32.3208+ #:collect-sub*directories
32.3209+ ;; Resolving symlinks somewhat
32.3210+ #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
32.3211+ ;; merging with cwd
32.3212+ #:get-pathname-defaults #:call-with-current-directory #:with-current-directory
32.3213+ ;; Environment pathnames
32.3214+ #:inter-directory-separator #:split-native-pathnames-string
32.3215+ #:getenv-pathname #:getenv-pathnames
32.3216+ #:getenv-absolute-directory #:getenv-absolute-directories
32.3217+ #:lisp-implementation-directory #:lisp-implementation-pathname-p
32.3218+ ;; Simple filesystem operations
32.3219+ #:ensure-all-directories-exist
32.3220+ #:rename-file-overwriting-target
32.3221+ #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
32.3222+(in-package :uiop/filesystem)
32.3223+
32.3224+;;; Native namestrings, as seen by the operating system calls rather than Lisp
32.3225+(with-upgradability ()
32.3226+ (defun native-namestring (x)
32.3227+ "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
32.3228+ (when x
32.3229+ (let ((p (pathname x)))
32.3230+ #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
32.3231+ #+(or cmucl scl) (ext:unix-namestring p nil)
32.3232+ #+sbcl (sb-ext:native-namestring p)
32.3233+ #-(or clozure cmucl sbcl scl)
32.3234+ (os-cond
32.3235+ ((os-unix-p) (unix-namestring p))
32.3236+ (t (namestring p))))))
32.3237+
32.3238+ (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
32.3239+ "From a native namestring suitable for use by the operating system, return
32.3240+a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
32.3241+ (check-type string (or string null))
32.3242+ (let* ((pathname
32.3243+ (when string
32.3244+ (with-pathname-defaults ()
32.3245+ #+clozure (ccl:native-to-pathname string)
32.3246+ #+cmucl (uiop/os::parse-unix-namestring* string)
32.3247+ #+sbcl (sb-ext:parse-native-namestring string)
32.3248+ #+scl (lisp::parse-unix-namestring string)
32.3249+ #-(or clozure cmucl sbcl scl)
32.3250+ (os-cond
32.3251+ ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory))
32.3252+ (t (parse-namestring string))))))
32.3253+ (pathname
32.3254+ (if ensure-directory
32.3255+ (and pathname (ensure-directory-pathname pathname))
32.3256+ pathname)))
32.3257+ (apply 'ensure-pathname pathname constraints))))
32.3258+
32.3259+
32.3260+;;; Probing the filesystem
32.3261+(with-upgradability ()
32.3262+ (defun truename* (p)
32.3263+ "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
32.3264+ (when p
32.3265+ (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p))))
32.3266+ (values
32.3267+ (or (ignore-errors (truename p))
32.3268+ ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
32.3269+ ;; a trailing directory separator, causes an error on some lisps.
32.3270+ #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d)))
32.3271+ ;; On Genera, truename of a directory pathname will probably fail as Genera
32.3272+ ;; will merge in a filename/type/version from *default-pathname-defaults* and
32.3273+ ;; will try to get the truename of a file that probably doesn't exist.
32.3274+ #+genera (when (directory-pathname-p p)
32.3275+ (let ((d (scl:send p :directory-pathname-as-file)))
32.3276+ (ensure-directory-pathname (ignore-errors (truename d)) nil)))))))
32.3277+
32.3278+ (defun safe-file-write-date (pathname)
32.3279+ "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
32.3280+ ;; If FILE-WRITE-DATE returns NIL, it's possible that
32.3281+ ;; the user or some other agent has deleted an input file.
32.3282+ ;; Also, generated files will not exist at the time planning is done
32.3283+ ;; and calls compute-action-stamp which calls safe-file-write-date.
32.3284+ ;; So it is very possible that we can't get a valid file-write-date,
32.3285+ ;; and we can survive and we will continue the planning
32.3286+ ;; as if the file were very old.
32.3287+ ;; (or should we treat the case in a different, special way?)
32.3288+ (and pathname
32.3289+ (handler-case (file-write-date (physicalize-pathname pathname))
32.3290+ (file-error () nil))))
32.3291+
32.3292+ (defun probe-file* (p &key truename)
32.3293+ "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
32.3294+probes the filesystem for a file or directory with given pathname.
32.3295+If it exists, return its truename if TRUENAME is true,
32.3296+or the original (parsed) pathname if it is false (the default)."
32.3297+ (values
32.3298+ (ignore-errors
32.3299+ (setf p (funcall 'ensure-pathname p
32.3300+ :namestring :lisp
32.3301+ :ensure-physical t
32.3302+ :ensure-absolute t :defaults 'get-pathname-defaults
32.3303+ :want-non-wild t
32.3304+ :on-error nil))
32.3305+ (when p
32.3306+ #+allegro
32.3307+ (probe-file p :follow-symlinks truename)
32.3308+ #+gcl
32.3309+ (if truename
32.3310+ (truename* p)
32.3311+ (let ((kind (car (si::stat p))))
32.3312+ (when (eq kind :link)
32.3313+ (setf kind (ignore-errors (car (si::stat (truename* p))))))
32.3314+ (ecase kind
32.3315+ ((nil) nil)
32.3316+ ((:file :link)
32.3317+ (cond
32.3318+ ((file-pathname-p p) p)
32.3319+ ((directory-pathname-p p)
32.3320+ (subpathname p (car (last (pathname-directory p)))))))
32.3321+ (:directory (ensure-directory-pathname p)))))
32.3322+ #+clisp
32.3323+ #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
32.3324+ (pp (find-symbol* '#:probe-pathname :ext nil)))
32.3325+ `(if truename
32.3326+ ,(if pp
32.3327+ `(values (,pp p))
32.3328+ '(or (truename* p)
32.3329+ (truename* (ignore-errors (ensure-directory-pathname p)))))
32.3330+ ,(cond
32.3331+ (fs `(and (,fs p) p))
32.3332+ (pp `(nth-value 1 (,pp p)))
32.3333+ (t '(or (and (truename* p) p)
32.3334+ (if-let (d (ensure-directory-pathname p))
32.3335+ (and (truename* d) d)))))))
32.3336+ #-(or allegro clisp gcl)
32.3337+ (if truename
32.3338+ (probe-file p)
32.3339+ (and
32.3340+ #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p))
32.3341+ #+(and lispworks os-unix) (system:get-file-stat p)
32.3342+ #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
32.3343+ #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-date p)
32.3344+ p))))))
32.3345+
32.3346+ (defun directory-exists-p (x)
32.3347+ "Is X the name of a directory that exists on the filesystem?"
32.3348+ #+allegro
32.3349+ (excl:probe-directory x)
32.3350+ #+clisp
32.3351+ (handler-case (ext:probe-directory x)
32.3352+ (sys::simple-file-error ()
32.3353+ nil))
32.3354+ #-(or allegro clisp)
32.3355+ (let ((p (probe-file* x :truename t)))
32.3356+ (and (directory-pathname-p p) p)))
32.3357+
32.3358+ (defun file-exists-p (x)
32.3359+ "Is X the name of a file that exists on the filesystem?"
32.3360+ (let ((p (probe-file* x :truename t)))
32.3361+ (and (file-pathname-p p) p)))
32.3362+
32.3363+ (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
32.3364+ "Return a list of the entries in a directory by calling DIRECTORY.
32.3365+Try to override the defaults to not resolving symlinks, if implementation allows."
32.3366+ (apply 'directory pathname-spec
32.3367+ (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
32.3368+ #+(or clozure digitool) '(:follow-links nil)
32.3369+ #+clisp '(:circle t :if-does-not-exist :ignore)
32.3370+ #+(or cmucl scl) '(:follow-links nil :truenamep nil)
32.3371+ #+lispworks '(:link-transparency nil)
32.3372+ #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
32.3373+ '(:resolve-symlinks nil))))))
32.3374+
32.3375+ (defun filter-logical-directory-results (directory entries merger)
32.3376+ "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is,
32.3377+given ENTRIES in the DIRECTORY, remove the entries which are physical yet
32.3378+when transformed by MERGER have a different TRUENAME.
32.3379+Also remove duplicates as may appear with some translation rules.
32.3380+This function is used as a helper to DIRECTORY-FILES to avoid invalid entries
32.3381+when using logical-pathnames."
32.3382+ (if (logical-pathname-p directory)
32.3383+ (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
32.3384+ ;; Try hard to not resolve logical-pathname into physical pathnames;
32.3385+ ;; otherwise logical-pathname users/lovers will be disappointed.
32.3386+ ;; If directory* could use some implementation-dependent magic,
32.3387+ ;; we will have logical pathnames already; otherwise,
32.3388+ ;; we only keep pathnames for which specifying the name and
32.3389+ ;; translating the LPN commute.
32.3390+ (loop :for f :in entries
32.3391+ :for p = (or (and (logical-pathname-p f) f)
32.3392+ (let* ((u (ignore-errors (call-function merger f))))
32.3393+ ;; The first u avoids a cumbersome (truename u) error.
32.3394+ ;; At this point f should already be a truename,
32.3395+ ;; but isn't quite in CLISP, for it doesn't have :version :newest
32.3396+ (and u (equal (truename* u) (truename* f)) u)))
32.3397+ :when p :collect p)
32.3398+ :test 'pathname-equal)
32.3399+ entries))
32.3400+
32.3401+ (defun directory-files (directory &optional (pattern *wild-file-for-directory*))
32.3402+ "Return a list of the files in a directory according to the PATTERN.
32.3403+Subdirectories should NOT be returned.
32.3404+ PATTERN defaults to a pattern carefully chosen based on the implementation;
32.3405+override the default at your own risk.
32.3406+ DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this,
32.3407+but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
32.3408+ (let ((dir (ensure-directory-pathname directory)))
32.3409+ (when (logical-pathname-p dir)
32.3410+ ;; Because of the filtering we do below,
32.3411+ ;; logical pathnames have restrictions on wild patterns.
32.3412+ ;; Not that the results are very portable when you use these patterns on physical pathnames.
32.3413+ (when (wild-pathname-p dir)
32.3414+ (parameter-error "~S: Invalid wild pattern in logical directory ~S"
32.3415+ 'directory-files directory))
32.3416+ (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
32.3417+ (parameter-error "~S: Invalid file pattern ~S for logical directory ~S" 'directory-files pattern directory))
32.3418+ (setf pattern (make-pathname-logical pattern (pathname-host dir))))
32.3419+ (let* ((pat (merge-pathnames* pattern dir))
32.3420+ (entries (ignore-errors (directory* pat))))
32.3421+ (remove-if 'directory-pathname-p
32.3422+ (filter-logical-directory-results
32.3423+ directory entries
32.3424+ #'(lambda (f)
32.3425+ (make-pathname :defaults dir
32.3426+ :name (make-pathname-component-logical (pathname-name f))
32.3427+ :type (make-pathname-component-logical (pathname-type f))
32.3428+ :version (make-pathname-component-logical (pathname-version f)))))))))
32.3429+
32.3430+ (defun subdirectories (directory)
32.3431+ "Given a DIRECTORY pathname designator, return a list of the subdirectories under it.
32.3432+The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
32.3433+ (let* ((directory (ensure-directory-pathname directory))
32.3434+ #-(or abcl cormanlisp genera xcl)
32.3435+ (wild (merge-pathnames*
32.3436+ #-(or abcl allegro cmucl lispworks sbcl scl xcl)
32.3437+ *wild-directory*
32.3438+ #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*"
32.3439+ directory))
32.3440+ (dirs
32.3441+ #-(or abcl cormanlisp genera xcl)
32.3442+ (ignore-errors
32.3443+ (directory* wild . #.(or #+clozure '(:directories t :files nil)
32.3444+ #+mcl '(:directories t))))
32.3445+ #+(or abcl xcl) (system:list-directory directory)
32.3446+ #+cormanlisp (cl::directory-subdirs directory)
32.3447+ #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil)))
32.3448+ #+(or abcl allegro cmucl genera lispworks sbcl scl xcl)
32.3449+ (dirs (loop :for x :in dirs
32.3450+ :for d = #+(or abcl xcl) (extensions:probe-directory x)
32.3451+ #+allegro (excl:probe-directory x)
32.3452+ #+(or cmucl sbcl scl) (directory-pathname-p x)
32.3453+ #+genera (getf (cdr x) :directory)
32.3454+ #+lispworks (lw:file-directory-p x)
32.3455+ :when d :collect #+(or abcl allegro xcl) (ensure-directory-pathname d)
32.3456+ #+genera (ensure-directory-pathname (first x))
32.3457+ #+(or cmucl lispworks sbcl scl) x)))
32.3458+ (filter-logical-directory-results
32.3459+ directory dirs
32.3460+ (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
32.3461+ '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
32.3462+ #'(lambda (d)
32.3463+ (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
32.3464+ (and (consp dir) (consp (cdr dir))
32.3465+ (make-pathname
32.3466+ :defaults directory :name nil :type nil :version nil
32.3467+ :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
32.3468+
32.3469+ (defun collect-sub*directories (directory collectp recursep collector)
32.3470+ "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory,
32.3471+call-function the COLLECTOR function designator on the directory,
32.3472+and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them.
32.3473+This function will thus let you traverse a filesystem hierarchy,
32.3474+superseding the functionality of CL-FAD:WALK-DIRECTORY.
32.3475+The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
32.3476+ (when (call-function collectp directory)
32.3477+ (call-function collector directory)
32.3478+ (dolist (subdir (subdirectories directory))
32.3479+ (when (call-function recursep subdir)
32.3480+ (collect-sub*directories subdir collectp recursep collector))))))
32.3481+
32.3482+;;; Resolving symlinks somewhat
32.3483+(with-upgradability ()
32.3484+ (defun truenamize (pathname)
32.3485+ "Resolve as much of a pathname as possible"
32.3486+ (block nil
32.3487+ (when (typep pathname '(or null logical-pathname)) (return pathname))
32.3488+ (let ((p pathname))
32.3489+ (unless (absolute-pathname-p p)
32.3490+ (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
32.3491+ (return p))))
32.3492+ (when (logical-pathname-p p) (return p))
32.3493+ (let ((found (probe-file* p :truename t)))
32.3494+ (when found (return found)))
32.3495+ (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
32.3496+ (up-components (reverse (rest directory)))
32.3497+ (down-components ()))
32.3498+ (assert (eq :absolute (first directory)))
32.3499+ (loop :while up-components :do
32.3500+ (if-let (parent
32.3501+ (ignore-errors
32.3502+ (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components))
32.3503+ :name nil :type nil :version nil :defaults p))))
32.3504+ (if-let (simplified
32.3505+ (ignore-errors
32.3506+ (merge-pathnames*
32.3507+ (make-pathname :directory `(:relative ,@down-components)
32.3508+ :defaults p)
32.3509+ (ensure-directory-pathname parent))))
32.3510+ (return simplified)))
32.3511+ (push (pop up-components) down-components)
32.3512+ :finally (return p))))))
32.3513+
32.3514+ (defun resolve-symlinks (path)
32.3515+ "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
32.3516+ #-allegro (truenamize path)
32.3517+ #+allegro
32.3518+ (if (physical-pathname-p path)
32.3519+ (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
32.3520+ path))
32.3521+
32.3522+ (defvar *resolve-symlinks* t
32.3523+ "Determine whether or not ASDF resolves symlinks when defining systems.
32.3524+Defaults to T.")
32.3525+
32.3526+ (defun resolve-symlinks* (path)
32.3527+ "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)."
32.3528+ (if *resolve-symlinks*
32.3529+ (and path (resolve-symlinks path))
32.3530+ path)))
32.3531+
32.3532+
32.3533+;;; Check pathname constraints
32.3534+(with-upgradability ()
32.3535+ (defun ensure-pathname
32.3536+ (pathname &key
32.3537+ on-error
32.3538+ defaults type dot-dot namestring
32.3539+ empty-is-nil
32.3540+ want-pathname
32.3541+ want-logical want-physical ensure-physical
32.3542+ want-relative want-absolute ensure-absolute ensure-subpath
32.3543+ want-non-wild want-wild wilden
32.3544+ want-file want-directory ensure-directory
32.3545+ want-existing ensure-directories-exist
32.3546+ truename resolve-symlinks truenamize
32.3547+ &aux (p pathname)) ;; mutable working copy, preserve original
32.3548+ "Coerces its argument into a PATHNAME,
32.3549+optionally doing some transformations and checking specified constraints.
32.3550+
32.3551+If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
32.3552+
32.3553+If the argument is a STRING, it is first converted to a pathname via
32.3554+PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
32.3555+depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
32.3556+or else by using CALL-FUNCTION on the NAMESTRING argument;
32.3557+if :UNIX is specified (or NIL, the default, which specifies the same thing),
32.3558+then PARSE-UNIX-NAMESTRING it is called with the keywords
32.3559+DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
32.3560+the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
32.3561+
32.3562+The pathname passed or resulting from parsing the string
32.3563+is then subjected to all the checks and transformations below are run.
32.3564+
32.3565+Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
32.3566+The boolean T is an alias for ERROR.
32.3567+ERROR means that an error will be raised if the constraint is not satisfied.
32.3568+CERROR means that an continuable error will be raised if the constraint is not satisfied.
32.3569+IGNORE means just return NIL instead of the pathname.
32.3570+
32.3571+The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
32.3572+that will be called with the the following arguments:
32.3573+a generic format string for ensure pathname, the pathname,
32.3574+the keyword argument corresponding to the failed check or transformation,
32.3575+a format string for the reason ENSURE-PATHNAME failed,
32.3576+and a list with arguments to that format string.
32.3577+If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
32.3578+You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
32.3579+
32.3580+The transformations and constraint checks are done in this order,
32.3581+which is also the order in the lambda-list:
32.3582+
32.3583+EMPTY-IS-NIL returns NIL if the argument is an empty string.
32.3584+WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
32.3585+Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
32.3586+WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
32.3587+WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
32.3588+ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
32.3589+WANT-RELATIVE checks that pathname has a relative directory component
32.3590+WANT-ABSOLUTE checks that pathname does have an absolute directory component
32.3591+ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
32.3592+that the result absolute is an absolute pathname indeed.
32.3593+ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
32.3594+WANT-FILE checks that pathname has a non-nil FILE component
32.3595+WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
32.3596+ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
32.3597+any file and type components as being actually a last directory component.
32.3598+WANT-NON-WILD checks that pathname is not a wild pathname
32.3599+WANT-WILD checks that pathname is a wild pathname
32.3600+WILDEN merges the pathname with **/*.*.* if it is not wild
32.3601+WANT-EXISTING checks that a file (or directory) exists with that pathname.
32.3602+ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
32.3603+TRUENAME replaces the pathname by its truename, or errors if not possible.
32.3604+RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
32.3605+TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
32.3606+ (block nil
32.3607+ (flet ((report-error (keyword description &rest arguments)
32.3608+ (call-function (or on-error 'error)
32.3609+ "Invalid pathname ~S: ~*~?"
32.3610+ pathname keyword description arguments)))
32.3611+ (macrolet ((err (constraint &rest arguments)
32.3612+ `(report-error ',(intern* constraint :keyword) ,@arguments))
32.3613+ (check (constraint condition &rest arguments)
32.3614+ `(when ,constraint
32.3615+ (unless ,condition (err ,constraint ,@arguments))))
32.3616+ (transform (transform condition expr)
32.3617+ `(when ,transform
32.3618+ (,@(if condition `(when ,condition) '(progn))
32.3619+ (setf p ,expr)))))
32.3620+ (etypecase p
32.3621+ ((or null pathname))
32.3622+ (string
32.3623+ (when (and (emptyp p) empty-is-nil)
32.3624+ (return-from ensure-pathname nil))
32.3625+ (setf p (case namestring
32.3626+ ((:unix nil)
32.3627+ (parse-unix-namestring
32.3628+ p :defaults defaults :type type :dot-dot dot-dot
32.3629+ :ensure-directory ensure-directory :want-relative want-relative))
32.3630+ ((:native)
32.3631+ (parse-native-namestring p))
32.3632+ ((:lisp)
32.3633+ (parse-namestring p))
32.3634+ (t
32.3635+ (call-function namestring p))))))
32.3636+ (etypecase p
32.3637+ (pathname)
32.3638+ (null
32.3639+ (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
32.3640+ (return nil)))
32.3641+ (check want-logical (logical-pathname-p p) "Expected a logical pathname")
32.3642+ (check want-physical (physical-pathname-p p) "Expected a physical pathname")
32.3643+ (transform ensure-physical () (physicalize-pathname p))
32.3644+ (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
32.3645+ (check want-relative (relative-pathname-p p) "Expected a relative pathname")
32.3646+ (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
32.3647+ (transform ensure-absolute (not (absolute-pathname-p p))
32.3648+ (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
32.3649+ (check ensure-absolute (absolute-pathname-p p)
32.3650+ "Could not make into an absolute pathname even after merging with ~S" defaults)
32.3651+ (check ensure-subpath (absolute-pathname-p defaults)
32.3652+ "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
32.3653+ (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
32.3654+ (check want-file (file-pathname-p p) "Expected a file pathname")
32.3655+ (check want-directory (directory-pathname-p p) "Expected a directory pathname")
32.3656+ (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
32.3657+ (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
32.3658+ (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
32.3659+ (transform wilden (not (wild-pathname-p p)) (wilden p))
32.3660+ (when want-existing
32.3661+ (let ((existing (probe-file* p :truename truename)))
32.3662+ (if existing
32.3663+ (when truename
32.3664+ (return existing))
32.3665+ (err want-existing "Expected an existing pathname"))))
32.3666+ (when ensure-directories-exist (ensure-directories-exist p))
32.3667+ (when truename
32.3668+ (let ((truename (truename* p)))
32.3669+ (if truename
32.3670+ (return truename)
32.3671+ (err truename "Can't get a truename for pathname"))))
32.3672+ (transform resolve-symlinks () (resolve-symlinks p))
32.3673+ (transform truenamize () (truenamize p))
32.3674+ p)))))
32.3675+
32.3676+
32.3677+;;; Pathname defaults
32.3678+(with-upgradability ()
32.3679+ (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
32.3680+ "Find the actual DEFAULTS to use for pathnames, including
32.3681+resolving them with respect to GETCWD if the DEFAULTS were relative"
32.3682+ (or (absolute-pathname-p defaults)
32.3683+ (merge-pathnames* defaults (getcwd))))
32.3684+
32.3685+ (defun call-with-current-directory (dir thunk)
32.3686+ "call the THUNK in a context where the current directory was changed to DIR, if not NIL.
32.3687+Note that this operation is usually NOT thread-safe."
32.3688+ (if dir
32.3689+ (let* ((dir (resolve-symlinks*
32.3690+ (get-pathname-defaults
32.3691+ (ensure-directory-pathname
32.3692+ dir))))
32.3693+ (cwd (getcwd))
32.3694+ (*default-pathname-defaults* dir))
32.3695+ (chdir dir)
32.3696+ (unwind-protect
32.3697+ (funcall thunk)
32.3698+ (chdir cwd)))
32.3699+ (funcall thunk)))
32.3700+
32.3701+ (defmacro with-current-directory ((&optional dir) &body body)
32.3702+ "Call BODY while the POSIX current working directory is set to DIR"
32.3703+ `(call-with-current-directory ,dir #'(lambda () ,@body))))
32.3704+
32.3705+
32.3706+;;; Environment pathnames
32.3707+(with-upgradability ()
32.3708+ (defun inter-directory-separator ()
32.3709+ "What character does the current OS conventionally uses to separate directories?"
32.3710+ (os-cond ((os-unix-p) #\:) (t #\;)))
32.3711+
32.3712+ (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
32.3713+ "Given a string of pathnames specified in native OS syntax, separate them in a list,
32.3714+check constraints and normalize each one as per ENSURE-PATHNAME,
32.3715+where an empty string denotes NIL."
32.3716+ (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
32.3717+ :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints))))
32.3718+
32.3719+ (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
32.3720+ "Extract a pathname from a user-configured environment variable, as per native OS,
32.3721+check constraints and normalize as per ENSURE-PATHNAME."
32.3722+ ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
32.3723+ (apply 'parse-native-namestring (getenvp x)
32.3724+ :ensure-directory (or ensure-directory want-directory)
32.3725+ :on-error (or on-error
32.3726+ `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
32.3727+ constraints))
32.3728+ (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
32.3729+ "Extract a list of pathname from a user-configured environment variable, as per native OS,
32.3730+check constraints and normalize each one as per ENSURE-PATHNAME.
32.3731+ Any empty entries in the environment variable X will be returned as NILs."
32.3732+ (unless (getf constraints :empty-is-nil t)
32.3733+ (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-pathnames))
32.3734+ (apply 'split-native-pathnames-string (getenvp x)
32.3735+ :on-error (or on-error
32.3736+ `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
32.3737+ :empty-is-nil t
32.3738+ constraints))
32.3739+ (defun getenv-absolute-directory (x)
32.3740+ "Extract an absolute directory pathname from a user-configured environment variable,
32.3741+as per native OS"
32.3742+ (getenv-pathname x :want-absolute t :ensure-directory t))
32.3743+ (defun getenv-absolute-directories (x)
32.3744+ "Extract a list of absolute directories from a user-configured environment variable,
32.3745+as per native OS. Any empty entries in the environment variable X will be returned as
32.3746+NILs."
32.3747+ (getenv-pathnames x :want-absolute t :ensure-directory t))
32.3748+
32.3749+ (defun lisp-implementation-directory (&key truename)
32.3750+ "Where are the system files of the current installation of the CL implementation?"
32.3751+ (declare (ignorable truename))
32.3752+ (let ((dir
32.3753+ #+abcl extensions:*lisp-home*
32.3754+ #+(or allegro clasp ecl mkcl) #p"SYS:"
32.3755+ #+clisp custom:*lib-directory*
32.3756+ #+clozure #p"ccl:"
32.3757+ #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
32.3758+ #+gcl system::*system-directory*
32.3759+ #+lispworks lispworks:*lispworks-directory*
32.3760+ #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
32.3761+ (funcall it)
32.3762+ (getenv-pathname "SBCL_HOME" :ensure-directory t))
32.3763+ #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/")))
32.3764+ #+xcl ext:*xcl-home*))
32.3765+ (if (and dir truename)
32.3766+ (truename* dir)
32.3767+ dir)))
32.3768+
32.3769+ (defun lisp-implementation-pathname-p (pathname)
32.3770+ "Is the PATHNAME under the current installation of the CL implementation?"
32.3771+ ;; Other builtin systems are those under the implementation directory
32.3772+ (and (when pathname
32.3773+ (if-let (impdir (lisp-implementation-directory))
32.3774+ (or (subpathp pathname impdir)
32.3775+ (when *resolve-symlinks*
32.3776+ (if-let (truename (truename* pathname))
32.3777+ (if-let (trueimpdir (truename* impdir))
32.3778+ (subpathp truename trueimpdir)))))))
32.3779+ t)))
32.3780+
32.3781+
32.3782+;;; Simple filesystem operations
32.3783+(with-upgradability ()
32.3784+ (defun ensure-all-directories-exist (pathnames)
32.3785+ "Ensure that for every pathname in PATHNAMES, we ensure its directories exist"
32.3786+ (dolist (pathname pathnames)
32.3787+ (when pathname
32.3788+ (ensure-directories-exist (physicalize-pathname pathname)))))
32.3789+
32.3790+ (defun delete-file-if-exists (x)
32.3791+ "Delete a file X if it already exists"
32.3792+ (when x (handler-case (delete-file x) (file-error () nil))))
32.3793+
32.3794+ (defun rename-file-overwriting-target (source target)
32.3795+ "Rename a file, overwriting any previous file with the TARGET name,
32.3796+in an atomic way if the implementation allows."
32.3797+ (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t))
32.3798+ (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t)))
32.3799+ #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
32.3800+ (progn (funcall 'require "syscalls")
32.3801+ (symbol-call :posix :copy-file source target :method :rename))
32.3802+ #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic
32.3803+ #-clisp
32.3804+ (rename-file source target
32.3805+ #+(or clasp clozure ecl) :if-exists
32.3806+ #+clozure :rename-and-delete #+(or clasp ecl) t)))
32.3807+
32.3808+ (defun delete-empty-directory (directory-pathname)
32.3809+ "Delete an empty directory"
32.3810+ #+(or abcl digitool gcl) (delete-file directory-pathname)
32.3811+ #+allegro (excl:delete-directory directory-pathname)
32.3812+ #+clisp (ext:delete-directory directory-pathname)
32.3813+ #+clozure (ccl::delete-empty-directory directory-pathname)
32.3814+ #+(or cmucl scl) (multiple-value-bind (ok errno)
32.3815+ (unix:unix-rmdir (native-namestring directory-pathname))
32.3816+ (unless ok
32.3817+ #+cmucl (error "Error number ~A when trying to delete directory ~A"
32.3818+ errno directory-pathname)
32.3819+ #+scl (error "~@<Error deleting ~S: ~A~@:>"
32.3820+ directory-pathname (unix:get-unix-error-msg errno))))
32.3821+ #+cormanlisp (win32:delete-directory directory-pathname)
32.3822+ #+(or clasp ecl) (si:rmdir directory-pathname)
32.3823+ #+genera (fs:delete-directory directory-pathname)
32.3824+ #+lispworks (lw:delete-directory directory-pathname)
32.3825+ #+mkcl (mkcl:rmdir directory-pathname)
32.3826+ #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
32.3827+ `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
32.3828+ `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
32.3829+ #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
32.3830+ #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
32.3831+ (not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera
32.3832+
32.3833+ (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
32.3834+ "Delete a directory including all its recursive contents, aka rm -rf.
32.3835+
32.3836+To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
32.3837+a physical non-wildcard directory pathname (not namestring).
32.3838+
32.3839+If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
32.3840+if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
32.3841+
32.3842+Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
32.3843+the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
32.3844+which in practice is thus compulsory, and validates by returning a non-NIL result.
32.3845+If you're suicidal or extremely confident, just use :VALIDATE T."
32.3846+ (check-type if-does-not-exist (member :error :ignore))
32.3847+ (setf directory-pathname (ensure-pathname directory-pathname
32.3848+ :want-pathname t :want-non-wild t
32.3849+ :want-physical t :want-directory t))
32.3850+ (cond
32.3851+ ((not validatep)
32.3852+ (parameter-error "~S was asked to delete ~S but was not provided a validation predicate"
32.3853+ 'delete-directory-tree directory-pathname))
32.3854+ ((not (call-function validate directory-pathname))
32.3855+ (parameter-error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
32.3856+ 'delete-directory-tree directory-pathname validate))
32.3857+ ((not (directory-exists-p directory-pathname))
32.3858+ (ecase if-does-not-exist
32.3859+ (:error
32.3860+ (error "~S was asked to delete ~S but the directory does not exist"
32.3861+ 'delete-directory-tree directory-pathname))
32.3862+ (:ignore nil)))
32.3863+ #-(or allegro cmucl clozure genera sbcl scl)
32.3864+ ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
32.3865+ ;; except on implementations where we can prevent DIRECTORY from following symlinks;
32.3866+ ;; instead spawn a standard external program to do the dirty work.
32.3867+ (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
32.3868+ (t
32.3869+ ;; On supported implementation, call supported system functions
32.3870+ #+allegro (symbol-call :excl.osi :delete-directory-and-files
32.3871+ directory-pathname :if-does-not-exist if-does-not-exist)
32.3872+ #+clozure (ccl:delete-directory directory-pathname)
32.3873+ #+genera (fs:delete-directory directory-pathname :confirm nil)
32.3874+ #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
32.3875+ `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
32.3876+ '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
32.3877+ ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
32.3878+ ;; do things the hard way.
32.3879+ #-(or allegro clozure genera sbcl)
32.3880+ (let ((sub*directories
32.3881+ (while-collecting (c)
32.3882+ (collect-sub*directories directory-pathname t t #'c))))
32.3883+ (dolist (d (nreverse sub*directories))
32.3884+ (map () 'delete-file (directory-files d))
32.3885+ (delete-empty-directory d)))))))
32.3886+;;;; ---------------------------------------------------------------------------
32.3887+;;;; Utilities related to streams
32.3888+
32.3889+(uiop/package:define-package :uiop/stream
32.3890+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
32.3891+ (:export
32.3892+ #:*default-stream-element-type*
32.3893+ #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr
32.3894+ #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
32.3895+ #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
32.3896+ #:*default-encoding* #:*utf-8-external-format*
32.3897+ #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
32.3898+ #:with-output #:output-string #:with-input #:input-string
32.3899+ #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
32.3900+ #:null-device-pathname #:call-with-null-input #:with-null-input
32.3901+ #:call-with-null-output #:with-null-output
32.3902+ #:finish-outputs #:format! #:safe-format!
32.3903+ #:copy-stream-to-stream #:concatenate-files #:copy-file
32.3904+ #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
32.3905+ #:slurp-stream-forms #:slurp-stream-form
32.3906+ #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line
32.3907+ #:read-file-forms #:read-file-form #:safe-read-file-form
32.3908+ #:eval-input #:eval-thunk #:standard-eval-thunk
32.3909+ #:println #:writeln
32.3910+ #:file-stream-p #:file-or-synonym-stream-p
32.3911+ ;; Temporary files
32.3912+ #:*temporary-directory* #:temporary-directory #:default-temporary-directory
32.3913+ #:setup-temporary-directory
32.3914+ #:call-with-temporary-file #:with-temporary-file
32.3915+ #:add-pathname-suffix #:tmpize-pathname
32.3916+ #:call-with-staging-pathname #:with-staging-pathname))
32.3917+(in-package :uiop/stream)
32.3918+
32.3919+(with-upgradability ()
32.3920+ (defvar *default-stream-element-type*
32.3921+ (or #+(or abcl cmucl cormanlisp scl xcl) 'character
32.3922+ #+lispworks 'lw:simple-char
32.3923+ :default)
32.3924+ "default element-type for open (depends on the current CL implementation)")
32.3925+
32.3926+ (defvar *stdin* *standard-input*
32.3927+ "the original standard input stream at startup")
32.3928+
32.3929+ (defun setup-stdin ()
32.3930+ (setf *stdin*
32.3931+ #.(or #+clozure 'ccl::*stdin*
32.3932+ #+(or cmucl scl) 'system:*stdin*
32.3933+ #+(or clasp ecl) 'ext::+process-standard-input+
32.3934+ #+sbcl 'sb-sys:*stdin*
32.3935+ '*standard-input*)))
32.3936+
32.3937+ (defvar *stdout* *standard-output*
32.3938+ "the original standard output stream at startup")
32.3939+
32.3940+ (defun setup-stdout ()
32.3941+ (setf *stdout*
32.3942+ #.(or #+clozure 'ccl::*stdout*
32.3943+ #+(or cmucl scl) 'system:*stdout*
32.3944+ #+(or clasp ecl) 'ext::+process-standard-output+
32.3945+ #+sbcl 'sb-sys:*stdout*
32.3946+ '*standard-output*)))
32.3947+
32.3948+ (defvar *stderr* *error-output*
32.3949+ "the original error output stream at startup")
32.3950+
32.3951+ (defun setup-stderr ()
32.3952+ (setf *stderr*
32.3953+ #.(or #+allegro 'excl::*stderr*
32.3954+ #+clozure 'ccl::*stderr*
32.3955+ #+(or cmucl scl) 'system:*stderr*
32.3956+ #+(or clasp ecl) 'ext::+process-error-output+
32.3957+ #+sbcl 'sb-sys:*stderr*
32.3958+ '*error-output*)))
32.3959+
32.3960+ ;; Run them now. In image.lisp, we'll register them to be run at image restart.
32.3961+ (setup-stdin) (setup-stdout) (setup-stderr))
32.3962+
32.3963+
32.3964+;;; Encodings (mostly hooks only; full support requires asdf-encodings)
32.3965+(with-upgradability ()
32.3966+ (defparameter *default-encoding*
32.3967+ ;; preserve explicit user changes to something other than the legacy default :default
32.3968+ (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*)))
32.3969+ (unless (eq previous :default) previous))
32.3970+ :utf-8)
32.3971+ "Default encoding for source files.
32.3972+The default value :utf-8 is the portable thing.
32.3973+The legacy behavior was :default.
32.3974+If you (asdf:load-system :asdf-encodings) then
32.3975+you will have autodetection via *encoding-detection-hook* below,
32.3976+reading emacs-style -*- coding: utf-8 -*- specifications,
32.3977+and falling back to utf-8 or latin1 if nothing is specified.")
32.3978+
32.3979+ (defparameter *utf-8-external-format*
32.3980+ (if (featurep :asdf-unicode)
32.3981+ (or #+clisp charset:utf-8 :utf-8)
32.3982+ :default)
32.3983+ "Default :external-format argument to pass to CL:OPEN and also
32.3984+CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
32.3985+On modern implementations, this will decode UTF-8 code points as CL characters.
32.3986+On legacy implementations, it may fall back on some 8-bit encoding,
32.3987+with non-ASCII code points being read as several CL characters;
32.3988+hopefully, if done consistently, that won't affect program behavior too much.")
32.3989+
32.3990+ (defun always-default-encoding (pathname)
32.3991+ "Trivial function to use as *encoding-detection-hook*,
32.3992+always 'detects' the *default-encoding*"
32.3993+ (declare (ignore pathname))
32.3994+ *default-encoding*)
32.3995+
32.3996+ (defvar *encoding-detection-hook* #'always-default-encoding
32.3997+ "Hook for an extension to define a function to automatically detect a file's encoding")
32.3998+
32.3999+ (defun detect-encoding (pathname)
32.4000+ "Detects the encoding of a specified file, going through user-configurable hooks"
32.4001+ (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
32.4002+ (funcall *encoding-detection-hook* pathname)
32.4003+ *default-encoding*))
32.4004+
32.4005+ (defun default-encoding-external-format (encoding)
32.4006+ "Default, ignorant, function to transform a character ENCODING as a
32.4007+portable keyword to an implementation-dependent EXTERNAL-FORMAT specification.
32.4008+Load system ASDF-ENCODINGS to hook in a better one."
32.4009+ (case encoding
32.4010+ (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
32.4011+ (:utf-8 *utf-8-external-format*)
32.4012+ (otherwise
32.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)
32.4014+ :default)))
32.4015+
32.4016+ (defvar *encoding-external-format-hook*
32.4017+ #'default-encoding-external-format
32.4018+ "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping
32.4019+from non-default encodings to and implementation-defined external-format's")
32.4020+
32.4021+ (defun encoding-external-format (encoding)
32.4022+ "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT,
32.4023+going through all the proper hooks."
32.4024+ (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
32.4025+
32.4026+
32.4027+;;; Safe syntax
32.4028+(with-upgradability ()
32.4029+ (defvar *standard-readtable* (with-standard-io-syntax *readtable*)
32.4030+ "The standard readtable, implementing the syntax specified by the CLHS.
32.4031+It must never be modified, though only good implementations will even enforce that.")
32.4032+
32.4033+ (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
32.4034+ "Establish safe CL reader options around the evaluation of BODY"
32.4035+ `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
32.4036+
32.4037+ (defun call-with-safe-io-syntax (thunk &key (package :cl))
32.4038+ (with-standard-io-syntax
32.4039+ (let ((*package* (find-package package))
32.4040+ (*read-default-float-format* 'double-float)
32.4041+ (*print-readably* nil)
32.4042+ (*read-eval* nil))
32.4043+ (funcall thunk))))
32.4044+
32.4045+ (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
32.4046+ "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX"
32.4047+ (with-safe-io-syntax (:package package)
32.4048+ (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
32.4049+
32.4050+;;; Output helpers
32.4051+ (with-upgradability ()
32.4052+ (defun call-with-output-file (pathname thunk
32.4053+ &key
32.4054+ (element-type *default-stream-element-type*)
32.4055+ (external-format *utf-8-external-format*)
32.4056+ (if-exists :error)
32.4057+ (if-does-not-exist :create))
32.4058+ "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
32.4059+Other keys are accepted but discarded."
32.4060+ (with-open-file (s pathname :direction :output
32.4061+ :element-type element-type
32.4062+ :external-format external-format
32.4063+ :if-exists if-exists
32.4064+ :if-does-not-exist if-does-not-exist)
32.4065+ (funcall thunk s)))
32.4066+
32.4067+ (defmacro with-output-file ((var pathname &rest keys
32.4068+ &key element-type external-format if-exists if-does-not-exist)
32.4069+ &body body)
32.4070+ (declare (ignore element-type external-format if-exists if-does-not-exist))
32.4071+ `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys))
32.4072+
32.4073+ (defun call-with-output (output function &key (element-type 'character))
32.4074+ "Calls FUNCTION with an actual stream argument,
32.4075+behaving like FORMAT with respect to how stream designators are interpreted:
32.4076+If OUTPUT is a STREAM, use it as the stream.
32.4077+If OUTPUT is NIL, use a STRING-OUTPUT-STREAM of given ELEMENT-TYPE as the stream, and
32.4078+return the resulting string.
32.4079+If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
32.4080+If OUTPUT is a STRING with a fill-pointer, use it as a STRING-OUTPUT-STREAM of given ELEMENT-TYPE.
32.4081+If OUTPUT is a PATHNAME, open the file and write to it, passing ELEMENT-TYPE to WITH-OUTPUT-FILE
32.4082+-- this latter as an extension since ASDF 3.1.
32.4083+\(Proper ELEMENT-TYPE treatment since ASDF 3.3.4 only.\)
32.4084+Otherwise, signal an error."
32.4085+ (etypecase output
32.4086+ (null
32.4087+ (with-output-to-string (stream nil :element-type element-type) (funcall function stream)))
32.4088+ ((eql t)
32.4089+ (funcall function *standard-output*))
32.4090+ (stream
32.4091+ (funcall function output))
32.4092+ (string
32.4093+ (assert (fill-pointer output))
32.4094+ (with-output-to-string (stream output :element-type element-type) (funcall function stream)))
32.4095+ (pathname
32.4096+ (call-with-output-file output function :element-type element-type)))))
32.4097+
32.4098+(with-upgradability ()
32.4099+ (locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
32.4100+ (handler-bind (#+sbcl (style-warning #'muffle-warning))
32.4101+ (defmacro with-output ((output-var &optional (value output-var) &key element-type) &body body)
32.4102+ "Bind OUTPUT-VAR to an output stream obtained from VALUE (default: previous binding
32.4103+of OUTPUT-VAR) treated as a stream designator per CALL-WITH-OUTPUT. Evaluate BODY in
32.4104+the scope of this binding."
32.4105+ `(call-with-output ,value #'(lambda (,output-var) ,@body)
32.4106+ ,@(when element-type `(:element-type ,element-type)))))))
32.4107+
32.4108+(defun output-string (string &optional output)
32.4109+ "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
32.4110+ (if output
32.4111+ (with-output (output) (princ string output))
32.4112+ string))
32.4113+
32.4114+
32.4115+;;; Input helpers
32.4116+(with-upgradability ()
32.4117+ (defun call-with-input-file (pathname thunk
32.4118+ &key
32.4119+ (element-type *default-stream-element-type*)
32.4120+ (external-format *utf-8-external-format*)
32.4121+ (if-does-not-exist :error))
32.4122+ "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
32.4123+Other keys are accepted but discarded."
32.4124+ (with-open-file (s pathname :direction :input
32.4125+ :element-type element-type
32.4126+ :external-format external-format
32.4127+ :if-does-not-exist if-does-not-exist)
32.4128+ (funcall thunk s)))
32.4129+
32.4130+ (defmacro with-input-file ((var pathname &rest keys
32.4131+ &key element-type external-format if-does-not-exist)
32.4132+ &body body)
32.4133+ (declare (ignore element-type external-format if-does-not-exist))
32.4134+ `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
32.4135+
32.4136+ (defun call-with-input (input function &key keys)
32.4137+ "Calls FUNCTION with an actual stream argument, interpreting
32.4138+stream designators like READ, but also coercing strings to STRING-INPUT-STREAM,
32.4139+and PATHNAME to FILE-STREAM.
32.4140+If INPUT is a STREAM, use it as the stream.
32.4141+If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
32.4142+If INPUT is T, use *TERMINAL-IO* as the stream.
32.4143+If INPUT is a STRING, use it as a string-input-stream.
32.4144+If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE
32.4145+-- the latter is an extension since ASDF 3.1.
32.4146+Otherwise, signal an error."
32.4147+ (etypecase input
32.4148+ (null (funcall function *standard-input*))
32.4149+ ((eql t) (funcall function *terminal-io*))
32.4150+ (stream (funcall function input))
32.4151+ (string (with-input-from-string (stream input) (funcall function stream)))
32.4152+ (pathname (apply 'call-with-input-file input function keys))))
32.4153+
32.4154+ (defmacro with-input ((input-var &optional (value input-var)) &body body)
32.4155+ "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
32.4156+as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
32.4157+ `(call-with-input ,value #'(lambda (,input-var) ,@body)))
32.4158+
32.4159+ (defun input-string (&optional input)
32.4160+ "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string
32.4161+and return that"
32.4162+ (if (stringp input)
32.4163+ input
32.4164+ (with-input (input) (funcall 'slurp-stream-string input)))))
32.4165+
32.4166+;;; Null device
32.4167+(with-upgradability ()
32.4168+ (defun null-device-pathname ()
32.4169+ "Pathname to a bit bucket device that discards any information written to it
32.4170+and always returns EOF when read from"
32.4171+ (os-cond
32.4172+ ((os-unix-p) #p"/dev/null")
32.4173+ ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
32.4174+ (t (error "No /dev/null on your OS"))))
32.4175+ (defun call-with-null-input (fun &key element-type external-format if-does-not-exist)
32.4176+ "Call FUN with an input stream that always returns end of file.
32.4177+The keyword arguments are allowed for backward compatibility, but are ignored."
32.4178+ (declare (ignore element-type external-format if-does-not-exist))
32.4179+ (with-open-stream (input (make-concatenated-stream))
32.4180+ (funcall fun input)))
32.4181+ (defmacro with-null-input ((var &rest keys
32.4182+ &key element-type external-format if-does-not-exist)
32.4183+ &body body)
32.4184+ (declare (ignore element-type external-format if-does-not-exist))
32.4185+ "Evaluate BODY in a context when VAR is bound to an input stream that always returns end of file.
32.4186+The keyword arguments are allowed for backward compatibility, but are ignored."
32.4187+ `(call-with-null-input #'(lambda (,var) ,@body) ,@keys))
32.4188+ (defun call-with-null-output (fun
32.4189+ &key (element-type *default-stream-element-type*)
32.4190+ (external-format *utf-8-external-format*)
32.4191+ (if-exists :overwrite)
32.4192+ (if-does-not-exist :error))
32.4193+ (declare (ignore element-type external-format if-exists if-does-not-exist))
32.4194+ "Call FUN with an output stream that discards all output.
32.4195+The keyword arguments are allowed for backward compatibility, but are ignored."
32.4196+ (with-open-stream (output (make-broadcast-stream))
32.4197+ (funcall fun output)))
32.4198+ (defmacro with-null-output ((var &rest keys
32.4199+ &key element-type external-format if-does-not-exist if-exists)
32.4200+ &body body)
32.4201+ "Evaluate BODY in a context when VAR is bound to an output stream that discards all output.
32.4202+The keyword arguments are allowed for backward compatibility, but are ignored."
32.4203+ (declare (ignore element-type external-format if-exists if-does-not-exist))
32.4204+ `(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))
32.4205+
32.4206+;;; Ensure output buffers are flushed
32.4207+(with-upgradability ()
32.4208+ (defun finish-outputs (&rest streams)
32.4209+ "Finish output on the main output streams as well as any specified one.
32.4210+Useful for portably flushing I/O before user input or program exit."
32.4211+ ;; CCL notably buffers its stream output by default.
32.4212+ (dolist (s (append streams
32.4213+ (list *stdout* *stderr* *error-output* *standard-output* *trace-output*
32.4214+ *debug-io* *terminal-io* *query-io*)))
32.4215+ (ignore-errors (finish-output s)))
32.4216+ (values))
32.4217+
32.4218+ (defun format! (stream format &rest args)
32.4219+ "Just like format, but call finish-outputs before and after the output."
32.4220+ (finish-outputs stream)
32.4221+ (apply 'format stream format args)
32.4222+ (finish-outputs stream))
32.4223+
32.4224+ (defun safe-format! (stream format &rest args)
32.4225+ "Variant of FORMAT that is safe against both
32.4226+dangerous syntax configuration and errors while printing."
32.4227+ (with-safe-io-syntax ()
32.4228+ (ignore-errors (apply 'format! stream format args))
32.4229+ (finish-outputs stream)))) ; just in case format failed
32.4230+
32.4231+
32.4232+;;; Simple Whole-Stream processing
32.4233+(with-upgradability ()
32.4234+ (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
32.4235+ "Copy the contents of the INPUT stream into the OUTPUT stream.
32.4236+If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
32.4237+Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
32.4238+ (with-open-stream (input input)
32.4239+ (if linewise
32.4240+ (loop :for (line eof) = (multiple-value-list (read-line input nil nil))
32.4241+ :while line :do
32.4242+ (when prefix (princ prefix output))
32.4243+ (princ line output)
32.4244+ (unless eof (terpri output))
32.4245+ (finish-output output)
32.4246+ (when eof (return)))
32.4247+ (loop
32.4248+ :with buffer-size = (or buffer-size 8192)
32.4249+ :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
32.4250+ :for end = (read-sequence buffer input)
32.4251+ :until (zerop end)
32.4252+ :do (write-sequence buffer output :end end)
32.4253+ (when (< end buffer-size) (return))))))
32.4254+
32.4255+ (defun concatenate-files (inputs output)
32.4256+ "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
32.4257+ (with-open-file (o output :element-type '(unsigned-byte 8)
32.4258+ :direction :output :if-exists :rename-and-delete)
32.4259+ (dolist (input inputs)
32.4260+ (with-open-file (i input :element-type '(unsigned-byte 8)
32.4261+ :direction :input :if-does-not-exist :error)
32.4262+ (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
32.4263+
32.4264+ (defun copy-file (input output)
32.4265+ "Copy contents of the INPUT file to the OUTPUT file"
32.4266+ ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
32.4267+ #+allegro
32.4268+ (excl.osi:copy-file input output)
32.4269+ #+ecl
32.4270+ (ext:copy-file input output)
32.4271+ #-(or allegro ecl)
32.4272+ (concatenate-files (list input) output))
32.4273+
32.4274+ (defun slurp-stream-string (input &key (element-type 'character) stripped)
32.4275+ "Read the contents of the INPUT stream as a string"
32.4276+ (let ((string
32.4277+ (with-open-stream (input input)
32.4278+ (with-output-to-string (output nil :element-type element-type)
32.4279+ (copy-stream-to-stream input output :element-type element-type)))))
32.4280+ (if stripped (stripln string) string)))
32.4281+
32.4282+ (defun slurp-stream-lines (input &key count)
32.4283+ "Read the contents of the INPUT stream as a list of lines, return those lines.
32.4284+
32.4285+Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR
32.4286+from the line-ending if the file or stream had CR+LF but Lisp only removed LF.
32.4287+
32.4288+Read no more than COUNT lines."
32.4289+ (check-type count (or null integer))
32.4290+ (with-open-stream (input input)
32.4291+ (loop :for n :from 0
32.4292+ :for l = (and (or (not count) (< n count))
32.4293+ (read-line input nil nil))
32.4294+ ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF
32.4295+ :while l :collect (stripln l))))
32.4296+
32.4297+ (defun slurp-stream-line (input &key (at 0))
32.4298+ "Read the contents of the INPUT stream as a list of lines,
32.4299+then return the ACCESS-AT of that list of lines using the AT specifier.
32.4300+PATH defaults to 0, i.e. return the first line.
32.4301+PATH is typically an integer, or a list of an integer and a function.
32.4302+If PATH is NIL, it will return all the lines in the file.
32.4303+
32.4304+The stream will not be read beyond the Nth lines,
32.4305+where N is the index specified by path
32.4306+if path is either an integer or a list that starts with an integer."
32.4307+ (access-at (slurp-stream-lines input :count (access-at-count at)) at))
32.4308+
32.4309+ (defun slurp-stream-forms (input &key count)
32.4310+ "Read the contents of the INPUT stream as a list of forms,
32.4311+and return those forms.
32.4312+
32.4313+If COUNT is null, read to the end of the stream;
32.4314+if COUNT is an integer, stop after COUNT forms were read.
32.4315+
32.4316+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
32.4317+ (check-type count (or null integer))
32.4318+ (loop :with eof = '#:eof
32.4319+ :for n :from 0
32.4320+ :for form = (if (and count (>= n count))
32.4321+ eof
32.4322+ (read-preserving-whitespace input nil eof))
32.4323+ :until (eq form eof) :collect form))
32.4324+
32.4325+ (defun slurp-stream-form (input &key (at 0))
32.4326+ "Read the contents of the INPUT stream as a list of forms,
32.4327+then return the ACCESS-AT of these forms following the AT.
32.4328+AT defaults to 0, i.e. return the first form.
32.4329+AT is typically a list of integers.
32.4330+If AT is NIL, it will return all the forms in the file.
32.4331+
32.4332+The stream will not be read beyond the Nth form,
32.4333+where N is the index specified by path,
32.4334+if path is either an integer or a list that starts with an integer.
32.4335+
32.4336+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
32.4337+ (access-at (slurp-stream-forms input :count (access-at-count at)) at))
32.4338+
32.4339+ (defun read-file-string (file &rest keys)
32.4340+ "Open FILE with option KEYS, read its contents as a string"
32.4341+ (apply 'call-with-input-file file 'slurp-stream-string keys))
32.4342+
32.4343+ (defun read-file-lines (file &rest keys)
32.4344+ "Open FILE with option KEYS, read its contents as a list of lines
32.4345+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
32.4346+ (apply 'call-with-input-file file 'slurp-stream-lines keys))
32.4347+
32.4348+ (defun read-file-line (file &rest keys &key (at 0) &allow-other-keys)
32.4349+ "Open input FILE with option KEYS (except AT),
32.4350+and read its contents as per SLURP-STREAM-LINE with given AT specifier.
32.4351+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
32.4352+ (apply 'call-with-input-file file
32.4353+ #'(lambda (input) (slurp-stream-line input :at at))
32.4354+ (remove-plist-key :at keys)))
32.4355+
32.4356+ (defun read-file-forms (file &rest keys &key count &allow-other-keys)
32.4357+ "Open input FILE with option KEYS (except COUNT),
32.4358+and read its contents as per SLURP-STREAM-FORMS with given COUNT.
32.4359+If COUNT is null, read to the end of the stream;
32.4360+if COUNT is an integer, stop after COUNT forms were read.
32.4361+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
32.4362+ (apply 'call-with-input-file file
32.4363+ #'(lambda (input) (slurp-stream-forms input :count count))
32.4364+ (remove-plist-key :count keys)))
32.4365+
32.4366+ (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
32.4367+ "Open input FILE with option KEYS (except AT),
32.4368+and read its contents as per SLURP-STREAM-FORM with given AT specifier.
32.4369+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
32.4370+ (apply 'call-with-input-file file
32.4371+ #'(lambda (input) (slurp-stream-form input :at at))
32.4372+ (remove-plist-key :at keys)))
32.4373+
32.4374+ (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys)
32.4375+ "Reads the specified line from the top of a file using a safe standardized syntax.
32.4376+Extracts the line using READ-FILE-LINE,
32.4377+within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
32.4378+ (with-safe-io-syntax (:package package)
32.4379+ (apply 'read-file-line pathname (remove-plist-key :package keys))))
32.4380+
32.4381+ (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
32.4382+ "Reads the specified form from the top of a file using a safe standardized syntax.
32.4383+Extracts the form using READ-FILE-FORM,
32.4384+within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
32.4385+ (with-safe-io-syntax (:package package)
32.4386+ (apply 'read-file-form pathname (remove-plist-key :package keys))))
32.4387+
32.4388+ (defun eval-input (input)
32.4389+ "Portably read and evaluate forms from INPUT, return the last values."
32.4390+ (with-input (input)
32.4391+ (loop :with results :with eof ='#:eof
32.4392+ :for form = (read input nil eof)
32.4393+ :until (eq form eof)
32.4394+ :do (setf results (multiple-value-list (eval form)))
32.4395+ :finally (return (values-list results)))))
32.4396+
32.4397+ (defun eval-thunk (thunk)
32.4398+ "Evaluate a THUNK of code:
32.4399+If a function, FUNCALL it without arguments.
32.4400+If a constant literal and not a sequence, return it.
32.4401+If a cons or a symbol, EVAL it.
32.4402+If a string, repeatedly read and evaluate from it, returning the last values."
32.4403+ (etypecase thunk
32.4404+ ((or boolean keyword number character pathname) thunk)
32.4405+ ((or cons symbol) (eval thunk))
32.4406+ (function (funcall thunk))
32.4407+ (string (eval-input thunk))))
32.4408+
32.4409+ (defun standard-eval-thunk (thunk &key (package :cl))
32.4410+ "Like EVAL-THUNK, but in a more standardized evaluation context."
32.4411+ ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
32.4412+ (when thunk
32.4413+ (with-safe-io-syntax (:package package)
32.4414+ (let ((*read-eval* t))
32.4415+ (eval-thunk thunk))))))
32.4416+
32.4417+(with-upgradability ()
32.4418+ (defun println (x &optional (stream *standard-output*))
32.4419+ "Variant of PRINC that also calls TERPRI afterwards"
32.4420+ (princ x stream) (terpri stream) (finish-output stream) (values))
32.4421+
32.4422+ (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys)
32.4423+ "Variant of WRITE that also calls TERPRI afterwards"
32.4424+ (apply 'write x keys) (terpri stream) (finish-output stream) (values)))
32.4425+
32.4426+
32.4427+;;; Using temporary files
32.4428+(with-upgradability ()
32.4429+ (defun default-temporary-directory ()
32.4430+ "Return a default directory to use for temporary files"
32.4431+ (os-cond
32.4432+ ((os-unix-p)
32.4433+ (or (getenv-pathname "TMPDIR" :ensure-directory t)
32.4434+ (parse-native-namestring "/tmp/")))
32.4435+ ((os-windows-p)
32.4436+ (getenv-pathname "TEMP" :ensure-directory t))
32.4437+ (t (subpathname (user-homedir-pathname) "tmp/"))))
32.4438+
32.4439+ (defvar *temporary-directory* nil "User-configurable location for temporary files")
32.4440+
32.4441+ (defun temporary-directory ()
32.4442+ "Return a directory to use for temporary files"
32.4443+ (or *temporary-directory* (default-temporary-directory)))
32.4444+
32.4445+ (defun setup-temporary-directory ()
32.4446+ "Configure a default temporary directory to use."
32.4447+ (setf *temporary-directory* (default-temporary-directory))
32.4448+ #+gcl (setf system::*tmp-dir* *temporary-directory*))
32.4449+
32.4450+ (defun call-with-temporary-file
32.4451+ (thunk &key
32.4452+ (want-stream-p t) (want-pathname-p t) (direction :io) keep after
32.4453+ directory (type "tmp" typep) prefix (suffix (when typep "-tmp"))
32.4454+ (element-type *default-stream-element-type*)
32.4455+ (external-format *utf-8-external-format*))
32.4456+ "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
32.4457+
32.4458+The temporary file's pathname will be based on concatenating
32.4459+PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string,
32.4460+and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
32.4461+and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
32.4462+within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
32.4463+
32.4464+The file will be open with specified DIRECTION (defaults to :IO),
32.4465+ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
32.4466+EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
32.4467+If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
32.4468+with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
32.4469+and stream will be closed after the THUNK exits (either normally or abnormally).
32.4470+If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
32.4471+THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
32.4472+Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
32.4473+If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
32.4474+Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
32.4475+ #+xcl (declare (ignorable typep))
32.4476+ (check-type direction (member :output :io))
32.4477+ (assert (or want-stream-p want-pathname-p))
32.4478+ (loop
32.4479+ :with prefix-pn = (ensure-absolute-pathname
32.4480+ (or prefix "tmp")
32.4481+ (or (ensure-pathname
32.4482+ directory
32.4483+ :namestring :native
32.4484+ :ensure-directory t
32.4485+ :ensure-physical t)
32.4486+ #'temporary-directory))
32.4487+ :with prefix-nns = (native-namestring prefix-pn)
32.4488+ :with results = (progn (ensure-directories-exist prefix-pn)
32.4489+ ())
32.4490+ :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
32.4491+ :for pathname = (parse-native-namestring
32.4492+ (format nil "~A~36R~@[~A~]~@[.~A~]"
32.4493+ prefix-nns counter suffix (unless (eq type :unspecific) type)))
32.4494+ :for okp = nil :do
32.4495+ ;; TODO: on Unix, do something about umask
32.4496+ ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
32.4497+ ;; TODO: on Unix, use CFFI and mkstemp --
32.4498+ ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
32.4499+ ;; Can we at least design some hook?
32.4500+ (unwind-protect
32.4501+ (progn
32.4502+ (ensure-directories-exist pathname)
32.4503+ (with-open-file (stream pathname
32.4504+ :direction direction
32.4505+ :element-type element-type
32.4506+ :external-format external-format
32.4507+ :if-exists nil :if-does-not-exist :create)
32.4508+ (when stream
32.4509+ (setf okp pathname)
32.4510+ (when want-stream-p
32.4511+ ;; Note: can't return directly from within with-open-file
32.4512+ ;; or the non-local return causes the file creation to be undone.
32.4513+ (setf results (multiple-value-list
32.4514+ (if want-pathname-p
32.4515+ (call-function thunk stream pathname)
32.4516+ (call-function thunk stream)))))))
32.4517+ ;; if we don't want a stream, then we must call the thunk *after*
32.4518+ ;; the stream is closed, but only if it was successfully opened.
32.4519+ (when okp
32.4520+ (when (and want-pathname-p (not want-stream-p))
32.4521+ (setf results (multiple-value-list (call-function thunk okp))))
32.4522+ ;; if the stream was successfully opened, then return a value,
32.4523+ ;; either one computed already, or one from AFTER, if that exists.
32.4524+ (if after
32.4525+ (return (call-function after pathname))
32.4526+ (return (values-list results)))))
32.4527+ (when (and okp (not (call-function keep)))
32.4528+ (ignore-errors (delete-file-if-exists okp))))))
32.4529+
32.4530+ (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
32.4531+ (pathname (gensym "PATHNAME") pathnamep)
32.4532+ directory prefix suffix type
32.4533+ keep direction element-type external-format)
32.4534+ &body body)
32.4535+ "Evaluate BODY where the symbols specified by keyword arguments
32.4536+STREAM and PATHNAME (if respectively specified) are bound corresponding
32.4537+to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
32.4538+At least one of STREAM or PATHNAME must be specified.
32.4539+If the STREAM is not specified, it will be closed before the BODY is evaluated.
32.4540+If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
32.4541+separates forms run before and after the stream is closed.
32.4542+The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
32.4543+Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
32.4544+ (check-type stream symbol)
32.4545+ (check-type pathname symbol)
32.4546+ (assert (or streamp pathnamep))
32.4547+ (let* ((afterp (position :close-stream body))
32.4548+ (before (if afterp (subseq body 0 afterp) body))
32.4549+ (after (when afterp (subseq body (1+ afterp))))
32.4550+ (beforef (gensym "BEFORE"))
32.4551+ (afterf (gensym "AFTER")))
32.4552+ (when (eql afterp 0)
32.4553+ (style-warn ":CLOSE-STREAM should not be the first form of BODY in WITH-TEMPORARY-FILE. Instead, do not provide a STREAM."))
32.4554+ `(flet (,@(when before
32.4555+ `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
32.4556+ ,@(when after `((declare (ignorable ,pathname))))
32.4557+ ,@before)))
32.4558+ ,@(when after
32.4559+ (assert pathnamep)
32.4560+ `((,afterf (,pathname) ,@after))))
32.4561+ #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf))))
32.4562+ (call-with-temporary-file
32.4563+ ,(when before `#',beforef)
32.4564+ :want-stream-p ,streamp
32.4565+ :want-pathname-p ,pathnamep
32.4566+ ,@(when direction `(:direction ,direction))
32.4567+ ,@(when directory `(:directory ,directory))
32.4568+ ,@(when prefix `(:prefix ,prefix))
32.4569+ ,@(when suffix `(:suffix ,suffix))
32.4570+ ,@(when type `(:type ,type))
32.4571+ ,@(when keep `(:keep ,keep))
32.4572+ ,@(when after `(:after #',afterf))
32.4573+ ,@(when element-type `(:element-type ,element-type))
32.4574+ ,@(when external-format `(:external-format ,external-format))))))
32.4575+
32.4576+ (defun get-temporary-file (&key directory prefix suffix type (keep t))
32.4577+ (with-temporary-file (:pathname pn :keep keep
32.4578+ :directory directory :prefix prefix :suffix suffix :type type)
32.4579+ pn))
32.4580+
32.4581+ ;; Temporary pathnames in simple cases where no contention is assumed
32.4582+ (defun add-pathname-suffix (pathname suffix &rest keys)
32.4583+ "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
32.4584+Further KEYS can be passed to MAKE-PATHNAME."
32.4585+ (apply 'make-pathname :name (strcat (pathname-name pathname) suffix)
32.4586+ :defaults pathname keys))
32.4587+
32.4588+ (defun tmpize-pathname (x)
32.4589+ "Return a new pathname modified from X by adding a trivial random suffix.
32.4590+A new empty file with said temporary pathname is created, to ensure there is no
32.4591+clash with any concurrent process attempting the same thing."
32.4592+ (let* ((px (ensure-pathname x :ensure-physical t))
32.4593+ (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp"))
32.4594+ (directory (pathname-directory-pathname px)))
32.4595+ ;; Genera uses versioned pathnames -- If we leave the empty file in place,
32.4596+ ;; the system will create a new version of the file when the caller opens
32.4597+ ;; it for output. That empty file will remain after the operation is completed.
32.4598+ ;; As Genera is a single core processor, the possibility of a name conflict is
32.4599+ ;; minimal if not nil. (And, in the event of a collision, the two processes
32.4600+ ;; would be writing to different versions of the file.)
32.4601+ (get-temporary-file :directory directory :prefix prefix :type (pathname-type px)
32.4602+ #+genera :keep #+genera nil)))
32.4603+
32.4604+ (defun call-with-staging-pathname (pathname fun)
32.4605+ "Calls FUN with a staging pathname, and atomically
32.4606+renames the staging pathname to the PATHNAME in the end.
32.4607+NB: this protects only against failure of the program, not against concurrent attempts.
32.4608+For the latter case, we ought pick a random suffix and atomically open it."
32.4609+ (let* ((pathname (pathname pathname))
32.4610+ (staging (tmpize-pathname pathname)))
32.4611+ (unwind-protect
32.4612+ (multiple-value-prog1
32.4613+ (funcall fun staging)
32.4614+ (rename-file-overwriting-target staging pathname))
32.4615+ (delete-file-if-exists staging))))
32.4616+
32.4617+ (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
32.4618+ "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
32.4619+ `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
32.4620+
32.4621+(with-upgradability ()
32.4622+ (defun file-stream-p (stream)
32.4623+ (typep stream 'file-stream))
32.4624+ (defun file-or-synonym-stream-p (stream)
32.4625+ (or (file-stream-p stream)
32.4626+ (and (typep stream 'synonym-stream)
32.4627+ (file-or-synonym-stream-p
32.4628+ (symbol-value (synonym-stream-symbol stream)))))))
32.4629+;;;; -------------------------------------------------------------------------
32.4630+;;;; Starting, Stopping, Dumping a Lisp image
32.4631+
32.4632+(uiop/package:define-package :uiop/image
32.4633+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
32.4634+ (:export
32.4635+ #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
32.4636+ #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0
32.4637+ #:*lisp-interaction*
32.4638+ #:fatal-condition #:fatal-condition-p
32.4639+ #:handle-fatal-condition
32.4640+ #:call-with-fatal-condition-handler #:with-fatal-condition-handler
32.4641+ #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
32.4642+ #:*image-postlude* #:*image-dump-hook*
32.4643+ #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
32.4644+ #:shell-boolean-exit
32.4645+ #:register-image-restore-hook #:register-image-dump-hook
32.4646+ #:call-image-restore-hook #:call-image-dump-hook
32.4647+ #:restore-image #:dump-image #:create-image
32.4648+))
32.4649+(in-package :uiop/image)
32.4650+
32.4651+(with-upgradability ()
32.4652+ (defvar *lisp-interaction* t
32.4653+ "Is this an interactive Lisp environment, or is it batch processing?")
32.4654+
32.4655+ (defvar *command-line-arguments* nil
32.4656+ "Command-line arguments")
32.4657+
32.4658+ (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
32.4659+ "Is this a dumped image? As a standalone executable?")
32.4660+
32.4661+ (defvar *image-restore-hook* nil
32.4662+ "Functions to call (in reverse order) when the image is restored")
32.4663+
32.4664+ (defvar *image-restored-p* nil
32.4665+ "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
32.4666+
32.4667+ (defvar *image-prelude* nil
32.4668+ "a form to evaluate, or string containing forms to read and evaluate
32.4669+when the image is restarted, but before the entry point is called.")
32.4670+
32.4671+ (defvar *image-entry-point* nil
32.4672+ "a function with which to restart the dumped image when execution is restored from it.")
32.4673+
32.4674+ (defvar *image-postlude* nil
32.4675+ "a form to evaluate, or string containing forms to read and evaluate
32.4676+before the image dump hooks are called and before the image is dumped.")
32.4677+
32.4678+ (defvar *image-dump-hook* nil
32.4679+ "Functions to call (in order) when before an image is dumped"))
32.4680+
32.4681+(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
32.4682+ (deftype fatal-condition ()
32.4683+ `(and serious-condition #+clozure (not ccl:process-reset))))
32.4684+
32.4685+;;; Exiting properly or im-
32.4686+(with-upgradability ()
32.4687+ (defun quit (&optional (code 0) (finish-output t))
32.4688+ "Quits from the Lisp world, with the given exit status if provided.
32.4689+This is designed to abstract away the implementation specific quit forms."
32.4690+ (when finish-output ;; essential, for ClozureCL, and for standard compliance.
32.4691+ (finish-outputs))
32.4692+ #+(or abcl xcl) (ext:quit :status code)
32.4693+ #+allegro (excl:exit code :quiet t)
32.4694+ #+(or clasp ecl) (si:quit code)
32.4695+ #+clisp (ext:quit code)
32.4696+ #+clozure (ccl:quit code)
32.4697+ #+cormanlisp (win32:exitprocess code)
32.4698+ #+(or cmucl scl) (unix:unix-exit code)
32.4699+ #+gcl (system:quit code)
32.4700+ #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
32.4701+ #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
32.4702+ #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
32.4703+ #+mkcl (mk-ext:quit :exit-code code)
32.4704+ #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
32.4705+ (quit (find-symbol* :quit :sb-ext nil)))
32.4706+ (cond
32.4707+ (exit `(,exit :code code :abort (not finish-output)))
32.4708+ (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
32.4709+ #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
32.4710+ (not-implemented-error 'quit "(called with exit code ~S)" code))
32.4711+
32.4712+ (defun die (code format &rest arguments)
32.4713+ "Die in error with some error message"
32.4714+ (with-safe-io-syntax ()
32.4715+ (ignore-errors
32.4716+ (format! *stderr* "~&~?~&" format arguments)))
32.4717+ (quit code))
32.4718+
32.4719+ (defun raw-print-backtrace (&key (stream *debug-io*) count condition)
32.4720+ "Print a backtrace, directly accessing the implementation"
32.4721+ (declare (ignorable stream count condition))
32.4722+ #+abcl
32.4723+ (loop :for i :from 0
32.4724+ :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
32.4725+ (safe-format! stream "~&~D: ~A~%" i frame))
32.4726+ #+allegro
32.4727+ (let ((*terminal-io* stream)
32.4728+ (*standard-output* stream)
32.4729+ (tpl:*zoom-print-circle* *print-circle*)
32.4730+ (tpl:*zoom-print-level* *print-level*)
32.4731+ (tpl:*zoom-print-length* *print-length*))
32.4732+ (tpl:do-command "zoom"
32.4733+ :from-read-eval-print-loop nil
32.4734+ :count (or count t)
32.4735+ :all t))
32.4736+ #+clasp
32.4737+ (clasp-debug:print-backtrace :stream stream :count count)
32.4738+ #+(or ecl mkcl)
32.4739+ (let* ((top (si:ihs-top))
32.4740+ (repeats (if count (min top count) top))
32.4741+ (backtrace (loop :for ihs :from 0 :below top
32.4742+ :collect (list (si::ihs-fun ihs)
32.4743+ (si::ihs-env ihs)))))
32.4744+ (loop :for i :from 0 :below repeats
32.4745+ :for frame :in (nreverse backtrace) :do
32.4746+ (safe-format! stream "~&~D: ~S~%" i frame)))
32.4747+ #+clisp
32.4748+ (system::print-backtrace :out stream :limit count)
32.4749+ #+(or clozure mcl)
32.4750+ (let ((*debug-io* stream))
32.4751+ #+clozure (ccl:print-call-history :count count :start-frame-number 1)
32.4752+ #+mcl (ccl:print-call-history :detailed-p nil)
32.4753+ (finish-output stream))
32.4754+ #+(or cmucl scl)
32.4755+ (let ((debug:*debug-print-level* *print-level*)
32.4756+ (debug:*debug-print-length* *print-length*))
32.4757+ (debug:backtrace (or count most-positive-fixnum) stream))
32.4758+ #+gcl
32.4759+ (let ((*debug-io* stream))
32.4760+ (ignore-errors
32.4761+ (with-safe-io-syntax ()
32.4762+ (if condition
32.4763+ (conditions::condition-backtrace condition)
32.4764+ (system::simple-backtrace)))))
32.4765+ #+lispworks
32.4766+ (let ((dbg::*debugger-stack*
32.4767+ (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
32.4768+ (*debug-io* stream)
32.4769+ (dbg:*debug-print-level* *print-level*)
32.4770+ (dbg:*debug-print-length* *print-length*))
32.4771+ (dbg:bug-backtrace nil))
32.4772+ #+mezzano
32.4773+ (let ((*standard-output* stream))
32.4774+ (sys.int::backtrace count))
32.4775+ #+sbcl
32.4776+ (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum))
32.4777+ #+xcl
32.4778+ (loop :for i :from 0 :below (or count most-positive-fixnum)
32.4779+ :for frame :in (extensions:backtrace-as-list) :do
32.4780+ (safe-format! stream "~&~D: ~S~%" i frame)))
32.4781+
32.4782+ (defun print-backtrace (&rest keys &key stream count condition)
32.4783+ "Print a backtrace"
32.4784+ (declare (ignore stream count condition))
32.4785+ (with-safe-io-syntax (:package :cl)
32.4786+ (let ((*print-readably* nil)
32.4787+ (*print-circle* t)
32.4788+ (*print-miser-width* 75)
32.4789+ (*print-length* nil)
32.4790+ (*print-level* nil)
32.4791+ (*print-pretty* t))
32.4792+ (ignore-errors (apply 'raw-print-backtrace keys)))))
32.4793+
32.4794+ (defun print-condition-backtrace (condition &key (stream *stderr*) count)
32.4795+ "Print a condition after a backtrace triggered by that condition"
32.4796+ ;; We print the condition *after* the backtrace,
32.4797+ ;; for the sake of who sees the backtrace at a terminal.
32.4798+ ;; It is up to the caller to print the condition *before*, with some context.
32.4799+ (print-backtrace :stream stream :count count :condition condition)
32.4800+ (when condition
32.4801+ (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
32.4802+ condition)))
32.4803+
32.4804+ (defun fatal-condition-p (condition)
32.4805+ "Is the CONDITION fatal?"
32.4806+ (typep condition 'fatal-condition))
32.4807+
32.4808+ (defun handle-fatal-condition (condition)
32.4809+ "Handle a fatal CONDITION:
32.4810+depending on whether *LISP-INTERACTION* is set, enter debugger or die"
32.4811+ (cond
32.4812+ (*lisp-interaction*
32.4813+ (invoke-debugger condition))
32.4814+ (t
32.4815+ (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
32.4816+ (print-condition-backtrace condition :stream *stderr*)
32.4817+ (die 99 "~A" condition))))
32.4818+
32.4819+ (defun call-with-fatal-condition-handler (thunk)
32.4820+ "Call THUNK in a context where fatal conditions are appropriately handled"
32.4821+ (handler-bind ((fatal-condition #'handle-fatal-condition))
32.4822+ (funcall thunk)))
32.4823+
32.4824+ (defmacro with-fatal-condition-handler ((&optional) &body body)
32.4825+ "Execute BODY in a context where fatal conditions are appropriately handled"
32.4826+ `(call-with-fatal-condition-handler #'(lambda () ,@body)))
32.4827+
32.4828+ (defun shell-boolean-exit (x)
32.4829+ "Quit with a return code that is 0 iff argument X is true"
32.4830+ (quit (if x 0 1))))
32.4831+
32.4832+
32.4833+;;; Using image hooks
32.4834+(with-upgradability ()
32.4835+ (defun register-image-restore-hook (hook &optional (call-now-p t))
32.4836+ "Regiter a hook function to be run when restoring a dumped image"
32.4837+ (register-hook-function '*image-restore-hook* hook call-now-p))
32.4838+
32.4839+ (defun register-image-dump-hook (hook &optional (call-now-p nil))
32.4840+ "Register a the hook function to be run before to dump an image"
32.4841+ (register-hook-function '*image-dump-hook* hook call-now-p))
32.4842+
32.4843+ (defun call-image-restore-hook ()
32.4844+ "Call the hook functions registered to be run when restoring a dumped image"
32.4845+ (call-functions (reverse *image-restore-hook*)))
32.4846+
32.4847+ (defun call-image-dump-hook ()
32.4848+ "Call the hook functions registered to be run before to dump an image"
32.4849+ (call-functions *image-dump-hook*)))
32.4850+
32.4851+
32.4852+;;; Proper command-line arguments
32.4853+(with-upgradability ()
32.4854+ (defun raw-command-line-arguments ()
32.4855+ "Find what the actual command line for this process was."
32.4856+ #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
32.4857+ #+allegro (sys:command-line-arguments) ; default: :application t
32.4858+ #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
32.4859+ #+clisp (coerce (ext:argv) 'list)
32.4860+ #+clozure ccl:*command-line-argument-list*
32.4861+ #+(or cmucl scl) extensions:*command-line-strings*
32.4862+ #+gcl si:*command-args*
32.4863+ #+(or genera mcl mezzano) nil
32.4864+ #+lispworks sys:*line-arguments-list*
32.4865+ #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i))
32.4866+ #+sbcl sb-ext:*posix-argv*
32.4867+ #+xcl system:*argv*
32.4868+ #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
32.4869+ (not-implemented-error 'raw-command-line-arguments))
32.4870+
32.4871+ (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
32.4872+ "Extract user arguments from command-line invocation of current process.
32.4873+Assume the calling conventions of a generated script that uses --
32.4874+if we are not called from a directly executable image."
32.4875+ (block nil
32.4876+ #+abcl (return arguments)
32.4877+ ;; SBCL and Allegro already separate user arguments from implementation arguments.
32.4878+ #-(or sbcl allegro)
32.4879+ (unless (eq *image-dumped-p* :executable)
32.4880+ ;; LispWorks command-line processing isn't transparent to the user
32.4881+ ;; unless you create a standalone executable; in that case,
32.4882+ ;; we rely on cl-launch or some other script to set the arguments for us.
32.4883+ #+lispworks (return *command-line-arguments*)
32.4884+ ;; On other implementations, on non-standalone executables,
32.4885+ ;; we trust cl-launch or whichever script starts the program
32.4886+ ;; to use -- as a delimiter between implementation arguments and user arguments.
32.4887+ #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
32.4888+ (rest arguments)))
32.4889+
32.4890+ (defun argv0 ()
32.4891+ "On supported implementations (most that matter), or when invoked by a proper wrapper script,
32.4892+return a string that for the name with which the program was invoked, i.e. argv[0] in C.
32.4893+Otherwise, return NIL."
32.4894+ (cond
32.4895+ ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 !
32.4896+ ;; NB: not currently available on ABCL, Corman, Genera, MCL
32.4897+ (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl)
32.4898+ (first (raw-command-line-arguments))
32.4899+ #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0)))
32.4900+ (t ;; argv[0] is the name of the interpreter.
32.4901+ ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
32.4902+ (getenvp "__CL_ARGV0"))))
32.4903+
32.4904+ (defun setup-command-line-arguments ()
32.4905+ (setf *command-line-arguments* (command-line-arguments)))
32.4906+
32.4907+ (defun restore-image (&key
32.4908+ (lisp-interaction *lisp-interaction*)
32.4909+ (restore-hook *image-restore-hook*)
32.4910+ (prelude *image-prelude*)
32.4911+ (entry-point *image-entry-point*)
32.4912+ (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
32.4913+ "From a freshly restarted Lisp image, restore the saved Lisp environment
32.4914+by setting appropriate variables, running various hooks, and calling any specified entry point.
32.4915+
32.4916+If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*,
32.4917+call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return
32.4918+immediately to the surrounding restore process if allowed to continue.
32.4919+
32.4920+Then, comes the restore process itself:
32.4921+First, call each function in the RESTORE-HOOK,
32.4922+in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
32.4923+Second, evaluate the prelude, which is often Lisp text that is read,
32.4924+as per EVAL-INPUT.
32.4925+Third, call the ENTRY-POINT function, if any is specified, with no argument.
32.4926+
32.4927+The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL,
32.4928+any unhandled error leads to a backtrace and an exit with an error status.
32.4929+If LISP-INTERACTION is NIL, the process also exits when no error occurs:
32.4930+if neither restart nor entry function is provided, the program will exit with status 0 (success);
32.4931+if a function was provided, the program will exit after the function returns (if it returns),
32.4932+with status 0 if and only if the primary return value of result is generalized boolean true,
32.4933+and with status 1 if this value is NIL.
32.4934+
32.4935+If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result
32.4936+of the function will be returned rather than interpreted as a boolean designating an exit code."
32.4937+ (when *image-restored-p*
32.4938+ (if if-already-restored
32.4939+ (call-function if-already-restored "Image already ~:[being ~;~]restored"
32.4940+ (eq *image-restored-p* t))
32.4941+ (return-from restore-image)))
32.4942+ (with-fatal-condition-handler ()
32.4943+ (setf *lisp-interaction* lisp-interaction)
32.4944+ (setf *image-restore-hook* restore-hook)
32.4945+ (setf *image-prelude* prelude)
32.4946+ (setf *image-restored-p* :in-progress)
32.4947+ (call-image-restore-hook)
32.4948+ (standard-eval-thunk prelude)
32.4949+ (setf *image-restored-p* t)
32.4950+ (let ((results (multiple-value-list
32.4951+ (if entry-point
32.4952+ (call-function entry-point)
32.4953+ t))))
32.4954+ (if lisp-interaction
32.4955+ (values-list results)
32.4956+ (shell-boolean-exit (first results)))))))
32.4957+
32.4958+
32.4959+;;; Dumping an image
32.4960+
32.4961+(with-upgradability ()
32.4962+ (defun dump-image (filename &key output-name executable
32.4963+ (postlude *image-postlude*)
32.4964+ (dump-hook *image-dump-hook*)
32.4965+ #+clozure prepend-symbols #+clozure (purify t)
32.4966+ #+sbcl compression
32.4967+ #+(and sbcl os-windows) application-type)
32.4968+ "Dump an image of the current Lisp environment at pathname FILENAME, with various options.
32.4969+
32.4970+First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
32.4971+ the functions in DUMP-HOOK, in reverse order of registration by REGISTER-IMAGE-DUMP-HOOK.
32.4972+
32.4973+If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup.
32.4974+
32.4975+Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL,
32.4976+or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
32.4977+ ;; Note: at least SBCL saves only global values of variables in the heap image,
32.4978+ ;; so make sure things you want to dump are NOT just local bindings shadowing the global values.
32.4979+ (declare (ignorable filename output-name executable))
32.4980+ (setf *image-dumped-p* (if executable :executable t))
32.4981+ (setf *image-restored-p* :in-regress)
32.4982+ (setf *image-postlude* postlude)
32.4983+ (standard-eval-thunk *image-postlude*)
32.4984+ (setf *image-dump-hook* dump-hook)
32.4985+ (call-image-dump-hook)
32.4986+ (setf *image-restored-p* nil)
32.4987+ #-(or clisp clozure (and cmucl executable) lispworks sbcl scl)
32.4988+ (when executable
32.4989+ (not-implemented-error 'dump-image "dumping an executable"))
32.4990+ #+allegro
32.4991+ (progn
32.4992+ (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
32.4993+ (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
32.4994+ #+clisp
32.4995+ (apply #'ext:saveinitmem filename
32.4996+ :quiet t
32.4997+ :start-package *package*
32.4998+ :keep-global-handlers nil
32.4999+ ;; Faré explains the odd executable value (slightly paraphrased):
32.5000+ ;; 0 is very different from t in clisp and there for a good reason:
32.5001+ ;; 0 turns the executable into one that has its own command-line handling, so hackers can't
32.5002+ ;; use the underlying -i or -x to turn your would-be restricted binary into an unrestricted evaluator.
32.5003+ :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
32.5004+ (when executable
32.5005+ (list
32.5006+ ;; :parse-options nil ;--- requires a non-standard patch to clisp.
32.5007+ :norc t :script nil :init-function #'restore-image)))
32.5008+ #+clozure
32.5009+ (flet ((dump (prepend-kernel)
32.5010+ (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
32.5011+ :toplevel-function (when executable #'restore-image))))
32.5012+ ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
32.5013+ (if prepend-symbols
32.5014+ (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
32.5015+ (require 'elf)
32.5016+ (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
32.5017+ (dump path))
32.5018+ (dump t)))
32.5019+ #+(or cmucl scl)
32.5020+ (progn
32.5021+ (ext:gc :full t)
32.5022+ (setf ext:*batch-mode* nil)
32.5023+ (setf ext::*gc-run-time* 0)
32.5024+ (apply 'ext:save-lisp filename
32.5025+ :allow-other-keys t ;; hush SCL and old versions of CMUCL
32.5026+ #+(and cmucl executable) :executable #+(and cmucl executable) t
32.5027+ (when executable '(:init-function restore-image :process-command-line nil
32.5028+ :quiet t :load-init-file nil :site-init nil))))
32.5029+ #+gcl
32.5030+ (progn
32.5031+ (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
32.5032+ (si::save-system filename))
32.5033+ #+lispworks
32.5034+ (if executable
32.5035+ (lispworks:deliver 'restore-image filename 0 :interface nil)
32.5036+ (hcl:save-image filename :environment nil))
32.5037+ #+sbcl
32.5038+ (progn
32.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
32.5040+ (setf sb-ext::*gc-run-time* 0)
32.5041+ (apply 'sb-ext:save-lisp-and-die filename
32.5042+ :executable t ;--- always include the runtime that goes with the core
32.5043+ (append
32.5044+ (when compression (list :compression compression))
32.5045+ ;;--- only save runtime-options for standalone executables
32.5046+ (when executable (list :toplevel #'restore-image :save-runtime-options t))
32.5047+ #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window.
32.5048+ ;; the default is :console - only works with SBCL 1.1.15 or later.
32.5049+ (when application-type (list :application-type application-type)))))
32.5050+ #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl)
32.5051+ (not-implemented-error 'dump-image))
32.5052+
32.5053+ (defun create-image (destination lisp-object-files
32.5054+ &key kind output-name prologue-code epilogue-code extra-object-files
32.5055+ (prelude () preludep) (postlude () postludep)
32.5056+ (entry-point () entry-point-p) build-args no-uiop)
32.5057+ (declare (ignorable destination lisp-object-files extra-object-files kind output-name
32.5058+ prologue-code epilogue-code prelude preludep postlude postludep
32.5059+ entry-point entry-point-p build-args no-uiop))
32.5060+ "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
32.5061+ ;; Is it meaningful to run these in the current environment?
32.5062+ ;; only if we also track the object files that constitute the "current" image,
32.5063+ ;; and otherwise simulate dump-image, including quitting at the end.
32.5064+ #-(or clasp ecl mkcl) (not-implemented-error 'create-image)
32.5065+ #+(or clasp ecl mkcl)
32.5066+ (let ((epilogue-code
32.5067+ (if no-uiop
32.5068+ epilogue-code
32.5069+ (let ((forms
32.5070+ (append
32.5071+ (when epilogue-code `(,epilogue-code))
32.5072+ (when postludep `((setf *image-postlude* ',postlude)))
32.5073+ (when preludep `((setf *image-prelude* ',prelude)))
32.5074+ (when entry-point-p `((setf *image-entry-point* ',entry-point)))
32.5075+ (case kind
32.5076+ ((:image)
32.5077+ (setf kind :program) ;; to ECL, it's just another program.
32.5078+ `((setf *image-dumped-p* t)
32.5079+ (si::top-level #+(or clasp ecl) t) (quit)))
32.5080+ ((:program)
32.5081+ `((setf *image-dumped-p* :executable)
32.5082+ (shell-boolean-exit
32.5083+ (restore-image))))))))
32.5084+ (when forms `(progn ,@forms))))))
32.5085+ (check-type kind (member :dll :shared-library :lib :static-library
32.5086+ :fasl :fasb :program))
32.5087+ (apply #+clasp 'cmp:builder #+clasp kind
32.5088+ #+(or ecl mkcl)
32.5089+ (ecase kind
32.5090+ ((:dll :shared-library)
32.5091+ #+ecl 'c::build-shared-library #+mkcl 'compiler:build-shared-library)
32.5092+ ((:lib :static-library)
32.5093+ #+ecl 'c::build-static-library #+mkcl 'compiler:build-static-library)
32.5094+ ((:fasl #+ecl :fasb)
32.5095+ #+ecl 'c::build-fasl #+mkcl 'compiler:build-fasl)
32.5096+ #+mkcl ((:fasb) 'compiler:build-bundle)
32.5097+ ((:program)
32.5098+ #+ecl 'c::build-program #+mkcl 'compiler:build-program))
32.5099+ (pathname destination)
32.5100+ #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files
32.5101+ (append lisp-object-files #+(or clasp ecl) extra-object-files)
32.5102+ #+ecl :init-name
32.5103+ #+ecl (getf build-args :init-name)
32.5104+ (append
32.5105+ (when prologue-code `(:prologue-code ,prologue-code))
32.5106+ (when epilogue-code `(:epilogue-code ,epilogue-code))
32.5107+ #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
32.5108+ build-args)))))
32.5109+
32.5110+
32.5111+;;; Some universal image restore hooks
32.5112+(with-upgradability ()
32.5113+ (map () 'register-image-restore-hook
32.5114+ '(setup-stdin setup-stdout setup-stderr
32.5115+ setup-command-line-arguments setup-temporary-directory
32.5116+ #+abcl detect-os)))
32.5117+;;;; -------------------------------------------------------------------------
32.5118+;;;; Support to build (compile and load) Lisp files
32.5119+
32.5120+(uiop/package:define-package :uiop/lisp-build
32.5121+ (:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp
32.5122+ (:use :uiop/common-lisp :uiop/package :uiop/utility
32.5123+ :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
32.5124+ (:export
32.5125+ ;; Variables
32.5126+ #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
32.5127+ #:*output-translation-function*
32.5128+ #:*optimization-settings* #:*previous-optimization-settings*
32.5129+ #:*base-build-directory*
32.5130+ #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
32.5131+ #:compile-warned-warning #:compile-failed-warning
32.5132+ #:check-lisp-compile-results #:check-lisp-compile-warnings
32.5133+ #:*uninteresting-conditions* #:*usual-uninteresting-conditions*
32.5134+ #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
32.5135+ ;; Types
32.5136+ #+sbcl #:sb-grovel-unknown-constant-condition
32.5137+ ;; Functions & Macros
32.5138+ #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings
32.5139+ #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
32.5140+ #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
32.5141+ #:reify-simple-sexp #:unreify-simple-sexp
32.5142+ #:reify-deferred-warnings #:unreify-deferred-warnings
32.5143+ #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
32.5144+ #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
32.5145+ #:enable-deferred-warnings-check #:disable-deferred-warnings-check
32.5146+ #:current-lisp-file-pathname #:load-pathname
32.5147+ #:lispize-pathname #:compile-file-type #:call-around-hook
32.5148+ #:compile-file* #:compile-file-pathname* #:*compile-check*
32.5149+ #:load* #:load-from-string #:combine-fasls)
32.5150+ (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
32.5151+(in-package :uiop/lisp-build)
32.5152+
32.5153+(with-upgradability ()
32.5154+ (defvar *compile-file-warnings-behaviour*
32.5155+ (or #+clisp :ignore :warn)
32.5156+ "How should ASDF react if it encounters a warning when compiling a file?
32.5157+Valid values are :error, :warn, and :ignore.")
32.5158+
32.5159+ (defvar *compile-file-failure-behaviour*
32.5160+ (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
32.5161+ "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
32.5162+when compiling a file, which includes any non-style-warning warning.
32.5163+Valid values are :error, :warn, and :ignore.
32.5164+Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
32.5165+
32.5166+ (defvar *base-build-directory* nil
32.5167+ "When set to a non-null value, it should be an absolute directory pathname,
32.5168+which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE,
32.5169+what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it.
32.5170+This can help you produce more deterministic output for FASLs."))
32.5171+
32.5172+;;; Optimization settings
32.5173+(with-upgradability ()
32.5174+ (defvar *optimization-settings* nil
32.5175+ "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS")
32.5176+ (defvar *previous-optimization-settings* nil
32.5177+ "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
32.5178+ (defparameter +optimization-variables+
32.5179+ ;; TODO: allegro genera corman mcl
32.5180+ (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*)
32.5181+ #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents)
32.5182+ #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety*
32.5183+ ccl::*nx-debug* ccl::*nx-cspeed*)
32.5184+ #+(or cmucl scl) '(c::*default-cookie*)
32.5185+ #+clasp nil
32.5186+ #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
32.5187+ #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
32.5188+ #+lispworks '(compiler::*optimization-level*)
32.5189+ #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*)
32.5190+ #+sbcl '(sb-c::*policy*)))
32.5191+ (defun get-optimization-settings ()
32.5192+ "Get current compiler optimization settings, ready to PROCLAIM again"
32.5193+ #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
32.5194+ (warn "~S does not support ~S. Please help me fix that."
32.5195+ 'get-optimization-settings (implementation-type))
32.5196+ #+clasp (cleavir-env:optimize (cleavir-env:optimize-info CLASP-CLEAVIR:*CLASP-ENV*))
32.5197+ #+(or abcl allegro clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
32.5198+ (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity)))
32.5199+ #.`(loop #+(or allegro clozure)
32.5200+ ,@'(:with info = #+allegro (sys:declaration-information 'optimize)
32.5201+ #+clozure (ccl:declaration-information 'optimize nil))
32.5202+ :for x :in settings
32.5203+ ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
32.5204+ :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
32.5205+ #+clisp (gethash x system::*optimize* 1)
32.5206+ #+(or abcl ecl mkcl xcl) (symbol-value v)
32.5207+ #+(or cmucl scl) (slot-value c::*default-cookie*
32.5208+ (case x (compilation-speed 'c::cspeed)
32.5209+ (otherwise x)))
32.5210+ #+lispworks (slot-value compiler::*optimization-level* x)
32.5211+ #+sbcl (sb-c::policy-quality sb-c::*policy* x))
32.5212+ :when y :collect (list x y))))
32.5213+ (defun proclaim-optimization-settings ()
32.5214+ "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
32.5215+ (proclaim `(optimize ,@*optimization-settings*))
32.5216+ (let ((settings (get-optimization-settings)))
32.5217+ (unless (equal *previous-optimization-settings* settings)
32.5218+ (setf *previous-optimization-settings* settings))))
32.5219+ (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body)
32.5220+ #+(or allegro clasp clisp)
32.5221+ (let ((previous-settings (gensym "PREVIOUS-SETTINGS"))
32.5222+ (reset-settings (gensym "RESET-SETTINGS")))
32.5223+ `(let* ((,previous-settings (get-optimization-settings))
32.5224+ (,reset-settings #+clasp (reverse ,previous-settings) #-clasp ,previous-settings))
32.5225+ ,@(when settings `((proclaim `(optimize ,@,settings))))
32.5226+ (unwind-protect (progn ,@body)
32.5227+ (proclaim `(optimize ,@,reset-settings)))))
32.5228+ #-(or allegro clasp clisp)
32.5229+ `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v))
32.5230+ ,@(when settings `((proclaim `(optimize ,@,settings))))
32.5231+ ,@body)))
32.5232+
32.5233+
32.5234+;;; Condition control
32.5235+(with-upgradability ()
32.5236+ #+sbcl
32.5237+ (progn
32.5238+ (defun sb-grovel-unknown-constant-condition-p (c)
32.5239+ "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
32.5240+ (ignore-errors
32.5241+ (and (typep c 'sb-int:simple-style-warning)
32.5242+ (string-enclosed-p
32.5243+ "Couldn't grovel for "
32.5244+ (simple-condition-format-control c)
32.5245+ " (unknown to the C compiler)."))))
32.5246+ (deftype sb-grovel-unknown-constant-condition ()
32.5247+ '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
32.5248+
32.5249+ (defvar *usual-uninteresting-conditions*
32.5250+ (append
32.5251+ ;;#+clozure '(ccl:compiler-warning)
32.5252+ #+cmucl '("Deleting unreachable code.")
32.5253+ #+lispworks '("~S being redefined in ~A (previously in ~A)."
32.5254+ "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
32.5255+ #+sbcl
32.5256+ '(sb-c::simple-compiler-note
32.5257+ "&OPTIONAL and &KEY found in the same lambda list: ~S"
32.5258+ sb-kernel:undefined-alien-style-warning
32.5259+ sb-grovel-unknown-constant-condition ; defined above.
32.5260+ sb-ext:implicit-generic-function-warning ;; Controversial.
32.5261+ sb-int:package-at-variance
32.5262+ sb-kernel:uninteresting-redefinition
32.5263+ ;; BEWARE: the below four are controversial to include here.
32.5264+ sb-kernel:redefinition-with-defun
32.5265+ sb-kernel:redefinition-with-defgeneric
32.5266+ sb-kernel:redefinition-with-defmethod
32.5267+ sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
32.5268+ #+sbcl
32.5269+ (let ((condition (find-symbol* '#:lexical-environment-too-complex :sb-kernel nil)))
32.5270+ (when condition
32.5271+ (list condition)))
32.5272+ '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
32.5273+ "A suggested value to which to set or bind *uninteresting-conditions*.")
32.5274+
32.5275+ (defvar *uninteresting-conditions* '()
32.5276+ "Conditions that may be skipped while compiling or loading Lisp code.")
32.5277+ (defvar *uninteresting-compiler-conditions* '()
32.5278+ "Additional conditions that may be skipped while compiling Lisp code.")
32.5279+ (defvar *uninteresting-loader-conditions*
32.5280+ (append
32.5281+ '("Overwriting already existing readtable ~S." ;; from named-readtables
32.5282+ #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
32.5283+ #+clisp '(clos::simple-gf-replacing-method-warning))
32.5284+ "Additional conditions that may be skipped while loading Lisp code."))
32.5285+
32.5286+;;;; ----- Filtering conditions while building -----
32.5287+(with-upgradability ()
32.5288+ (defun call-with-muffled-compiler-conditions (thunk)
32.5289+ "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
32.5290+ (call-with-muffled-conditions
32.5291+ thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
32.5292+ (defmacro with-muffled-compiler-conditions ((&optional) &body body)
32.5293+ "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS"
32.5294+ `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
32.5295+ (defun call-with-muffled-loader-conditions (thunk)
32.5296+ "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
32.5297+ (call-with-muffled-conditions
32.5298+ thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
32.5299+ (defmacro with-muffled-loader-conditions ((&optional) &body body)
32.5300+ "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS"
32.5301+ `(call-with-muffled-loader-conditions #'(lambda () ,@body))))
32.5302+
32.5303+
32.5304+;;;; Handle warnings and failures
32.5305+(with-upgradability ()
32.5306+ (define-condition compile-condition (condition)
32.5307+ ((context-format
32.5308+ :initform nil :reader compile-condition-context-format :initarg :context-format)
32.5309+ (context-arguments
32.5310+ :initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
32.5311+ (description
32.5312+ :initform nil :reader compile-condition-description :initarg :description))
32.5313+ (:report (lambda (c s)
32.5314+ (format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
32.5315+ (or (compile-condition-description c) (type-of c))
32.5316+ (compile-condition-context-format c)
32.5317+ (compile-condition-context-arguments c)))))
32.5318+ (define-condition compile-file-error (compile-condition error) ())
32.5319+ (define-condition compile-warned-warning (compile-condition warning) ())
32.5320+ (define-condition compile-warned-error (compile-condition error) ())
32.5321+ (define-condition compile-failed-warning (compile-condition warning) ())
32.5322+ (define-condition compile-failed-error (compile-condition error) ())
32.5323+
32.5324+ (defun check-lisp-compile-warnings (warnings-p failure-p
32.5325+ &optional context-format context-arguments)
32.5326+ "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
32.5327+raise an error or warning as appropriate"
32.5328+ (when failure-p
32.5329+ (case *compile-file-failure-behaviour*
32.5330+ (:warn (warn 'compile-failed-warning
32.5331+ :description "Lisp compilation failed"
32.5332+ :context-format context-format
32.5333+ :context-arguments context-arguments))
32.5334+ (:error (error 'compile-failed-error
32.5335+ :description "Lisp compilation failed"
32.5336+ :context-format context-format
32.5337+ :context-arguments context-arguments))
32.5338+ (:ignore nil)))
32.5339+ (when warnings-p
32.5340+ (case *compile-file-warnings-behaviour*
32.5341+ (:warn (warn 'compile-warned-warning
32.5342+ :description "Lisp compilation had style-warnings"
32.5343+ :context-format context-format
32.5344+ :context-arguments context-arguments))
32.5345+ (:error (error 'compile-warned-error
32.5346+ :description "Lisp compilation had style-warnings"
32.5347+ :context-format context-format
32.5348+ :context-arguments context-arguments))
32.5349+ (:ignore nil))))
32.5350+
32.5351+ (defun check-lisp-compile-results (output warnings-p failure-p
32.5352+ &optional context-format context-arguments)
32.5353+ "Given the results of COMPILE-FILE, raise an error or warning as appropriate"
32.5354+ (unless output
32.5355+ (error 'compile-file-error :context-format context-format :context-arguments context-arguments))
32.5356+ (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
32.5357+
32.5358+
32.5359+;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
32.5360+;;;
32.5361+;;; To support an implementation, three functions must be implemented:
32.5362+;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
32.5363+;;; See their respective docstrings.
32.5364+(with-upgradability ()
32.5365+ (defun reify-simple-sexp (sexp)
32.5366+ "Given a simple SEXP, return a representation of it as a portable SEXP.
32.5367+Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
32.5368+ (etypecase sexp
32.5369+ (symbol (reify-symbol sexp))
32.5370+ ((or number character simple-string pathname) sexp)
32.5371+ (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
32.5372+ (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
32.5373+
32.5374+ (defun unreify-simple-sexp (sexp)
32.5375+ "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
32.5376+ (etypecase sexp
32.5377+ ((or symbol number character simple-string pathname) sexp)
32.5378+ (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
32.5379+ ((simple-vector 2) (unreify-symbol sexp))
32.5380+ ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector))))
32.5381+
32.5382+ #+clozure
32.5383+ (progn
32.5384+ (defun reify-source-note (source-note)
32.5385+ (when source-note
32.5386+ (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename)
32.5387+ (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note
32.5388+ (declare (ignorable source))
32.5389+ (list :filename filename :start-pos start-pos :end-pos end-pos
32.5390+ #|:source (reify-source-note source)|#))))
32.5391+ (defun unreify-source-note (source-note)
32.5392+ (when source-note
32.5393+ (destructuring-bind (&key filename start-pos end-pos source) source-note
32.5394+ (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
32.5395+ :source (unreify-source-note source)))))
32.5396+ (defun unsymbolify-function-name (name)
32.5397+ (if-let (setfed (gethash name ccl::%setf-function-name-inverses%))
32.5398+ `(setf ,setfed)
32.5399+ name))
32.5400+ (defun symbolify-function-name (name)
32.5401+ (if (and (consp name) (eq (first name) 'setf))
32.5402+ (let ((setfed (second name)))
32.5403+ (gethash setfed ccl::%setf-function-names%))
32.5404+ name))
32.5405+ (defun reify-function-name (function-name)
32.5406+ (let ((name (or (first function-name) ;; defun: extract the name
32.5407+ (let ((sec (second function-name)))
32.5408+ (or (and (atom sec) sec) ; scoped method: drop scope
32.5409+ (first sec)))))) ; method: keep gf name, drop method specializers
32.5410+ (list name)))
32.5411+ (defun unreify-function-name (function-name)
32.5412+ function-name)
32.5413+ (defun nullify-non-literals (sexp)
32.5414+ (typecase sexp
32.5415+ ((or number character simple-string symbol pathname) sexp)
32.5416+ (cons (cons (nullify-non-literals (car sexp))
32.5417+ (nullify-non-literals (cdr sexp))))
32.5418+ (t nil)))
32.5419+ (defun reify-deferred-warning (deferred-warning)
32.5420+ (with-accessors ((warning-type ccl::compiler-warning-warning-type)
32.5421+ (args ccl::compiler-warning-args)
32.5422+ (source-note ccl:compiler-warning-source-note)
32.5423+ (function-name ccl:compiler-warning-function-name)) deferred-warning
32.5424+ (list :warning-type warning-type :function-name (reify-function-name function-name)
32.5425+ :source-note (reify-source-note source-note)
32.5426+ :args (destructuring-bind (fun &rest more)
32.5427+ args
32.5428+ (cons (unsymbolify-function-name fun)
32.5429+ (nullify-non-literals more))))))
32.5430+ (defun unreify-deferred-warning (reified-deferred-warning)
32.5431+ (destructuring-bind (&key warning-type function-name source-note args)
32.5432+ reified-deferred-warning
32.5433+ (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*))
32.5434+ 'ccl::compiler-warning)
32.5435+ :function-name (unreify-function-name function-name)
32.5436+ :source-note (unreify-source-note source-note)
32.5437+ :warning-type warning-type
32.5438+ :args (destructuring-bind (fun . more) args
32.5439+ (cons (symbolify-function-name fun) more))))))
32.5440+ #+(or cmucl scl)
32.5441+ (defun reify-undefined-warning (warning)
32.5442+ ;; Extracting undefined-warnings from the compilation-unit
32.5443+ ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
32.5444+ (list*
32.5445+ (c::undefined-warning-kind warning)
32.5446+ (c::undefined-warning-name warning)
32.5447+ (c::undefined-warning-count warning)
32.5448+ (mapcar
32.5449+ #'(lambda (frob)
32.5450+ ;; the lexenv slot can be ignored for reporting purposes
32.5451+ `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob)
32.5452+ :source ,(c::compiler-error-context-source frob)
32.5453+ :original-source ,(c::compiler-error-context-original-source frob)
32.5454+ :context ,(c::compiler-error-context-context frob)
32.5455+ :file-name ,(c::compiler-error-context-file-name frob) ; a pathname
32.5456+ :file-position ,(c::compiler-error-context-file-position frob) ; an integer
32.5457+ :original-source-path ,(c::compiler-error-context-original-source-path frob)))
32.5458+ (c::undefined-warning-warnings warning))))
32.5459+
32.5460+ #+sbcl
32.5461+ (defun reify-undefined-warning (warning)
32.5462+ ;; Extracting undefined-warnings from the compilation-unit
32.5463+ ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
32.5464+ (list*
32.5465+ (sb-c::undefined-warning-kind warning)
32.5466+ (sb-c::undefined-warning-name warning)
32.5467+ (sb-c::undefined-warning-count warning)
32.5468+ ;; the COMPILER-ERROR-CONTEXT struct has changed in SBCL, which means how we
32.5469+ ;; handle deferred warnings must change... TODO: when enough time has
32.5470+ ;; gone by, just assume all versions of SBCL are adequately
32.5471+ ;; up-to-date, and cut this material.[2018/05/30:rpg]
32.5472+ (mapcar
32.5473+ #'(lambda (frob)
32.5474+ ;; the lexenv slot can be ignored for reporting purposes
32.5475+ `(
32.5476+ #- #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c)
32.5477+ ,@`(:enclosing-source
32.5478+ ,(sb-c::compiler-error-context-enclosing-source frob)
32.5479+ :source
32.5480+ ,(sb-c::compiler-error-context-source frob)
32.5481+ :original-source
32.5482+ ,(sb-c::compiler-error-context-original-source frob))
32.5483+ #+ #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c)
32.5484+ ,@ `(:%enclosing-source
32.5485+ ,(sb-c::compiler-error-context-enclosing-source frob)
32.5486+ :%source
32.5487+ ,(sb-c::compiler-error-context-source frob)
32.5488+ :original-form
32.5489+ ,(sb-c::compiler-error-context-original-form frob))
32.5490+ :context ,(sb-c::compiler-error-context-context frob)
32.5491+ :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
32.5492+ :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
32.5493+ :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
32.5494+ (sb-c::undefined-warning-warnings warning))))
32.5495+
32.5496+ (defun reify-deferred-warnings ()
32.5497+ "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
32.5498+using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
32.5499+WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
32.5500+ #+allegro
32.5501+ (list :functions-defined excl::.functions-defined.
32.5502+ :functions-called excl::.functions-called.)
32.5503+ #+clozure
32.5504+ (mapcar 'reify-deferred-warning
32.5505+ (if-let (dw ccl::*outstanding-deferred-warnings*)
32.5506+ (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
32.5507+ (ccl::deferred-warnings.warnings mdw))))
32.5508+ #+(or cmucl scl)
32.5509+ (when lisp::*in-compilation-unit*
32.5510+ ;; Try to send nothing through the pipe if nothing needs to be accumulated
32.5511+ `(,@(when c::*undefined-warnings*
32.5512+ `((c::*undefined-warnings*
32.5513+ ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*))))
32.5514+ ,@(loop :for what :in '(c::*compiler-error-count*
32.5515+ c::*compiler-warning-count*
32.5516+ c::*compiler-note-count*)
32.5517+ :for value = (symbol-value what)
32.5518+ :when (plusp value)
32.5519+ :collect `(,what . ,value))))
32.5520+ #+sbcl
32.5521+ (when sb-c::*in-compilation-unit*
32.5522+ ;; Try to send nothing through the pipe if nothing needs to be accumulated
32.5523+ `(,@(when sb-c::*undefined-warnings*
32.5524+ `((sb-c::*undefined-warnings*
32.5525+ ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*))))
32.5526+ ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
32.5527+ sb-c::*compiler-error-count*
32.5528+ sb-c::*compiler-warning-count*
32.5529+ sb-c::*compiler-style-warning-count*
32.5530+ sb-c::*compiler-note-count*)
32.5531+ :for value = (symbol-value what)
32.5532+ :when (plusp value)
32.5533+ :collect `(,what . ,value)))))
32.5534+
32.5535+ (defun unreify-deferred-warnings (reified-deferred-warnings)
32.5536+ "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
32.5537+deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
32.5538+Handle any warning that has been resolved already,
32.5539+such as an undefined function that has been defined since.
32.5540+One of three functions required for deferred-warnings support in ASDF."
32.5541+ (declare (ignorable reified-deferred-warnings))
32.5542+ #+allegro
32.5543+ (destructuring-bind (&key functions-defined functions-called)
32.5544+ reified-deferred-warnings
32.5545+ (setf excl::.functions-defined.
32.5546+ (append functions-defined excl::.functions-defined.)
32.5547+ excl::.functions-called.
32.5548+ (append functions-called excl::.functions-called.)))
32.5549+ #+clozure
32.5550+ (let ((dw (or ccl::*outstanding-deferred-warnings*
32.5551+ (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t)))))
32.5552+ (appendf (ccl::deferred-warnings.warnings dw)
32.5553+ (mapcar 'unreify-deferred-warning reified-deferred-warnings)))
32.5554+ #+(or cmucl scl)
32.5555+ (dolist (item reified-deferred-warnings)
32.5556+ ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
32.5557+ ;; For *undefined-warnings*, the adjustment is a list of initargs.
32.5558+ ;; For everything else, it's an integer.
32.5559+ (destructuring-bind (symbol . adjustment) item
32.5560+ (case symbol
32.5561+ ((c::*undefined-warnings*)
32.5562+ (setf c::*undefined-warnings*
32.5563+ (nconc (mapcan
32.5564+ #'(lambda (stuff)
32.5565+ (destructuring-bind (kind name count . rest) stuff
32.5566+ (unless (case kind (:function (fboundp name)))
32.5567+ (list
32.5568+ (c::make-undefined-warning
32.5569+ :name name
32.5570+ :kind kind
32.5571+ :count count
32.5572+ :warnings
32.5573+ (mapcar #'(lambda (x)
32.5574+ (apply #'c::make-compiler-error-context x))
32.5575+ rest))))))
32.5576+ adjustment)
32.5577+ c::*undefined-warnings*)))
32.5578+ (otherwise
32.5579+ (set symbol (+ (symbol-value symbol) adjustment))))))
32.5580+ #+sbcl
32.5581+ (dolist (item reified-deferred-warnings)
32.5582+ ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
32.5583+ ;; For *undefined-warnings*, the adjustment is a list of initargs.
32.5584+ ;; For everything else, it's an integer.
32.5585+ (destructuring-bind (symbol . adjustment) item
32.5586+ (case symbol
32.5587+ ((sb-c::*undefined-warnings*)
32.5588+ (setf sb-c::*undefined-warnings*
32.5589+ (nconc (mapcan
32.5590+ #'(lambda (stuff)
32.5591+ (destructuring-bind (kind name count . rest) stuff
32.5592+ (unless (case kind (:function (fboundp name)))
32.5593+ (list
32.5594+ (sb-c::make-undefined-warning
32.5595+ :name name
32.5596+ :kind kind
32.5597+ :count count
32.5598+ :warnings
32.5599+ (mapcar #'(lambda (x)
32.5600+ (apply #'sb-c::make-compiler-error-context x))
32.5601+ rest))))))
32.5602+ adjustment)
32.5603+ sb-c::*undefined-warnings*)))
32.5604+ (otherwise
32.5605+ (set symbol (+ (symbol-value symbol) adjustment)))))))
32.5606+
32.5607+ (defun reset-deferred-warnings ()
32.5608+ "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT.
32.5609+One of three functions required for deferred-warnings support in ASDF."
32.5610+ #+allegro
32.5611+ (setf excl::.functions-defined. nil
32.5612+ excl::.functions-called. nil)
32.5613+ #+clozure
32.5614+ (if-let (dw ccl::*outstanding-deferred-warnings*)
32.5615+ (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
32.5616+ (setf (ccl::deferred-warnings.warnings mdw) nil)))
32.5617+ #+(or cmucl scl)
32.5618+ (when lisp::*in-compilation-unit*
32.5619+ (setf c::*undefined-warnings* nil
32.5620+ c::*compiler-error-count* 0
32.5621+ c::*compiler-warning-count* 0
32.5622+ c::*compiler-note-count* 0))
32.5623+ #+sbcl
32.5624+ (when sb-c::*in-compilation-unit*
32.5625+ (setf sb-c::*undefined-warnings* nil
32.5626+ sb-c::*aborted-compilation-unit-count* 0
32.5627+ sb-c::*compiler-error-count* 0
32.5628+ sb-c::*compiler-warning-count* 0
32.5629+ sb-c::*compiler-style-warning-count* 0
32.5630+ sb-c::*compiler-note-count* 0)))
32.5631+
32.5632+ (defun save-deferred-warnings (warnings-file)
32.5633+ "Save forward reference conditions so they may be issued at a latter time,
32.5634+possibly in a different process."
32.5635+ (with-open-file (s warnings-file :direction :output :if-exists :supersede
32.5636+ :element-type *default-stream-element-type*
32.5637+ :external-format *utf-8-external-format*)
32.5638+ (with-safe-io-syntax ()
32.5639+ (let ((*read-eval* t))
32.5640+ (write (reify-deferred-warnings) :stream s :pretty t :readably t))
32.5641+ (terpri s))))
32.5642+
32.5643+ (defun warnings-file-type (&optional implementation-type)
32.5644+ "The pathname type for warnings files on given IMPLEMENTATION-TYPE,
32.5645+where NIL designates the current one"
32.5646+ (case (or implementation-type *implementation-type*)
32.5647+ ((:acl :allegro) "allegro-warnings")
32.5648+ ;;((:clisp) "clisp-warnings")
32.5649+ ((:cmu :cmucl) "cmucl-warnings")
32.5650+ ((:sbcl) "sbcl-warnings")
32.5651+ ((:clozure :ccl) "ccl-warnings")
32.5652+ ((:scl) "scl-warnings")))
32.5653+
32.5654+ (defvar *warnings-file-type* nil
32.5655+ "Pathname type for warnings files, or NIL if disabled")
32.5656+
32.5657+ (defun enable-deferred-warnings-check ()
32.5658+ "Enable the saving of deferred warnings"
32.5659+ (setf *warnings-file-type* (warnings-file-type)))
32.5660+
32.5661+ (defun disable-deferred-warnings-check ()
32.5662+ "Disable the saving of deferred warnings"
32.5663+ (setf *warnings-file-type* nil))
32.5664+
32.5665+ (defun warnings-file-p (file &optional implementation-type)
32.5666+ "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
32.5667+If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
32.5668+ (if-let (type (if implementation-type
32.5669+ (warnings-file-type implementation-type)
32.5670+ *warnings-file-type*))
32.5671+ (equal (pathname-type file) type)))
32.5672+
32.5673+ (defun check-deferred-warnings (files &optional context-format context-arguments)
32.5674+ "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
32.5675+re-intern and raise any warnings that are still meaningful."
32.5676+ (let ((file-errors nil)
32.5677+ (failure-p nil)
32.5678+ (warnings-p nil))
32.5679+ (handler-bind
32.5680+ ((warning #'(lambda (c)
32.5681+ (setf warnings-p t)
32.5682+ (unless (typep c 'style-warning)
32.5683+ (setf failure-p t)))))
32.5684+ (with-compilation-unit (:override t)
32.5685+ (reset-deferred-warnings)
32.5686+ (dolist (file files)
32.5687+ (unreify-deferred-warnings
32.5688+ (handler-case
32.5689+ (with-safe-io-syntax ()
32.5690+ (let ((*read-eval* t))
32.5691+ (read-file-form file)))
32.5692+ (error (c)
32.5693+ ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
32.5694+ (push c file-errors)
32.5695+ nil))))))
32.5696+ (dolist (error file-errors) (error error))
32.5697+ (check-lisp-compile-warnings
32.5698+ (or failure-p warnings-p) failure-p context-format context-arguments)))
32.5699+
32.5700+ #|
32.5701+ Mini-guide to adding support for deferred warnings on an implementation.
32.5702+
32.5703+ First, look at what such a warning looks like:
32.5704+
32.5705+ (describe
32.5706+ (handler-case
32.5707+ (and (eval '(lambda () (some-undefined-function))) nil)
32.5708+ (t (c) c)))
32.5709+
32.5710+ Then you can grep for the condition type in your compiler sources
32.5711+ and see how to catch those that have been deferred,
32.5712+ and/or read, clear and restore the deferred list.
32.5713+
32.5714+ Also look at
32.5715+ (macroexpand-1 '(with-compilation-unit () foo))
32.5716+ |#
32.5717+
32.5718+ (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring)
32.5719+ "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
32.5720+and save those warnings to the given file for latter use,
32.5721+possibly in a different process. Otherwise just call THUNK."
32.5722+ (declare (ignorable source-namestring))
32.5723+ (if warnings-file
32.5724+ (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring)
32.5725+ (unwind-protect
32.5726+ (let (#+sbcl (sb-c::*undefined-warnings* nil))
32.5727+ (multiple-value-prog1
32.5728+ (funcall thunk)
32.5729+ (save-deferred-warnings warnings-file)))
32.5730+ (reset-deferred-warnings)))
32.5731+ (funcall thunk)))
32.5732+
32.5733+ (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body)
32.5734+ "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
32.5735+ `(call-with-saved-deferred-warnings
32.5736+ #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring)))
32.5737+
32.5738+
32.5739+;;; from ASDF
32.5740+(with-upgradability ()
32.5741+ (defun current-lisp-file-pathname ()
32.5742+ "Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
32.5743+ (or *compile-file-pathname* *load-pathname*))
32.5744+
32.5745+ (defun load-pathname ()
32.5746+ "Portably return the LOAD-PATHNAME of the current source file or fasl.
32.5747+ May return a relative pathname."
32.5748+ *load-pathname*) ;; magic no longer needed for GCL.
32.5749+
32.5750+ (defun lispize-pathname (input-file)
32.5751+ "From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
32.5752+ (make-pathname :type "lisp" :defaults input-file))
32.5753+
32.5754+ (defun compile-file-type (&rest keys)
32.5755+ "pathname TYPE for lisp FASt Loading files"
32.5756+ (declare (ignorable keys))
32.5757+ #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
32.5758+ #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
32.5759+
32.5760+ (defun call-around-hook (hook function)
32.5761+ "Call a HOOK around the execution of FUNCTION"
32.5762+ (call-function (or hook 'funcall) function))
32.5763+
32.5764+ (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
32.5765+ "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
32.5766+ (let* ((keys
32.5767+ (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format
32.5768+ ,@(unless output-file '(:output-file))) keys)))
32.5769+ (if (absolute-pathname-p output-file)
32.5770+ ;; what cfp should be doing, w/ mp* instead of mp
32.5771+ (let* ((type (pathname-type (apply 'compile-file-type keys)))
32.5772+ (defaults (make-pathname
32.5773+ :type type :defaults (merge-pathnames* input-file))))
32.5774+ (merge-pathnames* output-file defaults))
32.5775+ (funcall *output-translation-function*
32.5776+ (apply 'compile-file-pathname input-file keys)))))
32.5777+
32.5778+ (defvar *compile-check* nil
32.5779+ "A hook for user-defined compile-time invariants")
32.5780+
32.5781+ (defun compile-file* (input-file &rest keys
32.5782+ &key (compile-check *compile-check*) output-file warnings-file
32.5783+ #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl
32.5784+ &allow-other-keys)
32.5785+ "This function provides a portable wrapper around COMPILE-FILE.
32.5786+It ensures that the OUTPUT-FILE value is only returned and
32.5787+the file only actually created if the compilation was successful,
32.5788+even though your implementation may not do that. It also checks an optional
32.5789+user-provided consistency function COMPILE-CHECK to determine success;
32.5790+it will call this function if not NIL at the end of the compilation
32.5791+with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
32.5792+where TMP-FILE is the name of a temporary output-file.
32.5793+It also checks two flags (with legacy british spelling from ASDF1),
32.5794+*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
32.5795+with appropriate implementation-dependent defaults,
32.5796+and if a failure (respectively warnings) are reported by COMPILE-FILE,
32.5797+it will consider that an error unless the respective behaviour flag
32.5798+is one of :SUCCESS :WARN :IGNORE.
32.5799+If WARNINGS-FILE is defined, deferred warnings are saved to that file.
32.5800+On ECL or MKCL, it creates both the linkable object and loadable fasl files.
32.5801+On implementations that erroneously do not recognize standard keyword arguments,
32.5802+it will filter them appropriately."
32.5803+ #+(or clasp ecl)
32.5804+ (when (and object-file (equal (compile-file-type) (pathname object-file)))
32.5805+ (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
32.5806+ 'compile-file* output-file object-file)
32.5807+ (rotatef output-file object-file))
32.5808+ (let* ((keywords (remove-plist-keys
32.5809+ `(:output-file :compile-check :warnings-file
32.5810+ #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys))
32.5811+ (output-file
32.5812+ (or output-file
32.5813+ (apply 'compile-file-pathname* input-file :output-file output-file keywords)))
32.5814+ (physical-output-file (physicalize-pathname output-file))
32.5815+ #+(or clasp ecl)
32.5816+ (object-file
32.5817+ (unless (use-ecl-byte-compiler-p)
32.5818+ (or object-file
32.5819+ #+ecl (compile-file-pathname output-file :type :object)
32.5820+ #+clasp (compile-file-pathname output-file :output-type :object))))
32.5821+ #+mkcl
32.5822+ (object-file
32.5823+ (or object-file
32.5824+ (compile-file-pathname output-file :fasl-p nil)))
32.5825+ (tmp-file (tmpize-pathname physical-output-file))
32.5826+ #+clasp
32.5827+ (tmp-object-file (compile-file-pathname tmp-file :output-type :object))
32.5828+ #+sbcl
32.5829+ (cfasl-file (etypecase emit-cfasl
32.5830+ (null nil)
32.5831+ ((eql t) (make-pathname :type "cfasl" :defaults physical-output-file))
32.5832+ (string (parse-namestring emit-cfasl))
32.5833+ (pathname emit-cfasl)))
32.5834+ #+sbcl
32.5835+ (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
32.5836+ #+clisp
32.5837+ (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
32.5838+ (multiple-value-bind (output-truename warnings-p failure-p)
32.5839+ (with-enough-pathname (input-file :defaults *base-build-directory*)
32.5840+ (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
32.5841+ (with-muffled-compiler-conditions ()
32.5842+ (or #-(or clasp ecl mkcl)
32.5843+ (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t))
32.5844+ (apply 'compile-file input-file :output-file tmp-file
32.5845+ #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
32.5846+ #-sbcl keywords))
32.5847+ #+ecl (apply 'compile-file input-file :output-file
32.5848+ (if object-file
32.5849+ (list* object-file :system-p t keywords)
32.5850+ (list* tmp-file keywords)))
32.5851+ #+clasp (apply 'compile-file input-file :output-file
32.5852+ (if object-file
32.5853+ (list* tmp-object-file :output-type :object #|:system-p t|# keywords)
32.5854+ (list* tmp-file keywords)))
32.5855+ #+mkcl (apply 'compile-file input-file
32.5856+ :output-file object-file :fasl-p nil keywords)))))
32.5857+ (cond
32.5858+ ((and output-truename
32.5859+ (flet ((check-flag (flag behaviour)
32.5860+ (or (not flag) (member behaviour '(:success :warn :ignore)))))
32.5861+ (and (check-flag failure-p *compile-file-failure-behaviour*)
32.5862+ (check-flag warnings-p *compile-file-warnings-behaviour*)))
32.5863+ (progn
32.5864+ #+(or clasp ecl mkcl)
32.5865+ (when (and #+(or clasp ecl) object-file)
32.5866+ (setf output-truename
32.5867+ (compiler::build-fasl tmp-file
32.5868+ #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list #+clasp tmp-object-file #-clasp object-file))))
32.5869+ (or (not compile-check)
32.5870+ (apply compile-check input-file
32.5871+ :output-file output-truename
32.5872+ keywords))))
32.5873+ (delete-file-if-exists physical-output-file)
32.5874+ (when output-truename
32.5875+ ;; see CLISP bug 677
32.5876+ #+clisp
32.5877+ (progn
32.5878+ (setf tmp-lib (make-pathname :type "lib" :defaults output-truename))
32.5879+ (unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file)))
32.5880+ (rename-file-overwriting-target tmp-lib lib-file))
32.5881+ #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
32.5882+ #+clasp
32.5883+ (progn
32.5884+ ;;; the following 4 rename-file-overwriting-target better be atomic, but we can't implement this right now
32.5885+ #+:target-os-darwin
32.5886+ (let ((temp-dwarf (pathname (strcat (namestring output-truename) ".dwarf")))
32.5887+ (target-dwarf (pathname (strcat (namestring physical-output-file) ".dwarf"))))
32.5888+ (when (probe-file temp-dwarf)
32.5889+ (rename-file-overwriting-target temp-dwarf target-dwarf)))
32.5890+ ;;; need to rename the bc or ll file as well or test-bundle.script fails
32.5891+ ;;; They might not exist with parallel compilation
32.5892+ (let ((bitcode-src (compile-file-pathname tmp-file :output-type :bitcode))
32.5893+ (bitcode-target (compile-file-pathname physical-output-file :output-type :bitcode)))
32.5894+ (when (probe-file bitcode-src)
32.5895+ (rename-file-overwriting-target bitcode-src bitcode-target)))
32.5896+ (rename-file-overwriting-target tmp-object-file object-file))
32.5897+ (rename-file-overwriting-target output-truename physical-output-file)
32.5898+ (setf output-truename (truename physical-output-file)))
32.5899+ #+clasp (delete-file-if-exists tmp-file)
32.5900+ #+clisp (progn (delete-file-if-exists tmp-file) ;; this one works around clisp BUG 677
32.5901+ (delete-file-if-exists tmp-lib))) ;; this one is "normal" defensive cleanup
32.5902+ (t ;; error or failed check
32.5903+ (delete-file-if-exists output-truename)
32.5904+ #+clisp (delete-file-if-exists tmp-lib)
32.5905+ #+sbcl (delete-file-if-exists tmp-cfasl)
32.5906+ (setf output-truename nil)))
32.5907+ (values output-truename warnings-p failure-p))))
32.5908+
32.5909+ (defun load* (x &rest keys &key &allow-other-keys)
32.5910+ "Portable wrapper around LOAD that properly handles loading from a stream."
32.5911+ (with-muffled-loader-conditions ()
32.5912+ (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t))
32.5913+ (etypecase x
32.5914+ ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
32.5915+ (apply 'load x keys))
32.5916+ ;; Genera can't load from a string-input-stream
32.5917+ ;; ClozureCL 1.6 can only load from file input stream
32.5918+ ;; Allegro 5, I don't remember but it must have been broken when I tested.
32.5919+ #+(or allegro clozure genera)
32.5920+ (stream ;; make do this way
32.5921+ (let ((*package* *package*)
32.5922+ (*readtable* *readtable*)
32.5923+ (*load-pathname* nil)
32.5924+ (*load-truename* nil))
32.5925+ (eval-input x)))))))
32.5926+
32.5927+ (defun load-from-string (string)
32.5928+ "Portably read and evaluate forms from a STRING."
32.5929+ (with-input-from-string (s string) (load* s))))
32.5930+
32.5931+;;; Links FASLs together
32.5932+(with-upgradability ()
32.5933+ (defun combine-fasls (inputs output)
32.5934+ "Combine a list of FASLs INPUTS into a single FASL OUTPUT"
32.5935+ #-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl)
32.5936+ (not-implemented-error 'combine-fasls "~%inputs: ~S~%output: ~S" inputs output)
32.5937+ #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
32.5938+ #+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output)
32.5939+ #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
32.5940+ #+lispworks
32.5941+ (let (fasls)
32.5942+ (unwind-protect
32.5943+ (progn
32.5944+ (loop :for i :in inputs
32.5945+ :for n :from 1
32.5946+ :for f = (add-pathname-suffix
32.5947+ output (format nil "-FASL~D" n))
32.5948+ :do (copy-file i f)
32.5949+ (push f fasls))
32.5950+ (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
32.5951+ (eval `(scm:defsystem :fasls-to-concatenate
32.5952+ (:default-pathname ,(pathname-directory-pathname output))
32.5953+ :members
32.5954+ ,(loop :for f :in (reverse fasls)
32.5955+ :collect `(,(namestring f) :load-only t))))
32.5956+ (scm:concatenate-system output :fasls-to-concatenate :force t))
32.5957+ (loop :for f :in fasls :do (ignore-errors (delete-file f)))
32.5958+ (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
32.5959+;;;; -------------------------------------------------------------------------
32.5960+;;;; launch-program - semi-portably spawn asynchronous subprocesses
32.5961+
32.5962+(uiop/package:define-package :uiop/launch-program
32.5963+ (:use :uiop/common-lisp :uiop/package :uiop/utility
32.5964+ :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream
32.5965+ :uiop/version)
32.5966+ (:export
32.5967+ ;;; Escaping the command invocation madness
32.5968+ #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
32.5969+ #:escape-windows-token #:escape-windows-command
32.5970+ #:escape-shell-token #:escape-shell-command
32.5971+ #:escape-token #:escape-command
32.5972+
32.5973+ ;;; launch-program
32.5974+ #:launch-program
32.5975+ #:close-streams #:process-alive-p #:terminate-process #:wait-process
32.5976+ #:process-info
32.5977+ #:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid))
32.5978+(in-package :uiop/launch-program)
32.5979+
32.5980+;;;; ----- Escaping strings for the shell -----
32.5981+(with-upgradability ()
32.5982+ (defun requires-escaping-p (token &key good-chars bad-chars)
32.5983+ "Does this token require escaping, given the specification of
32.5984+either good chars that don't need escaping or bad chars that do need escaping,
32.5985+as either a recognizing function or a sequence of characters."
32.5986+ (some
32.5987+ (cond
32.5988+ ((and good-chars bad-chars)
32.5989+ (parameter-error "~S: only one of good-chars and bad-chars can be provided"
32.5990+ 'requires-escaping-p))
32.5991+ ((typep good-chars 'function)
32.5992+ (complement good-chars))
32.5993+ ((typep bad-chars 'function)
32.5994+ bad-chars)
32.5995+ ((and good-chars (typep good-chars 'sequence))
32.5996+ #'(lambda (c) (not (find c good-chars))))
32.5997+ ((and bad-chars (typep bad-chars 'sequence))
32.5998+ #'(lambda (c) (find c bad-chars)))
32.5999+ (t (parameter-error "~S: no good-char criterion" 'requires-escaping-p)))
32.6000+ token))
32.6001+
32.6002+ (defun escape-token (token &key stream quote good-chars bad-chars escaper)
32.6003+ "Call the ESCAPER function on TOKEN string if it needs escaping as per
32.6004+REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
32.6005+using STREAM as output (or returning result as a string if NIL)"
32.6006+ (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
32.6007+ (with-output (stream)
32.6008+ (apply escaper token stream (when quote `(:quote ,quote))))
32.6009+ (output-string token stream)))
32.6010+
32.6011+ (defun escape-windows-token-within-double-quotes (x &optional s)
32.6012+ "Escape a string token X within double-quotes
32.6013+for use within a MS Windows command-line, outputing to S."
32.6014+ (labels ((issue (c) (princ c s))
32.6015+ (issue-backslash (n) (loop :repeat n :do (issue #\\))))
32.6016+ (loop
32.6017+ :initially (issue #\") :finally (issue #\")
32.6018+ :with l = (length x) :with i = 0
32.6019+ :for i+1 = (1+ i) :while (< i l) :do
32.6020+ (case (char x i)
32.6021+ ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
32.6022+ ((#\\)
32.6023+ (let* ((j (and (< i+1 l) (position-if-not
32.6024+ #'(lambda (c) (eql c #\\)) x :start i+1)))
32.6025+ (n (- (or j l) i)))
32.6026+ (cond
32.6027+ ((null j)
32.6028+ (issue-backslash (* 2 n)) (setf i l))
32.6029+ ((and (< j l) (eql (char x j) #\"))
32.6030+ (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
32.6031+ (t
32.6032+ (issue-backslash n) (setf i j)))))
32.6033+ (otherwise
32.6034+ (issue (char x i)) (setf i i+1))))))
32.6035+
32.6036+ (defun easy-windows-character-p (x)
32.6037+ "Is X an \"easy\" character that does not require quoting by the shell?"
32.6038+ (or (alphanumericp x) (find x "+-_.,@:/=")))
32.6039+
32.6040+ (defun escape-windows-token (token &optional s)
32.6041+ "Escape a string TOKEN within double-quotes if needed
32.6042+for use within a MS Windows command-line, outputing to S."
32.6043+ (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
32.6044+ :escaper 'escape-windows-token-within-double-quotes))
32.6045+
32.6046+ (defun escape-sh-token-within-double-quotes (x s &key (quote t))
32.6047+ "Escape a string TOKEN within double-quotes
32.6048+for use within a POSIX Bourne shell, outputing to S;
32.6049+omit the outer double-quotes if key argument :QUOTE is NIL"
32.6050+ (when quote (princ #\" s))
32.6051+ (loop :for c :across x :do
32.6052+ (when (find c "$`\\\"") (princ #\\ s))
32.6053+ (princ c s))
32.6054+ (when quote (princ #\" s)))
32.6055+
32.6056+ (defun easy-sh-character-p (x)
32.6057+ "Is X an \"easy\" character that does not require quoting by the shell?"
32.6058+ (or (alphanumericp x) (find x "+-_.,%@:/=")))
32.6059+
32.6060+ (defun escape-sh-token (token &optional s)
32.6061+ "Escape a string TOKEN within double-quotes if needed
32.6062+for use within a POSIX Bourne shell, outputing to S."
32.6063+ (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p
32.6064+ :escaper 'escape-sh-token-within-double-quotes))
32.6065+
32.6066+ (defun escape-shell-token (token &optional s)
32.6067+ "Escape a token for the current operating system shell"
32.6068+ (os-cond
32.6069+ ((os-unix-p) (escape-sh-token token s))
32.6070+ ((os-windows-p) (escape-windows-token token s))))
32.6071+
32.6072+ (defun escape-command (command &optional s
32.6073+ (escaper 'escape-shell-token))
32.6074+ "Given a COMMAND as a list of tokens, return a string of the
32.6075+spaced, escaped tokens, using ESCAPER to escape."
32.6076+ (etypecase command
32.6077+ (string (output-string command s))
32.6078+ (list (with-output (s)
32.6079+ (loop :for first = t :then nil :for token :in command :do
32.6080+ (unless first (princ #\space s))
32.6081+ (funcall escaper token s))))))
32.6082+
32.6083+ (defun escape-windows-command (command &optional s)
32.6084+ "Escape a list of command-line arguments into a string suitable for parsing
32.6085+by CommandLineToArgv in MS Windows"
32.6086+ ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
32.6087+ ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
32.6088+ (escape-command command s 'escape-windows-token))
32.6089+
32.6090+ (defun escape-sh-command (command &optional s)
32.6091+ "Escape a list of command-line arguments into a string suitable for parsing
32.6092+by /bin/sh in POSIX"
32.6093+ (escape-command command s 'escape-sh-token))
32.6094+
32.6095+ (defun escape-shell-command (command &optional stream)
32.6096+ "Escape a command for the current operating system's shell"
32.6097+ (escape-command command stream 'escape-shell-token)))
32.6098+
32.6099+
32.6100+(with-upgradability ()
32.6101+ ;;; Internal helpers for run-program
32.6102+ (defun %normalize-io-specifier (specifier &optional role)
32.6103+ "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent
32.6104+argument to pass to the internal RUN-PROGRAM"
32.6105+ (declare (ignorable role))
32.6106+ (typecase specifier
32.6107+ (null (or #+(or allegro lispworks) (null-device-pathname)))
32.6108+ (string (parse-native-namestring specifier))
32.6109+ (pathname specifier)
32.6110+ (stream specifier)
32.6111+ ((eql :stream) :stream)
32.6112+ ((eql :interactive)
32.6113+ #+(or allegro lispworks) nil
32.6114+ #+clisp :terminal
32.6115+ #+(or abcl clasp clozure cmucl ecl mkcl sbcl scl) t
32.6116+ #-(or abcl clasp clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp)
32.6117+ (not-implemented-error :interactive-output
32.6118+ "On this lisp implementation, cannot interpret ~a value of ~a"
32.6119+ specifier role))
32.6120+ ((eql :output)
32.6121+ (cond ((eq role :error-output)
32.6122+ #+(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
32.6123+ :output
32.6124+ #-(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
32.6125+ (not-implemented-error :error-output-redirect
32.6126+ "Can't send ~a to ~a on this lisp implementation."
32.6127+ role specifier))
32.6128+ (t (parameter-error "~S IO specifier invalid for ~S" specifier role))))
32.6129+ ((eql t)
32.6130+ #+ (or lispworks abcl)
32.6131+ (not-implemented-error :interactive-output
32.6132+ "On this lisp implementation, cannot interpret ~a value of ~a"
32.6133+ specifier role)
32.6134+ #- (or lispworks abcl)
32.6135+ (cond ((eq role :error-output) *error-output*)
32.6136+ ((eq role :output) #+lispworks *terminal-io* #-lispworks *standard-output*)
32.6137+ ((eq role :input) *standard-input*)))
32.6138+ (otherwise
32.6139+ (parameter-error "Incorrect I/O specifier ~S for ~S"
32.6140+ specifier role))))
32.6141+
32.6142+ (defun %interactivep (input output error-output)
32.6143+ (member :interactive (list input output error-output)))
32.6144+
32.6145+ (defun %signal-to-exit-code (signum)
32.6146+ (+ 128 signum))
32.6147+
32.6148+ (defun %code-to-status (exit-code signal-code)
32.6149+ (cond ((null exit-code) :running)
32.6150+ ((null signal-code) (values :exited exit-code))
32.6151+ (t (values :signaled signal-code))))
32.6152+
32.6153+ #+mkcl
32.6154+ (defun %mkcl-signal-to-number (signal)
32.6155+ (require :mk-unix)
32.6156+ (symbol-value (find-symbol signal :mk-unix)))
32.6157+
32.6158+ (defclass process-info ()
32.6159+ (;; The process field is highly platform-, implementation-, and
32.6160+ ;; even version-dependent.
32.6161+ ;; Prior to LispWorks 7, the only information that
32.6162+ ;; `sys:run-shell-command` with `:wait nil` was certain to return
32.6163+ ;; is a PID (e.g. when all streams are nil), hence we stored it
32.6164+ ;; and used `sys:pid-exit-status` to obtain an exit status
32.6165+ ;; later. That is still what we do.
32.6166+ ;; From LispWorks 7 on, if `sys:run-shell-command` does not
32.6167+ ;; return a proper stream, we are instead given a dummy stream.
32.6168+ ;; We can thus always store a stream and use
32.6169+ ;; `sys:pipe-exit-status` to obtain an exit status later.
32.6170+ ;; The advantage of dealing with streams instead of PID is the
32.6171+ ;; availability of functions like `sys:pipe-kill-process`.
32.6172+ (process :initform nil)
32.6173+ (input-stream :initform nil)
32.6174+ (output-stream :initform nil)
32.6175+ (bidir-stream :initform nil)
32.6176+ (error-output-stream :initform nil)
32.6177+ ;; For backward-compatibility, to maintain the property (zerop
32.6178+ ;; exit-code) <-> success, an exit in response to a signal is
32.6179+ ;; encoded as 128+signum.
32.6180+ (exit-code :initform nil)
32.6181+ ;; If the platform allows it, distinguish exiting with a code
32.6182+ ;; >128 from exiting in response to a signal by setting this code
32.6183+ (signal-code :initform nil))
32.6184+ (:documentation "This class should be treated as opaque by programmers, except for the
32.6185+exported PROCESS-INFO-* functions. It should never be directly instantiated by
32.6186+MAKE-INSTANCE. Primarily, it is being made available to enable type-checking."))
32.6187+
32.6188+;;;---------------------------------------------------------------------------
32.6189+;;; The following two helper functions take care of handling the IF-EXISTS and
32.6190+;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the
32.6191+;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master
32.6192+;;; function to treat input and output files unconditionally for reading and
32.6193+;;; writing.
32.6194+;;;---------------------------------------------------------------------------
32.6195+
32.6196+ (defun %handle-if-exists (file if-exists)
32.6197+ (when (or (stringp file) (pathnamep file))
32.6198+ (ecase if-exists
32.6199+ ((:append :supersede :error)
32.6200+ (with-open-file (dummy file :direction :output :if-exists if-exists)
32.6201+ (declare (ignorable dummy)))))))
32.6202+
32.6203+ (defun %handle-if-does-not-exist (file if-does-not-exist)
32.6204+ (when (or (stringp file) (pathnamep file))
32.6205+ (ecase if-does-not-exist
32.6206+ ((:create :error)
32.6207+ (with-open-file (dummy file :direction :probe
32.6208+ :if-does-not-exist if-does-not-exist)
32.6209+ (declare (ignorable dummy)))))))
32.6210+
32.6211+ (defun process-info-error-output (process-info)
32.6212+ (slot-value process-info 'error-output-stream))
32.6213+ (defun process-info-input (process-info)
32.6214+ (or (slot-value process-info 'bidir-stream)
32.6215+ (slot-value process-info 'input-stream)))
32.6216+ (defun process-info-output (process-info)
32.6217+ (or (slot-value process-info 'bidir-stream)
32.6218+ (slot-value process-info 'output-stream)))
32.6219+
32.6220+ (defun process-info-pid (process-info)
32.6221+ (let ((process (slot-value process-info 'process)))
32.6222+ (declare (ignorable process))
32.6223+ #+abcl (symbol-call :sys :process-pid process)
32.6224+ #+allegro process
32.6225+ #+clasp (if (find-symbol* '#:external-process-pid :ext nil)
32.6226+ (symbol-call :ext '#:external-process-pid process)
32.6227+ (not-implemented-error 'process-info-pid))
32.6228+ #+clozure (ccl:external-process-id process)
32.6229+ #+ecl (ext:external-process-pid process)
32.6230+ #+(or cmucl scl) (ext:process-pid process)
32.6231+ #+lispworks7+ (sys:pipe-pid process)
32.6232+ #+(and lispworks (not lispworks7+)) process
32.6233+ #+mkcl (mkcl:process-id process)
32.6234+ #+sbcl (sb-ext:process-pid process)
32.6235+ #-(or abcl allegro clasp clozure cmucl ecl mkcl lispworks sbcl scl)
32.6236+ (not-implemented-error 'process-info-pid)))
32.6237+
32.6238+ (defun %process-status (process-info)
32.6239+ (if-let (exit-code (slot-value process-info 'exit-code))
32.6240+ (return-from %process-status
32.6241+ (if-let (signal-code (slot-value process-info 'signal-code))
32.6242+ (values :signaled signal-code)
32.6243+ (values :exited exit-code))))
32.6244+ #-(or allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
32.6245+ (not-implemented-error '%process-status)
32.6246+ (if-let (process (slot-value process-info 'process))
32.6247+ (multiple-value-bind (status code)
32.6248+ (progn
32.6249+ #+allegro (multiple-value-bind (exit-code pid signal-code)
32.6250+ (sys:reap-os-subprocess :pid process :wait nil)
32.6251+ (assert pid)
32.6252+ (%code-to-status exit-code signal-code))
32.6253+ #+clasp (if (find-symbol* '#:external-process-status :ext nil)
32.6254+ (symbol-call :ext '#:external-process-status process)
32.6255+ (not-implemented-error '%process-status))
32.6256+ #+clozure (ccl:external-process-status process)
32.6257+ #+(or cmucl scl) (let ((status (ext:process-status process)))
32.6258+ (if (member status '(:exited :signaled))
32.6259+ ;; Calling ext:process-exit-code on
32.6260+ ;; processes that are still alive
32.6261+ ;; yields an undefined result
32.6262+ (values status (ext:process-exit-code process))
32.6263+ status))
32.6264+ #+ecl (ext:external-process-status process)
32.6265+ #+lispworks
32.6266+ ;; a signal is only returned on LispWorks 7+
32.6267+ (multiple-value-bind (exit-code signal-code)
32.6268+ (symbol-call :sys
32.6269+ #+lispworks7+ :pipe-exit-status
32.6270+ #-lispworks7+ :pid-exit-status
32.6271+ process :wait nil)
32.6272+ (%code-to-status exit-code signal-code))
32.6273+ #+mkcl (let ((status (mk-ext:process-status process)))
32.6274+ (if (eq status :exited)
32.6275+ ;; Only call mk-ext:process-exit-code when
32.6276+ ;; necessary since it leads to another waitpid()
32.6277+ (let ((code (mk-ext:process-exit-code process)))
32.6278+ (if (stringp code)
32.6279+ (values :signaled (%mkcl-signal-to-number code))
32.6280+ (values :exited code)))
32.6281+ status))
32.6282+ #+sbcl (let ((status (sb-ext:process-status process)))
32.6283+ (if (eq status :running)
32.6284+ :running
32.6285+ ;; sb-ext:process-exit-code can also be
32.6286+ ;; called for stopped processes to determine
32.6287+ ;; the signal that stopped them
32.6288+ (values status (sb-ext:process-exit-code process)))))
32.6289+ (case status
32.6290+ (:exited (setf (slot-value process-info 'exit-code) code))
32.6291+ (:signaled (let ((%code (%signal-to-exit-code code)))
32.6292+ (setf (slot-value process-info 'exit-code) %code
32.6293+ (slot-value process-info 'signal-code) code))))
32.6294+ (if code
32.6295+ (values status code)
32.6296+ status))))
32.6297+
32.6298+ (defun process-alive-p (process-info)
32.6299+ "Check if a process has yet to exit."
32.6300+ (unless (slot-value process-info 'exit-code)
32.6301+ #+abcl (sys:process-alive-p (slot-value process-info 'process))
32.6302+ #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
32.6303+ #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
32.6304+ #-(or abcl cmucl sbcl scl) (find (%process-status process-info)
32.6305+ '(:running :stopped :continued :resumed))))
32.6306+
32.6307+ (defun wait-process (process-info)
32.6308+ "Wait for the process to terminate, if it is still running.
32.6309+Otherwise, return immediately. An exit code (a number) will be
32.6310+returned, with 0 indicating success, and anything else indicating
32.6311+failure. If the process exits after receiving a signal, the exit code
32.6312+will be the sum of 128 and the (positive) numeric signal code. A second
32.6313+value may be returned in this case: the numeric signal code itself.
32.6314+Any asynchronously spawned process requires this function to be run
32.6315+before it is garbage-collected in order to free up resources that
32.6316+might otherwise be irrevocably lost."
32.6317+ (if-let (exit-code (slot-value process-info 'exit-code))
32.6318+ (if-let (signal-code (slot-value process-info 'signal-code))
32.6319+ (values exit-code signal-code)
32.6320+ exit-code)
32.6321+ (let ((process (slot-value process-info 'process)))
32.6322+ #-(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
32.6323+ (not-implemented-error 'wait-process)
32.6324+ (when process
32.6325+ ;; 1- wait
32.6326+ #+clozure (ccl::external-process-wait process)
32.6327+ #+(or cmucl scl) (ext:process-wait process)
32.6328+ #+sbcl (sb-ext:process-wait process)
32.6329+ ;; 2- extract result
32.6330+ (multiple-value-bind (exit-code signal-code)
32.6331+ (progn
32.6332+ #+abcl (sys:process-wait process)
32.6333+ #+allegro (multiple-value-bind (exit-code pid signal)
32.6334+ (sys:reap-os-subprocess :pid process :wait t)
32.6335+ (assert pid)
32.6336+ (values exit-code signal))
32.6337+ #+clasp (if (find-symbol* '#:external-process-wait :ext nil)
32.6338+ (multiple-value-bind (status code)
32.6339+ (symbol-call :ext '#:external-process-wait process t)
32.6340+ (if (eq status :signaled)
32.6341+ (values nil code)
32.6342+ code))
32.6343+ (not-implemented-error 'wait-process))
32.6344+ #+clozure (multiple-value-bind (status code)
32.6345+ (ccl:external-process-status process)
32.6346+ (if (eq status :signaled)
32.6347+ (values nil code)
32.6348+ code))
32.6349+ #+(or cmucl scl) (let ((status (ext:process-status process))
32.6350+ (code (ext:process-exit-code process)))
32.6351+ (if (eq status :signaled)
32.6352+ (values nil code)
32.6353+ code))
32.6354+ #+ecl (multiple-value-bind (status code)
32.6355+ (ext:external-process-wait process t)
32.6356+ (if (eq status :signaled)
32.6357+ (values nil code)
32.6358+ code))
32.6359+ #+lispworks (symbol-call :sys
32.6360+ #+lispworks7+ :pipe-exit-status
32.6361+ #-lispworks7+ :pid-exit-status
32.6362+ process :wait t)
32.6363+ #+mkcl (let ((code (mkcl:join-process process)))
32.6364+ (if (stringp code)
32.6365+ (values nil (%mkcl-signal-to-number code))
32.6366+ code))
32.6367+ #+sbcl (let ((status (sb-ext:process-status process))
32.6368+ (code (sb-ext:process-exit-code process)))
32.6369+ (if (eq status :signaled)
32.6370+ (values nil code)
32.6371+ code)))
32.6372+ (if signal-code
32.6373+ (let ((%exit-code (%signal-to-exit-code signal-code)))
32.6374+ (setf (slot-value process-info 'exit-code) %exit-code
32.6375+ (slot-value process-info 'signal-code) signal-code)
32.6376+ (values %exit-code signal-code))
32.6377+ (progn (setf (slot-value process-info 'exit-code) exit-code)
32.6378+ exit-code)))))))
32.6379+
32.6380+ ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
32.6381+ ;; do what you expect it to. Sending SIGSTOP to a process spawned
32.6382+ ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
32.6383+ ;; to run the command (via `sh -c command`) but not the actual
32.6384+ ;; command.
32.6385+ #+os-unix
32.6386+ (defun %posix-send-signal (process-info signal)
32.6387+ #+allegro (excl.osi:kill (slot-value process-info 'process) signal)
32.6388+ #+clozure (ccl:signal-external-process (slot-value process-info 'process)
32.6389+ signal :error-if-exited nil)
32.6390+ #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
32.6391+ #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
32.6392+ #-(or allegro clozure cmucl sbcl scl)
32.6393+ (if-let (pid (process-info-pid process-info))
32.6394+ (symbol-call :uiop :run-program
32.6395+ (format nil "kill -~a ~a" signal pid) :ignore-error-status t)))
32.6396+
32.6397+ ;;; this function never gets called on Windows, but the compiler cannot tell
32.6398+ ;;; that. [2016/09/25:rpg]
32.6399+ #+os-windows
32.6400+ (defun %posix-send-signal (process-info signal)
32.6401+ (declare (ignore process-info signal))
32.6402+ (values))
32.6403+
32.6404+ (defun terminate-process (process-info &key urgent)
32.6405+ "Cause the process to exit. To that end, the process may or may
32.6406+not be sent a signal, which it will find harder (or even impossible)
32.6407+to ignore if URGENT is T. On some platforms, it may also be subject to
32.6408+race conditions."
32.6409+ (declare (ignorable urgent))
32.6410+ #+abcl (sys:process-kill (slot-value process-info 'process))
32.6411+ ;; On ECL, this will only work on versions later than 2016-09-06,
32.6412+ ;; but we still want to compile on earlier versions, so we use symbol-call
32.6413+ #+(or clasp ecl) (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent)
32.6414+ #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
32.6415+ #+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
32.6416+ :force urgent)
32.6417+ #-(or abcl clasp ecl lispworks7+ mkcl)
32.6418+ (os-cond
32.6419+ ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
32.6420+ ((os-windows-p) (if-let (pid (process-info-pid process-info))
32.6421+ (symbol-call :uiop :run-program
32.6422+ (format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid)
32.6423+ :ignore-error-status t)))
32.6424+ (t (not-implemented-error 'terminate-process))))
32.6425+
32.6426+ (defun close-streams (process-info)
32.6427+ "Close any stream that the process might own. Needs to be run
32.6428+whenever streams were requested by passing :stream to :input, :output,
32.6429+or :error-output."
32.6430+ (dolist (stream
32.6431+ (cons (slot-value process-info 'error-output-stream)
32.6432+ (if-let (bidir-stream (slot-value process-info 'bidir-stream))
32.6433+ (list bidir-stream)
32.6434+ (list (slot-value process-info 'input-stream)
32.6435+ (slot-value process-info 'output-stream)))))
32.6436+ (when stream (close stream))))
32.6437+
32.6438+ (defun launch-program (command &rest keys
32.6439+ &key
32.6440+ input (if-input-does-not-exist :error)
32.6441+ output (if-output-exists :supersede)
32.6442+ error-output (if-error-output-exists :supersede)
32.6443+ (element-type #-clozure *default-stream-element-type*
32.6444+ #+clozure 'character)
32.6445+ (external-format *utf-8-external-format*)
32.6446+ directory
32.6447+ #+allegro separate-streams
32.6448+ &allow-other-keys)
32.6449+ "Launch program specified by COMMAND,
32.6450+either a list of strings specifying a program and list of arguments,
32.6451+or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
32.6452+Windows) _asynchronously_.
32.6453+
32.6454+If OUTPUT is a pathname, a string designating a pathname, or NIL (the
32.6455+default) designating the null device, the file at that path is used as
32.6456+output.
32.6457+If it's :INTERACTIVE, output is inherited from the current process;
32.6458+beware that this may be different from your *STANDARD-OUTPUT*, and
32.6459+under SLIME will be on your *inferior-lisp* buffer. If it's T, output
32.6460+goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new
32.6461+stream will be made available that can be accessed via
32.6462+PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
32.6463+that the underlying lisp implementation knows how to handle.
32.6464+
32.6465+IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
32.6466+pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
32.6467+default). The meaning of these values and their effect on the case
32.6468+where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
32.6469+to OPEN with :DIRECTION :OUTPUT.
32.6470+
32.6471+ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
32.6472+:OUTPUT means redirecting the error output to the output stream,
32.6473+and :STREAM causes a stream to be made available via
32.6474+PROCESS-INFO-ERROR-OUTPUT.
32.6475+
32.6476+IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
32.6477+affects ERROR-OUTPUT rather than OUTPUT.
32.6478+
32.6479+INPUT is similar to OUTPUT, except that T designates the
32.6480+*STANDARD-INPUT* and a stream requested through the :STREAM keyword
32.6481+would be available through PROCESS-INFO-INPUT.
32.6482+
32.6483+IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
32.6484+or a pathname, can take the values :CREATE and :ERROR (the
32.6485+default). The meaning of these values is analogous to the
32.6486+IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
32.6487+
32.6488+ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp
32.6489+implementation, when applicable, for creation of the output stream.
32.6490+
32.6491+LAUNCH-PROGRAM returns a PROCESS-INFO object.
32.6492+
32.6493+LAUNCH-PROGRAM currently does not smooth over all the differences between
32.6494+implementations. Of particular note is when streams are provided for OUTPUT or
32.6495+ERROR-OUTPUT. Some implementations don't support this at all, some support only
32.6496+certain subclasses of streams, and some support any arbitrary
32.6497+stream. Additionally, the implementations that support streams may have
32.6498+differing behavior on how those streams are filled with data. If data is not
32.6499+periodically read from the child process and sent to the stream, the child
32.6500+could block because its output buffers are full."
32.6501+ #-(or abcl allegro clasp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
32.6502+ (progn command keys input output error-output directory element-type external-format
32.6503+ if-input-does-not-exist if-output-exists if-error-output-exists ;; ignore
32.6504+ (not-implemented-error 'launch-program))
32.6505+ #+allegro
32.6506+ (when (some #'(lambda (stream)
32.6507+ (and (streamp stream)
32.6508+ (not (file-stream-p stream))))
32.6509+ (list input output error-output))
32.6510+ (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp"
32.6511+ 'launch-program))
32.6512+ #+(or abcl clisp lispworks)
32.6513+ (when (some #'streamp (list input output error-output))
32.6514+ (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
32.6515+ 'launch-program))
32.6516+ #+clisp
32.6517+ (unless (eq error-output :interactive)
32.6518+ (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
32.6519+ 'launch-program :error-output :interactive))
32.6520+ #+(or clasp ecl)
32.6521+ (when (and #+ecl (version< (lisp-implementation-version) "20.4.24")
32.6522+ (some #'(lambda (stream)
32.6523+ (and (streamp stream)
32.6524+ (not (file-or-synonym-stream-p stream))))
32.6525+ (list input output error-output)))
32.6526+ (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
32.6527+ 'launch-program))
32.6528+ #+(or abcl allegro clasp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
32.6529+ (nest
32.6530+ (progn ;; see comments for these functions
32.6531+ (%handle-if-does-not-exist input if-input-does-not-exist)
32.6532+ (%handle-if-exists output if-output-exists)
32.6533+ (%handle-if-exists error-output if-error-output-exists))
32.6534+ #+(or clasp ecl) (let ((*standard-input* *stdin*)
32.6535+ (*standard-output* *stdout*)
32.6536+ (*error-output* *stderr*)))
32.6537+ (let ((process-info (make-instance 'process-info))
32.6538+ (input (%normalize-io-specifier input :input))
32.6539+ (output (%normalize-io-specifier output :output))
32.6540+ (error-output (%normalize-io-specifier error-output :error-output))
32.6541+ #+(and allegro os-windows) (interactive (%interactivep input output error-output))
32.6542+ (command
32.6543+ (etypecase command
32.6544+ #+os-unix (string `("/bin/sh" "-c" ,command))
32.6545+ #+os-unix (list command)
32.6546+ #+os-windows
32.6547+ (string
32.6548+ ;; NB: On other Windows implementations, this is utterly bogus
32.6549+ ;; except in the most trivial cases where no quoting is needed.
32.6550+ ;; Use at your own risk.
32.6551+ #-(or allegro clasp clisp clozure ecl)
32.6552+ (nest
32.6553+ #+(or clasp ecl sbcl) (unless (find-symbol* :escape-arguments #+(or clasp ecl) :ext #+sbcl :sb-impl nil))
32.6554+ (parameter-error "~S doesn't support string commands on Windows on this Lisp"
32.6555+ 'launch-program command))
32.6556+ ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
32.6557+ ;; when the command contains spaces or special characters:
32.6558+ ;; IIUC, the system will use space as a separator,
32.6559+ ;; but the C++ argv-decoding libraries won't, and
32.6560+ ;; you're supposed to use an extra argument to CreateProcess to bridge the gap,
32.6561+ ;; yet neither allegro nor clisp provide access to that argument.
32.6562+ #+(or allegro clisp) (strcat "cmd /c " command)
32.6563+ ;; On ClozureCL for Windows, we assume you are using
32.6564+ ;; r15398 or later in 1.9 or later,
32.6565+ ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
32.6566+ ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304
32.6567+ ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13)
32.6568+ #+(or clasp clozure ecl sbcl) (cons "cmd" (strcat "/c " command)))
32.6569+ #+os-windows
32.6570+ (list
32.6571+ #+allegro (escape-windows-command command)
32.6572+ #-allegro command)))))
32.6573+ #+(or abcl (and allegro os-unix) clasp clozure cmucl ecl mkcl sbcl)
32.6574+ (let ((program (car command))
32.6575+ #-allegro (arguments (cdr command))))
32.6576+ #+(and (or clasp ecl sbcl) os-windows)
32.6577+ (multiple-value-bind (arguments escape-arguments)
32.6578+ (if (listp arguments)
32.6579+ (values arguments t)
32.6580+ (values (list arguments) nil)))
32.6581+ #-(or allegro mkcl sbcl) (with-current-directory (directory))
32.6582+ (multiple-value-bind
32.6583+ #+(or abcl clozure cmucl sbcl scl) (process)
32.6584+ #+allegro (in-or-io out-or-err err-or-pid pid-or-nil)
32.6585+ #+(or clasp ecl) (stream code process)
32.6586+ #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil)
32.6587+ #+mkcl (stream process code)
32.6588+ #.`(apply
32.6589+ #+abcl 'sys:run-program
32.6590+ #+allegro ,@'('excl:run-shell-command
32.6591+ #+os-unix (coerce (cons program command) 'vector)
32.6592+ #+os-windows command)
32.6593+ #+clasp (if (find-symbol* '#:run-program :ext nil)
32.6594+ (find-symbol* '#:run-program :ext nil)
32.6595+ (not-implemented-error 'launch-program))
32.6596+ #+clozure 'ccl:run-program
32.6597+ #+(or cmucl ecl scl) 'ext:run-program
32.6598+
32.6599+ #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed
32.6600+ #+mkcl 'mk-ext:run-program
32.6601+ #+sbcl 'sb-ext:run-program
32.6602+ #+(or abcl clasp clozure cmucl ecl mkcl sbcl) ,@'(program arguments)
32.6603+ #+(and (or clasp ecl sbcl) os-windows) ,@'(:escape-arguments escape-arguments)
32.6604+ :input input :if-input-does-not-exist :error
32.6605+ :output output :if-output-exists :append
32.6606+ ,(or #+(or allegro lispworks) :error-output :error) error-output
32.6607+ ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append
32.6608+ :wait nil :element-type element-type :external-format external-format
32.6609+ :allow-other-keys t
32.6610+ #+allegro ,@`(:directory directory
32.6611+ #+os-windows ,@'(:show-window (if interactive nil :hide)))
32.6612+ #+lispworks ,@'(:save-exit-status t)
32.6613+ #+mkcl ,@'(:directory (native-namestring directory))
32.6614+ #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys
32.6615+ #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys)))))
32.6616+ (labels ((prop (key value) (setf (slot-value process-info key) value)))
32.6617+ #+allegro
32.6618+ (cond
32.6619+ (separate-streams
32.6620+ (prop 'process pid-or-nil)
32.6621+ (when (eq input :stream) (prop 'input-stream in-or-io))
32.6622+ (when (eq output :stream) (prop 'output-stream out-or-err))
32.6623+ (when (eq error-output :stream) (prop 'error-output-stream err-or-pid)))
32.6624+ (t
32.6625+ (prop 'process err-or-pid)
32.6626+ (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
32.6627+ (0)
32.6628+ (1 (prop 'input-stream in-or-io))
32.6629+ (2 (prop 'output-stream in-or-io))
32.6630+ (3 (prop 'bidir-stream in-or-io)))
32.6631+ (when (eq error-output :stream)
32.6632+ (prop 'error-output-stream out-or-err))))
32.6633+ #+(or abcl clozure cmucl sbcl scl)
32.6634+ (progn
32.6635+ (prop 'process process)
32.6636+ (when (eq input :stream)
32.6637+ (nest
32.6638+ (prop 'input-stream)
32.6639+ #+abcl (symbol-call :sys :process-input)
32.6640+ #+clozure (ccl:external-process-input-stream)
32.6641+ #+(or cmucl scl) (ext:process-input)
32.6642+ #+sbcl (sb-ext:process-input)
32.6643+ process))
32.6644+ (when (eq output :stream)
32.6645+ (nest
32.6646+ (prop 'output-stream)
32.6647+ #+abcl (symbol-call :sys :process-output)
32.6648+ #+clozure (ccl:external-process-output-stream)
32.6649+ #+(or cmucl scl) (ext:process-output)
32.6650+ #+sbcl (sb-ext:process-output)
32.6651+ process))
32.6652+ (when (eq error-output :stream)
32.6653+ (nest
32.6654+ (prop 'error-output-stream)
32.6655+ #+abcl (symbol-call :sys :process-error)
32.6656+ #+clozure (ccl:external-process-error-stream)
32.6657+ #+(or cmucl scl) (ext:process-error)
32.6658+ #+sbcl (sb-ext:process-error)
32.6659+ process)))
32.6660+ #+(or clasp ecl mkcl)
32.6661+ (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
32.6662+ code ;; ignore
32.6663+ (unless (zerop mode)
32.6664+ (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))
32.6665+ (when (eq error-output :stream)
32.6666+ (prop 'error-output-stream
32.6667+ (if (and #+clasp nil #-clasp t (version< (lisp-implementation-version) "16.0.0"))
32.6668+ (symbol-call :ext :external-process-error process)
32.6669+ (symbol-call :ext :external-process-error-stream process))))
32.6670+ (prop 'process process))
32.6671+ #+lispworks
32.6672+ ;; See also the comments on the process-info class
32.6673+ (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
32.6674+ (cond
32.6675+ ((or (plusp mode) (eq error-output :stream))
32.6676+ (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-nil)
32.6677+ (when (plusp mode)
32.6678+ (prop (ecase mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream))
32.6679+ io-or-pid))
32.6680+ (when (eq error-output :stream)
32.6681+ (prop 'error-output-stream err-or-nil)))
32.6682+ ;; Prior to Lispworks 7, this returned (pid); now it
32.6683+ ;; returns (io err pid) of which we keep io.
32.6684+ (t (prop 'process io-or-pid)))))
32.6685+ process-info)))
32.6686+
32.6687+;;;; -------------------------------------------------------------------------
32.6688+;;;; run-program initially from xcvb-driver.
32.6689+
32.6690+(uiop/package:define-package :uiop/run-program
32.6691+ (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv.
32.6692+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version
32.6693+ :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program)
32.6694+ (:export
32.6695+ #:run-program
32.6696+ #:slurp-input-stream #:vomit-output-stream
32.6697+ #:subprocess-error
32.6698+ #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process)
32.6699+ (:import-from :uiop/launch-program
32.6700+ #:%handle-if-does-not-exist #:%handle-if-exists #:%interactivep
32.6701+ #:input-stream #:output-stream #:error-output-stream))
32.6702+(in-package :uiop/run-program)
32.6703+
32.6704+;;;; Slurping a stream, typically the output of another program
32.6705+(with-upgradability ()
32.6706+ (defun call-stream-processor (fun processor stream)
32.6707+ "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
32.6708+a PROCESSOR specification which is either an atom or a list specifying
32.6709+a processor an keyword arguments, call the specified processor with
32.6710+the given STREAM as input"
32.6711+ (if (consp processor)
32.6712+ (apply fun (first processor) stream (rest processor))
32.6713+ (funcall fun processor stream)))
32.6714+
32.6715+ (defgeneric slurp-input-stream (processor input-stream &key)
32.6716+ (:documentation
32.6717+ "SLURP-INPUT-STREAM is a generic function with two positional arguments
32.6718+PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
32.6719+the contents of the INPUT-STREAM and processes them according to a method
32.6720+specified by PROCESSOR.
32.6721+
32.6722+Built-in methods include the following:
32.6723+* if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
32.6724+* if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the
32.6725+ INPUT-STREAM and the rest of the list. That is (x . y) will be treated as
32.6726+ \(APPLY x <stream> y\)
32.6727+* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
32.6728+ per copy-stream-to-stream, with appropriate keyword arguments.
32.6729+* if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
32.6730+ are returned as a string, as per SLURP-STREAM-STRING.
32.6731+* if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
32.6732+* if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
32.6733+* if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
32.6734+* if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
32.6735+* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
32.6736+
32.6737+Programmers are encouraged to define their own methods for this generic function."))
32.6738+
32.6739+ #-genera
32.6740+ (defmethod slurp-input-stream ((function function) input-stream &key)
32.6741+ (funcall function input-stream))
32.6742+
32.6743+ (defmethod slurp-input-stream ((list cons) input-stream &key)
32.6744+ (apply (first list) input-stream (rest list)))
32.6745+
32.6746+ #-genera
32.6747+ (defmethod slurp-input-stream ((output-stream stream) input-stream
32.6748+ &key linewise prefix (element-type 'character) buffer-size)
32.6749+ (copy-stream-to-stream
32.6750+ input-stream output-stream
32.6751+ :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
32.6752+
32.6753+ (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
32.6754+ (slurp-stream-string stream :stripped stripped))
32.6755+
32.6756+ (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
32.6757+ (slurp-stream-string stream :stripped stripped))
32.6758+
32.6759+ (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
32.6760+ (slurp-stream-lines stream :count count))
32.6761+
32.6762+ (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
32.6763+ (slurp-stream-line stream :at at))
32.6764+
32.6765+ (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
32.6766+ (slurp-stream-forms stream :count count))
32.6767+
32.6768+ (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
32.6769+ (slurp-stream-form stream :at at))
32.6770+
32.6771+ (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
32.6772+ (apply 'slurp-input-stream *standard-output* stream keys))
32.6773+
32.6774+ (defmethod slurp-input-stream ((x null) (stream t) &key)
32.6775+ nil)
32.6776+
32.6777+ (defmethod slurp-input-stream ((pathname pathname) input
32.6778+ &key
32.6779+ (element-type *default-stream-element-type*)
32.6780+ (external-format *utf-8-external-format*)
32.6781+ (if-exists :rename-and-delete)
32.6782+ (if-does-not-exist :create)
32.6783+ buffer-size
32.6784+ linewise)
32.6785+ (with-output-file (output pathname
32.6786+ :element-type element-type
32.6787+ :external-format external-format
32.6788+ :if-exists if-exists
32.6789+ :if-does-not-exist if-does-not-exist)
32.6790+ (copy-stream-to-stream
32.6791+ input output
32.6792+ :element-type element-type :buffer-size buffer-size :linewise linewise)))
32.6793+
32.6794+ (defmethod slurp-input-stream (x stream
32.6795+ &key linewise prefix (element-type 'character) buffer-size)
32.6796+ (declare (ignorable stream linewise prefix element-type buffer-size))
32.6797+ (cond
32.6798+ #+genera
32.6799+ ((functionp x) (funcall x stream))
32.6800+ #+genera
32.6801+ ((output-stream-p x)
32.6802+ (copy-stream-to-stream
32.6803+ stream x
32.6804+ :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
32.6805+ (t
32.6806+ (parameter-error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
32.6807+
32.6808+;;;; Vomiting a stream, typically into the input of another program.
32.6809+(with-upgradability ()
32.6810+ (defgeneric vomit-output-stream (processor output-stream &key)
32.6811+ (:documentation
32.6812+ "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
32.6813+PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
32.6814+some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
32.6815+
32.6816+Built-in methods include the following:
32.6817+* if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
32.6818+* if PROCESSOR is a list, its first element should be a function.
32.6819+ It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
32.6820+ That is (x . y) will be treated as \(APPLY x <stream> y\)
32.6821+* if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
32.6822+ per copy-stream-to-stream, with appropriate keyword arguments.
32.6823+* if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
32.6824+* if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.
32.6825+
32.6826+Programmers are encouraged to define their own methods for this generic function."))
32.6827+
32.6828+ #-genera
32.6829+ (defmethod vomit-output-stream ((function function) output-stream &key)
32.6830+ (funcall function output-stream))
32.6831+
32.6832+ (defmethod vomit-output-stream ((list cons) output-stream &key)
32.6833+ (apply (first list) output-stream (rest list)))
32.6834+
32.6835+ #-genera
32.6836+ (defmethod vomit-output-stream ((input-stream stream) output-stream
32.6837+ &key linewise prefix (element-type 'character) buffer-size)
32.6838+ (copy-stream-to-stream
32.6839+ input-stream output-stream
32.6840+ :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
32.6841+
32.6842+ (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
32.6843+ (princ x stream)
32.6844+ (when fresh-line (fresh-line stream))
32.6845+ (when terpri (terpri stream))
32.6846+ (values))
32.6847+
32.6848+ (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
32.6849+ (apply 'vomit-output-stream *standard-input* stream keys))
32.6850+
32.6851+ (defmethod vomit-output-stream ((x null) (stream t) &key)
32.6852+ (values))
32.6853+
32.6854+ (defmethod vomit-output-stream ((pathname pathname) input
32.6855+ &key
32.6856+ (element-type *default-stream-element-type*)
32.6857+ (external-format *utf-8-external-format*)
32.6858+ (if-exists :rename-and-delete)
32.6859+ (if-does-not-exist :create)
32.6860+ buffer-size
32.6861+ linewise)
32.6862+ (with-output-file (output pathname
32.6863+ :element-type element-type
32.6864+ :external-format external-format
32.6865+ :if-exists if-exists
32.6866+ :if-does-not-exist if-does-not-exist)
32.6867+ (copy-stream-to-stream
32.6868+ input output
32.6869+ :element-type element-type :buffer-size buffer-size :linewise linewise)))
32.6870+
32.6871+ (defmethod vomit-output-stream (x stream
32.6872+ &key linewise prefix (element-type 'character) buffer-size)
32.6873+ (declare (ignorable stream linewise prefix element-type buffer-size))
32.6874+ (cond
32.6875+ #+genera
32.6876+ ((functionp x) (funcall x stream))
32.6877+ #+genera
32.6878+ ((input-stream-p x)
32.6879+ (copy-stream-to-stream
32.6880+ x stream
32.6881+ :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
32.6882+ (t
32.6883+ (parameter-error "Invalid ~S source ~S" 'vomit-output-stream x)))))
32.6884+
32.6885+
32.6886+;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output.
32.6887+(with-upgradability ()
32.6888+ (define-condition subprocess-error (error)
32.6889+ ((code :initform nil :initarg :code :reader subprocess-error-code)
32.6890+ (command :initform nil :initarg :command :reader subprocess-error-command)
32.6891+ (process :initform nil :initarg :process :reader subprocess-error-process))
32.6892+ (:report (lambda (condition stream)
32.6893+ (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
32.6894+ (subprocess-error-process condition)
32.6895+ (subprocess-error-command condition)
32.6896+ (subprocess-error-code condition)))))
32.6897+
32.6898+ (defun %check-result (exit-code &key command process ignore-error-status)
32.6899+ (unless ignore-error-status
32.6900+ (unless (eql exit-code 0)
32.6901+ (cerror "IGNORE-ERROR-STATUS"
32.6902+ 'subprocess-error :command command :code exit-code :process process)))
32.6903+ exit-code)
32.6904+
32.6905+ (defun %active-io-specifier-p (specifier)
32.6906+ "Determines whether a run-program I/O specifier requires Lisp-side processing
32.6907+via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
32.6908+or whether it's already taken care of by the implementation's underlying run-program."
32.6909+ (not (typep specifier '(or null string pathname (member :interactive :output)
32.6910+ #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
32.6911+ #+lispworks file-stream))))
32.6912+
32.6913+ (defun %run-program (command &rest keys &key &allow-other-keys)
32.6914+ "DEPRECATED. Use LAUNCH-PROGRAM instead."
32.6915+ (apply 'launch-program command keys))
32.6916+
32.6917+ (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
32.6918+ &key
32.6919+ (element-type #-clozure *default-stream-element-type* #+clozure 'character)
32.6920+ (external-format *utf-8-external-format*) &allow-other-keys)
32.6921+ ;; handle redirection for run-program and system
32.6922+ ;; SPEC is the specification for the subprocess's input or output or error-output
32.6923+ ;; TVAL is the value used if the spec is T
32.6924+ ;; GF is the generic function to call to handle arbitrary values of SPEC
32.6925+ ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
32.6926+ ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
32.6927+ ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
32.6928+ ;; FUN is a function of the new reduced spec and an activity function to call with a stream
32.6929+ ;; when the subprocess is active and communicating through that stream.
32.6930+ ;; ACTIVEP is a boolean true if we will get to run code while the process is running
32.6931+ ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
32.6932+ ;; RETURNER is a function called with the value of the activity.
32.6933+ ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
32.6934+ (declare (ignorable stream-easy-p))
32.6935+ (let* ((actual-spec (if (eq spec t) tval spec))
32.6936+ (activity-spec (if (eq actual-spec :output)
32.6937+ (ecase direction
32.6938+ ((:input :output)
32.6939+ (parameter-error "~S does not allow ~S as a ~S spec"
32.6940+ 'run-program :output direction))
32.6941+ ((:error-output)
32.6942+ nil))
32.6943+ actual-spec)))
32.6944+ (labels ((activity (stream)
32.6945+ (call-function returner (call-stream-processor gf activity-spec stream)))
32.6946+ (easy-case ()
32.6947+ (funcall fun actual-spec nil))
32.6948+ (hard-case ()
32.6949+ (if activep
32.6950+ (funcall fun :stream #'activity)
32.6951+ (with-temporary-file (:pathname tmp)
32.6952+ (ecase direction
32.6953+ (:input
32.6954+ (with-output-file (s tmp :if-exists :overwrite
32.6955+ :external-format external-format
32.6956+ :element-type element-type)
32.6957+ (activity s))
32.6958+ (funcall fun tmp nil))
32.6959+ ((:output :error-output)
32.6960+ (multiple-value-prog1 (funcall fun tmp nil)
32.6961+ (with-input-file (s tmp
32.6962+ :external-format external-format
32.6963+ :element-type element-type)
32.6964+ (activity s)))))))))
32.6965+ (typecase activity-spec
32.6966+ ((or null string pathname (eql :interactive))
32.6967+ (easy-case))
32.6968+ #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
32.6969+ (stream
32.6970+ (if stream-easy-p (easy-case) (hard-case)))
32.6971+ (t
32.6972+ (hard-case))))))
32.6973+
32.6974+ (defmacro place-setter (place)
32.6975+ (when place
32.6976+ (let ((value (gensym)))
32.6977+ `#'(lambda (,value) (setf ,place ,value)))))
32.6978+
32.6979+ (defmacro with-program-input (((reduced-input-var
32.6980+ &optional (input-activity-var (gensym) iavp))
32.6981+ input-form &key setf stream-easy-p active keys) &body body)
32.6982+ `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p
32.6983+ #'(lambda (,reduced-input-var ,input-activity-var)
32.6984+ ,@(unless iavp `((declare (ignore ,input-activity-var))))
32.6985+ ,@body)
32.6986+ :input ,input-form ,active (place-setter ,setf) ,keys))
32.6987+
32.6988+ (defmacro with-program-output (((reduced-output-var
32.6989+ &optional (output-activity-var (gensym) oavp))
32.6990+ output-form &key setf stream-easy-p active keys) &body body)
32.6991+ `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p
32.6992+ #'(lambda (,reduced-output-var ,output-activity-var)
32.6993+ ,@(unless oavp `((declare (ignore ,output-activity-var))))
32.6994+ ,@body)
32.6995+ :output ,output-form ,active (place-setter ,setf) ,keys))
32.6996+
32.6997+ (defmacro with-program-error-output (((reduced-error-output-var
32.6998+ &optional (error-output-activity-var (gensym) eoavp))
32.6999+ error-output-form &key setf stream-easy-p active keys)
32.7000+ &body body)
32.7001+ `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p
32.7002+ #'(lambda (,reduced-error-output-var ,error-output-activity-var)
32.7003+ ,@(unless eoavp `((declare (ignore ,error-output-activity-var))))
32.7004+ ,@body)
32.7005+ :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
32.7006+
32.7007+ (defun %use-launch-program (command &rest keys
32.7008+ &key input output error-output ignore-error-status &allow-other-keys)
32.7009+ ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM
32.7010+ #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl)
32.7011+ (progn
32.7012+ command keys input output error-output ignore-error-status ;; ignore
32.7013+ (not-implemented-error '%use-launch-program))
32.7014+ (when (member :stream (list input output error-output))
32.7015+ (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
32.7016+ 'run-program :stream))
32.7017+ (let* ((active-input-p (%active-io-specifier-p input))
32.7018+ (active-output-p (%active-io-specifier-p output))
32.7019+ (active-error-output-p (%active-io-specifier-p error-output))
32.7020+ (activity
32.7021+ (cond
32.7022+ (active-output-p :output)
32.7023+ (active-input-p :input)
32.7024+ (active-error-output-p :error-output)
32.7025+ (t nil)))
32.7026+ output-result error-output-result exit-code process-info)
32.7027+ (with-program-output ((reduced-output output-activity)
32.7028+ output :keys keys :setf output-result
32.7029+ :stream-easy-p t :active (eq activity :output))
32.7030+ (with-program-error-output ((reduced-error-output error-output-activity)
32.7031+ error-output :keys keys :setf error-output-result
32.7032+ :stream-easy-p t :active (eq activity :error-output))
32.7033+ (with-program-input ((reduced-input input-activity)
32.7034+ input :keys keys
32.7035+ :stream-easy-p t :active (eq activity :input))
32.7036+ (setf process-info
32.7037+ (apply 'launch-program command
32.7038+ :input reduced-input :output reduced-output
32.7039+ :error-output (if (eq error-output :output) :output reduced-error-output)
32.7040+ keys))
32.7041+ (labels ((get-stream (stream-name &optional fallbackp)
32.7042+ (or (slot-value process-info stream-name)
32.7043+ (when fallbackp
32.7044+ (slot-value process-info 'bidir-stream))))
32.7045+ (run-activity (activity stream-name &optional fallbackp)
32.7046+ (if-let (stream (get-stream stream-name fallbackp))
32.7047+ (funcall activity stream)
32.7048+ (error 'subprocess-error
32.7049+ :code `(:missing ,stream-name)
32.7050+ :command command :process process-info))))
32.7051+ (unwind-protect
32.7052+ (ecase activity
32.7053+ ((nil))
32.7054+ (:input (run-activity input-activity 'input-stream t))
32.7055+ (:output (run-activity output-activity 'output-stream t))
32.7056+ (:error-output (run-activity error-output-activity 'error-output-stream)))
32.7057+ (close-streams process-info)
32.7058+ (setf exit-code (wait-process process-info)))))))
32.7059+ (%check-result exit-code
32.7060+ :command command :process process-info
32.7061+ :ignore-error-status ignore-error-status)
32.7062+ (values output-result error-output-result exit-code)))
32.7063+
32.7064+ (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
32.7065+ (etypecase command
32.7066+ (string command)
32.7067+ (list (escape-shell-command
32.7068+ (os-cond
32.7069+ ((os-unix-p) (cons "exec" command))
32.7070+ (t command))))))
32.7071+
32.7072+ (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
32.7073+ (flet ((redirect (spec operator)
32.7074+ (let ((pathname
32.7075+ (typecase spec
32.7076+ (null (null-device-pathname))
32.7077+ (string (parse-native-namestring spec))
32.7078+ (pathname spec)
32.7079+ ((eql :output)
32.7080+ (unless (equal operator " 2>>")
32.7081+ (parameter-error "~S: only the ~S argument can be ~S"
32.7082+ 'run-program :error-output :output))
32.7083+ (return-from redirect '(" 2>&1"))))))
32.7084+ (when pathname
32.7085+ (list operator " "
32.7086+ (escape-shell-token (native-namestring pathname)))))))
32.7087+ (let* ((redirections (append (redirect in " <") (redirect out " >>") (redirect err " 2>>")))
32.7088+ (normalized (%normalize-system-command command))
32.7089+ (directory (or directory #+(or abcl xcl) (getcwd)))
32.7090+ (chdir (when directory
32.7091+ (let ((dir-arg (escape-shell-token (native-namestring directory))))
32.7092+ (os-cond
32.7093+ ((os-unix-p) `("cd " ,dir-arg " ; "))
32.7094+ ((os-windows-p) `("cd /d " ,dir-arg " & ")))))))
32.7095+ (reduce/strcat
32.7096+ (os-cond
32.7097+ ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
32.7098+ ((os-windows-p) `(,@redirections " (" ,@chdir ,normalized ")")))))))
32.7099+
32.7100+ (defun %system (command &rest keys &key directory
32.7101+ input (if-input-does-not-exist :error)
32.7102+ output (if-output-exists :supersede)
32.7103+ error-output (if-error-output-exists :supersede)
32.7104+ &allow-other-keys)
32.7105+ "A portable abstraction of a low-level call to libc's system()."
32.7106+ (declare (ignorable keys directory input if-input-does-not-exist output
32.7107+ if-output-exists error-output if-error-output-exists))
32.7108+ (when (member :stream (list input output error-output))
32.7109+ (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
32.7110+ 'run-program :stream))
32.7111+ #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
32.7112+ (let (#+(or abcl ecl mkcl)
32.7113+ (version (parse-version
32.7114+ #-abcl
32.7115+ (lisp-implementation-version)
32.7116+ #+abcl
32.7117+ (second (split-string (implementation-identifier) :separator '(#\-))))))
32.7118+ (nest
32.7119+ #+abcl (unless (lexicographic< '< version '(1 4 0)))
32.7120+ #+ecl (unless (lexicographic<= '< version '(16 0 0)))
32.7121+ #+mkcl (unless (lexicographic<= '< version '(1 1 9)))
32.7122+ (return-from %system
32.7123+ (wait-process
32.7124+ (apply 'launch-program (%normalize-system-command command) keys)))))
32.7125+ #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
32.7126+ (let ((%command (%redirected-system-command command input output error-output directory)))
32.7127+ ;; see comments for these functions
32.7128+ (%handle-if-does-not-exist input if-input-does-not-exist)
32.7129+ (%handle-if-exists output if-output-exists)
32.7130+ (%handle-if-exists error-output if-error-output-exists)
32.7131+ #+abcl (ext:run-shell-command %command)
32.7132+ #+(or clasp ecl) (let ((*standard-input* *stdin*)
32.7133+ (*standard-output* *stdout*)
32.7134+ (*error-output* *stderr*))
32.7135+ (ext:system %command))
32.7136+ #+clisp
32.7137+ (let ((raw-exit-code
32.7138+ (or
32.7139+ #.`(#+os-windows ,@'(ext:run-shell-command %command)
32.7140+ #+os-unix ,@'(ext:run-program "/bin/sh" :arguments `("-c" ,%command))
32.7141+ :wait t :input :terminal :output :terminal)
32.7142+ 0)))
32.7143+ (if (minusp raw-exit-code)
32.7144+ (- 128 raw-exit-code)
32.7145+ raw-exit-code))
32.7146+ #+cormanlisp (win32:system %command)
32.7147+ #+gcl (system:system %command)
32.7148+ #+genera (not-implemented-error '%system)
32.7149+ #+(and lispworks os-windows)
32.7150+ (system:call-system %command :current-directory directory :wait t)
32.7151+ #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
32.7152+ #+mkcl (mkcl:system %command)
32.7153+ #+xcl (system:%run-shell-command %command)))
32.7154+
32.7155+ (defun %use-system (command &rest keys
32.7156+ &key input output error-output ignore-error-status &allow-other-keys)
32.7157+ ;; helper for RUN-PROGRAM when using %system
32.7158+ (let (output-result error-output-result exit-code)
32.7159+ (with-program-output ((reduced-output)
32.7160+ output :keys keys :setf output-result)
32.7161+ (with-program-error-output ((reduced-error-output)
32.7162+ error-output :keys keys :setf error-output-result)
32.7163+ (with-program-input ((reduced-input) input :keys keys)
32.7164+ (setf exit-code (apply '%system command
32.7165+ :input reduced-input :output reduced-output
32.7166+ :error-output reduced-error-output keys)))))
32.7167+ (%check-result exit-code
32.7168+ :command command
32.7169+ :ignore-error-status ignore-error-status)
32.7170+ (values output-result error-output-result exit-code)))
32.7171+
32.7172+ (defun run-program (command &rest keys
32.7173+ &key ignore-error-status (force-shell nil force-shell-suppliedp)
32.7174+ input (if-input-does-not-exist :error)
32.7175+ output (if-output-exists :supersede)
32.7176+ error-output (if-error-output-exists :supersede)
32.7177+ (element-type #-clozure *default-stream-element-type* #+clozure 'character)
32.7178+ (external-format *utf-8-external-format*)
32.7179+ &allow-other-keys)
32.7180+ "Run program specified by COMMAND,
32.7181+either a list of strings specifying a program and list of arguments,
32.7182+or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
32.7183+_synchronously_ process its output as specified and return the processing results
32.7184+when the program and its output processing are complete.
32.7185+
32.7186+Always call a shell (rather than directly execute the command when possible)
32.7187+if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is
32.7188+specified to be NIL.
32.7189+
32.7190+Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
32.7191+unless IGNORE-ERROR-STATUS is specified.
32.7192+
32.7193+If OUTPUT is a pathname, a string designating a pathname, or NIL (the default)
32.7194+designating the null device, the file at that path is used as output.
32.7195+If it's :INTERACTIVE, output is inherited from the current process;
32.7196+beware that this may be different from your *STANDARD-OUTPUT*,
32.7197+and under SLIME will be on your *inferior-lisp* buffer.
32.7198+If it's T, output goes to your current *STANDARD-OUTPUT* stream.
32.7199+Otherwise, OUTPUT should be a value that is a suitable first argument to
32.7200+SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
32.7201+In this case, RUN-PROGRAM will create a temporary stream for the program output;
32.7202+the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
32.7203+using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
32.7204+The primary value resulting from that call (or NIL if no call was needed)
32.7205+will be the first value returned by RUN-PROGRAM.
32.7206+E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
32.7207+And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
32.7208+stripped of any ending newline.
32.7209+
32.7210+IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
32.7211+pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
32.7212+default). The meaning of these values and their effect on the case
32.7213+where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
32.7214+to OPEN with :DIRECTION :OUTPUT.
32.7215+
32.7216+ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
32.7217+as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
32.7218+Also :OUTPUT means redirecting the error output to the output stream,
32.7219+in which case NIL is returned.
32.7220+
32.7221+IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
32.7222+affects ERROR-OUTPUT rather than OUTPUT.
32.7223+
32.7224+INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
32.7225+no value is returned, and T designates the *STANDARD-INPUT*.
32.7226+
32.7227+IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
32.7228+or a pathname, can take the values :CREATE and :ERROR (the
32.7229+default). The meaning of these values is analogous to the
32.7230+IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
32.7231+
32.7232+ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
32.7233+to your Lisp implementation, when applicable, for creation of the output stream.
32.7234+
32.7235+One and only one of the stream slurping or vomiting may or may not happen
32.7236+in parallel in parallel with the subprocess,
32.7237+depending on options and implementation,
32.7238+and with priority being given to output processing.
32.7239+Other streams are completely produced or consumed
32.7240+before or after the subprocess is spawned, using temporary files.
32.7241+
32.7242+RUN-PROGRAM returns 3 values:
32.7243+0- the result of the OUTPUT slurping if any, or NIL
32.7244+1- the result of the ERROR-OUTPUT slurping if any, or NIL
32.7245+2- either 0 if the subprocess exited with success status,
32.7246+or an indication of failure via the EXIT-CODE of the process"
32.7247+ (declare (ignorable input output error-output if-input-does-not-exist if-output-exists
32.7248+ if-error-output-exists element-type external-format ignore-error-status))
32.7249+ #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
32.7250+ (not-implemented-error 'run-program)
32.7251+ (apply (if (or force-shell
32.7252+ ;; Per doc string, set FORCE-SHELL to T if we get command as a string.
32.7253+ ;; But don't override user's specified preference. [2015/06/29:rpg]
32.7254+ (and (stringp command)
32.7255+ (or (not force-shell-suppliedp)
32.7256+ #-(or allegro clisp clozure sbcl) (os-cond ((os-windows-p) t))))
32.7257+ #+(or clasp clisp cormanlisp gcl (and lispworks os-windows) mcl xcl) t
32.7258+ ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
32.7259+ #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
32.7260+ (lexicographic<= '< ver '(16 0 0)))
32.7261+ #+(and lispworks os-unix) (%interactivep input output error-output))
32.7262+ '%use-system '%use-launch-program)
32.7263+ command keys)))
32.7264+
32.7265+;;;; ---------------------------------------------------------------------------
32.7266+;;;; Generic support for configuration files
32.7267+
32.7268+(uiop/package:define-package :uiop/configuration
32.7269+ (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27.
32.7270+ (:use :uiop/package :uiop/common-lisp :uiop/utility
32.7271+ :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
32.7272+ (:export
32.7273+ #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
32.7274+ #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem
32.7275+ #:get-folder-path
32.7276+ #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
32.7277+ #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
32.7278+ #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames
32.7279+ #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname
32.7280+ #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
32.7281+ #:configuration-inheritance-directive-p
32.7282+ #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
32.7283+ #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
32.7284+ #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
32.7285+ #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration
32.7286+ #:uiop-directory))
32.7287+(in-package :uiop/configuration)
32.7288+
32.7289+(with-upgradability ()
32.7290+ (define-condition invalid-configuration ()
32.7291+ ((form :reader condition-form :initarg :form)
32.7292+ (location :reader condition-location :initarg :location)
32.7293+ (format :reader condition-format :initarg :format)
32.7294+ (arguments :reader condition-arguments :initarg :arguments :initform nil))
32.7295+ (:report (lambda (c s)
32.7296+ (format s (compatfmt "~@<~? (will be skipped)~@:>")
32.7297+ (condition-format c)
32.7298+ (list* (condition-form c) (condition-location c)
32.7299+ (condition-arguments c))))))
32.7300+
32.7301+ (defun configuration-inheritance-directive-p (x)
32.7302+ "Is X a configuration inheritance directive?"
32.7303+ (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
32.7304+ (or (member x kw)
32.7305+ (and (length=n-p x 1) (member (car x) kw)))))
32.7306+
32.7307+ (defun report-invalid-form (reporter &rest args)
32.7308+ "Report an invalid form according to REPORTER and various ARGS"
32.7309+ (etypecase reporter
32.7310+ (null
32.7311+ (apply 'error 'invalid-configuration args))
32.7312+ (function
32.7313+ (apply reporter args))
32.7314+ ((or symbol string)
32.7315+ (apply 'error reporter args))
32.7316+ (cons
32.7317+ (apply 'apply (append reporter args)))))
32.7318+
32.7319+ (defvar *ignored-configuration-form* nil
32.7320+ "Have configuration forms been ignored while parsing the configuration?")
32.7321+
32.7322+ (defun validate-configuration-form (form tag directive-validator
32.7323+ &key location invalid-form-reporter)
32.7324+ "Validate a configuration FORM. By default it will raise an error if the
32.7325+FORM is not valid. Otherwise it will return the validated form.
32.7326+ Arguments control the behavior:
32.7327+ The configuration FORM should be of the form (TAG . <rest>)
32.7328+ Each element of <rest> will be checked by first seeing if it's a configuration inheritance
32.7329+directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
32.7330+on it.
32.7331+ In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
32.7332+reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
32.7333+the configuration form appeared."
32.7334+ (unless (and (consp form) (eq (car form) tag))
32.7335+ (setf *ignored-configuration-form* t)
32.7336+ (report-invalid-form invalid-form-reporter :form form :location location)
32.7337+ (return-from validate-configuration-form nil))
32.7338+ (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
32.7339+ :for directive :in (cdr form)
32.7340+ :when (cond
32.7341+ ((configuration-inheritance-directive-p directive)
32.7342+ (incf inherit) t)
32.7343+ ((eq directive :ignore-invalid-entries)
32.7344+ (setf ignore-invalid-p t) t)
32.7345+ ((funcall directive-validator directive)
32.7346+ t)
32.7347+ (ignore-invalid-p
32.7348+ nil)
32.7349+ (t
32.7350+ (setf *ignored-configuration-form* t)
32.7351+ (report-invalid-form invalid-form-reporter :form directive :location location)
32.7352+ nil))
32.7353+ :do (push directive x)
32.7354+ :finally
32.7355+ (unless (= inherit 1)
32.7356+ (report-invalid-form invalid-form-reporter
32.7357+ :form form :location location
32.7358+ ;; we throw away the form and location arguments, hence the ~2*
32.7359+ ;; this is necessary because of the report in INVALID-CONFIGURATION
32.7360+ :format (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
32.7361+ One and only one of ~S or ~S is required.~@:>")
32.7362+ :arguments '(:inherit-configuration :ignore-inherited-configuration)))
32.7363+ (return (nreverse x))))
32.7364+
32.7365+ (defun validate-configuration-file (file validator &key description)
32.7366+ "Validate a configuration FILE. The configuration file should have only one s-expression
32.7367+in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error
32.7368+reporting."
32.7369+ (let ((forms (read-file-forms file)))
32.7370+ (unless (length=n-p forms 1)
32.7371+ (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
32.7372+ description forms))
32.7373+ (funcall validator (car forms) :location file)))
32.7374+
32.7375+ (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter)
32.7376+ "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
32.7377+be applied to the results to yield a configuration form. Current
32.7378+values of TAG include :source-registry and :output-translations."
32.7379+ (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
32.7380+ (remove-if
32.7381+ 'hidden-pathname-p
32.7382+ (directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
32.7383+ #'string< :key #'namestring)))
32.7384+ `(,tag
32.7385+ ,@(loop :for file :in files :append
32.7386+ (loop :with ignore-invalid-p = nil
32.7387+ :for form :in (read-file-forms file)
32.7388+ :when (eq form :ignore-invalid-entries)
32.7389+ :do (setf ignore-invalid-p t)
32.7390+ :else
32.7391+ :when (funcall validator form)
32.7392+ :collect form
32.7393+ :else
32.7394+ :when ignore-invalid-p
32.7395+ :do (setf *ignored-configuration-form* t)
32.7396+ :else
32.7397+ :do (report-invalid-form invalid-form-reporter :form form :location file)))
32.7398+ :inherit-configuration)))
32.7399+
32.7400+ (defun resolve-relative-location (x &key ensure-directory wilden)
32.7401+ "Given a designator X for an relative location, resolve it to a pathname."
32.7402+ (ensure-pathname
32.7403+ (etypecase x
32.7404+ (null nil)
32.7405+ (pathname x)
32.7406+ (string (parse-unix-namestring
32.7407+ x :ensure-directory ensure-directory))
32.7408+ (cons
32.7409+ (if (null (cdr x))
32.7410+ (resolve-relative-location
32.7411+ (car x) :ensure-directory ensure-directory :wilden wilden)
32.7412+ (let* ((car (resolve-relative-location
32.7413+ (car x) :ensure-directory t :wilden nil)))
32.7414+ (merge-pathnames*
32.7415+ (resolve-relative-location
32.7416+ (cdr x) :ensure-directory ensure-directory :wilden wilden)
32.7417+ car))))
32.7418+ ((eql :*/) *wild-directory*)
32.7419+ ((eql :**/) *wild-inferiors*)
32.7420+ ((eql :*.*.*) *wild-file*)
32.7421+ ((eql :implementation)
32.7422+ (parse-unix-namestring
32.7423+ (implementation-identifier) :ensure-directory t))
32.7424+ ((eql :implementation-type)
32.7425+ (parse-unix-namestring
32.7426+ (string-downcase (implementation-type)) :ensure-directory t))
32.7427+ ((eql :hostname)
32.7428+ (parse-unix-namestring (hostname) :ensure-directory t)))
32.7429+ :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
32.7430+ :want-relative t))
32.7431+
32.7432+ (defvar *here-directory* nil
32.7433+ "This special variable is bound to the currect directory during calls to
32.7434+PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
32.7435+directive.")
32.7436+
32.7437+ (defvar *user-cache* nil
32.7438+ "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
32.7439+
32.7440+ (defun resolve-absolute-location (x &key ensure-directory wilden)
32.7441+ "Given a designator X for an absolute location, resolve it to a pathname"
32.7442+ (ensure-pathname
32.7443+ (etypecase x
32.7444+ (null nil)
32.7445+ (pathname x)
32.7446+ (string
32.7447+ (let ((p #-mcl (parse-namestring x)
32.7448+ #+mcl (probe-posix x)))
32.7449+ #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
32.7450+ (if ensure-directory (ensure-directory-pathname p) p)))
32.7451+ (cons
32.7452+ (return-from resolve-absolute-location
32.7453+ (if (null (cdr x))
32.7454+ (resolve-absolute-location
32.7455+ (car x) :ensure-directory ensure-directory :wilden wilden)
32.7456+ (merge-pathnames*
32.7457+ (resolve-relative-location
32.7458+ (cdr x) :ensure-directory ensure-directory :wilden wilden)
32.7459+ (resolve-absolute-location
32.7460+ (car x) :ensure-directory t :wilden nil)))))
32.7461+ ((eql :root)
32.7462+ ;; special magic! we return a relative pathname,
32.7463+ ;; but what it means to the output-translations is
32.7464+ ;; "relative to the root of the source pathname's host and device".
32.7465+ (return-from resolve-absolute-location
32.7466+ (let ((p (make-pathname :directory '(:relative))))
32.7467+ (if wilden (wilden p) p))))
32.7468+ ((eql :home) (user-homedir-pathname))
32.7469+ ((eql :here) (resolve-absolute-location
32.7470+ (or *here-directory* (pathname-directory-pathname (truename (load-pathname))))
32.7471+ :ensure-directory t :wilden nil))
32.7472+ ((eql :user-cache) (resolve-absolute-location
32.7473+ *user-cache* :ensure-directory t :wilden nil)))
32.7474+ :wilden (and wilden (not (pathnamep x)))
32.7475+ :resolve-symlinks *resolve-symlinks*
32.7476+ :want-absolute t))
32.7477+
32.7478+ ;; Try to override declaration in previous versions of ASDF.
32.7479+ (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
32.7480+ (:ensure-directory boolean)) t) resolve-location))
32.7481+
32.7482+ (defun resolve-location (x &key ensure-directory wilden directory)
32.7483+ "Resolve location designator X into a PATHNAME"
32.7484+ ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
32.7485+ (loop :with dirp = (or directory ensure-directory)
32.7486+ :with (first . rest) = (if (atom x) (list x) x)
32.7487+ :with path = (or (resolve-absolute-location
32.7488+ first :ensure-directory (and (or dirp rest) t)
32.7489+ :wilden (and wilden (null rest)))
32.7490+ (return nil))
32.7491+ :for (element . morep) :on rest
32.7492+ :for dir = (and (or morep dirp) t)
32.7493+ :for wild = (and wilden (not morep))
32.7494+ :for sub = (merge-pathnames*
32.7495+ (resolve-relative-location
32.7496+ element :ensure-directory dir :wilden wild)
32.7497+ path)
32.7498+ :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
32.7499+ :finally (return path)))
32.7500+
32.7501+ (defun location-designator-p (x)
32.7502+ "Is X a designator for a location?"
32.7503+ ;; NIL means "skip this entry", or as an output translation, same as translation input.
32.7504+ ;; T means "any input" for a translation, or as output, same as translation input.
32.7505+ (flet ((absolute-component-p (c)
32.7506+ (typep c '(or string pathname
32.7507+ (member :root :home :here :user-cache))))
32.7508+ (relative-component-p (c)
32.7509+ (typep c '(or string pathname
32.7510+ (member :*/ :**/ :*.*.* :implementation :implementation-type)))))
32.7511+ (or (typep x 'boolean)
32.7512+ (absolute-component-p x)
32.7513+ (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
32.7514+
32.7515+ (defun location-function-p (x)
32.7516+ "Is X the specification of a location function?"
32.7517+ ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
32.7518+ (and (length=n-p x 2) (eq (car x) :function)))
32.7519+
32.7520+ (defvar *clear-configuration-hook* '())
32.7521+
32.7522+ (defun register-clear-configuration-hook (hook-function &optional call-now-p)
32.7523+ "Register a function to be called when clearing configuration"
32.7524+ (register-hook-function '*clear-configuration-hook* hook-function call-now-p))
32.7525+
32.7526+ (defun clear-configuration ()
32.7527+ "Call the functions in *CLEAR-CONFIGURATION-HOOK*"
32.7528+ (call-functions *clear-configuration-hook*))
32.7529+
32.7530+ (register-image-dump-hook 'clear-configuration)
32.7531+
32.7532+ (defun upgrade-configuration ()
32.7533+ "If a previous version of ASDF failed to read some configuration, try again now."
32.7534+ (when *ignored-configuration-form*
32.7535+ (clear-configuration)
32.7536+ (setf *ignored-configuration-form* nil)))
32.7537+
32.7538+
32.7539+ (defun get-folder-path (folder)
32.7540+ "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
32.7541+this function tries to locate the Windows FOLDER for one of
32.7542+:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
32.7543+ Returns NIL when the folder is not defined (e.g., not on Windows)."
32.7544+ (or #+(and lispworks os-windows) (sys:get-folder-path folder)
32.7545+ ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
32.7546+ (ecase folder
32.7547+ (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
32.7548+ (subpathname* (get-folder-path :appdata) "Local")))
32.7549+ (:appdata (getenv-absolute-directory "APPDATA"))
32.7550+ (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
32.7551+ (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
32.7552+
32.7553+
32.7554+ ;; Support for the XDG Base Directory Specification
32.7555+ (defun xdg-data-home (&rest more)
32.7556+ "Returns an absolute pathname for the directory containing user-specific data files.
32.7557+MORE may contain specifications for a subpath relative to this directory: a
32.7558+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
32.7559+also \"Configuration DSL\"\) in the ASDF manual."
32.7560+ (resolve-absolute-location
32.7561+ `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
32.7562+ (os-cond
32.7563+ ((os-windows-p) (get-folder-path :local-appdata))
32.7564+ (t (subpathname (user-homedir-pathname) ".local/share/"))))
32.7565+ ,more)))
32.7566+
32.7567+ (defun xdg-config-home (&rest more)
32.7568+ "Returns a pathname for the directory containing user-specific configuration files.
32.7569+MORE may contain specifications for a subpath relative to this directory: a
32.7570+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
32.7571+also \"Configuration DSL\"\) in the ASDF manual."
32.7572+ (resolve-absolute-location
32.7573+ `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
32.7574+ (os-cond
32.7575+ ((os-windows-p) (xdg-data-home "config/"))
32.7576+ (t (subpathname (user-homedir-pathname) ".config/"))))
32.7577+ ,more)))
32.7578+
32.7579+ (defun xdg-data-dirs (&rest more)
32.7580+ "The preference-ordered set of additional paths to search for data files.
32.7581+Returns a list of absolute directory pathnames.
32.7582+MORE may contain specifications for a subpath relative to these directories: a
32.7583+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
32.7584+also \"Configuration DSL\"\) in the ASDF manual."
32.7585+ (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
32.7586+ (or (remove nil (getenv-absolute-directories "XDG_DATA_DIRS"))
32.7587+ (os-cond
32.7588+ ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
32.7589+ ;; macOS' separate read-only system volume means that the contents
32.7590+ ;; of /usr/share are frozen by Apple. Unlike when running natively
32.7591+ ;; on macOS, Genera must access the filesystem through NFS. Attempting
32.7592+ ;; to export either the root (/) or /usr/share simply doesn't work.
32.7593+ ;; (Genera will go into an infinite loop trying to access those mounts.)
32.7594+ ;; So, when running Genera on macOS, only search /usr/local/share.
32.7595+ ((os-genera-p)
32.7596+ #+Genera (sys:system-case
32.7597+ (darwin-vlm (mapcar 'parse-unix-namestring '("/usr/local/share/")))
32.7598+ (otherwise (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))
32.7599+ (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))))
32.7600+
32.7601+ (defun xdg-config-dirs (&rest more)
32.7602+ "The preference-ordered set of additional base paths to search for configuration files.
32.7603+Returns a list of absolute directory pathnames.
32.7604+MORE may contain specifications for a subpath relative to these directories:
32.7605+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
32.7606+also \"Configuration DSL\"\) in the ASDF manual."
32.7607+ (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
32.7608+ (or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIRS"))
32.7609+ (os-cond
32.7610+ ((os-windows-p) (xdg-data-dirs "config/"))
32.7611+ (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))
32.7612+
32.7613+ (defun xdg-cache-home (&rest more)
32.7614+ "The base directory relative to which user specific non-essential data files should be stored.
32.7615+Returns an absolute directory pathname.
32.7616+MORE may contain specifications for a subpath relative to this directory: a
32.7617+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
32.7618+also \"Configuration DSL\"\) in the ASDF manual."
32.7619+ (resolve-absolute-location
32.7620+ `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
32.7621+ (os-cond
32.7622+ ((os-windows-p) (xdg-data-home "cache/"))
32.7623+ (t (subpathname* (user-homedir-pathname) ".cache/"))))
32.7624+ ,more)))
32.7625+
32.7626+ (defun xdg-runtime-dir (&rest more)
32.7627+ "Pathname for user-specific non-essential runtime files and other file objects,
32.7628+such as sockets, named pipes, etc.
32.7629+Returns an absolute directory pathname.
32.7630+MORE may contain specifications for a subpath relative to this directory: a
32.7631+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
32.7632+also \"Configuration DSL\"\) in the ASDF manual."
32.7633+ ;; The XDG spec says that if not provided by the login system, the application should
32.7634+ ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
32.7635+ (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
32.7636+
32.7637+ ;;; NOTE: modified the docstring because "system user configuration
32.7638+ ;;; directories" seems self-contradictory. I'm not sure my wording is right.
32.7639+ (defun system-config-pathnames (&rest more)
32.7640+ "Return a list of directories where are stored the system's default user configuration information.
32.7641+MORE may contain specifications for a subpath relative to these directories: a
32.7642+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
32.7643+also \"Configuration DSL\"\) in the ASDF manual."
32.7644+ (declare (ignorable more))
32.7645+ (os-cond
32.7646+ ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more))))))
32.7647+
32.7648+ (defun filter-pathname-set (dirs)
32.7649+ "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
32.7650+ (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))
32.7651+
32.7652+ (defun xdg-data-pathnames (&rest more)
32.7653+ "Return a list of absolute pathnames for application data directories. With APP,
32.7654+returns directory for data for that application, without APP, returns the set of directories
32.7655+for storing all application configurations.
32.7656+MORE may contain specifications for a subpath relative to these directories: a
32.7657+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
32.7658+also \"Configuration DSL\"\) in the ASDF manual."
32.7659+ (filter-pathname-set
32.7660+ `(,(xdg-data-home more)
32.7661+ ,@(xdg-data-dirs more))))
32.7662+
32.7663+ (defun xdg-config-pathnames (&rest more)
32.7664+ "Return a list of pathnames for application configuration.
32.7665+MORE may contain specifications for a subpath relative to these directories: a
32.7666+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
32.7667+also \"Configuration DSL\"\) in the ASDF manual."
32.7668+ (filter-pathname-set
32.7669+ `(,(xdg-config-home more)
32.7670+ ,@(xdg-config-dirs more))))
32.7671+
32.7672+ (defun find-preferred-file (files &key (direction :input))
32.7673+ "Find first file in the list of FILES that exists (for direction :input or :probe)
32.7674+or just the first one (for direction :output or :io).
32.7675+ Note that when we say \"file\" here, the files in question may be directories."
32.7676+ (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))
32.7677+
32.7678+ (defun xdg-data-pathname (&optional more (direction :input))
32.7679+ (find-preferred-file (xdg-data-pathnames more) :direction direction))
32.7680+
32.7681+ (defun xdg-config-pathname (&optional more (direction :input))
32.7682+ (find-preferred-file (xdg-config-pathnames more) :direction direction))
32.7683+
32.7684+ (defun compute-user-cache ()
32.7685+ "Compute (and return) the location of the default user-cache for translate-output
32.7686+objects. Side-effects for cached file location computation."
32.7687+ (setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
32.7688+ (register-image-restore-hook 'compute-user-cache)
32.7689+
32.7690+ (defun uiop-directory ()
32.7691+ "Try to locate the UIOP source directory at runtime"
32.7692+ (labels ((pf (x) (ignore-errors (probe-file* x)))
32.7693+ (sub (x y) (pf (subpathname x y)))
32.7694+ (ssd (x) (ignore-errors (symbol-call :asdf :system-source-directory x))))
32.7695+ ;; NB: conspicuously *not* including searches based on #.(current-lisp-pathname)
32.7696+ (or
32.7697+ ;; Look under uiop if available as source override, under asdf if avaiable as source
32.7698+ (ssd "uiop")
32.7699+ (sub (ssd "asdf") "uiop/")
32.7700+ ;; Look in recommended path for user-visible source installation
32.7701+ (sub (user-homedir-pathname) "common-lisp/asdf/uiop/")
32.7702+ ;; Look in XDG paths under known package names for user-invisible source installation
32.7703+ (xdg-data-pathname "common-lisp/source/asdf/uiop/")
32.7704+ (xdg-data-pathname "common-lisp/source/cl-asdf/uiop/") ; traditional Debian location
32.7705+ ;; The last one below is useful for Fare, primary (sole?) known user
32.7706+ (sub (user-homedir-pathname) "cl/asdf/uiop/")
32.7707+ (cerror "Configure source registry to include UIOP source directory and retry."
32.7708+ "Unable to find UIOP directory")
32.7709+ (uiop-directory)))))
32.7710+;;; -------------------------------------------------------------------------
32.7711+;;; Hacks for backward-compatibility with older versions of UIOP
32.7712+
32.7713+(uiop/package:define-package :uiop/backward-driver
32.7714+ (:recycle :uiop/backward-driver :asdf/backward-driver :uiop)
32.7715+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version
32.7716+ :uiop/pathname :uiop/stream :uiop/os :uiop/image
32.7717+ :uiop/run-program :uiop/lisp-build :uiop/configuration)
32.7718+ (:export
32.7719+ #:coerce-pathname
32.7720+ #:user-configuration-directories #:system-configuration-directories
32.7721+ #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory
32.7722+ #:version-compatible-p))
32.7723+(in-package :uiop/backward-driver)
32.7724+
32.7725+(eval-when (:compile-toplevel :load-toplevel :execute)
32.7726+(with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2" :warning "3.4"))
32.7727+ ;; Backward compatibility with ASDF 2.000 to 2.26
32.7728+
32.7729+ ;; For backward-compatibility only, for people using internals
32.7730+ ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release)
32.7731+ ;; Will be removed after 2015-12.
32.7732+ (defun coerce-pathname (name &key type defaults)
32.7733+ "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead."
32.7734+ (parse-unix-namestring name :type type :defaults defaults))
32.7735+
32.7736+ ;; Backward compatibility for ASDF 2.27 to 3.1.4
32.7737+ (defun user-configuration-directories ()
32.7738+ "Return the current user's list of user configuration directories
32.7739+for configuring common-lisp.
32.7740+DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead."
32.7741+ (xdg-config-pathnames "common-lisp"))
32.7742+ (defun system-configuration-directories ()
32.7743+ "Return the list of system configuration directories for common-lisp.
32.7744+DEPRECATED. Use UIOP:SYSTEM-CONFIG-PATHNAMES (with argument \"common-lisp\"),
32.7745+instead."
32.7746+ (system-config-pathnames "common-lisp"))
32.7747+ (defun in-first-directory (dirs x &key (direction :input))
32.7748+ "Finds the first appropriate file named X in the list of DIRS for I/O
32.7749+in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
32.7750+If direction is :INPUT or :PROBE, will return the first extant file named
32.7751+X in one of the DIRS.
32.7752+If direction is :OUTPUT or :IO, will simply return the file named X in the
32.7753+first element of DIRS that exists. DEPRECATED."
32.7754+ (find-preferred-file
32.7755+ (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs)
32.7756+ :direction direction))
32.7757+ (defun in-user-configuration-directory (x &key (direction :input))
32.7758+ "Return the file named X in the user configuration directory for common-lisp.
32.7759+DEPRECATED."
32.7760+ (xdg-config-pathname `("common-lisp" ,x) direction))
32.7761+ (defun in-system-configuration-directory (x &key (direction :input))
32.7762+ "Return the pathname for the file named X under the system configuration directory
32.7763+for common-lisp. DEPRECATED."
32.7764+ (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction))
32.7765+
32.7766+
32.7767+ ;; Backward compatibility with ASDF 1 to ASDF 2.32
32.7768+
32.7769+ (defun version-compatible-p (provided-version required-version)
32.7770+ "Is the provided version a compatible substitution for the required-version?
32.7771+If major versions differ, it's not compatible.
32.7772+If they are equal, then any later version is compatible,
32.7773+with later being determined by a lexicographical comparison of minor numbers.
32.7774+DEPRECATED."
32.7775+ (let ((x (parse-version provided-version nil))
32.7776+ (y (parse-version required-version nil)))
32.7777+ (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))))
32.7778+
32.7779+;;;; ---------------------------------------------------------------------------
32.7780+;;;; Re-export all the functionality in UIOP
32.7781+
32.7782+(uiop/package:define-package :uiop/driver
32.7783+ (:nicknames :uiop ;; Official name we recommend should be used for all references to uiop symbols.
32.7784+ :asdf/driver) ;; DO NOT USE, a deprecated name, not supported anymore.
32.7785+ ;; We should remove the name :asdf/driver at some point,
32.7786+ ;; but not until it has been eradicated from Quicklisp for a year or two.
32.7787+ ;; The last known user was cffi (PR merged in May 2020).
32.7788+ (:use :uiop/common-lisp)
32.7789+ ;; NB: We are not reexporting uiop/common-lisp
32.7790+ ;; which include all of CL with compatibility modifications on select platforms,
32.7791+ ;; because that would cause potential conflicts for packages that
32.7792+ ;; might want to :use (:cl :uiop) or :use (:closer-common-lisp :uiop), etc.
32.7793+ (:use-reexport
32.7794+ :uiop/package* :uiop/utility :uiop/version
32.7795+ :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image
32.7796+ :uiop/launch-program :uiop/run-program
32.7797+ :uiop/lisp-build :uiop/configuration :uiop/backward-driver))
32.7798+
32.7799+;; Provide both lowercase and uppercase, to satisfy more implementations.
32.7800+(provide "uiop") (provide "UIOP")
32.7801+;;;; -------------------------------------------------------------------------
32.7802+;;;; Handle upgrade as forward- and backward-compatibly as possible
32.7803+;; See https://bugs.launchpad.net/asdf/+bug/485687
32.7804+
32.7805+(uiop/package:define-package :asdf/upgrade
32.7806+ (:recycle :asdf/upgrade :asdf)
32.7807+ (:use :uiop/common-lisp :uiop)
32.7808+ (:export
32.7809+ #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
32.7810+ #:asdf-message #:*verbose-out*
32.7811+ #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter*
32.7812+ #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf
32.7813+ ;; There will be no symbol left behind!
32.7814+ #:with-asdf-deprecation
32.7815+ #:intern*)
32.7816+ (:import-from :uiop/package #:intern* #:find-symbol*))
32.7817+(in-package :asdf/upgrade)
32.7818+
32.7819+;;; Special magic to detect if this is an upgrade
32.7820+
32.7821+(with-upgradability ()
32.7822+ (defun asdf-version ()
32.7823+ "Exported interface to the version of ASDF currently installed. A string.
32.7824+You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")."
32.7825+ (when (find-package :asdf)
32.7826+ (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
32.7827+ (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf))
32.7828+ (rev (and revsym (boundp revsym) (symbol-value revsym))))
32.7829+ (etypecase rev
32.7830+ (string rev)
32.7831+ (cons (format nil "~{~D~^.~}" rev))
32.7832+ (null "1.0"))))))
32.7833+ ;; This (private) variable contains a list of versions of previously loaded variants of ASDF,
32.7834+ ;; from which ASDF was upgraded.
32.7835+ ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly.
32.7836+ (defvar *previous-asdf-versions*
32.7837+ (let ((previous (asdf-version)))
32.7838+ (when previous
32.7839+ ;; Punt on upgrade from ASDF1 or ASDF2, by renaming (or deleting) the package.
32.7840+ (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature.
32.7841+ (let ((away (format nil "~A-~A" :asdf previous)))
32.7842+ (rename-package :asdf away)
32.7843+ (when *load-verbose*
32.7844+ (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))
32.7845+ (list previous))))
32.7846+ ;; This public variable will be bound shortly to the currently loaded version of ASDF.
32.7847+ (defvar *asdf-version* nil)
32.7848+ ;; We need to clear systems from versions older than the one in this (private) parameter.
32.7849+ ;; The latest incompatible defclass is 2.32.13 renaming a slot in component,
32.7850+ ;; or 3.2.0.2 for CCL (incompatibly changing some superclasses).
32.7851+ ;; the latest incompatible gf change is in 3.1.7.20 (see redefined-functions below).
32.7852+ (defparameter *oldest-forward-compatible-asdf-version* "3.2.0.2")
32.7853+ ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages
32.7854+ (defvar *verbose-out* nil)
32.7855+ ;; Private function by which ASDF outputs progress messages and warning messages:
32.7856+ (defun asdf-message (format-string &rest format-args)
32.7857+ (when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
32.7858+ ;; Private hook for functions to run after ASDF has upgraded itself from an older variant:
32.7859+ (defvar *post-upgrade-cleanup-hook* ())
32.7860+ ;; Private variable for post upgrade cleanup to communicate if an upgrade has
32.7861+ ;; actually occured.
32.7862+ (defvar *asdf-upgraded-p*)
32.7863+ ;; Private function to detect whether the current upgrade counts as an incompatible
32.7864+ ;; data schema upgrade implying the need to drop data.
32.7865+ (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*))
32.7866+ (and *previous-asdf-versions*
32.7867+ (version< (first *previous-asdf-versions*) oldest-compatible-version)))
32.7868+ ;; Private variant of defparameter that works in presence of incompatible upgrades:
32.7869+ ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change),
32.7870+ ;; but behaves like defparameter if in presence of an incompatible upgrade.
32.7871+ (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*))
32.7872+ (let* ((name (string-trim "*" var))
32.7873+ (valfun (intern (format nil "%~A-~A-~A" :compute name :value))))
32.7874+ `(progn
32.7875+ (defun ,valfun () ,value)
32.7876+ (defvar ,var (,valfun) ,@(ensure-list docstring))
32.7877+ (when (upgrading-p ,version)
32.7878+ (setf ,var (,valfun))))))
32.7879+ ;; Private macro to declare sections of code that are only compiled and run when upgrading.
32.7880+ ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects,
32.7881+ ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs.
32.7882+ (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*)
32.7883+ (upgrading-p `(upgrading-p ,version)) when) &body body)
32.7884+ "A wrapper macro for code that should only be run when upgrading a
32.7885+previously-loaded version of ASDF."
32.7886+ `(with-upgradability ()
32.7887+ (when (and ,upgrading-p ,@(when when `(,when)))
32.7888+ (handler-bind ((style-warning #'muffle-warning))
32.7889+ (eval '(progn ,@body))))))
32.7890+ ;; Only now can we safely update the version.
32.7891+ (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
32.7892+ ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8
32.7893+ ;; can help you do these changes in synch (look at the source for documentation).
32.7894+ ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp.
32.7895+ ;; "3.4" would be the general branch for major version 3, minor version 4.
32.7896+ ;; "3.4.5" would be an official release in the 3.4 branch.
32.7897+ ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
32.7898+ ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
32.7899+ ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
32.7900+ (asdf-version "3.3.6")
32.7901+ (existing-version (asdf-version)))
32.7902+ (setf *asdf-version* asdf-version)
32.7903+ (when (and existing-version (not (equal asdf-version existing-version)))
32.7904+ (push existing-version *previous-asdf-versions*)
32.7905+ (when (or *verbose-out* *load-verbose*)
32.7906+ (format (or *verbose-out* *trace-output*)
32.7907+ (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
32.7908+ existing-version asdf-version)))))
32.7909+
32.7910+;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined
32.7911+(when-upgrading ()
32.7912+ (let* ((previous-version (first *previous-asdf-versions*))
32.7913+ (redefined-functions ;; List of functions that changed incompatibly since 2.27:
32.7914+ ;; gf signature changed, defun that became a generic function (but not way around),
32.7915+ ;; method removed that will mess up with new ones
32.7916+ ;; (especially :around :before :after, more specific or call-next-method'ed method)
32.7917+ ;; and/or semantics otherwise modified. Oops.
32.7918+ ;; NB: it's too late to do anything about functions in UIOP!
32.7919+ ;; If you introduce some critical incompatibility there, you MUST change the function name.
32.7920+ ;; Note that we don't need do anything about functions that changed incompatibly
32.7921+ ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade.
32.7922+ ;; Also, the strong constraints apply most importantly for functions called from
32.7923+ ;; the continuation of compiling or loading some of the code in ASDF or UIOP.
32.7924+ ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36
32.7925+ ;; and at https://gitlab.common-lisp.net/asdf/asdf/-/merge_requests/141
32.7926+ `(,@(when (version< previous-version "2.31") '(#:normalize-version)) ;; pathname became &key
32.7927+ ,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2
32.7928+ ,@(when (version< previous-version "3.1.7.20") '(#:find-component)))) ;; added &key registered
32.7929+ (redefined-classes
32.7930+ ;; with the old ASDF during upgrade, and many implementations bork
32.7931+ (when (or #+(or clozure mkcl) t)
32.7932+ '((#:compile-concatenated-source-op (#:operation) ())
32.7933+ (#:compile-bundle-op (#:operation) ())
32.7934+ (#:concatenate-source-op (#:operation) ())
32.7935+ (#:dll-op (#:operation) ())
32.7936+ (#:lib-op (#:operation) ())
32.7937+ (#:monolithic-compile-bundle-op (#:operation) ())
32.7938+ (#:monolithic-concatenate-source-op (#:operation) ())))))
32.7939+ (loop :for name :in redefined-functions
32.7940+ :for sym = (find-symbol* name :asdf nil)
32.7941+ :do (when sym (fmakunbound sym)))
32.7942+ (labels ((asym (x) (multiple-value-bind (s p)
32.7943+ (if (consp x) (values (car x) (cadr x)) (values x :asdf))
32.7944+ (find-symbol* s p nil)))
32.7945+ (asyms (l) (mapcar #'asym l)))
32.7946+ (loop :for (name superclasses slots) :in redefined-classes
32.7947+ :for sym = (find-symbol* name :asdf nil)
32.7948+ :when (and sym (find-class sym))
32.7949+ :do #+ccl (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))
32.7950+ #-ccl (setf (find-class sym) nil))))) ;; mkcl
32.7951+
32.7952+;;; Self-upgrade functions
32.7953+(with-upgradability ()
32.7954+ ;; This private function is called at the end of asdf/footer and ensures that,
32.7955+ ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called.
32.7956+ (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*)))
32.7957+ (let ((new-version (asdf-version)))
32.7958+ (unless (equal old-version new-version)
32.7959+ (push new-version *previous-asdf-versions*)
32.7960+ (when (boundp '*asdf-upgraded-p*)
32.7961+ (setf *asdf-upgraded-p* t))
32.7962+ (when old-version
32.7963+ (if (version<= new-version old-version)
32.7964+ (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
32.7965+ old-version new-version)
32.7966+ (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
32.7967+ old-version new-version))
32.7968+ ;; In case the previous version was too old to be forward-compatible, clear systems.
32.7969+ ;; TODO: if needed, we may have to define a separate hook to run
32.7970+ ;; in case of forward-compatible upgrade.
32.7971+ ;; Or to move the tests forward-compatibility test inside each hook function?
32.7972+ (unless (version<= *oldest-forward-compatible-asdf-version* old-version)
32.7973+ (call-functions (reverse *post-upgrade-cleanup-hook*)))
32.7974+ t))))
32.7975+
32.7976+ (defun upgrade-asdf ()
32.7977+ "Try to upgrade of ASDF. If a different version was used, return T.
32.7978+ We need do that before we operate on anything that may possibly depend on ASDF."
32.7979+ (let ((*load-print* nil)
32.7980+ (*compile-print* nil)
32.7981+ (*asdf-upgraded-p* nil))
32.7982+ (handler-bind (((or style-warning) #'muffle-warning))
32.7983+ (symbol-call :asdf :load-system :asdf :verbose nil))
32.7984+ *asdf-upgraded-p*))
32.7985+
32.7986+ (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body)
32.7987+ `(with-upgradability ()
32.7988+ (with-deprecation ((version-deprecation *asdf-version* ,@keys))
32.7989+ ,@body))))
32.7990+;;;; -------------------------------------------------------------------------
32.7991+;;;; Session
32.7992+
32.7993+(uiop/package:define-package :asdf/session
32.7994+ (:recycle :asdf/session :asdf/cache :asdf/component
32.7995+ :asdf/action :asdf/find-system :asdf/plan :asdf)
32.7996+ (:use :uiop/common-lisp :uiop :asdf/upgrade)
32.7997+ (:export
32.7998+ #:get-file-stamp #:compute-file-stamp #:register-file-stamp
32.7999+ #:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
32.8000+ #:do-asdf-cache #:normalize-namestring
32.8001+ #:call-with-asdf-session #:with-asdf-session
32.8002+ #:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session
32.8003+ #:session-cache #:forcing #:asdf-upgraded-p
32.8004+ #:visited-actions #:visiting-action-set #:visiting-action-list
32.8005+ #:total-action-count #:planned-action-count #:planned-output-action-count
32.8006+ #:clear-configuration-and-retry #:retry
32.8007+ #:operate-level
32.8008+ ;; conditions
32.8009+ #:system-definition-error ;; top level, moved here because this is the earliest place for it.
32.8010+ #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error))
32.8011+(in-package :asdf/session)
32.8012+
32.8013+
32.8014+(with-upgradability ()
32.8015+ ;; The session variable.
32.8016+ ;; NIL when outside a session.
32.8017+ (defvar *asdf-session* nil)
32.8018+ (defparameter* *asdf-session-class* 'session
32.8019+ "The default class for sessions")
32.8020+
32.8021+ (defclass session ()
32.8022+ (;; The ASDF session cache is used to memoize some computations.
32.8023+ ;; It is instrumental in achieving:
32.8024+ ;; * Consistency in the view of the world relied on by ASDF within a given session.
32.8025+ ;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
32.8026+ ;; (a.k.a. stack overflows) and other erratic behavior.
32.8027+ ;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
32.8028+ ;; no expensive recomputations of transitive dependencies for input-files or output-files.
32.8029+ ;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
32.8030+ (ancestor
32.8031+ :initform nil :initarg :ancestor :reader session-ancestor
32.8032+ :documentation "Top level session that this is part of")
32.8033+ (session-cache
32.8034+ :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache
32.8035+ :documentation "Memoize expensive computations")
32.8036+ (operate-level
32.8037+ :initform 0 :initarg :operate-level :accessor session-operate-level
32.8038+ :documentation "Number of nested calls to operate we're under (for toplevel session only)")
32.8039+ ;; shouldn't the below be superseded by the session-wide caching of action-status
32.8040+ ;; for (load-op "asdf") ?
32.8041+ (asdf-upgraded-p
32.8042+ :initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p
32.8043+ :documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.")
32.8044+ (forcing
32.8045+ :initform nil :initarg :forcing :accessor forcing
32.8046+ :documentation "Forcing parameters for the session")
32.8047+ ;; Table that to actions already visited while walking the dependencies associates status
32.8048+ (visited-actions :initform (make-hash-table :test 'equal) :accessor visited-actions)
32.8049+ ;; Actions that depend on those being currently walked through, to detect circularities
32.8050+ (visiting-action-set ;; as a set
32.8051+ :initform (make-hash-table :test 'equal) :accessor visiting-action-set)
32.8052+ (visiting-action-list :initform () :accessor visiting-action-list) ;; as a list
32.8053+ ;; Counts of total actions in plan
32.8054+ (total-action-count :initform 0 :accessor total-action-count)
32.8055+ ;; Count of actions that need to be performed
32.8056+ (planned-action-count :initform 0 :accessor planned-action-count)
32.8057+ ;; Count of actions that need to be performed that have a non-empty list of output-files.
32.8058+ (planned-output-action-count :initform 0 :accessor planned-output-action-count))
32.8059+ (:documentation "An ASDF session with a cache to memoize some computations"))
32.8060+
32.8061+ (defun toplevel-asdf-session ()
32.8062+ (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*)))
32.8063+
32.8064+ (defun operate-level ()
32.8065+ (session-operate-level (toplevel-asdf-session)))
32.8066+
32.8067+ (defun (setf operate-level) (new-level)
32.8068+ (setf (session-operate-level (toplevel-asdf-session)) new-level))
32.8069+
32.8070+ (defun asdf-cache ()
32.8071+ (session-cache *asdf-session*))
32.8072+
32.8073+ ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
32.8074+ ;; Return those values.
32.8075+ (defun set-asdf-cache-entry (key value-list)
32.8076+ (values-list (if *asdf-session*
32.8077+ (setf (gethash key (asdf-cache)) value-list)
32.8078+ value-list)))
32.8079+
32.8080+ ;; Unset the session cache entry for KEY, when inside a session.
32.8081+ (defun unset-asdf-cache-entry (key)
32.8082+ (when *asdf-session*
32.8083+ (remhash key (session-cache *asdf-session*))))
32.8084+
32.8085+ ;; Consult the session cache entry for KEY if present and in a session;
32.8086+ ;; if not present, compute it by calling the THUNK,
32.8087+ ;; and set the session cache entry accordingly, if in a session.
32.8088+ ;; Return the values from the cache and/or the thunk computation.
32.8089+ (defun consult-asdf-cache (key &optional thunk)
32.8090+ (if *asdf-session*
32.8091+ (multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*))
32.8092+ (if foundp
32.8093+ (values-list results)
32.8094+ (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
32.8095+ (call-function thunk)))
32.8096+
32.8097+ ;; Syntactic sugar for consult-asdf-cache
32.8098+ (defmacro do-asdf-cache (key &body body)
32.8099+ `(consult-asdf-cache ,key #'(lambda () ,@body)))
32.8100+
32.8101+ ;; Compute inside a ASDF session with a cache.
32.8102+ ;; First, make sure an ASDF session is underway, by binding the session cache variable
32.8103+ ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true).
32.8104+ ;; Second, if a new session was started, establish restarts for retrying the overall computation.
32.8105+ ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache
32.8106+ ;; entry isn't found, or just call the THUNK if no KEY was specified.
32.8107+ (defun call-with-asdf-session (thunk &key override key override-cache override-forcing)
32.8108+ (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
32.8109+ (if (and (not override) *asdf-session*)
32.8110+ (funcall fun)
32.8111+ (loop
32.8112+ (restart-case
32.8113+ (let ((*asdf-session*
32.8114+ (apply 'make-instance *asdf-session-class*
32.8115+ (when *asdf-session*
32.8116+ `(:ancestor ,(toplevel-asdf-session)
32.8117+ ,@(unless override-forcing
32.8118+ `(:forcing ,(forcing *asdf-session*)))
32.8119+ ,@(unless override-cache
32.8120+ `(:session-cache ,(session-cache *asdf-session*))))))))
32.8121+ (return (funcall fun)))
32.8122+ (retry ()
32.8123+ :report (lambda (s)
32.8124+ (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
32.8125+ (clear-configuration-and-retry ()
32.8126+ :report (lambda (s)
32.8127+ (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
32.8128+ (unless (null *asdf-session*)
32.8129+ (clrhash (session-cache *asdf-session*)))
32.8130+ (clear-configuration)))))))
32.8131+
32.8132+ ;; Syntactic sugar for call-with-asdf-session
32.8133+ (defmacro with-asdf-session ((&key key override override-cache override-forcing) &body body)
32.8134+ `(call-with-asdf-session
32.8135+ #'(lambda () ,@body)
32.8136+ :override ,override :key ,key
32.8137+ :override-cache ,override-cache :override-forcing ,override-forcing))
32.8138+
32.8139+
32.8140+ ;;; Define specific accessor for file (date) stamp.
32.8141+
32.8142+ ;; Normalize a namestring for use as a key in the session cache.
32.8143+ (defun normalize-namestring (pathname)
32.8144+ (let ((resolved (resolve-symlinks*
32.8145+ (ensure-absolute-pathname
32.8146+ (physicalize-pathname pathname)
32.8147+ 'get-pathname-defaults))))
32.8148+ (with-pathname-defaults () (namestring resolved))))
32.8149+
32.8150+ ;; Compute the file stamp for a normalized namestring
32.8151+ (defun compute-file-stamp (normalized-namestring)
32.8152+ (with-pathname-defaults ()
32.8153+ (or (safe-file-write-date normalized-namestring) t)))
32.8154+
32.8155+ ;; Override the time STAMP associated to a given FILE in the session cache.
32.8156+ ;; If no STAMP is specified, recompute a new one from the filesystem.
32.8157+ (defun register-file-stamp (file &optional (stamp nil stampp))
32.8158+ (let* ((namestring (normalize-namestring file))
32.8159+ (stamp (if stampp stamp (compute-file-stamp namestring))))
32.8160+ (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
32.8161+
32.8162+ ;; Get or compute a memoized stamp for given FILE from the session cache.
32.8163+ (defun get-file-stamp (file)
32.8164+ (when file
32.8165+ (let ((namestring (normalize-namestring file)))
32.8166+ (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))
32.8167+
32.8168+
32.8169+ ;;; Conditions
32.8170+
32.8171+ (define-condition system-definition-error (error) ()
32.8172+ ;; [this use of :report should be redundant, but unfortunately it's not.
32.8173+ ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
32.8174+ ;; over print-object; this is always conditions::%print-condition for
32.8175+ ;; condition objects, which in turn does inheritance of :report options at
32.8176+ ;; run-time. fortunately, inheritance means we only need this kludge here in
32.8177+ ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
32.8178+ #+cmucl (:report print-object))
32.8179+
32.8180+ (define-condition formatted-system-definition-error (system-definition-error)
32.8181+ ((format-control :initarg :format-control :reader format-control)
32.8182+ (format-arguments :initarg :format-arguments :reader format-arguments))
32.8183+ (:report (lambda (c s)
32.8184+ (apply 'format s (format-control c) (format-arguments c)))))
32.8185+
32.8186+ (defun sysdef-error (format &rest arguments)
32.8187+ (error 'formatted-system-definition-error :format-control
32.8188+ format :format-arguments arguments)))
32.8189+;;;; -------------------------------------------------------------------------
32.8190+;;;; Components
32.8191+
32.8192+(uiop/package:define-package :asdf/component
32.8193+ (:recycle :asdf/component :asdf/find-component :asdf)
32.8194+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
32.8195+ (:export
32.8196+ #:component #:component-find-path
32.8197+ #:find-component ;; methods defined in find-component
32.8198+ #:component-name #:component-pathname #:component-relative-pathname
32.8199+ #:component-parent #:component-system #:component-parent-pathname
32.8200+ #:child-component #:parent-component #:module
32.8201+ #:file-component
32.8202+ #:source-file #:c-source-file #:java-source-file
32.8203+ #:static-file #:doc-file #:html-file
32.8204+ #:file-type
32.8205+ #:source-file-type #:source-file-explicit-type ;; backward-compatibility
32.8206+ #:component-in-order-to #:component-sideway-dependencies
32.8207+ #:component-if-feature #:around-compile-hook
32.8208+ #:component-description #:component-long-description
32.8209+ #:component-version #:version-satisfies
32.8210+ #:component-inline-methods ;; backward-compatibility only. DO NOT USE!
32.8211+ #:component-operation-times ;; For internal use only.
32.8212+ ;; portable ASDF encoding and implementation-specific external-format
32.8213+ #:component-external-format #:component-encoding
32.8214+ #:component-children-by-name #:component-children #:compute-children-by-name
32.8215+ #:component-build-operation
32.8216+ #:module-default-component-class
32.8217+ #:module-components ;; backward-compatibility. DO NOT USE.
32.8218+ #:sub-components
32.8219+
32.8220+ ;; conditions
32.8221+ #:duplicate-names
32.8222+
32.8223+ ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
32.8224+ #:name #:version #:description #:long-description #:author #:maintainer #:licence
32.8225+ #:components-by-name #:components #:children #:children-by-name
32.8226+ #:default-component-class #:source-file
32.8227+ #:defsystem-depends-on ; This symbol retained for backward compatibility.
32.8228+ #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
32.8229+ #:relative-pathname #:absolute-pathname #:operation-times #:around-compile
32.8230+ #:%encoding #:properties #:component-properties #:parent))
32.8231+(in-package :asdf/component)
32.8232+
32.8233+(with-upgradability ()
32.8234+ (defgeneric component-name (component)
32.8235+ (:documentation "Name of the COMPONENT, unique relative to its parent"))
32.8236+ (defgeneric component-system (component)
32.8237+ (:documentation "Top-level system containing the COMPONENT"))
32.8238+ (defgeneric component-pathname (component)
32.8239+ (:documentation "Pathname of the COMPONENT if any, or NIL."))
32.8240+ (defgeneric component-relative-pathname (component)
32.8241+ ;; in ASDF4, rename that to component-specified-pathname ?
32.8242+ (:documentation "Specified pathname of the COMPONENT,
32.8243+intended to be merged with the pathname of that component's parent if any, using merged-pathnames*.
32.8244+Despite the function's name, the return value can be an absolute pathname, in which case the merge
32.8245+will leave it unmodified."))
32.8246+ (defgeneric component-external-format (component)
32.8247+ (:documentation "The external-format of the COMPONENT.
32.8248+By default, deduced from the COMPONENT-ENCODING."))
32.8249+ (defgeneric component-encoding (component)
32.8250+ (:documentation "The encoding of the COMPONENT. By default, only :utf-8 is supported.
32.8251+Use asdf-encodings to support more encodings."))
32.8252+ (defgeneric version-satisfies (component version)
32.8253+ (:documentation "Check whether a COMPONENT satisfies the constraint of being at least as recent
32.8254+as the specified VERSION, which must be a string of dot-separated natural numbers, or NIL."))
32.8255+ (defgeneric component-version (component)
32.8256+ (:documentation "Return the version of a COMPONENT, which must be a string of dot-separated
32.8257+natural numbers, or NIL."))
32.8258+ (defgeneric (setf component-version) (new-version component)
32.8259+ (:documentation "Updates the version of a COMPONENT, which must be a string of dot-separated
32.8260+natural numbers, or NIL."))
32.8261+ (defgeneric component-parent (component)
32.8262+ (:documentation "The parent of a child COMPONENT,
32.8263+or NIL for top-level components (a.k.a. systems)"))
32.8264+ ;; NIL is a designator for the absence of a component, in which case the parent is also absent.
32.8265+ (defmethod component-parent ((component null)) nil)
32.8266+
32.8267+ ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component.
32.8268+ (with-asdf-deprecation (:style-warning "3.4")
32.8269+ (defgeneric source-file-type (component system)
32.8270+ (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead.")))
32.8271+
32.8272+ (define-condition duplicate-names (system-definition-error)
32.8273+ ((name :initarg :name :reader duplicate-names-name))
32.8274+ (:report (lambda (c s)
32.8275+ (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
32.8276+ (duplicate-names-name c))))))
32.8277+
32.8278+
32.8279+(with-upgradability ()
32.8280+ (defclass component ()
32.8281+ ((name :accessor component-name :initarg :name :type string :documentation
32.8282+ "Component name: designator for a string composed of portable pathname characters")
32.8283+ ;; We might want to constrain version with
32.8284+ ;; :type (and string (satisfies parse-version))
32.8285+ ;; but we cannot until we fix all systems that don't use it correctly!
32.8286+ (version :accessor component-version :initarg :version :initform nil)
32.8287+ (description :accessor component-description :initarg :description :initform nil)
32.8288+ (long-description :accessor component-long-description :initarg :long-description :initform nil)
32.8289+ (sideway-dependencies :accessor component-sideway-dependencies :initform nil)
32.8290+ (if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
32.8291+ ;; In the ASDF object model, dependencies exist between *actions*,
32.8292+ ;; where an action is a pair of an operation and a component.
32.8293+ ;; Dependencies are represented as alists of operations
32.8294+ ;; to a list where each entry is a pair of an operation and a list of component specifiers.
32.8295+ ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies:
32.8296+ ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to.
32.8297+ ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl)
32.8298+ ;; and do-first things that modify the current image (such as loading a fasl).
32.8299+ ;; These are now unified because we now correctly propagate timestamps between dependencies.
32.8300+ ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017,
32.8301+ ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains.
32.8302+ ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52!
32.8303+ ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
32.8304+ ;; Maybe rename the slots in ASDF? But that's not very backward-compatible.
32.8305+ ;; See our ASDF 2 paper for more complete explanations.
32.8306+ (in-order-to :initform nil :initarg :in-order-to
32.8307+ :accessor component-in-order-to)
32.8308+ ;; Methods defined using the "inline" style inside a defsystem form:
32.8309+ ;; we store them here so we can delete them when the system is re-evaluated.
32.8310+ (inline-methods :accessor component-inline-methods :initform nil)
32.8311+ ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative.
32.8312+ ;; There is no initform and no direct accessor for this specified pathname,
32.8313+ ;; so we only access the information through appropriate methods, after it has been processed.
32.8314+ ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4.
32.8315+ (relative-pathname :initarg :pathname)
32.8316+ ;; The absolute-pathname is computed based on relative-pathname and parent pathname.
32.8317+ ;; The slot is but a cache used by component-pathname.
32.8318+ (absolute-pathname)
32.8319+ (operation-times :initform (make-hash-table)
32.8320+ :accessor component-operation-times)
32.8321+ (around-compile :initarg :around-compile)
32.8322+ ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE!
32.8323+ (properties :accessor component-properties :initarg :properties
32.8324+ :initform nil)
32.8325+ (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
32.8326+ ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it.
32.8327+ (parent :initarg :parent :initform nil :reader component-parent)
32.8328+ (build-operation
32.8329+ :initarg :build-operation :initform nil :reader component-build-operation)
32.8330+ ;; Cache for ADDITIONAL-INPUT-FILES function.
32.8331+ (additional-input-files :accessor %additional-input-files :initform nil))
32.8332+ (:documentation "Base class for all components of a build"))
32.8333+
32.8334+ (defgeneric find-component (base path &key registered)
32.8335+ (:documentation "Find a component by resolving the PATH starting from BASE parent.
32.8336+If REGISTERED is true, only search currently registered systems."))
32.8337+
32.8338+ (defun component-find-path (component)
32.8339+ "Return a path from a root system to the COMPONENT.
32.8340+The return value is a list of component NAMES; a list of strings."
32.8341+ (check-type component (or null component))
32.8342+ (reverse
32.8343+ (loop :for c = component :then (component-parent c)
32.8344+ :while c :collect (component-name c))))
32.8345+
32.8346+ (defmethod print-object ((c component) stream)
32.8347+ (print-unreadable-object (c stream :type t :identity nil)
32.8348+ (format stream "~{~S~^ ~}" (component-find-path c))))
32.8349+
32.8350+ (defmethod component-system ((component component))
32.8351+ (if-let (system (component-parent component))
32.8352+ (component-system system)
32.8353+ component)))
32.8354+
32.8355+
32.8356+;;;; Component hierarchy within a system
32.8357+;; The tree typically but not necessarily follows the filesystem hierarchy.
32.8358+(with-upgradability ()
32.8359+ (defclass child-component (component) ()
32.8360+ (:documentation "A CHILD-COMPONENT is a COMPONENT that may be part of
32.8361+a PARENT-COMPONENT."))
32.8362+
32.8363+ (defclass file-component (child-component)
32.8364+ ((type :accessor file-type :initarg :type)) ; no default
32.8365+ (:documentation "a COMPONENT that represents a file"))
32.8366+ (defclass source-file (file-component)
32.8367+ ((type :accessor source-file-explicit-type ;; backward-compatibility
32.8368+ :initform nil))) ;; NB: many systems have come to rely on this default.
32.8369+ (defclass c-source-file (source-file)
32.8370+ ((type :initform "c")))
32.8371+ (defclass java-source-file (source-file)
32.8372+ ((type :initform "java")))
32.8373+ (defclass static-file (source-file)
32.8374+ ((type :initform nil))
32.8375+ (:documentation "Component for a file to be included as is in the build output"))
32.8376+ (defclass doc-file (static-file) ())
32.8377+ (defclass html-file (doc-file)
32.8378+ ((type :initform "html")))
32.8379+
32.8380+ (defclass parent-component (component)
32.8381+ ((children
32.8382+ :initform nil
32.8383+ :initarg :components
32.8384+ :reader module-components ; backward-compatibility
32.8385+ :accessor component-children)
32.8386+ (children-by-name
32.8387+ :reader module-components-by-name ; backward-compatibility
32.8388+ :accessor component-children-by-name)
32.8389+ (default-component-class
32.8390+ :initform nil
32.8391+ :initarg :default-component-class
32.8392+ :accessor module-default-component-class))
32.8393+ (:documentation "A PARENT-COMPONENT is a component that may have children.")))
32.8394+
32.8395+(with-upgradability ()
32.8396+ ;; (Private) Function that given a PARENT component,
32.8397+ ;; the list of children of which has been initialized,
32.8398+ ;; compute the hash-table in slot children-by-name that allows to retrieve its children by name.
32.8399+ ;; If ONLY-IF-NEEDED-P is defined, skip any (re)computation if the slot is already populated.
32.8400+ (defun compute-children-by-name (parent &key only-if-needed-p)
32.8401+ (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
32.8402+ (let ((hash (make-hash-table :test 'equal)))
32.8403+ (setf (component-children-by-name parent) hash)
32.8404+ (loop :for c :in (component-children parent)
32.8405+ :for name = (component-name c)
32.8406+ :for previous = (gethash name hash)
32.8407+ :do (when previous (error 'duplicate-names :name name))
32.8408+ (setf (gethash name hash) c))
32.8409+ hash))))
32.8410+
32.8411+(with-upgradability ()
32.8412+ (defclass module (child-component parent-component)
32.8413+ (#+clisp (components)) ;; backward compatibility during upgrade only
32.8414+ (:documentation "A module is a intermediate component with both a parent and children,
32.8415+typically but not necessarily representing the files in a subdirectory of the build source.")))
32.8416+
32.8417+
32.8418+;;;; component pathnames
32.8419+(with-upgradability ()
32.8420+ (defgeneric component-parent-pathname (component)
32.8421+ (:documentation "The pathname of the COMPONENT's parent, if any, or NIL"))
32.8422+ (defmethod component-parent-pathname (component)
32.8423+ (component-pathname (component-parent component)))
32.8424+
32.8425+ ;; The default method for component-pathname tries to extract a cached precomputed
32.8426+ ;; absolute-pathname from the relevant slot, and if not, computes it by merging the
32.8427+ ;; component-relative-pathname (which should be component-specified-pathname, it can be absolute)
32.8428+ ;; with the directory of the component-parent-pathname.
32.8429+ (defmethod component-pathname ((component component))
32.8430+ (if (slot-boundp component 'absolute-pathname)
32.8431+ (slot-value component 'absolute-pathname)
32.8432+ (let ((pathname
32.8433+ (merge-pathnames*
32.8434+ (component-relative-pathname component)
32.8435+ (pathname-directory-pathname (component-parent-pathname component)))))
32.8436+ (unless (or (null pathname) (absolute-pathname-p pathname))
32.8437+ (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
32.8438+ pathname (component-find-path component)))
32.8439+ (setf (slot-value component 'absolute-pathname) pathname)
32.8440+ pathname)))
32.8441+
32.8442+ ;; Default method for component-relative-pathname:
32.8443+ ;; combine the contents of slot relative-pathname (from specified initarg :pathname)
32.8444+ ;; with the appropriate source-file-type, which defaults to the file-type of the component.
32.8445+ (defmethod component-relative-pathname ((component component))
32.8446+ ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
32.8447+ ;; We ought to be able to extract this from the component alone with FILE-TYPE.
32.8448+ ;; TODO: track who uses it in Quicklisp, and have them not use it anymore;
32.8449+ ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
32.8450+ (let (#+abcl
32.8451+ (parent
32.8452+ (component-parent-pathname component)))
32.8453+ (parse-unix-namestring
32.8454+ (or (and (slot-boundp component 'relative-pathname)
32.8455+ (slot-value component 'relative-pathname))
32.8456+ (component-name component))
32.8457+ :want-relative
32.8458+ #-abcl t
32.8459+ ;; JAR-PATHNAMES always have absolute directories
32.8460+ #+abcl (not (ext:pathname-jar-p parent))
32.8461+ :type (source-file-type component (component-system component))
32.8462+ :defaults (component-parent-pathname component))))
32.8463+
32.8464+ (defmethod source-file-type ((component parent-component) (system parent-component))
32.8465+ :directory)
32.8466+
32.8467+ (defmethod source-file-type ((component file-component) (system parent-component))
32.8468+ (file-type component)))
32.8469+
32.8470+
32.8471+;;;; Encodings
32.8472+(with-upgradability ()
32.8473+ (defmethod component-encoding ((c component))
32.8474+ (or (loop :for x = c :then (component-parent x)
32.8475+ :while x :thereis (%component-encoding x))
32.8476+ (detect-encoding (component-pathname c))))
32.8477+
32.8478+ (defmethod component-external-format ((c component))
32.8479+ (encoding-external-format (component-encoding c))))
32.8480+
32.8481+
32.8482+;;;; around-compile-hook
32.8483+(with-upgradability ()
32.8484+ (defgeneric around-compile-hook (component)
32.8485+ (:documentation "An optional hook function that will be called with one argument, a thunk.
32.8486+The hook function must call the thunk, that will compile code from the component, and may or may not
32.8487+also evaluate the compiled results. The hook function may establish dynamic variable bindings around
32.8488+this compilation, or check its results, etc."))
32.8489+ (defmethod around-compile-hook ((c component))
32.8490+ (cond
32.8491+ ((slot-boundp c 'around-compile)
32.8492+ (slot-value c 'around-compile))
32.8493+ ((component-parent c)
32.8494+ (around-compile-hook (component-parent c))))))
32.8495+
32.8496+
32.8497+;;;; version-satisfies
32.8498+(with-upgradability ()
32.8499+ ;; short-circuit testing of null version specifications.
32.8500+ ;; this is an all-pass, without warning
32.8501+ (defmethod version-satisfies :around ((c t) (version null))
32.8502+ t)
32.8503+ (defmethod version-satisfies ((c component) version)
32.8504+ (unless (and version (slot-boundp c 'version) (component-version c))
32.8505+ (when version
32.8506+ (warn "Requested version ~S but ~S has no version" version c))
32.8507+ (return-from version-satisfies nil))
32.8508+ (version-satisfies (component-version c) version))
32.8509+
32.8510+ (defmethod version-satisfies ((cver string) version)
32.8511+ (version<= version cver)))
32.8512+
32.8513+
32.8514+;;; all sub-components (of a given type)
32.8515+(with-upgradability ()
32.8516+ (defun sub-components (component &key (type t))
32.8517+ "Compute the transitive sub-components of given COMPONENT that are of given TYPE"
32.8518+ (while-collecting (c)
32.8519+ (labels ((recurse (x)
32.8520+ (when (if-let (it (component-if-feature x)) (featurep it) t)
32.8521+ (when (typep x type)
32.8522+ (c x))
32.8523+ (when (typep x 'parent-component)
32.8524+ (map () #'recurse (component-children x))))))
32.8525+ (recurse component)))))
32.8526+
32.8527+;;;; -------------------------------------------------------------------------
32.8528+;;;; Operations
32.8529+
32.8530+(uiop/package:define-package :asdf/operation
32.8531+ (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
32.8532+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
32.8533+ (:export
32.8534+ #:operation
32.8535+ #:*operations* #:make-operation #:find-operation
32.8536+ #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature.
32.8537+(in-package :asdf/operation)
32.8538+
32.8539+;;; Operation Classes
32.8540+(when-upgrading (:version "2.27" :when (find-class 'operation nil))
32.8541+ ;; override any obsolete shared-initialize method when upgrading from ASDF2.
32.8542+ (defmethod shared-initialize :after ((o operation) (slot-names t) &key)
32.8543+ (values)))
32.8544+
32.8545+(with-upgradability ()
32.8546+ (defclass operation ()
32.8547+ ()
32.8548+ (:documentation "The base class for all ASDF operations.
32.8549+
32.8550+ASDF does NOT and never did distinguish between multiple operations of the same class.
32.8551+Therefore, all slots of all operations MUST have :allocation :class and no initargs. No exceptions.
32.8552+"))
32.8553+
32.8554+ (defvar *in-make-operation* nil)
32.8555+
32.8556+ (defun check-operation-constructor ()
32.8557+ "Enforce that OPERATION instances must be created with MAKE-OPERATION."
32.8558+ (unless *in-make-operation*
32.8559+ (sysdef-error "OPERATION instances must only be created through MAKE-OPERATION.")))
32.8560+
32.8561+ (defmethod print-object ((o operation) stream)
32.8562+ (print-unreadable-object (o stream :type t :identity nil)))
32.8563+
32.8564+ ;;; Override previous methods (from 3.1.7 and earlier) and add proper error checking.
32.8565+ #-genera ;; Genera adds its own system initargs, e.g. clos-internals:storage-area 8
32.8566+ (defmethod initialize-instance :after ((o operation) &rest initargs &key &allow-other-keys)
32.8567+ (unless (null initargs)
32.8568+ (parameter-error "~S does not accept initargs" 'operation))))
32.8569+
32.8570+
32.8571+;;; make-operation, find-operation
32.8572+
32.8573+(with-upgradability ()
32.8574+ ;; A table to memoize instances of a given operation. There shall be only one.
32.8575+ (defparameter* *operations* (make-hash-table :test 'equal))
32.8576+
32.8577+ ;; A memoizing way of creating instances of operation.
32.8578+ (defun make-operation (operation-class)
32.8579+ "This function creates and memoizes an instance of OPERATION-CLASS.
32.8580+All operation instances MUST be created through this function.
32.8581+
32.8582+Use of INITARGS is not supported at this time."
32.8583+ (let ((class (coerce-class operation-class
32.8584+ :package :asdf/interface :super 'operation :error 'sysdef-error))
32.8585+ (*in-make-operation* t))
32.8586+ (ensure-gethash class *operations* `(make-instance ,class))))
32.8587+
32.8588+ ;; This function is mostly for backward and forward compatibility:
32.8589+ ;; operations used to preserve the operation-original-initargs of the context,
32.8590+ ;; and may in the future preserve some operation-canonical-initargs.
32.8591+ ;; Still, the treatment of NIL as a disabling context is useful in some cases.
32.8592+ (defgeneric find-operation (context spec)
32.8593+ (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
32.8594+ (defmethod find-operation ((context t) (spec operation))
32.8595+ spec)
32.8596+ (defmethod find-operation ((context t) (spec symbol))
32.8597+ (when spec ;; NIL designates itself, i.e. absence of operation
32.8598+ (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context)
32.8599+ (defmethod find-operation ((context t) (spec string))
32.8600+ (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context)
32.8601+
32.8602+;;;; -------------------------------------------------------------------------
32.8603+;;;; Systems
32.8604+
32.8605+(uiop/package:define-package :asdf/system
32.8606+ (:recycle :asdf :asdf/system :asdf/find-system)
32.8607+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component)
32.8608+ (:export
32.8609+ #:system #:proto-system #:undefined-system #:reset-system-class
32.8610+ #:system-source-file #:system-source-directory #:system-relative-pathname
32.8611+ #:system-description #:system-long-description
32.8612+ #:system-author #:system-maintainer #:system-licence #:system-license
32.8613+ #:system-version
32.8614+ #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on
32.8615+ #:system-depends-on #:system-weakly-depends-on
32.8616+ #:component-build-pathname #:build-pathname
32.8617+ #:component-entry-point #:entry-point
32.8618+ #:homepage #:system-homepage
32.8619+ #:bug-tracker #:system-bug-tracker
32.8620+ #:mailto #:system-mailto
32.8621+ #:long-name #:system-long-name
32.8622+ #:source-control #:system-source-control
32.8623+ #:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename
32.8624+ #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system
32.8625+(in-package :asdf/system)
32.8626+
32.8627+(with-upgradability ()
32.8628+ ;; The method is actually defined in asdf/find-system,
32.8629+ ;; but we declare the function here to avoid a forward reference.
32.8630+ (defgeneric find-system (system &optional error-p)
32.8631+ (:documentation "Given a system designator, find the actual corresponding system object.
32.8632+If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL.
32.8633+A system designator is usually a string (conventionally all lowercase) or a symbol, designating
32.8634+the same system as its downcased name; it can also be a system object (designating itself)."))
32.8635+
32.8636+ (defgeneric system-source-file (system)
32.8637+ (:documentation "Return the source file in which system is defined."))
32.8638+
32.8639+ ;; This is bad design, but was the easiest kluge I found to let the user specify that
32.8640+ ;; some special actions create outputs at locations controled by the user that are not affected
32.8641+ ;; by the usual output-translations.
32.8642+ ;; TODO: Fix operate to stop passing flags to operation (which in the current design shouldn't
32.8643+ ;; have any flags, since the stamp cache, etc., can't distinguish them), and instead insert
32.8644+ ;; *there* the ability of specifying special output paths, not in the system definition.
32.8645+ (defgeneric component-build-pathname (component)
32.8646+ (:documentation "The COMPONENT-BUILD-PATHNAME, when defined and not null, specifies the
32.8647+output pathname for the action using the COMPONENT-BUILD-OPERATION.
32.8648+
32.8649+NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
32.8650+
32.8651+ ;; TODO: Should this have been made a SYSTEM-ENTRY-POINT instead?
32.8652+ (defgeneric component-entry-point (component)
32.8653+ (:documentation "The COMPONENT-ENTRY-POINT, when defined, specifies what function to call
32.8654+(with no argument) when running an image dumped from the COMPONENT.
32.8655+
32.8656+NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
32.8657+
32.8658+ (defmethod component-entry-point ((c component))
32.8659+ nil))
32.8660+
32.8661+
32.8662+;;;; The system class
32.8663+
32.8664+(with-upgradability ()
32.8665+ (defclass proto-system () ; slots to keep when resetting a system
32.8666+ ;; To preserve identity for all objects, we'd need keep the components slots
32.8667+ ;; but also to modify parse-component-form to reset the recycled objects.
32.8668+ ((name)
32.8669+ (source-file)
32.8670+ ;; These two slots contains the *inferred* dependencies of define-op,
32.8671+ ;; from loading the .asd file, as list and as set.
32.8672+ (definition-dependency-list
32.8673+ :initform nil :accessor definition-dependency-list)
32.8674+ (definition-dependency-set
32.8675+ :initform (list-to-hash-set nil) :accessor definition-dependency-set))
32.8676+ (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when
32.8677+a SYSTEM is redefined and its class is modified."))
32.8678+
32.8679+ (defclass system (module proto-system)
32.8680+ ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component.
32.8681+ (;; {,long-}description is now inherited from component, but we add the legacy accessors
32.8682+ (description :writer (setf system-description))
32.8683+ (long-description :writer (setf system-long-description))
32.8684+ (author :writer (setf system-author) :initarg :author :initform nil)
32.8685+ (maintainer :writer (setf system-maintainer) :initarg :maintainer :initform nil)
32.8686+ (licence :writer (setf system-licence) :initarg :licence
32.8687+ :writer (setf system-license) :initarg :license
32.8688+ :initform nil)
32.8689+ (homepage :writer (setf system-homepage) :initarg :homepage :initform nil)
32.8690+ (bug-tracker :writer (setf system-bug-tracker) :initarg :bug-tracker :initform nil)
32.8691+ (mailto :writer (setf system-mailto) :initarg :mailto :initform nil)
32.8692+ (long-name :writer (setf system-long-name) :initarg :long-name :initform nil)
32.8693+ ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced.
32.8694+ ;; I'm introducing the slot before the conventions are set for maximum compatibility.
32.8695+ (source-control :writer (setf system-source-control) :initarg :source-control :initform nil)
32.8696+
32.8697+ (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)
32.8698+ (build-pathname
32.8699+ :initform nil :initarg :build-pathname :accessor component-build-pathname)
32.8700+ (entry-point
32.8701+ :initform nil :initarg :entry-point :accessor component-entry-point)
32.8702+ (source-file :initform nil :initarg :source-file :accessor system-source-file)
32.8703+ ;; This slot contains the *declared* defsystem-depends-on dependencies
32.8704+ (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
32.8705+ :initform nil)
32.8706+ ;; these two are specially set in parse-component-form, so have no :INITARGs.
32.8707+ (depends-on :reader system-depends-on :initform nil)
32.8708+ (weakly-depends-on :reader system-weakly-depends-on :initform nil))
32.8709+ (:documentation "SYSTEM is the base class for top-level components that users may request
32.8710+ASDF to build."))
32.8711+
32.8712+ (defclass undefined-system (system) ()
32.8713+ (:documentation "System that was not defined yet."))
32.8714+
32.8715+ (defun reset-system-class (system new-class &rest keys &key &allow-other-keys)
32.8716+ "Erase any data from a SYSTEM except its basic identity, then reinitialize it
32.8717+based on supplied KEYS."
32.8718+ (change-class (change-class system 'proto-system) new-class)
32.8719+ (apply 'reinitialize-instance system keys)))
32.8720+
32.8721+
32.8722+;;; Canonicalizing system names
32.8723+
32.8724+(with-upgradability ()
32.8725+ (defun coerce-name (name)
32.8726+ "Given a designator for a component NAME, return the name as a string.
32.8727+The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component),
32.8728+a SYMBOL (designing its name, downcased), or a STRING (designing itself)."
32.8729+ (typecase name
32.8730+ (component (component-name name))
32.8731+ (symbol (string-downcase name))
32.8732+ (string name)
32.8733+ (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
32.8734+
32.8735+ (defun primary-system-name (system-designator)
32.8736+ "Given a system designator NAME, return the name of the corresponding
32.8737+primary system, after which the .asd file in which it is defined is named.
32.8738+If given a string or symbol (to downcase), do it syntactically
32.8739+ by stripping anything from the first slash on.
32.8740+If given a component, do it semantically by extracting
32.8741+the system-primary-system-name of its system from its source-file if any,
32.8742+falling back to the syntactic criterion if none."
32.8743+ (etypecase system-designator
32.8744+ (string (if-let (p (position #\/ system-designator))
32.8745+ (subseq system-designator 0 p) system-designator))
32.8746+ (symbol (primary-system-name (coerce-name system-designator)))
32.8747+ (component (let* ((system (component-system system-designator))
32.8748+ (source-file (physicalize-pathname (system-source-file system))))
32.8749+ (if source-file
32.8750+ (and (equal (pathname-type source-file) "asd")
32.8751+ (pathname-name source-file))
32.8752+ (primary-system-name (component-name system)))))))
32.8753+
32.8754+ (defun primary-system-p (system)
32.8755+ "Given a system designator SYSTEM, return T if it designates a primary system, or else NIL.
32.8756+If given a string, do it syntactically and return true if the name does not contain a slash.
32.8757+If given a symbol, downcase to a string then fallback to previous case (NB: for NIL return T).
32.8758+If given a component, do it semantically and return T if it's a SYSTEM and its primary-system-name
32.8759+is the same as its component-name."
32.8760+ (etypecase system
32.8761+ (string (not (find #\/ system)))
32.8762+ (symbol (primary-system-p (coerce-name system)))
32.8763+ (component (and (typep system 'system)
32.8764+ (equal (component-name system) (primary-system-name system))))))
32.8765+
32.8766+ (defun coerce-filename (name)
32.8767+ "Coerce a system designator NAME into a string suitable as a filename component.
32.8768+The (current) transformation is to replace characters /:\\ each by --,
32.8769+the former being forbidden in a filename component.
32.8770+NB: The onus is unhappily on the user to avoid clashes."
32.8771+ (frob-substrings (coerce-name name) '("/" ":" "\\") "--")))
32.8772+
32.8773+
32.8774+;;; System virtual slot readers, recursing to the primary system if needed.
32.8775+(with-upgradability ()
32.8776+ (defvar *system-virtual-slots* '(long-name description long-description
32.8777+ author maintainer mailto
32.8778+ homepage source-control
32.8779+ licence version bug-tracker)
32.8780+ "The list of system virtual slot names.")
32.8781+ (defun system-virtual-slot-value (system slot-name)
32.8782+ "Return SYSTEM's virtual SLOT-NAME value.
32.8783+If SYSTEM's SLOT-NAME value is NIL and SYSTEM is a secondary system, look in
32.8784+the primary one."
32.8785+ (or (slot-value system slot-name)
32.8786+ (unless (primary-system-p system)
32.8787+ (slot-value (find-system (primary-system-name system))
32.8788+ slot-name))))
32.8789+ (defmacro define-system-virtual-slot-reader (slot-name)
32.8790+ (let ((name (intern (strcat (string :system-) (string slot-name)))))
32.8791+ `(progn
32.8792+ (fmakunbound ',name) ;; These were gf from defgeneric before 3.3.2.11
32.8793+ (declaim (notinline ,name))
32.8794+ (defun ,name (system) (system-virtual-slot-value system ',slot-name)))))
32.8795+ (defmacro define-system-virtual-slot-readers ()
32.8796+ `(progn ,@(mapcar (lambda (slot-name)
32.8797+ `(define-system-virtual-slot-reader ,slot-name))
32.8798+ *system-virtual-slots*)))
32.8799+ (define-system-virtual-slot-readers)
32.8800+ (defun system-license (system)
32.8801+ (system-virtual-slot-value system 'licence)))
32.8802+
32.8803+
32.8804+;;;; Pathnames
32.8805+
32.8806+(with-upgradability ()
32.8807+ ;; Resolve a system designator to a system before extracting its system-source-file
32.8808+ (defmethod system-source-file ((system-name string))
32.8809+ (system-source-file (find-system system-name)))
32.8810+ (defmethod system-source-file ((system-name symbol))
32.8811+ (when system-name
32.8812+ (system-source-file (find-system system-name))))
32.8813+
32.8814+ (defun system-source-directory (system-designator)
32.8815+ "Return a pathname object corresponding to the directory
32.8816+in which the system specification (.asd file) is located."
32.8817+ (pathname-directory-pathname (system-source-file system-designator)))
32.8818+
32.8819+ (defun system-relative-pathname (system name &key type)
32.8820+ "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
32.8821+return the absolute pathname of a corresponding file under that system's source code pathname."
32.8822+ (subpathname (system-source-directory system) name :type type))
32.8823+
32.8824+ (defmethod component-pathname ((system system))
32.8825+ "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
32.8826+return the absolute pathname of a corresponding file under that system's source code pathname."
32.8827+ (let ((pathname (or (call-next-method) (system-source-directory system))))
32.8828+ (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age
32.8829+ (slot-value system 'relative-pathname)) ;; systems that directly access this slot.
32.8830+ (setf (slot-value system 'relative-pathname) pathname))
32.8831+ pathname))
32.8832+
32.8833+ ;; The default method of component-relative-pathname for a system:
32.8834+ ;; if a pathname was specified in the .asd file, it must be relative to the .asd file
32.8835+ ;; (actually, to its truename* if *resolve-symlinks* it true, the default).
32.8836+ ;; The method will return an *absolute* pathname, once again showing that the historical name
32.8837+ ;; component-relative-pathname is misleading and should have been component-specified-pathname.
32.8838+ (defmethod component-relative-pathname ((system system))
32.8839+ (parse-unix-namestring
32.8840+ (and (slot-boundp system 'relative-pathname)
32.8841+ (slot-value system 'relative-pathname))
32.8842+ :want-relative t
32.8843+ :type :directory
32.8844+ :ensure-absolute t
32.8845+ :defaults (system-source-directory system)))
32.8846+
32.8847+ ;; A system has no parent; if some method wants to make a path "relative to its parent",
32.8848+ ;; it will instead be relative to the system itself.
32.8849+ (defmethod component-parent-pathname ((system system))
32.8850+ (system-source-directory system))
32.8851+
32.8852+ ;; Most components don't have a specified component-build-pathname, and therefore
32.8853+ ;; no magic redirection of their output that disregards the output-translations.
32.8854+ (defmethod component-build-pathname ((c component))
32.8855+ nil))
32.8856+
32.8857+;;;; -------------------------------------------------------------------------
32.8858+;;;; Finding systems
32.8859+
32.8860+(uiop/package:define-package :asdf/system-registry
32.8861+ (:recycle :asdf/system-registry :asdf/find-system :asdf)
32.8862+ (:use :uiop/common-lisp :uiop :asdf/upgrade
32.8863+ :asdf/session :asdf/component :asdf/system)
32.8864+ (:export
32.8865+ #:remove-entry-from-registry #:coerce-entry-to-directory
32.8866+ #:registered-system #:register-system
32.8867+ #:registered-systems* #:registered-systems
32.8868+ #:clear-system #:map-systems
32.8869+ #:*system-definition-search-functions* #:search-for-system-definition
32.8870+ #:*central-registry* #:probe-asd #:sysdef-central-registry-search
32.8871+ #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
32.8872+ #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
32.8873+ #:find-system-if-being-defined #:mark-component-preloaded ;; forward references to asdf/find-system
32.8874+ #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems*
32.8875+ #:*registered-systems* #:clear-registered-systems
32.8876+ ;; defined in source-registry, but specially mentioned here:
32.8877+ #:sysdef-source-registry-search))
32.8878+(in-package :asdf/system-registry)
32.8879+
32.8880+(with-upgradability ()
32.8881+ ;;; Registry of Defined Systems
32.8882+
32.8883+ (defvar *registered-systems* (make-hash-table :test 'equal)
32.8884+ "This is a hash table whose keys are strings -- the names of systems --
32.8885+and whose values are systems.
32.8886+A system is referred to as \"registered\" if it is present in this table.")
32.8887+
32.8888+ (defun registered-system (name)
32.8889+ "Return a system of given NAME that was registered already,
32.8890+if such a system exists. NAME is a system designator, to be
32.8891+normalized by COERCE-NAME. The value returned is a system object,
32.8892+or NIL if not found."
32.8893+ (gethash (coerce-name name) *registered-systems*))
32.8894+
32.8895+ (defun registered-systems* ()
32.8896+ "Return a list containing every registered system (as a system object)."
32.8897+ (loop :for registered :being :the :hash-values :of *registered-systems*
32.8898+ :collect registered))
32.8899+
32.8900+ (defun registered-systems ()
32.8901+ "Return a list of the names of every registered system."
32.8902+ (mapcar 'coerce-name (registered-systems*)))
32.8903+
32.8904+ (defun register-system (system)
32.8905+ "Given a SYSTEM object, register it."
32.8906+ (check-type system system)
32.8907+ (let ((name (component-name system)))
32.8908+ (check-type name string)
32.8909+ (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name)
32.8910+ (setf (gethash name *registered-systems*) system)))
32.8911+
32.8912+ (defun map-systems (fn)
32.8913+ "Apply FN to each defined system.
32.8914+
32.8915+FN should be a function of one argument. It will be
32.8916+called with an object of type asdf:system."
32.8917+ (loop :for registered :being :the :hash-values :of *registered-systems*
32.8918+ :do (funcall fn registered)))
32.8919+
32.8920+
32.8921+ ;;; Preloaded systems: in the image even if you can't find source files backing them.
32.8922+
32.8923+ (defvar *preloaded-systems* (make-hash-table :test 'equal)
32.8924+ "Registration table for preloaded systems.")
32.8925+
32.8926+ (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/find-system
32.8927+
32.8928+ (defun make-preloaded-system (name keys)
32.8929+ "Make a preloaded system of given NAME with build information from KEYS"
32.8930+ (let ((system (apply 'make-instance (getf keys :class 'system)
32.8931+ :name name :source-file (getf keys :source-file)
32.8932+ (remove-plist-keys '(:class :name :source-file) keys))))
32.8933+ (mark-component-preloaded system)
32.8934+ system))
32.8935+
32.8936+ (defun sysdef-preloaded-system-search (requested)
32.8937+ "If REQUESTED names a system registered as preloaded, return a new system
32.8938+with its registration information."
32.8939+ (let ((name (coerce-name requested)))
32.8940+ (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
32.8941+ (when foundp
32.8942+ (make-preloaded-system name keys)))))
32.8943+
32.8944+ (defun ensure-preloaded-system-registered (name)
32.8945+ "If there isn't a registered _defined_ system of given NAME,
32.8946+and a there is a registered _preloaded_ system of given NAME,
32.8947+then define and register said preloaded system."
32.8948+ (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name)))
32.8949+ (register-system system)))
32.8950+
32.8951+ (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys)
32.8952+ "Register a system as being preloaded. If the system has not been loaded from the filesystem
32.8953+yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be
32.8954+registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION).
32.8955+If VERSION is the default T, and a system was already loaded, then its version will be preserved."
32.8956+ (let ((name (coerce-name system-name)))
32.8957+ (when (eql version t)
32.8958+ (if-let (system (registered-system name))
32.8959+ (setf (getf keys :version) (component-version system))))
32.8960+ (setf (gethash name *preloaded-systems*) keys)
32.8961+ (ensure-preloaded-system-registered system-name)))
32.8962+
32.8963+
32.8964+ ;;; Immutable systems: in the image and can't be reloaded from source.
32.8965+
32.8966+ (defvar *immutable-systems* nil
32.8967+ "A hash-set (equal hash-table mapping keys to T) of systems that are immutable,
32.8968+i.e. already loaded in memory and not to be refreshed from the filesystem.
32.8969+They will be treated specially by find-system, and passed as :force-not argument to make-plan.
32.8970+
32.8971+For instance, to can deliver an image with many systems precompiled, that *will not* check the
32.8972+filesystem for them every time a user loads an extension, what more risk a problematic upgrade
32.8973+ or catastrophic downgrade, before you dump an image, you may use:
32.8974+ (map () 'asdf:register-immutable-system (asdf:already-loaded-systems))
32.8975+
32.8976+Note that direct access to this variable from outside ASDF is not supported.
32.8977+Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and
32.8978+contact maintainers if you need a stable API to do more than that.")
32.8979+
32.8980+ (defun sysdef-immutable-system-search (requested)
32.8981+ (let ((name (coerce-name requested)))
32.8982+ (when (and *immutable-systems* (gethash name *immutable-systems*))
32.8983+ (or (registered-system requested)
32.8984+ (error 'formatted-system-definition-error
32.8985+ :format-control "Requested system ~A registered as an immutable-system, ~
32.8986+but not even registered as defined"
32.8987+ :format-arguments (list name))))))
32.8988+
32.8989+ (defun register-immutable-system (system-name &rest keys)
32.8990+ "Register SYSTEM-NAME as preloaded and immutable.
32.8991+It will automatically be considered as passed to FORCE-NOT in a plan."
32.8992+ (let ((system-name (coerce-name system-name)))
32.8993+ (apply 'register-preloaded-system system-name keys)
32.8994+ (unless *immutable-systems*
32.8995+ (setf *immutable-systems* (list-to-hash-set nil)))
32.8996+ (setf (gethash system-name *immutable-systems*) t)))
32.8997+
32.8998+
32.8999+ ;;; Making systems undefined.
32.9000+
32.9001+ (defun clear-system (system)
32.9002+ "Clear the entry for a SYSTEM in the database of systems previously defined.
32.9003+However if the system was registered as PRELOADED (which it is if it is IMMUTABLE),
32.9004+then a new system with the same name will be defined and registered in its place
32.9005+from which build details will have been cleared.
32.9006+Note that this does NOT in any way cause any of the code of the system to be unloaded.
32.9007+Returns T if system was or is now undefined, NIL if a new preloaded system was redefined."
32.9008+ ;; There is no "unload" operation in Common Lisp, and
32.9009+ ;; a general such operation cannot be portably written,
32.9010+ ;; considering how much CL relies on side-effects to global data structures.
32.9011+ (let ((name (coerce-name system)))
32.9012+ (remhash name *registered-systems*)
32.9013+ (unset-asdf-cache-entry `(find-system ,name))
32.9014+ (not (ensure-preloaded-system-registered name))))
32.9015+
32.9016+ (defun clear-registered-systems ()
32.9017+ "Clear all currently registered defined systems.
32.9018+Preloaded systems (including immutable ones) will be reset, other systems will be de-registered."
32.9019+ (map () 'clear-system (registered-systems)))
32.9020+
32.9021+
32.9022+ ;;; Searching for system definitions
32.9023+
32.9024+ ;; For the sake of keeping things reasonably neat, we adopt a convention that
32.9025+ ;; only symbols are to be pushed to this list (rather than e.g. function objects),
32.9026+ ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF-
32.9027+ (defvar *system-definition-search-functions* '()
32.9028+ "A list that controls the ways that ASDF looks for system definitions.
32.9029+It contains symbols to be funcalled in order, with a requested system name as argument,
32.9030+until one returns a non-NIL result (if any), which must then be a fully initialized system object
32.9031+with that name.")
32.9032+
32.9033+ ;; Initialize and/or upgrade the *system-definition-search-functions*
32.9034+ ;; so it doesn't contain obsolete symbols, and does contain the current ones.
32.9035+ (defun cleanup-system-definition-search-functions ()
32.9036+ (setf *system-definition-search-functions*
32.9037+ (append
32.9038+ ;; Remove known-incompatible sysdef functions from old versions of asdf.
32.9039+ ;; Order matters, so we can't just use set-difference.
32.9040+ (let ((obsolete
32.9041+ '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search)))
32.9042+ (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*))
32.9043+ ;; Tuck our defaults at the end of the list if they were absent.
32.9044+ ;; This is imperfect, in case they were removed on purpose,
32.9045+ ;; but then it will be the responsibility of whoever removes these symmbols
32.9046+ ;; to upgrade asdf before he does such a thing rather than after.
32.9047+ (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
32.9048+ '(sysdef-central-registry-search
32.9049+ sysdef-source-registry-search)))))
32.9050+ (cleanup-system-definition-search-functions)
32.9051+
32.9052+ ;; This (private) function does the search for a system definition using *s-d-s-f*;
32.9053+ ;; it is to be called by locate-system.
32.9054+ (defun search-for-system-definition (system)
32.9055+ ;; Search for valid definitions of the system available in the current session.
32.9056+ ;; Previous definitions as registered in *registered-systems* MUST NOT be considered;
32.9057+ ;; they will be reconciled by locate-system then find-system.
32.9058+ ;; There are two special treatments: first, specially search for objects being defined
32.9059+ ;; in the current session, to avoid definition races between several files;
32.9060+ ;; second, specially search for immutable systems, so they cannot be redefined.
32.9061+ ;; Finally, use the search functions specified in *system-definition-search-functions*.
32.9062+ (let ((name (coerce-name system)))
32.9063+ (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
32.9064+ (try 'find-system-if-being-defined)
32.9065+ (try 'sysdef-immutable-system-search)
32.9066+ (map () #'try *system-definition-search-functions*))))
32.9067+
32.9068+
32.9069+ ;;; The legacy way of finding a system: the *central-registry*
32.9070+
32.9071+ ;; This variable contains a list of directories to be lazily searched for the requested asd
32.9072+ ;; by sysdef-central-registry-search.
32.9073+ (defvar *central-registry* nil
32.9074+ "A list of 'system directory designators' ASDF uses to find systems.
32.9075+
32.9076+A 'system directory designator' is a pathname or an expression
32.9077+which evaluates to a pathname. For example:
32.9078+
32.9079+ (setf asdf:*central-registry*
32.9080+ (list '*default-pathname-defaults*
32.9081+ #p\"/home/me/cl/systems/\"
32.9082+ #p\"/usr/share/common-lisp/systems/\"))
32.9083+
32.9084+This variable is for backward compatibility.
32.9085+Going forward, we recommend new users should be using the source-registry.")
32.9086+
32.9087+ ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS.
32.9088+ ;; Return the truename of that file if it is found and TRUENAME is true.
32.9089+ ;; Return NIL if the file is not found.
32.9090+ ;; On Windows, follow shortcuts to .asd files.
32.9091+ (defun probe-asd (name defaults &key truename)
32.9092+ (block nil
32.9093+ (when (directory-pathname-p defaults)
32.9094+ (if-let (file (probe-file*
32.9095+ (ensure-absolute-pathname
32.9096+ (parse-unix-namestring name :type "asd")
32.9097+ #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil))
32.9098+ nil)
32.9099+ :truename truename))
32.9100+ (return file))
32.9101+ #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
32.9102+ (os-cond
32.9103+ ((os-windows-p)
32.9104+ (when (physical-pathname-p defaults)
32.9105+ (let ((shortcut
32.9106+ (make-pathname
32.9107+ :defaults defaults :case :local
32.9108+ :name (strcat name ".asd")
32.9109+ :type "lnk")))
32.9110+ (when (probe-file* shortcut)
32.9111+ (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))))
32.9112+
32.9113+ ;; Function to push onto *s-d-s-f* to use the *central-registry*
32.9114+ (defun sysdef-central-registry-search (system)
32.9115+ (let ((name (primary-system-name system))
32.9116+ (to-remove nil)
32.9117+ (to-replace nil))
32.9118+ (block nil
32.9119+ (unwind-protect
32.9120+ (dolist (dir *central-registry*)
32.9121+ (let ((defaults (eval dir))
32.9122+ directorized)
32.9123+ (when defaults
32.9124+ (cond ((directory-pathname-p defaults)
32.9125+ (let* ((file (probe-asd name defaults :truename *resolve-symlinks*)))
32.9126+ (when file
32.9127+ (return file))))
32.9128+ (t
32.9129+ (restart-case
32.9130+ (let* ((*print-circle* nil)
32.9131+ (message
32.9132+ (format nil
32.9133+ (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.~@:>")
32.9134+ system dir defaults)))
32.9135+ (error message))
32.9136+ (remove-entry-from-registry ()
32.9137+ :report "Remove entry from *central-registry* and continue"
32.9138+ (push dir to-remove))
32.9139+ (coerce-entry-to-directory ()
32.9140+ :test (lambda (c) (declare (ignore c))
32.9141+ (and (not (directory-pathname-p defaults))
32.9142+ (directory-pathname-p
32.9143+ (setf directorized
32.9144+ (ensure-directory-pathname defaults)))))
32.9145+ :report (lambda (s)
32.9146+ (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
32.9147+ directorized dir))
32.9148+ (push (cons dir directorized) to-replace))))))))
32.9149+ ;; cleanup
32.9150+ (dolist (dir to-remove)
32.9151+ (setf *central-registry* (remove dir *central-registry*)))
32.9152+ (dolist (pair to-replace)
32.9153+ (let* ((current (car pair))
32.9154+ (new (cdr pair))
32.9155+ (position (position current *central-registry*)))
32.9156+ (setf *central-registry*
32.9157+ (append (subseq *central-registry* 0 position)
32.9158+ (list new)
32.9159+ (subseq *central-registry* (1+ position)))))))))))
32.9160+
32.9161+;;;; -------------------------------------------------------------------------
32.9162+;;;; Actions
32.9163+
32.9164+(uiop/package:define-package :asdf/action
32.9165+ (:nicknames :asdf-action)
32.9166+ (:recycle :asdf/action :asdf/plan :asdf)
32.9167+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation)
32.9168+ (:import-from :asdf/operation #:check-operation-constructor)
32.9169+ (:import-from :asdf/component #:%additional-input-files)
32.9170+ (:export
32.9171+ #:action #:define-convenience-action-methods
32.9172+ #:action-description #:format-action
32.9173+ #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
32.9174+ #:non-propagating-operation
32.9175+ #:component-depends-on
32.9176+ #:input-files #:output-files #:output-file #:operation-done-p
32.9177+ #:action-operation #:action-component #:make-action
32.9178+ #:component-operation-time #:mark-operation-done #:compute-action-stamp
32.9179+ #:perform #:perform-with-restarts #:retry #:accept
32.9180+ #:action-path #:find-action
32.9181+ #:operation-definition-warning #:operation-definition-error ;; condition
32.9182+ #:action-valid-p
32.9183+ #:circular-dependency #:circular-dependency-actions
32.9184+ #:call-while-visiting-action #:while-visiting-action
32.9185+ #:additional-input-files))
32.9186+(in-package :asdf/action)
32.9187+
32.9188+(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
32.9189+
32.9190+ (deftype action ()
32.9191+ "A pair of operation and component uniquely identifies a node in the dependency graph
32.9192+of steps to be performed while building a system."
32.9193+ '(cons operation component))
32.9194+
32.9195+ (deftype operation-designator ()
32.9196+ "An operation designates itself. NIL designates a context-dependent current operation,
32.9197+and a class-name or class designates the canonical instance of the designated class."
32.9198+ '(or operation null symbol class)))
32.9199+
32.9200+;;; these are pseudo accessors -- let us abstract away the CONS cell representation of plan
32.9201+;;; actions.
32.9202+(with-upgradability ()
32.9203+ (defun make-action (operation component)
32.9204+ (cons operation component))
32.9205+ (defun action-operation (action)
32.9206+ (car action))
32.9207+ (defun action-component (action)
32.9208+ (cdr action)))
32.9209+
32.9210+;;;; Reified representation for storage or debugging. Note: an action is identified by its class.
32.9211+(with-upgradability ()
32.9212+ (defun action-path (action)
32.9213+ "A readable data structure that identifies the action."
32.9214+ (when action
32.9215+ (let ((o (action-operation action))
32.9216+ (c (action-component action)))
32.9217+ (cons (type-of o) (component-find-path c)))))
32.9218+ (defun find-action (path)
32.9219+ "Reconstitute an action from its action-path"
32.9220+ (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c)))))
32.9221+
32.9222+;;;; Convenience methods
32.9223+(with-upgradability ()
32.9224+ ;; A macro that defines convenience methods for a generic function (gf) that
32.9225+ ;; dispatches on operation and component. The convenience methods allow users
32.9226+ ;; to call the gf with operation and/or component designators, that the
32.9227+ ;; methods will resolve into actual operation and component objects, so that
32.9228+ ;; the users can interact using readable designators, but developers only have
32.9229+ ;; to write methods that handle operation and component objects.
32.9230+ ;; FUNCTION is the generic function name
32.9231+ ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT.
32.9232+ ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found.
32.9233+ ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found.
32.9234+ (defmacro define-convenience-action-methods
32.9235+ (function formals &key if-no-operation if-no-component)
32.9236+ (let* ((rest (gensym "REST"))
32.9237+ (found (gensym "FOUND"))
32.9238+ (keyp (equal (last formals) '(&key)))
32.9239+ (formals-no-key (if keyp (butlast formals) formals))
32.9240+ (len (length formals-no-key))
32.9241+ (operation 'operation)
32.9242+ (component 'component)
32.9243+ (opix (position operation formals))
32.9244+ (coix (position component formals))
32.9245+ (prefix (subseq formals 0 opix))
32.9246+ (suffix (subseq formals (1+ coix) len))
32.9247+ (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
32.9248+ (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
32.9249+ (flet ((next-method (o c)
32.9250+ (if keyp
32.9251+ `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
32.9252+ `(,function ,@prefix ,o ,c ,@suffix))))
32.9253+ `(progn
32.9254+ (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args)
32.9255+ (declare (notinline ,function))
32.9256+ (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on
32.9257+ ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component)))
32.9258+ (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args)
32.9259+ (declare (notinline ,function))
32.9260+ (if ,operation
32.9261+ ,(next-method
32.9262+ `(make-operation ,operation)
32.9263+ `(or (find-component () ,component) ,if-no-component))
32.9264+ ,if-no-operation))
32.9265+ (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
32.9266+ (declare (notinline ,function))
32.9267+ (if (typep ,component 'component)
32.9268+ (error "No defined method for ~S on ~/asdf-action:format-action/"
32.9269+ ',function (make-action ,operation ,component))
32.9270+ (if-let (,found (find-component () ,component))
32.9271+ ,(next-method operation found)
32.9272+ ,if-no-component))))))))
32.9273+
32.9274+
32.9275+;;;; Self-description
32.9276+(with-upgradability ()
32.9277+ (defgeneric action-description (operation component)
32.9278+ (:documentation "returns a phrase that describes performing this operation
32.9279+on this component, e.g. \"loading /a/b/c\".
32.9280+You can put together sentences using this phrase."))
32.9281+ (defmethod action-description (operation component)
32.9282+ (format nil (compatfmt "~@<~A on ~A~@:>")
32.9283+ operation component))
32.9284+
32.9285+ (defun format-action (stream action &optional colon-p at-sign-p)
32.9286+ "FORMAT helper to display an action's action-description.
32.9287+Use it in FORMAT control strings as ~/asdf-action:format-action/"
32.9288+ (assert (null colon-p)) (assert (null at-sign-p))
32.9289+ (destructuring-bind (operation . component) action
32.9290+ (princ (action-description operation component) stream))))
32.9291+
32.9292+
32.9293+;;;; Detection of circular dependencies
32.9294+(with-upgradability ()
32.9295+ (defun action-valid-p (operation component)
32.9296+ "Is this action valid to include amongst dependencies?"
32.9297+ ;; If either the operation or component was resolved to nil, the action is invalid.
32.9298+ ;; :if-feature will invalidate actions on components for which the features don't apply.
32.9299+ (and operation component
32.9300+ (if-let (it (component-if-feature component)) (featurep it) t)))
32.9301+
32.9302+ (define-condition circular-dependency (system-definition-error)
32.9303+ ((actions :initarg :actions :reader circular-dependency-actions))
32.9304+ (:report (lambda (c s)
32.9305+ (format s (compatfmt "~@<Circular dependency of ~s on: ~3i~_~S~@:>")
32.9306+ (first (circular-dependency-actions c))
32.9307+ (circular-dependency-actions c)))))
32.9308+
32.9309+ (defun call-while-visiting-action (operation component fun)
32.9310+ "Detect circular dependencies"
32.9311+ (with-asdf-session ()
32.9312+ (with-accessors ((action-set visiting-action-set)
32.9313+ (action-list visiting-action-list)) *asdf-session*
32.9314+ (let ((action (cons operation component)))
32.9315+ (when (gethash action action-set)
32.9316+ (error 'circular-dependency :actions
32.9317+ (member action (reverse action-list) :test 'equal)))
32.9318+ (setf (gethash action action-set) t)
32.9319+ (push action action-list)
32.9320+ (unwind-protect
32.9321+ (funcall fun)
32.9322+ (pop action-list)
32.9323+ (setf (gethash action action-set) nil))))))
32.9324+
32.9325+ ;; Syntactic sugar for call-while-visiting-action
32.9326+ (defmacro while-visiting-action ((o c) &body body)
32.9327+ `(call-while-visiting-action ,o ,c #'(lambda () ,@body))))
32.9328+
32.9329+
32.9330+;;;; Dependencies
32.9331+(with-upgradability ()
32.9332+ (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
32.9333+ (:documentation
32.9334+ "Returns a list of dependencies needed by the component to perform
32.9335+ the operation. A dependency has one of the following forms:
32.9336+
32.9337+ (<operation> <component>*), where <operation> is an operation designator
32.9338+ with respect to FIND-OPERATION in the context of the OPERATION argument,
32.9339+ and each <component> is a component designator with respect to
32.9340+ FIND-COMPONENT in the context of the COMPONENT argument,
32.9341+ and means that the component depends on
32.9342+ <operation> having been performed on each <component>;
32.9343+
32.9344+ [Note: an <operation> is an operation designator -- it can be either an
32.9345+ operation name or an operation object. Similarly, a <component> may be
32.9346+ a component name or a component object. Also note that, the degenerate
32.9347+ case of (<operation>) is a no-op.]
32.9348+
32.9349+ Methods specialized on subclasses of existing component types
32.9350+ should usually append the results of CALL-NEXT-METHOD to the list."))
32.9351+ (define-convenience-action-methods component-depends-on (operation component))
32.9352+
32.9353+ (defmethod component-depends-on :around ((o operation) (c component))
32.9354+ (do-asdf-cache `(component-depends-on ,o ,c)
32.9355+ (call-next-method))))
32.9356+
32.9357+
32.9358+;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
32.9359+;; These together handle actions that propagate along the component hierarchy or operation universe.
32.9360+(with-upgradability ()
32.9361+ (defclass downward-operation (operation)
32.9362+ ((downward-operation
32.9363+ :initform nil :reader downward-operation
32.9364+ :type operation-designator :allocation :class))
32.9365+ (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy.
32.9366+I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then
32.9367+the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M.
32.9368+The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself.
32.9369+E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the
32.9370+children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP."))
32.9371+ (defun downward-operation-depends-on (o c)
32.9372+ `((,(or (downward-operation o) o) ,@(component-children c))))
32.9373+ (defmethod component-depends-on ((o downward-operation) (c parent-component))
32.9374+ `(,@(downward-operation-depends-on o c) ,@(call-next-method)))
32.9375+
32.9376+ (defclass upward-operation (operation)
32.9377+ ((upward-operation
32.9378+ :initform nil :reader upward-operation
32.9379+ :type operation-designator :allocation :class))
32.9380+ (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy.
32.9381+I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U,
32.9382+then the action (O . C) of O on a component C that has the parent P will depends on (U . P).
32.9383+The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself.
32.9384+E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT
32.9385+must first be prepared for loading or compiling with PREPARE-OP."))
32.9386+ ;; For backward-compatibility reasons, a system inherits from module and is a child-component
32.9387+ ;; so we must guard against this case. ASDF4: remove that.
32.9388+ (defun upward-operation-depends-on (o c)
32.9389+ (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))))
32.9390+ (defmethod component-depends-on ((o upward-operation) (c child-component))
32.9391+ `(,@(upward-operation-depends-on o c) ,@(call-next-method)))
32.9392+
32.9393+ (defclass sideway-operation (operation)
32.9394+ ((sideway-operation
32.9395+ :initform nil :reader sideway-operation
32.9396+ :type operation-designator :allocation :class))
32.9397+ (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings
32.9398+that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot
32.9399+designates operation S (where NIL designates O itself), then the action (O . C) of O on component C
32.9400+depends on each of (S . D) where D is a declared dependency of C.
32.9401+E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP,
32.9402+each of its declared dependencies must first be loaded as by LOAD-OP."))
32.9403+ (defun sideway-operation-depends-on (o c)
32.9404+ `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c))))
32.9405+ (defmethod component-depends-on ((o sideway-operation) (c component))
32.9406+ `(,@(sideway-operation-depends-on o c) ,@(call-next-method)))
32.9407+
32.9408+ (defclass selfward-operation (operation)
32.9409+ ((selfward-operation
32.9410+ ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which
32.9411+ :type (or operation-designator list) :reader selfward-operation :allocation :class))
32.9412+ (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
32.9413+I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L,
32.9414+then the action (O . C) of O on component C depends on each (S . C) for S in L.
32.9415+E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
32.9416+A operation-designator designates a singleton list of the designated operation;
32.9417+a list of operation-designators designates the list of designated operations;
32.9418+NIL is not a valid operation designator in that context. Note that any dependency
32.9419+ordering between the operations in a list of SELFWARD-OPERATION should be specified separately
32.9420+in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly."))
32.9421+ (defun selfward-operation-depends-on (o c)
32.9422+ (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)))
32.9423+ (defmethod component-depends-on ((o selfward-operation) (c component))
32.9424+ `(,@(selfward-operation-depends-on o c) ,@(call-next-method)))
32.9425+
32.9426+ (defclass non-propagating-operation (operation)
32.9427+ ()
32.9428+ (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
32.9429+no dependencies whatsoever. It is supplied in order that the programmer be able
32.9430+to specify that s/he is intentionally specifying an operation which invokes no
32.9431+dependencies.")))
32.9432+
32.9433+
32.9434+;;;---------------------------------------------------------------------------
32.9435+;;; Help programmers catch obsolete OPERATION subclasses
32.9436+;;;---------------------------------------------------------------------------
32.9437+(with-upgradability ()
32.9438+ (define-condition operation-definition-warning (simple-warning)
32.9439+ ()
32.9440+ (:documentation "Warning condition related to definition of obsolete OPERATION objects."))
32.9441+
32.9442+ (define-condition operation-definition-error (simple-error)
32.9443+ ()
32.9444+ (:documentation "Error condition related to definition of incorrect OPERATION objects."))
32.9445+
32.9446+ (defmethod initialize-instance :before ((o operation) &key)
32.9447+ (check-operation-constructor)
32.9448+ (unless (typep o '(or downward-operation upward-operation sideway-operation
32.9449+ selfward-operation non-propagating-operation))
32.9450+ (warn 'operation-definition-warning
32.9451+ :format-control
32.9452+ "No dependency propagating scheme specified for operation class ~S.
32.9453+The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins."
32.9454+ :format-arguments (list (type-of o)))))
32.9455+
32.9456+ (defmethod initialize-instance :before ((o non-propagating-operation) &key)
32.9457+ (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation))
32.9458+ (error 'operation-definition-error
32.9459+ :format-control
32.9460+ "Inconsistent class: ~S
32.9461+ NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses."
32.9462+ :format-arguments
32.9463+ (list (type-of o)))))
32.9464+
32.9465+ (defun backward-compatible-depends-on (o c)
32.9466+ "DEPRECATED: all subclasses of OPERATION used in ASDF should inherit from one of
32.9467+ DOWNWARD-OPERATION UPWARD-OPERATION SIDEWAY-OPERATION SELFWARD-OPERATION NON-PROPAGATING-OPERATION.
32.9468+ The function BACKWARD-COMPATIBLE-DEPENDS-ON temporarily provides ASDF2 behaviour for those that
32.9469+ don't. In the future this functionality will be removed, and the default will be no propagation."
32.9470+ (uiop/version::notify-deprecated-function
32.9471+ (version-deprecation *asdf-version* :style-warning "3.2")
32.9472+ `(backward-compatible-depends-on :for-operation ,o))
32.9473+ `(,@(sideway-operation-depends-on o c)
32.9474+ ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))
32.9475+
32.9476+ (defmethod component-depends-on ((o operation) (c component))
32.9477+ `(;; Normal behavior, to allow user-specified in-order-to dependencies
32.9478+ ,@(cdr (assoc (type-of o) (component-in-order-to c)))
32.9479+ ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation
32.9480+ ;; or non-propagation through an appropriate mixin will be downward and sideway.
32.9481+ ,@(unless (typep o '(or downward-operation upward-operation sideway-operation
32.9482+ selfward-operation non-propagating-operation))
32.9483+ (backward-compatible-depends-on o c))))
32.9484+
32.9485+ (defmethod downward-operation ((o operation)) nil)
32.9486+ (defmethod sideway-operation ((o operation)) nil))
32.9487+
32.9488+
32.9489+;;;---------------------------------------------------------------------------
32.9490+;;; End of OPERATION class checking
32.9491+;;;---------------------------------------------------------------------------
32.9492+
32.9493+
32.9494+;;;; Inputs, Outputs, and invisible dependencies
32.9495+(with-upgradability ()
32.9496+ (defgeneric output-files (operation component)
32.9497+ (:documentation "Methods for this function return two values: a list of output files
32.9498+corresponding to this action, and a boolean indicating if they have already been subjected
32.9499+to relevant output translations and should not be further translated.
32.9500+
32.9501+Methods on PERFORM *must* call this function to determine where their outputs are to be located.
32.9502+They may rely on the order of the files to discriminate between outputs.
32.9503+"))
32.9504+ (defgeneric input-files (operation component)
32.9505+ (:documentation "A list of input files corresponding to this action.
32.9506+
32.9507+Methods on PERFORM *must* call this function to determine where their inputs are located.
32.9508+They may rely on the order of the files to discriminate between inputs.
32.9509+"))
32.9510+ (defgeneric operation-done-p (operation component)
32.9511+ (:documentation "Returns a boolean which is NIL if the action must be performed (again)."))
32.9512+ (define-convenience-action-methods output-files (operation component))
32.9513+ (define-convenience-action-methods input-files (operation component))
32.9514+ (define-convenience-action-methods operation-done-p (operation component))
32.9515+
32.9516+ (defmethod operation-done-p ((o operation) (c component))
32.9517+ t)
32.9518+
32.9519+ ;; Translate output files, unless asked not to. Memoize the result.
32.9520+ (defmethod output-files :around ((operation t) (component t))
32.9521+ (do-asdf-cache `(output-files ,operation ,component)
32.9522+ (values
32.9523+ (multiple-value-bind (pathnames fixedp) (call-next-method)
32.9524+ ;; 1- Make sure we have absolute pathnames
32.9525+ (let* ((directory (pathname-directory-pathname
32.9526+ (component-pathname (find-component () component))))
32.9527+ (absolute-pathnames
32.9528+ (loop
32.9529+ :for pathname :in pathnames
32.9530+ :collect (ensure-absolute-pathname pathname directory))))
32.9531+ ;; 2- Translate those pathnames as required
32.9532+ (if fixedp
32.9533+ absolute-pathnames
32.9534+ (mapcar *output-translation-function* absolute-pathnames))))
32.9535+ t)))
32.9536+ (defmethod output-files ((o operation) (c component))
32.9537+ nil)
32.9538+ (defun output-file (operation component)
32.9539+ "The unique output file of performing OPERATION on COMPONENT"
32.9540+ (let ((files (output-files operation component)))
32.9541+ (assert (length=n-p files 1))
32.9542+ (first files)))
32.9543+
32.9544+ (defgeneric additional-input-files (operation component)
32.9545+ (:documentation "Additional input files for the operation on this
32.9546+ component. These are files that are inferred, rather than
32.9547+ explicitly specified, and these are typically NOT files that
32.9548+ undergo operations directly. Instead, they are files that it is
32.9549+ important for ASDF to know about in order to compute operation times,etc."))
32.9550+ (define-convenience-action-methods additional-input-files (operation component))
32.9551+ (defmethod additional-input-files ((op operation) (comp component))
32.9552+ (cdr (assoc op (%additional-input-files comp))))
32.9553+
32.9554+ ;; Memoize input files.
32.9555+ (defmethod input-files :around (operation component)
32.9556+ (do-asdf-cache `(input-files ,operation ,component)
32.9557+ ;; get the additional input files, if any
32.9558+ (append (call-next-method)
32.9559+ ;; must come after the first, for other code that
32.9560+ ;; assumes the first will be the "key" file
32.9561+ (additional-input-files operation component))))
32.9562+
32.9563+ ;; By default an action has no input-files.
32.9564+ (defmethod input-files ((o operation) (c component))
32.9565+ nil)
32.9566+
32.9567+ ;; An action with a selfward-operation by default gets its input-files from the output-files of
32.9568+ ;; the actions using selfward-operations it depends on (and the same component),
32.9569+ ;; or if there are none, on the component-pathname of the component if it's a file
32.9570+ ;; -- and then on the results of the next-method.
32.9571+ (defmethod input-files ((o selfward-operation) (c component))
32.9572+ `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
32.9573+ :append (or (output-files dep-o c) (input-files dep-o c)))
32.9574+ (if-let ((pathname (component-pathname c)))
32.9575+ (and (file-pathname-p pathname) (list pathname))))
32.9576+ ,@(call-next-method))))
32.9577+
32.9578+
32.9579+;;;; Done performing
32.9580+(with-upgradability ()
32.9581+ ;; ASDF4: hide it behind plan-action-stamp
32.9582+ (defgeneric component-operation-time (operation component)
32.9583+ (:documentation "Return the timestamp for when an action was last performed"))
32.9584+ (defgeneric (setf component-operation-time) (time operation component)
32.9585+ (:documentation "Update the timestamp for when an action was last performed"))
32.9586+ (define-convenience-action-methods component-operation-time (operation component))
32.9587+
32.9588+ ;; ASDF4: hide it behind (setf plan-action-stamp)
32.9589+ (defgeneric mark-operation-done (operation component)
32.9590+ (:documentation "Mark a action as having been just done.
32.9591+
32.9592+Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP
32.9593+using the JUST-DONE flag."))
32.9594+ (defgeneric compute-action-stamp (plan- operation component &key just-done)
32.9595+ ;; NB: using plan- rather than plan above allows clisp to upgrade from 2.26(!)
32.9596+ (:documentation "Has this action been successfully done already,
32.9597+and at what known timestamp has it been done at or will it be done at?
32.9598+* PLAN is a plan object modelling future effects of actions,
32.9599+ or NIL to denote what actually happened.
32.9600+* OPERATION and COMPONENT denote the action.
32.9601+Takes keyword JUST-DONE:
32.9602+* JUST-DONE is a boolean that is true if the action was just successfully performed,
32.9603+ at which point we want compute the actual stamp and warn if files are missing;
32.9604+ otherwise we are making plans, anticipating the effects of the action.
32.9605+Returns two values:
32.9606+* a STAMP saying when it was done or will be done,
32.9607+ or T if the action involves files that need to be recomputed.
32.9608+* a boolean DONE-P that indicates whether the action has actually been done,
32.9609+ and both its output-files and its in-image side-effects are up to date."))
32.9610+
32.9611+ (defmethod component-operation-time ((o operation) (c component))
32.9612+ (gethash o (component-operation-times c)))
32.9613+
32.9614+ (defmethod (setf component-operation-time) (stamp (o operation) (c component))
32.9615+ (assert stamp () "invalid null stamp for ~A" (action-description o c))
32.9616+ (setf (gethash o (component-operation-times c)) stamp))
32.9617+
32.9618+ (defmethod mark-operation-done ((o operation) (c component))
32.9619+ (let ((stamp (compute-action-stamp nil o c :just-done t)))
32.9620+ (assert stamp () "Failed to compute a stamp for completed action ~A" (action-description o c))1
32.9621+ (setf (component-operation-time o c) stamp))))
32.9622+
32.9623+
32.9624+;;;; Perform
32.9625+(with-upgradability ()
32.9626+ (defgeneric perform (operation component)
32.9627+ (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
32.9628+ (define-convenience-action-methods perform (operation component))
32.9629+
32.9630+ (defmethod perform :around ((o operation) (c component))
32.9631+ (while-visiting-action (o c) (call-next-method)))
32.9632+ (defmethod perform :before ((o operation) (c component))
32.9633+ (ensure-all-directories-exist (output-files o c)))
32.9634+ (defmethod perform :after ((o operation) (c component))
32.9635+ (mark-operation-done o c))
32.9636+ (defmethod perform ((o operation) (c parent-component))
32.9637+ nil)
32.9638+ (defmethod perform ((o operation) (c source-file))
32.9639+ ;; For backward compatibility, don't error on operations that don't specify propagation.
32.9640+ (when (typep o '(or downward-operation upward-operation sideway-operation
32.9641+ selfward-operation non-propagating-operation))
32.9642+ (sysdef-error
32.9643+ (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>")
32.9644+ 'perform (make-action o c))))
32.9645+
32.9646+ ;; The restarts of the perform-with-restarts variant matter in an interactive context.
32.9647+ ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build
32.9648+ ;; may call perform directly rather than call p-w-r.
32.9649+ (defgeneric perform-with-restarts (operation component)
32.9650+ (:documentation "PERFORM an action in a context where suitable restarts are in place."))
32.9651+ (defmethod perform-with-restarts (operation component)
32.9652+ (perform operation component))
32.9653+ (defmethod perform-with-restarts :around (operation component)
32.9654+ (loop
32.9655+ (restart-case
32.9656+ (return (call-next-method))
32.9657+ (retry ()
32.9658+ :report
32.9659+ (lambda (s)
32.9660+ (format s (compatfmt "~@<Retry ~A.~@:>")
32.9661+ (action-description operation component))))
32.9662+ (accept ()
32.9663+ :report
32.9664+ (lambda (s)
32.9665+ (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
32.9666+ (action-description operation component)))
32.9667+ (mark-operation-done operation component)
32.9668+ (return))))))
32.9669+;;;; -------------------------------------------------------------------------
32.9670+;;;; Actions to build Common Lisp software
32.9671+
32.9672+(uiop/package:define-package :asdf/lisp-action
32.9673+ (:recycle :asdf/lisp-action :asdf)
32.9674+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
32.9675+ :asdf/component :asdf/system :asdf/operation :asdf/action)
32.9676+ (:export
32.9677+ #:try-recompiling
32.9678+ #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
32.9679+ #:basic-load-op #:basic-compile-op
32.9680+ #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
32.9681+ #:call-with-around-compile-hook
32.9682+ #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source
32.9683+ #:lisp-compilation-output-files))
32.9684+(in-package :asdf/lisp-action)
32.9685+
32.9686+
32.9687+;;;; Component classes
32.9688+(with-upgradability ()
32.9689+ (defclass cl-source-file (source-file)
32.9690+ ((type :initform "lisp"))
32.9691+ (:documentation "Component class for a Common Lisp source file (using type \"lisp\")"))
32.9692+ (defclass cl-source-file.cl (cl-source-file)
32.9693+ ((type :initform "cl"))
32.9694+ (:documentation "Component class for a Common Lisp source file using type \"cl\""))
32.9695+ (defclass cl-source-file.lsp (cl-source-file)
32.9696+ ((type :initform "lsp"))
32.9697+ (:documentation "Component class for a Common Lisp source file using type \"lsp\"")))
32.9698+
32.9699+
32.9700+;;;; Operation classes
32.9701+(with-upgradability ()
32.9702+ (defclass basic-load-op (operation) ()
32.9703+ (:documentation "Base class for operations that apply the load-time effects of a file"))
32.9704+ (defclass basic-compile-op (operation) ()
32.9705+ (:documentation "Base class for operations that apply the compile-time effects of a file")))
32.9706+
32.9707+
32.9708+;;; Our default operations: loading into the current lisp image
32.9709+(with-upgradability ()
32.9710+ (defclass prepare-op (upward-operation sideway-operation)
32.9711+ ((sideway-operation :initform 'load-op :allocation :class))
32.9712+ (:documentation "Load the dependencies for the COMPILE-OP or LOAD-OP of a given COMPONENT."))
32.9713+ (defclass load-op (basic-load-op downward-operation selfward-operation)
32.9714+ ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
32.9715+ ;; so we need to directly depend on prepare-op for its side-effects in the current image.
32.9716+ ((selfward-operation :initform '(prepare-op compile-op) :allocation :class))
32.9717+ (:documentation "Operation for loading the compiled FASL for a Lisp file"))
32.9718+ (defclass compile-op (basic-compile-op downward-operation selfward-operation)
32.9719+ ((selfward-operation :initform 'prepare-op :allocation :class))
32.9720+ (:documentation "Operation for compiling a Lisp file to a FASL"))
32.9721+
32.9722+
32.9723+ (defclass prepare-source-op (upward-operation sideway-operation)
32.9724+ ((sideway-operation :initform 'load-source-op :allocation :class))
32.9725+ (:documentation "Operation for loading the dependencies of a Lisp file as source."))
32.9726+ (defclass load-source-op (basic-load-op downward-operation selfward-operation)
32.9727+ ((selfward-operation :initform 'prepare-source-op :allocation :class))
32.9728+ (:documentation "Operation for loading a Lisp file as source."))
32.9729+
32.9730+ (defclass test-op (selfward-operation)
32.9731+ ((selfward-operation :initform 'load-op :allocation :class))
32.9732+ (:documentation "Operation for running the tests for system.
32.9733+If the tests fail, an error will be signaled.")))
32.9734+
32.9735+
32.9736+;;;; Methods for prepare-op, compile-op and load-op
32.9737+
32.9738+;;; prepare-op
32.9739+(with-upgradability ()
32.9740+ (defmethod action-description ((o prepare-op) (c component))
32.9741+ (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
32.9742+ (defmethod perform ((o prepare-op) (c component))
32.9743+ nil)
32.9744+ (defmethod input-files ((o prepare-op) (s system))
32.9745+ (if-let (it (system-source-file s)) (list it))))
32.9746+
32.9747+;;; compile-op
32.9748+(with-upgradability ()
32.9749+ (defmethod action-description ((o compile-op) (c component))
32.9750+ (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
32.9751+ (defmethod action-description ((o compile-op) (c parent-component))
32.9752+ (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
32.9753+ (defgeneric call-with-around-compile-hook (component thunk)
32.9754+ (:documentation "A method to be called around the PERFORM'ing of actions that apply the
32.9755+compile-time side-effects of file (i.e., COMPILE-OP or LOAD-SOURCE-OP). This method can be used
32.9756+to setup readtables and other variables that control reading, macroexpanding, and compiling, etc.
32.9757+Note that it will NOT be called around the performing of LOAD-OP."))
32.9758+ (defmethod call-with-around-compile-hook ((c component) function)
32.9759+ (call-around-hook (around-compile-hook c) function))
32.9760+ (defun perform-lisp-compilation (o c)
32.9761+ "Perform the compilation of the Lisp file associated to the specified action (O . C)."
32.9762+ (let (;; Before 2.26.53, that was unfortunately component-pathname. Now,
32.9763+ ;; we consult input-files, the first of which should be the one to compile-file
32.9764+ (input-file (first (input-files o c)))
32.9765+ ;; On some implementations, there are more than one output-file,
32.9766+ ;; but the first one should always be the primary fasl that gets loaded.
32.9767+ (outputs (output-files o c)))
32.9768+ (multiple-value-bind (output warnings-p failure-p)
32.9769+ (destructuring-bind
32.9770+ (output-file
32.9771+ &optional
32.9772+ #+(or clasp ecl mkcl) object-file
32.9773+ #+clisp lib-file
32.9774+ warnings-file &rest rest) outputs
32.9775+ ;; Allow for extra outputs that are not of type warnings-file
32.9776+ ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional.
32.9777+ (declare (ignore rest))
32.9778+ (when warnings-file
32.9779+ (unless (equal (pathname-type warnings-file) (warnings-file-type))
32.9780+ (setf warnings-file nil)))
32.9781+ (let ((*package* (find-package* '#:common-lisp-user)))
32.9782+ (call-with-around-compile-hook
32.9783+ c #'(lambda (&rest flags)
32.9784+ (apply 'compile-file* input-file
32.9785+ :output-file output-file
32.9786+ :external-format (component-external-format c)
32.9787+ :warnings-file warnings-file
32.9788+ (append
32.9789+ #+clisp (list :lib-file lib-file)
32.9790+ #+(or clasp ecl mkcl) (list :object-file object-file)
32.9791+ flags))))))
32.9792+ (check-lisp-compile-results output warnings-p failure-p
32.9793+ "~/asdf-action::format-action/" (list (cons o c))))))
32.9794+ (defun report-file-p (f)
32.9795+ "Is F a build report file containing, e.g., warnings to check?"
32.9796+ (equalp (pathname-type f) "build-report"))
32.9797+ (defun perform-lisp-warnings-check (o c)
32.9798+ "Check the warnings associated with the dependencies of an action."
32.9799+ (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c)))
32.9800+ (actual-warnings-files (loop :for w :in expected-warnings-files
32.9801+ :when (get-file-stamp w)
32.9802+ :collect w
32.9803+ :else :do (warn "Missing warnings file ~S while ~A"
32.9804+ w (action-description o c)))))
32.9805+ (check-deferred-warnings actual-warnings-files)
32.9806+ (let* ((output (output-files o c))
32.9807+ (report (find-if #'report-file-p output)))
32.9808+ (when report
32.9809+ (with-open-file (s report :direction :output :if-exists :supersede)
32.9810+ (format s ":success~%"))))))
32.9811+ (defmethod perform ((o compile-op) (c cl-source-file))
32.9812+ (perform-lisp-compilation o c))
32.9813+ (defun lisp-compilation-output-files (o c)
32.9814+ "Compute the output-files for compiling the Lisp file for the specified action (O . C),
32.9815+an OPERATION and a COMPONENT."
32.9816+ (let* ((i (first (input-files o c)))
32.9817+ (f (compile-file-pathname
32.9818+ i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl
32.9819+ #+mkcl :fasl-p #+mkcl t)))
32.9820+ `(,f ;; the fasl is the primary output, in first position
32.9821+ #+clasp
32.9822+ ,@(unless nil ;; was (use-ecl-byte-compiler-p)
32.9823+ `(,(compile-file-pathname i :output-type :object)))
32.9824+ #+clisp
32.9825+ ,@`(,(make-pathname :type "lib" :defaults f))
32.9826+ #+ecl
32.9827+ ,@(unless (use-ecl-byte-compiler-p)
32.9828+ `(,(compile-file-pathname i :type :object)))
32.9829+ #+mkcl
32.9830+ ,(compile-file-pathname i :fasl-p nil) ;; object file
32.9831+ ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c))))
32.9832+ `(,(make-pathname :type *warnings-file-type* :defaults f))))))
32.9833+ (defmethod output-files ((o compile-op) (c cl-source-file))
32.9834+ (lisp-compilation-output-files o c))
32.9835+ (defmethod perform ((o compile-op) (c static-file))
32.9836+ nil)
32.9837+
32.9838+ ;; Performing compile-op on a system will check the deferred warnings for the system
32.9839+ (defmethod perform ((o compile-op) (c system))
32.9840+ (when (and *warnings-file-type* (not (builtin-system-p c)))
32.9841+ (perform-lisp-warnings-check o c)))
32.9842+ (defmethod input-files ((o compile-op) (c system))
32.9843+ (when (and *warnings-file-type* (not (builtin-system-p c)))
32.9844+ ;; The most correct way to do it would be to use:
32.9845+ ;; (collect-dependencies o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file)
32.9846+ ;; but it's expensive and we don't care too much about file order or ASDF extensions.
32.9847+ (loop :for sub :in (sub-components c :type 'cl-source-file)
32.9848+ :nconc (remove-if-not 'warnings-file-p (output-files o sub)))))
32.9849+ (defmethod output-files ((o compile-op) (c system))
32.9850+ (when (and *warnings-file-type* (not (builtin-system-p c)))
32.9851+ (if-let ((pathname (component-pathname c)))
32.9852+ (list (subpathname pathname (coerce-filename c) :type "build-report"))))))
32.9853+
32.9854+;;; load-op
32.9855+(with-upgradability ()
32.9856+ (defmethod action-description ((o load-op) (c cl-source-file))
32.9857+ (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
32.9858+ (defmethod action-description ((o load-op) (c parent-component))
32.9859+ (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
32.9860+ (defmethod action-description ((o load-op) (c component))
32.9861+ (format nil (compatfmt "~@<loading ~3i~_~A~@:>") c))
32.9862+ (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
32.9863+ (loop
32.9864+ (restart-case
32.9865+ (return (call-next-method))
32.9866+ (try-recompiling ()
32.9867+ :report (lambda (s)
32.9868+ (format s "Recompile ~a and try loading it again"
32.9869+ (component-name c)))
32.9870+ (perform (find-operation o 'compile-op) c)))))
32.9871+ (defun perform-lisp-load-fasl (o c)
32.9872+ "Perform the loading of a FASL associated to specified action (O . C),
32.9873+an OPERATION and a COMPONENT."
32.9874+ (if-let (fasl (first (input-files o c)))
32.9875+ (let ((*package* (find-package '#:common-lisp-user)))
32.9876+ (load* fasl))))
32.9877+ (defmethod perform ((o load-op) (c cl-source-file))
32.9878+ (perform-lisp-load-fasl o c))
32.9879+ (defmethod perform ((o load-op) (c static-file))
32.9880+ nil))
32.9881+
32.9882+
32.9883+;;;; prepare-source-op, load-source-op
32.9884+
32.9885+;;; prepare-source-op
32.9886+(with-upgradability ()
32.9887+ (defmethod action-description ((o prepare-source-op) (c component))
32.9888+ (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
32.9889+ (defmethod input-files ((o prepare-source-op) (s system))
32.9890+ (if-let (it (system-source-file s)) (list it)))
32.9891+ (defmethod perform ((o prepare-source-op) (c component))
32.9892+ nil))
32.9893+
32.9894+;;; load-source-op
32.9895+(with-upgradability ()
32.9896+ (defmethod action-description ((o load-source-op) (c component))
32.9897+ (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
32.9898+ (defmethod action-description ((o load-source-op) (c parent-component))
32.9899+ (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
32.9900+ (defun perform-lisp-load-source (o c)
32.9901+ "Perform the loading of a Lisp file as associated to specified action (O . C)"
32.9902+ (call-with-around-compile-hook
32.9903+ c #'(lambda ()
32.9904+ (load* (first (input-files o c))
32.9905+ :external-format (component-external-format c)))))
32.9906+
32.9907+ (defmethod perform ((o load-source-op) (c cl-source-file))
32.9908+ (perform-lisp-load-source o c))
32.9909+ (defmethod perform ((o load-source-op) (c static-file))
32.9910+ nil))
32.9911+
32.9912+
32.9913+;;;; test-op
32.9914+(with-upgradability ()
32.9915+ (defmethod perform ((o test-op) (c component))
32.9916+ nil)
32.9917+ (defmethod operation-done-p ((o test-op) (c system))
32.9918+ "Testing a system is _never_ done."
32.9919+ nil))
32.9920+;;;; -------------------------------------------------------------------------
32.9921+;;;; Finding components
32.9922+
32.9923+(uiop/package:define-package :asdf/find-component
32.9924+ (:recycle :asdf/find-component :asdf/find-system :asdf)
32.9925+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
32.9926+ :asdf/component :asdf/system :asdf/system-registry)
32.9927+ (:export
32.9928+ #:find-component
32.9929+ #:resolve-dependency-name #:resolve-dependency-spec
32.9930+ #:resolve-dependency-combination
32.9931+ ;; Conditions
32.9932+ #:missing-component #:missing-requires #:missing-parent #:missing-component-of-version #:retry
32.9933+ #:missing-dependency #:missing-dependency-of-version
32.9934+ #:missing-requires #:missing-parent
32.9935+ #:missing-required-by #:missing-version))
32.9936+(in-package :asdf/find-component)
32.9937+
32.9938+;;;; Missing component conditions
32.9939+
32.9940+(with-upgradability ()
32.9941+ (define-condition missing-component (system-definition-error)
32.9942+ ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
32.9943+ (parent :initform nil :reader missing-parent :initarg :parent)))
32.9944+
32.9945+ (define-condition missing-component-of-version (missing-component)
32.9946+ ((version :initform nil :reader missing-version :initarg :version)))
32.9947+
32.9948+ (define-condition missing-dependency (missing-component)
32.9949+ ((required-by :initarg :required-by :reader missing-required-by)))
32.9950+
32.9951+ (defmethod print-object ((c missing-dependency) s)
32.9952+ (format s (compatfmt "~@<~A, required by ~A~@:>")
32.9953+ (call-next-method c nil) (missing-required-by c)))
32.9954+
32.9955+ (define-condition missing-dependency-of-version (missing-dependency
32.9956+ missing-component-of-version)
32.9957+ ())
32.9958+
32.9959+ (defmethod print-object ((c missing-component) s)
32.9960+ (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
32.9961+ (missing-requires c)
32.9962+ (when (missing-parent c)
32.9963+ (coerce-name (missing-parent c)))))
32.9964+
32.9965+ (defmethod print-object ((c missing-component-of-version) s)
32.9966+ (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
32.9967+ (missing-requires c)
32.9968+ (missing-version c)
32.9969+ (when (missing-parent c)
32.9970+ (coerce-name (missing-parent c))))))
32.9971+
32.9972+
32.9973+;;;; Finding components
32.9974+
32.9975+(with-upgradability ()
32.9976+ (defgeneric resolve-dependency-combination (component combinator arguments)
32.9977+ (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS)
32.9978+in the context of COMPONENT"))
32.9979+
32.9980+ ;; Methods for find-component
32.9981+
32.9982+ ;; If the base component is a string, resolve it as a system, then if not nil follow the path.
32.9983+ (defmethod find-component ((base string) path &key registered)
32.9984+ (if-let ((s (if registered
32.9985+ (registered-system base)
32.9986+ (find-system base nil))))
32.9987+ (find-component s path :registered registered)))
32.9988+
32.9989+ ;; If the base component is a symbol, coerce it to a name if not nil, and resolve that.
32.9990+ ;; If nil, use the path as base if not nil, or else return nil.
32.9991+ (defmethod find-component ((base symbol) path &key registered)
32.9992+ (cond
32.9993+ (base (find-component (coerce-name base) path :registered registered))
32.9994+ (path (find-component path nil :registered registered))
32.9995+ (t nil)))
32.9996+
32.9997+ ;; If the base component is a cons cell, resolve its car, and add its cdr to the path.
32.9998+ (defmethod find-component ((base cons) path &key registered)
32.9999+ (find-component (car base) (cons (cdr base) path) :registered registered))
32.10000+
32.10001+ ;; If the base component is a parent-component and the path a string, find the named child.
32.10002+ (defmethod find-component ((parent parent-component) (name string) &key registered)
32.10003+ (declare (ignorable registered))
32.10004+ (compute-children-by-name parent :only-if-needed-p t)
32.10005+ (values (gethash name (component-children-by-name parent))))
32.10006+
32.10007+ ;; If the path is a symbol, coerce it to a name if non-nil, or else just return the base.
32.10008+ (defmethod find-component (base (name symbol) &key registered)
32.10009+ (if name
32.10010+ (find-component base (coerce-name name) :registered registered)
32.10011+ base))
32.10012+
32.10013+ ;; If the path is a cons, first resolve its car as path, then its cdr.
32.10014+ (defmethod find-component ((c component) (name cons) &key registered)
32.10015+ (find-component (find-component c (car name) :registered registered)
32.10016+ (cdr name) :registered registered))
32.10017+
32.10018+ ;; If the path is a component, return it, disregarding the base.
32.10019+ (defmethod find-component ((base t) (actual component) &key registered)
32.10020+ (declare (ignorable registered))
32.10021+ actual)
32.10022+
32.10023+ ;; Resolve dependency NAME in the context of a COMPONENT, with given optional VERSION constraint.
32.10024+ ;; This (private) function is used below by RESOLVE-DEPENDENCY-SPEC and by the :VERSION spec.
32.10025+ (defun resolve-dependency-name (component name &optional version)
32.10026+ (loop
32.10027+ (restart-case
32.10028+ (return
32.10029+ (let ((comp (find-component (component-parent component) name)))
32.10030+ (unless comp
32.10031+ (error 'missing-dependency
32.10032+ :required-by component
32.10033+ :requires name))
32.10034+ (when version
32.10035+ (unless (version-satisfies comp version)
32.10036+ (error 'missing-dependency-of-version
32.10037+ :required-by component
32.10038+ :version version
32.10039+ :requires name)))
32.10040+ comp))
32.10041+ (retry ()
32.10042+ :report (lambda (s)
32.10043+ (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
32.10044+ :test
32.10045+ (lambda (c)
32.10046+ (or (null c)
32.10047+ (and (typep c 'missing-dependency)
32.10048+ (eq (missing-required-by c) component)
32.10049+ (equal (missing-requires c) name))))
32.10050+ (unless (component-parent component)
32.10051+ (let ((name (coerce-name name)))
32.10052+ (unset-asdf-cache-entry `(find-system ,name))))))))
32.10053+
32.10054+ ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT.
32.10055+ ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON
32.10056+ ;; and by PARSE-DEFSYSTEM to process DEFSYSTEM-DEPENDS-ON.
32.10057+ (defun resolve-dependency-spec (component dep-spec)
32.10058+ (let ((component (find-component () component)))
32.10059+ (if (atom dep-spec)
32.10060+ (resolve-dependency-name component dep-spec)
32.10061+ (resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))))
32.10062+
32.10063+ ;; Methods for RESOLVE-DEPENDENCY-COMBINATION to parse lists as dependency specifications.
32.10064+ (defmethod resolve-dependency-combination (component combinator arguments)
32.10065+ (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S~@:>")
32.10066+ 'resolve-dependency-combination (cons combinator arguments) component))
32.10067+
32.10068+ (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
32.10069+ (when (featurep (first arguments))
32.10070+ (resolve-dependency-spec component (second arguments))))
32.10071+
32.10072+ (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
32.10073+ (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788
32.10074+
32.10075+;;;; -------------------------------------------------------------------------
32.10076+;;;; Forcing
32.10077+
32.10078+(uiop/package:define-package :asdf/forcing
32.10079+ (:recycle :asdf/forcing :asdf/plan :asdf)
32.10080+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
32.10081+ :asdf/component :asdf/operation :asdf/system :asdf/system-registry)
32.10082+ (:export
32.10083+ #:forcing #:make-forcing #:forced #:forced-not #:performable-p
32.10084+ #:normalize-forced-systems #:normalize-forced-not-systems
32.10085+ #:action-forced-p #:action-forced-not-p))
32.10086+(in-package :asdf/forcing)
32.10087+
32.10088+;;;; Forcing
32.10089+(with-upgradability ()
32.10090+ (defclass forcing ()
32.10091+ (;; Can plans using this forcing be PERFORMed? A plan that has different force and force-not
32.10092+ ;; settings than the session can only be used for read-only queries that do not cause the
32.10093+ ;; status of any action to be raised.
32.10094+ (performable-p :initform nil :initarg :performable-p :reader performable-p)
32.10095+ ;; Parameters
32.10096+ (parameters :initform nil :initarg :parameters :reader parameters)
32.10097+ ;; Table of systems specified via :force arguments
32.10098+ (forced :initarg :forced :reader forced)
32.10099+ ;; Table of systems specified via :force-not argument (and/or immutable)
32.10100+ (forced-not :initarg :forced-not :reader forced-not)))
32.10101+
32.10102+ (defgeneric action-forced-p (forcing operation component)
32.10103+ (:documentation "Is this action forced to happen in this plan?"))
32.10104+ (defgeneric action-forced-not-p (forcing operation component)
32.10105+ (:documentation "Is this action forced to not happen in this plan?
32.10106+Takes precedence over action-forced-p."))
32.10107+
32.10108+ (defun normalize-forced-systems (force system)
32.10109+ "Given a SYSTEM on which operate is called and the specified FORCE argument,
32.10110+extract a hash-set of systems that are forced, or a predicate on system names,
32.10111+or NIL if none are forced, or :ALL if all are."
32.10112+ (etypecase force
32.10113+ ((or (member nil :all) hash-table function) force)
32.10114+ (cons (list-to-hash-set (mapcar #'coerce-name force)))
32.10115+ ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
32.10116+
32.10117+ (defun normalize-forced-not-systems (force-not system)
32.10118+ "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument,
32.10119+and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not,
32.10120+or predicate on system names, or NIL if none are forced, or :ALL if all are."
32.10121+ (let ((requested
32.10122+ (etypecase force-not
32.10123+ ((or (member nil :all) hash-table function) force-not)
32.10124+ (cons (list-to-hash-set (mapcar #'coerce-name force-not)))
32.10125+ ((eql t) (if system (let ((name (coerce-name system)))
32.10126+ #'(lambda (x) (not (equal x name))))
32.10127+ :all)))))
32.10128+ (if (and *immutable-systems* requested)
32.10129+ #'(lambda (x) (or (call-function requested x)
32.10130+ (call-function *immutable-systems* x)))
32.10131+ (or *immutable-systems* requested))))
32.10132+
32.10133+ ;; TODO: shouldn't we be looking up the primary system name, rather than the system name?
32.10134+ (defun action-override-p (forcing operation component override-accessor)
32.10135+ "Given a plan, an action, and a function that given the plan accesses a set of overrides,
32.10136+i.e. force or force-not, see if the override applies to the current action."
32.10137+ (declare (ignore operation))
32.10138+ (call-function (funcall override-accessor forcing)
32.10139+ (coerce-name (component-system (find-component () component)))))
32.10140+
32.10141+ (defmethod action-forced-p (forcing operation component)
32.10142+ (and
32.10143+ ;; Did the user ask us to re-perform the action?
32.10144+ (action-override-p forcing operation component 'forced)
32.10145+ ;; You really can't force a builtin system and :all doesn't apply to it.
32.10146+ (not (builtin-system-p (component-system component)))))
32.10147+
32.10148+ (defmethod action-forced-not-p (forcing operation component)
32.10149+ ;; Did the user ask us to not re-perform the action?
32.10150+ ;; NB: force-not takes precedence over force, as it should
32.10151+ (action-override-p forcing operation component 'forced-not))
32.10152+
32.10153+ ;; Null forcing means no forcing either way
32.10154+ (defmethod action-forced-p ((forcing null) (operation operation) (component component))
32.10155+ nil)
32.10156+ (defmethod action-forced-not-p ((forcing null) (operation operation) (component component))
32.10157+ nil)
32.10158+
32.10159+ (defun or-function (fun1 fun2)
32.10160+ (cond
32.10161+ ((or (null fun2) (eq fun1 :all)) fun1)
32.10162+ ((or (null fun1) (eq fun2 :all)) fun2)
32.10163+ (t #'(lambda (x) (or (call-function fun1 x) (call-function fun2 x))))))
32.10164+
32.10165+ (defun make-forcing (&key performable-p system
32.10166+ (force nil force-p) (force-not nil force-not-p) &allow-other-keys)
32.10167+ (let* ((session-forcing (when *asdf-session* (forcing *asdf-session*)))
32.10168+ (system (and system (coerce-name system)))
32.10169+ (forced (normalize-forced-systems force system))
32.10170+ (forced-not (normalize-forced-not-systems force-not system))
32.10171+ (parameters `(,@(when force `(:force ,force))
32.10172+ ,@(when force-not `(:force-not ,force-not))
32.10173+ ,@(when (or (eq force t) (eq force-not t)) `(:system ,system))
32.10174+ ,@(when performable-p `(:performable-p t))))
32.10175+ forcing)
32.10176+ (cond
32.10177+ ((not session-forcing)
32.10178+ (setf forcing (make-instance 'forcing
32.10179+ :performable-p performable-p :parameters parameters
32.10180+ :forced forced :forced-not forced-not))
32.10181+ (when (and performable-p *asdf-session*)
32.10182+ (setf (forcing *asdf-session*) forcing)))
32.10183+ (performable-p
32.10184+ (when (and (not (equal parameters (parameters session-forcing)))
32.10185+ (or force-p force-not-p))
32.10186+ (parameter-error "~*~S and ~S arguments not allowed in a nested call to ~3:*~S ~
32.10187+unless identically to toplevel"
32.10188+ (find-symbol* :operate :asdf) :force :force-not))
32.10189+ (setf forcing session-forcing))
32.10190+ (t
32.10191+ (setf forcing (make-instance 'forcing
32.10192+ ;; Combine force and force-not with values from the toplevel-plan
32.10193+ :parameters `(,@parameters :on-top-of ,(parameters session-forcing))
32.10194+ :forced (or-function (forced session-forcing) forced)
32.10195+ :forced-not (or-function (forced-not session-forcing) forced-not)))))
32.10196+ forcing))
32.10197+
32.10198+ (defmethod print-object ((forcing forcing) stream)
32.10199+ (print-unreadable-object (forcing stream :type t)
32.10200+ (format stream "~{~S~^ ~}" (parameters forcing))))
32.10201+
32.10202+ ;; During upgrade, the *asdf-session* may legitimately be NIL, so we must handle that case.
32.10203+ (defmethod forcing ((x null))
32.10204+ (if-let (session (toplevel-asdf-session))
32.10205+ (forcing session)
32.10206+ (make-forcing :performable-p t)))
32.10207+
32.10208+ ;; When performing a plan that is a list of actions, use the toplevel asdf sesssion forcing.
32.10209+ (defmethod forcing ((x cons)) (forcing (toplevel-asdf-session))))
32.10210+;;;; -------------------------------------------------------------------------
32.10211+;;;; Plan
32.10212+
32.10213+(uiop/package:define-package :asdf/plan
32.10214+ ;; asdf/action below is needed for required-components, traverse-action and traverse-sub-actions
32.10215+ ;; that used to live there before 3.2.0.
32.10216+ (:recycle :asdf/plan :asdf/action :asdf)
32.10217+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
32.10218+ :asdf/component :asdf/operation :asdf/action :asdf/lisp-action
32.10219+ :asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing)
32.10220+ (:export
32.10221+ #:plan #:plan-traversal #:sequential-plan #:*plan-class*
32.10222+ #:action-status #:status-stamp #:status-index #:status-done-p #:status-keep-p #:status-need-p
32.10223+ #:action-already-done-p
32.10224+ #:+status-good+ #:+status-todo+ #:+status-void+
32.10225+ #:system-out-of-date #:action-up-to-date-p
32.10226+ #:circular-dependency #:circular-dependency-actions
32.10227+ #:needed-in-image-p
32.10228+ #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
32.10229+ #:compute-action-stamp #:traverse-action #:record-dependency
32.10230+ #:make-plan #:plan-actions #:plan-actions-r #:perform-plan #:mark-as-done
32.10231+ #:required-components #:filtered-sequential-plan
32.10232+ #:plan-component-type #:plan-keep-operation #:plan-keep-component))
32.10233+(in-package :asdf/plan)
32.10234+
32.10235+;;;; Generic plan traversal class
32.10236+(with-upgradability ()
32.10237+ (defclass plan () ()
32.10238+ (:documentation "Base class for a plan based on which ASDF can build a system"))
32.10239+ (defclass plan-traversal (plan)
32.10240+ (;; The forcing parameters for this plan. Also indicates whether the plan is performable,
32.10241+ ;; in which case the forcing is the same as for the entire session.
32.10242+ (forcing :initform (forcing (toplevel-asdf-session)) :initarg :forcing :reader forcing))
32.10243+ (:documentation "Base class for plans that simply traverse dependencies"))
32.10244+ ;; Sequential plans (the default)
32.10245+ (defclass sequential-plan (plan-traversal)
32.10246+ ((actions-r :initform nil :accessor plan-actions-r))
32.10247+ (:documentation "Simplest, default plan class, accumulating a sequence of actions"))
32.10248+
32.10249+ (defgeneric plan-actions (plan)
32.10250+ (:documentation "Extract from a plan a list of actions to perform in sequence"))
32.10251+ (defmethod plan-actions ((plan list))
32.10252+ plan)
32.10253+ (defmethod plan-actions ((plan sequential-plan))
32.10254+ (reverse (plan-actions-r plan)))
32.10255+
32.10256+ (defgeneric record-dependency (plan operation component)
32.10257+ (:documentation "Record that, within PLAN, performing OPERATION on COMPONENT depends on all
32.10258+of the (OPERATION . COMPONENT) actions in the current ASDF session's VISITING-ACTION-LIST.
32.10259+
32.10260+You can get a single action which dominates the set of dependencies corresponding to this call with
32.10261+(first (visiting-action-list *asdf-session*))
32.10262+since VISITING-ACTION-LIST is a stack whose top action depends directly on its second action,
32.10263+and whose second action depends directly on its third action, and so forth."))
32.10264+
32.10265+ ;; No need to record a dependency to build a full graph, just accumulate nodes in order.
32.10266+ (defmethod record-dependency ((plan sequential-plan) (o operation) (c component))
32.10267+ (values)))
32.10268+
32.10269+(when-upgrading (:version "3.3.0")
32.10270+ (defmethod initialize-instance :after ((plan plan-traversal) &key &allow-other-keys)))
32.10271+
32.10272+
32.10273+;;;; Planned action status
32.10274+(with-upgradability ()
32.10275+ (defclass action-status ()
32.10276+ ((bits
32.10277+ :type fixnum :initarg :bits :reader status-bits
32.10278+ :documentation "bitmap describing the status of the action.")
32.10279+ (stamp
32.10280+ :type (or integer boolean) :initarg :stamp :reader status-stamp
32.10281+ :documentation "STAMP associated with the ACTION if it has been completed already in some
32.10282+previous session or image, T if it was done and builtin the image, or NIL if it needs to be done.")
32.10283+ (level
32.10284+ :type fixnum :initarg :level :initform 0 :reader status-level
32.10285+ :documentation "the highest (operate-level) at which the action was needed")
32.10286+ (index
32.10287+ :type (or integer null) :initarg :index :initform nil :reader status-index
32.10288+ :documentation "INDEX associated with the ACTION in the current session,
32.10289+or NIL if no the status is considered outside of a specific plan."))
32.10290+ (:documentation "Status of an action in a plan"))
32.10291+
32.10292+ ;; STAMP KEEP-P DONE-P NEED-P symbol bitmap previously currently
32.10293+ ;; not-nil T T T => GOOD 7 up-to-date done (e.g. file previously loaded)
32.10294+ ;; not-nil T T NIL => HERE 6 up-to-date unplanned yet done
32.10295+ ;; not-nil T NIL T => REDO 5 up-to-date planned (e.g. file to load)
32.10296+ ;; not-nil T NIL NIL => SKIP 4 up-to-date unplanned (e.g. file compiled)
32.10297+ ;; not-nil NIL T T => DONE 3 out-of-date done
32.10298+ ;; not-nil NIL T NIL => WHAT 2 out-of-date unplanned yet done(?)
32.10299+ ;; NIL NIL NIL T => TODO 1 out-of-date planned
32.10300+ ;; NIL NIL NIL NIL => VOID 0 out-of-date unplanned
32.10301+ ;;
32.10302+ ;; Note that a VOID status cannot happen as part of a transitive dependency of a wanted node
32.10303+ ;; while traversing a node with TRAVERSE-ACTION; it can only happen while checking whether an
32.10304+ ;; action is up-to-date with ACTION-UP-TO-DATE-P.
32.10305+ ;;
32.10306+ ;; When calling TRAVERSE-ACTION, the +need-bit+ is set,
32.10307+ ;; unless the action is up-to-date and not needed-in-image (HERE, SKIP).
32.10308+ ;; When PERFORMing an action, the +done-bit+ is set.
32.10309+ ;; When the +need-bit+ is set but not the +done-bit+, the level slot indicates which level of
32.10310+ ;; OPERATE it was last marked needed for; if it happens to be needed at a higher-level, then
32.10311+ ;; its urgency (and that of its transitive dependencies) must be escalated so that it will be
32.10312+ ;; done before the end of this level of operate.
32.10313+ ;;
32.10314+ ;; Also, when no ACTION-STATUS is associated to an action yet, NIL serves as a bottom value.
32.10315+ ;;
32.10316+ (defparameter +keep-bit+ 4)
32.10317+ (defparameter +done-bit+ 2)
32.10318+ (defparameter +need-bit+ 1)
32.10319+ (defparameter +good-bits+ 7)
32.10320+ (defparameter +todo-bits+ 1)
32.10321+ (defparameter +void-bits+ 0)
32.10322+
32.10323+ (defparameter +status-good+
32.10324+ (make-instance 'action-status :bits +good-bits+ :stamp t))
32.10325+ (defparameter +status-todo+
32.10326+ (make-instance 'action-status :bits +todo-bits+ :stamp nil))
32.10327+ (defparameter +status-void+
32.10328+ (make-instance 'action-status :bits +void-bits+ :stamp nil)))
32.10329+
32.10330+(with-upgradability ()
32.10331+ (defun make-action-status (&key bits stamp (level 0) index)
32.10332+ (check-type bits (integer 0 7))
32.10333+ (check-type stamp (or integer boolean))
32.10334+ (check-type level (integer 0 #.most-positive-fixnum))
32.10335+ (check-type index (or integer null))
32.10336+ (assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) ()
32.10337+ "Bad action-status :bits ~S :stamp ~S" bits stamp)
32.10338+ (block nil
32.10339+ (when (and (null index) (zerop level))
32.10340+ (case bits
32.10341+ (#.+void-bits+ (return +status-void+))
32.10342+ (#.+todo-bits+ (return +status-todo+))
32.10343+ (#.+good-bits+ (when (eq stamp t) (return +status-good+)))))
32.10344+ (make-instance 'action-status :bits bits :stamp stamp :level level :index index)))
32.10345+
32.10346+ (defun status-keep-p (status)
32.10347+ (plusp (logand (status-bits status) #.+keep-bit+)))
32.10348+ (defun status-done-p (status)
32.10349+ (plusp (logand (status-bits status) #.+done-bit+)))
32.10350+ (defun status-need-p (status)
32.10351+ (plusp (logand (status-bits status) #.+need-bit+)))
32.10352+
32.10353+ (defun merge-action-status (status1 status2) ;; status-and
32.10354+ "Return the earliest status later than both status1 and status2"
32.10355+ (make-action-status
32.10356+ :bits (logand (status-bits status1) (status-bits status2))
32.10357+ :stamp (latest-timestamp (status-stamp status1) (status-stamp status2))
32.10358+ :level (min (status-level status1) (status-level status2))
32.10359+ :index (or (status-index status1) (status-index status2))))
32.10360+
32.10361+ (defun mark-status-needed (status &optional (level (operate-level))) ;; limited status-or
32.10362+ "Return the same status but with the need bit set, for the given level"
32.10363+ (if (and (status-need-p status)
32.10364+ (>= (status-level status) level))
32.10365+ status
32.10366+ (make-action-status
32.10367+ :bits (logior (status-bits status) +need-bit+)
32.10368+ :level (max level (status-level status))
32.10369+ :stamp (status-stamp status)
32.10370+ :index (status-index status))))
32.10371+
32.10372+ (defmethod print-object ((status action-status) stream)
32.10373+ (print-unreadable-object (status stream :type t)
32.10374+ (with-slots (bits stamp level index) status
32.10375+ (format stream "~{~S~^ ~}" `(:bits ,bits :stamp ,stamp :level ,level :index ,index)))))
32.10376+
32.10377+ (defgeneric action-status (plan operation component)
32.10378+ (:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT
32.10379+in the PLAN, or NIL if the action wasn't visited yet as part of the PLAN."))
32.10380+
32.10381+ (defgeneric (setf action-status) (new-status plan operation component)
32.10382+ (:documentation "Sets the ACTION-STATUS associated to
32.10383+the action of OPERATION on COMPONENT in the PLAN"))
32.10384+
32.10385+ (defmethod action-status ((plan null) (o operation) (c component))
32.10386+ (multiple-value-bind (stamp done-p) (component-operation-time o c)
32.10387+ (if done-p
32.10388+ (make-action-status :bits #.+keep-bit+ :stamp stamp)
32.10389+ +status-void+)))
32.10390+
32.10391+ (defmethod (setf action-status) (new-status (plan null) (o operation) (c component))
32.10392+ (let ((times (component-operation-times c)))
32.10393+ (if (status-done-p new-status)
32.10394+ (setf (gethash o times) (status-stamp new-status))
32.10395+ (remhash o times)))
32.10396+ new-status)
32.10397+
32.10398+ ;; Handle FORCED-NOT: it makes an action return its current timestamp as status
32.10399+ (defmethod action-status ((p plan) (o operation) (c component))
32.10400+ ;; TODO: should we instead test something like:
32.10401+ ;; (action-forced-not-p plan operation (primary-system component))
32.10402+ (or (gethash (make-action o c) (visited-actions *asdf-session*))
32.10403+ (when (action-forced-not-p (forcing p) o c)
32.10404+ (let ((status (action-status nil o c)))
32.10405+ (setf (gethash (make-action o c) (visited-actions *asdf-session*))
32.10406+ (make-action-status
32.10407+ :bits +good-bits+
32.10408+ :stamp (or (and status (status-stamp status)) t)
32.10409+ :index (incf (total-action-count *asdf-session*))))))))
32.10410+
32.10411+ (defmethod (setf action-status) (new-status (p plan) (o operation) (c component))
32.10412+ (setf (gethash (make-action o c) (visited-actions *asdf-session*)) new-status))
32.10413+
32.10414+ (defmethod (setf action-status) :after
32.10415+ (new-status (p sequential-plan) (o operation) (c component))
32.10416+ (unless (status-done-p new-status)
32.10417+ (push (make-action o c) (plan-actions-r p)))))
32.10418+
32.10419+
32.10420+;;;; Is the action needed in this image?
32.10421+(with-upgradability ()
32.10422+ (defgeneric needed-in-image-p (operation component)
32.10423+ (:documentation "Is the action of OPERATION on COMPONENT needed in the current image
32.10424+to be meaningful, or could it just as well have been done in another Lisp image?"))
32.10425+
32.10426+ (defmethod needed-in-image-p ((o operation) (c component))
32.10427+ ;; We presume that actions that modify the filesystem don't need be run
32.10428+ ;; in the current image if they have already been done in another,
32.10429+ ;; and can be run in another process (e.g. a fork),
32.10430+ ;; whereas those that don't are meant to side-effect the current image and can't.
32.10431+ (not (output-files o c))))
32.10432+
32.10433+
32.10434+;;;; Visiting dependencies of an action and computing action stamps
32.10435+(with-upgradability ()
32.10436+ (defun map-direct-dependencies (operation component fun)
32.10437+ "Call FUN on all the valid dependencies of the given action in the given plan"
32.10438+ (loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
32.10439+ :for dep-o = (find-operation operation dep-o-spec)
32.10440+ :when dep-o
32.10441+ :do (loop :for dep-c-spec :in dep-c-specs
32.10442+ :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
32.10443+ :when (action-valid-p dep-o dep-c)
32.10444+ :do (funcall fun dep-o dep-c))))
32.10445+
32.10446+ (defun reduce-direct-dependencies (operation component combinator seed)
32.10447+ "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR
32.10448+for each dependency action on the dependency's operation and component and an accumulator
32.10449+initialized with SEED."
32.10450+ (map-direct-dependencies
32.10451+ operation component
32.10452+ #'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed))))
32.10453+ seed)
32.10454+
32.10455+ (defun direct-dependencies (operation component)
32.10456+ "Compute a list of the direct dependencies of the action within the plan"
32.10457+ (reverse (reduce-direct-dependencies operation component #'acons nil)))
32.10458+
32.10459+ ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp
32.10460+ ;; shall also be parametrized by the plan, or by a second model object,
32.10461+ ;; so they need not refer to the state of the filesystem,
32.10462+ ;; and the stamps could be cryptographic checksums rather than timestamps.
32.10463+ ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP.
32.10464+ (define-condition dependency-not-done (warning)
32.10465+ ((op
32.10466+ :initarg :op)
32.10467+ (component
32.10468+ :initarg :component)
32.10469+ (dep-op
32.10470+ :initarg :dep-op)
32.10471+ (dep-component
32.10472+ :initarg :dep-component)
32.10473+ (plan
32.10474+ :initarg :plan
32.10475+ :initform nil))
32.10476+ (:report (lambda (condition stream)
32.10477+ (with-slots (op component dep-op dep-component plan) condition
32.10478+ (format stream "Computing just-done stamp ~@[in plan ~S~] for action ~S, but dependency ~S wasn't done yet!"
32.10479+ plan
32.10480+ (action-path (make-action op component))
32.10481+ (action-path (make-action dep-op dep-component)))))))
32.10482+
32.10483+ (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
32.10484+ ;; Given an action, figure out at what time in the past it has been done,
32.10485+ ;; or if it has just been done, return the time that it has.
32.10486+ ;; Returns two values:
32.10487+ ;; 1- the TIMESTAMP of the action if it has already been done and is up to date,
32.10488+ ;; or NIL is either hasn't been done or is out of date.
32.10489+ ;; (An ASDF extension could use a cryptographic digest instead.)
32.10490+ ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done
32.10491+ ;; in the current image, or NIL if it hasn't.
32.10492+ ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but
32.10493+ ;; hasn't been done in the current image yet, then it can have a non-NIL timestamp,
32.10494+ ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded,
32.10495+ ;; i.e. that of the input-files.
32.10496+ ;; If just-done is NIL, these values return are the notional fields of
32.10497+ ;; a KEEP, REDO or TODO status (VOID is possible, but probably an error).
32.10498+ ;; If just-done is T, they are the notional fields of DONE status
32.10499+ ;; (or, if something went wrong, TODO).
32.10500+ (nest
32.10501+ (block ())
32.10502+ (let* ((dep-status ; collect timestamp from dependencies (or T if forced or out-of-date)
32.10503+ (reduce-direct-dependencies
32.10504+ o c
32.10505+ #'(lambda (do dc status)
32.10506+ ;; out-of-date dependency: don't bother looking further
32.10507+ (let ((action-status (action-status plan do dc)))
32.10508+ (cond
32.10509+ ((and action-status (or (status-keep-p action-status)
32.10510+ (and just-done (status-stamp action-status))))
32.10511+ (merge-action-status action-status status))
32.10512+ (just-done
32.10513+ ;; It's OK to lose some ASDF action stamps during self-upgrade
32.10514+ (unless (equal "asdf" (primary-system-name dc))
32.10515+ (warn 'dependency-not-done
32.10516+ :plan plan
32.10517+ :op o :component c
32.10518+ :dep-op do :dep-component dc))
32.10519+ status)
32.10520+ (t
32.10521+ (return (values nil nil))))))
32.10522+ +status-good+))
32.10523+ (dep-stamp (status-stamp dep-status))))
32.10524+ (let* (;; collect timestamps from inputs, and exit early if any is missing
32.10525+ (in-files (input-files o c))
32.10526+ (in-stamps (mapcar #'get-file-stamp in-files))
32.10527+ (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
32.10528+ (latest-in (timestamps-latest (cons dep-stamp in-stamps))))
32.10529+ (when (and missing-in (not just-done)) (return (values nil nil))))
32.10530+ (let* (;; collect timestamps from outputs, and exit early if any is missing
32.10531+ (out-files (remove-if 'null (output-files o c)))
32.10532+ (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
32.10533+ (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
32.10534+ (earliest-out (timestamps-earliest out-stamps)))
32.10535+ (when (and missing-out (not just-done)) (return (values nil nil))))
32.10536+ (let (;; Time stamps from the files at hand, and whether any is missing
32.10537+ (all-present (not (or missing-in missing-out)))
32.10538+ ;; Has any input changed since we last generated the files?
32.10539+ ;; Note that we use timestamp<= instead of timestamp< to play nice with generated files.
32.10540+ ;; Any race condition is intrinsic to the limited timestamp resolution.
32.10541+ (up-to-date-p (timestamp<= latest-in earliest-out))
32.10542+ ;; If everything is up to date, the latest of inputs and outputs is our stamp
32.10543+ (done-stamp (timestamps-latest (cons latest-in out-stamps))))
32.10544+ ;; Warn if some files are missing:
32.10545+ ;; either our model is wrong or some other process is messing with our files.
32.10546+ (when (and just-done (not all-present))
32.10547+ ;; Shouldn't that be an error instead?
32.10548+ (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
32.10549+ ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
32.10550+ (action-description o c)
32.10551+ missing-in (length missing-in) (and missing-in missing-out)
32.10552+ missing-out (length missing-out))))
32.10553+ (let (;; There are three kinds of actions:
32.10554+ (out-op (and out-files t)) ; those that create files on the filesystem
32.10555+ ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
32.10556+ ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
32.10557+ ))
32.10558+ (if (or just-done ;; The done-stamp is valid: if we're just done, or
32.10559+ (and all-present ;; if all filesystem effects are up-to-date
32.10560+ up-to-date-p
32.10561+ (operation-done-p o c) ;; and there's no invalidating reason.
32.10562+ (not (action-forced-p (forcing (or plan *asdf-session*)) o c))))
32.10563+ (values done-stamp ;; return the hard-earned timestamp
32.10564+ (or just-done
32.10565+ out-op ;; A file-creating op is done when all files are up to date.
32.10566+ ;; An image-effecting operation is done when
32.10567+ (and (status-done-p dep-status) ;; all the dependencies were done, and
32.10568+ (multiple-value-bind (perform-stamp perform-done-p)
32.10569+ (component-operation-time o c)
32.10570+ (and perform-done-p ;; the op was actually run,
32.10571+ (equal perform-stamp done-stamp)))))) ;; with a matching stamp.
32.10572+ ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
32.10573+ (values nil nil)))))
32.10574+
32.10575+
32.10576+;;;; The four different actual traversals:
32.10577+;; * TRAVERSE-ACTION o c T: Ensure all dependencies are either up-to-date in-image, or planned
32.10578+;; * TRAVERSE-ACTION o c NIL: Ensure all dependencies are up-to-date or planned, in-image or not
32.10579+;; * ACTION-UP-TO-DATE-P: Check whether some (defsystem-depends-on ?) dependencies are up to date
32.10580+;; * COLLECT-ACTION-DEPENDENCIES: Get the dependencies (filtered), don't change any status
32.10581+(with-upgradability ()
32.10582+
32.10583+ ;; Compute the action status for a newly visited action.
32.10584+ (defun compute-action-status (plan operation component need-p)
32.10585+ (multiple-value-bind (stamp done-p)
32.10586+ (compute-action-stamp plan operation component)
32.10587+ (assert (or stamp (not done-p)))
32.10588+ (make-action-status
32.10589+ :bits (logior (if stamp #.+keep-bit+ 0)
32.10590+ (if done-p #.+done-bit+ 0)
32.10591+ (if need-p #.+need-bit+ 0))
32.10592+ :stamp stamp
32.10593+ :level (operate-level)
32.10594+ :index (incf (total-action-count *asdf-session*)))))
32.10595+
32.10596+ ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data,
32.10597+ ;; visits the action defined by its OPERATION and COMPONENT arguments,
32.10598+ ;; and all its transitive dependencies (unless already visited),
32.10599+ ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P,
32.10600+ ;; i.e. needs to be done in the current image vs merely have been done in a previous image.
32.10601+ ;;
32.10602+ ;; TRAVERSE-ACTION updates the VISITED-ACTIONS entries for the action and for all its
32.10603+ ;; transitive dependencies (that haven't been sufficiently visited so far).
32.10604+ ;; It does not return any usable value.
32.10605+ ;;
32.10606+ ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action,
32.10607+ ;; the below method would be insufficient, since it assumes a single image
32.10608+ ;; to traverse each node at most twice; non-niip actions would be traversed only once,
32.10609+ ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action.
32.10610+
32.10611+ (defun traverse-action (plan operation component needed-in-image-p)
32.10612+ (block nil
32.10613+ (unless (action-valid-p operation component) (return))
32.10614+ ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph,
32.10615+ ;; instead of just a dependency order as in vanilla ASDF.
32.10616+ ;; TODO: It is also needed to detect OPERATE-in-PERFORM.
32.10617+ (record-dependency plan operation component)
32.10618+ (while-visiting-action (operation component) ; maintain context, handle circularity.
32.10619+ ;; needed-in-image distinguishes b/w things that must happen in the
32.10620+ ;; current image and those things that simply need to have been done in a previous one.
32.10621+ (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image
32.10622+ ;; effective niip: meaningful for the action and required by the plan as traversed
32.10623+ (eniip (and aniip needed-in-image-p))
32.10624+ ;; status: have we traversed that action previously, and if so what was its status?
32.10625+ (status (action-status plan operation component))
32.10626+ (level (operate-level)))
32.10627+ (when (and status
32.10628+ (or (status-done-p status) ;; all done
32.10629+ (and (status-need-p status) (<= level (status-level status))) ;; already visited
32.10630+ (and (status-keep-p status) (not eniip)))) ;; up-to-date and not eniip
32.10631+ (return)) ; Already visited with sufficient need-in-image level!
32.10632+ (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T
32.10633+ (map-direct-dependencies ; recursively traverse dependencies
32.10634+ operation component #'(lambda (o c) (traverse-action plan o c niip)))
32.10635+ ;; AFTER dependencies have been traversed, compute action stamp
32.10636+ (let* ((status (if status
32.10637+ (mark-status-needed status level)
32.10638+ (compute-action-status plan operation component t)))
32.10639+ (out-of-date-p (not (status-keep-p status)))
32.10640+ (to-perform-p (or out-of-date-p (and niip (not (status-done-p status))))))
32.10641+ (cond ; it needs be done if it's out of date or needed in image but absent
32.10642+ ((and out-of-date-p (not niip)) ; if we need to do it,
32.10643+ (visit-action t)) ; then we need to do it *in the (current) image*!
32.10644+ (t
32.10645+ (setf (action-status plan operation component) status)
32.10646+ (when (status-done-p status)
32.10647+ (setf (component-operation-time operation component)
32.10648+ (status-stamp status)))
32.10649+ (when to-perform-p ; if it needs to be added to the plan, count it
32.10650+ (incf (planned-action-count *asdf-session*))
32.10651+ (unless aniip ; if it's output-producing, count it
32.10652+ (incf (planned-output-action-count *asdf-session*)))))))))
32.10653+ (visit-action eniip)))))) ; visit the action
32.10654+
32.10655+ ;; NB: This is not an error, not a warning, but a normal expected condition,
32.10656+ ;; to be to signaled by FIND-SYSTEM when it detects an out-of-date system,
32.10657+ ;; *before* it tries to replace it with a new definition.
32.10658+ (define-condition system-out-of-date (condition)
32.10659+ ((name :initarg :name :reader component-name))
32.10660+ (:documentation "condition signaled when a system is detected as being out of date")
32.10661+ (:report (lambda (c s)
32.10662+ (format s "system ~A is out of date" (component-name c)))))
32.10663+
32.10664+ (defun action-up-to-date-p (plan operation component)
32.10665+ "Check whether an action was up-to-date at the beginning of the session.
32.10666+Update the VISITED-ACTIONS table with the known status, but don't add anything to the PLAN."
32.10667+ (block nil
32.10668+ (unless (action-valid-p operation component) (return t))
32.10669+ (while-visiting-action (operation component) ; maintain context, handle circularity.
32.10670+ ;; Do NOT record the dependency: it might be out of date.
32.10671+ (let ((status (or (action-status plan operation component)
32.10672+ (setf (action-status plan operation component)
32.10673+ (let ((dependencies-up-to-date-p
32.10674+ (handler-case
32.10675+ (block nil
32.10676+ (map-direct-dependencies
32.10677+ operation component
32.10678+ #'(lambda (o c)
32.10679+ (unless (action-up-to-date-p plan o c)
32.10680+ (return nil))))
32.10681+ t)
32.10682+ (system-out-of-date () nil))))
32.10683+ (if dependencies-up-to-date-p
32.10684+ (compute-action-status plan operation component nil)
32.10685+ +status-void+))))))
32.10686+ (and (status-keep-p status) (status-stamp status)))))))
32.10687+
32.10688+
32.10689+;;;; Incidental traversals
32.10690+
32.10691+;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source
32.10692+;;; files required by a bundling operation.
32.10693+(with-upgradability ()
32.10694+ (defclass filtered-sequential-plan (sequential-plan)
32.10695+ ((component-type :initform t :initarg :component-type :reader plan-component-type)
32.10696+ (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation)
32.10697+ (keep-component :initform t :initarg :keep-component :reader plan-keep-component))
32.10698+ (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions."))
32.10699+
32.10700+ (defmethod initialize-instance :after ((plan filtered-sequential-plan)
32.10701+ &key system other-systems)
32.10702+ ;; Ignore force and force-not, rely on other-systems:
32.10703+ ;; force traversal of what we're interested in, i.e. current system or also others;
32.10704+ ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems.
32.10705+ (setf (slot-value plan 'forcing)
32.10706+ (make-forcing :system system :force :all :force-not (if other-systems nil t))))
32.10707+
32.10708+ (defmethod plan-actions ((plan filtered-sequential-plan))
32.10709+ (with-slots (keep-operation keep-component) plan
32.10710+ (loop :for action :in (call-next-method)
32.10711+ :as o = (action-operation action)
32.10712+ :as c = (action-component action)
32.10713+ :when (and (typep o keep-operation) (typep c keep-component))
32.10714+ :collect (make-action o c))))
32.10715+
32.10716+ (defun collect-action-dependencies (plan operation component)
32.10717+ (when (action-valid-p operation component)
32.10718+ (while-visiting-action (operation component) ; maintain context, handle circularity.
32.10719+ (let ((action (make-action operation component)))
32.10720+ (unless (nth-value 1 (gethash action (visited-actions *asdf-session*)))
32.10721+ (setf (gethash action (visited-actions *asdf-session*)) nil)
32.10722+ (when (and (typep component (plan-component-type plan))
32.10723+ (not (action-forced-not-p (forcing plan) operation component)))
32.10724+ (map-direct-dependencies operation component
32.10725+ #'(lambda (o c) (collect-action-dependencies plan o c)))
32.10726+ (push action (plan-actions-r plan))))))))
32.10727+
32.10728+ (defgeneric collect-dependencies (operation component &key &allow-other-keys)
32.10729+ (:documentation "Given an action, build a plan for all of its dependencies."))
32.10730+ (define-convenience-action-methods collect-dependencies (operation component &key))
32.10731+ (defmethod collect-dependencies ((operation operation) (component component)
32.10732+ &rest keys &key &allow-other-keys)
32.10733+ (let ((plan (apply 'make-instance 'filtered-sequential-plan
32.10734+ :system (component-system component) keys)))
32.10735+ (loop :for action :in (direct-dependencies operation component)
32.10736+ :do (collect-action-dependencies plan (action-operation action) (action-component action)))
32.10737+ (plan-actions plan)))
32.10738+
32.10739+ (defun required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
32.10740+ "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and
32.10741+return a list of the components involved in building the desired action."
32.10742+ (with-asdf-session (:override t)
32.10743+ (remove-duplicates
32.10744+ (mapcar 'action-component
32.10745+ (apply 'collect-dependencies goal-operation system
32.10746+ (remove-plist-key :goal-operation keys)))
32.10747+ :from-end t))))
32.10748+
32.10749+
32.10750+;;;; High-level interface: make-plan, perform-plan
32.10751+(with-upgradability ()
32.10752+ (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
32.10753+ (:documentation "Generate and return a plan for performing OPERATION on COMPONENT."))
32.10754+ (define-convenience-action-methods make-plan (plan-class operation component &key))
32.10755+
32.10756+ (defgeneric mark-as-done (plan-class operation component)
32.10757+ (:documentation "Mark an action as done in a plan, after performing it."))
32.10758+ (define-convenience-action-methods mark-as-done (plan-class operation component))
32.10759+
32.10760+ (defgeneric perform-plan (plan &key)
32.10761+ (:documentation "Actually perform a plan and build the requested actions"))
32.10762+
32.10763+ (defparameter* *plan-class* 'sequential-plan
32.10764+ "The default plan class to use when building with ASDF")
32.10765+
32.10766+ (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
32.10767+ (with-asdf-session ()
32.10768+ (let ((plan (apply 'make-instance (or plan-class *plan-class*) keys)))
32.10769+ (traverse-action plan o c t)
32.10770+ plan)))
32.10771+
32.10772+ (defmethod perform-plan :around ((plan t) &key)
32.10773+ (assert (performable-p (forcing plan)) () "plan not performable")
32.10774+ (let ((*package* *package*)
32.10775+ (*readtable* *readtable*))
32.10776+ (with-compilation-unit () ;; backward-compatibility.
32.10777+ (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
32.10778+
32.10779+ (defun action-already-done-p (plan operation component)
32.10780+ (if-let (status (action-status plan operation component))
32.10781+ (status-done-p status)))
32.10782+
32.10783+ (defmethod perform-plan ((plan t) &key)
32.10784+ (loop :for action :in (plan-actions plan)
32.10785+ :as o = (action-operation action)
32.10786+ :as c = (action-component action) :do
32.10787+ (unless (action-already-done-p plan o c)
32.10788+ (perform-with-restarts o c)
32.10789+ (mark-as-done plan o c))))
32.10790+
32.10791+ (defmethod mark-as-done ((plan plan) (o operation) (c component))
32.10792+ (let ((plan-status (action-status plan o c))
32.10793+ (perform-status (action-status nil o c)))
32.10794+ (assert (and (status-stamp perform-status) (status-keep-p perform-status)) ()
32.10795+ "Just performed ~A but failed to mark it done" (action-description o c))
32.10796+ (setf (action-status plan o c)
32.10797+ (make-action-status
32.10798+ :bits (logior (status-bits plan-status) +done-bit+)
32.10799+ :stamp (status-stamp perform-status)
32.10800+ :level (status-level plan-status)
32.10801+ :index (status-index plan-status))))))
32.10802+;;;; -------------------------------------------------------------------------
32.10803+;;;; Invoking Operations
32.10804+
32.10805+(uiop/package:define-package :asdf/operate
32.10806+ (:recycle :asdf/operate :asdf)
32.10807+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
32.10808+ :asdf/component :asdf/system :asdf/system-registry :asdf/find-component
32.10809+ :asdf/operation :asdf/action :asdf/lisp-action :asdf/forcing :asdf/plan)
32.10810+ (:export
32.10811+ #:operate #:oos #:build-op #:make
32.10812+ #:load-system #:load-systems #:load-systems*
32.10813+ #:compile-system #:test-system #:require-system #:module-provide-asdf
32.10814+ #:component-loaded-p #:already-loaded-systems
32.10815+ #:recursive-operate))
32.10816+(in-package :asdf/operate)
32.10817+
32.10818+(with-upgradability ()
32.10819+ (defgeneric operate (operation component &key)
32.10820+ (:documentation
32.10821+ "Operate does mainly four things for the user:
32.10822+
32.10823+1. Resolves the OPERATION designator into an operation object.
32.10824+ OPERATION is typically a symbol denoting an operation class, instantiated with MAKE-OPERATION.
32.10825+2. Resolves the COMPONENT designator into a component object.
32.10826+ COMPONENT is typically a string or symbol naming a system, loaded from disk using FIND-SYSTEM.
32.10827+3. It then calls MAKE-PLAN with the operation and system as arguments.
32.10828+4. Finally calls PERFORM-PLAN on the resulting plan to actually build the system.
32.10829+
32.10830+The entire computation is wrapped in WITH-COMPILATION-UNIT and error handling code.
32.10831+If a VERSION argument is supplied, then operate also ensures that the system found satisfies it
32.10832+using the VERSION-SATISFIES method.
32.10833+If a PLAN-CLASS argument is supplied, that class is used for the plan.
32.10834+If a PLAN-OPTIONS argument is supplied, the options are passed to the plan.
32.10835+
32.10836+The :FORCE or :FORCE-NOT argument to OPERATE can be:
32.10837+ T to force the inside of the specified system to be rebuilt (resp. not),
32.10838+ without recursively forcing the other systems we depend on.
32.10839+ :ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
32.10840+ (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
32.10841+:FORCE-NOT has precedence over :FORCE; builtin systems cannot be forced.
32.10842+
32.10843+For backward compatibility, all keyword arguments are passed to MAKE-OPERATION
32.10844+when instantiating a new operation, that will in turn be inherited by new operations.
32.10845+But do NOT depend on it, for this is deprecated behavior."))
32.10846+
32.10847+ (define-convenience-action-methods operate (operation component &key)
32.10848+ :if-no-component (error 'missing-component :requires component))
32.10849+
32.10850+ ;; This method ensures that an ASDF upgrade is attempted as the very first thing,
32.10851+ ;; with suitable state preservation in case in case it actually happens,
32.10852+ ;; and that a few suitable dynamic bindings are established.
32.10853+ (defmethod operate :around (operation component &rest keys
32.10854+ &key verbose
32.10855+ (on-warnings *compile-file-warnings-behaviour*)
32.10856+ (on-failure *compile-file-failure-behaviour*))
32.10857+ (nest
32.10858+ (with-asdf-session ())
32.10859+ (let* ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
32.10860+ (etypecase operation
32.10861+ (operation (let ((name (type-of operation)))
32.10862+ #'(lambda () (make-operation name))))
32.10863+ ((or symbol string) (constantly operation))))
32.10864+ (component-path (typecase component ;; to remake the component after ASDF upgrade
32.10865+ (component (component-find-path component))
32.10866+ (t component)))
32.10867+ (system-name (labels ((first-name (x)
32.10868+ (etypecase x
32.10869+ ((or string symbol) x) ; NB: includes the NIL case.
32.10870+ (cons (or (first-name (car x)) (first-name (cdr x)))))))
32.10871+ (coerce-name (first-name component-path)))))
32.10872+ (apply 'make-forcing :performable-p t :system system-name keys)
32.10873+ ;; Before we operate on any system, make sure ASDF is up-to-date,
32.10874+ ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
32.10875+ (unless (asdf-upgraded-p (toplevel-asdf-session))
32.10876+ (setf (asdf-upgraded-p (toplevel-asdf-session)) t)
32.10877+ (when (upgrade-asdf)
32.10878+ ;; If we were upgraded, restart OPERATE the hardest of ways, for
32.10879+ ;; its function may have been redefined.
32.10880+ (return-from operate
32.10881+ (with-asdf-session (:override t :override-cache t)
32.10882+ (apply 'operate (funcall operation-remaker) component-path keys))))))
32.10883+ ;; Setup proper bindings around any operate call.
32.10884+ (let* ((*verbose-out* (and verbose *standard-output*))
32.10885+ (*compile-file-warnings-behaviour* on-warnings)
32.10886+ (*compile-file-failure-behaviour* on-failure)))
32.10887+ (unwind-protect
32.10888+ (progn
32.10889+ (incf (operate-level))
32.10890+ (call-next-method))
32.10891+ (decf (operate-level)))))
32.10892+
32.10893+ (defmethod operate :before ((operation operation) (component component)
32.10894+ &key version)
32.10895+ (unless (version-satisfies component version)
32.10896+ (error 'missing-component-of-version :requires component :version version))
32.10897+ (record-dependency nil operation component))
32.10898+
32.10899+ (defmethod operate ((operation operation) (component component)
32.10900+ &key plan-class plan-options)
32.10901+ (let ((plan (apply 'make-plan plan-class operation component
32.10902+ :forcing (forcing *asdf-session*) plan-options)))
32.10903+ (perform-plan plan)
32.10904+ (values operation plan)))
32.10905+
32.10906+ (defun oos (operation component &rest args &key &allow-other-keys)
32.10907+ (apply 'operate operation component args))
32.10908+
32.10909+ (setf (documentation 'oos 'function)
32.10910+ (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
32.10911+ (documentation 'operate 'function)))
32.10912+
32.10913+ (define-condition recursive-operate (warning)
32.10914+ ((operation :initarg :operation :reader condition-operation)
32.10915+ (component :initarg :component :reader condition-component)
32.10916+ (action :initarg :action :reader condition-action))
32.10917+ (:report (lambda (c s)
32.10918+ (format s (compatfmt "~@<Deprecated recursive use of (~S '~S '~S) while visiting ~S ~
32.10919+- please use proper dependencies instead~@:>")
32.10920+ 'operate
32.10921+ (type-of (condition-operation c))
32.10922+ (component-find-path (condition-component c))
32.10923+ (action-path (condition-action c)))))))
32.10924+
32.10925+;;;; Common operations
32.10926+(when-upgrading ()
32.10927+ (defmethod component-depends-on ((o prepare-op) (s system))
32.10928+ (call-next-method)))
32.10929+(with-upgradability ()
32.10930+ (defclass build-op (non-propagating-operation) ()
32.10931+ (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
32.10932+to operate by default on a system or component, via the function BUILD.
32.10933+Its meaning is configurable via the :BUILD-OPERATION option of a component.
32.10934+which typically specifies the name of a specific operation to which to delegate the build,
32.10935+as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on);
32.10936+if NIL is specified (the default), BUILD-OP falls back to LOAD-OP,
32.10937+that will load the system in the current image."))
32.10938+ (defmethod component-depends-on ((o build-op) (c component))
32.10939+ `((,(or (component-build-operation c) 'load-op) ,c)
32.10940+ ,@(call-next-method)))
32.10941+
32.10942+ (defun make (system &rest keys)
32.10943+ "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO).
32.10944+It will build system FOO using the operation BUILD-OP,
32.10945+the meaning of which is configurable by the system, and
32.10946+defaults to LOAD-OP, to load it in current image."
32.10947+ (apply 'operate 'build-op system keys)
32.10948+ t)
32.10949+
32.10950+ (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys)
32.10951+ "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details."
32.10952+ (declare (ignore force force-not verbose version))
32.10953+ (apply 'operate 'load-op system keys)
32.10954+ t)
32.10955+
32.10956+ (defun load-systems* (systems &rest keys)
32.10957+ "Loading multiple systems at once."
32.10958+ (dolist (s systems) (apply 'load-system s keys)))
32.10959+
32.10960+ (defun load-systems (&rest systems)
32.10961+ "Loading multiple systems at once."
32.10962+ (load-systems* systems))
32.10963+
32.10964+ (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys)
32.10965+ "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details."
32.10966+ (declare (ignore force force-not verbose version))
32.10967+ (apply 'operate 'compile-op system args)
32.10968+ t)
32.10969+
32.10970+ (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys)
32.10971+ "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details."
32.10972+ (declare (ignore force force-not verbose version))
32.10973+ (apply 'operate 'test-op system args)
32.10974+ t))
32.10975+
32.10976+;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE,
32.10977+;; only tries to load its specified target if it's not loaded yet.
32.10978+(with-upgradability ()
32.10979+ (defun component-loaded-p (component)
32.10980+ "Has the given COMPONENT been successfully loaded in the current image (yet)?
32.10981+Note that this returns true even if the component is not up to date."
32.10982+ (if-let ((component (find-component component () :registered t)))
32.10983+ (nth-value 1 (component-operation-time (make-operation 'load-op) component))))
32.10984+
32.10985+ (defun already-loaded-systems ()
32.10986+ "return a list of the names of the systems that have been successfully loaded so far"
32.10987+ (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*)))))
32.10988+
32.10989+
32.10990+;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
32.10991+;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
32.10992+;; Note that despite the two being homonyms, the _function_ require-system
32.10993+;; and the _class_ require-system are quite distinct entities, fulfilling independent purposes.
32.10994+(with-upgradability ()
32.10995+ (defvar *modules-being-required* nil)
32.10996+
32.10997+ (defclass require-system (system)
32.10998+ ((module :initarg :module :initform nil :accessor required-module))
32.10999+ (:documentation "A SYSTEM subclass whose processing is handled by
32.11000+the implementation's REQUIRE rather than by internal ASDF mechanisms."))
32.11001+
32.11002+ (defmethod perform ((o compile-op) (c require-system))
32.11003+ nil)
32.11004+
32.11005+ (defmethod perform ((o load-op) (s require-system))
32.11006+ (let* ((module (or (required-module s) (coerce-name s)))
32.11007+ (*modules-being-required* (cons module *modules-being-required*)))
32.11008+ (assert (null (component-children s)))
32.11009+ (require module)))
32.11010+
32.11011+ (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
32.11012+ (unless (and (length=n-p arguments 1)
32.11013+ (typep (car arguments) '(or string (and symbol (not null)))))
32.11014+ (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S. ~S takes one argument, a string or non-null symbol~@:>")
32.11015+ 'resolve-dependency-combination
32.11016+ (cons combinator arguments) component combinator))
32.11017+ ;; :require must be prepared for some implementations providing modules using ASDF,
32.11018+ ;; as SBCL used to do, and others may might do. Thus, the system provided in the end
32.11019+ ;; would be a downcased name as per module-provide-asdf above. For the same reason,
32.11020+ ;; we cannot assume that the system in the end will be of type require-system,
32.11021+ ;; but must check whether we can use find-system and short-circuit cl:require.
32.11022+ ;; Otherwise, calling cl:require could result in nasty reentrant calls between
32.11023+ ;; cl:require and asdf:operate that could potentially blow up the stack,
32.11024+ ;; all the while defeating the consistency of the dependency graph.
32.11025+ (let* ((module (car arguments)) ;; NB: we already checked that it was not null
32.11026+ ;; CMUCL, MKCL, SBCL like their module names to be all upcase.
32.11027+ (module-name (string module))
32.11028+ (system-name (string-downcase module))
32.11029+ (system (find-system system-name nil)))
32.11030+ (or system (let ((system (make-instance 'require-system :name system-name :module module-name)))
32.11031+ (register-system system)
32.11032+ system))))
32.11033+
32.11034+ (defun module-provide-asdf (name)
32.11035+ ;; We must use string-downcase, because modules are traditionally specified as symbols,
32.11036+ ;; that implementations traditionally normalize as uppercase, for which we seek a system
32.11037+ ;; with a name that is traditionally in lowercase. Case is lost along the way. That's fine.
32.11038+ ;; We could make complex, non-portable rules to try to preserve case, and just documenting
32.11039+ ;; them would be a hell that it would be a disservice to inflict on users.
32.11040+ (let ((module-name (string name))
32.11041+ (system-name (string-downcase name)))
32.11042+ (unless (member module-name *modules-being-required* :test 'equal)
32.11043+ (let ((*modules-being-required* (cons module-name *modules-being-required*))
32.11044+ #+sbcl (sb-impl::*requiring* (remove module-name sb-impl::*requiring* :test 'equal)))
32.11045+ (handler-bind
32.11046+ (((or style-warning recursive-operate) #'muffle-warning)
32.11047+ (missing-component (constantly nil))
32.11048+ (fatal-condition
32.11049+ #'(lambda (e)
32.11050+ (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
32.11051+ name e))))
32.11052+ (let ((*verbose-out* (make-broadcast-stream)))
32.11053+ (let ((system (find-system system-name nil)))
32.11054+ (when system
32.11055+ ;; Do not use require-system after all, use load-system:
32.11056+ ;; on the one hand, REQUIRE already uses *MODULES* not to load something twice,
32.11057+ ;; on the other hand, REQUIRE-SYSTEM uses FORCE-NOT which may conflict with
32.11058+ ;; the toplevel session forcing settings.
32.11059+ (load-system system :verbose nil)
32.11060+ t)))))))))
32.11061+
32.11062+
32.11063+;;;; Some upgrade magic
32.11064+(with-upgradability ()
32.11065+ (defun restart-upgraded-asdf ()
32.11066+ ;; If we're in the middle of something, restart it.
32.11067+ (let ((systems-being-defined
32.11068+ (when *asdf-session*
32.11069+ (prog1
32.11070+ (loop :for k :being :the hash-keys :of (asdf-cache)
32.11071+ :when (eq (first k) 'find-system) :collect (second k))
32.11072+ (clrhash (asdf-cache))))))
32.11073+ ;; Regardless, clear defined systems, since they might be invalid
32.11074+ ;; after an incompatible ASDF upgrade.
32.11075+ (clear-registered-systems)
32.11076+ ;; The configuration also may have to be upgraded.
32.11077+ (upgrade-configuration)
32.11078+ ;; If we were in the middle of an operation, be sure to restore the system being defined.
32.11079+ (dolist (s systems-being-defined) (find-system s nil))))
32.11080+ (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf))
32.11081+;;;; -------------------------------------------------------------------------
32.11082+;;;; Finding systems
32.11083+
32.11084+(uiop/package:define-package :asdf/find-system
32.11085+ (:recycle :asdf/find-system :asdf)
32.11086+ (:use :uiop/common-lisp :uiop :asdf/upgrade
32.11087+ :asdf/session :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-action
32.11088+ :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate)
32.11089+ (:import-from #:asdf/component #:%additional-input-files)
32.11090+ (:export
32.11091+ #:find-system #:locate-system #:load-asd #:define-op
32.11092+ #:load-system-definition-error #:error-name #:error-pathname #:error-condition))
32.11093+(in-package :asdf/find-system)
32.11094+
32.11095+(with-upgradability ()
32.11096+ (define-condition load-system-definition-error (system-definition-error)
32.11097+ ((name :initarg :name :reader error-name)
32.11098+ (pathname :initarg :pathname :reader error-pathname)
32.11099+ (condition :initarg :condition :reader error-condition))
32.11100+ (:report (lambda (c s)
32.11101+ (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
32.11102+ (error-name c) (error-pathname c) (error-condition c)))))
32.11103+
32.11104+
32.11105+ ;;; Methods for find-system
32.11106+
32.11107+ ;; Reject NIL as a system designator.
32.11108+ (defmethod find-system ((name null) &optional (error-p t))
32.11109+ (when error-p
32.11110+ (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
32.11111+
32.11112+ ;; Default method for find-system: resolve the argument using COERCE-NAME.
32.11113+ (defmethod find-system (name &optional (error-p t))
32.11114+ (find-system (coerce-name name) error-p))
32.11115+
32.11116+ (defun find-system-if-being-defined (name)
32.11117+ ;; This function finds systems being defined *in the current ASDF session*, as embodied by
32.11118+ ;; its session cache, even before they are fully defined and registered in *registered-systems*.
32.11119+ ;; The purpose of this function is to prevent races between two files that might otherwise
32.11120+ ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow.
32.11121+ ;; This function explicitly MUST NOT find definitions merely registered in previous sessions.
32.11122+ ;; NB: this function depends on a corresponding side-effect in parse-defsystem;
32.11123+ ;; the precise protocol between the two functions may change in the future (or not).
32.11124+ (first (gethash `(find-system ,(coerce-name name)) (asdf-cache))))
32.11125+
32.11126+ (defclass define-op (non-propagating-operation) ()
32.11127+ (:documentation "An operation to record dependencies on loading a .asd file."))
32.11128+
32.11129+ (defmethod record-dependency ((plan null) (operation t) (component t))
32.11130+ (unless (or (typep operation 'define-op)
32.11131+ (and (typep operation 'load-op)
32.11132+ (typep component 'system)
32.11133+ (equal "asdf" (coerce-name component))))
32.11134+ (if-let ((action (first (visiting-action-list *asdf-session*))))
32.11135+ (let ((parent-operation (action-operation action))
32.11136+ (parent-component (action-component action)))
32.11137+ (cond
32.11138+ ((and (typep parent-operation 'define-op)
32.11139+ (typep parent-component 'system))
32.11140+ (let ((action (cons operation component)))
32.11141+ (unless (gethash action (definition-dependency-set parent-component))
32.11142+ (push (cons operation component) (definition-dependency-list parent-component))
32.11143+ (setf (gethash action (definition-dependency-set parent-component)) t))))
32.11144+ (t
32.11145+ (warn 'recursive-operate
32.11146+ :operation operation :component component :action action)))))))
32.11147+
32.11148+ (defmethod component-depends-on ((o define-op) (s system))
32.11149+ `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below.
32.11150+ ;; 2- We don't call-next-method to avoid other methods
32.11151+ ,@(loop :for (o . c) :in (definition-dependency-list s) :collect (list o c))))
32.11152+
32.11153+ (defmethod component-depends-on ((o operation) (s system))
32.11154+ `(,@(when (and (not (typep o 'define-op))
32.11155+ (or (system-source-file s) (definition-dependency-list s)))
32.11156+ `((define-op ,(primary-system-name s))))
32.11157+ ,@(call-next-method)))
32.11158+
32.11159+ (defmethod perform ((o operation) (c undefined-system))
32.11160+ (sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c)))
32.11161+
32.11162+ ;; TODO: could this file be refactored so that locate-system is merely
32.11163+ ;; the cache-priming call to input-files here?
32.11164+ (defmethod input-files ((o define-op) (s system))
32.11165+ (if-let ((asd (system-source-file s))) (list asd)))
32.11166+
32.11167+ (defmethod perform ((o define-op) (s system))
32.11168+ (nest
32.11169+ (if-let ((pathname (first (input-files o s)))))
32.11170+ (let ((readtable *readtable*) ;; save outer syntax tables. TODO: proper syntax-control
32.11171+ (print-pprint-dispatch *print-pprint-dispatch*)))
32.11172+ (with-standard-io-syntax)
32.11173+ (let ((*print-readably* nil)
32.11174+ ;; Note that our backward-compatible *readtable* is
32.11175+ ;; a global readtable that gets globally side-effected. Ouch.
32.11176+ ;; Same for the *print-pprint-dispatch* table.
32.11177+ ;; We should do something about that for ASDF3 if possible, or else ASDF4.
32.11178+ (*readtable* readtable) ;; restore inside syntax table
32.11179+ (*print-pprint-dispatch* print-pprint-dispatch)
32.11180+ (*package* (find-package :asdf-user))
32.11181+ (*default-pathname-defaults*
32.11182+ ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
32.11183+ (pathname-directory-pathname (physicalize-pathname pathname)))))
32.11184+ (handler-bind
32.11185+ (((and error (not missing-component))
32.11186+ #'(lambda (condition)
32.11187+ (error 'load-system-definition-error
32.11188+ :name (coerce-name s) :pathname pathname :condition condition))))
32.11189+ (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
32.11190+ (coerce-name s) pathname)
32.11191+ ;; dependencies will depend on what's loaded via definition-dependency-list
32.11192+ (unset-asdf-cache-entry `(component-depends-on ,o ,s))
32.11193+ (unset-asdf-cache-entry `(input-files ,o ,s)))
32.11194+ (load* pathname :external-format (encoding-external-format (detect-encoding pathname)))))
32.11195+
32.11196+ (defun load-asd (pathname &key name)
32.11197+ "Load system definitions from PATHNAME.
32.11198+NAME if supplied is the name of a system expected to be defined in that file.
32.11199+
32.11200+Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
32.11201+ (with-asdf-session ()
32.11202+ ;; TODO: use OPERATE, so we consult the cache and only load once per session.
32.11203+ (flet ((do-it (o c) (operate o c)))
32.11204+ (let ((primary-name (primary-system-name (or name (pathname-name pathname))))
32.11205+ (operation (make-operation 'define-op)))
32.11206+ (if-let (system (registered-system primary-name))
32.11207+ (progn
32.11208+ ;; We already determine this to be obsolete ---
32.11209+ ;; or should we move some tests from find-system to check for up-to-date-ness here?
32.11210+ (setf (component-operation-time operation system) t
32.11211+ (definition-dependency-list system) nil
32.11212+ (definition-dependency-set system) (list-to-hash-set nil))
32.11213+ (do-it operation system))
32.11214+ (let ((system (make-instance 'undefined-system
32.11215+ :name primary-name :source-file pathname)))
32.11216+ (register-system system)
32.11217+ (unwind-protect (do-it operation system)
32.11218+ (when (typep system 'undefined-system)
32.11219+ (clear-system system)))))))))
32.11220+
32.11221+ (defvar *old-asdf-systems* (make-hash-table :test 'equal))
32.11222+
32.11223+ ;; (Private) function to check that a system that was found isn't an asdf downgrade.
32.11224+ ;; Returns T if everything went right, NIL if the system was an ASDF at an older version,
32.11225+ ;; or UIOP of the same or older version, that shall not be loaded.
32.11226+ ;; Also issue a warning if it was a strictly older version of ASDF.
32.11227+ (defun check-not-old-asdf-system (name pathname)
32.11228+ (or (not (member name '("asdf" "uiop") :test 'equal))
32.11229+ (null pathname)
32.11230+ (let* ((asdfp (equal name "asdf")) ;; otherwise, it's uiop
32.11231+ (version-pathname
32.11232+ (subpathname pathname "version" :type (if asdfp "lisp-expr" "lisp")))
32.11233+ (version (and (probe-file* version-pathname :truename nil)
32.11234+ (read-file-form version-pathname :at (if asdfp '(0) '(2 2 2)))))
32.11235+ (old-version (asdf-version)))
32.11236+ (cond
32.11237+ ;; Same version is OK for ASDF, to allow loading from modified source.
32.11238+ ;; However, do *not* load UIOP of the exact same version:
32.11239+ ;; it was already loaded it as part of ASDF and would only be double-loading.
32.11240+ ;; Be quiet about it, though, since it's a normal situation.
32.11241+ ((equal old-version version) asdfp)
32.11242+ ((version< old-version version) t) ;; newer version: Good!
32.11243+ (t ;; old version: bad
32.11244+ (ensure-gethash
32.11245+ (list (namestring pathname) version) *old-asdf-systems*
32.11246+ #'(lambda ()
32.11247+ (let ((old-pathname (system-source-file (registered-system "asdf"))))
32.11248+ (if asdfp
32.11249+ (warn "~@<~
32.11250+ You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
32.11251+ or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
32.11252+ ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~
32.11253+ Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~
32.11254+ and having an old version registered is a configuration error. ~
32.11255+ ASDF will ignore this configured system rather than downgrade itself. ~
32.11256+ In the future, you may want to either: ~
32.11257+ (a) upgrade this configured ASDF to a newer version, ~
32.11258+ (b) install a newer ASDF and register it in front of the former in your configuration, or ~
32.11259+ (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~
32.11260+ Note that the older ASDF might be registered implicitly through configuration inherited ~
32.11261+ from your system installation, in which case you might have to specify ~
32.11262+ :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~
32.11263+ or other source-registry configuration file, environment variable or lisp parameter. ~
32.11264+ Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~
32.11265+ that you might want to upgrade (if a recent enough version is available) ~
32.11266+ or else remove altogether (since most implementations ship with a recent asdf); ~
32.11267+ if you lack the system administration rights to upgrade or remove this package, ~
32.11268+ then you might indeed want to either install and register a more recent version, ~
32.11269+ or use :ignore-inherited-configuration to avoid registering the old one. ~
32.11270+ Please consult ASDF documentation and/or experts.~@:>~%"
32.11271+ old-version old-pathname version pathname)
32.11272+ ;; NB: for UIOP, don't warn, just ignore.
32.11273+ (warn "ASDF ~A (from ~A), UIOP ~A (from ~A)"
32.11274+ old-version old-pathname version pathname)
32.11275+ ))))
32.11276+ nil))))) ;; only issue the warning the first time, but always return nil
32.11277+
32.11278+ (defun locate-system (name)
32.11279+ "Given a system NAME designator, try to locate where to load the system from.
32.11280+Returns six values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME PREVIOUS-PRIMARY
32.11281+FOUNDP is true when a system was found,
32.11282+either a new unregistered one or a previously registered one.
32.11283+FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed.
32.11284+PATHNAME when not null is a path from which to load the system,
32.11285+either associated with FOUND-SYSTEM, or with the PREVIOUS system.
32.11286+PREVIOUS when not null is a previously loaded SYSTEM object of same name.
32.11287+PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
32.11288+PREVIOUS-PRIMARY when not null is the primary system for the PREVIOUS system."
32.11289+ (with-asdf-session () ;; NB: We don't cache the results. We once used to, but it wasn't useful,
32.11290+ ;; and keeping a negative cache was a bug (see lp#1335323), which required
32.11291+ ;; explicit invalidation in clear-system and find-system (when unsucccessful).
32.11292+ (let* ((name (coerce-name name))
32.11293+ (previous (registered-system name)) ; load from disk if absent or newer on disk
32.11294+ (previous-primary-name (and previous (primary-system-name previous)))
32.11295+ (previous-primary-system (and previous-primary-name
32.11296+ (registered-system previous-primary-name)))
32.11297+ (previous-time (and previous-primary-system
32.11298+ (component-operation-time 'define-op previous-primary-system)))
32.11299+ (found (search-for-system-definition name))
32.11300+ (found-system (and (typep found 'system) found))
32.11301+ (pathname (ensure-pathname
32.11302+ (or (and (typep found '(or pathname string)) (pathname found))
32.11303+ (system-source-file found-system)
32.11304+ (system-source-file previous))
32.11305+ :want-absolute t :resolve-symlinks *resolve-symlinks*))
32.11306+ (foundp (and (or found-system pathname previous) t)))
32.11307+ (check-type found (or null pathname system))
32.11308+ (unless (check-not-old-asdf-system name pathname)
32.11309+ (check-type previous system) ;; asdf is preloaded, so there should be a previous one.
32.11310+ (setf found-system nil pathname nil))
32.11311+ (values foundp found-system pathname previous previous-time previous-primary-system))))
32.11312+
32.11313+ ;; TODO: make a prepare-define-op node for this
32.11314+ ;; so we can properly cache the answer rather than recompute it.
32.11315+ (defun definition-dependencies-up-to-date-p (system)
32.11316+ (check-type system system)
32.11317+ (or (not (primary-system-p system))
32.11318+ (handler-case
32.11319+ (loop :with plan = (make-instance *plan-class*)
32.11320+ :for action :in (definition-dependency-list system)
32.11321+ :always (action-up-to-date-p
32.11322+ plan (action-operation action) (action-component action))
32.11323+ :finally
32.11324+ (let ((o (make-operation 'define-op)))
32.11325+ (multiple-value-bind (stamp done-p)
32.11326+ (compute-action-stamp plan o system)
32.11327+ (return (and (timestamp<= stamp (component-operation-time o system))
32.11328+ done-p)))))
32.11329+ (system-out-of-date () nil))))
32.11330+
32.11331+ ;; Main method for find-system: first, make sure the computation is memoized in a session cache.
32.11332+ ;; Unless the system is immutable, use locate-system to find the primary system;
32.11333+ ;; reconcile the finding (if any) with any previous definition (in a previous session,
32.11334+ ;; preloaded, with a previous configuration, or before filesystem changes), and
32.11335+ ;; load a found .asd if appropriate. Finally, update registration table and return results.
32.11336+ (defmethod find-system ((name string) &optional (error-p t))
32.11337+ (nest
32.11338+ (with-asdf-session (:key `(find-system ,name)))
32.11339+ (let ((name-primary-p (primary-system-p name)))
32.11340+ (unless name-primary-p (find-system (primary-system-name name) nil)))
32.11341+ (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)))
32.11342+ (multiple-value-bind (foundp found-system pathname previous previous-time previous-primary)
32.11343+ (locate-system name)
32.11344+ (assert (eq foundp (and (or found-system pathname previous) t))))
32.11345+ (let ((previous-pathname (system-source-file previous))
32.11346+ (system (or previous found-system)))
32.11347+ (when (and found-system (not previous))
32.11348+ (register-system found-system))
32.11349+ (when (and system pathname)
32.11350+ (setf (system-source-file system) pathname))
32.11351+ (if-let ((stamp (get-file-stamp pathname)))
32.11352+ (let ((up-to-date-p
32.11353+ (and previous previous-primary
32.11354+ (or (pathname-equal pathname previous-pathname)
32.11355+ (and pathname previous-pathname
32.11356+ (pathname-equal
32.11357+ (physicalize-pathname pathname)
32.11358+ (physicalize-pathname previous-pathname))))
32.11359+ (timestamp<= stamp previous-time)
32.11360+ ;; Check that all previous definition-dependencies are up-to-date,
32.11361+ ;; traversing them without triggering the adding of nodes to the plan.
32.11362+ ;; TODO: actually have a prepare-define-op, extract its timestamp,
32.11363+ ;; and check that it is less than the stamp of the previous define-op ?
32.11364+ (definition-dependencies-up-to-date-p previous-primary))))
32.11365+ (unless up-to-date-p
32.11366+ (restart-case
32.11367+ (signal 'system-out-of-date :name name)
32.11368+ (continue () :report "continue"))
32.11369+ (load-asd pathname :name name)))))
32.11370+ ;; Try again after having loaded from disk if needed
32.11371+ (or (registered-system name)
32.11372+ (when error-p (error 'missing-component :requires name)))))
32.11373+
32.11374+ ;; Resolved forward reference for asdf/system-registry.
32.11375+ (defun mark-component-preloaded (component)
32.11376+ "Mark a component as preloaded."
32.11377+ (let ((component (find-component component nil :registered t)))
32.11378+ ;; Recurse to children, so asdf/plan will hopefully be happy.
32.11379+ (map () 'mark-component-preloaded (component-children component))
32.11380+ ;; Mark the timestamps of the common lisp-action operations as 0.
32.11381+ (let ((cot (component-operation-times component)))
32.11382+ (dolist (o `(,@(when (primary-system-p component) '(define-op))
32.11383+ prepare-op compile-op load-op))
32.11384+ (setf (gethash (make-operation o) cot) 0))))))
32.11385+;;;; -------------------------------------------------------------------------
32.11386+;;;; Defsystem
32.11387+
32.11388+(uiop/package:define-package :asdf/parse-defsystem
32.11389+ (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
32.11390+ (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
32.11391+ (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
32.11392+ :asdf/session :asdf/component :asdf/system :asdf/system-registry
32.11393+ :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
32.11394+ (:import-from :asdf/system #:depends-on #:weakly-depends-on)
32.11395+ ;; these needed for record-additional-system-input-file
32.11396+ (:import-from :asdf/operation #:make-operation)
32.11397+ (:import-from :asdf/component #:%additional-input-files)
32.11398+ (:import-from :asdf/find-system #:define-op)
32.11399+ (:export
32.11400+ #:defsystem #:register-system-definition
32.11401+ #:*default-component-class*
32.11402+ #:determine-system-directory #:parse-component-form
32.11403+ #:non-toplevel-system #:non-system-system #:bad-system-name
32.11404+ #:*known-systems-with-bad-secondary-system-names*
32.11405+ #:known-system-with-bad-secondary-system-names-p
32.11406+ #:sysdef-error-component #:check-component-input
32.11407+ #:explain
32.11408+ ;; for extending the component types
32.11409+ #:compute-component-children
32.11410+ #:class-for-type))
32.11411+(in-package :asdf/parse-defsystem)
32.11412+
32.11413+;;; Pathname
32.11414+(with-upgradability ()
32.11415+ (defun determine-system-directory (pathname)
32.11416+ ;; The defsystem macro calls this function to determine the pathname of a system as follows:
32.11417+ ;; 1. If the pathname argument is an pathname object (NOT a namestring),
32.11418+ ;; that is already an absolute pathname, return it.
32.11419+ ;; 2. Otherwise, the directory containing the LOAD-PATHNAME
32.11420+ ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
32.11421+ ;; if it is indeed available and an absolute pathname, then
32.11422+ ;; the PATHNAME argument is normalized to a relative pathname
32.11423+ ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
32.11424+ ;; and merged into that DIRECTORY as per SUBPATHNAME.
32.11425+ ;; Note: avoid *COMPILE-FILE-PATHNAME* because the .asd is loaded as source,
32.11426+ ;; but may be from within the EVAL-WHEN of a file compilation.
32.11427+ ;; If no absolute pathname was found, we return NIL.
32.11428+ (check-type pathname (or null string pathname))
32.11429+ (pathname-directory-pathname
32.11430+ (resolve-symlinks*
32.11431+ (ensure-absolute-pathname
32.11432+ (parse-unix-namestring pathname :type :directory)
32.11433+ #'(lambda () (ensure-absolute-pathname
32.11434+ (load-pathname) 'get-pathname-defaults nil))
32.11435+ nil)))))
32.11436+
32.11437+
32.11438+(when-upgrading (:version "3.3.4.17")
32.11439+ ;; This turned into a generic function in 3.3.4.17
32.11440+ (fmakunbound 'class-for-type))
32.11441+
32.11442+;;; Component class
32.11443+(with-upgradability ()
32.11444+ ;; What :file gets interpreted as, unless overridden by a :default-component-class
32.11445+ (defvar *default-component-class* 'cl-source-file)
32.11446+
32.11447+ (defgeneric class-for-type (parent type-designator)
32.11448+ (:documentation
32.11449+ "Return a CLASS object to be used to instantiate components specified by TYPE-DESIGNATOR in the context of PARENT."))
32.11450+
32.11451+ (defmethod class-for-type ((parent null) type)
32.11452+ "If the PARENT is NIL, then TYPE must designate a subclass of SYSTEM."
32.11453+ (or (coerce-class type :package :asdf/interface :super 'system :error nil)
32.11454+ (sysdef-error "don't recognize component type ~S in the context of no parent" type)))
32.11455+
32.11456+ (defmethod class-for-type ((parent parent-component) type)
32.11457+ (or (coerce-class type :package :asdf/interface :super 'component :error nil)
32.11458+ (and (eq type :file)
32.11459+ (coerce-class
32.11460+ (or (loop :for p = parent :then (component-parent p) :while p
32.11461+ :thereis (module-default-component-class p))
32.11462+ *default-component-class*)
32.11463+ :package :asdf/interface :super 'component :error nil))
32.11464+ (sysdef-error "don't recognize component type ~S" type))))
32.11465+
32.11466+
32.11467+;;; Check inputs
32.11468+(with-upgradability ()
32.11469+ (define-condition non-system-system (system-definition-error)
32.11470+ ((name :initarg :name :reader non-system-system-name)
32.11471+ (class-name :initarg :class-name :reader non-system-system-class-name))
32.11472+ (:report (lambda (c s)
32.11473+ (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
32.11474+ (non-system-system-name c) (non-system-system-class-name c) 'system))))
32.11475+
32.11476+ (define-condition non-toplevel-system (system-definition-error)
32.11477+ ((parent :initarg :parent :reader non-toplevel-system-parent)
32.11478+ (name :initarg :name :reader non-toplevel-system-name))
32.11479+ (:report (lambda (c s)
32.11480+ (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
32.11481+ (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
32.11482+
32.11483+ (define-condition bad-system-name (warning)
32.11484+ ((name :initarg :name :reader component-name)
32.11485+ (source-file :initarg :source-file :reader system-source-file))
32.11486+ (:report (lambda (c s)
32.11487+ (let* ((file (system-source-file c))
32.11488+ (name (component-name c))
32.11489+ (asd (pathname-name file)))
32.11490+ (format s (compatfmt "~@<System definition file ~S contains definition for system ~S. ~
32.11491+Please only define ~S and secondary systems with a name starting with ~S (e.g. ~S) in that file.~@:>")
32.11492+ file name asd (strcat asd "/") (strcat asd "/test"))))))
32.11493+
32.11494+ (defun sysdef-error-component (msg type name value)
32.11495+ (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
32.11496+ type name value))
32.11497+
32.11498+ (defun check-component-input (type name weakly-depends-on
32.11499+ depends-on components)
32.11500+ "A partial test of the values of a component."
32.11501+ (unless (listp depends-on)
32.11502+ (sysdef-error-component ":depends-on must be a list."
32.11503+ type name depends-on))
32.11504+ (unless (listp weakly-depends-on)
32.11505+ (sysdef-error-component ":weakly-depends-on must be a list."
32.11506+ type name weakly-depends-on))
32.11507+ (unless (listp components)
32.11508+ (sysdef-error-component ":components must be NIL or a list of components."
32.11509+ type name components)))
32.11510+
32.11511+
32.11512+ (defun record-additional-system-input-file (pathname component parent)
32.11513+ (let* ((record-on (if parent
32.11514+ (loop :with retval
32.11515+ :for par = parent :then (component-parent par)
32.11516+ :while par
32.11517+ :do (setf retval par)
32.11518+ :finally (return retval))
32.11519+ component))
32.11520+ (comp (if (typep record-on 'component)
32.11521+ record-on
32.11522+ ;; at this point there will be no parent for RECORD-ON
32.11523+ (find-component record-on nil)))
32.11524+ (op (make-operation 'define-op))
32.11525+ (cell (or (assoc op (%additional-input-files comp))
32.11526+ (let ((new-cell (list op)))
32.11527+ (push new-cell (%additional-input-files comp))
32.11528+ new-cell))))
32.11529+ (pushnew pathname (cdr cell) :test 'pathname-equal)
32.11530+ (values)))
32.11531+
32.11532+ ;; Given a form used as :version specification, in the context of a system definition
32.11533+ ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form
32.11534+ ;; to an acceptable ASDF-format version.
32.11535+ (fmakunbound 'normalize-version) ;; signature changed between 2.27 and 2.31
32.11536+ (defun normalize-version (form &key pathname component parent)
32.11537+ (labels ((invalid (&optional (continuation "using NIL instead"))
32.11538+ (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
32.11539+ form component parent pathname continuation))
32.11540+ (invalid-parse (control &rest args)
32.11541+ (unless (if-let (target (find-component parent component)) (builtin-system-p target))
32.11542+ (apply 'warn control args)
32.11543+ (invalid))))
32.11544+ (if-let (v (typecase form
32.11545+ ((or string null) form)
32.11546+ (real
32.11547+ (invalid "Substituting a string")
32.11548+ (format nil "~D" form)) ;; 1.0 becomes "1.0"
32.11549+ (cons
32.11550+ (case (first form)
32.11551+ ((:read-file-form)
32.11552+ (destructuring-bind (subpath &key (at 0)) (rest form)
32.11553+ (let ((path (subpathname pathname subpath)))
32.11554+ (record-additional-system-input-file path component parent)
32.11555+ (safe-read-file-form path
32.11556+ :at at :package :asdf-user))))
32.11557+ ((:read-file-line)
32.11558+ (destructuring-bind (subpath &key (at 0)) (rest form)
32.11559+ (let ((path (subpathname pathname subpath)))
32.11560+ (record-additional-system-input-file path component parent)
32.11561+ (safe-read-file-line (subpathname pathname subpath)
32.11562+ :at at))))
32.11563+ (otherwise
32.11564+ (invalid))))
32.11565+ (t
32.11566+ (invalid))))
32.11567+ (if-let (pv (parse-version v #'invalid-parse))
32.11568+ (unparse-version pv)
32.11569+ (invalid))))))
32.11570+
32.11571+
32.11572+;;; "inline methods"
32.11573+(with-upgradability ()
32.11574+ (defparameter* +asdf-methods+
32.11575+ '(perform-with-restarts perform explain output-files operation-done-p))
32.11576+
32.11577+ (defun %remove-component-inline-methods (component)
32.11578+ (dolist (name +asdf-methods+)
32.11579+ (map ()
32.11580+ ;; this is inefficient as most of the stored
32.11581+ ;; methods will not be for this particular gf
32.11582+ ;; But this is hardly performance-critical
32.11583+ #'(lambda (m)
32.11584+ (remove-method (symbol-function name) m))
32.11585+ (component-inline-methods component)))
32.11586+ (component-inline-methods component) nil)
32.11587+
32.11588+ (defparameter *standard-method-combination-qualifiers*
32.11589+ '(:around :before :after))
32.11590+
32.11591+;;; Find inline method definitions of the form
32.11592+;;;
32.11593+;;; :perform (test-op :before (operation component) ...)
32.11594+;;;
32.11595+;;; in REST (which is the plist of all DEFSYSTEM initargs) and define the specified methods.
32.11596+ (defun %define-component-inline-methods (ret rest)
32.11597+ ;; find key-value pairs that look like inline method definitions in REST. For each identified
32.11598+ ;; definition, parse it and, if it is well-formed, define the method.
32.11599+ (loop :for (key value) :on rest :by #'cddr
32.11600+ :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
32.11601+ :when name :do
32.11602+ ;; parse VALUE as an inline method definition of the form
32.11603+ ;;
32.11604+ ;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY)
32.11605+ (destructuring-bind (operation-name &rest rest) value
32.11606+ (let ((qualifiers '()))
32.11607+ ;; ensure that OPERATION-NAME is a symbol.
32.11608+ (unless (and (symbolp operation-name) (not (null operation-name)))
32.11609+ (sysdef-error "Ill-formed inline method: ~S. The first element is not a symbol ~
32.11610+ designating an operation but ~S."
32.11611+ value operation-name))
32.11612+ ;; ensure that REST starts with either a cons (potential lambda list, further checked
32.11613+ ;; below) or a qualifier accepted by the standard method combination. Everything else
32.11614+ ;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely
32.11615+ ;; has to start with the lambda list.
32.11616+ (cond
32.11617+ ((consp (car rest)))
32.11618+ ((not (member (car rest)
32.11619+ *standard-method-combination-qualifiers*))
32.11620+ (sysdef-error "Ill-formed inline method: ~S. Only a single of the standard ~
32.11621+ qualifiers ~{~S~^ ~} is allowed, not ~S."
32.11622+ value *standard-method-combination-qualifiers* (car rest)))
32.11623+ (t
32.11624+ (setf qualifiers (list (pop rest)))))
32.11625+ ;; REST must start with a two-element lambda list.
32.11626+ (unless (and (listp (car rest))
32.11627+ (length=n-p (car rest) 2)
32.11628+ (null (cddar rest)))
32.11629+ (sysdef-error "Ill-formed inline method: ~S. The operation name ~S is not followed by ~
32.11630+ a lambda-list of the form (OPERATION COMPONENT) and a method body."
32.11631+ value operation-name))
32.11632+ ;; define the method.
32.11633+ (destructuring-bind ((o c) &rest body) rest
32.11634+ (pushnew
32.11635+ (eval `(defmethod ,name ,@qualifiers ((,o ,operation-name) (,c (eql ,ret))) ,@body))
32.11636+ (component-inline-methods ret)))))))
32.11637+
32.11638+ (defun %refresh-component-inline-methods (component rest)
32.11639+ ;; clear methods, then add the new ones
32.11640+ (%remove-component-inline-methods component)
32.11641+ (%define-component-inline-methods component rest)))
32.11642+
32.11643+
32.11644+;;; Main parsing function
32.11645+(with-upgradability ()
32.11646+ (defun parse-dependency-def (dd)
32.11647+ (if (listp dd)
32.11648+ (case (first dd)
32.11649+ (:feature
32.11650+ (unless (= (length dd) 3)
32.11651+ (sysdef-error "Ill-formed feature dependency: ~s" dd))
32.11652+ (let ((embedded (parse-dependency-def (third dd))))
32.11653+ `(:feature ,(second dd) ,embedded)))
32.11654+ (feature
32.11655+ (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd))
32.11656+ (:require
32.11657+ (unless (= (length dd) 2)
32.11658+ (sysdef-error "Ill-formed require dependency: ~s" dd))
32.11659+ dd)
32.11660+ (:version
32.11661+ (unless (= (length dd) 3)
32.11662+ (sysdef-error "Ill-formed version dependency: ~s" dd))
32.11663+ `(:version ,(coerce-name (second dd)) ,(third dd)))
32.11664+ (otherwise (sysdef-error "Ill-formed dependency: ~s" dd)))
32.11665+ (coerce-name dd)))
32.11666+
32.11667+ (defun parse-dependency-defs (dd-list)
32.11668+ "Parse the dependency defs in DD-LIST into canonical form by translating all
32.11669+system names contained using COERCE-NAME. Return the result."
32.11670+ (mapcar 'parse-dependency-def dd-list))
32.11671+
32.11672+ (defgeneric compute-component-children (component components serial-p)
32.11673+ (:documentation
32.11674+ "Return a list of children for COMPONENT.
32.11675+
32.11676+COMPONENTS is a list of the explicitly defined children descriptions.
32.11677+
32.11678+SERIAL-P is non-NIL if each child in COMPONENTS should depend on the previous
32.11679+children."))
32.11680+
32.11681+ (defun stable-union (s1 s2 &key (test #'eql) (key 'identity))
32.11682+ (append s1
32.11683+ (remove-if #'(lambda (e2) (member (funcall key e2) (funcall key s1) :test test)) s2)))
32.11684+
32.11685+ (defun parse-component-form (parent options &key previous-serial-components)
32.11686+ (destructuring-bind
32.11687+ (type name &rest rest &key
32.11688+ (builtin-system-p () bspp)
32.11689+ ;; the following list of keywords is reproduced below in the
32.11690+ ;; remove-plist-keys form. important to keep them in sync
32.11691+ components pathname perform explain output-files operation-done-p
32.11692+ weakly-depends-on depends-on serial
32.11693+ do-first if-component-dep-fails version
32.11694+ ;; list ends
32.11695+ &allow-other-keys) options
32.11696+ (declare (ignore perform explain output-files operation-done-p builtin-system-p))
32.11697+ (check-component-input type name weakly-depends-on depends-on components)
32.11698+ (when (and parent
32.11699+ (find-component parent name)
32.11700+ (not ;; ignore the same object when rereading the defsystem
32.11701+ (typep (find-component parent name)
32.11702+ (class-for-type parent type))))
32.11703+ (error 'duplicate-names :name name))
32.11704+ (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
32.11705+ (let* ((name (coerce-name name))
32.11706+ (args `(:name ,name
32.11707+ :pathname ,pathname
32.11708+ ,@(when parent `(:parent ,parent))
32.11709+ ,@(remove-plist-keys
32.11710+ '(:components :pathname :if-component-dep-fails :version
32.11711+ :perform :explain :output-files :operation-done-p
32.11712+ :weakly-depends-on :depends-on :serial)
32.11713+ rest)))
32.11714+ (component (find-component parent name))
32.11715+ (class (class-for-type parent type)))
32.11716+ (when (and parent (subtypep class 'system))
32.11717+ (error 'non-toplevel-system :parent parent :name name))
32.11718+ (if component ; preserve identity
32.11719+ (apply 'reinitialize-instance component args)
32.11720+ (setf component (apply 'make-instance class args)))
32.11721+ (component-pathname component) ; eagerly compute the absolute pathname
32.11722+ (when (typep component 'system)
32.11723+ ;; cache information for introspection
32.11724+ (setf (slot-value component 'depends-on)
32.11725+ (parse-dependency-defs depends-on)
32.11726+ (slot-value component 'weakly-depends-on)
32.11727+ ;; these must be a list of systems, cannot be features or versioned systems
32.11728+ (mapcar 'coerce-name weakly-depends-on)))
32.11729+ (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
32.11730+ (when (and (typep component 'system) (not bspp))
32.11731+ (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
32.11732+ (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
32.11733+ ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
32.11734+ ;; A better fix is required.
32.11735+ (setf (slot-value component 'version) version)
32.11736+ (when (typep component 'parent-component)
32.11737+ (setf (component-children component) (compute-component-children component components serial))
32.11738+ (compute-children-by-name component))
32.11739+ (when previous-serial-components
32.11740+ (setf depends-on (stable-union depends-on previous-serial-components :test #'equal)))
32.11741+ (when weakly-depends-on
32.11742+ ;; ASDF4: deprecate this feature and remove it.
32.11743+ (appendf depends-on
32.11744+ (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
32.11745+ ;; Used by POIU. ASDF4: rename to component-depends-on?
32.11746+ (setf (component-sideway-dependencies component) depends-on)
32.11747+ (%refresh-component-inline-methods component rest)
32.11748+ (when if-component-dep-fails
32.11749+ (error "The system definition for ~S uses deprecated ~
32.11750+ ASDF option :IF-COMPONENT-DEP-FAILS. ~
32.11751+ Starting with ASDF 3, please use :IF-FEATURE instead"
32.11752+ (coerce-name (component-system component))))
32.11753+ component)))
32.11754+
32.11755+ (defmethod compute-component-children ((component parent-component) components serial-p)
32.11756+ (loop
32.11757+ :with previous-components = nil ; list of strings
32.11758+ :for c-form :in components
32.11759+ :for c = (parse-component-form component c-form
32.11760+ :previous-serial-components previous-components)
32.11761+ :for name :of-type string = (component-name c)
32.11762+ :when serial-p
32.11763+ ;; if this is an if-feature component, we need to make a serial link
32.11764+ ;; from previous components to following components -- otherwise should
32.11765+ ;; the IF-FEATURE component drop out, the chain of serial dependencies will be
32.11766+ ;; broken.
32.11767+ :unless (component-if-feature c)
32.11768+ :do (setf previous-components nil)
32.11769+ :end
32.11770+ :and
32.11771+ :do (push name previous-components)
32.11772+ :end
32.11773+ :collect c))
32.11774+
32.11775+ ;; the following are all systems that Stas Boukarev maintains and refuses to fix,
32.11776+ ;; hoping instead to make my life miserable. Instead, I just make ASDF ignore them.
32.11777+ (defparameter* *known-systems-with-bad-secondary-system-names*
32.11778+ (list-to-hash-set '("cl-ppcre" "cl-interpol")))
32.11779+ (defun known-system-with-bad-secondary-system-names-p (asd-name)
32.11780+ ;; Does .asd file with name ASD-NAME contain known exceptions
32.11781+ ;; that should be screened out of checking for BAD-SYSTEM-NAME?
32.11782+ (gethash asd-name *known-systems-with-bad-secondary-system-names*))
32.11783+
32.11784+ (defun register-system-definition
32.11785+ (name &rest options &key pathname (class 'system) (source-file () sfp)
32.11786+ defsystem-depends-on &allow-other-keys)
32.11787+ ;; The system must be registered before we parse the body,
32.11788+ ;; otherwise we recur when trying to find an existing system
32.11789+ ;; of the same name to reuse options (e.g. pathname) from.
32.11790+ ;; To avoid infinite recursion in cases where you defsystem a system
32.11791+ ;; that is registered to a different location to find-system,
32.11792+ ;; we also need to remember it in the asdf-cache.
32.11793+ (nest
32.11794+ (with-asdf-session ())
32.11795+ (let* ((name (coerce-name name))
32.11796+ (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))))
32.11797+ (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x))))
32.11798+ (let* ((asd-name (and source-file
32.11799+ (equal "asd" (fix-case (pathname-type source-file)))
32.11800+ (fix-case (pathname-name source-file))))
32.11801+ ;; note that PRIMARY-NAME is a *syntactically* primary name
32.11802+ (primary-name (primary-system-name name)))
32.11803+ (when (and asd-name
32.11804+ (not (equal asd-name primary-name))
32.11805+ (not (known-system-with-bad-secondary-system-names-p asd-name)))
32.11806+ (warn (make-condition 'bad-system-name :source-file source-file :name name))))
32.11807+ (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object,
32.11808+ ;; so that in case it fails, there is no incomplete object polluting the build.
32.11809+ (checked-defsystem-depends-on
32.11810+ (let* ((dep-forms (parse-dependency-defs defsystem-depends-on))
32.11811+ (deps (loop :for spec :in dep-forms
32.11812+ :when (resolve-dependency-spec nil spec)
32.11813+ :collect :it)))
32.11814+ (load-systems* deps)
32.11815+ dep-forms))
32.11816+ (system (or (find-system-if-being-defined name)
32.11817+ (if-let (registered (registered-system name))
32.11818+ (reset-system-class registered 'undefined-system
32.11819+ :name name :source-file source-file)
32.11820+ (register-system (make-instance 'undefined-system
32.11821+ :name name :source-file source-file)))))
32.11822+ (component-options
32.11823+ (append
32.11824+ (remove-plist-keys '(:defsystem-depends-on :class) options)
32.11825+ ;; cache defsystem-depends-on in canonical form
32.11826+ (when checked-defsystem-depends-on
32.11827+ `(:defsystem-depends-on ,checked-defsystem-depends-on))))
32.11828+ (directory (determine-system-directory pathname)))
32.11829+ ;; This works hand in hand with asdf/find-system:find-system-if-being-defined:
32.11830+ (set-asdf-cache-entry `(find-system ,name) (list system)))
32.11831+ ;; We change-class AFTER we loaded the defsystem-depends-on
32.11832+ ;; since the class might be defined as part of those.
32.11833+ (let ((class (class-for-type nil class)))
32.11834+ (unless (subtypep class 'system)
32.11835+ (error 'non-system-system :name name :class-name (class-name class)))
32.11836+ (unless (eq (type-of system) class)
32.11837+ (reset-system-class system class)))
32.11838+ (parse-component-form nil (list* :system name :pathname directory component-options))))
32.11839+
32.11840+ (defmacro defsystem (name &body options)
32.11841+ `(apply 'register-system-definition ',name ',options)))
32.11842+;;;; -------------------------------------------------------------------------
32.11843+;;;; ASDF-Bundle
32.11844+
32.11845+(uiop/package:define-package :asdf/bundle
32.11846+ (:recycle :asdf/bundle :asdf)
32.11847+ (:use :uiop/common-lisp :uiop :asdf/upgrade
32.11848+ :asdf/component :asdf/system :asdf/operation
32.11849+ :asdf/find-component ;; used by ECL
32.11850+ :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem)
32.11851+ (:export
32.11852+ #:bundle-op #:bundle-type #:program-system
32.11853+ #:bundle-system #:bundle-pathname-type #:direct-dependency-files
32.11854+ #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
32.11855+ #:basic-compile-bundle-op #:prepare-bundle-op
32.11856+ #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
32.11857+ #:lib-op #:monolithic-lib-op
32.11858+ #:dll-op #:monolithic-dll-op
32.11859+ #:deliver-asd-op #:monolithic-deliver-asd-op
32.11860+ #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
32.11861+ #:user-system-p #:user-system #:trivial-system-p
32.11862+ #:prologue-code #:epilogue-code #:static-library))
32.11863+(in-package :asdf/bundle)
32.11864+
32.11865+(with-upgradability ()
32.11866+ (defclass bundle-op (operation) ()
32.11867+ (:documentation "base class for operations that bundle outputs from multiple components"))
32.11868+ (defgeneric bundle-type (bundle-op))
32.11869+
32.11870+ (defclass monolithic-op (operation) ()
32.11871+ (:documentation "A MONOLITHIC operation operates on a system *and all of its
32.11872+dependencies*. So, for example, a monolithic concatenate operation will
32.11873+concatenate together a system's components and all of its dependencies, but a
32.11874+simple concatenate operation will concatenate only the components of the system
32.11875+itself."))
32.11876+
32.11877+ (defclass monolithic-bundle-op (bundle-op monolithic-op)
32.11878+ ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.
32.11879+ ;; DEPRECATED. Supported replacement: Define slots on program-system instead.
32.11880+ ((prologue-code :initform nil :accessor prologue-code)
32.11881+ (epilogue-code :initform nil :accessor epilogue-code))
32.11882+ (:documentation "operations that are both monolithic-op and bundle-op"))
32.11883+
32.11884+ (defclass program-system (system)
32.11885+ ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
32.11886+ ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
32.11887+ (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
32.11888+ (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
32.11889+ (prefix-lisp-object-files :initarg :prefix-lisp-object-files
32.11890+ :initform nil :accessor prefix-lisp-object-files)
32.11891+ (postfix-lisp-object-files :initarg :postfix-lisp-object-files
32.11892+ :initform nil :accessor postfix-lisp-object-files)
32.11893+ (extra-object-files :initarg :extra-object-files
32.11894+ :initform nil :accessor extra-object-files)
32.11895+ (extra-build-args :initarg :extra-build-args
32.11896+ :initform nil :accessor extra-build-args)))
32.11897+
32.11898+ (defmethod prologue-code ((x system)) nil)
32.11899+ (defmethod epilogue-code ((x system)) nil)
32.11900+ (defmethod no-uiop ((x system)) nil)
32.11901+ (defmethod prefix-lisp-object-files ((x system)) nil)
32.11902+ (defmethod postfix-lisp-object-files ((x system)) nil)
32.11903+ (defmethod extra-object-files ((x system)) nil)
32.11904+ (defmethod extra-build-args ((x system)) nil)
32.11905+
32.11906+ (defclass link-op (bundle-op) ()
32.11907+ (:documentation "Abstract operation for linking files together"))
32.11908+
32.11909+ (defclass gather-operation (bundle-op) ()
32.11910+ (:documentation "Abstract operation for gathering many input files from a system"))
32.11911+ (defgeneric gather-operation (gather-operation))
32.11912+ (defmethod gather-operation ((o gather-operation)) nil)
32.11913+ (defgeneric gather-type (gather-operation))
32.11914+
32.11915+ (defun operation-monolithic-p (op)
32.11916+ (typep op 'monolithic-op))
32.11917+
32.11918+ ;; Dependencies of a gather-op are the actions of the dependent operation
32.11919+ ;; for all the (sorted) required components for loading the system.
32.11920+ ;; Monolithic operations typically use lib-op as the dependent operation,
32.11921+ ;; and all system-level dependencies as required components.
32.11922+ ;; Non-monolithic operations typically use compile-op as the dependent operation,
32.11923+ ;; and all transitive sub-components as required components (excluding other systems).
32.11924+ (defmethod component-depends-on ((o gather-operation) (s system))
32.11925+ (let* ((mono (operation-monolithic-p o))
32.11926+ (go (make-operation (or (gather-operation o) 'compile-op)))
32.11927+ (bundle-p (typep go 'bundle-op))
32.11928+ ;; In a non-mono operation, don't recurse to other systems.
32.11929+ ;; In a mono operation gathering bundles, don't recurse inside systems.
32.11930+ (component-type (if mono (if bundle-p 'system t) '(not system)))
32.11931+ ;; In the end, only keep system bundles or non-system bundles, depending.
32.11932+ (keep-component (if bundle-p 'system '(not system)))
32.11933+ (deps
32.11934+ ;; Required-components only looks at the dependencies of an action, excluding the action
32.11935+ ;; itself, so it may be safely used by an action recursing on its dependencies (which
32.11936+ ;; may or may not be an overdesigned API, since in practice we never use it that way).
32.11937+ ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks
32.11938+ ;; cleaner, we will miss the load-op on the requested system itself, which doesn't
32.11939+ ;; matter for a regular system, but matters, a lot, for a package-inferred-system.
32.11940+ ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works
32.11941+ ;; for our needs of gathering all the files we want to include in a bundle.
32.11942+ ;; Note that we use basic-compile-op rather than compile-op so it will still work on
32.11943+ ;; systems that would somehow load dependencies with load-bundle-op.
32.11944+ (required-components
32.11945+ s :other-systems mono :component-type component-type :keep-component keep-component
32.11946+ :goal-operation 'load-op :keep-operation 'basic-compile-op)))
32.11947+ `((,go ,@deps) ,@(call-next-method))))
32.11948+
32.11949+ ;; Create a single fasl for the entire library
32.11950+ (defclass basic-compile-bundle-op (bundle-op basic-compile-op) ()
32.11951+ (:documentation "Base class for compiling into a bundle"))
32.11952+ (defmethod bundle-type ((o basic-compile-bundle-op)) :fasb)
32.11953+ (defmethod gather-type ((o basic-compile-bundle-op))
32.11954+ #-(or clasp ecl mkcl) :fasl
32.11955+ #+(or clasp ecl mkcl) :object)
32.11956+
32.11957+ ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op
32.11958+ (defclass prepare-bundle-op (sideway-operation)
32.11959+ ((sideway-operation
32.11960+ :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
32.11961+ :allocation :class))
32.11962+ (:documentation "Operation class for loading the bundles of a system's dependencies"))
32.11963+
32.11964+ (defclass lib-op (link-op gather-operation non-propagating-operation) ()
32.11965+ (:documentation "Compile the system and produce a linkable static library (.a/.lib)
32.11966+for all the linkable object files associated with the system. Compare with DLL-OP.
32.11967+
32.11968+On most implementations, these object files only include extensions to the runtime
32.11969+written in C or another language with a compiler producing linkable object files.
32.11970+On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
32.11971+themselves. In any case, this operation will produce what you need to further build
32.11972+a static runtime for your system, or a dynamic library to load in an existing runtime."))
32.11973+ (defmethod bundle-type ((o lib-op)) :lib)
32.11974+ (defmethod gather-type ((o lib-op)) :object)
32.11975+
32.11976+ ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so;
32.11977+ ;; on other implementations, we combine (usually concatenate) the .fasl files into one.
32.11978+ (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation
32.11979+ #+(or clasp ecl mkcl) link-op)
32.11980+ ((selfward-operation :initform '(prepare-bundle-op) :allocation :class))
32.11981+ (:documentation "This operator is an alternative to COMPILE-OP. Build a system
32.11982+and all of its dependencies, but build only a single (\"monolithic\") FASL, instead
32.11983+of one per source file, which may be more resource efficient. That monolithic
32.11984+FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP."))
32.11985+
32.11986+ (defclass load-bundle-op (basic-load-op selfward-operation)
32.11987+ ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))
32.11988+ (:documentation "This operator is an alternative to LOAD-OP. Build a system
32.11989+and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with
32.11990+respect to LOAD-OP is that it builds only a single FASL, which may be
32.11991+faster and more resource efficient."))
32.11992+
32.11993+ ;; NB: since the monolithic-op's can't be sideway-operation's,
32.11994+ ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's,
32.11995+ ;; we'd have to have the monolithic-op not inherit from the main op,
32.11996+ ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above.
32.11997+
32.11998+ (defclass dll-op (link-op gather-operation non-propagating-operation) ()
32.11999+ (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
32.12000+for all the linkable object files associated with the system. Compare with LIB-OP."))
32.12001+ (defmethod bundle-type ((o dll-op)) :dll)
32.12002+ (defmethod gather-type ((o dll-op)) :object)
32.12003+
32.12004+ (defclass deliver-asd-op (basic-compile-op selfward-operation)
32.12005+ ((selfward-operation
32.12006+ ;; TODO: implement link-op on all implementations, and make that
32.12007+ ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op)
32.12008+ :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op)
32.12009+ :allocation :class))
32.12010+ (:documentation "produce an asd file for delivering the system as a single fasl"))
32.12011+
32.12012+
32.12013+ (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op)
32.12014+ ((selfward-operation
32.12015+ ;; TODO: implement link-op on all implementations, and make that
32.12016+ ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
32.12017+ :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
32.12018+ :allocation :class))
32.12019+ (:documentation "produce fasl and asd files for combined system and dependencies."))
32.12020+
32.12021+ (defclass monolithic-compile-bundle-op
32.12022+ (basic-compile-bundle-op monolithic-bundle-op
32.12023+ #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
32.12024+ ()
32.12025+ (:documentation "Create a single fasl for the system and its dependencies."))
32.12026+
32.12027+ (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op)
32.12028+ ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
32.12029+ (:documentation "Load a single fasl for the system and its dependencies."))
32.12030+
32.12031+ (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation) ()
32.12032+ (:documentation "Compile the system and produce a linkable static library (.a/.lib)
32.12033+for all the linkable object files associated with the system or its dependencies. See LIB-OP."))
32.12034+
32.12035+ (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation) ()
32.12036+ (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
32.12037+for all the linkable object files associated with the system or its dependencies. See LIB-OP"))
32.12038+
32.12039+ (defclass image-op (monolithic-bundle-op selfward-operation
32.12040+ #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
32.12041+ ((selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
32.12042+ (:documentation "create an image file from the system and its dependencies"))
32.12043+ (defmethod bundle-type ((o image-op)) :image)
32.12044+ #+(or clasp ecl mkcl) (defmethod gather-operation ((o image-op)) 'lib-op)
32.12045+ #+(or clasp ecl mkcl) (defmethod gather-type ((o image-op)) :static-library)
32.12046+
32.12047+ (defclass program-op (image-op) ()
32.12048+ (:documentation "create an executable file from the system and its dependencies"))
32.12049+ (defmethod bundle-type ((o program-op)) :program)
32.12050+
32.12051+ ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.
32.12052+ (defun bundle-pathname-type (bundle-type)
32.12053+ (etypecase bundle-type
32.12054+ ((or null string) ;; pass through nil or string literal
32.12055+ bundle-type)
32.12056+ ((eql :no-output-file) ;; marker for a bundle-type that has NO output file
32.12057+ (error "No output file, therefore no pathname type"))
32.12058+ ((eql :fasl) ;; the type of a fasl
32.12059+ (compile-file-type)) ; on image-based platforms, used as input and output
32.12060+ ((eql :fasb) ;; the type of a fasl
32.12061+ #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output
32.12062+ #+(or ecl mkcl) "fasb"
32.12063+ #+clasp "fasp") ; on C-linking platforms, only used as output for system bundles
32.12064+ ((member :image)
32.12065+ #+allegro "dxl"
32.12066+ #+(and clisp os-windows) "exe"
32.12067+ #-(or allegro (and clisp os-windows)) "image")
32.12068+ ;; NB: on CLASP and ECL these implementations, we better agree with
32.12069+ ;; (compile-file-type :type bundle-type))
32.12070+ ((eql :object) ;; the type of a linkable object file
32.12071+ (os-cond ((os-unix-p)
32.12072+ #+clasp "fasp" ;(core:build-extension cmp:*default-object-type*)
32.12073+ #-clasp "o")
32.12074+ ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj"))))
32.12075+ ((member :lib :static-library) ;; the type of a linkable library
32.12076+ (os-cond ((os-unix-p) "a")
32.12077+ ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
32.12078+ ((member :dll :shared-library) ;; the type of a shared library
32.12079+ (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
32.12080+ ((eql :program) ;; the type of an executable program
32.12081+ (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
32.12082+
32.12083+ ;; Compute the output-files for a given bundle action
32.12084+ (defun bundle-output-files (o c)
32.12085+ (let ((bundle-type (bundle-type o)))
32.12086+ (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
32.12087+ (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
32.12088+ (let ((name (or (component-build-pathname c)
32.12089+ (let ((suffix
32.12090+ (unless (typep o 'program-op)
32.12091+ ;; "." is no good separator for Logical Pathnames, so we use "--"
32.12092+ (if (operation-monolithic-p o)
32.12093+ "--all-systems"
32.12094+ ;; These use a different type .fasb or .a instead of .fasl
32.12095+ #-(or clasp ecl mkcl) "--system"))))
32.12096+ (format nil "~A~@[~A~]" (coerce-filename (component-name c)) suffix))))
32.12097+ (type (bundle-pathname-type bundle-type)))
32.12098+ (values (list (subpathname (component-pathname c) name :type type))
32.12099+ (eq (class-of o) (coerce-class (component-build-operation c)
32.12100+ :package :asdf/interface
32.12101+ :super 'operation
32.12102+ :error nil)))))))
32.12103+
32.12104+ (defmethod output-files ((o bundle-op) (c system))
32.12105+ (bundle-output-files o c))
32.12106+
32.12107+ #-(or clasp ecl mkcl)
32.12108+ (progn
32.12109+ (defmethod perform ((o image-op) (c system))
32.12110+ (dump-image (output-file o c) :executable (typep o 'program-op)))
32.12111+ (defmethod perform :before ((o program-op) (c system))
32.12112+ (setf *image-entry-point* (ensure-function (component-entry-point c)))))
32.12113+
32.12114+ (defclass compiled-file (file-component)
32.12115+ ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb"))
32.12116+ (:documentation "Class for a file that is already compiled,
32.12117+e.g. as part of the implementation, of an outer build system that calls into ASDF,
32.12118+or of opaque libraries shipped along the source code."))
32.12119+
32.12120+ (defclass precompiled-system (system)
32.12121+ ((build-pathname :initarg :fasb :initarg :fasl))
32.12122+ (:documentation "Class For a system that is delivered as a precompiled fasl"))
32.12123+
32.12124+ (defclass prebuilt-system (system)
32.12125+ ((build-pathname :initarg :static-library :initarg :lib
32.12126+ :accessor prebuilt-system-static-library))
32.12127+ (:documentation "Class for a system delivered with a linkable static library (.a/.lib)")))
32.12128+
32.12129+
32.12130+;;;
32.12131+;;; BUNDLE-OP
32.12132+;;;
32.12133+;;; This operation takes all components from one or more systems and
32.12134+;;; creates a single output file, which may be
32.12135+;;; a FASL, a statically linked library, a shared library, etc.
32.12136+;;; The different targets are defined by specialization.
32.12137+;;;
32.12138+(when-upgrading (:version "3.2.0")
32.12139+ ;; Cancel any previously defined method
32.12140+ (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)
32.12141+ (declare (ignore initargs))))
32.12142+
32.12143+(with-upgradability ()
32.12144+ (defgeneric trivial-system-p (component))
32.12145+
32.12146+ (defun user-system-p (s)
32.12147+ (and (typep s 'system)
32.12148+ (not (builtin-system-p s))
32.12149+ (not (trivial-system-p s)))))
32.12150+
32.12151+(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
32.12152+ (deftype user-system () '(and system (satisfies user-system-p))))
32.12153+
32.12154+;;;
32.12155+;;; First we handle monolithic bundles.
32.12156+;;; These are standalone systems which contain everything,
32.12157+;;; including other ASDF systems required by the current one.
32.12158+;;; A PROGRAM is always monolithic.
32.12159+;;;
32.12160+;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
32.12161+;;;
32.12162+(with-upgradability ()
32.12163+ (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
32.12164+ ;; This function selects output files from direct dependencies;
32.12165+ ;; your component-depends-on method must gather the correct dependencies in the correct order.
32.12166+ (while-collecting (collect)
32.12167+ (map-direct-dependencies
32.12168+ o c #'(lambda (sub-o sub-c)
32.12169+ (loop :for f :in (funcall key sub-o sub-c)
32.12170+ :when (funcall test f) :do (collect f))))))
32.12171+
32.12172+ (defun pathname-type-equal-function (type)
32.12173+ #'(lambda (p) (equalp (pathname-type p) type)))
32.12174+
32.12175+ (defmethod input-files ((o gather-operation) (c system))
32.12176+ (unless (eq (bundle-type o) :no-output-file)
32.12177+ (direct-dependency-files
32.12178+ o c :key 'output-files
32.12179+ :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
32.12180+
32.12181+ ;; Find the operation that produces a given bundle-type
32.12182+ (defun select-bundle-operation (type &optional monolithic)
32.12183+ (ecase type
32.12184+ ((:dll :shared-library)
32.12185+ (if monolithic 'monolithic-dll-op 'dll-op))
32.12186+ ((:lib :static-library)
32.12187+ (if monolithic 'monolithic-lib-op 'lib-op))
32.12188+ ((:fasb)
32.12189+ (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
32.12190+ ((:image)
32.12191+ 'image-op)
32.12192+ ((:program)
32.12193+ 'program-op))))
32.12194+
32.12195+;;;
32.12196+;;; LOAD-BUNDLE-OP
32.12197+;;;
32.12198+;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
32.12199+;;;
32.12200+(with-upgradability ()
32.12201+ (defmethod component-depends-on ((o load-bundle-op) (c system))
32.12202+ `((,o ,@(component-sideway-dependencies c))
32.12203+ (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
32.12204+ ,@(call-next-method)))
32.12205+
32.12206+ (defmethod input-files ((o load-bundle-op) (c system))
32.12207+ (when (user-system-p c)
32.12208+ (output-files (find-operation o 'compile-bundle-op) c)))
32.12209+
32.12210+ (defmethod perform ((o load-bundle-op) (c system))
32.12211+ (when (input-files o c)
32.12212+ (perform-lisp-load-fasl o c)))
32.12213+
32.12214+ (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
32.12215+ (mark-operation-done (find-operation o 'load-op) c)))
32.12216+
32.12217+;;;
32.12218+;;; PRECOMPILED FILES
32.12219+;;;
32.12220+;;; This component can be used to distribute ASDF systems in precompiled form.
32.12221+;;; Only useful when the dependencies have also been precompiled.
32.12222+;;;
32.12223+(with-upgradability ()
32.12224+ (defmethod trivial-system-p ((s system))
32.12225+ (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
32.12226+
32.12227+ (defmethod input-files ((o operation) (c compiled-file))
32.12228+ (list (component-pathname c)))
32.12229+ (defmethod perform ((o load-op) (c compiled-file))
32.12230+ (perform-lisp-load-fasl o c))
32.12231+ (defmethod perform ((o load-source-op) (c compiled-file))
32.12232+ (perform (find-operation o 'load-op) c))
32.12233+ (defmethod perform ((o operation) (c compiled-file))
32.12234+ nil))
32.12235+
32.12236+;;;
32.12237+;;; Pre-built systems
32.12238+;;;
32.12239+(with-upgradability ()
32.12240+ (defmethod trivial-system-p ((s prebuilt-system))
32.12241+ t)
32.12242+
32.12243+ (defmethod perform ((o link-op) (c prebuilt-system))
32.12244+ nil)
32.12245+
32.12246+ (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
32.12247+ nil)
32.12248+
32.12249+ (defmethod perform ((o lib-op) (c prebuilt-system))
32.12250+ nil)
32.12251+
32.12252+ (defmethod perform ((o dll-op) (c prebuilt-system))
32.12253+ nil)
32.12254+
32.12255+ (defmethod component-depends-on ((o gather-operation) (c prebuilt-system))
32.12256+ nil)
32.12257+
32.12258+ (defmethod output-files ((o lib-op) (c prebuilt-system))
32.12259+ (values (list (prebuilt-system-static-library c)) t)))
32.12260+
32.12261+
32.12262+;;;
32.12263+;;; PREBUILT SYSTEM CREATOR
32.12264+;;;
32.12265+(with-upgradability ()
32.12266+ (defmethod output-files ((o deliver-asd-op) (s system))
32.12267+ (list (make-pathname :name (coerce-filename (component-name s)) :type "asd"
32.12268+ :defaults (component-pathname s))))
32.12269+
32.12270+ ;; because of name collisions between the output files of different
32.12271+ ;; subclasses of DELIVER-ASD-OP, we cannot trust the file system to
32.12272+ ;; tell us if the output file is up-to-date, so just treat the
32.12273+ ;; operation as never being done.
32.12274+ (defmethod operation-done-p ((o deliver-asd-op) (s system))
32.12275+ (declare (ignorable o s))
32.12276+ nil)
32.12277+
32.12278+ (defun space-for-crlf (s)
32.12279+ (substitute-if #\space #'(lambda (x) (find x +crlf+)) s))
32.12280+
32.12281+ (defmethod perform ((o deliver-asd-op) (s system))
32.12282+ "Write an ASDF system definition for loading S as a delivered system."
32.12283+ (let* ((inputs (input-files o s))
32.12284+ (fasl (first inputs))
32.12285+ (library (second inputs))
32.12286+ (asd (output-file o s))
32.12287+ (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
32.12288+ (version (component-version s))
32.12289+ (dependencies
32.12290+ (if (operation-monolithic-p o)
32.12291+ ;; We want only dependencies, and we use basic-load-op rather than load-op so that
32.12292+ ;; this will keep working on systems that load dependencies with load-bundle-op
32.12293+ (remove-if-not 'builtin-system-p
32.12294+ (required-components s :component-type 'system
32.12295+ :keep-operation 'basic-load-op))
32.12296+ (while-collecting (x) ;; resolve the sideway-dependencies of s
32.12297+ (map-direct-dependencies
32.12298+ 'prepare-op s
32.12299+ #'(lambda (o c)
32.12300+ (when (and (typep o 'load-op) (typep c 'system))
32.12301+ (x c)))))))
32.12302+ (depends-on (mapcar 'coerce-name dependencies)))
32.12303+ (when (pathname-equal asd (system-source-file s))
32.12304+ (cerror "overwrite the asd file"
32.12305+ "~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~
32.12306+which is probably not what you want; you probably need to tweak your output translations."
32.12307+ (cons o s) asd))
32.12308+ (with-open-file (s asd :direction :output :if-exists :supersede
32.12309+ :if-does-not-exist :create)
32.12310+ (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
32.12311+ (operation-monolithic-p o) name)
32.12312+ ;; this can cause bugs in cases where one of the functions returns a multi-line
32.12313+ ;; string
32.12314+ (let ((description-string (format nil ";;; Built for ~A ~A on a ~A/~A ~A"
32.12315+ (lisp-implementation-type)
32.12316+ (lisp-implementation-version)
32.12317+ (software-type)
32.12318+ (machine-type)
32.12319+ (software-version))))
32.12320+ ;; ensure the whole thing is on one line
32.12321+ (println (space-for-crlf description-string) s))
32.12322+ (let ((*package* (find-package :asdf-user)))
32.12323+ (pprint `(defsystem ,name
32.12324+ :class prebuilt-system
32.12325+ :version ,version
32.12326+ :depends-on ,depends-on
32.12327+ :components ((:compiled-file ,(pathname-name fasl)))
32.12328+ ,@(when library `(:lib ,(file-namestring library))))
32.12329+ s)
32.12330+ (terpri s)))))
32.12331+
32.12332+ #-(or clasp ecl mkcl)
32.12333+ (defmethod perform ((o basic-compile-bundle-op) (c system))
32.12334+ (let* ((input-files (input-files o c))
32.12335+ (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
32.12336+ (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
32.12337+ (output-files (output-files o c)) ; can't use OUTPUT-FILE fn because possibility it's NIL
32.12338+ (output-file (first output-files)))
32.12339+ (assert (eq (not input-files) (not output-files)))
32.12340+ (when input-files
32.12341+ (when non-fasl-files
32.12342+ (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
32.12343+ (implementation-type) non-fasl-files))
32.12344+ (when (or (prologue-code c) (epilogue-code c))
32.12345+ (error "prologue-code and epilogue-code are not supported on ~A"
32.12346+ (implementation-type)))
32.12347+ (with-staging-pathname (output-file)
32.12348+ (combine-fasls fasl-files output-file)))))
32.12349+
32.12350+ (defmethod input-files ((o load-op) (s precompiled-system))
32.12351+ (bundle-output-files (find-operation o 'compile-bundle-op) s))
32.12352+
32.12353+ (defmethod perform ((o load-op) (s precompiled-system))
32.12354+ (perform-lisp-load-fasl o s))
32.12355+
32.12356+ (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
32.12357+ `((load-op ,s) ,@(call-next-method))))
32.12358+
32.12359+#| ;; Example use:
32.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")))
32.12361+(asdf:load-system :precompiled-asdf-utils)
32.12362+|#
32.12363+
32.12364+#+(or clasp ecl mkcl)
32.12365+(with-upgradability ()
32.12366+ (defun system-module-pathname (module)
32.12367+ (let ((name (coerce-name module)))
32.12368+ (some
32.12369+ 'file-exists-p
32.12370+ (list
32.12371+ #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object)
32.12372+ #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib)
32.12373+ #+ecl (compile-file-pathname (make-pathname :name (strcat "lib" name) :defaults "sys:") :type :lib)
32.12374+ #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object)
32.12375+ #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:")
32.12376+ #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;")))))
32.12377+
32.12378+ (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name)))
32.12379+ "Creates a prebuilt-system if PATHNAME isn't NIL."
32.12380+ (when pathname
32.12381+ (make-instance 'prebuilt-system
32.12382+ :name (coerce-name name)
32.12383+ :static-library (resolve-symlinks* pathname))))
32.12384+
32.12385+ (defun linkable-system (x)
32.12386+ (or ;; If the system is available as source, use it.
32.12387+ (if-let (s (find-system x))
32.12388+ (and (output-files 'lib-op s) s))
32.12389+ ;; If an ASDF upgrade is available from source, but not a UIOP upgrade to that,
32.12390+ ;; then use the asdf/driver system instead of
32.12391+ ;; the UIOP that was disabled by check-not-old-asdf-system.
32.12392+ (if-let (s (and (equal (coerce-name x) "uiop")
32.12393+ (output-files 'lib-op "asdf")
32.12394+ (find-system "asdf/driver")))
32.12395+ (and (output-files 'lib-op s) s))
32.12396+ ;; If there was no source upgrade, look for modules provided by the implementation.
32.12397+ (if-let (p (system-module-pathname (coerce-name x)))
32.12398+ (make-prebuilt-system x p))))
32.12399+
32.12400+ (defmethod component-depends-on :around ((o image-op) (c system))
32.12401+ (let* ((next (call-next-method))
32.12402+ (deps (make-hash-table :test 'equal))
32.12403+ (linkable (loop :for (do . dcs) :in next :collect
32.12404+ (cons do
32.12405+ (loop :for dc :in dcs
32.12406+ :for dep = (and dc (resolve-dependency-spec c dc))
32.12407+ :when dep
32.12408+ :do (setf (gethash (coerce-name (component-system dep)) deps) t)
32.12409+ :collect (or (and (typep dep 'system) (linkable-system dep)) dep))))))
32.12410+ `((lib-op
32.12411+ ,@(unless (no-uiop c)
32.12412+ (list (linkable-system "cmp")
32.12413+ (unless (or (and (gethash "uiop" deps) (linkable-system "uiop"))
32.12414+ (and (gethash "asdf" deps) (linkable-system "asdf")))
32.12415+ (or (linkable-system "uiop")
32.12416+ (linkable-system "asdf")
32.12417+ "asdf")))))
32.12418+ ,@linkable)))
32.12419+
32.12420+ (defmethod perform ((o link-op) (c system))
32.12421+ (let* ((object-files (input-files o c))
32.12422+ (output (output-files o c))
32.12423+ (bundle (first output))
32.12424+ (programp (typep o 'program-op))
32.12425+ (kind (bundle-type o)))
32.12426+ (when output
32.12427+ (apply 'create-image
32.12428+ bundle (append
32.12429+ (when programp (prefix-lisp-object-files c))
32.12430+ object-files
32.12431+ (when programp (postfix-lisp-object-files c)))
32.12432+ :kind kind
32.12433+ :prologue-code (when programp (prologue-code c))
32.12434+ :epilogue-code (when programp (epilogue-code c))
32.12435+ :build-args (when programp (extra-build-args c))
32.12436+ :extra-object-files (when programp (extra-object-files c))
32.12437+ :no-uiop (no-uiop c)
32.12438+ (when programp `(:entry-point ,(component-entry-point c))))))))
32.12439+;;;; -------------------------------------------------------------------------
32.12440+;;;; Concatenate-source
32.12441+
32.12442+(uiop/package:define-package :asdf/concatenate-source
32.12443+ (:recycle :asdf/concatenate-source :asdf)
32.12444+ (:use :uiop/common-lisp :uiop :asdf/upgrade
32.12445+ :asdf/component :asdf/operation
32.12446+ :asdf/system
32.12447+ :asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle)
32.12448+ (:export
32.12449+ #:concatenate-source-op
32.12450+ #:load-concatenated-source-op
32.12451+ #:compile-concatenated-source-op
32.12452+ #:load-compiled-concatenated-source-op
32.12453+ #:monolithic-concatenate-source-op
32.12454+ #:monolithic-load-concatenated-source-op
32.12455+ #:monolithic-compile-concatenated-source-op
32.12456+ #:monolithic-load-compiled-concatenated-source-op))
32.12457+(in-package :asdf/concatenate-source)
32.12458+
32.12459+;;;
32.12460+;;; Concatenate sources
32.12461+;;;
32.12462+(with-upgradability ()
32.12463+ ;; Base classes for both regular and monolithic concatenate-source operations
32.12464+ (defclass basic-concatenate-source-op (bundle-op) ())
32.12465+ (defmethod bundle-type ((o basic-concatenate-source-op)) "lisp")
32.12466+ (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
32.12467+ (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
32.12468+ (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
32.12469+
32.12470+ ;; Regular concatenate-source operations
32.12471+ (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ()
32.12472+ (:documentation "Operation to concatenate all sources in a system into a single file"))
32.12473+ (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
32.12474+ ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))
32.12475+ (:documentation "Operation to load the result of concatenate-source-op as source"))
32.12476+ (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
32.12477+ ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))
32.12478+ (:documentation "Operation to compile the result of concatenate-source-op"))
32.12479+ (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
32.12480+ ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class))
32.12481+ (:documentation "Operation to load the result of compile-concatenated-source-op"))
32.12482+
32.12483+ (defclass monolithic-concatenate-source-op
32.12484+ (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ()
32.12485+ (:documentation "Operation to concatenate all sources in a system and its dependencies
32.12486+into a single file"))
32.12487+ (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
32.12488+ ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))
32.12489+ (:documentation "Operation to load the result of monolithic-concatenate-source-op as source"))
32.12490+ (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
32.12491+ ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))
32.12492+ (:documentation "Operation to compile the result of monolithic-concatenate-source-op"))
32.12493+ (defclass monolithic-load-compiled-concatenated-source-op
32.12494+ (basic-load-compiled-concatenated-source-op)
32.12495+ ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class))
32.12496+ (:documentation "Operation to load the result of monolithic-compile-concatenated-source-op"))
32.12497+
32.12498+ (defmethod input-files ((operation basic-concatenate-source-op) (s system))
32.12499+ (loop :with encoding = (or (component-encoding s) *default-encoding*)
32.12500+ :with other-encodings = '()
32.12501+ :with around-compile = (around-compile-hook s)
32.12502+ :with other-around-compile = '()
32.12503+ :for c :in (required-components ;; see note about similar call to required-components
32.12504+ s :goal-operation 'load-op ;; in bundle.lisp
32.12505+ :keep-operation 'basic-compile-op
32.12506+ :other-systems (operation-monolithic-p operation))
32.12507+ :append
32.12508+ (when (typep c 'cl-source-file)
32.12509+ (let ((e (component-encoding c)))
32.12510+ (unless (or (equal e encoding)
32.12511+ (and (equal e :ASCII) (equal encoding :UTF-8)))
32.12512+ (let ((a (assoc e other-encodings)))
32.12513+ (if a (push (component-find-path c) (cdr a))
32.12514+ (push (list e (component-find-path c)) other-encodings)))))
32.12515+ (unless (equal around-compile (around-compile-hook c))
32.12516+ (push (component-find-path c) other-around-compile))
32.12517+ (input-files (make-operation 'compile-op) c)) :into inputs
32.12518+ :finally
32.12519+ (when other-encodings
32.12520+ (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}"
32.12521+ operation encoding
32.12522+ (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x)))))
32.12523+ other-encodings)))
32.12524+ (when other-around-compile
32.12525+ (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
32.12526+ operation around-compile other-around-compile))
32.12527+ (return inputs)))
32.12528+ (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
32.12529+ (lisp-compilation-output-files o s))
32.12530+
32.12531+ (defmethod perform ((o basic-concatenate-source-op) (s system))
32.12532+ (let* ((ins (input-files o s))
32.12533+ (out (output-file o s))
32.12534+ (tmp (tmpize-pathname out)))
32.12535+ (concatenate-files ins tmp)
32.12536+ (rename-file-overwriting-target tmp out)))
32.12537+ (defmethod perform ((o basic-load-concatenated-source-op) (s system))
32.12538+ (perform-lisp-load-source o s))
32.12539+ (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
32.12540+ (perform-lisp-compilation o s))
32.12541+ (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
32.12542+ (perform-lisp-load-fasl o s)))
32.12543+
32.12544+;;;; -------------------------------------------------------------------------
32.12545+;;;; Package systems in the style of quick-build or faslpath
32.12546+
32.12547+(uiop:define-package :asdf/package-inferred-system
32.12548+ (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
32.12549+ (:use :uiop/common-lisp :uiop
32.12550+ :asdf/upgrade :asdf/session
32.12551+ :asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action
32.12552+ :asdf/parse-defsystem)
32.12553+ (:export
32.12554+ #:package-inferred-system #:sysdef-package-inferred-system-search
32.12555+ #:package-system ;; backward compatibility only. To be removed.
32.12556+ #:register-system-packages
32.12557+ #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
32.12558+(in-package :asdf/package-inferred-system)
32.12559+
32.12560+(with-upgradability ()
32.12561+ ;; The names of the recognized defpackage forms.
32.12562+ (defparameter *defpackage-forms* '(defpackage define-package))
32.12563+
32.12564+ (defun initial-package-inferred-systems-table ()
32.12565+ ;; Mark all existing packages are preloaded.
32.12566+ (let ((h (make-hash-table :test 'equal)))
32.12567+ (dolist (p (list-all-packages))
32.12568+ (dolist (n (package-names p))
32.12569+ (setf (gethash n h) t)))
32.12570+ h))
32.12571+
32.12572+ ;; Mapping from package names to systems that provide them.
32.12573+ (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
32.12574+
32.12575+ (defclass package-inferred-system (system)
32.12576+ ()
32.12577+ (:documentation "Class for primary systems for which secondary systems are automatically
32.12578+in the one-file, one-file, one-system style: system names are mapped to files under the primary
32.12579+system's system-source-directory, dependencies are inferred from the first defpackage form in
32.12580+every such file"))
32.12581+
32.12582+ ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release:
32.12583+ (defclass package-system (package-inferred-system) ())
32.12584+
32.12585+ ;; Is a given form recognizable as a defpackage form?
32.12586+ (defun defpackage-form-p (form)
32.12587+ (and (consp form)
32.12588+ (member (car form) *defpackage-forms*)))
32.12589+
32.12590+ ;; Find the first defpackage form in a stream, if any
32.12591+ (defun stream-defpackage-form (stream)
32.12592+ (loop :for form = (read stream nil nil) :while form
32.12593+ :when (defpackage-form-p form) :return form))
32.12594+
32.12595+ (defun file-defpackage-form (file)
32.12596+ "Return the first DEFPACKAGE form in FILE."
32.12597+ (with-input-file (f file)
32.12598+ (stream-defpackage-form f)))
32.12599+
32.12600+ (define-condition package-inferred-system-missing-package-error (system-definition-error)
32.12601+ ((system :initarg :system :reader error-system)
32.12602+ (pathname :initarg :pathname :reader error-pathname))
32.12603+ (:report (lambda (c s)
32.12604+ (format s (compatfmt "~@<No package form found while ~
32.12605+ trying to define package-inferred-system ~A from file ~A~>")
32.12606+ (error-system c) (error-pathname c)))))
32.12607+
32.12608+ (defun package-dependencies (defpackage-form)
32.12609+ "Return a list of packages depended on by the package
32.12610+defined in DEFPACKAGE-FORM. A package is depended upon if
32.12611+the DEFPACKAGE-FORM uses it or imports a symbol from it."
32.12612+ (assert (defpackage-form-p defpackage-form))
32.12613+ (remove-duplicates
32.12614+ (while-collecting (dep)
32.12615+ (loop :for (option . arguments) :in (cddr defpackage-form) :do
32.12616+ (ecase option
32.12617+ ((:use :mix :reexport :use-reexport :mix-reexport)
32.12618+ (dolist (p arguments) (dep (string p))))
32.12619+ ((:import-from :shadowing-import-from)
32.12620+ (dep (string (first arguments))))
32.12621+ #+package-local-nicknames
32.12622+ ((:local-nicknames)
32.12623+ (loop :for (nil actual-package-name) :in arguments :do
32.12624+ (dep (string actual-package-name))))
32.12625+ ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
32.12626+ :from-end t :test 'equal))
32.12627+
32.12628+ (defun package-designator-name (package)
32.12629+ "Normalize a package designator to a string"
32.12630+ (etypecase package
32.12631+ (package (package-name package))
32.12632+ (string package)
32.12633+ (symbol (string package))))
32.12634+
32.12635+ (defun register-system-packages (system packages)
32.12636+ "Register SYSTEM as providing PACKAGES."
32.12637+ (let ((name (or (eq system t) (coerce-name system))))
32.12638+ (dolist (p (ensure-list packages))
32.12639+ (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
32.12640+
32.12641+ (defun package-name-system (package-name)
32.12642+ "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
32.12643+otherwise return a default system name computed from PACKAGE-NAME."
32.12644+ (check-type package-name string)
32.12645+ (or (gethash package-name *package-inferred-systems*)
32.12646+ (string-downcase package-name)))
32.12647+
32.12648+ ;; Given a file in package-inferred-system style, find its dependencies
32.12649+ (defun package-inferred-system-file-dependencies (file &optional system)
32.12650+ (if-let (defpackage-form (file-defpackage-form file))
32.12651+ (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
32.12652+ (error 'package-inferred-system-missing-package-error :system system :pathname file)))
32.12653+
32.12654+ ;; Given package-inferred-system object, check whether its specification matches
32.12655+ ;; the provided parameters
32.12656+ (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies)
32.12657+ (and (eq (type-of system) 'package-inferred-system)
32.12658+ (equal (component-name system) name)
32.12659+ (pathname-equal directory (component-pathname system))
32.12660+ (equal dependencies (component-sideway-dependencies system))
32.12661+ (equal around-compile (around-compile-hook system))
32.12662+ (let ((children (component-children system)))
32.12663+ (and (length=n-p children 1)
32.12664+ (let ((child (first children)))
32.12665+ (and (eq (type-of child) 'cl-source-file)
32.12666+ (equal (component-name child) "lisp")
32.12667+ (and (slot-boundp child 'relative-pathname)
32.12668+ (equal (slot-value child 'relative-pathname) subpath))))))))
32.12669+
32.12670+ ;; sysdef search function to push into *system-definition-search-functions*
32.12671+ (defun sysdef-package-inferred-system-search (system-name)
32.12672+ "Takes SYSTEM-NAME and returns an initialized SYSTEM object, or NIL. Made to be added to
32.12673+*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*."
32.12674+ (let ((primary (primary-system-name system-name)))
32.12675+ ;; this function ONLY does something if the primary system name is NOT the same as
32.12676+ ;; SYSTEM-NAME. It is used to find the systems with names that are relative to
32.12677+ ;; the primary system's name, and that are not explicitly specified in the system
32.12678+ ;; definition
32.12679+ (unless (equal primary system-name)
32.12680+ (let ((top (find-system primary nil)))
32.12681+ (when (typep top 'package-inferred-system)
32.12682+ (if-let (dir (component-pathname top))
32.12683+ (let* ((sub (subseq system-name (1+ (length primary))))
32.12684+ (component-type (class-for-type top :file))
32.12685+ (file-type (file-type (make-instance component-type)))
32.12686+ (f (probe-file* (subpathname dir sub :type file-type)
32.12687+ :truename *resolve-symlinks*)))
32.12688+ (when (file-pathname-p f)
32.12689+ (let ((dependencies (package-inferred-system-file-dependencies f system-name))
32.12690+ (previous (registered-system system-name))
32.12691+ (around-compile (around-compile-hook top)))
32.12692+ (if (same-package-inferred-system-p previous system-name dir sub around-compile dependencies)
32.12693+ previous
32.12694+ (eval `(defsystem ,system-name
32.12695+ :class package-inferred-system
32.12696+ :default-component-class ,component-type
32.12697+ :source-file ,(system-source-file top)
32.12698+ :pathname ,dir
32.12699+ :depends-on ,dependencies
32.12700+ :around-compile ,around-compile
32.12701+ :components ((,component-type file-type :pathname ,sub)))))))))))))))
32.12702+
32.12703+(with-upgradability ()
32.12704+ (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
32.12705+ (setf *system-definition-search-functions*
32.12706+ (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
32.12707+ *system-definition-search-functions*)))
32.12708+;;;; ---------------------------------------------------------------------------
32.12709+;;;; asdf-output-translations
32.12710+
32.12711+(uiop/package:define-package :asdf/output-translations
32.12712+ (:recycle :asdf/output-translations :asdf)
32.12713+ (:use :uiop/common-lisp :uiop :asdf/upgrade)
32.12714+ (:export
32.12715+ #:*output-translations* #:*output-translations-parameter*
32.12716+ #:invalid-output-translation
32.12717+ #:output-translations #:output-translations-initialized-p
32.12718+ #:initialize-output-translations #:clear-output-translations
32.12719+ #:disable-output-translations #:ensure-output-translations
32.12720+ #:apply-output-translations
32.12721+ #:validate-output-translations-directive #:validate-output-translations-form
32.12722+ #:validate-output-translations-file #:validate-output-translations-directory
32.12723+ #:parse-output-translations-string #:wrapping-output-translations
32.12724+ #:user-output-translations-pathname #:system-output-translations-pathname
32.12725+ #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
32.12726+ #:environment-output-translations #:process-output-translations
32.12727+ #:compute-output-translations
32.12728+ #+abcl #:translate-jar-pathname
32.12729+ ))
32.12730+(in-package :asdf/output-translations)
32.12731+
32.12732+;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro
32.12733+;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us.
32.12734+(when-upgrading (:version "3.1.2") (fmakunbound '(setf output-translations)))
32.12735+
32.12736+(with-upgradability ()
32.12737+ (define-condition invalid-output-translation (invalid-configuration warning)
32.12738+ ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
32.12739+
32.12740+ (defvar *output-translations* ()
32.12741+ "Either NIL (for uninitialized), or a list of one element,
32.12742+said element itself being a sorted list of mappings.
32.12743+Each mapping is a pair of a source pathname and destination pathname,
32.12744+and the order is by decreasing length of namestring of the source pathname.")
32.12745+
32.12746+ (defun output-translations ()
32.12747+ "Return the configured output-translations, if any"
32.12748+ (car *output-translations*))
32.12749+
32.12750+ ;; Set the output-translations, by sorting the provided new-value.
32.12751+ (defun set-output-translations (new-value)
32.12752+ (setf *output-translations*
32.12753+ (list
32.12754+ (stable-sort (copy-list new-value) #'>
32.12755+ :key #'(lambda (x)
32.12756+ (etypecase (car x)
32.12757+ ((eql t) -1)
32.12758+ (pathname
32.12759+ (let ((directory
32.12760+ (normalize-pathname-directory-component
32.12761+ (pathname-directory (car x)))))
32.12762+ (if (listp directory) (length directory) 0))))))))
32.12763+ new-value)
32.12764+ (defun (setf output-translations) (new-value) (set-output-translations new-value))
32.12765+
32.12766+ (defun output-translations-initialized-p ()
32.12767+ "Have the output-translations been initialized yet?"
32.12768+ (and *output-translations* t))
32.12769+
32.12770+ (defun clear-output-translations ()
32.12771+ "Undoes any initialization of the output translations."
32.12772+ (setf *output-translations* '())
32.12773+ (values))
32.12774+ (register-clear-configuration-hook 'clear-output-translations)
32.12775+
32.12776+
32.12777+ ;;; Validation of the configuration directives...
32.12778+
32.12779+ (defun validate-output-translations-directive (directive)
32.12780+ (or (member directive '(:enable-user-cache :disable-cache nil))
32.12781+ (and (consp directive)
32.12782+ (or (and (length=n-p directive 2)
32.12783+ (or (and (eq (first directive) :include)
32.12784+ (typep (second directive) '(or string pathname null)))
32.12785+ (and (location-designator-p (first directive))
32.12786+ (or (location-designator-p (second directive))
32.12787+ (location-function-p (second directive))))))
32.12788+ (and (length=n-p directive 1)
32.12789+ (location-designator-p (first directive)))))))
32.12790+
32.12791+ (defun validate-output-translations-form (form &key location)
32.12792+ (validate-configuration-form
32.12793+ form
32.12794+ :output-translations
32.12795+ 'validate-output-translations-directive
32.12796+ :location location :invalid-form-reporter 'invalid-output-translation))
32.12797+
32.12798+ (defun validate-output-translations-file (file)
32.12799+ (validate-configuration-file
32.12800+ file 'validate-output-translations-form :description "output translations"))
32.12801+
32.12802+ (defun validate-output-translations-directory (directory)
32.12803+ (validate-configuration-directory
32.12804+ directory :output-translations 'validate-output-translations-directive
32.12805+ :invalid-form-reporter 'invalid-output-translation))
32.12806+
32.12807+
32.12808+ ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents
32.12809+ (defun parse-output-translations-string (string &key location)
32.12810+ (cond
32.12811+ ((or (null string) (equal string ""))
32.12812+ '(:output-translations :inherit-configuration))
32.12813+ ((not (stringp string))
32.12814+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
32.12815+ ((eql (char string 0) #\")
32.12816+ (parse-output-translations-string (read-from-string string) :location location))
32.12817+ ((eql (char string 0) #\()
32.12818+ (validate-output-translations-form (read-from-string string) :location location))
32.12819+ (t
32.12820+ (loop
32.12821+ :with inherit = nil
32.12822+ :with directives = ()
32.12823+ :with start = 0
32.12824+ :with end = (length string)
32.12825+ :with source = nil
32.12826+ :with separator = (inter-directory-separator)
32.12827+ :for i = (or (position separator string :start start) end) :do
32.12828+ (let ((s (subseq string start i)))
32.12829+ (cond
32.12830+ (source
32.12831+ (push (list source (if (equal "" s) nil s)) directives)
32.12832+ (setf source nil))
32.12833+ ((equal "" s)
32.12834+ (when inherit
32.12835+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
32.12836+ string))
32.12837+ (setf inherit t)
32.12838+ (push :inherit-configuration directives))
32.12839+ (t
32.12840+ (setf source s)))
32.12841+ (setf start (1+ i))
32.12842+ (when (> start end)
32.12843+ (when source
32.12844+ (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
32.12845+ string))
32.12846+ (unless inherit
32.12847+ (push :ignore-inherited-configuration directives))
32.12848+ (return `(:output-translations ,@(nreverse directives)))))))))
32.12849+
32.12850+
32.12851+ ;; The default sources of configuration for output-translations
32.12852+ (defparameter* *default-output-translations*
32.12853+ '(environment-output-translations
32.12854+ user-output-translations-pathname
32.12855+ user-output-translations-directory-pathname
32.12856+ system-output-translations-pathname
32.12857+ system-output-translations-directory-pathname))
32.12858+
32.12859+ ;; Compulsory implementation-dependent wrapping for the translations:
32.12860+ ;; handle implementation-provided systems.
32.12861+ (defun wrapping-output-translations ()
32.12862+ `(:output-translations
32.12863+ ;; Some implementations have precompiled ASDF systems,
32.12864+ ;; so we must disable translations for implementation paths.
32.12865+ #+(or clasp #|clozure|# ecl mkcl sbcl)
32.12866+ ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
32.12867+ (when h `(((,h ,*wild-path*) ()))))
32.12868+ #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
32.12869+ ;; All-import, here is where we want user stuff to be:
32.12870+ :inherit-configuration
32.12871+ ;; These are for convenience, and can be overridden by the user:
32.12872+ #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
32.12873+ #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
32.12874+ ;; We enable the user cache by default, and here is the place we do:
32.12875+ :enable-user-cache))
32.12876+
32.12877+ ;; Relative pathnames of output-translations configuration to XDG configuration directory
32.12878+ (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
32.12879+ (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
32.12880+
32.12881+ ;; Locating various configuration pathnames, depending on input or output intent.
32.12882+ (defun user-output-translations-pathname (&key (direction :input))
32.12883+ (xdg-config-pathname *output-translations-file* direction))
32.12884+ (defun system-output-translations-pathname (&key (direction :input))
32.12885+ (find-preferred-file (system-config-pathnames *output-translations-file*)
32.12886+ :direction direction))
32.12887+ (defun user-output-translations-directory-pathname (&key (direction :input))
32.12888+ (xdg-config-pathname *output-translations-directory* direction))
32.12889+ (defun system-output-translations-directory-pathname (&key (direction :input))
32.12890+ (find-preferred-file (system-config-pathnames *output-translations-directory*)
32.12891+ :direction direction))
32.12892+ (defun environment-output-translations ()
32.12893+ (getenv "ASDF_OUTPUT_TRANSLATIONS"))
32.12894+
32.12895+
32.12896+ ;;; Processing the configuration.
32.12897+
32.12898+ (defgeneric process-output-translations (spec &key inherit collect))
32.12899+
32.12900+ (defun inherit-output-translations (inherit &key collect)
32.12901+ (when inherit
32.12902+ (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
32.12903+
32.12904+ (defun process-output-translations-directive (directive &key inherit collect)
32.12905+ (if (atom directive)
32.12906+ (ecase directive
32.12907+ ((:enable-user-cache)
32.12908+ (process-output-translations-directive '(t :user-cache) :collect collect))
32.12909+ ((:disable-cache)
32.12910+ (process-output-translations-directive '(t t) :collect collect))
32.12911+ ((:inherit-configuration)
32.12912+ (inherit-output-translations inherit :collect collect))
32.12913+ ((:ignore-inherited-configuration :ignore-invalid-entries nil)
32.12914+ nil))
32.12915+ (let ((src (first directive))
32.12916+ (dst (second directive)))
32.12917+ (if (eq src :include)
32.12918+ (when dst
32.12919+ (process-output-translations (pathname dst) :inherit nil :collect collect))
32.12920+ (when src
32.12921+ (let ((trusrc (or (eql src t)
32.12922+ (let ((loc (resolve-location src :ensure-directory t :wilden t)))
32.12923+ (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
32.12924+ (cond
32.12925+ ((location-function-p dst)
32.12926+ (funcall collect
32.12927+ (list trusrc (ensure-function (second dst)))))
32.12928+ ((typep dst 'boolean)
32.12929+ (funcall collect (list trusrc t)))
32.12930+ (t
32.12931+ (let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
32.12932+ (funcall collect (list trudst t))
32.12933+ (funcall collect (list trusrc trudst)))))))))))
32.12934+
32.12935+ (defmethod process-output-translations ((x symbol) &key
32.12936+ (inherit *default-output-translations*)
32.12937+ collect)
32.12938+ (process-output-translations (funcall x) :inherit inherit :collect collect))
32.12939+ (defmethod process-output-translations ((pathname pathname) &key inherit collect)
32.12940+ (cond
32.12941+ ((directory-pathname-p pathname)
32.12942+ (process-output-translations (validate-output-translations-directory pathname)
32.12943+ :inherit inherit :collect collect))
32.12944+ ((probe-file* pathname :truename *resolve-symlinks*)
32.12945+ (process-output-translations (validate-output-translations-file pathname)
32.12946+ :inherit inherit :collect collect))
32.12947+ (t
32.12948+ (inherit-output-translations inherit :collect collect))))
32.12949+ (defmethod process-output-translations ((string string) &key inherit collect)
32.12950+ (process-output-translations (parse-output-translations-string string)
32.12951+ :inherit inherit :collect collect))
32.12952+ (defmethod process-output-translations ((x null) &key inherit collect)
32.12953+ (inherit-output-translations inherit :collect collect))
32.12954+ (defmethod process-output-translations ((form cons) &key inherit collect)
32.12955+ (dolist (directive (cdr (validate-output-translations-form form)))
32.12956+ (process-output-translations-directive directive :inherit inherit :collect collect)))
32.12957+
32.12958+
32.12959+ ;;; Top-level entry-points to configure output-translations
32.12960+
32.12961+ (defun compute-output-translations (&optional parameter)
32.12962+ "read the configuration, return it"
32.12963+ (remove-duplicates
32.12964+ (while-collecting (c)
32.12965+ (inherit-output-translations
32.12966+ `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
32.12967+ :test 'equal :from-end t))
32.12968+
32.12969+ ;; Saving the user-provided parameter to output-translations, if any,
32.12970+ ;; so we can recompute the translations after code upgrade.
32.12971+ (defvar *output-translations-parameter* nil)
32.12972+
32.12973+ ;; Main entry-point for users.
32.12974+ (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
32.12975+ "read the configuration, initialize the internal configuration variable,
32.12976+return the configuration"
32.12977+ (setf *output-translations-parameter* parameter
32.12978+ (output-translations) (compute-output-translations parameter)))
32.12979+
32.12980+ (defun disable-output-translations ()
32.12981+ "Initialize output translations in a way that maps every file to itself,
32.12982+effectively disabling the output translation facility."
32.12983+ (initialize-output-translations
32.12984+ '(:output-translations :disable-cache :ignore-inherited-configuration)))
32.12985+
32.12986+ ;; checks an initial variable to see whether the state is initialized
32.12987+ ;; or cleared. In the former case, return current configuration; in
32.12988+ ;; the latter, initialize. ASDF will call this function at the start
32.12989+ ;; of (asdf:find-system).
32.12990+ (defun ensure-output-translations ()
32.12991+ (if (output-translations-initialized-p)
32.12992+ (output-translations)
32.12993+ (initialize-output-translations)))
32.12994+
32.12995+
32.12996+ ;; Top-level entry-point to _use_ output-translations
32.12997+ (defun apply-output-translations (path)
32.12998+ (etypecase path
32.12999+ (logical-pathname
32.13000+ path)
32.13001+ ((or pathname string)
32.13002+ (ensure-output-translations)
32.13003+ (loop :with p = (resolve-symlinks* path)
32.13004+ :for (source destination) :in (car *output-translations*)
32.13005+ :for root = (when (or (eq source t)
32.13006+ (and (pathnamep source)
32.13007+ (not (absolute-pathname-p source))))
32.13008+ (pathname-root p))
32.13009+ :for absolute-source = (cond
32.13010+ ((eq source t) (wilden root))
32.13011+ (root (merge-pathnames* source root))
32.13012+ (t source))
32.13013+ :when (or (eq source t) (pathname-match-p p absolute-source))
32.13014+ :return (translate-pathname* p absolute-source destination root source)
32.13015+ :finally (return p)))))
32.13016+
32.13017+
32.13018+ ;; Hook into uiop's output-translation mechanism
32.13019+ #-cormanlisp
32.13020+ (setf *output-translation-function* 'apply-output-translations)
32.13021+
32.13022+
32.13023+ ;;; Implementation-dependent hacks
32.13024+ #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar.
32.13025+ (defun translate-jar-pathname (source wildcard)
32.13026+ (declare (ignore wildcard))
32.13027+ (flet ((normalize-device (pathname)
32.13028+ (if (find :windows *features*)
32.13029+ pathname
32.13030+ (make-pathname :defaults pathname :device :unspecific))))
32.13031+ (let* ((jar
32.13032+ (pathname (first (pathname-device source))))
32.13033+ (target-root-directory-namestring
32.13034+ (format nil "/___jar___file___root___/~@[~A/~]"
32.13035+ (and (find :windows *features*)
32.13036+ (pathname-device jar))))
32.13037+ (relative-source
32.13038+ (relativize-pathname-directory source))
32.13039+ (relative-jar
32.13040+ (relativize-pathname-directory (ensure-directory-pathname jar)))
32.13041+ (target-root-directory
32.13042+ (normalize-device
32.13043+ (pathname-directory-pathname
32.13044+ (parse-namestring target-root-directory-namestring))))
32.13045+ (target-root
32.13046+ (merge-pathnames* relative-jar target-root-directory))
32.13047+ (target
32.13048+ (merge-pathnames* relative-source target-root)))
32.13049+ (normalize-device (apply-output-translations target))))))
32.13050+
32.13051+;;;; -----------------------------------------------------------------
32.13052+;;;; Source Registry Configuration, by Francois-Rene Rideau
32.13053+;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
32.13054+
32.13055+(uiop/package:define-package :asdf/source-registry
32.13056+ ;; NB: asdf/find-system allows upgrade from <=3.2.1 that have initialize-source-registry there
32.13057+ (:recycle :asdf/source-registry :asdf/find-system :asdf)
32.13058+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/system-registry)
32.13059+ (:export
32.13060+ #:*source-registry-parameter* #:*default-source-registries*
32.13061+ #:invalid-source-registry
32.13062+ #:source-registry-initialized-p
32.13063+ #:initialize-source-registry #:clear-source-registry #:*source-registry*
32.13064+ #:ensure-source-registry #:*source-registry-parameter*
32.13065+ #:*default-source-registry-exclusions* #:*source-registry-exclusions*
32.13066+ #:*wild-asd* #:directory-asd-files #:register-asd-directory
32.13067+ #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files
32.13068+ #:validate-source-registry-directive #:validate-source-registry-form
32.13069+ #:validate-source-registry-file #:validate-source-registry-directory
32.13070+ #:parse-source-registry-string #:wrapping-source-registry
32.13071+ #:default-user-source-registry #:default-system-source-registry
32.13072+ #:user-source-registry #:system-source-registry
32.13073+ #:user-source-registry-directory #:system-source-registry-directory
32.13074+ #:environment-source-registry #:process-source-registry #:inherit-source-registry
32.13075+ #:compute-source-registry #:flatten-source-registry
32.13076+ #:sysdef-source-registry-search))
32.13077+(in-package :asdf/source-registry)
32.13078+
32.13079+(with-upgradability ()
32.13080+ (define-condition invalid-source-registry (invalid-configuration warning)
32.13081+ ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
32.13082+
32.13083+ ;; Default list of directories under which the source-registry tree search won't recurse
32.13084+ (defvar *default-source-registry-exclusions*
32.13085+ '(;;-- Using ack 1.2 exclusions
32.13086+ ".bzr" ".cdv"
32.13087+ ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
32.13088+ ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
32.13089+ "_sgbak" "autom4te.cache" "cover_db" "_build"
32.13090+ ;;-- debian often builds stuff under the debian directory... BAD.
32.13091+ "debian"))
32.13092+
32.13093+ ;; Actual list of directories under which the source-registry tree search won't recurse
32.13094+ (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
32.13095+
32.13096+ ;; The state of the source-registry after search in configured locations
32.13097+ (defvar *source-registry* nil
32.13098+ "Either NIL (for uninitialized), or an equal hash-table, mapping
32.13099+system names to pathnames of .asd files")
32.13100+
32.13101+ ;; Saving the user-provided parameter to the source-registry, if any,
32.13102+ ;; so we can recompute the source-registry after code upgrade.
32.13103+ (defvar *source-registry-parameter* nil)
32.13104+
32.13105+ (defun source-registry-initialized-p ()
32.13106+ (typep *source-registry* 'hash-table))
32.13107+
32.13108+ (defun clear-source-registry ()
32.13109+ "Undoes any initialization of the source registry."
32.13110+ (setf *source-registry* nil)
32.13111+ (values))
32.13112+ (register-clear-configuration-hook 'clear-source-registry)
32.13113+
32.13114+ (defparameter *wild-asd*
32.13115+ (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
32.13116+
32.13117+ (defun directory-asd-files (directory)
32.13118+ (directory-files directory *wild-asd*))
32.13119+
32.13120+ (defun collect-asds-in-directory (directory collect)
32.13121+ (let ((asds (directory-asd-files directory)))
32.13122+ (map () collect asds)
32.13123+ asds))
32.13124+
32.13125+ (defvar *recurse-beyond-asds* t
32.13126+ "Should :tree entries of the source-registry recurse in subdirectories
32.13127+after having found a .asd file? True by default.")
32.13128+
32.13129+ ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache,
32.13130+ ;; read its contents instead of further recursively querying the filesystem.
32.13131+ (defun process-source-registry-cache (directory collect)
32.13132+ (let ((cache (ignore-errors
32.13133+ (safe-read-file-form (subpathname directory ".cl-source-registry.cache")))))
32.13134+ (when (and (listp cache) (eq :source-registry-cache (first cache)))
32.13135+ (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s)))
32.13136+ t)))
32.13137+
32.13138+ (defun collect-sub*directories-asd-files
32.13139+ (directory &key (exclude *default-source-registry-exclusions*) collect
32.13140+ (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache)
32.13141+ (let ((visited (make-hash-table :test 'equalp)))
32.13142+ (flet ((collectp (dir)
32.13143+ (unless (and (not ignore-cache) (process-source-registry-cache dir collect))
32.13144+ (let ((asds (collect-asds-in-directory dir collect)))
32.13145+ (or recurse-beyond-asds (not asds)))))
32.13146+ (recursep (x) ; x will be a directory pathname
32.13147+ (and
32.13148+ (not (member (car (last (pathname-directory x))) exclude :test #'equal))
32.13149+ (flet ((pathname-key (x)
32.13150+ (namestring (truename* x))))
32.13151+ (let ((visitedp (gethash (pathname-key x) visited)))
32.13152+ (if visitedp nil
32.13153+ (setf (gethash (pathname-key x) visited) t)))))))
32.13154+ (collect-sub*directories directory #'collectp #'recursep (constantly nil)))))
32.13155+
32.13156+
32.13157+ ;;; Validate the configuration forms
32.13158+
32.13159+ (defun validate-source-registry-directive (directive)
32.13160+ (or (member directive '(:default-registry))
32.13161+ (and (consp directive)
32.13162+ (let ((rest (rest directive)))
32.13163+ (case (first directive)
32.13164+ ((:include :directory :tree)
32.13165+ (and (length=n-p rest 1)
32.13166+ (location-designator-p (first rest))))
32.13167+ ((:exclude :also-exclude)
32.13168+ (every #'stringp rest))
32.13169+ ((:default-registry)
32.13170+ (null rest)))))))
32.13171+
32.13172+ (defun validate-source-registry-form (form &key location)
32.13173+ (validate-configuration-form
32.13174+ form :source-registry 'validate-source-registry-directive
32.13175+ :location location :invalid-form-reporter 'invalid-source-registry))
32.13176+
32.13177+ (defun validate-source-registry-file (file)
32.13178+ (validate-configuration-file
32.13179+ file 'validate-source-registry-form :description "a source registry"))
32.13180+
32.13181+ (defun validate-source-registry-directory (directory)
32.13182+ (validate-configuration-directory
32.13183+ directory :source-registry 'validate-source-registry-directive
32.13184+ :invalid-form-reporter 'invalid-source-registry))
32.13185+
32.13186+
32.13187+ ;;; Parse the configuration string
32.13188+
32.13189+ (defun parse-source-registry-string (string &key location)
32.13190+ (cond
32.13191+ ((or (null string) (equal string ""))
32.13192+ '(:source-registry :inherit-configuration))
32.13193+ ((not (stringp string))
32.13194+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
32.13195+ ((find (char string 0) "\"(")
32.13196+ (validate-source-registry-form (read-from-string string) :location location))
32.13197+ (t
32.13198+ (loop
32.13199+ :with inherit = nil
32.13200+ :with directives = ()
32.13201+ :with start = 0
32.13202+ :with end = (length string)
32.13203+ :with separator = (inter-directory-separator)
32.13204+ :for pos = (position separator string :start start) :do
32.13205+ (let ((s (subseq string start (or pos end))))
32.13206+ (flet ((check (dir)
32.13207+ (unless (absolute-pathname-p dir)
32.13208+ (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
32.13209+ dir))
32.13210+ (cond
32.13211+ ((equal "" s) ; empty element: inherit
32.13212+ (when inherit
32.13213+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
32.13214+ string))
32.13215+ (setf inherit t)
32.13216+ (push ':inherit-configuration directives))
32.13217+ ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
32.13218+ (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
32.13219+ (t
32.13220+ (push `(:directory ,(check s)) directives))))
32.13221+ (cond
32.13222+ (pos
32.13223+ (setf start (1+ pos)))
32.13224+ (t
32.13225+ (unless inherit
32.13226+ (push '(:ignore-inherited-configuration) directives))
32.13227+ (return `(:source-registry ,@(nreverse directives))))))))))
32.13228+
32.13229+ (defun register-asd-directory (directory &key recurse exclude collect)
32.13230+ (if (not recurse)
32.13231+ (collect-asds-in-directory directory collect)
32.13232+ (collect-sub*directories-asd-files
32.13233+ directory :exclude exclude :collect collect)))
32.13234+
32.13235+ (defparameter* *default-source-registries*
32.13236+ '(environment-source-registry
32.13237+ user-source-registry
32.13238+ user-source-registry-directory
32.13239+ default-user-source-registry
32.13240+ system-source-registry
32.13241+ system-source-registry-directory
32.13242+ default-system-source-registry)
32.13243+ "List of default source registries" "3.1.0.102")
32.13244+
32.13245+ (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
32.13246+ (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
32.13247+
32.13248+ (defun wrapping-source-registry ()
32.13249+ `(:source-registry
32.13250+ #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
32.13251+ :inherit-configuration
32.13252+ #+mkcl (:tree ,(translate-logical-pathname "SYS:"))
32.13253+ #+cmucl (:tree #p"modules:")
32.13254+ #+scl (:tree #p"file://modules/")))
32.13255+ (defun default-user-source-registry ()
32.13256+ `(:source-registry
32.13257+ (:tree (:home "common-lisp/"))
32.13258+ #+sbcl (:directory (:home ".sbcl/systems/"))
32.13259+ (:directory ,(xdg-data-home "common-lisp/systems/"))
32.13260+ (:tree ,(xdg-data-home "common-lisp/source/"))
32.13261+ :inherit-configuration))
32.13262+ (defun default-system-source-registry ()
32.13263+ `(:source-registry
32.13264+ ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
32.13265+ :collect `(:directory (,dir "systems/"))
32.13266+ :collect `(:tree (,dir "source/")))
32.13267+ :inherit-configuration))
32.13268+ (defun user-source-registry (&key (direction :input))
32.13269+ (xdg-config-pathname *source-registry-file* direction))
32.13270+ (defun system-source-registry (&key (direction :input))
32.13271+ (find-preferred-file (system-config-pathnames *source-registry-file*)
32.13272+ :direction direction))
32.13273+ (defun user-source-registry-directory (&key (direction :input))
32.13274+ (xdg-config-pathname *source-registry-directory* direction))
32.13275+ (defun system-source-registry-directory (&key (direction :input))
32.13276+ (find-preferred-file (system-config-pathnames *source-registry-directory*)
32.13277+ :direction direction))
32.13278+ (defun environment-source-registry ()
32.13279+ (getenv "CL_SOURCE_REGISTRY"))
32.13280+
32.13281+
32.13282+ ;;; Process the source-registry configuration
32.13283+
32.13284+ (defgeneric process-source-registry (spec &key inherit register))
32.13285+
32.13286+ (defun inherit-source-registry (inherit &key register)
32.13287+ (when inherit
32.13288+ (process-source-registry (first inherit) :register register :inherit (rest inherit))))
32.13289+
32.13290+ (defun process-source-registry-directive (directive &key inherit register)
32.13291+ (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
32.13292+ (ecase kw
32.13293+ ((:include)
32.13294+ (destructuring-bind (pathname) rest
32.13295+ (process-source-registry (resolve-location pathname) :inherit nil :register register)))
32.13296+ ((:directory)
32.13297+ (destructuring-bind (pathname) rest
32.13298+ (when pathname
32.13299+ (funcall register (resolve-location pathname :ensure-directory t)))))
32.13300+ ((:tree)
32.13301+ (destructuring-bind (pathname) rest
32.13302+ (when pathname
32.13303+ (funcall register (resolve-location pathname :ensure-directory t)
32.13304+ :recurse t :exclude *source-registry-exclusions*))))
32.13305+ ((:exclude)
32.13306+ (setf *source-registry-exclusions* rest))
32.13307+ ((:also-exclude)
32.13308+ (appendf *source-registry-exclusions* rest))
32.13309+ ((:default-registry)
32.13310+ (inherit-source-registry
32.13311+ '(default-user-source-registry default-system-source-registry) :register register))
32.13312+ ((:inherit-configuration)
32.13313+ (inherit-source-registry inherit :register register))
32.13314+ ((:ignore-inherited-configuration)
32.13315+ nil)))
32.13316+ nil)
32.13317+
32.13318+ (defmethod process-source-registry ((x symbol) &key inherit register)
32.13319+ (process-source-registry (funcall x) :inherit inherit :register register))
32.13320+ (defmethod process-source-registry ((pathname pathname) &key inherit register)
32.13321+ (cond
32.13322+ ((directory-pathname-p pathname)
32.13323+ (let ((*here-directory* (resolve-symlinks* pathname)))
32.13324+ (process-source-registry (validate-source-registry-directory pathname)
32.13325+ :inherit inherit :register register)))
32.13326+ ((probe-file* pathname :truename *resolve-symlinks*)
32.13327+ (let ((*here-directory* (pathname-directory-pathname pathname)))
32.13328+ (process-source-registry (validate-source-registry-file pathname)
32.13329+ :inherit inherit :register register)))
32.13330+ (t
32.13331+ (inherit-source-registry inherit :register register))))
32.13332+ (defmethod process-source-registry ((string string) &key inherit register)
32.13333+ (process-source-registry (parse-source-registry-string string)
32.13334+ :inherit inherit :register register))
32.13335+ (defmethod process-source-registry ((x null) &key inherit register)
32.13336+ (inherit-source-registry inherit :register register))
32.13337+ (defmethod process-source-registry ((form cons) &key inherit register)
32.13338+ (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
32.13339+ (dolist (directive (cdr (validate-source-registry-form form)))
32.13340+ (process-source-registry-directive directive :inherit inherit :register register))))
32.13341+
32.13342+
32.13343+ ;; Flatten the user-provided configuration into an ordered list of directories and trees
32.13344+ (defun flatten-source-registry (&optional (parameter *source-registry-parameter*))
32.13345+ (remove-duplicates
32.13346+ (while-collecting (collect)
32.13347+ (with-pathname-defaults () ;; be location-independent
32.13348+ (inherit-source-registry
32.13349+ `(wrapping-source-registry
32.13350+ ,parameter
32.13351+ ,@*default-source-registries*)
32.13352+ :register #'(lambda (directory &key recurse exclude)
32.13353+ (collect (list directory :recurse recurse :exclude exclude))))))
32.13354+ :test 'equal :from-end t))
32.13355+
32.13356+ ;; MAYBE: move this utility function to uiop/pathname and export it?
32.13357+ (defun pathname-directory-depth (p)
32.13358+ (length (normalize-pathname-directory-component (pathname-directory p))))
32.13359+
32.13360+ (defun preferred-source-path-p (x y)
32.13361+ "Return T iff X is to be preferred over Y as a source path"
32.13362+ (let ((lx (pathname-directory-depth x))
32.13363+ (ly (pathname-directory-depth y)))
32.13364+ (or (< lx ly)
32.13365+ (and (= lx ly)
32.13366+ (string< (namestring x)
32.13367+ (namestring y))))))
32.13368+
32.13369+ ;; Will read the configuration and initialize all internal variables.
32.13370+ (defun compute-source-registry (&optional (parameter *source-registry-parameter*)
32.13371+ (registry *source-registry*))
32.13372+ (dolist (entry (flatten-source-registry parameter))
32.13373+ (destructuring-bind (directory &key recurse exclude) entry
32.13374+ (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
32.13375+ (register-asd-directory
32.13376+ directory :recurse recurse :exclude exclude :collect
32.13377+ #'(lambda (asd)
32.13378+ (let* ((name (pathname-name asd))
32.13379+ (name (if (typep asd 'logical-pathname)
32.13380+ ;; logical pathnames are upper-case,
32.13381+ ;; at least in the CLHS and on SBCL,
32.13382+ ;; yet (coerce-name :foo) is lower-case.
32.13383+ ;; won't work well with (load-system "Foo")
32.13384+ ;; instead of (load-system 'foo)
32.13385+ (string-downcase name)
32.13386+ name)))
32.13387+ (unless (gethash name registry) ; already shadowed by something else
32.13388+ (if-let (old (gethash name h))
32.13389+ ;; If the name appears multiple times,
32.13390+ ;; prefer the one with the shallowest directory,
32.13391+ ;; or if they have same depth, compare unix-namestring with string<
32.13392+ (multiple-value-bind (better worse)
32.13393+ (if (preferred-source-path-p asd old)
32.13394+ (progn (setf (gethash name h) asd) (values asd old))
32.13395+ (values old asd))
32.13396+ (when *verbose-out*
32.13397+ (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
32.13398+ found several entries for ~A - picking ~S over ~S~:>")
32.13399+ directory recurse name better worse)))
32.13400+ (setf (gethash name h) asd))))))
32.13401+ (maphash #'(lambda (k v) (setf (gethash k registry) v)) h))))
32.13402+ (values))
32.13403+
32.13404+ (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
32.13405+ ;; Record the parameter used to configure the registry
32.13406+ (setf *source-registry-parameter* parameter)
32.13407+ ;; Clear the previous registry database:
32.13408+ (setf *source-registry* (make-hash-table :test 'equal))
32.13409+ ;; Do it!
32.13410+ (compute-source-registry parameter))
32.13411+
32.13412+ ;; Checks an initial variable to see whether the state is initialized
32.13413+ ;; or cleared. In the former case, return current configuration; in
32.13414+ ;; the latter, initialize. ASDF will call this function at the start
32.13415+ ;; of (asdf:find-system) to make sure the source registry is initialized.
32.13416+ ;; However, it will do so *without* a parameter, at which point it
32.13417+ ;; will be too late to provide a parameter to this function, though
32.13418+ ;; you may override the configuration explicitly by calling
32.13419+ ;; initialize-source-registry directly with your parameter.
32.13420+ (defun ensure-source-registry (&optional parameter)
32.13421+ (unless (source-registry-initialized-p)
32.13422+ (initialize-source-registry parameter))
32.13423+ (values))
32.13424+
32.13425+ (defun sysdef-source-registry-search (system)
32.13426+ (ensure-source-registry)
32.13427+ (values (gethash (primary-system-name system) *source-registry*))))
32.13428+
32.13429+
32.13430+;;;; -------------------------------------------------------------------------
32.13431+;;; Internal hacks for backward-compatibility
32.13432+
32.13433+(uiop/package:define-package :asdf/backward-internals
32.13434+ (:recycle :asdf/backward-internals :asdf)
32.13435+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
32.13436+ (:export #:load-sysdef))
32.13437+(in-package :asdf/backward-internals)
32.13438+
32.13439+(with-asdf-deprecation (:style-warning "3.2" :warning "3.4")
32.13440+ (defun load-sysdef (name pathname)
32.13441+ (declare (ignore name pathname))
32.13442+ ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older.
32.13443+ (error "Use asdf:load-asd instead of asdf::load-sysdef")))
32.13444+;;;; -------------------------------------------------------------------------
32.13445+;;; Backward-compatible interfaces
32.13446+
32.13447+(uiop/package:define-package :asdf/backward-interface
32.13448+ (:recycle :asdf/backward-interface :asdf)
32.13449+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
32.13450+ :asdf/component :asdf/system :asdf/system-registry :asdf/operation :asdf/action
32.13451+ :asdf/lisp-action :asdf/plan :asdf/operate
32.13452+ :asdf/find-system :asdf/parse-defsystem :asdf/output-translations :asdf/bundle)
32.13453+ (:export
32.13454+ #:*asdf-verbose*
32.13455+ #:operation-error #:compile-error #:compile-failed #:compile-warned
32.13456+ #:error-component #:error-operation #:traverse
32.13457+ #:component-load-dependencies
32.13458+ #:enable-asdf-binary-locations-compatibility
32.13459+ #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
32.13460+ #:component-property
32.13461+ #:run-shell-command
32.13462+ #:system-definition-pathname #:system-registered-p #:require-system
32.13463+ #:explain
32.13464+ #+ecl #:make-build))
32.13465+(in-package :asdf/backward-interface)
32.13466+
32.13467+;; NB: the warning status of these functions may have to be distinguished later,
32.13468+;; as some get removed faster than the others in client code.
32.13469+(with-asdf-deprecation (:style-warning "3.2" :warning "3.4")
32.13470+
32.13471+ ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp;
32.13472+ ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition
32.13473+ ;; that do not involve ASDF actions.
32.13474+ ;; TODO: find the offenders and stop them.
32.13475+ (progn
32.13476+ (define-condition operation-error (error) ;; Bad, backward-compatible name
32.13477+ ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
32.13478+ ((component :reader error-component :initarg :component)
32.13479+ (operation :reader error-operation :initarg :operation))
32.13480+ (:report (lambda (c s)
32.13481+ (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
32.13482+ (type-of c) (error-operation c) (error-component c)))))
32.13483+ (define-condition compile-error (operation-error) ())
32.13484+ (define-condition compile-failed (compile-error) ())
32.13485+ (define-condition compile-warned (compile-error) ()))
32.13486+
32.13487+ ;; In Quicklisp 2015-05, still used by lisp-executable, staple, repl-utilities, cffi
32.13488+ (defun component-load-dependencies (component) ;; from ASDF 2.000 to 2.26
32.13489+ "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead; or better,
32.13490+define your operations with proper use of SIDEWAY-OPERATION, SELFWARD-OPERATION,
32.13491+or define methods on PREPARE-OP, etc."
32.13492+ ;; Old deprecated name for the same thing. Please update your software.
32.13493+ (component-sideway-dependencies component))
32.13494+
32.13495+ ;; These old interfaces from ASDF1 have never been very meaningful
32.13496+ ;; but are still used in obscure places.
32.13497+ ;; In Quicklisp 2015-05, still used by cl-protobufs and clx.
32.13498+ (defgeneric operation-on-warnings (operation)
32.13499+ (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead."))
32.13500+ (defgeneric operation-on-failure (operation)
32.13501+ (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead."))
32.13502+ (defgeneric (setf operation-on-warnings) (x operation)
32.13503+ (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead."))
32.13504+ (defgeneric (setf operation-on-failure) (x operation)
32.13505+ (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead."))
32.13506+ (progn
32.13507+ (defmethod operation-on-warnings ((o operation))
32.13508+ *compile-file-warnings-behaviour*)
32.13509+ (defmethod operation-on-failure ((o operation))
32.13510+ *compile-file-failure-behaviour*)
32.13511+ (defmethod (setf operation-on-warnings) (x (o operation))
32.13512+ (setf *compile-file-warnings-behaviour* x))
32.13513+ (defmethod (setf operation-on-failure) (x (o operation))
32.13514+ (setf *compile-file-failure-behaviour* x)))
32.13515+
32.13516+ ;; Quicklisp 2015-05: Still used by SLIME's swank-asdf (!), common-lisp-stat,
32.13517+ ;; js-parser, osicat, babel, staple, weblocks, cl-png, plain-odbc, autoproject,
32.13518+ ;; cl-blapack, com.informatimago, cells-gtk3, asdf-dependency-grovel,
32.13519+ ;; cl-glfw, cffi, jwacs, montezuma
32.13520+ (defun system-definition-pathname (x)
32.13521+ ;; As of 2.014.8, we mean to make this function obsolete,
32.13522+ ;; but that won't happen until all clients have been updated.
32.13523+ "DEPRECATED. This function used to expose ASDF internals with subtle
32.13524+differences with respect to user expectations, that have been refactored
32.13525+away since. We recommend you use ASDF:SYSTEM-SOURCE-FILE instead for a
32.13526+mostly compatible replacement that we're supporting, or even
32.13527+ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
32.13528+if that's whay you mean." ;;)
32.13529+ (system-source-file x))
32.13530+
32.13531+ ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2.
32.13532+ ;; It was never officially exposed but some people still used it.
32.13533+ (defgeneric traverse (operation component &key &allow-other-keys)
32.13534+ (:documentation
32.13535+ "DEPRECATED. Use MAKE-PLAN and PLAN-ACTIONS, or REQUIRED-COMPONENTS,
32.13536+or some other supported interface instead.
32.13537+
32.13538+Generate and return a plan for performing OPERATION on COMPONENT.
32.13539+
32.13540+The plan returned is a list of dotted-pairs. Each pair is the CONS
32.13541+of ASDF operation object and a COMPONENT object. The pairs will be
32.13542+processed in order by OPERATE."))
32.13543+ (progn
32.13544+ (define-convenience-action-methods traverse (operation component &key)))
32.13545+ (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
32.13546+ (plan-actions (apply 'make-plan plan-class o c keys)))
32.13547+
32.13548+
32.13549+ ;; ASDF-Binary-Locations compatibility
32.13550+ ;; This remains supported for legacy user, but not recommended for new users.
32.13551+ ;; We suspect there are no more legacy users in 2016.
32.13552+ (defun enable-asdf-binary-locations-compatibility
32.13553+ (&key
32.13554+ (centralize-lisp-binaries nil)
32.13555+ (default-toplevel-directory
32.13556+ ;; Use ".cache/common-lisp/" instead ???
32.13557+ (subpathname (user-homedir-pathname) ".fasls/"))
32.13558+ (include-per-user-information nil)
32.13559+ (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil))
32.13560+ (source-to-target-mappings nil)
32.13561+ (file-types `(,(compile-file-type)
32.13562+ "build-report"
32.13563+ #+clasp (compile-file-type :output-type :object)
32.13564+ #+ecl (compile-file-type :type :object)
32.13565+ #+mkcl (compile-file-type :fasl-p nil)
32.13566+ #+clisp "lib" #+sbcl "cfasl"
32.13567+ #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
32.13568+ "DEPRECATED. Use asdf-output-translations instead."
32.13569+ #+(or clasp clisp ecl mkcl)
32.13570+ (when (null map-all-source-files)
32.13571+ (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
32.13572+ (let* ((patterns (if map-all-source-files (list *wild-file*)
32.13573+ (loop :for type :in file-types
32.13574+ :collect (make-pathname :type type :defaults *wild-file*))))
32.13575+ (destination-directory
32.13576+ (if centralize-lisp-binaries
32.13577+ `(,default-toplevel-directory
32.13578+ ,@(when include-per-user-information
32.13579+ (cdr (pathname-directory (user-homedir-pathname))))
32.13580+ :implementation ,*wild-inferiors*)
32.13581+ `(:root ,*wild-inferiors* :implementation))))
32.13582+ (initialize-output-translations
32.13583+ `(:output-translations
32.13584+ ,@source-to-target-mappings
32.13585+ #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
32.13586+ #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
32.13587+ ,@(loop :for pattern :in patterns
32.13588+ :collect `((:root ,*wild-inferiors* ,pattern)
32.13589+ (,@destination-directory ,pattern)))
32.13590+ (t t)
32.13591+ :ignore-inherited-configuration))))
32.13592+ (progn
32.13593+ (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
32.13594+ (declare (ignore operation-class system args))
32.13595+ (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
32.13596+ (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
32.13597+ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
32.13598+which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
32.13599+and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
32.13600+In case you insist on preserving your previous A-B-L configuration, but
32.13601+do not know how to achieve the same effect with A-O-T, you may use function
32.13602+ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
32.13603+call that function where you would otherwise have loaded and configured A-B-L."))))
32.13604+
32.13605+
32.13606+ ;; run-shell-command from ASDF 2, lightly fixed from ASDF 1, copied from MK-DEFSYSTEM. Die!
32.13607+ (defun run-shell-command (control-string &rest args)
32.13608+ "PLEASE DO NOT USE. This function is not just DEPRECATED, but also dysfunctional.
32.13609+Please use UIOP:RUN-PROGRAM instead."
32.13610+ #-(and ecl os-windows)
32.13611+ (let ((command (apply 'format nil control-string args)))
32.13612+ (asdf-message "; $ ~A~%" command)
32.13613+ (let ((exit-code
32.13614+ (ignore-errors
32.13615+ (nth-value 2 (run-program command :force-shell t :ignore-error-status t
32.13616+ :output *verbose-out*)))))
32.13617+ (typecase exit-code
32.13618+ ((integer 0 255) exit-code)
32.13619+ (t 255))))
32.13620+ #+(and ecl os-windows)
32.13621+ (not-implemented-error "run-shell-command" "for ECL on Windows."))
32.13622+
32.13623+ ;; HOW do we get rid of variables??? With a symbol-macro that issues a warning?
32.13624+ ;; In Quicklisp 2015-05, cl-protobufs still uses it, but that should be fixed in next version.
32.13625+ (progn
32.13626+ (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
32.13627+
32.13628+ ;; Do NOT use in new code. NOT SUPPORTED.
32.13629+ ;; NB: When this goes away, remove the slot PROPERTY in COMPONENT.
32.13630+ ;; In Quicklisp 2014-05, it's still used by yaclml, amazon-ecs, blackthorn-engine, cl-tidy.
32.13631+ ;; See TODO for further cleanups required before to get rid of it.
32.13632+ (defgeneric component-property (component property))
32.13633+ (defgeneric (setf component-property) (new-value component property))
32.13634+
32.13635+ (defmethod component-property ((c component) property)
32.13636+ (cdr (assoc property (slot-value c 'properties) :test #'equal)))
32.13637+
32.13638+ (defmethod (setf component-property) (new-value (c component) property)
32.13639+ (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
32.13640+ (if a
32.13641+ (setf (cdr a) new-value)
32.13642+ (setf (slot-value c 'properties)
32.13643+ (acons property new-value (slot-value c 'properties)))))
32.13644+ new-value)
32.13645+
32.13646+
32.13647+ ;; This method survives from ASDF 1, but really it is superseded by action-description.
32.13648+ (defgeneric explain (operation component)
32.13649+ (:documentation "Display a message describing an action.
32.13650+
32.13651+DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead."))
32.13652+ (progn
32.13653+ (define-convenience-action-methods explain (operation component)))
32.13654+ (defmethod explain ((o operation) (c component))
32.13655+ (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))))
32.13656+
32.13657+(with-asdf-deprecation (:style-warning "3.3")
32.13658+ (defun system-registered-p (name)
32.13659+ "DEPRECATED. Return a generalized boolean that is true if a system of given NAME was registered already.
32.13660+NAME is a system designator, to be normalized by COERCE-NAME.
32.13661+The value returned if true is a pair of a timestamp and a system object."
32.13662+ (if-let (system (registered-system name))
32.13663+ (cons (if-let (primary-system (registered-system (primary-system-name name)))
32.13664+ (component-operation-time 'define-op primary-system))
32.13665+ system)))
32.13666+
32.13667+ (defun require-system (system &rest keys &key &allow-other-keys)
32.13668+ "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the
32.13669+system or its dependencies if it has already been loaded."
32.13670+ (declare (ignore keys))
32.13671+ (unless (component-loaded-p system)
32.13672+ (load-system system))))
32.13673+
32.13674+;;; This function is for backward compatibility with ECL only.
32.13675+#+ecl
32.13676+(with-asdf-deprecation (:style-warning "3.2" :warning "9999")
32.13677+ (defun make-build (system &rest args
32.13678+ &key (monolithic nil) (type :fasl) (move-here nil move-here-p)
32.13679+ prologue-code epilogue-code no-uiop
32.13680+ prefix-lisp-object-files postfix-lisp-object-files extra-object-files
32.13681+ &allow-other-keys)
32.13682+ (let* ((operation (asdf/bundle::select-bundle-operation type monolithic))
32.13683+ (move-here-path (if (and move-here
32.13684+ (typep move-here '(or pathname string)))
32.13685+ (ensure-pathname move-here :namestring :lisp :ensure-directory t)
32.13686+ (system-relative-pathname system "asdf-output/")))
32.13687+ (extra-build-args (remove-plist-keys
32.13688+ '(:monolithic :type :move-here
32.13689+ :prologue-code :epilogue-code :no-uiop
32.13690+ :prefix-lisp-object-files :postfix-lisp-object-files
32.13691+ :extra-object-files)
32.13692+ args))
32.13693+ (build-system (if (subtypep operation 'image-op)
32.13694+ (eval `(defsystem "asdf.make-build"
32.13695+ :class program-system
32.13696+ :source-file nil
32.13697+ :pathname ,(system-source-directory system)
32.13698+ :build-operation ,operation
32.13699+ :build-pathname ,(subpathname move-here-path
32.13700+ (file-namestring (first (output-files operation system))))
32.13701+ :depends-on (,(coerce-name system))
32.13702+ :prologue-code ,prologue-code
32.13703+ :epilogue-code ,epilogue-code
32.13704+ :no-uiop ,no-uiop
32.13705+ :prefix-lisp-object-files ,prefix-lisp-object-files
32.13706+ :postfix-lisp-object-files ,postfix-lisp-object-files
32.13707+ :extra-object-files ,extra-object-files
32.13708+ :extra-build-args ,extra-build-args))
32.13709+ system))
32.13710+ (files (output-files operation build-system)))
32.13711+ (operate operation build-system)
32.13712+ (if (or move-here
32.13713+ (and (null move-here-p) (member operation '(program-op image-op))))
32.13714+ (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
32.13715+ :for f :in files
32.13716+ :for new-f = (make-pathname :name (pathname-name f)
32.13717+ :type (pathname-type f)
32.13718+ :defaults dest-path)
32.13719+ :do (rename-file-overwriting-target f new-f)
32.13720+ :collect new-f)
32.13721+ files))))
32.13722+;;;; ---------------------------------------------------------------------------
32.13723+;;;; Handle ASDF package upgrade, including implementation-dependent magic.
32.13724+
32.13725+(uiop/package:define-package :asdf/interface
32.13726+ (:nicknames :asdf :asdf-utilities)
32.13727+ (:recycle :asdf/interface :asdf)
32.13728+ (:unintern
32.13729+ #:loaded-systems ; makes for annoying SLIME completion
32.13730+ #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL
32.13731+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
32.13732+ :asdf/component :asdf/system :asdf/system-registry :asdf/find-component
32.13733+ :asdf/operation :asdf/action :asdf/lisp-action
32.13734+ :asdf/output-translations :asdf/source-registry
32.13735+ :asdf/forcing :asdf/plan :asdf/operate :asdf/find-system :asdf/parse-defsystem
32.13736+ :asdf/bundle :asdf/concatenate-source
32.13737+ :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system)
32.13738+ ;; Note: (1) we are NOT automatically reexporting everything from previous packages.
32.13739+ ;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
32.13740+ (:export
32.13741+ #:defsystem #:find-system #:load-asd #:locate-system #:coerce-name
32.13742+ #:primary-system-name #:primary-system-p
32.13743+ #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
32.13744+ #:system-definition-pathname
32.13745+ #:search-for-system-definition #:find-component #:component-find-path
32.13746+ #:compile-system #:load-system #:load-systems #:load-systems*
32.13747+ #:require-system #:test-system #:clear-system
32.13748+ #:operation #:make-operation #:find-operation
32.13749+ #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation
32.13750+ #:non-propagating-operation
32.13751+ #:build-op #:make
32.13752+ #:load-op #:prepare-op #:compile-op
32.13753+ #:prepare-source-op #:load-source-op #:test-op #:define-op
32.13754+ #:feature #:version #:version-satisfies #:upgrade-asdf
32.13755+ #:implementation-identifier #:implementation-type #:hostname
32.13756+ #:component-depends-on ; backward-compatible name rather than action-depends-on
32.13757+ #:input-files #:additional-input-files
32.13758+ #:output-files #:output-file #:perform #:perform-with-restarts
32.13759+ #:operation-done-p #:explain #:action-description #:component-sideway-dependencies
32.13760+ #:needed-in-image-p
32.13761+ #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
32.13762+ #:program-system
32.13763+ #:basic-compile-bundle-op #:prepare-bundle-op
32.13764+ #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
32.13765+ #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op
32.13766+ #:monolithic-lib-op #:monolithic-dll-op #:monolithic-deliver-asd-op
32.13767+ #:concatenate-source-op
32.13768+ #:load-concatenated-source-op
32.13769+ #:compile-concatenated-source-op
32.13770+ #:load-compiled-concatenated-source-op
32.13771+ #:monolithic-concatenate-source-op
32.13772+ #:monolithic-load-concatenated-source-op
32.13773+ #:monolithic-compile-concatenated-source-op
32.13774+ #:monolithic-load-compiled-concatenated-source-op
32.13775+ #:operation-monolithic-p
32.13776+ #:required-components
32.13777+ #:component-loaded-p
32.13778+ #:component #:parent-component #:child-component #:system #:module
32.13779+ #:file-component #:source-file #:c-source-file #:java-source-file
32.13780+ #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
32.13781+ #:static-file #:doc-file #:html-file
32.13782+ #:file-type #:source-file-type
32.13783+ #:register-preloaded-system #:sysdef-preloaded-system-search
32.13784+ #:register-immutable-system #:sysdef-immutable-system-search
32.13785+ #:package-inferred-system #:register-system-packages
32.13786+ #:component-children
32.13787+ #:component-children-by-name
32.13788+ #:component-pathname
32.13789+ #:component-relative-pathname
32.13790+ #:component-name
32.13791+ #:component-version
32.13792+ #:component-parent
32.13793+ #:component-system
32.13794+ #:component-encoding
32.13795+ #:component-external-format
32.13796+ #:system-description
32.13797+ #:system-long-description
32.13798+ #:system-author
32.13799+ #:system-maintainer
32.13800+ #:system-license
32.13801+ #:system-licence
32.13802+ #:system-version
32.13803+ #:system-source-file
32.13804+ #:system-source-directory
32.13805+ #:system-relative-pathname
32.13806+ #:system-homepage
32.13807+ #:system-mailto
32.13808+ #:system-bug-tracker
32.13809+ #:system-long-name
32.13810+ #:system-source-control
32.13811+ #:map-systems
32.13812+ #:system-defsystem-depends-on
32.13813+ #:system-depends-on
32.13814+ #:system-weakly-depends-on
32.13815+ #:*system-definition-search-functions* ; variables
32.13816+ #:*central-registry*
32.13817+ #:*compile-file-warnings-behaviour*
32.13818+ #:*compile-file-failure-behaviour*
32.13819+ #:*resolve-symlinks*
32.13820+ #:*verbose-out*
32.13821+ #:asdf-version
32.13822+ #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
32.13823+ #:compile-warned-warning #:compile-failed-warning
32.13824+ #:error-name
32.13825+ #:error-pathname
32.13826+ #:load-system-definition-error
32.13827+ #:error-component #:error-operation
32.13828+ #:system-definition-error
32.13829+ #:missing-component
32.13830+ #:missing-component-of-version
32.13831+ #:missing-dependency
32.13832+ #:missing-dependency-of-version
32.13833+ #:circular-dependency ; errors
32.13834+ #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name #:system-out-of-date
32.13835+ #:package-inferred-system-missing-package-error
32.13836+ #:operation-definition-warning #:operation-definition-error
32.13837+ #:try-recompiling ; restarts
32.13838+ #:retry
32.13839+ #:accept
32.13840+ #:coerce-entry-to-directory
32.13841+ #:remove-entry-from-registry
32.13842+ #:clear-configuration-and-retry
32.13843+ #:*encoding-detection-hook*
32.13844+ #:*encoding-external-format-hook*
32.13845+ #:*default-encoding*
32.13846+ #:*utf-8-external-format*
32.13847+ #:clear-configuration
32.13848+ #:*output-translations-parameter*
32.13849+ #:initialize-output-translations
32.13850+ #:disable-output-translations
32.13851+ #:clear-output-translations
32.13852+ #:ensure-output-translations
32.13853+ #:apply-output-translations
32.13854+ #:compile-file*
32.13855+ #:compile-file-pathname*
32.13856+ #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check
32.13857+ #:enable-asdf-binary-locations-compatibility
32.13858+ #:*default-source-registries*
32.13859+ #:*source-registry-parameter*
32.13860+ #:initialize-source-registry
32.13861+ #:compute-source-registry
32.13862+ #:clear-source-registry
32.13863+ #:ensure-source-registry
32.13864+ #:process-source-registry
32.13865+ #:registered-system #:registered-systems #:already-loaded-systems
32.13866+ #:resolve-location
32.13867+ #:asdf-message
32.13868+ #:*user-cache*
32.13869+ #:user-output-translations-pathname
32.13870+ #:system-output-translations-pathname
32.13871+ #:user-output-translations-directory-pathname
32.13872+ #:system-output-translations-directory-pathname
32.13873+ #:user-source-registry
32.13874+ #:system-source-registry
32.13875+ #:user-source-registry-directory
32.13876+ #:system-source-registry-directory
32.13877+
32.13878+ ;; The symbols below are all DEPRECATED, do not use. To be removed in a further release.
32.13879+ #:*asdf-verbose* #:run-shell-command
32.13880+ #:component-load-dependencies #:system-registered-p #:package-system
32.13881+ #+ecl #:make-build
32.13882+ #:operation-on-warnings #:operation-on-failure #:operation-error
32.13883+ #:compile-failed #:compile-warned #:compile-error
32.13884+ #:module-components #:component-property #:traverse))
32.13885+;;;; ---------------------------------------------------------------------------
32.13886+;;;; ASDF-USER, where the action happens.
32.13887+
32.13888+(uiop/package:define-package :asdf/user
32.13889+ (:nicknames :asdf-user)
32.13890+ ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below.
32.13891+ ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop.
32.13892+ ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo.
32.13893+ ;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package
32.13894+ ;; that only :use's :cl and :asdf
32.13895+ (:use :uiop/common-lisp :uiop :asdf/interface))
32.13896+;;;; -----------------------------------------------------------------------
32.13897+;;;; ASDF Footer: last words and cleanup
32.13898+
32.13899+(uiop/package:define-package :asdf/footer
32.13900+ (:recycle :asdf/footer :asdf)
32.13901+ (:use :uiop/common-lisp :uiop
32.13902+ :asdf/system ;; used by ECL
32.13903+ :asdf/upgrade :asdf/system-registry :asdf/operate :asdf/bundle)
32.13904+ ;; Happily, all those implementations all have the same module-provider hook interface.
32.13905+ #+(or abcl clasp cmucl clozure ecl mezzano mkcl sbcl)
32.13906+ (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext #+mezzano :sys.int
32.13907+ #:*module-provider-functions*
32.13908+ #+ecl #:*load-hooks*)
32.13909+ #+(or clasp mkcl) (:import-from :si #:*load-hooks*))
32.13910+
32.13911+(in-package :asdf/footer)
32.13912+
32.13913+;;;; Register ASDF itself and all its subsystems as preloaded.
32.13914+(with-upgradability ()
32.13915+ (dolist (s '("asdf" "asdf-package-system"))
32.13916+ ;; Don't bother with these system names, no one relies on them anymore:
32.13917+ ;; "asdf-utils" "asdf-bundle" "asdf-driver" "asdf-defsystem"
32.13918+ (register-preloaded-system s :version *asdf-version*))
32.13919+ (register-preloaded-system "uiop" :version *uiop-version*))
32.13920+
32.13921+;;;; Ensure that the version slot on the registered preloaded systems are
32.13922+;;;; correct, by CLEARing the system. However, we do not CLEAR-SYSTEM
32.13923+;;;; unconditionally. This is because it's possible the user has upgraded the
32.13924+;;;; systems using ASDF itself, meaning that the registered systems have real
32.13925+;;;; data from the file system that we want to preserve instead of blasting
32.13926+;;;; away and replacing with a blank preloaded system.
32.13927+(with-upgradability ()
32.13928+ (unless (equal (system-version (registered-system "asdf")) (asdf-version))
32.13929+ (clear-system "asdf"))
32.13930+ ;; 3.1.2 is the last version where asdf-package-system was a separate system.
32.13931+ (when (version< "3.1.2" (system-version (registered-system "asdf-package-system")))
32.13932+ (clear-system "asdf-package-system"))
32.13933+ (unless (equal (system-version (registered-system "uiop")) *uiop-version*)
32.13934+ (clear-system "uiop")))
32.13935+
32.13936+;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
32.13937+#+(or abcl clasp clisp clozure cmucl ecl mezzano mkcl sbcl)
32.13938+(with-upgradability ()
32.13939+ ;; Hook into CL:REQUIRE.
32.13940+ #-clisp (pushnew 'module-provide-asdf *module-provider-functions*)
32.13941+ #+clisp (if-let (x (find-symbol* '#:*module-provider-functions* :custom nil))
32.13942+ (eval `(pushnew 'module-provide-asdf ,x)))
32.13943+
32.13944+ #+(or clasp ecl mkcl)
32.13945+ (progn
32.13946+ (pushnew '("fasb" . si::load-binary) *load-hooks* :test 'equal :key 'car)
32.13947+
32.13948+ #+os-windows
32.13949+ (unless (assoc "asd" *load-hooks* :test 'equal)
32.13950+ (appendf *load-hooks* '(("asd" . si::load-source))))
32.13951+
32.13952+ ;; Wrap module provider functions in an idempotent, upgrade friendly way
32.13953+ (defvar *wrapped-module-provider* (make-hash-table))
32.13954+ (setf (gethash 'module-provide-asdf *wrapped-module-provider*) 'module-provide-asdf)
32.13955+ (defun wrap-module-provider (provider name)
32.13956+ (let ((results (multiple-value-list (funcall provider name))))
32.13957+ (when (first results) (register-preloaded-system (coerce-name name)))
32.13958+ (values-list results)))
32.13959+ (defun wrap-module-provider-function (provider)
32.13960+ (ensure-gethash provider *wrapped-module-provider*
32.13961+ (constantly
32.13962+ #'(lambda (module-name)
32.13963+ (wrap-module-provider provider module-name)))))
32.13964+ (setf *module-provider-functions*
32.13965+ (mapcar #'wrap-module-provider-function *module-provider-functions*))))
32.13966+
32.13967+#+cmucl ;; Hook into the CMUCL herald.
32.13968+(with-upgradability ()
32.13969+ (defun herald-asdf (stream)
32.13970+ (format stream " ASDF ~A" (asdf-version)))
32.13971+ (setf (getf ext:*herald-items* :asdf) '(herald-asdf)))
32.13972+
32.13973+
32.13974+;;;; Done!
32.13975+(with-upgradability ()
32.13976+ #+allegro ;; restore *w-o-n-r-c* setting as saved in uiop/common-lisp
32.13977+ (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
32.13978+ (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*))
32.13979+
32.13980+ ;; Advertise the features we provide.
32.13981+ (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf3.3)) (pushnew f *features*))
32.13982+
32.13983+ ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users.
32.13984+ (provide "asdf") (provide "ASDF")
32.13985+
32.13986+ ;; Finally, call a function that will cleanup in case this is an upgrade of an older ASDF.
32.13987+ (cleanup-upgraded-asdf))
32.13988+
32.13989+(when *load-verbose*
32.13990+ (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
33.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
33.2+++ b/tools/build-cli.lisp Mon Jun 05 19:59:26 2023 -0400
33.3@@ -0,0 +1,10 @@
33.4+(load "tools/prepare-image")
33.5+(defvar *output* "demo")
33.6+#+sbcl
33.7+(sb-ext:save-lisp-and-die *output*
33.8+ :purify t
33.9+ :toplevel 'screenshotbot-sdk:main
33.10+ :executable t)
33.11+#+ccl
33.12+(ccl:save-application *output*
33.13+ :toplevel-function 'screenshotbot-sdk:main)
34.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
34.2+++ b/tools/build-image.lisp Mon Jun 05 19:59:26 2023 -0400
34.3@@ -0,0 +1,51 @@
34.4+(in-package :cl-user)
34.5+
34.6+(load "tools/prepare-image.lisp")
34.7+
34.8+(defvar *image-load-hook-contents* (uiop:read-file-string "tools/init.lisp"))
34.9+(defvar *hook-loaded-p* nil)
34.10+
34.11+(defun image-load-hook ()
34.12+ ;; On MacOS, the TMPDIR variable can change between sessions.
34.13+ (uiop:setup-temporary-directory)
34.14+
34.15+ #-sbcl
34.16+ (log4cl::init-hook)
34.17+
34.18+ ;; If we used this image to deliver another image, we don't
34.19+ ;; want to load the same hook twice
34.20+ (unless *hook-loaded-p*
34.21+ (load (make-string-input-stream *image-load-hook-contents*))
34.22+ (setf *hook-loaded-p* t)))
34.23+
34.24+(compile 'image-load-hook)
34.25+
34.26+#+sbcl
34.27+(pushnew 'image-load-hook sb-ext:*init-hooks*)
34.28+
34.29+(format t "Got command line arguments: ~S" (uiop:raw-command-line-arguments))
34.30+
34.31+#-sbcl
34.32+(log4cl::save-hook)
34.33+
34.34+#+sbcl
34.35+(sb-ext:save-lisp-and-die
34.36+ (namestring
34.37+ (make-pathname
34.38+ #+win32 :type #+win32 "exe"
34.39+ :defaults #P"build/sbcl-console"))
34.40+ :executable t)
34.41+
34.42+#+ccl
34.43+(defun ccl-toplevel-function ()
34.44+ (image-load-hook)
34.45+ (let ((file (cadr ccl:*command-line-argument-list*)))
34.46+ (if file
34.47+ (load file :verbose t)
34.48+ (loop
34.49+ (print (eval (read)))))))
34.50+
34.51+
34.52+#+ccl
34.53+(ccl:save-application "build/ccl-console"
34.54+ :toplevel-function 'ccl-toplevel-function)
35.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
35.2+++ b/tools/init.lisp Mon Jun 05 19:59:26 2023 -0400
35.3@@ -0,0 +1,8 @@
35.4+(defvar *demo-config*
35.5+ '(:service "weather"
35.6+ :host "localhost"
35.7+ :port 8888
35.8+ :client (:name "guest"
35.9+ :type "docker"
35.10+ :mode "release"
35.11+ :theme "dark")))
36.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
36.2+++ b/tools/prepare-image.lisp Mon Jun 05 19:59:26 2023 -0400
36.3@@ -0,0 +1,159 @@
36.4+(in-package :cl-user)
36.5+
36.6+;; For SBCL, if you don't have SBCL_HOME set, then we won't be able to require this later.
36.7+#+sbcl
36.8+(require 'sb-introspect)
36.9+
36.10+(when (probe-file "scripts/asdf.lisp")
36.11+ (format t "Compiling asdf..~%")
36.12+ (let ((output (compile-file "scripts/asdf.lisp" :verbose nil :print nil)))
36.13+ (load output))
36.14+ (provide "asdf"))
36.15+
36.16+(require "asdf")
36.17+
36.18+#+sbcl
36.19+(require "sb-sprof")
36.20+
36.21+#+nil
36.22+(push (pathname (format nil "~a/local-projects/poiu/" (namestring (uiop:getcwd))))
36.23+ asdf:*central-registry*)
36.24+
36.25+(defvar *asdf-root-guesser* nil)
36.26+
36.27+(defparameter *cwd* (merge-pathnames
36.28+ *default-pathname-defaults*
36.29+ (uiop:getcwd)))
36.30+
36.31+(defun update-output-translations (root)
36.32+ "This function is called dynamically from deliver-utils/common.lisp!"
36.33+ (asdf:initialize-output-translations
36.34+ `(:output-translations
36.35+ :inherit-configuration
36.36+ (,(namestring root)
36.37+ ,(format nil "~abuild/asdf-cache/~a/" root
36.38+ (uiop:implementation-identifier))))))
36.39+
36.40+(update-output-translations *cwd*)
36.41+
36.42+#+sbcl
36.43+(progn
36.44+ (require :sb-rotate-byte)
36.45+ (require :sb-cltl2)
36.46+ (asdf:register-preloaded-system :sb-rotate-byte)
36.47+ (asdf:register-preloaded-system :sb-cltl2))
36.48+
36.49+(defun %read-version (file)
36.50+ (let ((key "version: "))
36.51+ (loop for line in (uiop:read-file-lines file)
36.52+ if (string= key line :end2 (length key))
36.53+ return (subseq line (length key)))))
36.54+
36.55+(defun init-quicklisp ()
36.56+ (let ((version (%read-version "quicklisp/dists/quicklisp/distinfo.txt")))
36.57+ (let ((quicklisp-loc (ensure-directories-exist
36.58+ (merge-pathnames
36.59+ (format nil "build/quicklisp/~a/" version)
36.60+ *cwd*)))
36.61+ (src (merge-pathnames
36.62+ "quicklisp/"
36.63+ *cwd*)))
36.64+ (flet ((safe-copy-file (path &optional (dest path))
36.65+ (let ((src (merge-pathnames
36.66+ path
36.67+ "quicklisp/"))
36.68+ (dest (merge-pathnames
36.69+ dest
36.70+ quicklisp-loc)))
36.71+ (format t "Copying: ~a to ~a~%" src dest)
36.72+
36.73+ (when (equal src dest)
36.74+ (error "Trying to overwrite the same file"))
36.75+ (unless (uiop:file-exists-p dest)
36.76+ (uiop:copy-file
36.77+ src
36.78+ (ensure-directories-exist
36.79+ dest))))))
36.80+ (loop for name in
36.81+ (append (directory
36.82+ (merge-pathnames
36.83+ "quicklisp/quicklisp/*.lisp"
36.84+ *cwd*))
36.85+ (directory
36.86+ (merge-pathnames
36.87+ "quicklisp/quicklisp/*.asd"
36.88+ *cwd*)))
36.89+ do (safe-copy-file name
36.90+ (format nil "quicklisp/~a.~a"
36.91+ (pathname-name name)
36.92+ (pathname-type name))))
36.93+ (loop for name in (directory
36.94+ (merge-pathnames
36.95+ "quicklisp/*.lisp"
36.96+ *cwd*))
36.97+ do (safe-copy-file name
36.98+ (format nil "~a.lisp"
36.99+ (pathname-name name))))
36.100+ (safe-copy-file "setup.lisp")
36.101+ (safe-copy-file "quicklisp/version.txt")
36.102+ (safe-copy-file "dists/quicklisp/distinfo.txt")
36.103+ (safe-copy-file "dists/quicklisp/enabled.txt")
36.104+ (safe-copy-file "dists/quicklisp/preference.txt"))
36.105+ (load (merge-pathnames
36.106+ "setup.lisp"
36.107+ quicklisp-loc)))))
36.108+
36.109+(init-quicklisp)
36.110+
36.111+#+nil
36.112+(ql:update-all-dists :prompt nil)
36.113+
36.114+(pushnew :demo *features*)
36.115+
36.116+(defun update-project-directories (cwd)
36.117+ (flet ((push-src-dir (name)
36.118+ (let ((dir (pathname (format nil "~a~a/" cwd name))))
36.119+ (when (probe-file dir)
36.120+ (push dir ql:*local-project-directories*)))))
36.121+ #-demo
36.122+ (push-src-dir "local-projects")
36.123+ (push-src-dir "src")
36.124+ (push-src-dir "third-party")
36.125+ (push-src-dir "lisp")))
36.126+
36.127+
36.128+(defun update-root (cwd)
36.129+ (update-output-translations cwd)
36.130+ (update-project-directories cwd))
36.131+
36.132+(update-project-directories *cwd*)
36.133+
36.134+(defun maybe-asdf-prepare ()
36.135+ (when *asdf-root-guesser*
36.136+ (update-root (funcall *asdf-root-guesser*))))
36.137+
36.138+(compile 'maybe-asdf-prepare)
36.139+
36.140+(defun unprepare-asdf (root-guesser)
36.141+ "This function is called dynamically from deliver-utils/common.lisp!"
36.142+ (setf *asdf-root-guesser* root-guesser))
36.143+
36.144+(defun maybe-configure-proxy ()
36.145+ (let ((proxy (uiop:getenv "HTTP_PROXY")))
36.146+ (when (and proxy (> (length proxy) 0))
36.147+ (setf ql:*proxy-url* proxy))))
36.148+
36.149+(maybe-configure-proxy)
36.150+
36.151+
36.152+(ql:quickload "log4cl")
36.153+(ql:quickload "prove-asdf")
36.154+
36.155+(log:info "*local-project-directories: ~S" ql:*local-project-directories*)
36.156+
36.157+;; (ql:quickload :cl-ppcre)
36.158+;; make sure we have build asd
36.159+#+nil
36.160+(push (pathname (format nil "~a/build-utils/" *cwd*))
36.161+ asdf:*central-registry*)
36.162+(ql:register-local-projects)
