Changeset 16074

May 9, 2014, 11:18:28 PM (6 years ago)

Upgrade bundled ASDF to ASDF 3.1.2.

1 edited


  • trunk/source/tools/asdf.lisp

    r15962 r16074  
    1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 3.0.3: Another System Definition Facility.
     1;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
     2;;; This is ASDF 3.1.2: Another System Definition Facility.
    44;;; Feedback, bug reports, and patches are all welcome:
    2020;;;  Monday; July 13, 2009)
    22 ;;; Copyright (c) 2001-2012 Daniel Barlow and contributors
     22;;; Copyright (c) 2001-2014 Daniel Barlow and contributors
    2424;;; Permission is hereby granted, free of charge, to any person obtaining
    5353(eval-when (:load-toplevel :compile-toplevel :execute)
    54   (declaim (optimize (speed 1) (safety 3) (debug 3)))
    5554  (setf ext:*gc-verbose* nil))
    57 #+(or abcl clisp clozure cmu ecl xcl) ;; punt on hard package upgrade on those implementations
     56;;; pre 1.3.0 ABCL versions do not support the bundle-op on Mac OS X
     58(eval-when (:load-toplevel :compile-toplevel :execute)
     59  (unless (and (member :darwin *features*)
     60               (second (third (sys::arglist 'directory))))
     61    (push :abcl-bundle-op-supported *features*)))
     63;; Punt on hard package upgrade: from ASDF1 always, and even from ASDF2 on most implementations.
    5864(eval-when (:load-toplevel :compile-toplevel :execute)
    5965  (unless (member :asdf3 *features*)
    7278           (away (format nil "~A-~A" :asdf existing-version)))
    7379      (when (and existing-version
    74                  (< existing-version-number 2.27))
     80                 (< existing-version-number
     81                    #+(or allegro clisp lispworks sbcl) 2.0
     82                    #-(or allegro clisp lispworks sbcl) 2.27))
    7583        (rename-package :asdf away)
    7684        (when *load-verbose*
    7785          (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
    7986;;;; ---------------------------------------------------------------------------
    8087;;;; Handle ASDF package upgrade, including implementation-dependent magic.
    563570            (t
    564571             (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
    566573  (defun recycle-symbol (name recycle exported)
    567574    ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
    616623             (when intern
    617624               (intern* name package))))))))
    618   (declaim (ftype function ensure-exported))
     625  (declaim (ftype (function (t t t &optional t) t) ensure-exported))
    619626  (defun ensure-exported-to-user (name symbol to-package &optional recycle)
    620627    (check-type name string)
    657664                                recycle mix reexport
    658665                                unintern)
    659     #+(or gcl2.6 genera) (declare (ignore documentation))
     666    #+genera (declare (ignore documentation))
    660667    (let* ((package-name (string name))
    661668           (nicknames (mapcar #'string nicknames))
    679686           (inherited (make-hash-table :test 'equal)))
    680687      (when-package-fishiness (record-fishy package-name))
    681       #-(or gcl2.6 genera)
     688      #-genera
    682689      (when documentation (setf (documentation package t) documentation))
    683690      (loop :for p :in (set-difference (package-use-list package) (append mix use))
    759766      :for (kw . args) :in clauses
    760767      :when (eq kw :nicknames) :append args :into nicknames :else
    761         :when (eq kw :documentation)
    762           :do (cond
    763                 (documentation (error "define-package: can't define documentation twice"))
    764                 ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
    765                 (t (setf documentation (car args)))) :else
     768      :when (eq kw :documentation)
     769        :do (cond
     770              (documentation (error "define-package: can't define documentation twice"))
     771              ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
     772              (t (setf documentation (car args)))) :else
    766773      :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
    767         :when (eq kw :shadow) :append args :into shadow :else
    768           :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
    769             :when (eq kw :import-from) :collect args :into import-from :else
    770               :when (eq kw :export) :append args :into export :else
    771                 :when (eq kw :intern) :append args :into intern :else
    772                   :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
    773                     :when (eq kw :mix) :append args :into mix :else
    774                       :when (eq kw :reexport) :append args :into reexport :else
    775                         :when (eq kw :unintern) :append args :into unintern :else
    776                           :do (error "unrecognized define-package keyword ~S" kw)
     774      :when (eq kw :shadow) :append args :into shadow :else
     775      :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
     776      :when (eq kw :import-from) :collect args :into import-from :else
     777      :when (eq kw :export) :append args :into export :else
     778      :when (eq kw :intern) :append args :into intern :else
     779      :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
     780      :when (eq kw :mix) :append args :into mix :else
     781      :when (eq kw :reexport) :append args :into reexport :else
     782      :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
     783        :and :do (setf use-p t) :else
     784      :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
     785        :and :do (setf use-p t) :else
     786      :when (eq kw :unintern) :append args :into unintern :else
     787        :do (error "unrecognized define-package keyword ~S" kw)
    777788      :finally (return `(,package
    778789                         :nicknames ,nicknames :documentation ,documentation
    785796(defmacro define-package (package &rest clauses)
    786   "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form 
     797  "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
    787798\(KEYWORD . ARGS\).
    788799DEFINE-PACKAGE supports the following keywords:
    798809created again. In short, except for special cases, always make it the first
    799810package on the list if the list is not empty.
    800 MIX -- Takes a list of package designators.  MIX behaves like 
     811MIX -- Takes a list of package designators.  MIX behaves like
    801812\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
    802813resolve conflicts in favor of the first found symbol.  It may still yield
    803 an error if there is a conflict with an explicitly :SHADOWING-IMPORT-FROM symbol.
     814an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
    804815REEXPORT -- Takes a list of package designators.  For each package, p, in the list,
    805816export symbols with the same name as those exported from p.  Note that in the case
    809820          `(apply 'ensure-package ',(parse-define-package-form package clauses))))
    810821    `(progn
    811        #+clisp
    812        (eval-when (:compile-toplevel :load-toplevel :execute)
    813          ,ensure-form)
    814        #+(or clisp ecl gcl) (defpackage ,package (:use))
     822       #+(or ecl gcl mkcl) (defpackage ,package (:use))
    815823       (eval-when (:compile-toplevel :load-toplevel :execute)
    816824         ,ensure-form))))
    824832  (setf excl::*autoload-package-name-alist*
    825833        (remove "asdf" excl::*autoload-package-name-alist*
    826                 :test 'equalp :key 'car))
    827   #+gcl
    828   ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff,
    829   ;; but can run ASDF 2.011. GCL 2.6 has even more issues.
    830   (cond
    831     ((or (< system::*gcl-major-version* 2)
    832          (and (= system::*gcl-major-version* 2)
    833               (< system::*gcl-minor-version* 6)))
    834      (error "GCL 2.6 or later required to use ASDF"))
    835     ((and (= system::*gcl-major-version* 2)
    836           (= system::*gcl-minor-version* 6))
    837      (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
    838      (pushnew :gcl2.6 *features*))
    839     (t
    840      (pushnew :gcl2.7 *features*))))
     834                :test 'equalp :key 'car)))
    842836;; Compatibility with whoever calls asdf/package
    861855   #:logical-pathname #:translate-logical-pathname
    862856   #:make-broadcast-stream #:file-namestring)
    863   #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
    864   #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
    865857  #+genera (:shadowing-import-from :scl #:boolean)
    866858  #+genera (:export #:boolean #:ensure-directories-exist)
    876868;;;; Early meta-level tweaks
    878 #+(or abcl allegro clisp cmu ecl mkcl clozure lispworks sbcl scl)
     870#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl)
    879871(eval-when (:load-toplevel :compile-toplevel :execute)
    880872  ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
    926918  (unless (use-ecl-byte-compiler-p) (require :cmp)))
    928 #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
    929921(eval-when (:load-toplevel :compile-toplevel :execute)
    930922  (unless (member :ansi-cl *features*)
    931923    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
    932924  (setf compiler::*compiler-default-type* (pathname "")
    933         compiler::*lsp-ext* ""))
    935 #+gcl2.6
    936 (eval-when (:compile-toplevel :load-toplevel :execute)
    937   (shadow 'type-of :uiop/common-lisp)
    938   (shadowing-import 'system:*load-pathname* :uiop/common-lisp))
    940 #+gcl2.6
    941 (eval-when (:compile-toplevel :load-toplevel :execute)
    942   (export 'type-of :uiop/common-lisp)
    943   (export 'system:*load-pathname* :uiop/common-lisp))
    945 #+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
    946 (eval-when (:load-toplevel :compile-toplevel :execute)
    947   (defvar *gcl2.6* t)
    948   (deftype logical-pathname () nil)
    949   (defun type-of (x) (class-name (class-of x)))
    950   (defun wild-pathname-p (path) (declare (ignore path)) nil)
    951   (defun translate-logical-pathname (x) x)
    952   (defvar *compile-file-pathname* nil)
    953   (defun pathname-match-p (in-pathname wild-pathname)
    954     (declare (ignore in-wildname wild-wildname)) nil)
    955   (defun translate-pathname (source from-wildname to-wildname &key)
    956     (declare (ignore from-wildname to-wildname)) source)
    957   (defun %print-unreadable-object (object stream type identity thunk)
    958     (format stream "#<~@[~S ~]" (when type (type-of object)))
    959     (funcall thunk)
    960     (format stream "~@[ ~X~]>" (when identity (system:address object))))
    961   (defmacro with-standard-io-syntax (&body body)
    962     `(progn ,@body))
    963   (defmacro with-compilation-unit (options &body body)
    964     (declare (ignore options)) `(progn ,@body))
    965   (defmacro print-unreadable-object ((object stream &key type identity) &body body)
    966     `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
    967   (defun ensure-directories-exist (path)
    968     (lisp:system (format nil "mkdir -p ~S"
    969                          (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
     925        compiler::*lsp-ext* "")
     926  #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later.
     927            (cond
     928              #+gcl
     929              ((or (< system::*gcl-major-version* 2)
     930                   (and (= system::*gcl-major-version* 2)
     931                        (< system::*gcl-minor-version* 7)))
     932               '(error "GCL 2.7 or later required to use ASDF")))))
     933      (eval code)
     934      code))
    1016981call FROB with the match and a function that emits a string in the output.
    1017982Return a string made of the parts not omitted or emitted by FROB."
    1018     (declare (optimize (speed 0) (safety 3) (debug 3)))
     983    (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3)))
    1019984    (let ((length (length string)) (stream nil))
    1020985      (labels ((emit-string (x &optional (start 0) (end (length x)))
    10501015  (defmacro compatfmt (format)
    10511016    #+(or gcl genera)
    1052     (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
     1017    (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>")))
    10531018    #-(or gcl genera) format))
    10541019;;;; -------------------------------------------------------------------------
    10671032   ;; magic helper to define debugging functions:
    10681033   #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
    1069    #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
    1070    #:if-let ;; basic flow control
     1034   #:with-upgradability ;; (un)defining functions in an upgrade-friendly way
     1035   #:undefine-function #:undefine-functions #:defun* #:defgeneric*
     1036   #:nest #:if-let ;; basic flow control
    10711037   #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
    10721038   #:remove-plist-keys #:remove-plist-key ;; plists
    10771043   #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
    10781044   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
    1079    #:find-class* ;; CLOS
     1045   #:coerce-class ;; CLOS
    10801046   #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
    10811047   #:earlier-stamp #:stamps-earliest #:earliest-stamp
    10991065    (cond
    11001066      ((symbolp function-spec)
     1067       ;; undefining the previous function is the portable way
     1068       ;; of overriding any incompatible previous gf,
     1069       ;; but CLISP needs extra help with getting rid of previous methods.
    11011070       #+clisp
    11021071       (let ((f (and (fboundp function-spec) (fdefinition function-spec))))
    11071076      ((and (consp function-spec) (eq (car function-spec) 'setf)
    11081077            (consp (cdr function-spec)) (null (cddr function-spec)))
    1109        #-gcl2.6 (fmakunbound function-spec))
     1078       (fmakunbound function-spec))
    11101079      (t (error "bad function spec ~S" function-spec))))
    11111080  (defun undefine-functions (function-spec-list)
    11201089              (declare (ignorable supersede))
    11211090              `(progn
    1122                  ;; undefining the previous function is the portable way
    1123                  ;; of overriding any incompatible previous gf, except on CLISP.
    11241091                 ;; We usually try to do it only for the functions that need it,
    1125                  ;; which happens in asdf/upgrade - however, for ECL, we need this hammer
    1126                  ;; (which causes issues in clisp)
    1127                  ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t)
     1092                 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
     1093                 ,@(when (or supersede #+ecl t)
    11281094                     `((undefine-function ',name)))
    1129                  #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
    11301095                 ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
    11311096                     `((declaim (notinline ,name))))
    11341099    (defdef defun* defun))
    11351100  (defmacro with-upgradability ((&optional) &body body)
     1101    "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
     1102to also declare the functions NOTINLINE and to accept a wrapping the function name
     1103specification into a list with keyword argument SUPERSEDE (which defaults to T if the name
     1104is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION
     1105to supersede any previous definition."
    11361106    `(eval-when (:compile-toplevel :load-toplevel :execute)
    11371107       ,@(loop :for form :in body :collect
    11401110                     (case car
    11411111                       ((defun) `(defun* ,@cdr))
    1142                        ((defgeneric)
    1143                         (unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr))))
    1144                           `(defgeneric* ,@cdr)))
     1112                       ((defgeneric) `(defgeneric* ,@cdr))
    11451113                       (otherwise form)))
    11461114                   form)))))
    11681136              (error "Failed to locate debug utility file: ~S" utility-file)))))))
    11711138;;; Flow control
    11721139(with-upgradability ()
     1140  (defmacro nest (&rest things)
     1141    "Macro to do keep code nesting and indentation under control." ;; Thanks to mbaringer
     1142    (reduce #'(lambda (outer inner) `(,@outer ,inner))
     1143            things :from-end t))
    11731145  (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
    11741146    ;; bindings can be (var form) or ((var1 form1) ...)
    12431215(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR.
    12441216  (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
     1217  #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow???
    12451218  (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
    12951268    (when (or start end) (setf strings (subseq strings start end)))
    12961269    (when key (setf strings (mapcar key strings)))
    1297     (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s)))
     1270    (loop :with output = (make-string (loop :for s :in strings
     1271                                            :sum (if (characterp s) 1 (length s)))
    12981272                                      :element-type (strings-common-element-type strings))
    12991273          :with pos = 0
    1378 ;;; CLOS
    1379 (with-upgradability ()
    1380   (defun find-class* (x &optional (errorp t) environment)
    1381     (etypecase x
    1382       ((or standard-class built-in-class) x)
    1383       #+gcl2.6 (keyword nil)
    1384       (symbol (find-class x errorp environment)))))
    13871352;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity
    13881353(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
    14261391      (function fun)
    14271392      ((or boolean keyword character number pathname) (constantly fun))
    1428       (symbol fun)
     1393      (hash-table (lambda (x) (gethash x fun)))
     1394      (symbol (fdefinition fun))
    14291395      (cons (if (eq 'lambda (car fun))
    14301396                (eval fun)
     1450;;; CLOS
     1451(with-upgradability ()
     1452  (defun coerce-class (class &key (package :cl) (super t) (error 'error))
     1453    "Coerce CLASS to a class that is subclass of SUPER if specified,
     1454or invoke ERROR handler as per CALL-FUNCTION.
     1456A keyword designates the name a symbol, which when found in either PACKAGE, designates a class.
     1457-- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future.
     1458A string is read as a symbol while in PACKAGE, the symbol designates a class.
     1460A class object designates itself.
     1461NIL designates itself (no class).
     1462A symbol otherwise designates a class by name."
     1463    (let* ((normalized
     1464             (typecase class
     1465              (keyword (or (find-symbol* class package nil)
     1466                           (find-symbol* class *package* nil)))
     1467              (string (symbol-call :uiop :safe-read-from-string class :package package))
     1468              (t class)))
     1469           (found
     1470             (etypecase normalized
     1471               ((or standard-class built-in-class) normalized)
     1472               ((or null keyword) nil)
     1473               (symbol (find-class normalized nil nil)))))
     1474      (or (and found
     1475               (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super))
     1476               found)
     1477          (call-function error "Can't coerce ~S to a ~@[class~;subclass of ~:*~S]" class super)))))
    14841480;;; Hash-tables
    14851481(with-upgradability ()
    14861482  (defun ensure-gethash (key table default)
    1487     "Lookup the TABLE for a KEY as by gethash, but if not present,
     1483    "Lookup the TABLE for a KEY as by GETHASH, but if not present,
    14881484call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION,
    1489 set the corresponding entry to the result in the table, and return that result."
     1485set the corresponding entry to the result in the table.
     1486Return two values: the entry after its optional computation, and whether it was found"
    14901487    (multiple-value-bind (value foundp) (gethash key table)
    1491       (if foundp
    1492           value
    1493           (setf (gethash key table) (values (call-function default))))))
     1488      (values
     1489       (if foundp
     1490           value
     1491           (setf (gethash key table) (call-function default)))
     1492       foundp)))
    14951494  (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
    15681567    #+clozure 'ccl::format-control
    15691568    #+(or cmu scl) 'conditions::format-control
    1570     #+ecl 'si::format-control
     1569    #+(or ecl mkcl) 'si::format-control
    15711570    #+(or gcl lispworks) 'conditions::format-string
    15721571    #+sbcl 'sb-kernel:format-control
    1573     #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
     1572    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil
    15741573    "Name of the slot for FORMAT-CONTROL in simple-condition")
    16021601  (defmacro with-muffled-conditions ((conditions) &body body)
     1602    "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
    16031603    `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
    16541654    "Is the underlying operating system Microsoft Windows?"
    16551655    (or #+abcl (featurep :windows)
    1656         #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
     1656        #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32 mingw64)) t))
    16581658  (defun os-genera-p ()
    16681668except on ABCL where it might change between FASL compilation and runtime."
    16691669    (loop* :with o
    1670            :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p)
    1671                                          (:os-macosx . os-macosx-p)
     1670           :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
     1671                                         (:os-windows . os-windows-p)
    16721672                                         (:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
    1673            :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*)
     1673           :when (and (or (not o) (eq feature :os-macosx)) (funcall detect))
     1674           :do (setf o feature) (pushnew feature *features*)
    16741675           :else :do (setf *features* (remove feature *features*))
    16751676           :finally
    18511852  (defun getcwd ()
    18521853    "Get the current working directory as per POSIX getcwd(3), as a pathname object"
    1853     (or #+abcl (parse-namestring
    1854                 (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
     1854    (or #+abcl (truename (symbol-call :asdf/filesystem :parse-native-namestring
     1855                          (java:jstatic "getProperty" "java.lang.System" "user.dir")
     1856                          :ensure-directory t))
    18551857        #+allegro (excl::current-directory)
    18561858        #+clisp (ext:default-directory)
    18601862        #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
    18611863        #+ecl (ext:getcwd)
    1862         #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
    1863                (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines)))
     1864        #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
    18641865        #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
    18651866        #+lispworks (system:current-directory)
    18831884          #+lispworks (hcl:change-directory x)
    18841885          #+mkcl (mk-ext:chdir x)
    1885           #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
     1886          #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
    18861887          (error "chdir not supported on your implementation")))))
    20192020implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
    20202021that is a list and not a string."
    2021     #+gcl2.6 (setf directory (substitute :back :parent directory))
    20222022    (cond
    20232023      #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
    20242024      ((stringp directory) `(:absolute ,directory))
    2025       #+gcl2.6
    2026       ((and (consp directory) (eq :root (first directory)))
    2027        `(:absolute ,@(rest directory)))
    20282025      ((or (null directory)
    20292026           (and (consp directory) (member (first directory) '(:absolute :relative))))
    20302027       directory)
    2031       #+gcl2.6
     2028      #+gcl
    20322029      ((consp directory)
    2033        `(:relative ,@directory))
     2030       (cons :relative directory))
    20342031      (t
    20352032       (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
    20382035    "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
    20392036by the underlying implementation's MAKE-PATHNAME and other primitives"
    2040     #-gcl2.6 directory-component
    2041     #+gcl2.6
    2042     (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
    2043                             directory-component)))
    2044       (cond
    2045         ((and (consp d) (eq :relative (first d))) (rest d))
    2046         ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
    2047         (t d))))
     2037    directory-component)
    20492039  (defun merge-pathname-directory-components (specified defaults)
    20742064  ;; This will be :unspecific if supported, or NIL if not.
    20752065  (defparameter *unspecific-pathname-type*
    2076     #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
    2077     #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil
     2066    #+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific
     2067    #+(or clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil
    20782068    "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
    2080   (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
     2070  (defun make-pathname* (&rest keys &key (directory nil)
    20812071                                      host (device () #+allegro devicep) name type version defaults
    20822072                                      #+scl &allow-other-keys)
    20892079           (append
    20902080            #+allegro (when (and devicep (null device)) `(:device :unspecific))
    2091             #+gcl2.6
    2092             (when directoryp
    2093               `(:directory ,(denormalize-pathname-directory-component directory)))
    20942081            keys)))
    21762163    ;; MCL has issues with make-pathname, nil and defaulting
    21772164    (declare (ignorable defaults))
    2178     #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
    2179                        :host (or #+cmu lisp::*unix-host*)
     2165    #.`(make-pathname* :directory nil :name nil :type nil :version nil
     2166                       :device (or #+(and mkcl unix) :unspecific)
     2167                       :host (or #+cmu lisp::*unix-host* #+(and mkcl unix) "localhost")
    21802168                       #+scl ,@'(:scheme nil :scheme-specific-part nil
    21812169                                 :username nil :password nil :parameters nil :query nil :fragment nil)
    22102198            (and (pathnamep p1) (pathnamep p2)
    22112199                 (and (=? pathname-host)
    2212                       (=? pathname-device)
     2200                      #-(and mkcl unix) (=? pathname-device)
    22132201                      (=? normalize-pathname-directory-component pathname-directory)
    22142202                      (=? pathname-name)
    22152203                      (=? pathname-type)
    2216                       (=? pathname-version)))))))
     2204                      #-mkcl (=? pathname-version)))))))
    22182206  (defun absolute-pathname-p (pathspec)
    22882276actually-existing directory."
    22892277    (when pathname
     2278      ;; I tried using Allegro's excl:file-directory-p, but this cannot be done,
     2279      ;; because it rejects apparently legal pathnames as
     2280      ;; ill-formed. [2014/02/10:rpg]
    22902281      (let ((pathname (pathname pathname)))
    22912282        (flet ((check-one (x)
    2292                  (member x '(nil :unspecific "") :test 'equal)))
     2283                 (member x '(nil :unspecific) :test 'equal)))
    22932284          (and (not (wild-pathname-p pathname))
    22942285               (check-one (pathname-name pathname))
    24662457      (pathname
    24672458       (with-output-to-string (s)
    2468          (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
     2459         (flet ((err () #+lispworks (describe pathname) (error "Not a valid unix-namestring ~S" pathname)))
    24692460           (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
    24702461                  (name (pathname-name pathname))
     2462                  (name (and (not (eq name :unspecific)) name))
    24712463                  (type (pathname-type pathname))
    24722464                  (type (and (not (eq type :unspecific)) type)))
    24732465             (cond
    2474                ((eq dir ()))
     2466               ((member dir '(nil :unspecific)))
    24752467               ((eq dir '(:relative)) (princ "./" s))
    24762468               ((consp dir)
    24882480             (cond
    24892481               (name
    2490                 (or (and (stringp name) (or (null type) (stringp type))) (err))
     2482                (unless (and (stringp name) (or (null type) (stringp type))) (err))
    24912483                (format s "~A~@[.~A~]" name type))
    24922484               (t
    25262518                    ;; scheme-specific parts: port username password, not others:
    25272519                    . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
    2529   (defun subpathp (maybe-subpath base-pathname)
    2530     "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
    2531 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
    2532     (and (pathnamep maybe-subpath) (pathnamep base-pathname)
    2533          (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
    2534          (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
    2535          (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
    2536          (with-pathname-defaults ()
    2537            (let ((enough (enough-namestring maybe-subpath base-pathname)))
    2538              (and (relative-pathname-p enough) (pathname enough))))))
    2540   (defun enough-pathname (maybe-subpath base-pathname)
    2541     "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
    2542 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
    2543     (check-type maybe-subpath (or null pathname))
    2544     (check-type base-pathname (or null pathname))
    2545     (when (pathnamep base-pathname) (assert (absolute-pathname-p base-pathname)))
    2546     (or (and base-pathname (subpathp maybe-subpath base-pathname))
    2547         maybe-subpath))
    2549   (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk)
    2550     "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null,
    2551 or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH
    2552 given DEFAULTS-PATHNAME as a base pathname."
    2553     (let ((enough (enough-pathname maybe-subpath defaults-pathname))
    2554           (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*)))
    2555       (funcall thunk enough)))
    2557   (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var)
    2558                                                   (defaults *default-pathname-defaults*))
    2559                                   &body body)
    2560     "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME"
    2561     `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body)))
    25632521  (defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
    25782536      (t (call-function on-error
    25792537                        "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
    2580                         path defaults)))))
     2538                        path defaults))))
     2540  (defun subpathp (maybe-subpath base-pathname)
     2541    "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
     2542when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
     2543    (and (pathnamep maybe-subpath) (pathnamep base-pathname)
     2544         (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
     2545         (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
     2546         (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
     2547         (with-pathname-defaults ()
     2548           (let ((enough (enough-namestring maybe-subpath base-pathname)))
     2549             (and (relative-pathname-p enough) (pathname enough))))))
     2551  (defun enough-pathname (maybe-subpath base-pathname)
     2552    "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
     2553when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
     2554    (let ((sub (when maybe-subpath (pathname maybe-subpath)))
     2555          (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
     2556      (or (and base (subpathp sub base)) sub)))
     2558  (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk)
     2559    "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null,
     2560or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH
     2561given DEFAULTS-PATHNAME as a base pathname."
     2562    (let ((enough (enough-pathname maybe-subpath defaults-pathname))
     2563          (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*)))
     2564      (funcall thunk enough)))
     2566  (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var)
     2567                                                  (defaults *default-pathname-defaults*))
     2568                                  &body body)
     2569    "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME"
     2570    `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body))))
    25852575  (defparameter *wild* (or #+cormanlisp "*" :wild)
    25862576    "Wild component for use with MAKE-PATHNAME")
    2587   (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild)
     2577  (defparameter *wild-directory-component* (or :wild)
    25882578    "Wild directory component for use with MAKE-PATHNAME")
    2589   (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors)
     2579  (defparameter *wild-inferiors-component* (or :wild-inferiors)
    25902580    "Wild-inferiors directory component for use with MAKE-PATHNAME")
    25912581  (defparameter *wild-file*
    28122802                   #+allegro
    28132803                   (probe-file p :follow-symlinks truename)
    2814                    #-(or allegro clisp gcl2.6)
     2804                   #+gcl
     2805                   (if truename
     2806                       (truename* p)
     2807                       (let ((kind (car (si::stat p))))
     2808                         (when (eq kind :link)
     2809                           (setf kind (ignore-errors (car (si::stat (truename* p))))))
     2810                         (ecase kind
     2811                           ((nil) nil)
     2812                           ((:file :link)
     2813                            (cond
     2814                              ((file-pathname-p p) p)
     2815                              ((directory-pathname-p p)
     2816                               (subpathname p (car (last (pathname-directory p)))))))
     2817                           (:directory (ensure-directory-pathname p)))))
     2818                   #+clisp
     2819                   #.(flet ((probe (probe)
     2820                              `(let ((foundtrue ,probe))
     2821                                 (cond
     2822                                   (truename foundtrue)
     2823                                   (foundtrue p)))))
     2824                       (let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
     2825                              (pp (find-symbol* '#:probe-pathname :ext nil))
     2826                              (resolve (if pp
     2827                                           `(ignore-errors (,pp p))
     2828                                           '(or (truename* p)
     2829                                             (truename* (ignore-errors (ensure-directory-pathname p)))))))
     2830                         (if fs
     2831                             `(if truename
     2832                                  ,resolve
     2833                                  (and (ignore-errors (,fs p)) p))
     2834                             (probe resolve))))
     2835                   #-(or allegro clisp gcl)
    28152836                   (if truename
    28162837                       (probe-file p)
    28222843                           #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
    28232844                           #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
    2824                            p))))
    2825                    #+(or clisp gcl2.6)
    2826                    #.(flet ((probe (probe)
    2827                               `(let ((foundtrue ,probe))
    2828                                  (cond
    2829                                    (truename foundtrue)
    2830                                    (foundtrue p)))))
    2831                        #+gcl2.6
    2832                        (probe '(or (probe-file p)
    2833                                 (and (directory-pathname-p p)
    2834                                  (ignore-errors
    2835                                   (ensure-directory-pathname
    2836                                    (truename* (subpathname
    2837                                                (ensure-directory-pathname p) ".")))))))
    2838                        #+clisp
    2839                        (let* ((fs (find-symbol* '#:file-stat :posix nil))
    2840                               (pp (find-symbol* '#:probe-pathname :ext nil))
    2841                               (resolve (if pp
    2842                                            `(ignore-errors (,pp p))
    2843                                            '(or (truename* p)
    2844                                              (truename* (ignore-errors (ensure-directory-pathname p)))))))
    2845                          (if fs
    2846                              `(if truename
    2847                                   ,resolve
    2848                                   (and (ignore-errors (,fs p)) p))
    2849                              (probe resolve)))))
     2845                           p)))))
    28502846                (file-error () nil)))))))
    28522848  (defun directory-exists-p (x)
    28532849    "Is X the name of a directory that exists on the filesystem?"
     2850    #+allegro
     2851    (excl:probe-directory x)
     2852    #+clisp
     2853    (handler-case (ext:probe-directory x)
     2854           (sys::simple-file-error ()
     2855             nil))
     2856    #-(or allegro clisp)
    28542857    (let ((p (probe-file* x :truename t)))
    28552858      (and (directory-pathname-p p) p)))
    28762879the entries which are physical yet when transformed by MERGER have a different TRUENAME.
    28772880This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames."
    2878     (if (logical-pathname-p directory)
    2879         ;; Try hard to not resolve logical-pathname into physical pathnames;
    2880         ;; otherwise logical-pathname users/lovers will be disappointed.
    2881         ;; If directory* could use some implementation-dependent magic,
    2882         ;; we will have logical pathnames already; otherwise,
    2883         ;; we only keep pathnames for which specifying the name and
    2884         ;; translating the LPN commute.
    2885         (loop :for f :in entries
    2886               :for p = (or (and (logical-pathname-p f) f)
    2887                            (let* ((u (ignore-errors (call-function merger f))))
    2888                              ;; The first u avoids a cumbersome (truename u) error.
    2889                              ;; At this point f should already be a truename,
    2890                              ;; but isn't quite in CLISP, for it doesn't have :version :newest
    2891                              (and u (equal (truename* u) (truename* f)) u)))
    2892               :when p :collect p)
    2893         entries))
     2881    (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
     2882     (if (logical-pathname-p directory)
     2883         ;; Try hard to not resolve logical-pathname into physical pathnames;
     2884         ;; otherwise logical-pathname users/lovers will be disappointed.
     2885         ;; If directory* could use some implementation-dependent magic,
     2886         ;; we will have logical pathnames already; otherwise,
     2887         ;; we only keep pathnames for which specifying the name and
     2888         ;; translating the LPN commute.
     2889         (loop :for f :in entries
     2890               :for p = (or (and (logical-pathname-p f) f)
     2891                            (let* ((u (ignore-errors (call-function merger f))))
     2892                              ;; The first u avoids a cumbersome (truename u) error.
     2893                              ;; At this point f should already be a truename,
     2894                              ;; but isn't quite in CLISP, for it doesn't have :version :newest
     2895                              (and u (equal (truename* u) (truename* f)) u)))
     2896               :when p :collect p)
     2897         entries)
     2898     :test 'pathname-equal))
    28952901  (defun directory-files (directory &optional (pattern *wild-file*))
    2896     "Return a list of the files in a directory according to the PATTERN,
    2897 which is not very portable to override. Try not resolve symlinks if implementation allows."
     2902    "Return a list of the files in a directory according to the PATTERN.
     2903Subdirectories should NOT be returned.
     2904  PATTERN defaults to a pattern carefully chosen based on the implementation;
     2905override the default at your own risk.
     2906  DIRECTORY-FILES tries NOT to resolve symlinks if the implementation
     2907permits this."
    28982908    (let ((dir (pathname directory)))
    28992909      (when (logical-pathname-p dir)
    29082918      (let* ((pat (merge-pathnames* pattern dir))
    29092919             (entries (append (ignore-errors (directory* pat))
    2910                               #+clisp
     2920                              #+(or clisp gcl)
    29112921                              (when (equal :wild (pathname-type pattern))
    29122922                                (ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
    2913         (filter-logical-directory-results
    2914          directory entries
    2915          #'(lambda (f)
    2916              (make-pathname :defaults dir
    2917                             :name (make-pathname-component-logical (pathname-name f))
    2918                             :type (make-pathname-component-logical (pathname-type f))
    2919                             :version (make-pathname-component-logical (pathname-version f))))))))
     2923        (remove-if 'directory-pathname-p
     2924                   (filter-logical-directory-results
     2925                    directory entries
     2926                    #'(lambda (f)
     2927                        (make-pathname :defaults dir
     2928                                       :name (make-pathname-component-logical (pathname-name f))
     2929                                       :type (make-pathname-component-logical (pathname-type f))
     2930                                       :version (make-pathname-component-logical (pathname-version f)))))))))
    29212932  (defun subdirectories (directory)
    29852996          (assert (eq :absolute (first directory)))
    29862997          (loop :while up-components :do
    2987             (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
    2988                                                          :name nil :type nil :version nil :defaults p)))
    2989               (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
    2990                                                         :defaults p)
    2991                                         (ensure-directory-pathname parent)))
    2992               (push (pop up-components) down-components))
    2993                 :finally (return p))))))
     2998            (if-let (parent
     2999                     (ignore-errors
     3000                      (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
     3001                                                   :name nil :type nil :version nil :defaults p))))
     3002              (if-let (simplified
     3003                       (ignore-errors
     3004                        (merge-pathnames*
     3005                         (make-pathname* :directory `(:relative ,@down-components)
     3006                                         :defaults p)
     3007                         (ensure-directory-pathname parent))))
     3008                (return simplified)))
     3009            (push (pop up-components) down-components)
     3010            :finally (return p))))))
    29953012  (defun resolve-symlinks (path)
    30173034      (pathname &key
    30183035                  on-error
    3019                   defaults type dot-dot
     3036                  defaults type dot-dot namestring
    30203037                  want-pathname
    30213038                  want-logical want-physical ensure-physical
    30313048If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
    3033 If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
    3035 then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
    3036 and the all the checks and transformations are run.
     3050If the argument is a STRING, it is first converted to a pathname via
     3052depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
     3053or else by using CALL-FUNCTION on the NAMESTRING argument;
     3054if :UNIX is specified (or NIL, the default, which specifies the same thing),
     3055then PARSE-UNIX-NAMESTRING it is called with the keywords
     3057the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
     3059The pathname passed or resulting from parsing the string
     3060is then subjected to all the checks and transformations below are run.
    30383062Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
    30933117            ((or null pathname))
    30943118            (string
    3095              (setf p (parse-unix-namestring
    3096                       p :defaults defaults :type type :dot-dot dot-dot
    3097                         :ensure-directory ensure-directory :want-relative want-relative))))
    3098           (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
    3099           (unless (pathnamep p) (return nil))
     3119             (setf p (case namestring
     3120                       ((:unix nil)
     3121                        (parse-unix-namestring
     3122                         p :defaults defaults :type type :dot-dot dot-dot
     3123                           :ensure-directory ensure-directory :want-relative want-relative))
     3124                       ((:native)
     3125                        (parse-native-namestring p))
     3126                       ((:lisp)
     3127                        (parse-namestring p))
     3128                       (t
     3129                        (call-function namestring p))))))
     3130          (etypecase p
     3131            (pathname)
     3132            (null
     3133             (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
     3134             (return nil)))
    31003135          (check want-logical (logical-pathname-p p) "Expected a logical pathname")
    31013136          (check want-physical (physical-pathname-p p) "Expected a physical pathname")
    32423277    #-clisp
    32433278    (rename-file source target
    3244                  #+clozure :if-exists #+clozure :rename-and-delete))
     3279                 #+(or clozure ecl) :if-exists #+clozure :rename-and-delete #+ecl t))
    32463281  (defun delete-file-if-exists (x)
    32693304               `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
    32703305    #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
    3271     #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl xcl)
     3306    #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks mkcl sbcl scl xcl)
    32723307    (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
    34923527      (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
    3494 ;;; Output to a stream or string, FORMAT-style
    3495 (with-upgradability ()
    3496   (defun call-with-output (output function)
     3529;;; Output helpers
     3530(with-upgradability ()
     3531  (defun call-with-output-file (pathname thunk
     3532                                &key
     3533                                  (element-type *default-stream-element-type*)
     3534                                  (external-format *utf-8-external-format*)
     3535                                  (if-exists :error)
     3536                                  (if-does-not-exist :create))
     3537    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
     3538Other keys are accepted but discarded."
     3539    (with-open-file (s pathname :direction :output
     3540                                :element-type element-type
     3541                                :external-format external-format
     3542                                :if-exists if-exists
     3543                                :if-does-not-exist if-does-not-exist)
     3544      (funcall thunk s)))
     3546  (defmacro with-output-file ((var pathname &rest keys
     3547                               &key element-type external-format if-exists if-does-not-exist)
     3548                              &body body)
     3549    (declare (ignore element-type external-format if-exists if-does-not-exist))
     3550    `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys))
     3552  (defun call-with-output (output function &key keys)
    34973553    "Calls FUNCTION with an actual stream argument,
    34983554behaving like FORMAT with respect to how stream designators are interpreted:
    3499 If OUTPUT is a stream, use it as the stream.
     3555If OUTPUT is a STREAM, use it as the stream.
    35003556If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
    35013557If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
    3502 If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
     3558If OUTPUT is a STRING with a fill-pointer, use it as a string-output-stream.
     3559If OUTPUT is a PATHNAME, open the file and write to it, passing KEYS to WITH-OUTPUT-FILE
     3560-- this latter as an extension since ASDF 3.1.
    35033561Otherwise, signal an error."
    35043562    (etypecase output
    35113569      (string
    35123570       (assert (fill-pointer output))
    3513        (with-output-to-string (stream output) (funcall function stream)))))
     3571       (with-output-to-string (stream output) (funcall function stream)))
     3572      (pathname
     3573       (apply 'call-with-output-file output function keys))))
    35153575  (defmacro with-output ((output-var &optional (value output-var)) &body body)
    35273587;;; Input helpers
    35283588(with-upgradability ()
    3529   (defun call-with-input (input function)
    3530     "Calls FUNCTION with an actual stream argument, interpreting
    3531 stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
    3532 If INPUT is a STREAM, use it as the stream.
    3533 If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
    3534 If INPUT is T, use *TERMINAL-IO* as the stream.
    3535 As an extension, if INPUT is a string, use it as a string-input-stream.
    3536 Otherwise, signal an error."
    3537     (etypecase input
    3538       (null (funcall function *standard-input*))
    3539       ((eql t) (funcall function *terminal-io*))
    3540       (stream (funcall function input))
    3541       (string (with-input-from-string (stream input) (funcall function stream)))))
    3543   (defmacro with-input ((input-var &optional (value input-var)) &body body)
    3544     "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
    3545 as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
    3546     `(call-with-input ,value #'(lambda (,input-var) ,@body)))
    35483589  (defun call-with-input-file (pathname thunk
    35493590                               &key
    35533594    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
    35543595Other keys are accepted but discarded."
    3555     #+gcl2.6 (declare (ignore external-format))
    35563596    (with-open-file (s pathname :direction :input
    35573597                                :element-type element-type
    3558                                 #-gcl2.6 :external-format #-gcl2.6 external-format
     3598                                :external-format external-format
    35593599                                :if-does-not-exist if-does-not-exist)
    35603600      (funcall thunk s)))
    35663606    `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
    3568   (defun call-with-output-file (pathname thunk
    3569                                 &key
    3570                                   (element-type *default-stream-element-type*)
    3571                                   (external-format *utf-8-external-format*)
    3572                                   (if-exists :error)
    3573                                   (if-does-not-exist :create))
    3574     "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
    3575 Other keys are accepted but discarded."
    3576     #+gcl2.6 (declare (ignore external-format))
    3577     (with-open-file (s pathname :direction :output
    3578                                 :element-type element-type
    3579                                 #-gcl2.6 :external-format #-gcl2.6 external-format
    3580                                 :if-exists if-exists
    3581                                 :if-does-not-exist if-does-not-exist)
    3582       (funcall thunk s)))
    3584   (defmacro with-output-file ((var pathname &rest keys
    3585                                &key element-type external-format if-exists if-does-not-exist)
    3586                               &body body)
    3587     (declare (ignore element-type external-format if-exists if-does-not-exist))
    3588     `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
     3608  (defun call-with-input (input function &key keys)
     3609    "Calls FUNCTION with an actual stream argument, interpreting
     3610stream designators like READ, but also coercing strings to STRING-INPUT-STREAM,
     3611and PATHNAME to FILE-STREAM.
     3612If INPUT is a STREAM, use it as the stream.
     3613If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
     3614If INPUT is T, use *TERMINAL-IO* as the stream.
     3615If INPUT is a STRING, use it as a string-input-stream.
     3616If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE
     3617-- the latter is an extension since ASDF 3.1.
     3618Otherwise, signal an error."
     3619    (etypecase input
     3620      (null (funcall function *standard-input*))
     3621      ((eql t) (funcall function *terminal-io*))
     3622      (stream (funcall function input))
     3623      (string (with-input-from-string (stream input) (funcall function stream)))
     3624      (pathname (apply 'call-with-input-file input function keys))))
     3626  (defmacro with-input ((input-var &optional (value input-var)) &body body)
     3627    "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
     3628as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
     3629    `(call-with-input ,value #'(lambda (,input-var) ,@body))))
    35903632;;; Null device
    35983640      (t (error "No /dev/null on your OS"))))
    35993641  (defun call-with-null-input (fun &rest keys &key element-type external-format if-does-not-exist)
     3642    "Call FUN with an input stream from the null device; pass keyword arguments to OPEN."
    36003643    (declare (ignore element-type external-format if-does-not-exist))
    36013644    (apply 'call-with-input-file (null-device-pathname) fun keys))
    36043647                             &body body)
    36053648    (declare (ignore element-type external-format if-does-not-exist))
    3606     "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device."
     3649    "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device.
     3650Pass keyword arguments to OPEN."
    36073651    `(call-with-null-input #'(lambda (,var) ,@body) ,@keys))
    36083652  (defun call-with-null-output (fun
    36113655                                  (if-exists :overwrite)
    36123656                                  (if-does-not-exist :error))
     3657    "Call FUN with an output stream to the null device; pass keyword arguments to OPEN."
    36133658    (call-with-output-file
    36143659     (null-device-pathname) fun
    36183663                              &key element-type external-format if-does-not-exist if-exists)
    36193664                              &body body)
    3620     "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device."
     3665    "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device.
     3666Pass keyword arguments to OPEN."
    36213667    (declare (ignore element-type external-format if-exists if-does-not-exist))
    36223668    `(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))
    38293875  (defun println (x &optional (stream *standard-output*))
    38303876    "Variant of PRINC that also calls TERPRI afterwards"
    3831     (princ x stream) (terpri stream) (values))
     3877    (princ x stream) (terpri stream) (finish-output stream) (values))
    38333879  (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys)
    38343880    "Variant of WRITE that also calls TERPRI afterwards"
    3835     (apply 'write x keys) (terpri stream) (values)))
     3881    (apply 'write x keys) (terpri stream) (finish-output stream) (values)))
    38573903    "Configure a default temporary directory to use."
    38583904    (setf *temporary-directory* (default-temporary-directory))
    3859     ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
    3860     #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
     3905    #+gcl (setf system::*tmp-dir* *temporary-directory*))
    38623907  (defun call-with-temporary-file
    38633908      (thunk &key
    3864                (want-stream-p t) (want-pathname-p t)
    3865                prefix keep (direction :io)
     3909               (want-stream-p t) (want-pathname-p t) (direction :io) keep after
     3910               directory (type "tmp" typep) prefix (suffix (when typep "-tmp"))
    38663911               (element-type *default-stream-element-type*)
    38673912               (external-format *utf-8-external-format*))
    3868     "Call a THUNK with STREAM and PATHNAME arguments identifying a temporary file.
    3869 The pathname will be based on appending a random suffix to PREFIX.
    3870 This utility will KEEP the file past its extent if and only if explicitly requested.
    3871 The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT."
    3872     #+gcl2.6 (declare (ignorable external-format))
     3913    "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
     3915The temporary file's pathname will be based on concatenating
     3916PREFIX (defaults to \"uiop\"), a random alphanumeric string,
     3917and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
     3918and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
     3919within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
     3921The file will be open with specified DIRECTION (defaults to :IO),
     3923EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
     3924If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
     3925with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
     3926and stream with be closed after the THUNK exits (either normally or abnormally).
     3927If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
     3928THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
     3929Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
     3930If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
     3931Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
     3932    #+xcl (declare (ignorable typep))
    38733933    (check-type direction (member :output :io))
    38743934    (assert (or want-stream-p want-pathname-p))
    38753935    (loop
    3876       :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
     3936      :with prefix = (native-namestring
     3937                      (ensure-absolute-pathname
     3938                       (or prefix "tmp")
     3939                       (or (ensure-pathname directory :namestring :native :ensure-directory t)
     3940                           #'temporary-directory)))
    38773941      :with results = ()
    3878       :for counter :from (random (ash 1 32))
    3879       :for pathname = (pathname (format nil "~A~36R" prefix counter))
     3942      :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
     3943      :for pathname = (parse-native-namestring
     3944                       (format nil "~A~36R~@[~A~]~@[.~A~]" prefix counter suffix type))
    38803945      :for okp = nil :do
    38813946        ;; TODO: on Unix, do something about umask
    38823947        ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
    3883         ;; TODO: on Unix, use CFFI and mkstemp -- but UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
     3948        ;; TODO: on Unix, use CFFI and mkstemp --
     3949        ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
     3950        ;; Can we at least design some hook?
    38843951        (unwind-protect
    38853952             (progn
    38873954                                       :direction direction
    38883955                                       :element-type element-type
    3889                                        #-gcl2.6 :external-format #-gcl2.6 external-format
     3956                                       :external-format external-format
    38903957                                       :if-exists nil :if-does-not-exist :create)
    38913958                 (when stream
    38983965                                (funcall thunk stream)))))))
    38993966               (when okp
    3900                  (if want-stream-p
    3901                      (return (apply 'values results))
    3902                      (return (funcall thunk pathname)))))
    3903           (when (and okp (not keep))
     3967                 (unless want-stream-p
     3968                   (setf results (multiple-value-list (call-function thunk pathname))))
     3969                 (when after
     3970                   (setf results (multiple-value-list (call-function after pathname))))
     3971                 (return (apply 'values results))))
     3972          (when (and okp (not (call-function keep)))
    39043973            (ignore-errors (delete-file-if-exists okp))))))
    39063975  (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
    39073976                                    (pathname (gensym "PATHNAME") pathnamep)
    3908                                     prefix keep direction element-type external-format)
     3977                                    directory prefix suffix type
     3978                                    keep direction element-type external-format)
    39093979                                 &body body)
    39103980    "Evaluate BODY where the symbols specified by keyword arguments
    39113981STREAM and PATHNAME (if respectively specified) are bound corresponding
    39123982to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
    3913 The STREAM will be closed if no binding is specified.
    3914 Unless KEEP is specified, delete the file afterwards."
     3983At least one of STREAM or PATHNAME must be specified.
     3984If the STREAM is not specified, it will be closed before the BODY is evaluated.
     3985If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
     3986separates forms run before and after the stream is closed.
     3987The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
     3988Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
    39153989    (check-type stream symbol)
    39163990    (check-type pathname symbol)
    39173991    (assert (or streamp pathnamep))
    3918     `(flet ((think (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
    3919               ,@body))
    3920        #-gcl (declare (dynamic-extent #'think))
    3921        (call-with-temporary-file
    3922         #'think
    3923         :want-stream-p ,streamp
    3924         :want-pathname-p ,pathnamep
    3925         ,@(when direction `(:direction ,direction))
    3926         ,@(when prefix `(:prefix ,prefix))
    3927         ,@(when keep `(:keep ,keep))
    3928         ,@(when element-type `(:element-type ,element-type))
    3929         ,@(when external-format `(:external-format ,external-format)))))
    3931   (defun get-temporary-file (&key prefix)
    3932     (with-temporary-file (:pathname pn :keep t :prefix prefix)
     3992    (let* ((afterp (position :close-stream body))
     3993           (before (if afterp (subseq body 0 afterp) body))
     3994           (after (when afterp (subseq body (1+ afterp))))
     3995           (beforef (gensym "BEFORE"))
     3996           (afterf (gensym "AFTER")))
     3997      `(flet (,@(when before
     3998                  `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@before)))
     3999              ,@(when after
     4000                  (assert pathnamep)
     4001                  `((,afterf (,pathname) ,@after))))
     4002         #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf))))
     4003         (call-with-temporary-file
     4004          ,(when before `#',beforef)
     4005          :want-stream-p ,streamp
     4006          :want-pathname-p ,pathnamep
     4007          ,@(when direction `(:direction ,direction))
     4008          ,@(when directory `(:directory ,directory))
     4009          ,@(when prefix `(:prefix ,prefix))
     4010          ,@(when suffix `(:suffix ,suffix))
     4011          ,@(when type `(:type ,type))
     4012          ,@(when keep `(:keep ,keep))
     4013          ,@(when after `(:after #',afterf))
     4014          ,@(when element-type `(:element-type ,element-type))
     4015          ,@(when external-format `(:external-format ,external-format))))))
     4017  (defun get-temporary-file (&key directory prefix suffix type)
     4018    (with-temporary-file (:pathname pn :keep t
     4019                          :directory directory :prefix prefix :suffix suffix :type type)
    39334020      pn))
    39354022  ;; Temporary pathnames in simple cases where no contention is assumed
    3936   (defun add-pathname-suffix (pathname suffix)
    3937     "Add a SUFFIX to the name of a PATHNAME, return a new pathname"
    3938     (make-pathname :name (strcat (pathname-name pathname) suffix)
    3939                    :defaults pathname))
     4023  (defun add-pathname-suffix (pathname suffix &rest keys)
     4024    "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
     4025Further KEYS can be passed to MAKE-PATHNAME."
     4026    (apply 'make-pathname :name (strcat (pathname-name pathname) suffix)
     4027                          :defaults pathname keys))
    39414029  (defun tmpize-pathname (x)
    39424030    "Return a new pathname modified from X by adding a trivial deterministic suffix"
    3943     (add-pathname-suffix x "-ASDF-TMP"))
     4031    (add-pathname-suffix x "-TMP"))
    39454033  (defun call-with-staging-pathname (pathname fun)
    3946     "Calls fun with a staging pathname, and atomically
    3947 renames the staging pathname to the pathname in the end.
    3948 Note: this protects only against failure of the program,
    3949 not against concurrent attempts.
    3950 For the latter case, we ought pick random suffix and atomically open it."
     4034    "Calls FUN with a staging pathname, and atomically
     4035renames the staging pathname to the PATHNAME in the end.
     4036NB: this protects only against failure of the program, not against concurrent attempts.
     4037For the latter case, we ought pick a random suffix and atomically open it."
    39514038    (let* ((pathname (pathname pathname))
    39524039           (staging (tmpize-pathname pathname)))
    39594046  (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
     4047    "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
    39604048    `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
    39694057  (:export
    39704058   #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
    3971    #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
     4059   #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0
    39724060   #:*lisp-interaction*
    39734061   #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition
    40324120    #+(or cmu scl) (unix:unix-exit code)
    40334121    #+ecl (si:quit code)
    4034     #+gcl (lisp:quit code)
     4122    #+gcl (system:quit code)
    40354123    #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
    40364124    #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
    40524140    (quit code))
    4054   (defun raw-print-backtrace (&key (stream *debug-io*) count)
     4142  (defun raw-print-backtrace (&key (stream *debug-io*) count condition)
    40554143    "Print a backtrace, directly accessing the implementation"
    4056     (declare (ignorable stream count))
     4144    (declare (ignorable stream count condition))
    40574145    #+abcl
    4058     (let ((*debug-io* stream)) (top-level::backtrace-command count))
     4146    (loop :for i :from 0
     4147          :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
     4148            (safe-format! stream "~&~D: ~A~%" i frame))
    40594149    #+allegro
    40604150    (let ((*terminal-io* stream)
    40654155      (tpl:do-command "zoom"
    40664156        :from-read-eval-print-loop nil
    4067         :count t
     4157        :count (or count t)
    40684158        :all t))
    40694159    #+clisp
    40774167    (let ((debug:*debug-print-level* *print-level*)
    40784168          (debug:*debug-print-length* *print-length*))
    4079       (debug:backtrace most-positive-fixnum stream))
    4080     #+ecl
    4081     (si::tpl-backtrace)
     4169      (debug:backtrace (or count most-positive-fixnum) stream))
     4170    #+(or ecl mkcl)
     4171    (let* ((top (si:ihs-top))
     4172           (repeats (if count (min top count) top))
     4173           (backtrace (loop :for ihs :from 0 :below top
     4174                            :collect (list (si::ihs-fun ihs)
     4175                                           (si::ihs-env ihs)))))
     4176      (loop :for i :from 0 :below repeats
     4177            :for frame :in (nreverse backtrace) :do
     4178              (safe-format! stream "~&~D: ~S~%" i frame)))
     4179    #+gcl
     4180    (let ((*debug-io* stream))
     4181      (ignore-errors
     4182       (with-safe-io-syntax ()
     4183         (if condition
     4184             (conditions::condition-backtrace condition)
     4185             (system::simple-backtrace)))))
    40824186    #+lispworks
    40834187    (let ((dbg::*debugger-stack*
    40904194    (sb-debug:backtrace
    40914195     #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
    4092      stream))
    4094   (defun print-backtrace (&rest keys &key stream count)
     4196     stream)
     4197    #+xcl
     4198    (loop :for i :from 0 :below (or count most-positive-fixnum)
     4199          :for frame :in (extensions:backtrace-as-list) :do
     4200            (safe-format! stream "~&~D: ~S~%" i frame)))
     4202  (defun print-backtrace (&rest keys &key stream count condition)
    40954203    "Print a backtrace"
    4096     (declare (ignore stream count))
     4204    (declare (ignore stream count condition))
    40974205    (with-safe-io-syntax (:package :cl)
    40984206      (let ((*print-readably* nil)
    41094217    ;; for the sake of who sees the backtrace at a terminal.
    41104218    ;; It is up to the caller to print the condition *before*, with some context.
    4111     (print-backtrace :stream stream :count count)
     4219    (print-backtrace :stream stream :count count :condition condition)
    41124220    (when condition
    41134221      (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
    41754283    #+(or genera mcl) nil
    41764284    #+lispworks sys:*line-arguments-list*
     4285    #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i))
    41774286    #+sbcl sb-ext:*posix-argv*
    41784287    #+xcl system:*argv*
    4179     #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl)
     4288    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    41804289    (error "raw-command-line-arguments not implemented yet"))
    41844293Assume the calling conventions of a generated script that uses --
    41854294if we are not called from a directly executable image."
    4186     #+abcl arguments
    4187     #-abcl
    4188     (let* (#-(or sbcl allegro)
    4189            (arguments
    4190              (if (eq *image-dumped-p* :executable)
    4191                  arguments
    4192                  (member "--" arguments :test 'string-equal))))
     4295    (block nil
     4296      #+abcl (return arguments)
     4297      ;; SBCL and Allegro already separate user arguments from implementation arguments.
     4298      #-(or sbcl allegro)
     4299      (unless (eq *image-dumped-p* :executable)
     4300        ;; LispWorks command-line processing isn't transparent to the user
     4301        ;; unless you create a standalone executable; in that case,
     4302        ;; we rely on cl-launch or some other script to set the arguments for us.
     4303        #+lispworks (return *command-line-arguments*)
     4304        ;; On other implementations, on non-standalone executables,
     4305        ;; we trust cl-launch or whichever script starts the program
     4306        ;; to use -- as a delimiter between implementation arguments and user arguments.
     4307        #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
    41934308      (rest arguments)))
     4310  (defun argv0 ()
     4311    "On supported implementations (most that matter), or when invoked by a proper wrapper script,
     4312return a string that for the name with which the program was invoked, i.e. argv[0] in C.
     4313Otherwise, return NIL."
     4314    (cond
     4315      ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 !
     4316       ;; NB: not currently available on ABCL, Corman, Genera, MCL
     4317       (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl)
     4318           (first (raw-command-line-arguments))
     4319           #+ecl (si:argv 0) #+mkcl (mkcl:argv 0)))
     4320      (t ;; argv[0] is the name of the interpreter.
     4321       ;; The wrapper script can export __CL_ARGV0. cl-launch does as of
     4322       (getenvp "__CL_ARGV0"))))
    41954324  (defun setup-command-line-arguments ()
    41984327  (defun restore-image (&key
    4199                           ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
    4200                           ((:restore-hook *image-restore-hook*) *image-restore-hook*)
    4201                           ((:prelude *image-prelude*) *image-prelude*)
    4202                           ((:entry-point *image-entry-point*) *image-entry-point*)
     4328                          (lisp-interaction *lisp-interaction*)
     4329                          (restore-hook *image-restore-hook*)
     4330                          (prelude *image-prelude*)
     4331                          (entry-point *image-entry-point*)
    42034332                          (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
    42044333    "From a freshly restarted Lisp image, restore the saved Lisp environment
    4205 by setting appropriate variables, running various hooks, and calling any specified entry point."
     4334by setting appropriate variables, running various hooks, and calling any specified entry point.
     4336If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*,
     4337call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return
     4338immediately to the surrounding restore process if allowed to continue.
     4340Then, comes the restore process itself:
     4341First, call each function in the RESTORE-HOOK,
     4342in the order they were registered with REGISTER-RESTORE-HOOK.
     4343Second, evaluate the prelude, which is often Lisp text that is read,
     4344as per EVAL-INPUT.
     4345Third, call the ENTRY-POINT function, if any is specified, with no argument.
     4347The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL,
     4348any unhandled error leads to a backtrace and an exit with an error status.
     4349If LISP-INTERACTION is NIL, the process also exits when no error occurs:
     4350if neither restart nor entry function is provided, the program will exit with status 0 (success);
     4351if a function was provided, the program will exit after the function returns (if it returns),
     4352with status 0 if and only if the primary return value of result is generalized boolean true,
     4353and with status 1 if this value is NIL.
     4355If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result
     4356of the function will be returned rather than interpreted as a boolean designating an exit code."
    42064357    (when *image-restored-p*
    42074358      (if if-already-restored
    4208           (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
     4359          (call-function if-already-restored "Image already ~:[being ~;~]restored"
     4360                         (eq *image-restored-p* t))
    42094361          (return-from restore-image)))
    42104362    (with-fatal-condition-handler ()
     4363      (setf *lisp-interaction* lisp-interaction)
     4364      (setf *image-restore-hook* restore-hook)
     4365      (setf *image-prelude* prelude)
    42114366      (setf *image-restored-p* :in-progress)
    42124367      (call-image-restore-hook)
    4213       (standard-eval-thunk *image-prelude*)
     4368      (standard-eval-thunk prelude)
    42144369      (setf *image-restored-p* t)
    42154370      (let ((results (multiple-value-list
    4216                       (if *image-entry-point*
    4217                           (call-function *image-entry-point*)
     4371                      (if entry-point
     4372                          (call-function entry-point)
    42184373                          t))))
    4219         (if *lisp-interaction*
     4374        (if lisp-interaction
    42204375            (apply 'values results)
    42214376            (shell-boolean-exit (first results)))))))
    42264381(with-upgradability ()
    42274382  (defun dump-image (filename &key output-name executable
    4228                                 ((:postlude *image-postlude*) *image-postlude*)
    4229                                 ((:dump-hook *image-dump-hook*) *image-dump-hook*)
    4230                                 #+clozure prepend-symbols #+clozure (purify t))
    4231     "Dump an image of the current Lisp environment at pathname FILENAME, with various options"
     4383                                (postlude *image-postlude*)
     4384                                (dump-hook *image-dump-hook*)
     4385                                #+clozure prepend-symbols #+clozure (purify t)
     4386                                #+sbcl compression
     4387                                #+(and sbcl windows) application-type)
     4388    "Dump an image of the current Lisp environment at pathname FILENAME, with various options.
     4390First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
     4391 the functions in DUMP-HOOK, in reverse order of registration by REGISTER-DUMP-HOOK.
     4393If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup.
     4395Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL,
     4396or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
     4397    ;; Note: at least SBCL saves only global values of variables in the heap image,
     4398    ;; so make sure things you want to dump are NOT just local bindings shadowing the global values.
    42324399    (declare (ignorable filename output-name executable))
    42334400    (setf *image-dumped-p* (if executable :executable t))
    42344401    (setf *image-restored-p* :in-regress)
     4402    (setf *image-postlude* postlude)
    42354403    (standard-eval-thunk *image-postlude*)
     4404    (setf *image-dump-hook* dump-hook)
    42364405    (call-image-dump-hook)
    42374406    (setf *image-restored-p* nil)
    42694438      (setf ext:*batch-mode* nil)
    42704439      (setf ext::*gc-run-time* 0)
    4271       (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
    4272                                      (when executable '(:init-function restore-image :process-command-line nil))))
     4440      (apply 'ext:save-lisp filename
     4441             #+cmu :executable #+cmu t
     4442             (when executable '(:init-function restore-image :process-command-line nil))))
    42734443    #+gcl
    42744444    (progn
    42854455      (apply 'sb-ext:save-lisp-and-die filename
    42864456             :executable t ;--- always include the runtime that goes with the core
    4287              (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
     4457             (append
     4458              (when compression (list :compression compression))
     4459              ;;--- only save runtime-options for standalone executables
     4460              (when executable (list :toplevel #'restore-image :save-runtime-options t))
     4461              #+(and sbcl windows) ;; passing :application-type :gui will disable the console window.
     4462              ;; the default is :console - only works with SBCL 1.1.15 or later.
     4463              (when application-type (list :application-type application-type)))))
    42884464    #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
    42894465    (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
    42904466           'dump-image filename (nth-value 1 (implementation-type))))
    4292   (defun create-image (destination object-files
    4293                        &key kind output-name prologue-code epilogue-code
     4468  (defun create-image (destination lisp-object-files
     4469                       &key kind output-name prologue-code epilogue-code extra-object-files
    42944470                         (prelude () preludep) (postlude () postludep)
    4295                          (entry-point () entry-point-p) build-args)
    4296     (declare (ignorable destination object-files kind output-name prologue-code epilogue-code
    4297                         prelude preludep postlude postludep entry-point entry-point-p build-args))
     4471                         (entry-point () entry-point-p) build-args no-uiop)
     4472    (declare (ignorable destination lisp-object-files extra-object-files kind output-name
     4473                        prologue-code epilogue-code prelude preludep postlude postludep
     4474                        entry-point entry-point-p build-args no-uiop))
    42984475    "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
    42994476    ;; Is it meaningful to run these in the current environment?
    43004477    ;; only if we also track the object files that constitute the "current" image,
    43014478    ;; and otherwise simulate dump-image, including quitting at the end.
    4302     #-ecl (error "~S not implemented for your implementation (yet)" 'create-image)
    4303     #+ecl
    4304     (progn
    4305       (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
    4306       (apply 'c::builder
    4307              kind (pathname destination)
    4308              :lisp-files object-files
    4309              :init-name (c::compute-init-name (or output-name destination) :kind kind)
    4310              :prologue-code prologue-code
    4311              :epilogue-code
    4312              `(progn
    4313                 ,epilogue-code
    4314                 ,@(when (eq kind :program)
    4315                     `((setf *image-dumped-p* :executable)
    4316                       (restore-image ;; default behavior would be (si::top-level)
    4317                        ,@(when preludep `(:prelude ',prelude))
    4318                        ,@(when entry-point-p `(:entry-point ',entry-point))))))
    4319              build-args))))
     4479    #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
     4480    #+(or ecl mkcl)
     4481    (let ((epilogue-code
     4482            (if no-uiop
     4483                epilogue-code
     4484                (let ((forms
     4485                        (append
     4486                         (when epilogue-code `(,epilogue-code))
     4487                         (when postludep `((setf *image-postlude* ',postlude)))
     4488                         (when preludep `((setf *image-prelude* ',prelude)))
     4489                         (when entry-point-p `((setf *image-entry-point* ',entry-point)))
     4490                         (case kind
     4491                           ((:image)
     4492                            (setf kind :program) ;; to ECL, it's just another program.
     4493                            `((setf *image-dumped-p* t)
     4494                              (si::top-level #+ecl t) (quit)))
     4495                           ((:program)
     4496                            `((setf *image-dumped-p* :executable)
     4497                              (shell-boolean-exit
     4498                               (restore-image))))))))
     4499                  (when forms `(progn ,@forms))))))
     4500      #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
     4501      (apply #+ecl 'c::builder #+ecl kind
     4502             #+mkcl (ecase kind
     4503                      ((:dll) 'compiler::build-shared-library)
     4504                      ((:lib :static-library) 'compiler::build-static-library)
     4505                      ((:fasl) 'compiler::build-bundle)
     4506                      ((:program) 'compiler::build-program))
     4507             (pathname destination)
     4508             #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files)
     4509             #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind)
     4510             (append
     4511              (when prologue-code `(:prologue-code ,prologue-code))
     4512              (when epilogue-code `(:epilogue-code ,epilogue-code))
     4513              #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
     4514              build-args)))))
    43324527  (:nicknames :asdf/run-program)
    43334528  (:recycle :uiop/run-program :asdf/run-program :xcvb-driver)
    4334   (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
     4529  (:use :uiop/common-lisp :uiop/package :uiop/utility
     4530   :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
    43354531  (:export
    43364532   ;;; Escaping the command invocation madness
    44984694Programmers are encouraged to define their own methods for this generic function."))
    4500   #-(or gcl2.6 genera)
     4696  #-genera
    45014697  (defmethod slurp-input-stream ((function function) input-stream &key)
    45024698    (funcall function input-stream))
    45054701    (apply (first list) input-stream (rest list)))
    4507   #-(or gcl2.6 genera)
     4703  #-genera
    45084704  (defmethod slurp-input-stream ((output-stream stream) input-stream
    45094705                                 &key linewise prefix (element-type 'character) buffer-size)
    45144710  (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
    4515     (declare (ignorable x))
    45164711    (slurp-stream-string stream :stripped stripped))
    45184713  (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
    4519     (declare (ignorable x))
    45204714    (slurp-stream-string stream :stripped stripped))
    45224716  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
    4523     (declare (ignorable x))
    45244717    (slurp-stream-lines stream :count count))
    45264719  (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
    4527     (declare (ignorable x))
    45284720    (slurp-stream-line stream :at at))
    45304722  (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
    4531     (declare (ignorable x))
    45324723    (slurp-stream-forms stream :count count))
    45344725  (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
    4535     (declare (ignorable x))
    45364726    (slurp-stream-form stream :at at))
    45384728  (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    4539     (declare (ignorable x))
    45404729    (apply 'slurp-input-stream *standard-output* stream keys))
    4542   (defmethod slurp-input-stream ((x null) stream &key)
    4543     (declare (ignorable x stream))
     4731  (defmethod slurp-input-stream ((x null) (stream t) &key)
    45444732    nil)
    45654753    (declare (ignorable stream linewise prefix element-type buffer-size))
    45664754    (cond
    4567       #+(or gcl2.6 genera)
     4755      #+genera
    45684756      ((functionp x) (funcall x stream))
    4569       #+(or gcl2.6 genera)
     4757      #+genera
    45704758      ((output-stream-p x)
    45714759       (copy-stream-to-stream
    45954783Programmers are encouraged to define their own methods for this generic function."))
    4597   #-(or gcl2.6 genera)
     4785  #-genera
    45984786  (defmethod vomit-output-stream ((function function) output-stream &key)
    45994787    (funcall function output-stream))
    46024790    (apply (first list) output-stream (rest list)))
    4604   #-(or gcl2.6 genera)
     4792  #-genera
    46054793  (defmethod vomit-output-stream ((input-stream stream) output-stream
    46064794                                 &key linewise prefix (element-type 'character) buffer-size)
    46174805  (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
    4618     (declare (ignorable x))
    46194806    (apply 'vomit-output-stream *standard-input* stream keys))
    4621   (defmethod vomit-output-stream ((x null) stream &key)
    4622     (declare (ignorable x stream))
     4808  (defmethod vomit-output-stream ((x null) (stream t) &key)
    46234809    (values))
    46444830    (declare (ignorable stream linewise prefix element-type buffer-size))
    46454831    (cond
    4646       #+(or gcl2.6 genera)
     4832      #+genera
    46474833      ((functionp x) (funcall x stream))
    4648       #+(or gcl2.6 genera)
     4834      #+genera
    46494835      ((input-stream-p x)
    46504836       (copy-stream-to-stream
    46784864      #+os-windows
    46794865      (string
     4866       #+mkcl (list "cmd" '#:/c command)
    46804867       ;; NB: We do NOT add cmd /c here. You might want to.
    46814868       #+(or allegro clisp) command
    46874874       ;; except in the most trivial cases where no quoting is needed.
    46884875       ;; Use at your own risk.
    4689        #-(or allegro clisp clozure) (list "cmd" "/c" command))
     4876       #-(or allegro clisp clozure mkcl) (list "cmd" "/c" command))
    46904877      #+os-windows
    46914878      (list
    47074894    (etypecase specifier
    47084895      (null (or #+(or allegro lispworks) (null-device-pathname)))
    4709       (string (pathname specifier))
     4896      (string (parse-native-namestring specifier))
    47104897      (pathname specifier)
    47114898      (stream specifier)
    47144901       #+allegro nil
    47154902       #+clisp :terminal
    4716        #+(or clozure cmu ecl sbcl scl) t)
    4717       #+(or allegro clozure cmu ecl lispworks sbcl scl)
     4903       #+(or clozure cmu ecl mkcl sbcl scl) t)
     4904      #+(or allegro clozure cmu ecl lispworks mkcl sbcl scl)
    47184905      ((eql :output)
    47194906       (if (eq role :error-output)
    47474934    ;; NB: these implementations have unix vs windows set at compile-time.
    4748     (declare (ignorable if-input-does-not-exist if-output-exists if-error-output-exists))
     4935    (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
    47494936    (assert (not (and wait (member :stream (list input output error-output)))))
    4750     #-(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
     4937    #-(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl)
    47514938    (progn command keys directory
    47524939           (error "run-program not available"))
    4753     #+(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl)
     4940    #+(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl)
    47544941    (let* ((%command (%normalize-command command))
    47554942           (%input (%normalize-io-specifier input :input))
    47714958               :allow-other-keys t keys))
    47724959             #-allegro
    4773              (with-current-directory (#-sbcl directory)
     4960             (with-current-directory (#-(or sbcl mkcl) directory)
    47744961               #+clisp
    4775                (flet ((run (f &rest args)
     4962               (flet ((run (f x &rest args)
    47764963                        (multiple-value-list
    4777                          (apply f :input %input :output %output
    4778                                   :allow-other-keys t `(,@args ,@keys)))))
     4964                         (apply f x :input %input :output %output
     4965                                    :allow-other-keys t `(,@args ,@keys)))))
    47794966                 (assert (eq %error-output :terminal))
    47804967                 ;;; since we now always return a code, we can't use this code path, anyway!
    47834970                   (list (run 'ext:run-program (car %command)
    47844971                              :arguments (cdr %command)))))
    4785                #+(or clozure cmu ecl sbcl scl)
    4786                (#-ecl progn #+ecl multiple-value-list
     4972               #+(or clozure cmu ecl mkcl sbcl scl)
     4973               (#-(or ecl mkcl) progn #+(or ecl mkcl) multiple-value-list
    47874974                (apply
    47884975                 '#+(or cmu ecl scl) ext:run-program
    4789                  #+clozure ccl:run-program #+sbcl sb-ext:run-program
     4976                 #+clozure ccl:run-program #+sbcl sb-ext:run-program #+mkcl mk-ext:run-program
    47904977                 (car %command) (cdr %command)
    47914978                 :input %input
    47954982                 :allow-other-keys t
    47964983                 (append
    4797                   #+(or clozure cmu sbcl scl)
     4984                  #+(or clozure cmu mkcl sbcl scl)
    47984985                  `(:if-input-does-not-exist ,if-input-does-not-exist
    47994986                    :if-output-exists ,if-output-exists
    48625049                  #+(or cmu scl) (ext:process-error process*)
    48635050                  #+sbcl (sb-ext:process-error process*))))
    4864         #+ecl
    4865         (destructuring-bind (stream code process) process*
     5051        #+(or ecl mkcl)
     5052        (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
    48665053          (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
    48675054            (cond
    48835070        (nreverse process-info-r))))
     5072  (defun %process-info-pid (process-info)
     5073    (let ((process (getf process-info :process)))
     5074      (declare (ignorable process))
     5075      #+(or allegro lispworks) process
     5076      #+clozure (ccl::external-process-pid process)
     5077      #+ecl (si:external-process-pid process)
     5078      #+(or cmu scl) (ext:process-pid process)
     5079      #+mkcl (mkcl:process-id process)
     5080      #+sbcl (sb-ext:process-pid process)
     5081      #-(or allegro cmu mkcl sbcl scl) (error "~S not implemented" '%process-info-pid)))
    48855083  (defun %wait-process-result (process-info)
    48865084    (or (getf process-info :exit-code)
    48975095            #+(or cmu scl) (ext:process-exit-code process)
    48985096            #+ecl (nth-value 1 (ext:external-process-status process))
    4899             #+lispworks (system:pid-exit-status process :wait t)
    4900             #+sbcl (sb-ext:process-exit-code process)))))
     5097            #+lispworks
     5098            (if-let ((stream (or (getf process-info :input-stream)
     5099                                 (getf process-info :output-stream)
     5100                                 (getf process-info :bidir-stream)
     5101                                 (getf process-info :error-stream))))
     5102              (system:pipe-exit-status stream :wait t)
     5103              (if-let ((f (find-symbol* :pid-exit-status :system nil)))
     5104                (funcall f process :wait t)))
     5105            #+sbcl (sb-ext:process-exit-code process)
     5106            #+mkcl (mkcl:join-process process)))))
    49025108  (defun %check-result (exit-code &key command process ignore-error-status)
    49985204                           &key input output error-output ignore-error-status &allow-other-keys)
    49995205    ;; helper for RUN-PROGRAM when using %run-program
    5000     #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
    5001     (error "Not implemented on this platform")
     5206    #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl)
     5207    (progn
     5208      command keys input output error-output ignore-error-status ;; ignore
     5209      (error "Not implemented on this platform"))
    50025210    (assert (not (member :stream (list input output error-output))))
    50035211    (let* ((active-input-p (%active-io-specifier-p input))
    50615269                     (typecase spec
    50625270                       (null (null-device-pathname))
    5063                        (string (pathname spec))
     5271                       (string (parse-native-namestring spec))
    50645272                       (pathname spec)
    50655273                       ((eql :output)
    5066                         (assert (equal operator "2>"))
     5274                        (assert (equal operator " 2>"))
    50675275                        (return-from redirect '(" 2>&1"))))))
    50685276               (when pathname
    5069                  (list " " operator " "
     5277                 (list operator " "
    50705278                       (escape-shell-token (native-namestring pathname)))))))
    50715279      (multiple-value-bind (before after)
    50765284        (reduce/strcat
    50775285         (append
    5078           before (redirect in "<") (redirect out ">") (redirect err "2>")
    5079           (when (and directory (os-unix-p)) `("cd " (escape-shell-token directory) " ; "))
     5286          before (redirect in " <") (redirect out " >") (redirect err " 2>")
     5287          (when (and directory (os-unix-p)) ;; NB: unless on Unix, %system uses with-current-directory
     5288            `(" ; cd " ,(escape-shell-token (native-namestring directory))))
    50805289          after)))))
    50875296    (%wait-process-result
    50885297     (apply '%run-program (%normalize-system-command command) :wait t keys))
    5089     #+(or abcl clisp cormanlisp ecl gcl (and lispworks os-windows) mkcl xcl)
     5298    #+(or abcl cormanlisp clisp ecl gcl (and lispworks os-windows) mkcl xcl)
    50905299    (let ((%command (%redirected-system-command command input output error-output directory)))
    50915300      #+(and lispworks os-windows)
    50925301      (system:call-system %command :current-directory directory :wait t)
    5093       #-(and lispworks os-windows)
     5302      #+clisp
     5303      (%wait-process-result
     5304       (apply '%run-program %command :wait t
     5305              :input :interactive :output :interactive :error-output :interactive keys))
     5306      #-(or clisp (and lispworks os-windows))
    50945307      (with-current-directory ((unless (os-unix-p) directory))
    5095         #+(or abcl xcl) (ext:run-shell-command %command)
    5096         #+clisp (clisp-exit-code (ext:shell %command))
     5308        #+abcl (ext:run-shell-command %command)
    50975309        #+cormanlisp (win32:system %command)
    50985310        #+ecl (let ((*standard-input* *stdin*)
    51005312                    (*error-output* *stderr*))
    51015313                (ext:system %command))
    5102         #+gcl (lisp:system %command)
     5314        #+gcl (system:system %command)
    51035315        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
    5104         #+mkcl ;; PROBABLY BOGUS -- ask jcb
    5105         (multiple-value-bind (io process exit-code)
    5106             (mkcl:run-program #+windows %command #+windows ()
    5107                               #-windows "/bin/sh" #-windows (list "-c" %command)
    5108                               :input t :output t)))))
     5316        #+mkcl (mkcl:system %command)
     5317        #+xcl (system:%run-shell-command %command))))
    51105319  (defun %use-system (command &rest keys
    51455354If OUTPUT is a pathname, a string designating a pathname, or NIL designating the null device,
    51465355the file at that path is used as output.
    5147 If it's :INTERACTIVE, output is inherited from the current process.
     5356If it's :INTERACTIVE, output is inherited from the current process;
     5357beware that this may be different from your *STANDARD-OUTPUT*,
     5358and under SLIME will be on your *inferior-lisp* buffer.
     5359If it's T, output goes to your current *STANDARD-OUTPUT* stream.
    51485360Otherwise, OUTPUT should be a value that is a suitable first argument to
    51495361SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
    5150 In this case, RUN-PROGRAM will create a temporary stream for the program output.
    5151 The program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
     5362In this case, RUN-PROGRAM will create a temporary stream for the program output;
     5363the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
    51525364using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
    5153 T designates the *STANDARD-OUTPUT* to be provided to SLURP-INPUT-STREAM.
    51545365The primary value resulting from that call (or NIL if no call was needed)
    51555366will be the first value returned by RUN-PROGRAM.
    51565367E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
     5368And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
     5369stripped of any ending newline.
    51585371ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
    51595372as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
    5160 Also :OUTPUT means redirecting the error output to the output stream, and NIL is returned.
     5373Also :OUTPUT means redirecting the error output to the output stream,
     5374in which case NIL is returned.
    51625376INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
    51635377no value is returned, and T designates the *STANDARD-INPUT*.
    5165 Use ELEMENT-TYPE and EXTERNAL-FORMAT to specify how streams are created.
     5379Use ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
     5380to your Lisp implementation, when applicable, for creation of the output stream.
    51675382One and only one of the stream slurping or vomiting may or may not happen
    5168 in parallel in parallel with the subprocess, depending on options and implementation.
    5169 Other streams are completely produced or consumed before or after the subprocess is spawned,
    5170 using temporary files.
     5383in parallel in parallel with the subprocess,
     5384depending on options and implementation,
     5385and with priority being given to output processing.
     5386Other streams are completely produced or consumed
     5387before or after the subprocess is spawned, using temporary files.
    51725389RUN-PROGRAM returns 3 values:
    51765393or an indication of failure via the EXIT-CODE of the process"
    51775394    (declare (ignorable ignore-error-status))
    5178     #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
     5395    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
    51795396    (error "RUN-PROGRAM not implemented for this Lisp")
    51805397    (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
    51845401                     #+(or abcl clisp) (eq :error-output :output)
    51855402                     #+(and lispworks os-unix) (%interactivep input output error-output)
    5186                      #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) t)
     5403                     #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
    51875404                 '%use-system '%use-run-program)
    51885405             command
    52115428   #:compile-warned-warning #:compile-failed-warning
    52125429   #:check-lisp-compile-results #:check-lisp-compile-warnings
    5213    #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
     5430   #:*uninteresting-conditions* #:*usual-uninteresting-conditions*
     5431   #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
    52145432   ;; Types
    52155433   #+sbcl #:sb-grovel-unknown-constant-condition
    52165434   ;; Functions & Macros
    5217    #:get-optimization-settings #:proclaim-optimization-settings
     5435   #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings
    52185436   #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
    52195437   #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
    52255443   #:current-lisp-file-pathname #:load-pathname
    52265444   #:lispize-pathname #:compile-file-type #:call-around-hook
    5227    #:compile-file* #:compile-file-pathname*
     5445   #:compile-file* #:compile-file-pathname* #:*compile-check*
    52285446   #:load* #:load-from-string #:combine-fasls)
    52295447  (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
    52555473  (defvar *previous-optimization-settings* nil
    52565474    "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
     5475  (defparameter +optimization-variables+
     5476    ;; TODO: allegro genera corman mcl
     5477    (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*)
     5478        #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents)
     5479        #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety*
     5480                    ccl::*nx-debug* ccl::*nx-cspeed*)
     5481        #+(or cmu scl) '(c::*default-cookie*)
     5482        #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
     5483        #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
     5484        #+lispworks '(compiler::*optimization-level*)
     5485        #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*)
     5486        #+sbcl '(sb-c::*policy*)))
    52575487  (defun get-optimization-settings ()
    52585488    "Get current compiler optimization settings, ready to PROCLAIM again"
    5259     #-(or clisp clozure cmu ecl sbcl scl)
    5260     (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type))
    5261     #+clozure (ccl:declaration-information 'optimize nil)
    5262     #+(or clisp cmu ecl sbcl scl)
     5489    #-(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
     5490    (warn "~S does not support ~S. Please help me fix that."
     5491          'get-optimization-settings (implementation-type))
     5492    #+(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
    52635493    (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
    5264       #.`(loop :for x :in settings
    5265                ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
    5266                      #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
    5267                :for y = (or #+clisp (gethash x system::*optimize*)
    5268                             #+(or ecl) (symbol-value v)
    5269                             #+(or cmu scl) (funcall f c::*default-cookie*)
     5494      #.`(loop #+(or allegro clozure)
     5495               ,@'(:with info = #+allegro (sys:declaration-information 'optimize)
     5496                   #+clozure (ccl:declaration-information 'optimize nil))
     5497               :for x :in settings
     5498               ,@(or #+(or abcl ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
     5499               :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
     5500                            #+clisp (gethash x system::*optimize* 1)
     5501                            #+(or abcl ecl mkcl xcl) (symbol-value v)
     5502                            #+(or cmu scl) (slot-value c::*default-cookie*
     5503                                                       (case x (compilation-speed 'c::cspeed)
     5504                                                             (otherwise x)))
     5505                            #+lispworks (slot-value compiler::*optimization-level* x)
    52705506                            #+sbcl (cdr (assoc x sb-c::*policy*)))
    52715507               :when y :collect (list x y))))
    52755511    (let ((settings (get-optimization-settings)))
    52765512      (unless (equal *previous-optimization-settings* settings)
    5277         (setf *previous-optimization-settings* settings)))))
     5513        (setf *previous-optimization-settings* settings))))
     5514  (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body)
     5515    #+(or allegro clisp)
     5516    (let ((previous-settings (gensym "PREVIOUS-SETTINGS")))
     5517      `(let ((,previous-settings (get-optimization-settings)))
     5518         ,@(when settings `((proclaim `(optimize ,@,settings))))
     5519         (unwind-protect (progn ,@body)
     5520           (proclaim `(optimize ,@,previous-settings)))))
     5521    #-(or allegro clisp)
     5522    `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v))
     5523       ,@(when settings `((proclaim `(optimize ,@,settings))))
     5524       ,@body)))
    56985945  (defun check-deferred-warnings (files &optional context-format context-arguments)
    5699     "Given a list of FILES in which deferred warnings were saved by CALL-WITH-DEFERRED-WARNINGS,
     5946    "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
    57005947re-intern and raise any warnings that are still meaningful."
    57015948    (let ((file-errors nil)
    57385985  |#
    5740   (defun call-with-saved-deferred-warnings (thunk warnings-file)
     5987  (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring)
    57415988    "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
    57425989and save those warnings to the given file for latter use,
    57435990possibly in a different process. Otherwise just call THUNK."
     5991    (declare (ignorable source-namestring))
    57445992    (if warnings-file
    5745         (with-compilation-unit (:override t)
     5993        (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring)
    57465994          (unwind-protect
    57475995               (let (#+sbcl (sb-c::*undefined-warnings* nil))
    57526000        (funcall thunk)))
    5754   (defmacro with-saved-deferred-warnings ((warnings-file) &body body)
     6002  (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body)
    57556003    "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
    5756     `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file)))
     6004    `(call-with-saved-deferred-warnings
     6005      #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring)))
    57656014  (defun load-pathname ()
    57666015    "Portably return the LOAD-PATHNAME of the current source file or fasl"
    5767     *load-pathname*) ;; see magic for GCL in uiop/common-lisp
     6016    *load-pathname*) ;; magic no longer needed for GCL.
    57696018  (defun lispize-pathname (input-file)
    57846033    "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
    57856034    (let* ((keys
    5786              (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format
     6035             (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format
    57876036                                    ,@(unless output-file '(:output-file))) keys)))
    57886037      (if (absolute-pathname-p output-file)
    57956044                   (apply 'compile-file-pathname input-file keys)))))
     6046  (defvar *compile-check* nil
     6047    "A hook for user-defined compile-time invariants")
    57976049  (defun* (compile-file*) (input-file &rest keys
    5798                                       &key compile-check output-file warnings-file
     6050                                      &key (compile-check *compile-check*) output-file warnings-file
    57996051                                      #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
    58006052                                      &allow-other-keys)
    58236075    (let* ((keywords (remove-plist-keys
    58246076                      `(:output-file :compile-check :warnings-file
    5825                                      #+clisp :lib-file #+(or ecl mkcl) :object-file
    5826                                      #+gcl2.6 ,@'(:external-format :print :verbose)) keys))
     6077                                     #+clisp :lib-file #+(or ecl mkcl) :object-file) keys))
    58276078           (output-file
    58286079             (or output-file
    58496100           (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
    58506101      (multiple-value-bind (output-truename warnings-p failure-p)
    5851           (with-saved-deferred-warnings (warnings-file)
    5852             (with-muffled-compiler-conditions ()
    5853               (with-enough-pathname (input-file :defaults *base-build-directory*)
     6102          (with-enough-pathname (input-file :defaults *base-build-directory*)
     6103            (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
     6104              (with-muffled-compiler-conditions ()
    58546105                (or #-(or ecl mkcl)
    58556106                    (apply 'compile-file input-file :output-file tmp-file
    58936144  (defun load* (x &rest keys &key &allow-other-keys)
    58946145    "Portable wrapper around LOAD that properly handles loading from a stream."
    5895     (etypecase x
    5896       ((or pathname string #-(or allegro clozure gcl2.6 genera) stream)
    5897        (apply 'load x
    5898               #-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys)))
    5899       ;; GCL 2.6, Genera can't load from a string-input-stream
    5900       ;; ClozureCL 1.6 can only load from file input stream
    5901       ;; Allegro 5, I don't remember but it must have been broken when I tested.
    5902       #+(or allegro clozure gcl2.6 genera)
    5903       (stream ;; make do this way
    5904        (let ((*package* *package*)
    5905              (*readtable* *readtable*)
    5906              (*load-pathname* nil)
    5907              (*load-truename* nil))
    5908          (eval-input x)))))
     6146    (with-muffled-loader-conditions ()
     6147      (etypecase x
     6148        ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
     6149         (apply 'load x keys))
     6150        ;; Genera can't load from a string-input-stream
     6151        ;; ClozureCL 1.6 can only load from file input stream
     6152        ;; Allegro 5, I don't remember but it must have been broken when I tested.
     6153        #+(or allegro clozure genera)
     6154        (stream ;; make do this way
     6155         (let ((*package* *package*)
     6156               (*readtable* *readtable*)
     6157               (*load-pathname* nil)
     6158               (*load-truename* nil))
     6159           (eval-input x))))))
    59106161  (defun load-from-string (string)
    60726323             (unless (= inherit 1)
    60736324               (report-invalid-form invalid-form-reporter
    6074                                     :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
    6075                                                      :inherit-configuration :ignore-inherited-configuration)))
     6325                                    :form form :location location
     6326                                    ;; we throw away the form and location arguments, hence the ~2*
     6327                                    ;; this is necessary because of the report in INVALID-CONFIGURATION
     6328                                    :format (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
     6329                                                        One and only one of ~S or ~S is required.~@:>")
     6330                                    :arguments '(:inherit-configuration :ignore-inherited-configuration)))
    60766331             (return (nreverse x))))
    63036558(uiop/package:define-package :uiop/driver
    63046559  (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils)
    6305   (:use :uiop/common-lisp :uiop/package :uiop/utility
    6306    :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
    6307    :uiop/run-program :uiop/lisp-build
    6308    :uiop/configuration :uiop/backward-driver)
    6309   (:reexport
    6310    ;; NB: excluding uiop/common-lisp
     6560  (:use :uiop/common-lisp)
     6561   ;; NB: not reexporting uiop/common-lisp
    63116562   ;; which include all of CL with compatibility modifications on select platforms,
    63126563   ;; that could cause potential conflicts for packages that would :use (cl uiop)
    63136564   ;; or :use (closer-common-lisp uiop), etc.
     6565  (:use-reexport
    63146566   :uiop/package :uiop/utility
    63156567   :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
    63166568   :uiop/run-program :uiop/lisp-build
    63176569   :uiop/configuration :uiop/backward-driver))
     6571#+mkcl (provide :uiop)
    63186572;;;; -------------------------------------------------------------------------
    63196573;;;; Handle upgrade as forward- and backward-compatibly as possible
    63206574;; See
    6322 (asdf/package:define-package :asdf/upgrade
     6576(uiop/package:define-package :asdf/upgrade
    63236577  (:recycle :asdf/upgrade :asdf)
    63246578  (:use :uiop/common-lisp :uiop)
    63266580   #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
    63276581   #:asdf-message #:*verbose-out*
    6328    #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error
     6582   #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error #:defparameter*
    63296583   #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
    63306584   ;; There will be no symbol left behind!
    63316585   #:intern*)
    6332   (:import-from :asdf/package #:intern* #:find-symbol*))
     6586  (:import-from :uiop/package #:intern* #:find-symbol*))
    63336587(in-package :asdf/upgrade)
    63476601              (cons (format nil "~{~D~^.~}" rev))
    63486602              (null "1.0"))))))
     6603  ;; Important: define *p-a-v* /before/ *a-v* so that it initializes correctly.
     6604  (defvar *previous-asdf-versions* (if-let (previous (asdf-version)) (list previous)))
    63496605  (defvar *asdf-version* nil)
    6350   (defvar *previous-asdf-versions* nil)
     6606  ;; We need to clear systems from versions yet older than the below:
     6607  (defparameter *oldest-forward-compatible-asdf-version* "2.33") ;; 2.32.13 renames a slot in component.
    63516608  (defvar *verbose-out* nil)
    63526609  (defun asdf-message (format-string &rest format-args)
    63546611  (defvar *post-upgrade-cleanup-hook* ())
    63556612  (defvar *post-upgrade-restart-hook* ())
    6356   (defun upgrading-p ()
    6357     (and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*)))))
    6358   (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body)
     6613  (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*))
     6614    (and *previous-asdf-versions*
     6615         (version< (first *previous-asdf-versions*) oldest-compatible-version)))
     6616  (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*))
     6617    (let* ((name (string-trim "*" var))
     6618           (valfun (intern (format nil "%~A-~A-~A" :compute name :value))))
     6619      `(progn
     6620         (defun ,valfun () ,value)
     6621         (defvar ,var (,valfun) ,@(ensure-list docstring))
     6622         (when (upgrading-p ,version)
     6623           (setf ,var (,valfun))))))
     6624  (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*)
     6625                               (upgrading-p `(upgrading-p ,version)) when) &body body)
     6626    "A wrapper macro for code that should only be run when upgrading a
     6627previously-loaded version of ASDF."
    63596628    `(with-upgradability ()
    63606629       (when (and ,upgrading-p ,@(when when `(,when)))
    63646633         ;; Please also modify asdf.asd to reflect this change. make bump-version v=
    63656634         ;; can help you do these changes in synch (look at the source for documentation).
    6366          ;; Relying on its automation, the version is now redundantly present on top of this file.
     6635         ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp.
    63676636         ;; "3.4" would be the general branch for major version 3, minor version 4.
    63686637         ;; "3.4.5" would be an official release in the 3.4 branch.
    6369          ;; "" would be a development version in the official upstream of 3.4.5.
     6638         ;; "" would be a development version in the official branch, on top of 3.4.5.
    63706639         ;; "" would be your eighth local modification of official release 3.4.5
    63716640         ;; "" would be your eighth local modification of development version
    6372          (asdf-version "3.0.3")
     6641         (asdf-version "3.1.2")
    63736642         (existing-version (asdf-version)))
    63746643    (setf *asdf-version* asdf-version)
    63826651(when-upgrading ()
    63836652  (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
     6653          ;; NB: it's too late to do anything about functions in UIOP!
     6654          ;; If you introduce some critically incompatibility there, you must change name.
    63846655          '(#:component-relative-pathname #:component-parent-pathname ;; component
    63856656            #:source-file-type
    63866657            #:find-system #:system-source-file #:system-relative-pathname ;; system
    6387              #:find-component ;; find-component
    6388              #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
    6389              #:component-depends-on #:operation-done-p #:component-depends-on
    6390              #:traverse ;; backward-interface
    6391              #:operate  ;; operate
    6392              #:parse-component-form ;; defsystem
    6393              #:apply-output-translations ;; output-translations
    6394              #:process-output-translations-directive
    6395              #:inherit-source-registry #:process-source-registry ;; source-registry
    6396              #:process-source-registry-directive
    6397              #:trivial-system-p ;; bundle
    6398              ;; NB: it's too late to do anything about uiop functions!
    6399              ))
    6400          (uninterned-symbols
    6401            '(#:*asdf-revision* #:around #:asdf-method-combination
    6402              #:split #:make-collector #:do-dep #:do-one-dep
    6403              #:component-self-dependencies
    6404              #:resolve-relative-location-component #:resolve-absolute-location-component
    6405              #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
    6406     (declare (ignorable redefined-functions uninterned-symbols))
    6407     (loop :for name :in (append redefined-functions)
     6658            #:find-component ;; find-component
     6659            #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
     6660            #:component-depends-on #:operation-done-p #:component-depends-on
     6661            #:traverse ;; backward-interface
     6662            #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan
     6663            #:operate  ;; operate
     6664            #:parse-component-form ;; defsystem
     6665            #:apply-output-translations ;; output-translations
     6666            #:process-output-translations-directive
     6667            #:inherit-source-registry #:process-source-registry ;; source-registry
     6668            #:process-source-registry-directive
     6669            #:trivial-system-p)) ;; bundle
     6670        (redefined-classes
     6671          ;; redefining the classes causes interim circularities
     6672          ;; with the old ASDF during upgrade, and many implementations bork
     6673          '((#:compile-concatenated-source-op (#:operation) ()))))
     6674    (loop :for name :in redefined-functions
    64086675          :for sym = (find-symbol* name :asdf nil) :do
    64096676            (when sym
    64106677              ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
    64116678              #-clisp (fmakunbound sym)))
    6412     (loop :with asdf = (find-package :asdf)
    6413           :for name :in uninterned-symbols
    6414           :for sym = (find-symbol* name :asdf nil)
    6415           :for base-pkg = (and sym (symbol-package sym)) :do
    6416             (when sym
    6417               (cond
    6418                 ((or (eq base-pkg asdf) (not base-pkg))
    6419                  (unintern* sym asdf)
    6420                  (intern* sym asdf))
    6421                 (t
    6422                  (unintern* sym base-pkg)
    6423                  (let ((new (intern* sym base-pkg)))
    6424                    (shadowing-import new asdf))))))))
     6679    (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf))
     6680                         (find-symbol* s p nil)))
     6681             (asyms (l) (mapcar #'asym l)))
     6682      (loop* :for (name superclasses slots) :in redefined-classes
     6683             :for sym = (find-symbol* name :asdf nil)
     6684             :when (and sym (find-class sym))
     6685             :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))))))
    64446705              (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
    64456706                            old-version new-version))
    6446           (call-functions (reverse *post-upgrade-cleanup-hook*))
     6707          ;; In case the previous version was too old to be forward-compatible, clear systems.
     6708          ;; TODO: if needed, we may have to define a separate hook to run
     6709          ;; in case of forward-compatible upgrade.
     6710          ;; Or to move the tests forward-compatibility test inside each hook function?
     6711          (unless (version<= *oldest-forward-compatible-asdf-version* old-version)
     6712            (call-functions (reverse *post-upgrade-cleanup-hook*)))
    64476713          t))))
    64606726;;;; Components
    6462 (asdf/package:define-package :asdf/component
     6728(uiop/package:define-package :asdf/component
    64636729  (:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf)
    64646730  (:use :uiop/common-lisp :uiop :asdf/upgrade)
    64936759   ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
    64946760   #:name #:version #:description #:long-description #:author #:maintainer #:licence
    6495    #:components-by-name #:components
    6496    #:children #:children-by-name #:default-component-class
    6497    #:author #:maintainer #:licence #:source-file #:defsystem-depends-on
     6761   #:components-by-name #:components #:children #:children-by-name
     6762   #:default-component-class #:source-file
     6763   #:defsystem-depends-on ; This symbol retained for backward compatibility.
    64986764   #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
    64996765   #:relative-pathname #:absolute-pathname #:operation-times #:around-compile
    65206786  (defgeneric (setf component-version) (new-version component))
    65216787  (defgeneric component-parent (component))
    6522   (defmethod component-parent ((component null)) (declare (ignorable component)) nil)
     6788  (defmethod component-parent ((component null)) nil)
    65246790  ;; Backward compatible way of computing the FILE-TYPE of a component.
    65416807                       (duplicate-names-name c))))))
    6545 (when-upgrading (:when (find-class 'component nil))
    6546   (defmethod reinitialize-instance :after ((c component) &rest initargs &key)
    6547     (declare (ignorable c initargs)) (values)))
    65496810(with-upgradability ()
    66026863  (defun component-find-path (component)
     6864    "Return a path from a root system to the COMPONENT.
     6865The return value is a list of component NAMES; a list of strings."
    66036866    (check-type component (or null component))
    66046867    (reverse
    66196882;; The tree typically but not necessarily follows the filesystem hierarchy.
    66206883(with-upgradability ()
    6621   (defclass child-component (component) ())
     6884  (defclass child-component (component) ()
     6885    (:documentation "A CHILD-COMPONENT is a component that may be part of
     6886a PARENT-COMPONENT."))
    66236888  (defclass file-component (child-component)
    66486913      :initform nil
    66496914      :initarg :default-component-class
    6650       :accessor module-default-component-class))))
     6915      :accessor module-default-component-class))
     6916  (:documentation "A PARENT-COMPONENT is a component that may have
    66526919(with-upgradability ()
    66616928                  (setf (gethash name hash) c))
    66626929        hash))))
    6664 (when-upgrading (:when (find-class 'module nil))
    6665   (defmethod reinitialize-instance :after ((m module) &rest initargs &key)
    6666     (declare (ignorable m initargs)) (values))
    6667   (defmethod update-instance-for-redefined-class :after
    6668       ((m module) added deleted plist &key)
    6669     (declare (ignorable m added deleted plist))
    6670     (when (and (member 'children added) (member 'components deleted))
    6671       (setf (slot-value m 'children)
    6672             ;; old ECLs provide an alist instead of a plist(!)
    6673             (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist)))
    6674                 (getf plist 'components)))
    6675       (compute-children-by-name m))))
    66776931(with-upgradability ()
    67016955  (defmethod component-relative-pathname ((component component))
    6702     ;; source-file-type is backward-compatibility with ASDF1;
    6703     ;; we ought to be able to extract this from the component alone with COMPONENT-TYPE.
    6704     ;; TODO: track who uses it, and have them not use it anymore.
     6956    ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
     6957    ;; We ought to be able to extract this from the component alone with COMPONENT-TYPE.
     6958    ;; TODO: track who uses it, and have them not use it anymore;
     6959    ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
    67056960    (parse-unix-namestring
    67066961     (or (and (slot-boundp component 'relative-pathname)
    67116966     :defaults (component-parent-pathname component)))
    6713   (defmethod source-file-type ((component parent-component) system)
    6714     (declare (ignorable component system))
     6968  (defmethod source-file-type ((component parent-component) (system parent-component))
    67156969    :directory)
    6717   (defmethod source-file-type ((component file-component) system)
    6718     (declare (ignorable system))
     6971  (defmethod source-file-type ((component file-component) (system parent-component))
    67196972    (file-type component)))
    67446997;;;; version-satisfies
    67456998(with-upgradability ()
     6999  ;; short-circuit testing of null version specifications.
     7000  ;; this is an all-pass, without warning
     7001  (defmethod version-satisfies :around ((c t) (version null))
     7002    t)
    67467003  (defmethod version-satisfies ((c component) version)
    6747     (unless (and version (slot-boundp c 'version))
     7004    (unless (and version (slot-boundp c 'version) (component-version c))
    67487005      (when version
    6749         (warn "Requested version ~S but component ~S has no version" version c))
    6750       (return-from version-satisfies t))
     7006        (warn "Requested version ~S but ~S has no version" version c))
     7007      (return-from version-satisfies nil))
    67517008    (version-satisfies (component-version c) version))
    67707027;;;; Systems
    6772 (asdf/package:define-package :asdf/system
     7029(uiop/package:define-package :asdf/system
    67737030  (:recycle :asdf :asdf/system)
    67747031  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component)
    67797036   #:system-description #:system-long-description
    67807037   #:system-author #:system-maintainer #:system-licence #:system-license
    6781    #:system-defsystem-depends-on
     7038   #:system-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on
    67827039   #:component-build-pathname #:build-pathname
    67837040   #:component-entry-point #:entry-point
    67927049(with-upgradability ()
    67937050  (defgeneric* (find-system) (system &optional error-p))
    6794   (defgeneric* (system-source-file) (system)
     7051  (defgeneric* (system-source-file :supersede #-clisp t #+clisp nil) (system)
    67957052    (:documentation "Return the source file in which system is defined."))
    67967053  (defgeneric component-build-pathname (component))
    67987055  (defgeneric component-entry-point (component))
    67997056  (defmethod component-entry-point ((c component))
    6800     (declare (ignorable c))
    68017057    nil))
    68327088      :initform nil :initarg :entry-point :accessor component-entry-point)
    68337089     (source-file :initform nil :initarg :source-file :accessor system-source-file)
    6834      (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
     7090     (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
     7091                           :initform nil)
     7092     ;; these two are specially set in parse-component-form, so have no :INITARGs.
     7093     (depends-on :reader system-depends-on :initform nil)
     7094     (weakly-depends-on :reader system-weakly-depends-on :initform nil)))
    68367096  (defun reset-system (system &rest keys &key &allow-other-keys)
    68767136  (defmethod component-build-pathname ((c component))
    6877     (declare (ignorable c))
    68787137    nil))
    68817140;;;; Stamp cache
    6883 (asdf/package:define-package :asdf/cache
     7142(uiop/package:define-package :asdf/cache
    68847143  (:use :uiop/common-lisp :uiop :asdf/upgrade)
    68857144  (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
    6886            #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring
     7145           #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
     7146           #:do-asdf-cache #:normalize-namestring
    68877147           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
    68887148(in-package :asdf/cache)
    69017161               (setf (gethash key *asdf-cache*) value-list)
    69027162               value-list)))
     7164  (defun unset-asdf-cache-entry (key)
     7165    (when *asdf-cache*
     7166      (remhash key *asdf-cache*)))
    69047168  (defun consult-asdf-cache (key &optional thunk)
    69137177    `(consult-asdf-cache ,key #'(lambda () ,@body)))
    6915   (defun call-with-asdf-cache (thunk &key override)
    6916     (if (and *asdf-cache* (not override))
    6917         (funcall thunk)
    6918         (let ((*asdf-cache* (make-hash-table :test 'equal)))
    6919           (funcall thunk))))
    6921   (defmacro with-asdf-cache ((&key override) &body body)
    6922     `(call-with-asdf-cache #'(lambda () ,@body) :override ,override))
     7179  (defun call-with-asdf-cache (thunk &key override key)
     7180    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
     7181      (if (and *asdf-cache* (not override))
     7182          (funcall fun)
     7183          (let ((*asdf-cache* (make-hash-table :test 'equal)))
     7184            (funcall fun)))))
     7186  (defmacro with-asdf-cache ((&key key override) &body body)
     7187    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
    69247189  (defun normalize-namestring (pathname)
    69407205  (defun get-file-stamp (file)
    6941     (let ((namestring (normalize-namestring file)))
    6942       (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))
     7206    (when file
     7207      (let ((namestring (normalize-namestring file)))
     7208        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
    69447210;;;; -------------------------------------------------------------------------
    69457211;;;; Finding systems
    6947 (asdf/package:define-package :asdf/find-system
     7213(uiop/package:define-package :asdf/find-system
    69487214  (:recycle :asdf/find-system :asdf)
    69497215  (:use :uiop/common-lisp :uiop :asdf/upgrade
    6950    :asdf/component :asdf/system :asdf/cache)
     7216    :asdf/cache :asdf/component :asdf/system)
    69517217  (:export
    69527218   #:remove-entry-from-registry #:coerce-entry-to-directory
    69537219   #:coerce-name #:primary-system-name #:coerce-filename
    6954    #:find-system #:locate-system #:load-asd #:with-system-definitions
     7220   #:find-system #:locate-system #:load-asd
    69557221   #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
    69567222   #:missing-component #:missing-requires #:missing-parent
    69597225   #:*system-definition-search-functions* #:search-for-system-definition
    69607226   #:*central-registry* #:probe-asd #:sysdef-central-registry-search
    6961    #:find-system-if-being-defined #:*systems-being-defined*
     7227   #:find-system-if-being-defined
    69627228   #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
    69637229   #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
    6964    #:clear-defined-systems #:*defined-systems*
     7230   #:clear-defined-system #:clear-defined-systems #:*defined-systems*
     7231   #:*immutable-systems*
    69657232   ;; defined in source-registry, but specially mentioned here:
    69667233   #:initialize-source-registry #:sysdef-source-registry-search))
    70327299                    system)))))
     7301  (defun clear-defined-system (system)
     7302    (let ((name (coerce-name system)))
     7303      (remhash name *defined-systems*)
     7304      (unset-asdf-cache-entry `(locate-system ,name))
     7305      (unset-asdf-cache-entry `(find-system ,name))
     7306      nil))
    70347308  (defun clear-defined-systems ()
    70357309    ;; Invalidate all systems but ASDF itself, if registered.
    7036     (let ((asdf (cdr (system-registered-p :asdf))))
    7037       (setf *defined-systems* (make-hash-table :test 'equal))
    7038       (when asdf
    7039         (setf (component-version asdf) *asdf-version*)
    7040         (setf (builtin-system-p asdf) t)
    7041         (register-system asdf)))
    7042     (values))
     7310    (loop :for name :being :the :hash-keys :of *defined-systems*
     7311          :unless (equal name "asdf")
     7312            :do (clear-defined-system name)))
    70447314  (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
    70827352  (defun search-for-system-definition (system)
    7083     (block ()
    7084       (let ((name (coerce-name system)))
    7085         (flet ((try (f) (if-let ((x (funcall f name))) (return x))))
    7086           (try 'find-system-if-being-defined)
    7087           (map () #'try *system-definition-search-functions*)
    7088           (try 'sysdef-preloaded-system-search)))))
     7353    (let ((name (coerce-name system)))
     7354      (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
     7355        (try 'find-system-if-being-defined)
     7356        (try 'sysdef-immutable-system-search)
     7357        (map () #'try *system-definition-search-functions*)
     7358        (try 'sysdef-preloaded-system-search))))
    70907360  (defvar *central-registry* nil
    71217391                   :type "lnk")))
    71227392            (when (probe-file* shortcut)
    7123               (let ((target (parse-windows-shortcut shortcut)))
    7124                 (when target
    7125                   (return (pathname target))))))))))
     7393              (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))
    71277395  (defun sysdef-central-registry-search (system)
    71887456    (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
    7190   (register-preloaded-system "asdf" :version *asdf-version*)
    7191   (register-preloaded-system "uiop" :version *asdf-version*)
    7192   (register-preloaded-system "asdf-driver" :version *asdf-version*)
    7193   (register-preloaded-system "asdf-defsystem" :version *asdf-version*)
     7458  (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
     7459    ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
     7460    (register-preloaded-system s :version *asdf-version*))
    71957462  (defmethod find-system ((name null) &optional (error-p t))
    7196     (declare (ignorable name))
    71977463    (when error-p
    71987464      (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
    72017467    (find-system (coerce-name name) error-p))
    7203   (defvar *systems-being-defined* nil
    7204     "A hash-table of systems currently being defined keyed by name, or NIL")
    72067469  (defun find-system-if-being-defined (name)
    7207     (when *systems-being-defined*
    7208       ;; notable side effect: mark the system as being defined, to avoid infinite loops
    7209       (ensure-gethash (coerce-name name) *systems-being-defined* nil)))
    7211   (defun call-with-system-definitions (thunk)
    7212     (if *systems-being-defined*
    7213         (call-with-asdf-cache thunk)
    7214         (let ((*systems-being-defined* (make-hash-table :test 'equal)))
    7215           (call-with-asdf-cache thunk))))
    7217   (defun clear-systems-being-defined ()
    7218     (when *systems-being-defined*
    7219       (clrhash *systems-being-defined*)))
    7221   (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined)
    7223   (defmacro with-system-definitions ((&optional) &body body)
    7224     `(call-with-system-definitions #'(lambda () ,@body)))
     7470    ;; notable side effect: mark the system as being defined, to avoid infinite loops
     7471    (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
    72267473  (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
    72277474    ;; Tries to load system definition with canonical NAME from PATHNAME.
    7228     (with-system-definitions ()
     7475    (with-asdf-cache ()
    72297476      (with-standard-io-syntax
    72307477        (let ((*package* (find-package :asdf-user))
    72467493            (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
    72477494                          name pathname)
    7248             (with-muffled-loader-conditions ()
    7249               (load* pathname :external-format external-format)))))))
     7495            (load* pathname :external-format external-format))))))
    72517497  (defvar *old-asdf-systems* (make-hash-table :test 'equal))
    72587504                             (read-file-form version-pathname)))
    72597505               (old-version (asdf-version)))
    7260           (or (version<= old-version version)
    7261               (ensure-gethash
    7262                (list pathname old-version) *old-asdf-systems*
    7263                  #'(lambda ()
    7264                      (let ((old-pathname
    7265                              (if-let (pair (system-registered-p "asdf"))
    7266                                (system-source-file (cdr pair)))))
    7267                        (warn "~@<~
     7506          (cond
     7507            ((version< old-version version) t) ;; newer version: good!
     7508            ((equal old-version version) nil) ;; same version: don't load, but don't warn
     7509            (t ;; old version: bad
     7510             (ensure-gethash
     7511              (list (namestring pathname) version) *old-asdf-systems*
     7512              #'(lambda ()
     7513                 (let ((old-pathname
     7514                         (if-let (pair (system-registered-p "asdf"))
     7515                           (system-source-file (cdr pair)))))
     7516                   (warn "~@<~
    72687517        You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
    72697518        or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
    72877536        or use :ignore-inherited-configuration to avoid registering the old one. ~
    72887537        Please consult ASDF documentation and/or experts.~@:>~%"
    7289                              old-version old-pathname version pathname)
    7290                        t)))))))
     7538                         old-version old-pathname version pathname))))
     7539             nil))))) ;; only issue the warning the first time, but always return nil
     7541  (defvar *immutable-systems* nil
     7542    "An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
     7543i.e. already loaded in memory and not to be refreshed from the filesystem.
     7544They will be treated specially by find-system, and passed as :force-not argument to make-plan.
     7546If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
     7547for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
     7548downgrade, before you dump an image, use:
     7549   (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
     7551  (defun sysdef-immutable-system-search (requested)
     7552    (let ((name (coerce-name requested)))
     7553      (when (and *immutable-systems* (gethash name *immutable-systems*))
     7554        (or (cdr (system-registered-p requested))
     7555            (error 'formatted-system-definition-error
     7556                   :format-control "Requested system ~A is in the *immutable-systems* set, ~
     7557but not loaded in memory"
     7558                   :format-arguments (list name))))))
    72927560  (defun locate-system (name)
    73007568PREVIOUS when not null is a previously loaded SYSTEM object of same name.
    73017569PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
    7302     (let* ((name (coerce-name name))
    7303            (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    7304            (previous (cdr in-memory))
    7305            (previous (and (typep previous 'system) previous))
    7306            (previous-time (car in-memory))
    7307            (found (search-for-system-definition name))
    7308            (found-system (and (typep found 'system) found))
    7309            (pathname (ensure-pathname
    7310                       (or (and (typep found '(or pathname string)) (pathname found))
    7311                           (and found-system (system-source-file found-system))
    7312                           (and previous (system-source-file previous)))
    7313                      :want-absolute t :resolve-symlinks *resolve-symlinks*))
    7314            (foundp (and (or found-system pathname previous) t)))
    7315       (check-type found (or null pathname system))
    7316       (unless (check-not-old-asdf-system name pathname)
    7317         (cond
    7318           (previous (setf found nil pathname nil))
    7319           (t
    7320            (setf found (sysdef-preloaded-system-search "asdf"))
    7321            (assert (typep found 'system))
    7322            (setf found-system found pathname nil))))
    7323       (values foundp found-system pathname previous previous-time)))
     7570    (with-asdf-cache (:key `(locate-system ,name))
     7571      (let* ((name (coerce-name name))
     7572             (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
     7573             (previous (cdr in-memory))
     7574             (previous (and (typep previous 'system) previous))
     7575             (previous-time (car in-memory))
     7576             (found (search-for-system-definition name))
     7577             (found-system (and (typep found 'system) found))
     7578             (pathname (ensure-pathname
     7579                        (or (and (typep found '(or pathname string)) (pathname found))
     7580                            (and found-system (system-source-file found-system))
     7581                            (and previous (system-source-file previous)))
     7582                        :want-absolute t :resolve-symlinks *resolve-symlinks*))
     7583             (foundp (and (or found-system pathname previous) t)))
     7584        (check-type found (or null pathname system))
     7585        (unless (check-not-old-asdf-system name pathname)
     7586          (cond
     7587            (previous (setf found nil pathname nil))
     7588            (t
     7589             (setf found (sysdef-preloaded-system-search "asdf"))
     7590             (assert (typep found 'system))
     7591             (setf found-system found pathname nil))))
     7592        (values foundp found-system pathname previous previous-time))))
    73257594  (defmethod find-system ((name string) &optional (error-p t))
    7326     (with-system-definitions ()
     7595    (with-asdf-cache (:key `(find-system ,name))
    73277596      (let ((primary-name (primary-system-name name)))
    7328         (unless (or (equal name primary-name)
    7329                     (nth-value 1 (gethash primary-name *systems-being-defined*)))
     7597        (unless (equal name primary-name)
    73307598          (find-system primary-name nil)))
    73317599      (loop
    73337601            (multiple-value-bind (foundp found-system pathname previous previous-time)
    73347602                (locate-system name)
     7603              (when (and found-system (eq found-system previous)
     7604                         (or (first (gethash `(find-system ,name) *asdf-cache*))
     7605                             (and *immutable-systems* (gethash name *immutable-systems*))))
     7606                (return found-system))
    73357607              (assert (eq foundp (and (or found-system pathname previous) t)))
    73367608              (let ((previous-pathname (and previous (system-source-file previous)))
    73647636            :report (lambda (s)
    73657637                      (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
     7638            (unset-asdf-cache-entry `(locate-system ,name))
    73667639            (initialize-source-registry)))))))
    73697642;;;; Finding components
    7371 (asdf/package:define-package :asdf/find-component
     7644(uiop/package:define-package :asdf/find-component
    73727645  (:recycle :asdf/find-component :asdf)
    7373   (:use :uiop/common-lisp :uiop :asdf/upgrade
     7646  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
    73747647   :asdf/component :asdf/system :asdf/find-system)
    73757648  (:export
    74477720    (find-component (find-component c (car name)) (cdr name)))
    7449   (defmethod find-component (base (actual component))
    7450     (declare (ignorable base))
     7722  (defmethod find-component ((base t) (actual component))
    74517723    actual)
    74757747                (and (typep c 'missing-dependency)
    74767748                     (eq (missing-required-by c) component)
    7477                      (equal (missing-requires c) name))))))))
     7749                     (equal (missing-requires c) name))))
     7750          (unless (component-parent component)
     7751            (let ((name (coerce-name name)))
     7752              (unset-asdf-cache-entry `(find-system ,name))
     7753              (unset-asdf-cache-entry `(locate-system ,name))))))))
    74797756  (defun resolve-dependency-spec (component dep-spec)
    74897766  (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
    7490     (declare (ignorable combinator))
    74917767    (when (featurep (first arguments))
    74927768      (resolve-dependency-spec component (second arguments))))
    74947770  (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
    7495     (declare (ignorable combinator)) ;; See
    7496     (resolve-dependency-name component (first arguments) (second arguments))))
     7771    (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788
    74987773;;;; -------------------------------------------------------------------------
    74997774;;;; Operations
    7501 (asdf/package:define-package :asdf/operation
     7776(uiop/package:define-package :asdf/operation
    75027777  (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
    7503   (:use :uiop/common-lisp :uiop :asdf/upgrade)
     7778  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
    75047779  (:export
    75057780   #:operation
    75067781   #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
    7507    #:build-op ;; THE generic operation
    7508    #:*operations* #:make-operation #:find-operation #:feature))
     7782   #:*operations* #:make-operation #:find-operation
     7783   #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature.
    75097784(in-package :asdf/operation)
    75137788(when-upgrading (:when (find-class 'operation nil))
    7514   (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key)
    7515     (declare (ignorable o slot-names initargs)) (values)))
     7789  ;; override any obsolete shared-initialize method when upgrading from ASDF2.
     7790  (defmethod shared-initialize :after ((o operation) (slot-names t) &key)
     7791    (values)))
    75177793(with-upgradability ()
    75207796      :initform nil :initarg :original-initargs :accessor operation-original-initargs)))
     7798  ;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not
     7799  ;; already bound.
    75227800  (defmethod initialize-instance :after ((o operation) &rest initargs
    75237801                                         &key force force-not system verbose &allow-other-keys)
    7524     (declare (ignorable force force-not system verbose))
     7802    (declare (ignore force force-not system verbose))
    75257803    (unless (slot-boundp o 'original-initargs)
    75267804      (setf (operation-original-initargs o) initargs)))
    75357813(with-upgradability ()
    7536   (defparameter *operations* (make-hash-table :test 'equal))
     7814  (defparameter* *operations* (make-hash-table :test 'equal))
    75377816  (defun make-operation (operation-class &rest initargs)
    7538     (ensure-gethash (cons operation-class initargs) *operations*
    7539                     (list* 'make-instance operation-class initargs)))
     7817    (let ((class (coerce-class operation-class
     7818                               :package :asdf/interface :super 'operation :error 'sysdef-error)))
     7819      (ensure-gethash (cons class initargs) *operations*
     7820                      (list* 'make-instance class initargs))))
    75417822  (defgeneric find-operation (context spec)
    75427823    (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
    7543   (defmethod find-operation (context (spec operation))
    7544     (declare (ignorable context))
     7824  (defmethod find-operation ((context t) (spec operation))
    75457825    spec)
    75467826  (defmethod find-operation (context (spec symbol))
    7547     (unless (member spec '(nil feature))
    7548       ;; NIL designates itself, i.e. absence of operation
    7549       ;; FEATURE is the ASDF1 misfeature that comes with IF-COMPONENT-DEP-FAILS
     7827    (when spec ;; NIL designates itself, i.e. absence of operation
    75507828      (apply 'make-operation spec (operation-original-initargs context))))
     7829  (defmethod find-operation (context (spec string))
     7830    (apply 'make-operation spec (operation-original-initargs context)))
    75517831  (defmethod operation-original-initargs ((context symbol))
    75527832    (declare (ignorable context))
    7553     nil)
    7555   (defclass build-op (operation) ()))
     7833    nil))
    75587835;;;; -------------------------------------------------------------------------
    75597836;;;; Actions
    7561 (asdf/package:define-package :asdf/action
     7838(uiop/package:define-package :asdf/action
    75627839  (:nicknames :asdf-action)
    75637840  (:recycle :asdf/action :asdf)
    75677844   #:action #:define-convenience-action-methods
    75687845   #:explain #:action-description
    7569    #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
     7846   #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
    75707847   #:component-depends-on
    75717848   #:input-files #:output-files #:output-file #:operation-done-p
    75747851   #:perform #:perform-with-restarts #:retry #:accept
    75757852   #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
    7576    #:action-path #:find-action #:stamp #:done-p))
     7853   #:action-path #:find-action #:stamp #:done-p
     7854   #:operation-definition-warning #:operation-definition-error ;; condition
     7855   ))
    75777856(in-package :asdf/action)
    7579 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
    7580   (deftype action () '(cons operation component))) ;; a step to be performed while building
     7858(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
     7859  (deftype action () '(cons operation component)) ;; a step to be performed while building
     7861  (deftype operation-designator ()
     7862    ;; an operation designates itself,
     7863    ;; nil designates a context-dependent current operation, and
     7864    ;; class-name or class designates an instance of the designated class.
     7865    '(or operation null symbol class)))
    75827867(with-upgradability ()
    76157900                   `(,function ,@prefix ,o ,c ,@suffix))))
    76167901        `(progn
    7617            (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args)
     7902           (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args)
     7903             (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on
     7904               ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component)))
     7905           (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args)
    76187906             (if ,operation
    76197907                 ,(next-method
    76647952        FIND-COMPONENT in the context of the COMPONENT argument,
    76657953        and means that the component depends on
    7666         <operation> having been performed on each <component>; or
    7668       (FEATURE <feature>), which means that the component depends
    7669         on the <feature> expression satisfying FEATUREP.
    7670         (This is DEPRECATED -- use :IF-FEATURE instead.)
     7954        <operation> having been performed on each <component>;
     7956        [Note: an <operation> is an operation designator -- it can be either an
     7957        operation name or an operation object.  Similarly, a <component> may be
     7958        a component name or a component object.  Also note that, the degenerate
     7959        case of (<operation>) is a no-op.]
    76727961    Methods specialized on subclasses of existing component types
    76767965  (defmethod component-depends-on :around ((o operation) (c component))
    76777966    (do-asdf-cache `(component-depends-on ,o ,c)
    7678       (call-next-method)))
    7680   (defmethod component-depends-on ((o operation) (c component))
    7681     (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies
    7684 ;;;; upward-operation, downward-operation
    7685 ;; These together handle actions that propagate along the component hierarchy.
    7686 ;; Downward operations like load-op or compile-op propagate down the hierarchy:
    7687 ;; operation on a parent depends-on operation on its children.
    7688 ;; By default, an operation propagates itself, but it may propagate another one instead.
     7967      (call-next-method))))
     7970;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
     7971;; These together handle actions that propagate along the component hierarchy or operation universe.
    76897972(with-upgradability ()
    76907973  (defclass downward-operation (operation)
    76917974    ((downward-operation
    7692       :initform nil :initarg :downward-operation :reader downward-operation :allocation :class)))
     7975      :initform nil :reader downward-operation
     7976      :type operation-designator :allocation :class))
     7977    (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy.
     7978I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then
     7979the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M.
     7980The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself.
     7981E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the
     7982children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP."))
     7983  (defun downward-operation-depends-on (o c)
     7984    `((,(or (downward-operation o) o) ,@(component-children c))))
    76937985  (defmethod component-depends-on ((o downward-operation) (c parent-component))
    7694     `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
    7695   ;; Upward operations like prepare-op propagate up the component hierarchy:
    7696   ;; operation on a child depends-on operation on its parent.
    7697   ;; By default, an operation propagates itself, but it may propagate another one instead.
     7986    `(,@(downward-operation-depends-on o c) ,@(call-next-method)))
    76987988  (defclass upward-operation (operation)
    76997989    ((upward-operation
    7700       :initform nil :initarg :downward-operation :reader upward-operation :allocation :class)))
     7990      :initform nil :reader upward-operation
     7991      :type operation-designator :allocation :class))
     7992    (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy.
     7993I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U,
     7994then the action (O . C) of O on a component C that has the parent P will depends on (U . P).
     7995The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself.
     7996E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT
     7997must first be prepared for loading or compiling with PREPARE-OP."))
    77017998  ;; For backward-compatibility reasons, a system inherits from module and is a child-component
    77027999  ;; so we must guard against this case. ASDF4: remove that.
     8000  (defun upward-operation-depends-on (o c)
     8001    (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))))
    77038002  (defmethod component-depends-on ((o upward-operation) (c child-component))
    7704     `(,@(if-let (p (component-parent c))
    7705           `((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
    7706   ;; Sibling operations propagate to siblings in the component hierarchy:
    7707   ;; operation on a child depends-on operation on its parent.
    7708   ;; By default, an operation propagates itself, but it may propagate another one instead.
     8003    `(,@(upward-operation-depends-on o c) ,@(call-next-method)))
    77098005  (defclass sideway-operation (operation)
    77108006    ((sideway-operation
    7711       :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class)))
     8007      :initform nil :reader sideway-operation
     8008      :type operation-designator :allocation :class))
     8009    (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings
     8010that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot
     8011designates operation S (where NIL designates O itself), then the action (O . C) of O on component C
     8012depends on each of (S . D) where D is a declared dependency of C.
     8013E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP,
     8014each of its declared dependencies must first be loaded as by LOAD-OP."))
     8015  (defun sideway-operation-depends-on (o c)
     8016    `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c))))
    77128017  (defmethod component-depends-on ((o sideway-operation) (c component))
    7713     `((,(or (sideway-operation o) o)
    7714        ,@(loop :for dep :in (component-sideway-dependencies c)
    7715                :collect (resolve-dependency-spec c dep)))
    7716       ,@(call-next-method)))
    7717   ;; Selfward operations propagate to themselves a sub-operation:
    7718   ;; they depend on some other operation being acted on the same component.
     8018    `(,@(sideway-operation-depends-on o c) ,@(call-next-method)))
    77198020  (defclass selfward-operation (operation)
    77208021    ((selfward-operation
    7721       :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class)))
     8022      ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which
     8023      :type (or operation-designator list) :reader selfward-operation :allocation :class))
     8024    (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
     8025I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L,
     8026then the action (O . C) of O on component C depends on each (S . C) for S in L.
     8027E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
     8028A operation-designator designates a singleton list of the designated operation;
     8029a list of operation-designators designates the list of designated operations;
     8030NIL is not a valid operation designator in that context.  Note that any dependency
     8031ordering between the operations in a list of SELFWARD-OPERATION should be specified separately
     8032in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly."))
     8033  (defun selfward-operation-depends-on (o c)
     8034    (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)))
    77228035  (defmethod component-depends-on ((o selfward-operation) (c component))
    7723     `(,@(loop :for op :in (ensure-list (selfward-operation o))
    7724               :collect `(,op ,c))
    7725       ,@(call-next-method))))
     8036    `(,@(selfward-operation-depends-on o c) ,@(call-next-method)))
     8038  (defclass non-propagating-operation (operation)
     8039    ()
     8040    (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
     8041no dependencies whatsoever.  It is supplied in order that the programmer be able
     8042to specify that s/he is intentionally specifying an operation which invokes no
     8047;;; Help programmers catch obsolete OPERATION subclasses
     8049(with-upgradability ()
     8050  (define-condition operation-definition-warning (simple-warning)
     8051    ()
     8052    (:documentation "Warning condition related to definition of obsolete OPERATION objects."))
     8054  (define-condition operation-definition-error (simple-error)
     8055    ()
     8056    (:documentation "Error condition related to definition of incorrect OPERATION objects."))
     8058  (defmethod initialize-instance :before ((o operation) &key)
     8059    (unless (typep o '(or downward-operation upward-operation sideway-operation
     8060                          selfward-operation non-propagating-operation))
     8061      (warn 'operation-definition-warning
     8062            :format-control
     8063            "No dependency propagating scheme specified for operation class ~S.
     8064The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins."
     8065            :format-arguments (list (type-of o)))))
     8067  (defmethod initialize-instance :before ((o non-propagating-operation) &key)
     8068    (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation))
     8069      (error 'operation-definition-error
     8070             :format-control
     8071             "Inconsistent class: ~S
     8072  NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses."
     8073             :format-arguments
     8074             (list (type-of o)))))
     8076  (defmethod component-depends-on ((o operation) (c component))
     8077    `(;; Normal behavior, to allow user-specified in-order-to dependencies
     8078      ,@(cdr (assoc (type-of o) (component-in-order-to c)))
     8079      ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation
     8080      ;; or non-propagation through an appropriate mixin will be downward and sideway.
     8081      ,@(unless (typep o '(or downward-operation upward-operation sideway-operation
     8082                              selfward-operation non-propagating-operation))
     8083          `(,@(sideway-operation-depends-on o c)
     8084            ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))))
     8086  (defmethod downward-operation ((o operation)) nil)
     8087  (defmethod sideway-operation ((o operation)) nil))
     8091;;; End of OPERATION class checking
    77388105  (defmethod operation-done-p ((o operation) (c component))
    7739     (declare (ignorable o c))
    77408106    t)
    77598125       t)))
    77608126  (defmethod output-files ((o operation) (c component))
    7761     (declare (ignorable o c))
    77628127    nil)
    77638128  (defun output-file (operation component)
    77748139  (defmethod input-files ((o operation) (c component))
    7775     (declare (ignorable o c))
    77768140    nil)
    78398203    (mark-operation-done o c))
    78408204  (defmethod perform ((o operation) (c parent-component))
    7841     (declare (ignorable o c))
    78428205    nil)
    78438206  (defmethod perform ((o operation) (c source-file))
    7844     (sysdef-error
    7845      (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
    7846      (class-of o) (class-of c)))
     8207    ;; For backward compatibility, don't error on operations that don't specify propagation.
     8208    (when (typep o '(or downward-operation upward-operation sideway-operation
     8209                     selfward-operation non-propagating-operation))
     8210      (sysdef-error
     8211       (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>")
     8212       'perform (cons o c))))
    78488214  (defmethod perform-with-restarts (operation component)
    78678233          (mark-operation-done operation component)
    78688234          (return))))))
    7870 ;;; Generic build operation
    7871 (with-upgradability ()
    7872   (defmethod component-depends-on ((o build-op) (c component))
    7873     `((,(or (component-build-operation c) 'load-op) ,c))))
    78758235;;;; -------------------------------------------------------------------------
    78768236;;;; Actions to build Common Lisp software
    7878 (asdf/package:define-package :asdf/lisp-action
     8238(uiop/package:define-package :asdf/lisp-action
    78798239  (:recycle :asdf/lisp-action :asdf)
    78808240  (:intern #:proclamations #:flags)
    79138273(with-upgradability ()
    79148274  (defclass prepare-op (upward-operation sideway-operation)
    7915     ((sideway-operation :initform 'load-op)))
    7916   (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation)
     8275    ((sideway-operation :initform 'load-op :allocation :class))
     8276    (:documentation "Load dependencies necessary for COMPILE-OP or LOAD-OP of a given COMPONENT."))
     8277  (defclass load-op (basic-load-op downward-operation selfward-operation)
    79178278    ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
    79188279    ;; so we need to directly depend on prepare-op for its side-effects in the current image.
    7919     ((selfward-operation :initform '(prepare-op compile-op))))
     8280    ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)))
    79208281  (defclass compile-op (basic-compile-op downward-operation selfward-operation)
    7921     ((selfward-operation :initform 'prepare-op)
    7922      (downward-operation :initform 'load-op)))
     8282    ((selfward-operation :initform 'prepare-op :allocation :class)))
    79248284  (defclass prepare-source-op (upward-operation sideway-operation)
    7925     ((sideway-operation :initform 'load-source-op)))
     8285    ((sideway-operation :initform 'load-source-op :allocation :class)))
    79268286  (defclass load-source-op (basic-load-op downward-operation selfward-operation)
    7927     ((selfward-operation :initform 'prepare-source-op)))
     8287    ((selfward-operation :initform 'prepare-source-op :allocation :class)))
    79298289  (defclass test-op (selfward-operation)
    7930     ((selfward-operation :initform 'load-op))))
     8290    ((selfward-operation :initform 'load-op :allocation :class))))
    79368296(with-upgradability ()
    79378297  (defmethod action-description ((o prepare-op) (c component))
    7938     (declare (ignorable o))
    79398298    (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
    79408299  (defmethod perform ((o prepare-op) (c component))
    7941     (declare (ignorable o c))
    7942     nil)
    7943   (defmethod input-files ((o prepare-op) (c component))
    7944     (declare (ignorable o c))
    79458300    nil)
    79468301  (defmethod input-files ((o prepare-op) (s system))
    7947     (declare (ignorable o))
    79488302    (if-let (it (system-source-file s)) (list it))))
    79518305(with-upgradability ()
    79528306  (defmethod action-description ((o compile-op) (c component))
    7953     (declare (ignorable o))
    79548307    (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
    79558308  (defmethod action-description ((o compile-op) (c parent-component))
    7956     (declare (ignorable o))
    79578309    (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
    79588310  (defgeneric call-with-around-compile-hook (component thunk))
    79758327            (call-with-around-compile-hook
    79768328             c #'(lambda (&rest flags)
    7977                    (with-muffled-compiler-conditions ()
    7978                      (apply 'compile-file* input-file
    7979                             :output-file output-file
    7980                             :external-format (component-external-format c)
    7981                             :warnings-file warnings-file
    7982                             (append
    7983                              #+clisp (list :lib-file lib-file)
    7984                              #+(or ecl mkcl) (list :object-file object-file)
    7985                              flags (compile-op-flags o)))))))
     8329                   (apply 'compile-file* input-file
     8330                          :output-file output-file
     8331                          :external-format (component-external-format c)
     8332                          :warnings-file warnings-file
     8333                          (append
     8334                           #+clisp (list :lib-file lib-file)
     8335                           #+(or ecl mkcl) (list :object-file object-file)
     8336                           flags (compile-op-flags o))))))
    79868337        (check-lisp-compile-results output warnings-p failure-p
    79878338                                    "~/asdf-action::format-action/" (list (cons o c))))))
    80218372    (lisp-compilation-output-files o c))
    80228373  (defmethod perform ((o compile-op) (c static-file))
    8023     (declare (ignorable o c))
    8024     nil)
    8025   (defmethod output-files ((o compile-op) (c static-file))
    8026     (declare (ignorable o c))
    80278374    nil)
    80288375  (defmethod perform ((o compile-op) (c system))
    80448391(with-upgradability ()
    80458392  (defmethod action-description ((o load-op) (c cl-source-file))
    8046     (declare (ignorable o))
    80478393    (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
    80488394  (defmethod action-description ((o load-op) (c parent-component))
    8049     (declare (ignorable o))
    80508395    (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
    8051   (defmethod action-description ((o load-op) component)
    8052     (declare (ignorable o))
    8053     (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
    8054             component))
     8396  (defmethod action-description ((o load-op) (c component))
     8397    (format nil (compatfmt "~@<loading ~3i~_~A~@:>") c))
    80558398  (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
    80568399    (loop
    80648407  (defun perform-lisp-load-fasl (o c)
    80658408    (if-let (fasl (first (input-files o c)))
    8066       (with-muffled-loader-conditions () (load* fasl))))
     8409      (load* fasl)))
    80678410  (defmethod perform ((o load-op) (c cl-source-file))
    80688411    (perform-lisp-load-fasl o c))
    80698412  (defmethod perform ((o load-op) (c static-file))
    8070     (declare (ignorable o c))
    80718413    nil))
    80778419(with-upgradability ()
    80788420  (defmethod action-description ((o prepare-source-op) (c component))
    8079     (declare (ignorable o))
    80808421    (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
    8081   (defmethod input-files ((o prepare-source-op) (c component))
    8082     (declare (ignorable o c))
    8083     nil)
    80848422  (defmethod input-files ((o prepare-source-op) (s system))
    8085     (declare (ignorable o))
    80868423    (if-let (it (system-source-file s)) (list it)))
    80878424  (defmethod perform ((o prepare-source-op) (c component))
    8088     (declare (ignorable o c))
    80898425    nil))
    80918427;;; load-source-op
    80928428(with-upgradability ()
    8093   (defmethod action-description ((o load-source-op) c)
    8094     (declare (ignorable o))
     8429  (defmethod action-description ((o load-source-op) (c component))
    80958430    (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
    80968431  (defmethod action-description ((o load-source-op) (c parent-component))
    8097     (declare (ignorable o))
    80988432    (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
    80998433  (defun perform-lisp-load-source (o c)
    81008434    (call-with-around-compile-hook
    81018435     c #'(lambda ()
    8102            (with-muffled-loader-conditions ()
    8103              (load* (first (input-files o c))
    8104                     :external-format (component-external-format c))))))
     8436           (load* (first (input-files o c))
     8437                  :external-format (component-external-format c)))))
    81068439  (defmethod perform ((o load-source-op) (c cl-source-file))
    81078440    (perform-lisp-load-source o c))
    81088441  (defmethod perform ((o load-source-op) (c static-file))
    8109     (declare (ignorable o c))
    8110     nil)
    8111   (defmethod output-files ((o load-source-op) (c component))
    8112     (declare (ignorable o c))
    81138442    nil))
    81178446(with-upgradability ()
    81188447  (defmethod perform ((o test-op) (c component))
    8119     (declare (ignorable o c))
    81208448    nil)
    81218449  (defmethod operation-done-p ((o test-op) (c system))
    81228450    "Testing a system is _never_ done."
    8123     (declare (ignorable o c))
    81248451    nil))
    81278454;;;; Plan
    8129 (asdf/package:define-package :asdf/plan
     8456(uiop/package:define-package :asdf/plan
    81308457  (:recycle :asdf/plan :asdf)
    81318458  (:use :uiop/common-lisp :uiop :asdf/upgrade
    81358462  (:export
    81368463   #:component-operation-time #:mark-operation-done
    8137    #:plan-traversal #:sequential-plan #:*default-plan-class*
     8464   #:plan #:plan-traversal #:sequential-plan #:*default-plan-class*
    81388465   #:planned-action-status #:plan-action-status #:action-already-done-p
    81398466   #:circular-dependency #:circular-dependency-actions
    81438470   #:normalize-forced-systems #:action-forced-p #:action-forced-not-p
    81448471   #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
    8145    #:visit-dependencies #:compute-action-stamp #:traverse-action
     8472   #:compute-action-stamp #:traverse-action
    81468473   #:circular-dependency #:circular-dependency-actions
    81478474   #:call-while-visiting-action #:while-visiting-action
    81588485;;;; Generic plan traversal class
    81598486(with-upgradability ()
    8160   (defclass plan-traversal ()
     8487  (defclass plan () ())
     8488  (defclass plan-traversal (plan)
    81618489    ((system :initform nil :initarg :system :accessor plan-system)
    81628490     (forced :initform nil :initarg :force :accessor plan-forced)
    81948522        (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p :index index))))
    8196   (defmethod action-planned-p (action-status)
    8197     (declare (ignorable action-status)) ; default method for non planned-action-status objects
    8198     t)
     8524  (defmethod action-planned-p ((action-status t))
     8525    t) ; default method for non planned-action-status objects
    82008527  ;; TODO: eliminate NODE-FOR, use CONS.
    82088535  (defmethod plan-action-status ((plan null) (o operation) (c component))
    8209     (declare (ignorable plan))
    82108536    (multiple-value-bind (stamp done-p) (component-operation-time o c)
    82118537      (make-instance 'action-status :stamp stamp :done-p done-p)))
    82138539  (defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component))
    8214     (declare (ignorable plan))
    82158540    (let ((to (type-of o))
    82168541          (times (component-operation-times c)))
    82288553  (defun normalize-forced-systems (x system)
    82298554    (etypecase x
    8230       ((member nil :all) x)
     8555      ((or (member nil :all) hash-table function) x)
    82318556      (cons (list-to-hash-set (mapcar #'coerce-name x)))
    82328557      ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
     8559  (defun normalize-forced-not-systems (x system)
     8560    (let ((requested
     8561            (etypecase x
     8562              ((or (member nil :all) hash-table function) x)
     8563              (cons (list-to-hash-set (mapcar #'coerce-name x)))
     8564              ((eql t) (if system (let ((name (coerce-name system)))
     8565                                    #'(lambda (x) (not (equal x name))))
     8566                           t)))))
     8567      (if (and *immutable-systems* requested)
     8568          #'(lambda (x) (or (call-function requested x) (call-function *immutable-systems* x)))
     8569          (or *immutable-systems* requested))))
    82348571  (defun action-override-p (plan operation component override-accessor)
    8235     (declare (ignorable operation))
    8236     (let* ((override (funcall override-accessor plan)))
    8237       (and override
    8238            (if (typep override 'hash-table)
    8239                (gethash (coerce-name (component-system (find-component () component))) override)
    8240                t))))
     8572    (declare (ignore operation))
     8573    (call-function (funcall override-accessor plan)
     8574                   (coerce-name (component-system (find-component () component)))))
    82428576  (defmethod action-forced-p (plan operation component)
    82528586  (defmethod action-forced-not-p (plan operation component)
    8253     (and
    8254      ;; Did the user ask us to not re-perform the action?
    8255      (action-override-p plan operation component 'plan-forced-not)
    8256      ;; Force takes precedence over force-not
    8257      (not (action-forced-p plan operation component))))
    8259   (defmethod action-forced-p ((plan null) operation component)
    8260     (declare (ignorable plan operation component))
     8587    ;; Did the user ask us to not re-perform the action?
     8588    ;; NB: force-not takes precedence over force, as it should
     8589    (action-override-p plan operation component 'plan-forced-not))
     8591  (defmethod action-forced-p ((plan null) (operation operation) (component component))
    82618592    nil)
    8263   (defmethod action-forced-not-p ((plan null) operation component)
    8264     (declare (ignorable plan operation component))
     8594  (defmethod action-forced-not-p ((plan null) (operation operation) (component component))
    82658595    nil))
    82708600  (defgeneric action-valid-p (plan operation component)
    82718601    (:documentation "Is this action valid to include amongst dependencies?"))
    8272   (defmethod action-valid-p (plan operation (c component))
    8273     (declare (ignorable plan operation))
     8602  (defmethod action-valid-p ((plan t) (o operation) (c component))
    82748603    (if-let (it (component-if-feature c)) (featurep it) t))
    8275   (defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil)
    8276   (defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil)
    8277   (defmethod action-valid-p ((plan null) operation component)
    8278     (declare (ignorable plan operation component))
    8279     (and operation component t)))
     8604  (defmethod action-valid-p ((plan t) (o null) (c t)) nil)
     8605  (defmethod action-valid-p ((plan t) (o t) (c null)) nil)
     8606  (defmethod action-valid-p ((plan null) (o operation) (c component)) t))
    82828608;;;; Is the action needed in this image?
    82968622;;;; Visiting dependencies of an action and computing action stamps
    82978623(with-upgradability ()
    8298   (defun map-direct-dependencies (operation component fun)
     8624  (defun (map-direct-dependencies) (plan operation component fun)
    82998625    (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
    83008626           :for dep-o = (find-operation operation dep-o-spec)
    83028628           :do (loop :for dep-c-spec :in dep-c-specs
    83038629                     :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
    8304                      :when dep-c
     8630                     :when (and dep-c (action-valid-p plan dep-o dep-c))
    83058631                       :do (funcall fun dep-o dep-c))))
    8307   (defun reduce-direct-dependencies (operation component combinator seed)
     8633  (defun (reduce-direct-dependencies) (plan operation component combinator seed)
    83088634    (map-direct-dependencies
    8309      operation component
     8635     plan operation component
    83108636     #'(lambda (dep-o dep-c)
    83118637         (setf seed (funcall combinator dep-o dep-c seed))))
    83128638    seed)
    8314   (defun direct-dependencies (operation component)
    8315     (reduce-direct-dependencies operation component #'acons nil))
    8317   (defun visit-dependencies (plan operation component dependency-stamper &aux stamp)
    8318     (map-direct-dependencies
    8319      operation component
    8320      #'(lambda (dep-o dep-c)
    8321          (when (action-valid-p plan dep-o dep-c)
    8322            (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c)))))
    8323     stamp)
     8640  (defun (direct-dependencies) (plan operation component)
     8641    (reduce-direct-dependencies plan operation component #'acons nil))
     8643  ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp
     8644  ;; shall also be parametrized by the plan, or by a second model object,
     8645  ;; so they need not refer to the state of the filesystem,
     8646  ;; and the stamps could be cryptographic checksums rather than timestamps.
     8647  ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP.
    83258649  (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
    8326     ;; In a distant future, get-file-stamp and component-operation-time
    8327     ;; shall also be parametrized by the plan, or by a second model object.
    8328     (let* ((stamp-lookup #'(lambda (o c)
    8329                              (if-let (it (plan-action-status plan o c)) (action-stamp it) t)))
    8330            (out-files (output-files o c))
    8331            (in-files (input-files o c))
    8332            ;; Three kinds of actions:
    8333            (out-op (and out-files t)) ; those that create files on the filesystem
    8334            ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
    8335            ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
    8336            ;; When was the thing last actually done? (Now, or ask.)
    8337            (op-time (or just-done (component-operation-time o c)))
    8338            ;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
    8339            (dep-stamp (visit-dependencies plan o c stamp-lookup))
    8340            ;; Time stamps from the files at hand, and whether any is missing
    8341            (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
    8342            (in-stamps (mapcar #'get-file-stamp in-files))
    8343            (missing-in
    8344              (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
    8345            (missing-out
    8346              (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
    8347            (all-present (not (or missing-in missing-out)))
    8348            ;; Has any input changed since we last generated the files?
    8349            (earliest-out (stamps-earliest out-stamps))
    8350            (latest-in (stamps-latest (cons dep-stamp in-stamps)))
    8351            (up-to-date-p (stamp<= latest-in earliest-out))
    8352            ;; If everything is up to date, the latest of inputs and outputs is our stamp
    8353            (done-stamp (stamps-latest (cons latest-in out-stamps))))
    8354       ;; Warn if some files are missing:
    8355       ;; either our model is wrong or some other process is messing with our files.
    8356       (when (and just-done (not all-present))
    8357         (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
    8358              ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
    8359               (action-description o c)
    8360               missing-in (length missing-in) (and missing-in missing-out)
    8361               missing-out (length missing-out)))
    8362       ;; Note that we use stamp<= instead of stamp< to play nice with generated files.
    8363       ;; Any race condition is intrinsic to the limited timestamp resolution.
    8364       (if (or just-done ;; The done-stamp is valid: if we're just done, or
    8365               ;; if all filesystem effects are up-to-date and there's no invalidating reason.
    8366               (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c))))
    8367           (values done-stamp ;; return the hard-earned timestamp
    8368                   (or just-done
    8369                       out-op ;; a file-creating op is done when all files are up to date
    8370                       ;; a image-effecting a placeholder op is done when it was actually run,
    8371                       (and op-time (eql op-time done-stamp)))) ;; with the matching stamp
    8372           ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
    8373           (values t nil)))))
     8650    ;; Given an action, figure out at what time in the past it has been done,
     8651    ;; or if it has just been done, return the time that it has.
     8652    ;; Returns two values:
     8653    ;; 1- the TIMESTAMP of the action if it has already been done and is up to date,
     8654    ;;   or T is either hasn't been done or is out of date.
     8655    ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done
     8656    ;;   in the current image, or NIL if it hasn't.
     8657    ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but
     8658    ;; hasn't been done in the current image yet, then it can have a non-T timestamp,
     8659    ;; yet a NIL done-in-image-p flag.
     8660    (nest
     8661     (block ())
     8662     (let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date)
     8663             (reduce-direct-dependencies
     8664              plan o c
     8665              #'(lambda (o c stamp)
     8666                  (if-let (it (plan-action-status plan o c))
     8667                    (latest-stamp stamp (action-stamp it))
     8668                    t))
     8669              nil)))
     8670       ;; out-of-date dependency: don't bother expensively querying the filesystem
     8671       (when (and (eq dep-stamp t) (not just-done)) (return (values t nil))))
     8672     ;; collect timestamps from inputs, and exit early if any is missing
     8673     (let* ((in-files (input-files o c))
     8674            (in-stamps (mapcar #'get-file-stamp in-files))
     8675            (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
     8676            (latest-in (stamps-latest (cons dep-stamp in-stamps))))
     8677       (when (and missing-in (not just-done)) (return (values t nil))))
     8678     ;; collect timestamps from outputs, and exit early if any is missing
     8679     (let* ((out-files (output-files o c))
     8680            (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
     8681            (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
     8682            (earliest-out (stamps-earliest out-stamps)))
     8683       (when (and missing-out (not just-done)) (return (values t nil))))
     8684     (let* (;; There are three kinds of actions:
     8685            (out-op (and out-files t)) ; those that create files on the filesystem
     8686            ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
     8687            ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
     8688            ;; When was the thing last actually done? (Now, or ask.)
     8689            (op-time (or just-done (component-operation-time o c)))
     8690            ;; Time stamps from the files at hand, and whether any is missing
     8691            (all-present (not (or missing-in missing-out)))
     8692            ;; Has any input changed since we last generated the files?
     8693            (up-to-date-p (stamp<= latest-in earliest-out))
     8694            ;; If everything is up to date, the latest of inputs and outputs is our stamp
     8695            (done-stamp (stamps-latest (cons latest-in out-stamps))))
     8696       ;; Warn if some files are missing:
     8697       ;; either our model is wrong or some other process is messing with our files.
     8698       (when (and just-done (not all-present))
     8699         (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
     8700                ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
     8701               (action-description o c)
     8702               missing-in (length missing-in) (and missing-in missing-out)
     8703               missing-out (length missing-out))))
     8704     ;; Note that we use stamp<= instead of stamp< to play nice with generated files.
     8705     ;; Any race condition is intrinsic to the limited timestamp resolution.
     8706     (if (or just-done ;; The done-stamp is valid: if we're just done, or
     8707             ;; if all filesystem effects are up-to-date and there's no invalidating reason.
     8708             (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c))))
     8709         (values done-stamp ;; return the hard-earned timestamp
     8710                 (or just-done
     8711                     out-op ;; a file-creating op is done when all files are up to date
     8712                     ;; a image-effecting a placeholder op is done when it was actually run,
     8713                     (and op-time (eql op-time done-stamp)))) ;; with the matching stamp
     8714         ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
     8715         (values t nil)))))
    83838725  (defmethod initialize-instance :after ((plan plan-traversal)
    8384                                          &key (force () fp) (force-not () fnp) system
     8726                                         &key force force-not system
    83858727                                         &allow-other-keys)
    83868728    (with-slots (forced forced-not) plan
    8387       (when fp (setf forced (normalize-forced-systems force system)))
    8388       (when fnp (setf forced-not (normalize-forced-systems force-not system)))))
     8729      (setf forced (normalize-forced-systems force system))
     8730      (setf forced-not (normalize-forced-not-systems force-not system))))
    83908732  (defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component))
    84268768  (defgeneric traverse-action (plan operation component needed-in-image-p))
     8770  ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data,
     8771  ;; visits the action defined by its OPERATION and COMPONENT arguments,
     8772  ;; and all its transitive dependencies (unless already visited),
     8773  ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P,
     8774  ;; i.e. needs to be done in the current image vs merely have been done in a previous image.
     8775  ;; For actions that are up-to-date, it returns a STAMP identifying the state of the action
     8776  ;; (that's timestamp, but it could be a cryptographic digest in some ASDF extension),
     8777  ;; or T if the action needs to be done again.
     8778  ;;
     8779  ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action,
     8780  ;; the below method would be insufficient, since it assumes a single image
     8781  ;; to traverse each node at most twice; non-niip actions would be traversed only once,
     8782  ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action.
    84288784  (defmethod traverse-action (plan operation component needed-in-image-p)
    84298785    (block nil
     8786      ;; ACTION-VALID-P among other things, handles forcing logic, including FORCE-NOT,
     8787      ;; and IF-FEATURE filtering.
    84308788      (unless (action-valid-p plan operation component) (return nil))
     8789      ;; the following hook is needed by POIU, which tracks a full dependency graph,
     8790      ;; instead of just a dependency order as in vanilla ASDF
    84318791      (plan-record-dependency plan operation component)
    8432       (let* ((aniip (needed-in-image-p operation component))
     8792      ;; needed in image distinguishes b/w things that must happen in the
     8793      ;; current image and those things that simply need to have been done in a previous one.
     8794      (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image
     8795             ;; effective niip: meaningful for the action and required by the plan as traversed
    84338796             (eniip (and aniip needed-in-image-p))
     8797             ;; status: have we traversed that action previously, and if so what was its status?
    84348798             (status (plan-action-status plan operation component)))
    84358799        (when (and status (or (action-done-p status) (action-planned-p status) (not eniip)))
    8436           ;; Already visited with sufficient need-in-image level: just return the stamp.
    8437           (return (action-stamp status)))
    8438         (labels ((visit-action (niip)
    8439                    (visit-dependencies plan operation component
    8440                                        #'(lambda (o c) (traverse-action plan o c niip)))
    8441                    (multiple-value-bind (stamp done-p)
    8442                        (compute-action-stamp plan operation component)
     8800          (return (action-stamp status))) ; Already visited with sufficient need-in-image level!
     8801        (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T
     8802                   (map-direct-dependencies ; recursively traverse dependencies
     8803                    plan operation component #'(lambda (o c) (traverse-action plan o c niip)))
     8804                   (multiple-value-bind (stamp done-p) ; AFTER dependencies have been traversed,
     8805                       (compute-action-stamp plan operation component) ; compute action stamp
    84438806                     (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p)))))
    8444                        (cond
    8445                          ((and add-to-plan-p (not niip)) ;; if we need to do it,
    8446                           (visit-action t)) ;; then we need to do it in the image!
     8807                       (cond ; it needs be done if it's out of date or needed in image but absent
     8808                         ((and add-to-plan-p (not niip)) ; if we need to do it,
     8809                          (visit-action t)) ; then we need to do it *in the (current) image*!
    84478810                         (t
    8448                           (setf (plan-action-status plan operation component)
     8811                          (setf (plan-action-status plan operation component) ; update status:
    84498812                                (make-instance
    84508813                                 'planned-action-status
    8451                                  :stamp stamp
    8452                                  :done-p (and done-p (not add-to-plan-p))
    8453                                  :planned-p add-to-plan-p
    8454                                  :index (if status
    8455                                             (action-index status)
    8456                                             (incf (plan-total-action-count plan)))))
    8457                           (when add-to-plan-p
    8458                             (incf (plan-planned-action-count plan))
    8459                             (unless aniip
    8460                               (incf (plan-planned-output-action-count plan))))
    8461                           stamp))))))
     8814                                 :stamp stamp ; computed stamp
     8815                                 :done-p (and done-p (not add-to-plan-p)) ; done *and* up-to-date?
     8816                                 :planned-p add-to-plan-p ; included in list of things to be done?
     8817                                 :index (if status ; index of action amongst all nodes in traversal
     8818                                            (action-index status) ;; if already visited, keep index
     8819                                            (incf (plan-total-action-count plan))))) ; else new index
     8820                          (when add-to-plan-p ; if it needs to be added to the plan,
     8821                            (incf (plan-planned-action-count plan)) ; count it
     8822                            (unless aniip ; if it's output-producing,
     8823                              (incf (plan-planned-output-action-count plan)))) ; count it
     8824                          stamp)))))) ; return the stamp
    84628825          (while-visiting-action (plan operation component) ; maintain context, handle circularity.
    8463             (visit-action eniip)))))))
     8826            (visit-action eniip))))))) ; visit the action
    84758838    (reverse (plan-actions-r plan)))
    8477   (defmethod plan-record-dependency ((plan sequential-plan)
    8478                                      (operation operation) (component component))
    8479     (declare (ignorable plan operation component))
     8840  (defmethod plan-record-dependency ((plan sequential-plan) (o operation) (c component))
    84808841    (values))
    84858846      (push (cons o c) (plan-actions-r p)))))
    8488 ;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
     8848;;;; High-level interface: traverse, perform-plan, plan-operates-on-p
    84898849(with-upgradability ()
    84908850  (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
    85008860  (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
    8501     (let ((plan (apply 'make-instance
    8502                        (or plan-class *default-plan-class*)
     8861    (let ((plan (apply 'make-instance (or plan-class *default-plan-class*)
    85038862                       :system (component-system c) keys)))
    85048863      (traverse-action plan o c t)
    85078866  (defmethod perform-plan :around ((plan t) &key)
     8867    #+xcl (declare (ignorable plan))
    85088868    (let ((*package* *package*)
    85098869          (*readtable* *readtable*))
    85298889;;;; Incidental traversals
     8891;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source
     8892;;; files required by a bundling operation.
    85308893(with-upgradability ()
    85318894  (defclass filtered-sequential-plan (sequential-plan)
    85378900  (defmethod initialize-instance :after ((plan filtered-sequential-plan)
    8538                                          &key (force () fp) (force-not () fnp)
     8901                                         &key force force-not
    85398902                                           other-systems)
    85408903    (declare (ignore force force-not))
    85418904    (with-slots (forced forced-not action-filter system) plan
    8542       (unless fp (setf forced (normalize-forced-systems (if other-systems :all t) system)))
    8543       (unless fnp (setf forced-not (normalize-forced-systems (if other-systems nil :all) system)))
     8905      (setf forced (normalize-forced-systems (if other-systems :all t) system))
     8906      (setf forced-not (normalize-forced-not-systems (if other-systems nil t) system))
    85448907      (setf action-filter (ensure-function action-filter))))
    85568919  (define-convenience-action-methods traverse-sub-actions (operation component &key))
    8557   (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys)
    8558     (apply 'traverse-actions (direct-dependencies operation component)
     8920  (defmethod traverse-sub-actions ((operation operation) (component component)
     8921                                   &rest keys &key &allow-other-keys)
     8922    (apply 'traverse-actions (direct-dependencies t operation component)
    85598923           :system (component-system component) keys))
    85758939;;;; Invoking Operations
    8577 (asdf/package:define-package :asdf/operate
     8941(uiop/package:define-package :asdf/operate
    85788942  (:recycle :asdf/operate :asdf)
    8579   (:use :uiop/common-lisp :uiop :asdf/upgrade
     8943  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
    85808944   :asdf/component :asdf/system :asdf/operation :asdf/action
    85818945   :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
    85838947   #:operate #:oos
    85848948   #:*systems-being-operated*
    8585    #:build-system
     8949   #:build-op #:make
    85868950   #:load-system #:load-systems #:load-systems*
    85878951   #:compile-system #:test-system #:require-system
    859789611. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
    859889622. It finds the  asdf-system specified by SYSTEM (possibly loading it from disk).
    8599 3. It then calls TRAVERSE with the operation and system as arguments
    8601 The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handling code.
    8602 If a VERSION argument is supplied, then operate also ensures that the system found
    8603 satisfies it using the VERSION-SATISFIES method.
     89633. It then calls MAKE-PLAN with the operation and system as arguments
     8965The operation of making a plan is wrapped in WITH-COMPILATION-UNIT and error
     8966handling code.  If a VERSION argument is supplied, then operate also ensures
     8967that the system found satisfies it using the VERSION-SATISFIES method.
    86058969Note that dependencies may cause the operation to invoke other operations on the system
    86278991                                (on-warnings *compile-file-warnings-behaviour*)
    86288992                                (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
    8629     (declare (ignorable operation component))
    86308993    (let* ((systems-being-operated *systems-being-operated*)
    86318994           (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
    8632            (operation-name (reify-symbol (etypecase operation
    8633                                            (operation (type-of operation))
    8634                                            (symbol operation))))
    8635            (component-path (typecase component
     8995           (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
     8996             (etypecase operation
     8997               (operation (let ((name (type-of operation))
     8998                                (initargs (operation-original-initargs operation)))
     8999                            #'(lambda () (make-operation name :original-initargs initargs initargs))))
     9000               ((or symbol string) (constantly operation))))
     9001           (component-path (typecase component ;; to remake the component after ASDF upgrade
    86369002                             (component (component-find-path component))
    86379003                             (t component))))
    86439009          ;; its function may have been redefined, its symbol uninterned, its package deleted.
    86449010          (return-from operate
    8645             (apply (find-symbol* 'operate :asdf)
    8646                    (unreify-symbol operation-name)
    8647                    component-path keys))))
     9011            (apply 'operate (funcall operation-remaker) component-path keys))))
    86489012      ;; Setup proper bindings around any operate call.
    8649       (with-system-definitions ()
     9013      (with-asdf-cache ()
    86509014        (let* ((*verbose-out* (and verbose *standard-output*))
    86519015               (*compile-file-warnings-behaviour* on-warnings)
    86789042  (defvar *load-system-operation* 'load-op
    86799043    "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
    8680 You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
     9044You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle
    86819045or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.
    8683 This may change in the future as we will implement component-based strategy
    8684 for how to load or compile stuff")
    8686   (defun build-system (system &rest keys)
    8687     "Shorthand for `(operate 'asdf:build-op system)`."
     9047The default operation may change in the future if we implement a
     9048component-directed strategy for how to load or compile systems.")
     9050  (defmethod component-depends-on ((o prepare-op) (s system))
     9051    `((,*load-system-operation* ,@(component-sideway-dependencies s))))
     9053  (defclass build-op (non-propagating-operation) ()
     9054    (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
     9055to operate by default on a system or component, via the function BUILD.
     9056Its meaning is configurable via the :BUILD-OPERATION option of a component.
     9057which typically specifies the name of a specific operation to which to delegate the build,
     9058as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on);
     9059if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION*
     9060that will load the system in the current image, and its typically LOAD-OP."))
     9061  (defmethod component-depends-on ((o build-op) (c component))
     9062    `((,(or (component-build-operation c) *load-system-operation*) ,c)))
     9064  (defun make (system &rest keys)
     9065    "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO).
     9066It will build system FOO using the operation BUILD-OP,
     9067the meaning of which is configurable by the system, and
     9068defaults to *LOAD-SYSTEM-OPERATION*, usually LOAD-OP,
     9069to load it in current image."
    86889070    (apply 'operate 'build-op system keys)
    86899071    t)
    87329114  (defclass require-system (system)
    8733     ((module :initarg :module :initform nil :accessor required-module)))
     9115    ((module :initarg :module :initform nil :accessor required-module))
     9116    (:documentation "A SYSTEM subclass whose processing is handled by
     9117the implementation's REQUIRE rather than by internal ASDF mechanisms."))
    87359119  (defmethod perform ((o compile-op) (c require-system))
    8736     (declare (ignorable o c))
    87379120    nil)
    87399122  (defmethod perform ((o load-op) (s require-system))
    8740     (declare (ignorable o))
    87419123    (let* ((module (or (required-module s) (coerce-name s)))
    87429124           (*modules-being-required* (cons module *modules-being-required*)))
    87469128  (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
    8747     (declare (ignorable component combinator))
    87489129    (unless (length=n-p arguments 1)
    87499130      (error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes only one argument~@:>")
    87829163  (defun restart-upgraded-asdf ()
    87839164    ;; If we're in the middle of something, restart it.
    8784     (when *systems-being-defined*
    8785       (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
    8786         (clrhash *systems-being-defined*)
     9165    (when *asdf-cache*
     9166      (let ((l (loop* :for (x y) :being :the hash-keys :of *asdf-cache*
     9167                      :when (eq x 'find-system) :collect y)))
     9168        (clrhash *asdf-cache*)
    87879169        (dolist (s l) (find-system s nil)))))
    87899170  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
    8792 ;;;; -------------------------------------------------------------------------
    8793 ;;; Internal hacks for backward-compatibility
    8795 (asdf/package:define-package :asdf/backward-internals
    8796   (:recycle :asdf/backward-internals :asdf)
    8797   (:use :uiop/common-lisp :uiop :asdf/upgrade
    8798    :asdf/system :asdf/component :asdf/operation
    8799    :asdf/find-system :asdf/action :asdf/lisp-action)
    8800   (:export ;; for internal use
    8801    #:load-sysdef #:make-temporary-package
    8802    #:%refresh-component-inline-methods
    8803    #:%resolve-if-component-dep-fails
    8804    #:make-sub-operation
    8805    #:load-sysdef #:make-temporary-package))
    8806 (in-package :asdf/backward-internals)
    8808 ;;;; Backward compatibility with "inline methods"
    8809 (with-upgradability ()
    8810   (defparameter +asdf-methods+
    8811     '(perform-with-restarts perform explain output-files operation-done-p))
    8813   (defun %remove-component-inline-methods (component)
    8814     (dolist (name +asdf-methods+)
    8815       (map ()
    8816            ;; this is inefficient as most of the stored
    8817            ;; methods will not be for this particular gf
    8818            ;; But this is hardly performance-critical
    8819            #'(lambda (m)
    8820                (remove-method (symbol-function name) m))
    8821            (component-inline-methods component)))
    8822     (component-inline-methods component) nil)
    8824   (defun %define-component-inline-methods (ret rest)
    8825     (loop* :for (key value) :on rest :by #'cddr
    8826            :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
    8827            :when name :do
    8828            (destructuring-bind (op &rest body) value
    8829              (loop :for arg = (pop body)
    8830                    :while (atom arg)
    8831                    :collect arg :into qualifiers
    8832                    :finally
    8833                       (destructuring-bind (o c) arg
    8834                         (pushnew
    8835                          (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
    8836                          (component-inline-methods ret)))))))
    8838   (defun %refresh-component-inline-methods (component rest)
    8839     ;; clear methods, then add the new ones
    8840     (%remove-component-inline-methods component)
    8841     (%define-component-inline-methods component rest)))
    8843 ;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
    8844 ;; and the companion asdf:feature pseudo-dependency.
    8845 ;; This won't recurse into dependencies to accumulate feature conditions.
    8846 ;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
    8847 ;; (older than but won't suffice to load an old nibbles.
    8848 (with-upgradability ()
    8849   (defun %resolve-if-component-dep-fails (if-component-dep-fails component)
    8850     (asdf-message "The system definition for ~S uses deprecated ~
    8851                  ASDF option :IF-COMPONENT-DEP-DAILS. ~
    8852                  Starting with ASDF 3, please use :IF-FEATURE instead"
    8853                   (coerce-name (component-system component)))
    8854     ;; This only supports the pattern of use of the "feature" seen in the wild
    8855     (check-type component parent-component)
    8856     (check-type if-component-dep-fails (member :fail :ignore :try-next))
    8857     (unless (eq if-component-dep-fails :fail)
    8858       (loop :with o = (make-operation 'compile-op)
    8859             :for c :in (component-children component) :do
    8860               (loop* :for (feature? feature) :in (component-depends-on o c)
    8861                      :when (eq feature? 'feature) :do
    8862                      (setf (component-if-feature c) feature))))))
    8864 (when-upgrading (:when (fboundp 'make-sub-operation))
    8865   (defun make-sub-operation (c o dep-c dep-o)
    8866     (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
    8869 ;;;; load-sysdef
    8870 (with-upgradability ()
    8871   (defun load-sysdef (name pathname)
    8872     (load-asd pathname :name name))
    8874   (defun make-temporary-package ()
    8875     ;; For loading a .asd file, we dont't make a temporary package anymore,
    8876     ;; but use ASDF-USER. I'd like to have this function do this,
    8877     ;; but since whoever uses it is likely to delete-package the result afterwards,
    8878     ;; this would be a bad idea, so preserve the old behavior.
    8879     (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
    8882 ;;;; -------------------------------------------------------------------------
    8883 ;;;; Defsystem
    8885 (asdf/package:define-package :asdf/defsystem
    8886   (:recycle :asdf/defsystem :asdf)
    8887   (:use :uiop/common-lisp :uiop :asdf/upgrade
    8888    :asdf/component :asdf/system :asdf/cache
    8889    :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
    8890    :asdf/backward-internals)
    8891   (:export
    8892    #:defsystem #:register-system-definition
    8893    #:class-for-type #:*default-component-class*
    8894    #:determine-system-directory #:parse-component-form
    8895    #:non-toplevel-system #:non-system-system
    8896    #:sysdef-error-component #:check-component-input))
    8897 (in-package :asdf/defsystem)
    8899 ;;; Pathname
    8900 (with-upgradability ()
    8901   (defun determine-system-directory (pathname)
    8902     ;; The defsystem macro calls this function to determine
    8903     ;; the pathname of a system as follows:
    8904     ;; 1. if the pathname argument is an pathname object (NOT a namestring),
    8905     ;;    that is already an absolute pathname, return it.
    8906     ;; 2. otherwise, the directory containing the LOAD-PATHNAME
    8907     ;;    is considered (as deduced from e.g. *LOAD-PATHNAME*), and
    8908     ;;    if it is indeed available and an absolute pathname, then
    8909     ;;    the PATHNAME argument is normalized to a relative pathname
    8910     ;;    as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
    8911     ;;    and merged into that DIRECTORY as per SUBPATHNAME.
    8912     ;;    Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
    8913     ;;    and may be from within the EVAL-WHEN of a file compilation.
    8914     ;; If no absolute pathname was found, we return NIL.
    8915     (check-type pathname (or null string pathname))
    8916     (pathname-directory-pathname
    8917      (resolve-symlinks*
    8918       (ensure-absolute-pathname
    8919        (parse-unix-namestring pathname :type :directory)
    8920        #'(lambda () (ensure-absolute-pathname
    8921                      (load-pathname) 'get-pathname-defaults nil))
    8922        nil)))))
    8925 ;;; Component class
    8926 (with-upgradability ()
    8927   (defvar *default-component-class* 'cl-source-file)
    8929   (defun class-for-type (parent type)
    8930     (or (loop :for symbol :in (list
    8931                                type
    8932                                (find-symbol* type *package* nil)
    8933                                (find-symbol* type :asdf/interface nil)
    8934                                (and (stringp type) (safe-read-from-string type :package :asdf/interface)))
    8935               :for class = (and symbol (symbolp symbol) (find-class* symbol nil))
    8936               :when (and class
    8937                          (#-cormanlisp subtypep #+cormanlisp cl::subclassp
    8938                           class (find-class* 'component)))
    8939                 :return class)
    8940         (and (eq type :file)
    8941              (find-class*
    8942               (or (loop :for p = parent :then (component-parent p) :while p
    8943                         :thereis (module-default-component-class p))
    8944                   *default-component-class*) nil))
    8945         (sysdef-error "don't recognize component type ~A" type))))
    8948 ;;; Check inputs
    8949 (with-upgradability ()
    8950   (define-condition non-system-system (system-definition-error)
    8951     ((name :initarg :name :reader non-system-system-name)
    8952      (class-name :initarg :class-name :reader non-system-system-class-name))
    8953     (:report (lambda (c s)
    8954                (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
    8955                        (non-system-system-name c) (non-system-system-class-name c) 'system))))
    8957   (define-condition non-toplevel-system (system-definition-error)
    8958     ((parent :initarg :parent :reader non-toplevel-system-parent)
    8959      (name :initarg :name :reader non-toplevel-system-name))
    8960     (:report (lambda (c s)
    8961                (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
    8962                        (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
    8964   (defun sysdef-error-component (msg type name value)
    8965     (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
    8966                   type name value))
    8968   (defun check-component-input (type name weakly-depends-on
    8969                                 depends-on components)
    8970     "A partial test of the values of a component."
    8971     (unless (listp depends-on)
    8972       (sysdef-error-component ":depends-on must be a list."
    8973                               type name depends-on))
    8974     (unless (listp weakly-depends-on)
    8975       (sysdef-error-component ":weakly-depends-on must be a list."
    8976                               type name weakly-depends-on))
    8977     (unless (listp components)
    8978       (sysdef-error-component ":components must be NIL or a list of components."
    8979                               type name components)))
    8981   (defun* (normalize-version) (form &key pathname component parent)
    8982     (labels ((invalid (&optional (continuation "using NIL instead"))
    8983                (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
    8984                      form component parent pathname continuation))
    8985              (invalid-parse (control &rest args)
    8986                (unless (builtin-system-p (find-component parent component))
    8987                  (apply 'warn control args)
    8988                  (invalid))))
    8989       (if-let (v (typecase form
    8990                    ((or string null) form)
    8991                    (real
    8992                     (invalid "Substituting a string")
    8993                     (format nil "~D" form)) ;; 1.0 becomes "1.0"
    8994                    (cons
    8995                     (case (first form)
    8996                       ((:read-file-form)
    8997                        (destructuring-bind (subpath &key (at 0)) (rest form)
    8998                          (safe-read-file-form (subpathname pathname subpath)
    8999                                               :at at :package :asdf-user)))
    9000                       ((:read-file-line)
    9001                        (destructuring-bind (subpath &key (at 0)) (rest form)
    9002                          (safe-read-file-line (subpathname pathname subpath)
    9003                                               :at at)))
    9004                       (otherwise
    9005                        (invalid))))
    9006                    (t
    9007                     (invalid))))
    9008         (if-let (pv (parse-version v #'invalid-parse))
    9009           (unparse-version pv)
    9010           (invalid))))))
    9013 ;;; Main parsing function
    9014 (with-upgradability ()
    9015   (defun* (parse-component-form) (parent options &key previous-serial-component)
    9016     (destructuring-bind
    9017         (type name &rest rest &key
    9018                                 (builtin-system-p () bspp)
    9019                                 ;; the following list of keywords is reproduced below in the
    9020                                 ;; remove-plist-keys form.  important to keep them in sync
    9021                                 components pathname perform explain output-files operation-done-p
    9022                                 weakly-depends-on depends-on serial
    9023                                 do-first if-component-dep-fails version
    9024                                 ;; list ends
    9025          &allow-other-keys) options
    9026       (declare (ignorable perform explain output-files operation-done-p builtin-system-p))
    9027       (check-component-input type name weakly-depends-on depends-on components)
    9028       (when (and parent
    9029                  (find-component parent name)
    9030                  (not ;; ignore the same object when rereading the defsystem
    9031                   (typep (find-component parent name)
    9032                          (class-for-type parent type))))
    9033         (error 'duplicate-names :name name))
    9034       (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
    9035       (let* ((name (coerce-name name))
    9036              (args `(:name ,name
    9037                      :pathname ,pathname
    9038                      ,@(when parent `(:parent ,parent))
    9039                      ,@(remove-plist-keys
    9040                         '(:components :pathname :if-component-dep-fails :version
    9041                           :perform :explain :output-files :operation-done-p
    9042                           :weakly-depends-on :depends-on :serial)
    9043                         rest)))
    9044              (component (find-component parent name))
    9045              (class (class-for-type parent type)))
    9046         (when (and parent (subtypep class 'system))
    9047           (error 'non-toplevel-system :parent parent :name name))
    9048         (if component ; preserve identity
    9049             (apply 'reinitialize-instance component args)
    9050             (setf component (apply 'make-instance class args)))
    9051         (component-pathname component) ; eagerly compute the absolute pathname
    9052         (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
    9053           (when (and (typep component 'system) (not bspp))
    9054             (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
    9055           (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
    9056         ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
    9057         ;; A better fix is required.
    9058         (setf (slot-value component 'version) version)
    9059         (when (typep component 'parent-component)
    9060           (setf (component-children component)
    9061                 (loop
    9062                   :with previous-component = nil
    9063                   :for c-form :in components
    9064                   :for c = (parse-component-form component c-form
    9065                                                  :previous-serial-component previous-component)
    9066                   :for name = (component-name c)
    9067                   :collect c
    9068                   :when serial :do (setf previous-component name)))
    9069           (compute-children-by-name component))
    9070         (when previous-serial-component
    9071           (push previous-serial-component depends-on))
    9072         (when weakly-depends-on
    9073           ;; ASDF4: deprecate this feature and remove it.
    9074           (appendf depends-on
    9075                    (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
    9076         ;; Used by POIU. ASDF4: rename to component-depends-on?
    9077         (setf (component-sideway-dependencies component) depends-on)
    9078         (%refresh-component-inline-methods component rest)
    9079         (when if-component-dep-fails
    9080           (%resolve-if-component-dep-fails if-component-dep-fails component))
    9081         component)))
    9083   (defun register-system-definition
    9084       (name &rest options &key pathname (class 'system) (source-file () sfp)
    9085                             defsystem-depends-on &allow-other-keys)
    9086     ;; The system must be registered before we parse the body,
    9087     ;; otherwise we recur when trying to find an existing system
    9088     ;; of the same name to reuse options (e.g. pathname) from.
    9089     ;; To avoid infinite recursion in cases where you defsystem a system
    9090     ;; that is registered to a different location to find-system,
    9091     ;; we also need to remember it in a special variable *systems-being-defined*.
    9092     (with-system-definitions ()
    9093       (let* ((name (coerce-name name))
    9094              (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
    9095              (registered (system-registered-p name))
    9096              (registered! (if registered
    9097                               (rplaca registered (get-file-stamp source-file))
    9098                               (register-system
    9099                                (make-instance 'system :name name :source-file source-file))))
    9100              (system (reset-system (cdr registered!)
    9101                                    :name name :source-file source-file))
    9102              (component-options (remove-plist-key :class options))
    9103              (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
    9104                                            (resolve-dependency-spec nil spec))))
    9105         (setf (gethash name *systems-being-defined*) system)
    9106         (load-systems* defsystem-dependencies)
    9107         ;; We change-class AFTER we loaded the defsystem-depends-on
    9108         ;; since the class might be defined as part of those.
    9109         (let ((class (class-for-type nil class)))
    9110           (unless (subtypep class 'system)
    9111             (error 'non-system-system :name name :class-name (class-name class)))
    9112           (unless (eq (type-of system) class)
    9113             (change-class system class)))
    9114         (parse-component-form
    9115          nil (list*
    9116               :module name
    9117               :pathname (determine-system-directory pathname)
    9118               component-options)))))
    9120   (defmacro defsystem (name &body options)
    9121     `(apply 'register-system-definition ',name ',options)))
    9122 ;;;; -------------------------------------------------------------------------
    9123 ;;;; ASDF-Bundle
    9125 (asdf/package:define-package :asdf/bundle
    9126   (:recycle :asdf/bundle :asdf)
    9127   (:use :uiop/common-lisp :uiop :asdf/upgrade
    9128    :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
    9129    :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
    9130   (:export
    9131    #:bundle-op #:bundle-op-build-args #:bundle-type
    9132    #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
    9133    #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
    9134    #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
    9135    #:lib-op #:monolithic-lib-op
    9136    #:dll-op #:monolithic-dll-op
    9137    #:binary-op #:monolithic-binary-op
    9138    #:program-op #:compiled-file #:precompiled-system #:prebuilt-system
    9139    #:user-system-p #:user-system #:trivial-system-p
    9140    #+ecl #:make-build
    9141    #:register-pre-built-system
    9142    #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
    9143 (in-package :asdf/bundle)
    9145 (with-upgradability ()
    9146   (defclass bundle-op (operation)
    9147     ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
    9148      (name-suffix :initarg :name-suffix :initform nil)
    9149      (bundle-type :initform :no-output-file :reader bundle-type)
    9150      #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
    9151      #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
    9152      #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
    9154   (defclass bundle-compile-op (bundle-op basic-compile-op)
    9155     ()
    9156     (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files"))
    9158   ;; create a single fasl for the entire library
    9159   (defclass basic-fasl-op (bundle-compile-op)
    9160     ((bundle-type :initform :fasl)))
    9161   (defclass prepare-fasl-op (sideway-operation)
    9162     ((sideway-operation :initform 'load-fasl-op)))
    9163   (defclass fasl-op (basic-fasl-op selfward-operation)
    9164     ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op))))
    9165   (defclass load-fasl-op (basic-load-op selfward-operation)
    9166     ((selfward-operation :initform '(prepare-op fasl-op))))
    9168   ;; NB: since the monolithic-op's can't be sideway-operation's,
    9169   ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's,
    9170   ;; we'd have to have the monolithic-op not inherit from the main op,
    9171   ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
    9173   (defclass no-ld-flags-op (operation) ())
    9175   (defclass lib-op (bundle-compile-op no-ld-flags-op)
    9176     ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
    9177     (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it."
    9178      #-(or ecl mkcl) "just compile the system"))
    9180   (defclass dll-op (bundle-compile-op selfward-operation no-ld-flags-op)
    9181     ((bundle-type :initform :dll))
    9182     (:documentation "compile the system and produce dynamic (.so/.dll) library for it."))
    9184   (defclass binary-op (basic-compile-op selfward-operation)
    9185     ((selfward-operation :initform '(fasl-op lib-op)))
    9186     (:documentation "produce fasl and asd files for the system"))
    9188   (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
    9190   (defclass monolithic-bundle-op (monolithic-op bundle-op)
    9191     ((prologue-code :accessor monolithic-op-prologue-code)
    9192      (epilogue-code :accessor monolithic-op-epilogue-code)))
    9194   (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op)
    9195     ()
    9196     (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems"))
    9198   (defclass monolithic-binary-op (monolithic-op binary-op)
    9199     ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op)))
    9200     (:documentation "produce fasl and asd files for combined system and dependencies."))
    9202   (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) ()
    9203     (:documentation "Create a single fasl for the system and its dependencies."))
    9205   (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op  no-ld-flags-op)
    9206     ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
    9207     (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies."
    9208      #-(or ecl mkcl) "Compile a system and its dependencies."))
    9210   (defclass monolithic-dll-op (monolithic-bundle-compile-op sideway-operation selfward-operation no-ld-flags-op)
    9211     ((bundle-type :initform :dll))
    9212     (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
    9214   (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op)
    9215             #-(or mkcl ecl) (monolithic-bundle-op selfward-operation)
    9216     ((bundle-type :initform :program)
    9217      #-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op))
    9218     (:documentation "create an executable file from the system and its dependencies"))
    9220   (defun bundle-pathname-type (bundle-type)
    9221     (etypecase bundle-type
    9222       ((eql :no-output-file) nil) ;; should we error out instead?
    9223       ((or null string) bundle-type)
    9224       ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
    9225       #+ecl
    9226       ((member :binary :dll :lib :shared-library :static-library :program :object :program)
    9227        (compile-file-type :type bundle-type))
    9228       ((eql :binary) "image")
    9229       ((eql :dll) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
    9230       ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
    9231       ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
    9233   (defun bundle-output-files (o c)
    9234     (when (input-files o c)
    9235       (let ((bundle-type (bundle-type o)))
    9236         (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
    9237           (let ((name (or (component-build-pathname c)
    9238                           (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
    9239                 (type (bundle-pathname-type bundle-type)))
    9240             (values (list (subpathname (component-pathname c) name :type type))
    9241                     (eq (type-of o) (component-build-operation c))))))))
    9243   (defmethod output-files ((o bundle-op) (c system))
    9244     (bundle-output-files o c))
    9246   #-(or ecl mkcl)
    9247   (defmethod perform ((o program-op) (c system))
    9248     (let ((output-file (output-file o c)))
    9249       (setf *image-entry-point* (ensure-function (component-entry-point c)))
    9250       (dump-image output-file :executable t)))
    9252   (defclass compiled-file (file-component)
    9253     ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
    9255   (defclass precompiled-system (system)
    9256     ((build-pathname :initarg :fasl)))
    9258   (defclass prebuilt-system (system)
    9259     ((build-pathname :initarg :static-library :initarg :lib
    9260                      :accessor prebuilt-system-static-library))))
    9263 ;;;
    9264 ;;; BUNDLE-OP
    9265 ;;;
    9266 ;;; This operation takes all components from one or more systems and
    9267 ;;; creates a single output file, which may be
    9268 ;;; a FASL, a statically linked library, a shared library, etc.
    9269 ;;; The different targets are defined by specialization.
    9270 ;;;
    9271 (with-upgradability ()
    9272   (defun operation-monolithic-p (op)
    9273     (typep op 'monolithic-op))
    9275   (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
    9276                                          &key (name-suffix nil name-suffix-p)
    9277                                          &allow-other-keys)
    9278     (declare (ignorable initargs name-suffix))
    9279     (unless name-suffix-p
    9280       (setf (slot-value instance 'name-suffix)
    9281             (unless (typep instance 'program-op)
    9282               (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames
    9283     (when (typep instance 'monolithic-bundle-op)
    9284       (destructuring-bind (&rest original-initargs
    9285                            &key lisp-files prologue-code epilogue-code
    9286                            &allow-other-keys)
    9287           (operation-original-initargs instance)
    9288         (setf (operation-original-initargs instance)
    9289               (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
    9290               (monolithic-op-prologue-code instance) prologue-code
    9291               (monolithic-op-epilogue-code instance) epilogue-code)
    9292         #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
    9293         #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
    9294     (setf (bundle-op-build-args instance)
    9295           (remove-plist-keys '(:type :monolithic :name-suffix)
    9296                              (operation-original-initargs instance))))
    9298   (defmethod bundle-op-build-args :around ((o no-ld-flags-op))
    9299     (declare (ignorable o))
    9300     (let ((args (call-next-method)))
    9301       (remf args :ld-flags)
    9302       args))
    9304   (defun bundlable-file-p (pathname)
    9305     (let ((type (pathname-type pathname)))
    9306       (declare (ignorable type))
    9307       (or #+ecl (or (equalp type (compile-file-type :type :object))
    9308                     (equalp type (compile-file-type :type :static-library)))
    9309           #+mkcl (equalp type (compile-file-type :fasl-p nil))
    9310           #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
    9312   (defgeneric* (trivial-system-p) (component))
    9314   (defun user-system-p (s)
    9315     (and (typep s 'system)
    9316          (not (builtin-system-p s))
    9317          (not (trivial-system-p s)))))
    9319 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
    9320   (deftype user-system () '(and system (satisfies user-system-p))))
    9322 ;;;
    9323 ;;; First we handle monolithic bundles.
    9324 ;;; These are standalone systems which contain everything,
    9325 ;;; including other ASDF systems required by the current one.
    9326 ;;; A PROGRAM is always monolithic.
    9327 ;;;
    9329 ;;;
    9330 (with-upgradability ()
    9331   (defmethod component-depends-on ((o bundle-compile-op) (c system))
    9332     `(,(if (operation-monolithic-p o)
    9333            `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op
    9334                ,@(required-components c :other-systems t :component-type 'system
    9335                                         :goal-operation (find-operation o 'load-op)
    9336                                         :keep-operation 'compile-op))
    9337            `(compile-op
    9338              ,@(required-components c :other-systems nil :component-type '(not system)
    9339                                       :goal-operation (find-operation o 'load-op)
    9340                                       :keep-operation 'compile-op)))
    9341       ,@(call-next-method)))
    9343   (defmethod component-depends-on :around ((o bundle-op) (c component))
    9344     (declare (ignorable o c))
    9345     (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
    9346       `((,op ,c))
    9347       (call-next-method)))
    9349   (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
    9350     ;; This file selects output files from direct dependencies;
    9351     ;; your component-depends-on method better gathered the correct dependencies in the correct order.
    9352     (while-collecting (collect)
    9353       (map-direct-dependencies
    9354        o c #'(lambda (sub-o sub-c)
    9355                (loop :for f :in (funcall key sub-o sub-c)
    9356                      :when (funcall test f) :do (collect f))))))
    9358   (defmethod input-files ((o bundle-compile-op) (c system))
    9359     (unless (eq (bundle-type o) :no-output-file)
    9360       (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)))
    9362   (defun select-bundle-operation (type &optional monolithic)
    9363     (ecase type
    9364       ((:binary)
    9365        (if monolithic 'monolithic-binary-op 'binary-op))
    9366       ((:dll :shared-library)
    9367        (if monolithic 'monolithic-dll-op 'dll-op))
    9368       ((:lib :static-library)
    9369        (if monolithic 'monolithic-lib-op 'lib-op))
    9370       ((:fasl)
    9371        (if monolithic 'monolithic-fasl-op 'fasl-op))
    9372       ((:program)
    9373        'program-op)))
    9375   (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
    9376                              (move-here nil move-here-p)
    9377                              &allow-other-keys)
    9378     (let* ((operation-name (select-bundle-operation type monolithic))
    9379            (move-here-path (if (and move-here
    9380                                     (typep move-here '(or pathname string)))
    9381                                (pathname move-here)
    9382                                (system-relative-pathname system "asdf-output/")))
    9383            (operation (apply #'operate operation-name
    9384                              system
    9385                              (remove-plist-keys '(:monolithic :type :move-here) args)))
    9386            (system (find-system system))
    9387            (files (and system (output-files operation system))))
    9388       (if (or move-here (and (null move-here-p)
    9389                              (member operation-name '(:program :binary))))
    9390           (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
    9391                 :for f :in files
    9392                 :for new-f = (make-pathname :name (pathname-name f)
    9393                                             :type (pathname-type f)
    9394                                             :defaults dest-path)
    9395                 :do (rename-file-overwriting-target f new-f)
    9396                 :collect new-f)
    9397           files))))
    9399 ;;;
    9400 ;;; LOAD-FASL-OP
    9401 ;;;
    9402 ;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
    9403 ;;;
    9404 (with-upgradability ()
    9405   (defmethod component-depends-on ((o load-fasl-op) (c system))
    9406     (declare (ignorable o))
    9407     `((,o ,@(loop :for dep :in (component-sideway-dependencies c)
    9408                   :collect (resolve-dependency-spec c dep)))
    9409       (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
    9410       ,@(call-next-method)))
    9412   (defmethod input-files ((o load-fasl-op) (c system))
    9413     (when (user-system-p c)
    9414       (output-files (find-operation o 'fasl-op) c)))
    9416   (defmethod perform ((o load-fasl-op) c)
    9417     (declare (ignorable o c))
    9418     nil)
    9420   (defmethod perform ((o load-fasl-op) (c system))
    9421     (when (input-files o c)
    9422       (perform-lisp-load-fasl o c)))
    9424   (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
    9425     (mark-operation-done (find-operation o 'load-op) c)))
    9427 ;;;
    9429 ;;;
    9430 ;;; This component can be used to distribute ASDF systems in precompiled form.
    9431 ;;; Only useful when the dependencies have also been precompiled.
    9432 ;;;
    9433 (with-upgradability ()
    9434   (defmethod trivial-system-p ((s system))
    9435     (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
    9437   (defmethod output-files (o (c compiled-file))
    9438     (declare (ignorable o c))
    9439     nil)
    9440   (defmethod input-files (o (c compiled-file))
    9441     (declare (ignorable o))
    9442     (component-pathname c))
    9443   (defmethod perform ((o load-op) (c compiled-file))
    9444     (perform-lisp-load-fasl o c))
    9445   (defmethod perform ((o load-source-op) (c compiled-file))
    9446     (perform (find-operation o 'load-op) c))
    9447   (defmethod perform ((o load-fasl-op) (c compiled-file))
    9448     (perform (find-operation o 'load-op) c))
    9449   (defmethod perform ((o operation) (c compiled-file))
    9450     (declare (ignorable o c))
    9451     nil))
    9453 ;;;
    9454 ;;; Pre-built systems
    9455 ;;;
    9456 (with-upgradability ()
    9457   (defmethod trivial-system-p ((s prebuilt-system))
    9458     (declare (ignorable s))
    9459     t)
    9461   (defmethod perform ((o lib-op) (c prebuilt-system))
    9462     (declare (ignorable o c))
    9463     nil)
    9465   (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
    9466     (declare (ignorable o c))
    9467     nil)
    9469   (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
    9470     (declare (ignorable o))
    9471     nil))
    9474 ;;;
    9476 ;;;
    9477 (with-upgradability ()
    9478   (defmethod output-files ((o binary-op) (s system))
    9479     (list (make-pathname :name (component-name s) :type "asd"
    9480                          :defaults (component-pathname s))))
    9482   (defmethod perform ((o binary-op) (s system))
    9483     (let* ((inputs (input-files o s))
    9484            (fasl (first inputs))
    9485            (library (second inputs))
    9486            (asd (first (output-files o s)))
    9487            (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
    9488            (dependencies
    9489              (if (operation-monolithic-p o)
    9490                  (remove-if-not 'builtin-system-p
    9491                                 (required-components s :component-type 'system
    9492                                                        :keep-operation 'load-op))
    9493                  (while-collecting (x) ;; resolve the sideway-dependencies of s
    9494                    (map-direct-dependencies
    9495                     'load-op s
    9496                     #'(lambda (o c)
    9497                         (when (and (typep o 'load-op) (typep c 'system))
    9498                           (x c)))))))
    9499            (depends-on (mapcar 'coerce-name dependencies)))
    9500       (when (pathname-equal asd (system-source-file s))
    9501         (cerror "overwrite the asd file"
    9502                 "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
    9503                 (cons o s) asd))
    9504       (with-open-file (s asd :direction :output :if-exists :supersede
    9505                              :if-does-not-exist :create)
    9506         (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
    9507                 (operation-monolithic-p o) name)
    9508         (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
    9509                 (lisp-implementation-type)
    9510                 (lisp-implementation-version)
    9511                 (software-type)
    9512                 (machine-type)
    9513                 (software-version))
    9514         (let ((*package* (find-package :asdf-user)))
    9515           (pprint `(defsystem ,name
    9516                      :class prebuilt-system
    9517                      :depends-on ,depends-on
    9518                      :components ((:compiled-file ,(pathname-name fasl)))
    9519                      ,@(when library `(:lib ,(file-namestring library))))
    9520                   s)
    9521           (terpri s)))))
    9523   #-(or ecl mkcl)
    9524   (defmethod perform ((o bundle-compile-op) (c system))
    9525     (let* ((input-files (input-files o c))
    9526            (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
    9527            (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
    9528            (output-files (output-files o c))
    9529            (output-file (first output-files)))
    9530       (assert (eq (not input-files) (not output-files)))
    9531       (when input-files
    9532         (when non-fasl-files
    9533           (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
    9534                  (implementation-type) non-fasl-files))
    9535         (when (and (typep o 'monolithic-bundle-op)
    9536                    (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
    9537           (error "prologue-code and epilogue-code are not supported on ~A"
    9538                  (implementation-type)))
    9539         (with-staging-pathname (output-file)
    9540           (combine-fasls fasl-files output-file)))))
    9542   (defmethod input-files ((o load-op) (s precompiled-system))
    9543     (declare (ignorable o))
    9544     (bundle-output-files (find-operation o 'fasl-op) s))
    9546   (defmethod perform ((o load-op) (s precompiled-system))
    9547     (perform-lisp-load-fasl o s))
    9549   (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
    9550     (declare (ignorable o))
    9551     `((load-op ,s) ,@(call-next-method))))
    9553   #| ;; Example use:
    9554 (asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
    9555 (asdf:load-system :precompiled-asdf-utils)
    9556 |#
    9558 #+(or ecl mkcl)
    9559 (with-upgradability ()
    9560   (defun uiop-library-file ()
    9561     (or (and (find-system :uiop nil)
    9562              (system-source-directory :uiop)
    9563              (progn
    9564                (operate 'lib-op :uiop)
    9565                (output-file 'lib-op :uiop)))
    9566         (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib))))
    9567   (defmethod input-files :around ((o program-op) (c system))
    9568     (let ((files (call-next-method))
    9569           (plan (traverse-sub-actions o c :plan-class 'sequential-plan)))
    9570       (unless (or (and (find-system :uiop nil)
    9571                        (system-source-directory :uiop)
    9572                        (plan-operates-on-p plan '("uiop")))
    9573                   (and (system-source-directory :asdf)
    9574                        (plan-operates-on-p plan '("asdf"))))
    9575         (pushnew (uiop-library-file) files :test 'pathname-equal))
    9576       files))
    9578   (defun register-pre-built-system (name)
    9579     (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
    9581 #+ecl
    9582 (with-upgradability ()
    9583   (defmethod perform ((o bundle-compile-op) (c system))
    9584     (let* ((object-files (input-files o c))
    9585            (output (output-files o c))
    9586            (bundle (first output))
    9587            (kind (bundle-type o)))
    9588       (when output
    9589         (create-image
    9590          bundle (append object-files (bundle-op-lisp-files o))
    9591          :kind kind
    9592          :entry-point (component-entry-point c)
    9593          :prologue-code
    9594          (when (typep o 'monolithic-bundle-op)
    9595            (monolithic-op-prologue-code o))
    9596          :epilogue-code
    9597          (when (typep o 'monolithic-bundle-op)
    9598            (monolithic-op-epilogue-code o))
    9599          :build-args (bundle-op-build-args o))))))
    9601 #+mkcl
    9602 (with-upgradability ()
    9603   (defmethod perform ((o lib-op) (s system))
    9604     (apply #'compiler::build-static-library (output-file o c)
    9605            :lisp-object-files (input-files o s) (bundle-op-build-args o)))
    9607   (defmethod perform ((o basic-fasl-op) (s system))
    9608     (apply #'compiler::build-bundle (output-file o c) ;; second???
    9609            :lisp-object-files (input-files o s) (bundle-op-build-args o)))
    9611   (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
    9612     (declare (ignore force verbose version))
    9613     (apply #'operate 'binary-op system args)))
    9614 ;;;; -------------------------------------------------------------------------
    9615 ;;;; Concatenate-source
    9617 (asdf/package:define-package :asdf/concatenate-source
    9618   (:recycle :asdf/concatenate-source :asdf)
    9619   (:use :uiop/common-lisp :uiop :asdf/upgrade
    9620    :asdf/component :asdf/operation
    9621    :asdf/system :asdf/find-system :asdf/defsystem
    9622    :asdf/action :asdf/lisp-action :asdf/bundle)
    9623   (:export
    9624    #:concatenate-source-op
    9625    #:load-concatenated-source-op
    9626    #:compile-concatenated-source-op
    9627    #:load-compiled-concatenated-source-op
    9628    #:monolithic-concatenate-source-op
    9629    #:monolithic-load-concatenated-source-op
    9630    #:monolithic-compile-concatenated-source-op
    9631    #:monolithic-load-compiled-concatenated-source-op))
    9632 (in-package :asdf/concatenate-source)
    9634 ;;;
    9635 ;;; Concatenate sources
    9636 ;;;
    9637 (with-upgradability ()
    9638   (defclass basic-concatenate-source-op (bundle-op)
    9639     ((bundle-type :initform "lisp")))
    9640   (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
    9641   (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
    9642   (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
    9644   (defclass concatenate-source-op (basic-concatenate-source-op) ())
    9645   (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
    9646     ((selfward-operation :initform '(prepare-op concatenate-source-op))))
    9647   (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
    9648     ((selfward-operation :initform '(prepare-op concatenate-source-op))))
    9649   (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
    9650     ((selfward-operation :initform '(prepare-op compile-concatenated-source-op))))
    9652   (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ())
    9653   (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
    9654     ((selfward-operation :initform 'monolithic-concatenate-source-op)))
    9655   (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
    9656     ((selfward-operation :initform 'monolithic-concatenate-source-op)))
    9657   (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
    9658     ((selfward-operation :initform 'monolithic-compile-concatenated-source-op)))
    9660   (defmethod input-files ((operation basic-concatenate-source-op) (s system))
    9661     (loop :with encoding = (or (component-encoding s) *default-encoding*)
    9662           :with other-encodings = '()
    9663           :with around-compile = (around-compile-hook s)
    9664           :with other-around-compile = '()
    9665           :for c :in (required-components
    9666                       s :goal-operation 'compile-op
    9667                         :keep-operation 'compile-op
    9668                         :other-systems (operation-monolithic-p operation))
    9669           :append
    9670           (when (typep c 'cl-source-file)
    9671             (let ((e (component-encoding c)))
    9672               (unless (equal e encoding)
    9673                 (let ((a (assoc e other-encodings)))
    9674                   (if a (push (component-find-path c) (cdr a))
    9675                       (push (list a (component-find-path c)) other-encodings)))))
    9676             (unless (equal around-compile (around-compile-hook c))
    9677               (push (component-find-path c) other-around-compile))
    9678             (input-files (make-operation 'compile-op) c)) :into inputs
    9679           :finally
    9680              (when other-encodings
    9681                (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}"
    9682                      operation encoding
    9683                      (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x)))))
    9684                              other-encodings)))
    9685              (when other-around-compile
    9686                (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
    9687                      operation around-compile other-around-compile))
    9688              (return inputs)))
    9689   (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
    9690     (lisp-compilation-output-files o s))
    9692   (defmethod perform ((o basic-concatenate-source-op) (s system))
    9693     (let ((inputs (input-files o s))
    9694           (output (output-file o s)))
    9695       (concatenate-files inputs output)))
    9696   (defmethod perform ((o basic-load-concatenated-source-op) (s system))
    9697     (perform-lisp-load-source o s))
    9698   (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
    9699     (perform-lisp-compilation o s))
    9700   (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
    9701     (perform-lisp-load-fasl o s)))
    97039173;;;; ---------------------------------------------------------------------------
    97049174;;;; asdf-output-translations
    9706 (asdf/package:define-package :asdf/output-translations
     9176(uiop/package:define-package :asdf/output-translations
    97079177  (:recycle :asdf/output-translations :asdf)
    97089178  (:use :uiop/common-lisp :uiop :asdf/upgrade)
    97519221                                      (if (listp directory) (length directory) 0))))))))
    97529222    new-value)
    9753   #-gcl2.6
    97549223  (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
    9755   #+gcl2.6
    9756   (defsetf output-translations set-output-translations)
    97589225  (defun output-translations-initialized-p ()
    98349301               (return `(:output-translations ,@(nreverse directives)))))))))
    9836   (defparameter *default-output-translations*
     9303  (defparameter* *default-output-translations*
    98379304    '(environment-output-translations
    98389305      user-output-translations-pathname
    99149381                                                       collect)
    99159382    (process-output-translations (funcall x) :inherit inherit :collect collect))
    9916   (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
     9383  (defmethod process-output-translations ((pathname pathname) &key inherit collect)
    99179384    (cond
    99189385      ((directory-pathname-p pathname)
    99289395                                 :inherit inherit :collect collect))
    99299396  (defmethod process-output-translations ((x null) &key inherit collect)
    9930     (declare (ignorable x))
    99319397    (inherit-output-translations inherit :collect collect))
    99329398  (defmethod process-output-translations ((form cons) &key inherit collect)
    100169482        (normalize-device (apply-output-translations target))))))
    10018 ;;;; -------------------------------------------------------------------------
    10019 ;;; Backward-compatible interfaces
    10021 (asdf/package:define-package :asdf/backward-interface
    10022   (:recycle :asdf/backward-interface :asdf)
    10023   (:use :uiop/common-lisp :uiop :asdf/upgrade
    10024    :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
    10025    :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
    10026   (:export
    10027    #:*asdf-verbose*
    10028    #:operation-error #:compile-error #:compile-failed #:compile-warned
    10029    #:error-component #:error-operation #:traverse
    10030    #:component-load-dependencies
    10031    #:enable-asdf-binary-locations-compatibility
    10032    #:operation-forced
    10033    #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
    10034    #:component-property
    10035    #:run-shell-command
    10036    #:system-definition-pathname))
    10037 (in-package :asdf/backward-interface)
    10039 (with-upgradability ()
    10040   (define-condition operation-error (error) ;; Bad, backward-compatible name
    10041     ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
    10042     ((component :reader error-component :initarg :component)
    10043      (operation :reader error-operation :initarg :operation))
    10044     (:report (lambda (c s)
    10045                (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
    10046                        (type-of c) (error-operation c) (error-component c)))))
    10047   (define-condition compile-error (operation-error) ())
    10048   (define-condition compile-failed (compile-error) ())
    10049   (define-condition compile-warned (compile-error) ())
    10051   (defun component-load-dependencies (component)
    10052     ;; Old deprecated name for the same thing. Please update your software.
    10053     (component-sideway-dependencies component))
    10055   (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
    10056   (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
    10058   (defgeneric operation-on-warnings (operation))
    10059   (defgeneric operation-on-failure (operation))
    10060   #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
    10061   #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
    10062   (defmethod operation-on-warnings ((o operation))
    10063     (declare (ignorable o)) *compile-file-warnings-behaviour*)
    10064   (defmethod operation-on-failure ((o operation))
    10065     (declare (ignorable o)) *compile-file-failure-behaviour*)
    10066   (defmethod (setf operation-on-warnings) (x (o operation))
    10067     (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
    10068   (defmethod (setf operation-on-failure) (x (o operation))
    10069     (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
    10071   (defun system-definition-pathname (x)
    10072     ;; As of 2.014.8, we mean to make this function obsolete,
    10073     ;; but that won't happen until all clients have been updated.
    10074     ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
    10075     "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
    10076 It used to expose ASDF internals with subtle differences with respect to
    10077 user expectations, that have been refactored away since.
    10078 We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
    10079 for a mostly compatible replacement that we're supporting,
    10081 if that's whay you mean." ;;)
    10082     (system-source-file x))
    10084   (defgeneric* (traverse) (operation component &key &allow-other-keys)
    10085     (:documentation
    10086      "Generate and return a plan for performing OPERATION on COMPONENT.
    10088 The plan returned is a list of dotted-pairs. Each pair is the CONS
    10089 of ASDF operation object and a COMPONENT object. The pairs will be
    10090 processed in order by OPERATE."))
    10091   (define-convenience-action-methods traverse (operation component &key))
    10093   (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
    10094     (plan-actions (apply 'make-plan plan-class o c keys))))
    10097 ;;;; ASDF-Binary-Locations compatibility
    10098 ;; This remains supported for legacy user, but not recommended for new users.
    10099 (with-upgradability ()
    10100   (defun enable-asdf-binary-locations-compatibility
    10101       (&key
    10102        (centralize-lisp-binaries nil)
    10103        (default-toplevel-directory
    10104         (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
    10105        (include-per-user-information nil)
    10106        (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
    10107        (source-to-target-mappings nil)
    10108        (file-types `(,(compile-file-type)
    10109                      "build-report"
    10110                      #+ecl (compile-file-type :type :object)
    10111                      #+mkcl (compile-file-type :fasl-p nil)
    10112                      #+clisp "lib" #+sbcl "cfasl"
    10113                      #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))