Changeset 16074


Ignore:
Timestamp:
May 9, 2014, 11:18:28 PM (6 years ago)
Author:
rme
Message:

Upgrade bundled ASDF to ASDF 3.1.2.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    2020;;;  Monday; July 13, 2009)
    2121;;;
    22 ;;; Copyright (c) 2001-2012 Daniel Barlow and contributors
     22;;; Copyright (c) 2001-2014 Daniel Barlow and contributors
    2323;;;
    2424;;; Permission is hereby granted, free of charge, to any person obtaining
     
    5252#+cmu
    5353(eval-when (:load-toplevel :compile-toplevel :execute)
    54   (declaim (optimize (speed 1) (safety 3) (debug 3)))
    5554  (setf ext:*gc-verbose* nil))
    5655
    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
     57#+abcl
     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*)))
     62
     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))))))
    78 
    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)))))))
    565  
     572
    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
     
    784795
    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)))
    841835
    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
    877869
    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)))
    927919
    928 #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
     920#+gcl
    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* ""))
    934 
    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))
    939 
    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))
    944 
    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))
    970935
    971936#+genera
     
    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)))))))
    11691137
    1170 
    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))
     1144
    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*)))
    12461219
     
    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
     
    13761350
    13771351
    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)))))
    1385 
    1386 
    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)
     
    14821448
    14831449
     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.
     1455
     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.
     1459
     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)))))
     1478
     1479
    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)))
    14941493
    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")
    15751574
     
    16011600
    16021601  (defmacro with-muffled-conditions ((conditions) &body body)
     1602    "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
    16031603    `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
    16041604
     
    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))
    16571657
    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")))))
    18871888
     
    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)
    20482038
    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")
    20792069
    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)))
    20952082
     
    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)))))))
    22172205
    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))))
    2528 
    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))))))
    2539 
    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))
    2548 
    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)))
    2556 
    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)))
    25622520
    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))))
     2539
     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))))))
     2550
     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)))
     2557
     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)))
     2565
     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))))
    25812571
    25822572
     
    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)))))))
    28512847
    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))
     2899
    28942900
    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)))))))))
    29202931
    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))))))
    29943011
    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.
    30323049
    3033 If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
    3034 reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
    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
     3051PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
     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
     3056DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
     3057the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
     3058
     3059The pathname passed or resulting from parsing the string
     3060is then subjected to all the checks and transformations below are run.
    30373061
    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))
    32453280
    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
    32733308
     
    34923527      (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
    34933528
    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)))
     3545
     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))
     3551
     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))))
    35143574
    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)))))
    3542 
    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)))
    3547 
    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))
    35673607
    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)))
    3583 
    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))))
     3625
     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))))
     3630
    35893631
    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))
    38323878
    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)))
    38363882
    38373883
     
    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*))
    38613906
    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.
     3914
     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.
     3920
     3921The file will be open with specified DIRECTION (defaults to :IO),
     3922ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
     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))))))
    39053974
    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)))))
    3930 
    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))))))
     4016
     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))
    39344021
    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))
    39404028
    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"))
    39444032
    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)))
     
    39584045
    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))))
    39614049
     
    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))
    40534141
    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))
    4093 
    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)))
     4201
     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"))
    41814290
     
    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)))
     4309
     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 4.0.1.8.
     4322       (getenvp "__CL_ARGV0"))))
    41944323
    41954324  (defun setup-command-line-arguments ()
     
    41974326
    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.
     4335
     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.
     4339
     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.
     4346
     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.
     4354
     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.
     4389
     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.
     4392
     4393If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup.
     4394
     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))))
    42914467
    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)))))
    43204515
    43214516
     
    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."))
    44994695
    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)))
    45064702
    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)
     
    45134709
    45144710  (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
    4515     (declare (ignorable x))
    45164711    (slurp-stream-string stream :stripped stripped))
    45174712
    45184713  (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
    4519     (declare (ignorable x))
    45204714    (slurp-stream-string stream :stripped stripped))
    45214715
    45224716  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
    4523     (declare (ignorable x))
    45244717    (slurp-stream-lines stream :count count))
    45254718
    45264719  (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
    4527     (declare (ignorable x))
    45284720    (slurp-stream-line stream :at at))
    45294721
    45304722  (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
    4531     (declare (ignorable x))
    45324723    (slurp-stream-forms stream :count count))
    45334724
    45344725  (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
    4535     (declare (ignorable x))
    45364726    (slurp-stream-form stream :at at))
    45374727
    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))
    45414730
    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)
    45454733
     
    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."))
    45964784
    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)))
    46034791
    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)
     
    46164804
    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))
    46204807
    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))
    46244810
     
    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)
     
    47464933     PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
    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))))
    48845071
     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)))
     5082
    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)))))
    49015107
    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)))))
    50815290
     
    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))))
    51095318
    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.
    51575370
    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.
    51615375
    51625376INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
    51635377no value is returned, and T designates the *STANDARD-INPUT*.
    51645378
    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.
    51665381
    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.
    51715388
    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)))
    52785525
    52795526
     
    56975944
    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  |#
    57395986
    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)))
    57536001
    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)))
    57576006
    57586007
     
    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.
    57686017
    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)))))
    57966045
     6046  (defvar *compile-check* nil
     6047    "A hook for user-defined compile-time invariants")
     6048
    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))))))
    59096160
    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))))
    60776332
     
    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))
     6570
     6571#+mkcl (provide :uiop)
    63186572;;;; -------------------------------------------------------------------------
    63196573;;;; Handle upgrade as forward- and backward-compatibly as possible
    63206574;; See https://bugs.launchpad.net/asdf/+bug/485687
    63216575
    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)
    63346588
     
    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=3.4.5.67.8
    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          ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
     6638         ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
    63706639         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    63716640         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    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)))))))
    64256686
    64266687
     
    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))))
    64486714
     
    64606726;;;; Components
    64616727
    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)
    65236789
    65246790  ;; Backward compatible way of computing the FILE-TYPE of a component.
     
    65416807                       (duplicate-names-name c))))))
    65426808
    6543 
    6544 
    6545 (when-upgrading (:when (find-class 'component nil))
    6546   (defmethod reinitialize-instance :after ((c component) &rest initargs &key)
    6547     (declare (ignorable c initargs)) (values)))
    65486809
    65496810(with-upgradability ()
     
    66016862
    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."))
    66226887
    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
     6917children.")))
    66516918
    66526919(with-upgradability ()
     
    66616928                  (setf (gethash name hash) c))
    66626929        hash))))
    6663 
    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))))
    66766930
    66776931(with-upgradability ()
     
    67006954
    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)))
    67126967
    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)
    67166970
    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)))
    67206973
     
    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))
    67527009
     
    67707027;;;; Systems
    67717028
    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))
    68027058
     
    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)))
    68357095
    68367096  (defun reset-system (system &rest keys &key &allow-other-keys)
     
    68757135
    68767136  (defmethod component-build-pathname ((c component))
    6877     (declare (ignorable c))
    68787137    nil))
    68797138
     
    68817140;;;; Stamp cache
    68827141
    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)))
     7163
     7164  (defun unset-asdf-cache-entry (key)
     7165    (when *asdf-cache*
     7166      (remhash key *asdf-cache*)))
    69037167
    69047168  (defun consult-asdf-cache (key &optional thunk)
     
    69137177    `(consult-asdf-cache ,key #'(lambda () ,@body)))
    69147178
    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))))
    6920 
    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)))))
     7185
     7186  (defmacro with-asdf-cache ((&key key override) &body body)
     7187    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
    69237188
    69247189  (defun normalize-namestring (pathname)
     
    69397204
    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))))))
    69437209
    69447210;;;; -------------------------------------------------------------------------
    69457211;;;; Finding systems
    69467212
    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)))))
    70337300
     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))
     7307
    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)))
    70437313
    70447314  (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
     
    70817351
    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))))
    70897359
    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)))))))
    71267394
    71277395  (defun sysdef-central-registry-search (system)
     
    71887456    (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
    71897457
    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*))
    71947461
    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))
    72027468
    7203   (defvar *systems-being-defined* nil
    7204     "A hash-table of systems currently being defined keyed by name, or NIL")
    7205 
    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)))
    7210 
    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))))
    7216 
    7217   (defun clear-systems-being-defined ()
    7218     (when *systems-being-defined*
    7219       (clrhash *systems-being-defined*)))
    7220 
    7221   (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined)
    7222 
    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*)))
    72257472
    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))))))
    72507496
    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
     7540
     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.
     7545
     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)))")
     7550
     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))))))
    72917559
    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))))
    73247593
    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)))))))
    73677640
     
    73697642;;;; Finding components
    73707643
    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)))
    74487721
    7449   (defmethod find-component (base (actual component))
    7450     (declare (ignorable base))
     7722  (defmethod find-component ((base t) (actual component))
    74517723    actual)
    74527724
     
    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))))))))
     7754
    74787755
    74797756  (defun resolve-dependency-spec (component dep-spec)
     
    74887765
    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))))
    74937769
    74947770  (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
    7495     (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788
    7496     (resolve-dependency-name component (first arguments) (second arguments))))
     7771    (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788
    74977772
    74987773;;;; -------------------------------------------------------------------------
    74997774;;;; Operations
    75007775
    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)
    75107785
     
    75127787
    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)))
    75167792
    75177793(with-upgradability ()
     
    75207796      :initform nil :initarg :original-initargs :accessor operation-original-initargs)))
    75217797
     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)))
     
    75347812
    75357813(with-upgradability ()
    7536   (defparameter *operations* (make-hash-table :test 'equal))
     7814  (defparameter* *operations* (make-hash-table :test 'equal))
     7815
    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))))
    75407821
    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)
    7554 
    7555   (defclass build-op (operation) ()))
    7556 
     7833    nil))
    75577834
    75587835;;;; -------------------------------------------------------------------------
    75597836;;;; Actions
    75607837
    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)
    75787857
    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
     7860
     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)))
    75817866
    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
    7667 
    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>;
     7955
     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.]
    76717960
    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)))
    7679 
    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
    7682 
    7683 
    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))))
     7968
     7969
     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)))
     7987
    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)))
     8004
    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)))
     8019
    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)))
     8037
     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
     8043dependencies.")))
     8044
     8045
     8046;;;---------------------------------------------------------------------------
     8047;;; Help programmers catch obsolete OPERATION subclasses
     8048;;;---------------------------------------------------------------------------
     8049(with-upgradability ()
     8050  (define-condition operation-definition-warning (simple-warning)
     8051    ()
     8052    (:documentation "Warning condition related to definition of obsolete OPERATION objects."))
     8053
     8054  (define-condition operation-definition-error (simple-error)
     8055    ()
     8056    (:documentation "Error condition related to definition of incorrect OPERATION objects."))
     8057
     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)))))
     8066
     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)))))
     8075
     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))))))
     8085
     8086  (defmethod downward-operation ((o operation)) nil)
     8087  (defmethod sideway-operation ((o operation)) nil))
     8088
     8089
     8090;;;---------------------------------------------------------------------------
     8091;;; End of OPERATION class checking
     8092;;;---------------------------------------------------------------------------
    77268093
    77278094
     
    77378104
    77388105  (defmethod operation-done-p ((o operation) (c component))
    7739     (declare (ignorable o c))
    77408106    t)
    77418107
     
    77598125       t)))
    77608126  (defmethod output-files ((o operation) (c component))
    7761     (declare (ignorable o c))
    77628127    nil)
    77638128  (defun output-file (operation component)
     
    77738138
    77748139  (defmethod input-files ((o operation) (c component))
    7775     (declare (ignorable o c))
    77768140    nil)
    77778141
     
    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))))
    78478213
    78488214  (defmethod perform-with-restarts (operation component)
     
    78678233          (mark-operation-done operation component)
    78688234          (return))))))
    7869 
    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))))
    7874 
    78758235;;;; -------------------------------------------------------------------------
    78768236;;;; Actions to build Common Lisp software
    78778237
    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)))
    79238283
    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)))
    79288288
    79298289  (defclass test-op (selfward-operation)
    7930     ((selfward-operation :initform 'load-op))))
     8290    ((selfward-operation :initform 'load-op :allocation :class))))
    79318291
    79328292
     
    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))))
    79498303
     
    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))
    80728414
     
    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))
    80908426
    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)))))
    81058438
    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))
    81148443
     
    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))
    81258452
     
    81278454;;;; Plan
    81288455
    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))))
    81958523
    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
    81998526
    82008527  ;; TODO: eliminate NODE-FOR, use CONS.
     
    82078534
    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)))
    82128538
    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)))))))
    82338558
     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))))
     8570
    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)))))
    82418575
    82428576  (defmethod action-forced-p (plan operation component)
     
    82518585
    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))))
    8258 
    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))
     8590
     8591  (defmethod action-forced-p ((plan null) (operation operation) (component component))
    82618592    nil)
    82628593
    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))
    82668596
     
    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)))
    8280 
     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))
    82818607
    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))))
    83068632
    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)
    83138639
    8314   (defun direct-dependencies (operation component)
    8315     (reduce-direct-dependencies operation component #'acons nil))
    8316 
    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))
     8642
     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.
    83248648
    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)))))
    83748716
    83758717
     
    83828724
    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))))
    83898731
    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))
    84278769
     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.
     8783
    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
    84648827
    84658828
     
    84758838    (reverse (plan-actions-r plan)))
    84768839
    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))
    84818842
     
    84858846      (push (cons o c) (plan-actions-r p)))))
    84868847
    8487 
    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)
     
    84998859
    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)
     
    85068865
    85078866  (defmethod perform-plan :around ((plan t) &key)
     8867    #+xcl (declare (ignorable plan))
    85088868    (let ((*package* *package*)
    85098869          (*readtable* *readtable*))
     
    85288888
    85298889;;;; Incidental traversals
     8890
     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)
     
    85368899
    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))))
    85458908
     
    85558918
    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))
    85608924
     
    85758939;;;; Invoking Operations
    85768940
    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
    8600 
    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
     8964
     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.
    86048968
    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.
    86829046
    8683 This may change in the future as we will implement component-based strategy
    8684 for how to load or compile stuff")
    8685 
    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.")
     9049
     9050  (defmethod component-depends-on ((o prepare-op) (s system))
     9051    `((,*load-system-operation* ,@(component-sideway-dependencies s))))
     9052
     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)))
     9063
     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)
     
    87319113
    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."))
    87349118
    87359119  (defmethod perform ((o compile-op) (c require-system))
    8736     (declare (ignorable o c))
    87379120    nil)
    87389121
    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*)))
     
    87459127
    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)))))
    8788 
    87899170  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
    87909171
    8791 
    8792 ;;;; -------------------------------------------------------------------------
    8793 ;;; Internal hacks for backward-compatibility
    8794 
    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)
    8807 
    8808 ;;;; Backward compatibility with "inline methods"
    8809 (with-upgradability ()
    8810   (defparameter +asdf-methods+
    8811     '(perform-with-restarts perform explain output-files operation-done-p))
    8812 
    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)
    8823 
    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)))))))
    8837 
    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)))
    8842 
    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 1.1.2.20-fe6da9f) 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))))))
    8863 
    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)))
    8867 
    8868 
    8869 ;;;; load-sysdef
    8870 (with-upgradability ()
    8871   (defun load-sysdef (name pathname)
    8872     (load-asd pathname :name name))
    8873 
    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))))
    8880 
    8881 
    8882 ;;;; -------------------------------------------------------------------------
    8883 ;;;; Defsystem
    8884 
    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)
    8898 
    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)))))
    8923 
    8924 
    8925 ;;; Component class
    8926 (with-upgradability ()
    8927   (defvar *default-component-class* 'cl-source-file)
    8928 
    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))))
    8946 
    8947 
    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))))
    8956 
    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)))))
    8963 
    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))
    8967 
    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)))
    8980 
    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))))))
    9011 
    9012 
    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)))
    9082 
    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)))))
    9119 
    9120   (defmacro defsystem (name &body options)
    9121     `(apply 'register-system-definition ',name ',options)))
    9122 ;;;; -------------------------------------------------------------------------
    9123 ;;;; ASDF-Bundle
    9124 
    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)
    9144 
    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)))
    9153 
    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"))
    9157 
    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))))
    9167 
    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.
    9172 
    9173   (defclass no-ld-flags-op (operation) ())
    9174 
    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"))
    9179 
    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."))
    9183 
    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"))
    9187 
    9188   (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
    9189 
    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)))
    9193 
    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"))
    9197 
    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."))
    9201 
    9202   (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) ()
    9203     (:documentation "Create a single fasl for the system and its dependencies."))
    9204 
    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."))
    9209 
    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."))
    9213 
    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"))
    9219 
    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")))))
    9232 
    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))))))))
    9242 
    9243   (defmethod output-files ((o bundle-op) (c system))
    9244     (bundle-output-files o c))
    9245 
    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)))
    9251 
    9252   (defclass compiled-file (file-component)
    9253     ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
    9254 
    9255   (defclass precompiled-system (system)
    9256     ((build-pathname :initarg :fasl)))
    9257 
    9258   (defclass prebuilt-system (system)
    9259     ((build-pathname :initarg :static-library :initarg :lib
    9260                      :accessor prebuilt-system-static-library))))
    9261 
    9262 
    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))
    9274 
    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))))
    9297 
    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))
    9303 
    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)))))
    9311 
    9312   (defgeneric* (trivial-system-p) (component))
    9313 
    9314   (defun user-system-p (s)
    9315     (and (typep s 'system)
    9316          (not (builtin-system-p s))
    9317          (not (trivial-system-p s)))))
    9318 
    9319 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
    9320   (deftype user-system () '(and system (satisfies user-system-p))))
    9321 
    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 ;;;
    9328 ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
    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)))
    9342 
    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)))
    9348 
    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))))))
    9357 
    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)))
    9361 
    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)))
    9374 
    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))))
    9398 
    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)))
    9411 
    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)))
    9415 
    9416   (defmethod perform ((o load-fasl-op) c)
    9417     (declare (ignorable o c))
    9418     nil)
    9419 
    9420   (defmethod perform ((o load-fasl-op) (c system))
    9421     (when (input-files o c)
    9422       (perform-lisp-load-fasl o c)))
    9423 
    9424   (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
    9425     (mark-operation-done (find-operation o 'load-op) c)))
    9426 
    9427 ;;;
    9428 ;;; PRECOMPILED FILES
    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)))
    9436 
    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))
    9452 
    9453 ;;;
    9454 ;;; Pre-built systems
    9455 ;;;
    9456 (with-upgradability ()
    9457   (defmethod trivial-system-p ((s prebuilt-system))
    9458     (declare (ignorable s))
    9459     t)
    9460 
    9461   (defmethod perform ((o lib-op) (c prebuilt-system))
    9462     (declare (ignorable o c))
    9463     nil)
    9464 
    9465   (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
    9466     (declare (ignorable o c))
    9467     nil)
    9468 
    9469   (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
    9470     (declare (ignorable o))
    9471     nil))
    9472 
    9473 
    9474 ;;;
    9475 ;;; PREBUILT SYSTEM CREATOR
    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))))
    9481 
    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)))))
    9522 
    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)))))
    9541 
    9542   (defmethod input-files ((o load-op) (s precompiled-system))
    9543     (declare (ignorable o))
    9544     (bundle-output-files (find-operation o 'fasl-op) s))
    9545 
    9546   (defmethod perform ((o load-op) (s precompiled-system))
    9547     (perform-lisp-load-fasl o s))
    9548 
    9549   (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
    9550     (declare (ignorable o))
    9551     `((load-op ,s) ,@(call-next-method))))
    9552 
    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 |#
    9557 
    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))
    9577 
    9578   (defun register-pre-built-system (name)
    9579     (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
    9580 
    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))))))
    9600 
    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)))
    9606 
    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)))
    9610 
    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
    9616 
    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)
    9633 
    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) ())
    9643 
    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))))
    9651 
    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)))
    9659 
    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))
    9691 
    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)))
    97029172
    97039173;;;; ---------------------------------------------------------------------------
    97049174;;;; asdf-output-translations
    97059175
    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)
    97579224
    97589225  (defun output-translations-initialized-p ()
     
    98349301               (return `(:output-translations ,@(nreverse directives)))))))))
    98359302
    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))))))
    100179483
    10018 ;;;; -------------------------------------------------------------------------
    10019 ;;; Backward-compatible interfaces
    10020 
    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)
    10038 
    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) ())
    10050 
    10051   (defun component-load-dependencies (component)
    10052     ;; Old deprecated name for the same thing. Please update your software.
    10053     (component-sideway-dependencies component))
    10054 
    10055   (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
    10056   (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
    10057 
    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))
    10070 
    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,
    10080 or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
    10081 if that's whay you mean." ;;)
    10082     (system-source-file x))
    10083 
    10084   (defgeneric* (traverse) (operation component &key &allow-other-keys)
    10085     (:documentation
    10086      "Generate and return a plan for performing OPERATION on COMPONENT.
    10087 
    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))
    10092 
    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))))
    10095 
    10096 
    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")))
    10114