Changeset 14928


Ignore:
Timestamp:
12/26/16 19:13:28 (5 years ago)
Author:
Mark Evenson
Message:

Update to asdf-3.1.7.43

Location:
trunk/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/doc/asdf/asdf.texinfo

    r14920 r14928  
    6666@titlepage
    6767@title ASDF: Another System Definition Facility
    68 @subtitle Manual for Version 3.1.7.40
     68@subtitle Manual for Version 3.1.7.43
    6969@c The following two commands start the copyright page.
    7070@page
     
    8383@top ASDF: Another System Definition Facility
    8484@ifnottex
    85 Manual for Version 3.1.7.37
     85Manual for Version 3.1.7.43
    8686@end ifnottex
    8787
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r14920 r14928  
    11;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
    2 ;;; This is ASDF 3.1.7.40: Another System Definition Facility.
     2;;; This is ASDF 3.1.7.43: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    10201020   #:defun* #:defgeneric*
    10211021   #:nest #:if-let ;; basic flow control
     1022   #:parse-body ;; macro definition helper
    10221023   #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
    10231024   #:remove-plist-keys #:remove-plist-key ;; plists
     
    10281029   #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
    10291030   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
    1030    #:standard-case-symbol-name #:find-standard-case-symbol
     1031   #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols
    10311032   #:coerce-class ;; CLOS
    10321033   #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
     
    10371038   #:call-function #:call-functions #:register-hook-function
    10381039   #:lexicographic< #:lexicographic<= ;; version
    1039    #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p
     1040   #:simple-style-warning #:style-warn ;; simple style warnings
    10401041   #:match-condition-p #:match-any-condition-p ;; conditions
    10411042   #:call-with-muffled-conditions #:with-muffled-conditions
     
    11231124             ,else-form)))))
    11241125
     1126;;; Macro definition helper
     1127(with-upgradability ()
     1128  (defun parse-body (body &key documentation whole) ;; from alexandria
     1129    "Parses BODY into (values remaining-forms declarations doc-string).
     1130Documentation strings are recognized only if DOCUMENTATION is true.
     1131Syntax errors in body are signalled and WHOLE is used in the signal
     1132arguments when given."
     1133    (let ((doc nil)
     1134          (decls nil)
     1135          (current nil))
     1136      (tagbody
     1137       :declarations
     1138         (setf current (car body))
     1139         (when (and documentation (stringp current) (cdr body))
     1140           (if doc
     1141               (error "Too many documentation strings in ~S." (or whole body))
     1142               (setf doc (pop body)))
     1143           (go :declarations))
     1144         (when (and (listp current) (eql (first current) 'declare))
     1145           (push (pop body) decls)
     1146           (go :declarations)))
     1147      (values body (nreverse decls) doc))))
     1148
     1149
    11251150;;; List manipulation
    11261151(with-upgradability ()
     
    11591184
    11601185
    1161 ;;; remove a key from a plist, i.e. for keyword argument cleanup
     1186;;; Remove a key from a plist, i.e. for keyword argument cleanup
    11621187(with-upgradability ()
    11631188  (defun remove-plist-key (key plist)
     
    15091534
    15101535
    1511 ;;; Version handling
    1512 (with-upgradability ()
     1536;;; Lexicographic comparison of lists of numbers
     1537(with-upgradability ()
     1538  (defun lexicographic< (element< x y)
     1539    "Lexicographically compare two lists of using the function element< to compare elements.
     1540element< is a strict total order; the resulting order on X and Y will also be strict."
     1541    (cond ((null y) nil)
     1542          ((null x) t)
     1543          ((funcall element< (car x) (car y)) t)
     1544          ((funcall element< (car y) (car x)) nil)
     1545          (t (lexicographic< element< (cdr x) (cdr y)))))
     1546
     1547  (defun lexicographic<= (element< x y)
     1548    "Lexicographically compare two lists of using the function element< to compare elements.
     1549element< is a strict total order; the resulting order on X and Y will be a non-strict total order."
     1550    (not (lexicographic< element< y x))))
     1551
     1552
     1553;;; Simple style warnings
     1554(with-upgradability ()
     1555  (define-condition simple-style-warning
     1556      #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning)
     1557    ())
     1558
     1559  (defun style-warn (datum &rest arguments)
     1560    (etypecase datum
     1561      (string (warn (make-condition 'simple-style-warning :format-control datum :format-arguments arguments)))
     1562      (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments))
     1563      (style-warning (apply 'warn datum arguments)))))
     1564
     1565
     1566;;; Condition control
     1567
     1568(with-upgradability ()
     1569  (defparameter +simple-condition-format-control-slot+
     1570    #+abcl 'system::format-control
     1571    #+allegro 'excl::format-control
     1572    #+(or clasp ecl mkcl) 'si::format-control
     1573    #+clisp 'system::$format-control
     1574    #+clozure 'ccl::format-control
     1575    #+(or cmucl scl) 'conditions::format-control
     1576    #+(or gcl lispworks) 'conditions::format-string
     1577    #+sbcl 'sb-kernel:format-control
     1578    #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil
     1579    "Name of the slot for FORMAT-CONTROL in simple-condition")
     1580
     1581  (defun match-condition-p (x condition)
     1582    "Compare received CONDITION to some pattern X:
     1583a symbol naming a condition class,
     1584a simple vector of length 2, arguments to find-symbol* with result as above,
     1585or a string describing the format-control of a simple-condition."
     1586    (etypecase x
     1587      (symbol (typep condition x))
     1588      ((simple-vector 2)
     1589       (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
     1590      (function (funcall x condition))
     1591      (string (and (typep condition 'simple-condition)
     1592                   ;; On SBCL, it's always set and the check triggers a warning
     1593                   #+(or allegro clozure cmucl lispworks scl)
     1594                   (slot-boundp condition +simple-condition-format-control-slot+)
     1595                   (ignore-errors (equal (simple-condition-format-control condition) x))))))
     1596
     1597  (defun match-any-condition-p (condition conditions)
     1598    "match CONDITION against any of the patterns of CONDITIONS supplied"
     1599    (loop :for x :in conditions :thereis (match-condition-p x condition)))
     1600
     1601  (defun call-with-muffled-conditions (thunk conditions)
     1602    "calls the THUNK in a context where the CONDITIONS are muffled"
     1603    (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
     1604                                      (muffle-warning c)))))
     1605      (funcall thunk)))
     1606
     1607  (defmacro with-muffled-conditions ((conditions) &body body)
     1608    "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
     1609    `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
     1610
     1611;;; Conditions
     1612
     1613(with-upgradability ()
     1614  (define-condition not-implemented-error (error)
     1615    ((functionality :initarg :functionality)
     1616     (format-control :initarg :format-control)
     1617     (format-arguments :initarg :format-arguments))
     1618    (:report (lambda (condition stream)
     1619               (format stream "Not implemented: ~s~@[ ~?~]"
     1620                       (slot-value condition 'functionality)
     1621                       (slot-value condition 'format-control)
     1622                       (slot-value condition 'format-arguments)))))
     1623
     1624  (defun not-implemented-error (functionality &optional format-control &rest format-arguments)
     1625    "Signal an error because some FUNCTIONALITY is not implemented in the current version
     1626of the software on the current platform; it may or may not be implemented in different combinations
     1627of version of the software and of the underlying platform. Optionally, report a formatted error
     1628message."
     1629    (error 'not-implemented-error
     1630           :functionality functionality
     1631           :format-control format-control
     1632           :format-arguments format-arguments))
     1633
     1634  (define-condition parameter-error (error)
     1635    ((functionality :initarg :functionality)
     1636     (format-control :initarg :format-control)
     1637     (format-arguments :initarg :format-arguments))
     1638    (:report (lambda (condition stream)
     1639               (apply 'format stream
     1640                       (slot-value condition 'format-control)
     1641                       (slot-value condition 'functionality)
     1642                       (slot-value condition 'format-arguments)))))
     1643
     1644  ;; Note that functionality MUST be passed as the second argument to parameter-error, just after
     1645  ;; the format-control. If you want it to not appear in first position in actual message, use
     1646  ;; ~* and ~:* to adjust parameter order.
     1647  (defun parameter-error (format-control functionality &rest format-arguments)
     1648    "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying
     1649platform does not accept a given parameter or combination of parameters. Report a formatted error
     1650message, that takes the functionality as its first argument (that can be skipped with ~*)."
     1651    (error 'parameter-error
     1652           :functionality functionality
     1653           :format-control format-control
     1654           :format-arguments format-arguments)))
     1655
     1656(uiop/package:define-package :uiop/version
     1657  (:recycle :uiop/version :uiop/utility :asdf)
     1658  (:use :uiop/common-lisp :uiop/package :uiop/utility)
     1659  (:export
     1660   #:*uiop-version*
     1661   #:parse-version #:unparse-version #:version< #:version<= ;; version support, moved from uiop/utility
     1662   #:next-version
     1663   #:deprecated-function-condition #:deprecated-function-name ;; deprecation control
     1664   #:deprecated-function-style-warning #:deprecated-function-warning
     1665   #:deprecated-function-error #:deprecated-function-should-be-deleted
     1666   #:version-deprecation #:with-deprecation))
     1667(in-package :uiop/version)
     1668
     1669(with-upgradability ()
     1670  (defparameter *uiop-version* "3.1.7.43")
     1671
    15131672  (defun unparse-version (version-list)
    15141673    "From a parsed version (a list of natural numbers), compute the version string"
     
    15421701        version-list)))
    15431702
    1544   (defun lexicographic< (element< x y)
    1545     "Lexicographically compare two lists of using the function element< to compare elements.
    1546 element< is a strict total order; the resulting order on X and Y will also be strict."
    1547     (cond ((null y) nil)
    1548           ((null x) t)
    1549           ((funcall element< (car x) (car y)) t)
    1550           ((funcall element< (car y) (car x)) nil)
    1551           (t (lexicographic< element< (cdr x) (cdr y)))))
    1552 
    1553   (defun lexicographic<= (element< x y)
    1554     "Lexicographically compare two lists of using the function element< to compare elements.
    1555 element< is a strict total order; the resulting order on X and Y will be a non-strict total order."
    1556     (not (lexicographic< element< y x)))
     1703  (defun next-version (version)
     1704    "When VERSION is not nil, it is a string, then parse it as a version, compute the next version
     1705and return it as a string."
     1706    (when version
     1707      (let ((version-list (parse-version version)))
     1708        (incf (car (last version-list)))
     1709        (unparse-version version-list))))
    15571710
    15581711  (defun version< (version1 version2)
    1559     "Compare two version strings"
     1712    "Given two version strings, return T if the second is strictly newer"
    15601713    (let ((v1 (parse-version version1 nil))
    15611714          (v2 (parse-version version2 nil)))
     
    15631716
    15641717  (defun version<= (version1 version2)
    1565     "Compare two version strings"
    1566     (not (version< version2 version1)))
    1567 
    1568   (defun version-compatible-p (provided-version required-version)
    1569     "Is the provided version a compatible substitution for the required-version?
    1570 If major versions differ, it's not compatible.
    1571 If they are equal, then any later version is compatible,
    1572 with later being determined by a lexicographical comparison of minor numbers."
    1573     (let ((x (parse-version provided-version nil))
    1574           (y (parse-version required-version nil)))
    1575       (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x))))))
    1576 
    1577 
    1578 ;;; Condition control
    1579 
    1580 (with-upgradability ()
    1581   (defparameter +simple-condition-format-control-slot+
    1582     #+abcl 'system::format-control
    1583     #+allegro 'excl::format-control
    1584     #+(or clasp ecl mkcl) 'si::format-control
    1585     #+clisp 'system::$format-control
    1586     #+clozure 'ccl::format-control
    1587     #+(or cmucl scl) 'conditions::format-control
    1588     #+(or gcl lispworks) 'conditions::format-string
    1589     #+sbcl 'sb-kernel:format-control
    1590     #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil
    1591     "Name of the slot for FORMAT-CONTROL in simple-condition")
    1592 
    1593   (defun match-condition-p (x condition)
    1594     "Compare received CONDITION to some pattern X:
    1595 a symbol naming a condition class,
    1596 a simple vector of length 2, arguments to find-symbol* with result as above,
    1597 or a string describing the format-control of a simple-condition."
    1598     (etypecase x
    1599       (symbol (typep condition x))
    1600       ((simple-vector 2)
    1601        (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
    1602       (function (funcall x condition))
    1603       (string (and (typep condition 'simple-condition)
    1604                    ;; On SBCL, it's always set and the check triggers a warning
    1605                    #+(or allegro clozure cmucl lispworks scl)
    1606                    (slot-boundp condition +simple-condition-format-control-slot+)
    1607                    (ignore-errors (equal (simple-condition-format-control condition) x))))))
    1608 
    1609   (defun match-any-condition-p (condition conditions)
    1610     "match CONDITION against any of the patterns of CONDITIONS supplied"
    1611     (loop :for x :in conditions :thereis (match-condition-p x condition)))
    1612 
    1613   (defun call-with-muffled-conditions (thunk conditions)
    1614     "calls the THUNK in a context where the CONDITIONS are muffled"
    1615     (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
    1616                                       (muffle-warning c)))))
    1617       (funcall thunk)))
    1618 
    1619   (defmacro with-muffled-conditions ((conditions) &body body)
    1620     "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
    1621     `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
    1622 
    1623 ;;; Conditions
    1624 
    1625 (with-upgradability ()
    1626   (define-condition not-implemented-error (error)
    1627     ((functionality :initarg :functionality)
    1628      (format-control :initarg :format-control)
    1629      (format-arguments :initarg :format-arguments))
    1630     (:report (lambda (condition stream)
    1631                (format stream "Not implemented: ~s~@[ ~?~]"
    1632                        (slot-value condition 'functionality)
    1633                        (slot-value condition 'format-control)
    1634                        (slot-value condition 'format-arguments)))))
    1635 
    1636   (defun not-implemented-error (functionality &optional format-control &rest format-arguments)
    1637     "Signal an error because some FUNCTIONALITY is not implemented in the current version
    1638 of the software on the current platform; it may or may not be implemented in different combinations
    1639 of version of the software and of the underlying platform. Optionally, report a formatted error
    1640 message."
    1641     (error 'not-implemented-error
    1642            :functionality functionality
    1643            :format-control format-control
    1644            :format-arguments format-arguments))
    1645 
    1646   (define-condition parameter-error (error)
    1647     ((functionality :initarg :functionality)
    1648      (format-control :initarg :format-control)
    1649      (format-arguments :initarg :format-arguments))
    1650     (:report (lambda (condition stream)
    1651                (apply 'format stream
    1652                        (slot-value condition 'format-control)
    1653                        (slot-value condition 'functionality)
    1654                        (slot-value condition 'format-arguments)))))
    1655 
    1656   ;; Note that functionality MUST be passed as the second argument to parameter-error, just after
    1657   ;; the format-control. If you want it to not appear in first position in actual message, use
    1658   ;; ~* and ~:* to adjust parameter order.
    1659   (defun parameter-error (format-control functionality &rest format-arguments)
    1660     "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying
    1661 platform does not accept a given parameter or combination of parameters. Report a formatted error
    1662 message, that takes the functionality as its first argument (that can be skipped with ~*)."
    1663     (error 'parameter-error
    1664            :functionality functionality
    1665            :format-control format-control
    1666            :format-arguments format-arguments)))
    1667 
     1718    "Given two version strings, return T if the second is newer or the same"
     1719    (not (version< version2 version1))))
     1720
     1721
     1722(with-upgradability ()
     1723  (define-condition deprecated-function-condition (condition)
     1724    ((name :initarg :name :reader deprecated-function-name)))
     1725  (define-condition deprecated-function-style-warning (deprecated-function-condition style-warning) ())
     1726  (define-condition deprecated-function-warning (deprecated-function-condition warning) ())
     1727  (define-condition deprecated-function-error (deprecated-function-condition error) ())
     1728  (define-condition deprecated-function-should-be-deleted (deprecated-function-condition error) ())
     1729
     1730  (defun deprecated-function-condition-kind (type)
     1731    (ecase type
     1732      ((deprecated-function-style-warning) :style-warning)
     1733      ((deprecated-function-warning) :warning)
     1734      ((deprecated-function-error) :error)
     1735      ((deprecated-function-should-be-deleted) :delete)))
     1736
     1737  (defmethod print-object ((c deprecated-function-condition) stream)
     1738    (let ((name (deprecated-function-name c)))
     1739      (cond
     1740        (*print-readably*
     1741         (let ((fmt "#.(make-condition '~S :name ~S)")
     1742               (args (list (type-of c) name)))
     1743           (if *read-eval*
     1744               (apply 'format stream fmt args)
     1745               (error "Can't print ~?" fmt args))))
     1746        (*print-escape*
     1747         (print-unreadable-object (c stream :type t) (format stream ":name ~S" name)))
     1748        (t
     1749         (let ((*package* (find-package :cl))
     1750               (type (type-of c)))
     1751           (format stream
     1752                   (if (eq type 'deprecated-function-should-be-deleted)
     1753                       "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete"
     1754                       "~A: Using deprecated function ~S -- please update your code to use a newer API.~
     1755~@[~%The docstring for this function says:~%~A~%~]")
     1756                   type name (when (symbolp name) (documentation name 'function))))))))
     1757
     1758  (defun notify-deprecated-function (status name)
     1759    (ecase status
     1760      ((nil) nil)
     1761      ((:style-warning) (style-warn 'deprecated-function-style-warning :name name))
     1762      ((:warning) (warn 'deprecated-function-warning :name name))
     1763      ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error :name name))))
     1764
     1765  (defun version-deprecation (version &key (style-warning nil)
     1766                                        (warning (next-version style-warning))
     1767                                        (error (next-version warning))
     1768                                        (delete (next-version error)))
     1769    "Given a VERSION string, and the starting versions for notifying the programmer of
     1770various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION
     1771that is the highest level that has a declared version older than the specified version.
     1772Each start version for a level of deprecation can be specified by a keyword argument, or
     1773if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation."
     1774    (cond
     1775      ((and delete (version<= delete version)) :delete)
     1776      ((and error (version<= error version)) :error)
     1777      ((and warning (version<= warning version)) :warning)
     1778      ((and style-warning (version<= style-warning version)) :style-warning)))
     1779
     1780  (defmacro with-deprecation ((level) &body definitions)
     1781    "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the
     1782DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function
     1783when it is compiled or called.
     1784
     1785Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet),
     1786:STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used),
     1787:ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while
     1788at that level).
     1789
     1790Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD
     1791from instrumentation by enclosing it in a PROGN."
     1792    (let ((level (eval level)))
     1793      (check-type level (member nil :style-warning :warning :error :delete))
     1794      (when (eq level :delete)
     1795        (error 'deprecated-function-should-be-deleted :name
     1796               (mapcar 'second
     1797                       (remove-if-not #'(lambda (x) (member x '(defun defmethod)))
     1798                                      definitions :key 'first))))
     1799      (labels ((instrument (name head body whole)
     1800                 (if level
     1801                     (let ((notifiedp
     1802                            (intern (format nil "*~A-~A-~A-~A*"
     1803                                            :deprecated-function level name :notified-p))))
     1804                       (multiple-value-bind (remaining-forms declarations doc-string)
     1805                           (parse-body body :documentation t :whole whole)
     1806                         `(progn
     1807                            (defparameter ,notifiedp nil)
     1808                            ;; tell some implementations to use the compiler-macro
     1809                            (declaim (inline ,name))
     1810                            (define-compiler-macro ,name (&whole form &rest args)
     1811                              (declare (ignore args))
     1812                              (notify-deprecated-function ,level ',name)
     1813                              form)
     1814                            (,@head ,@(when doc-string (list doc-string)) ,@declarations
     1815                                    (unless ,notifiedp
     1816                                      (setf ,notifiedp t)
     1817                                      (notify-deprecated-function ,level ',name))
     1818                                    ,@remaining-forms))))
     1819                     `(progn
     1820                        (eval-when (:compile-toplevel :load-toplevel :execute)
     1821                          (setf (compiler-macro-function ',name) nil))
     1822                        (declaim (notinline ,name))
     1823                        (,@head ,@body)))))
     1824        `(progn
     1825           ,@(loop :for form :in definitions :collect
     1826               (cond
     1827                 ((and (consp form) (eq (car form) 'defun))
     1828                  (instrument (second form) (subseq form 0 3) (subseq form 3) form))
     1829                 ((and (consp form) (eq (car form) 'defmethod))
     1830                  (let ((body-start (if (listp (third form)) 3 4)))
     1831                    (instrument (second form)
     1832                                (subseq form 0 body-start)
     1833                                (subseq form body-start)
     1834                                form)))
     1835                 (t
     1836                  form))))))))
    16681837;;;; ---------------------------------------------------------------------------
    16691838;;;; Access to the Operating System
     
    56055774(with-upgradability ()
    56065775  ;;; Internal helpers for run-program
    5607   (defun %normalize-command (command)
    5608     "Given a COMMAND as a list or string, transform it in a format suitable
    5609 for the implementation's underlying run-program function"
    5610     (etypecase command
    5611       #+os-unix (string `("/bin/sh" "-c" ,command))
    5612       #+os-unix (list command)
    5613       #+os-windows
    5614       (string
    5615        ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
    5616        ;; when the command contains spaces or special characters:
    5617        ;; IIUC, the system will use space as a separator, but the argv-decoding libraries won't,
    5618        ;; and you're supposed to use an extra argument to CreateProcess to bridge the gap,
    5619        ;; but neither allegro nor clisp provide access to that argument.
    5620        #+(or allegro clisp) (strcat "cmd /c " command)
    5621        ;; On ClozureCL for Windows, we assume you are using
    5622        ;; r15398 or later in 1.9 or later,
    5623        ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
    5624        ;; On SBCL, we assume the patch from https://bugs.launchpad.net/sbcl/+bug/1503496
    5625        #+(or clozure sbcl) (cons "cmd" (strcat "/c " command))
    5626        ;; NB: On other Windows implementations, this is utterly bogus
    5627        ;; except in the most trivial cases where no quoting is needed.
    5628        ;; Use at your own risk.
    5629        #-(or allegro clisp clozure sbcl)
    5630        (parameter-error "~S doesn't support string commands on Windows on this lisp: ~S" '%normalize-command command))
    5631       #+os-windows
    5632       (list
    5633        #+allegro (escape-windows-command command)
    5634        #-allegro command)))
    5635 
    56365776  (defun %normalize-io-specifier (specifier &optional role)
    56375777    "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent
     
    59956135      (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
    59966136                       'launch-program))
    5997     ;; see comments for these functions
    5998     (%handle-if-does-not-exist input if-input-does-not-exist)
    5999     (%handle-if-exists output if-output-exists)
    6000     (%handle-if-exists error-output if-error-output-exists)
    60016137    #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
    6002     (let* ((%command (%normalize-command command))
    6003            (%input (%normalize-io-specifier input :input))
    6004            (%output (%normalize-io-specifier output :output))
    6005            (%error-output (%normalize-io-specifier error-output :error-output))
    6006            #+(and allegro os-windows)
    6007            (interactive (%interactivep input output error-output))
    6008            (process*
    6009              (nest
    6010               #-(or allegro mkcl sbcl) (with-current-directory (directory))
    6011               #+(or allegro ecl lispworks mkcl) (multiple-value-list)
    6012               (apply
    6013                #+abcl #'sys:run-program
    6014                #+allegro 'excl:run-shell-command
    6015                #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector)
    6016                #+(and allegro os-windows) %command
    6017                #+clozure 'ccl:run-program
    6018                #+(or cmucl ecl scl) 'ext:run-program
    6019                #+lispworks 'system:run-shell-command
    6020                #+lispworks (cons "/usr/bin/env" %command) ; LW wants a full path
    6021                #+mkcl 'mk-ext:run-program
    6022                #+sbcl 'sb-ext:run-program
    6023                (append
    6024                 #+(or abcl clozure cmucl ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
    6025                 `(:input ,%input :output ,%output
    6026                   #.(or #+(or allegro lispworks) :error-output :error) ,%error-output
    6027                   :wait nil :element-type ,element-type :external-format ,external-format
    6028                   :if-input-does-not-exist :error
    6029                   :if-output-exists :append
    6030                   #-(or allegro lispworks) :if-error-exists
    6031                   #+(or allegro lispworks) :if-error-output-exists :append
    6032                   :allow-other-keys t)
    6033                 #+allegro `(:directory ,directory)
    6034                 #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide))
    6035                 #+lispworks `(:save-exit-status t)
    6036                 #+mkcl `(:directory ,(native-namestring directory))
    6037                 #+sbcl `(:search t)
    6038                 #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys
    6039                 #+sbcl (if directory keys (remove-plist-key :directory keys))))))
    6040            (process-info (make-instance 'process-info)))
    6041       (labels ((prop (key value) (setf (slot-value process-info key) value)))
    6042         #+allegro
    6043         (cond
    6044           (separate-streams
    6045            (destructuring-bind (in out err pid) process*
    6046              (prop 'process pid)
    6047              (when (eq input :stream) (prop 'input-stream in))
    6048              (when (eq output :stream) (prop 'output-stream out))
    6049              (when (eq error-output :stream) (prop 'error-stream err))))
    6050           (t
    6051            (prop 'process (third process*))
    6052            (let ((x (first process*)))
    6053              (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
    6054                (0)
    6055                (1 (prop 'input-stream x))
    6056                (2 (prop 'output-stream x))
    6057                (3 (prop 'bidir-stream x))))
    6058            (when (eq error-output :stream)
    6059              (prop 'error-stream (second process*)))))
    6060         #+(or abcl clozure cmucl sbcl scl)
    6061         (progn
    6062           (prop 'process process*)
    6063           (when (eq input :stream)
    6064             (prop 'input-stream
    6065                   #+abcl (symbol-call :sys :process-input process*)
    6066                   #+clozure (ccl:external-process-input-stream process*)
    6067                   #+(or cmucl scl) (ext:process-input process*)
    6068                   #+sbcl (sb-ext:process-input process*)))
    6069           (when (eq output :stream)
    6070             (prop 'output-stream
    6071                   #+abcl (symbol-call :sys :process-output process*)
    6072                   #+clozure (ccl:external-process-output-stream process*)
    6073                   #+(or cmucl scl) (ext:process-output process*)
    6074                   #+sbcl (sb-ext:process-output process*)))
     6138    (nest
     6139     (progn ;; see comments for these functions
     6140       (%handle-if-does-not-exist input if-input-does-not-exist)
     6141       (%handle-if-exists output if-output-exists)
     6142       (%handle-if-exists error-output if-error-output-exists))
     6143     (let ((process-info (make-instance 'process-info))
     6144           (input (%normalize-io-specifier input :input))
     6145           (output (%normalize-io-specifier output :output))
     6146           (error-output (%normalize-io-specifier error-output :error-output))
     6147           #+(and allegro os-windows) (interactive (%interactivep input output error-output))
     6148           (command
     6149            (etypecase command
     6150              #+os-unix (string `("/bin/sh" "-c" ,command))
     6151              #+os-unix (list command)
     6152              #+os-windows
     6153              (string
     6154               ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
     6155               ;; when the command contains spaces or special characters:
     6156               ;; IIUC, the system will use space as a separator,
     6157               ;; but the C++ argv-decoding libraries won't, and
     6158               ;; you're supposed to use an extra argument to CreateProcess to bridge the gap,
     6159               ;; yet neither allegro nor clisp provide access to that argument.
     6160               #+(or allegro clisp) (strcat "cmd /c " command)
     6161               ;; On ClozureCL for Windows, we assume you are using
     6162               ;; r15398 or later in 1.9 or later,
     6163               ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
     6164               ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13)
     6165               #+(or clozure sbcl) (cons "cmd" (strcat "/c " command))
     6166               ;; NB: On other Windows implementations, this is utterly bogus
     6167               ;; except in the most trivial cases where no quoting is needed.
     6168               ;; Use at your own risk.
     6169               #-(or allegro clisp clozure sbcl)
     6170               (parameter-error "~S doesn't support string commands on Windows on this lisp: ~S"
     6171                                'launch-program command))
     6172              #+os-windows
     6173              (list
     6174               #+allegro (escape-windows-command command)
     6175               #-allegro command)))))
     6176     #+(or abcl (and allegro os-unix) clozure cmucl ecl mkcl sbcl)
     6177     (let ((program (car command))
     6178           #-allegro (arguments (cdr command))))
     6179     #+(and sbcl os-windows)
     6180     (multiple-value-bind (arguments escape-arguments)
     6181         (if (listp arguments)
     6182             (values arguments t)
     6183             (values (list arguments) nil)))
     6184     #-(or allegro mkcl sbcl) (with-current-directory (directory))
     6185     (multiple-value-bind
     6186       #+(or abcl clozure cmucl sbcl scl) (process)
     6187       #+allegro (in-or-io out-or-err err-or-pid pid-or-nil)
     6188       #+ecl (stream code process)
     6189       #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil)
     6190       #+mkcl (stream process code)
     6191       #.`(apply
     6192           #+abcl 'sys:run-program
     6193           #+allegro ,@'('excl:run-shell-command
     6194                         #+os-unix (coerce (cons program command) 'vector)
     6195                         #+os-windows command)
     6196           #+clozure 'ccl:run-program
     6197           #+(or cmucl ecl scl) 'ext:run-program
     6198           #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed
     6199           #+mkcl 'mk-ext:run-program
     6200           #+sbcl 'sb-ext:run-program
     6201           #+(or abcl clozure cmucl ecl mkcl sbcl) ,@'(program arguments)
     6202           #+(and sbcl os-windows) ,@'(:escape-arguments escape-arguments)
     6203           :input input :if-input-does-not-exist :error
     6204           :output output :if-output-exists :append
     6205           ,(or #+(or allegro lispworks) :error-output :error) error-output
     6206           ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append
     6207           :wait nil :element-type element-type :external-format external-format
     6208           :allow-other-keys t
     6209           #+allegro ,@`(:directory directory
     6210                         #+os-windows ,@'(:show-window (if interactive nil :hide)))
     6211           #+lispworks ,@'(:save-exit-status t)
     6212           #+mkcl ,@'(:directory (native-namestring directory))
     6213           #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys
     6214           #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys)))))
     6215     (labels ((prop (key value) (setf (slot-value process-info key) value)))
     6216       #+allegro
     6217       (cond
     6218         (separate-streams
     6219          (prop 'process pid-or-nil)
     6220          (when (eq input :stream) (prop 'input-stream in-or-io))
     6221          (when (eq output :stream) (prop 'output-stream out-or-err))
     6222          (when (eq error-output :stream) (prop 'error-stream err-or-pid)))
     6223         (t
     6224          (prop 'process err-or-pid)
     6225          (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
     6226            (0)
     6227            (1 (prop 'input-stream in-or-io))
     6228            (2 (prop 'output-stream in-or-io))
     6229            (3 (prop 'bidir-stream in-or-io)))
    60756230          (when (eq error-output :stream)
    6076             (prop 'error-output-stream
    6077                   #+abcl (symbol-call :sys :process-error process*)
    6078                   #+clozure (ccl:external-process-error-stream process*)
    6079                   #+(or cmucl scl) (ext:process-error process*)
    6080                   #+sbcl (sb-ext:process-error process*))))
    6081         #+(or ecl mkcl)
    6082         (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
    6083           (declare (ignore code))
    6084           (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
    6085             (unless (zerop mode)
    6086               (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream)))
    6087           (prop 'process process))
    6088         #+lispworks
    6089         (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
    6090           (if (or (plusp mode) (eq error-output :stream))
    6091               (destructuring-bind (io err pid) process*
    6092                 #+lispworks7+ (declare (ignore pid))
    6093                 (prop 'process #+lispworks7+ io #-lispworks7+ pid)
    6094                 (when (plusp mode)
    6095                   (prop (ecase mode
    6096                           (1 'input-stream)
    6097                           (2 'output-stream)
    6098                           (3 'bidir-stream)) io))
    6099                 (when (eq error-output :stream)
    6100                   (prop 'error-stream err)))
    6101               ;; lispworks6 returns (pid), lispworks7 returns (io err pid) of which we keep io
    6102               (prop 'process (first process*)))))
    6103       process-info)))
     6231            (prop 'error-stream out-or-err))))
     6232       #+(or abcl clozure cmucl sbcl scl)
     6233       (progn
     6234         (prop 'process process)
     6235         (when (eq input :stream)
     6236           (nest
     6237            (prop 'input-stream)
     6238            #+abcl (symbol-call :sys :process-input)
     6239            #+clozure (ccl:external-process-input-stream)
     6240            #+(or cmucl scl) (ext:process-input)
     6241            #+sbcl (sb-ext:process-input)
     6242            process))
     6243         (when (eq output :stream)
     6244           (nest
     6245            (prop 'output-stream)
     6246            #+abcl (symbol-call :sys :process-output)
     6247            #+clozure (ccl:external-process-output-stream)
     6248            #+(or cmucl scl) (ext:process-output)
     6249            #+sbcl (sb-ext:process-output)
     6250            process))
     6251         (when (eq error-output :stream)
     6252           (nest
     6253            (prop 'error-output-stream)
     6254            #+abcl (symbol-call :sys :process-error)
     6255            #+clozure (ccl:external-process-error-stream)
     6256            #+(or cmucl scl) (ext:process-error)
     6257            #+sbcl (sb-ext:process-error)
     6258            process)))
     6259       #+(or ecl mkcl)
     6260       (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
     6261         code ;; ignore
     6262         (unless (zerop mode)
     6263           (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))
     6264         (prop 'process process))
     6265       #+lispworks
     6266       (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
     6267         (cond
     6268           ((or (plusp mode) (eq error-output :stream))
     6269            (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-nil)
     6270            (when (plusp mode)
     6271              (prop (ecase mode
     6272                      (1 'input-stream)
     6273                      (2 'output-stream)
     6274                      (3 'bidir-stream)) io-or-pid))
     6275            (when (eq error-output :stream)
     6276              (prop 'error-stream err-or-nil)))
     6277           ;; lispworks6 returns (pid), lispworks7 returns (io err pid) of which we keep io
     6278           (t (prop 'process io-or-pid)))))
     6279     process-info)))
    61046280
    61056281;;;; -------------------------------------------------------------------------
     
    61086284(uiop/package:define-package :uiop/run-program
    61096285  (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv.
    6110   (:use :uiop/common-lisp :uiop/package :uiop/utility
     6286  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version
    61116287   :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program)
    61126288  (:export
     
    71017277    (setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
    71027278  (register-image-restore-hook 'compute-user-cache))
    7103 ;;;; -------------------------------------------------------------------------
    7104 ;;; Hacks for backward-compatibility of the driver
     7279;;; -------------------------------------------------------------------------
     7280;;; Hacks for backward-compatibility with older versions of UIOP
    71057281
    71067282(uiop/package:define-package :uiop/backward-driver
    7107   (:use :uiop/common-lisp :uiop/package :uiop/utility
     7283  (:recycle :uiop/backward-driver :asdf/backward-driver :uiop)
     7284  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version
    71087285   :uiop/pathname :uiop/stream :uiop/os :uiop/image
    71097286   :uiop/run-program :uiop/lisp-build :uiop/configuration)
     
    71127289   #:user-configuration-directories #:system-configuration-directories
    71137290   #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory
    7114    ))
     7291   #:version-compatible-p))
    71157292(in-package :uiop/backward-driver)
    71167293
    7117 ;;;; Backward compatibility with various pathname functions.
    7118 
    7119 (with-upgradability ()
     7294(eval-when (:compile-toplevel :load-toplevel :execute)
     7295(with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2.0" :warning "3.2.1"))
     7296  ;; Backward compatibility with ASDF 2.000 to 2.26
     7297
     7298  ;; For backward-compatibility only, for people using internals
     7299  ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release)
     7300  ;; Will be removed after 2015-12.
    71207301  (defun coerce-pathname (name &key type defaults)
    7121     ;; For backward-compatibility only, for people using internals
    7122     ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release)
    7123     ;; Will be removed after 2015-12.
    7124     ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
     7302    "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead."
    71257303    (parse-unix-namestring name :type type :defaults defaults))
    71267304
     
    71297307    "Return the current user's list of user configuration directories
    71307308for configuring common-lisp.
    7131     DEPRECATED. Use uiop:xdg-config-pathnames instead."
     7309DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead."
    71327310    (xdg-config-pathnames "common-lisp"))
    71337311  (defun system-configuration-directories ()
    71347312    "Return the list of system configuration directories for common-lisp.
    7135     DEPRECATED. Use uiop:config-system-pathnames instead."
     7313DEPRECATED. Use UIOP:CONFIG-SYSTEM-PATHNAMES instead."
    71367314    (system-config-pathnames "common-lisp"))
    71377315  (defun in-first-directory (dirs x &key (direction :input))
    71387316    "Finds the first appropriate file named X in the list of DIRS for I/O
    71397317in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
    7140    If direction is :INPUT or :PROBE, will return the first extant file named
     7318If direction is :INPUT or :PROBE, will return the first extant file named
    71417319X in one of the DIRS.
    7142    If direction is :OUTPUT or :IO, will simply return the file named X in the
     7320If direction is :OUTPUT or :IO, will simply return the file named X in the
    71437321first element of DIRS that exists. DEPRECATED."
    71447322    (find-preferred-file
     
    71527330    "Return the pathname for the file named X under the system configuration directory
    71537331for common-lisp. DEPRECATED."
    7154     (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction)))
     7332    (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction))
     7333
     7334
     7335  ;; Backward compatibility with ASDF 1 to ASDF 2.32
     7336
     7337  (defun version-compatible-p (provided-version required-version)
     7338    "Is the provided version a compatible substitution for the required-version?
     7339If major versions differ, it's not compatible.
     7340If they are equal, then any later version is compatible,
     7341with later being determined by a lexicographical comparison of minor numbers.
     7342DEPRECATED."
     7343    (let ((x (parse-version provided-version nil))
     7344          (y (parse-version required-version nil)))
     7345      (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))))
     7346
    71557347;;;; ---------------------------------------------------------------------------
    71567348;;;; Re-export all the functionality in UIOP
     
    71657357   ;; or :use (closer-common-lisp uiop), etc.
    71667358  (:use-reexport
    7167    :uiop/package :uiop/utility
     7359   :uiop/package :uiop/utility :uiop/version
    71687360   :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image
    71697361   :uiop/launch-program :uiop/run-program
     
    71857377   #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf
    71867378   ;; There will be no symbol left behind!
     7379   #:with-asdf-deprecation
    71877380   #:intern*)
    71887381  (:import-from :uiop/package #:intern* #:find-symbol*))
     
    72667459         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    72677460         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    7268          (asdf-version "3.1.7.40")
     7461         (asdf-version "3.1.7.43")
    72697462         (existing-version (asdf-version)))
    72707463    (setf *asdf-version* asdf-version)
     
    73377530          (*compile-print* nil))
    73387531      (handler-bind (((or style-warning) #'muffle-warning))
    7339         (symbol-call :asdf :load-system :asdf :verbose nil)))))
     7532        (symbol-call :asdf :load-system :asdf :verbose nil))))
     7533
     7534  (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body)
     7535    `(with-upgradability ()
     7536       (with-deprecation ((version-deprecation *asdf-version* ,@keys))
     7537         ,@body))))
    73407538;;;; -------------------------------------------------------------------------
    73417539;;;; Session cache
     
    89719169             (list (type-of o)))))
    89729170
     9171  (with-asdf-deprecation (:style-warning "3.2")
     9172    (defun backward-compatible-depends-on (o c)
     9173      "DEPRECATED: all subclasses of OPERATION used in ASDF should inherit from one of
     9174 DOWNWARD-OPERATION UPWARD-OPERATION SIDEWAY-OPERATION SELFWARD-OPERATION NON-PROPAGATING-OPERATION.
     9175 The function BACKWARD-COMPATIBLE-DEPENDS-ON temporarily provides ASDF2 behaviour for those that
     9176 don't. In the future this functionality will be removed, and the default will be no propagation."
     9177      `(,@(sideway-operation-depends-on o c)
     9178        ,@(when (typep c 'parent-component) (downward-operation-depends-on o c)))))
     9179
    89739180  (defmethod component-depends-on ((o operation) (c component))
    89749181    `(;; Normal behavior, to allow user-specified in-order-to dependencies
    89759182      ,@(cdr (assoc (type-of o) (component-in-order-to c)))
    8976       ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation
    8977       ;; or non-propagation through an appropriate mixin will be downward and sideway.
    8978       ,@(unless (typep o '(or downward-operation upward-operation sideway-operation
    8979                               selfward-operation non-propagating-operation))
    8980           `(,@(sideway-operation-depends-on o c)
    8981             ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))))
     9183        ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation
     9184        ;; or non-propagation through an appropriate mixin will be downward and sideway.
     9185        ,@(unless (typep o '(or downward-operation upward-operation sideway-operation
     9186                             selfward-operation non-propagating-operation))
     9187            (backward-compatible-depends-on o c))))
    89829188
    89839189  (defmethod downward-operation ((o operation)) nil)
     
    1065810864  (defmethod component-depends-on ((o gather-operation) (s system))
    1065910865    (let* ((mono (operation-monolithic-p o))
     10866           (go (make-operation (or (gather-operation o) 'compile-op)))
     10867           (bundle-p (typep go 'bundle-op))
     10868           ;; In a non-mono operation, don't recurse to other systems.
     10869           ;; In a mono operation gathering bundles, don't recurse inside systems.
     10870           (component-type (if mono (if bundle-p 'system t) '(not system)))
     10871           ;; In the end, only keep system bundles or non-system bundles, depending.
     10872           (keep-component (if bundle-p 'system '(not system)))
    1066010873           (deps
    1066110874            ;; Required-components only looks at the dependencies of an action, excluding the action
     
    1067010883            ;; systems when *load-system-operation* is load-bundle-op.
    1067110884            (required-components
    10672              s :other-systems mono :component-type (if mono 'system '(not system))
     10885             s :other-systems mono :component-type component-type :keep-component keep-component
    1067310886             :goal-operation 'load-op :keep-operation 'basic-compile-op)))
    10674       `((,(or (gather-operation o) (if mono 'lib-op 'compile-op)) ,@deps)
    10675         ,@(call-next-method))))
     10887      `((,go ,@deps) ,@(call-next-method))))
    1067610888
    1067710889  ;; Create a single fasl for the entire library
     
    1070110913a static runtime for your system, or a dynamic library to load in an existing runtime."))
    1070210914
    10703   ;; What works: On ECL (and CLASP?), we link the .a output of lib-op into a .so;
    10704   ;; on MKCL, we link the many .o files from the system directly into the .so;
     10915  ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so;
    1070510916  ;; on other implementations, we combine (usually concatenate) the .fasl files into one.
    10706   (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
    10707                                #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-operation)
    10708     ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
    10709                          :allocation :class))
     10917  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation
     10918                                                       #+(or clasp ecl mkcl) link-op)
     10919    ((selfward-operation :initform '(prepare-bundle-op) :allocation :class))
    1071010920    (:documentation "This operator is an alternative to COMPILE-OP. Build a system
    1071110921and all of its dependencies, but build only a single (\"monolithic\") FASL, instead
     
    1075110961      (basic-compile-bundle-op monolithic-bundle-op
    1075210962       #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
    10753     ((gather-operation
    10754       :initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op
    10755       :allocation :class)
    10756      (gather-type
    10757       :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :static-library
    10758       :allocation :class))
     10963    ()
    1075910964    (:documentation "Create a single fasl for the system and its dependencies."))
    1076010965
     
    1076410969
    1076510970  (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation)
    10766     ((gather-type :initform :static-library :allocation :class))
     10971    ((gather-type :initform :object :allocation :class))
    1076710972    (:documentation "Compile the system and produce a linkable static library (.a/.lib)
    1076810973for all the linkable object files associated with the system or its dependencies. See LIB-OP."))
    1076910974
    1077010975  (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation)
    10771     ((gather-type :initform :static-library :allocation :class))
     10976    ((gather-type :initform :object :allocation :class))
    1077210977    (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
    1077310978for all the linkable object files associated with the system or its dependencies. See LIB-OP"))
     
    1077610981                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
    1077710982    ((bundle-type :initform :image :allocation :class)
     10983     (gather-operation :initform 'lib-op :allocation :class)
    1077810984     #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
    1077910985     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
     
    1086611072;;; The different targets are defined by specialization.
    1086711073;;;
    10868 (when-upgrading (:version "3.1.9")
     11074(when-upgrading (:version "3.2.0")
    1086911075  ;; Cancel any previously defined method
    1087011076  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)
     
    1126811474;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro
    1126911475;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us.
    11270 #-mkcl ; mkcl 1.1.9 can't fmakunbound a setf function.
    1127111476(when-upgrading (:version "3.1.2") (fmakunbound '(setf output-translations)))
    1127211477
     
    1211212317   #:component-load-dependencies
    1211312318   #:enable-asdf-binary-locations-compatibility
     12319   #:operation-forced
    1211412320   #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
    1211512321   #:component-property
     
    1211912325(in-package :asdf/backward-interface)
    1212012326
    12121 (with-upgradability ()
     12327;; NB: the warning status of these functions may have to be distinguished later,
     12328;; as some get removed faster than the others in client code.
     12329(with-asdf-deprecation (:style-warning "3.2")
     12330
    1212212331  ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp;
    1212312332  ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition
    1212412333  ;; that do not involve ASDF actions.
    1212512334  ;; TODO: find the offenders and stop them.
    12126   (define-condition operation-error (error) ;; Bad, backward-compatible name
    12127     ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
    12128     ((component :reader error-component :initarg :component)
    12129      (operation :reader error-operation :initarg :operation))
    12130     (:report (lambda (c s)
    12131                (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
    12132                        (type-of c) (error-operation c) (error-component c)))))
    12133   (define-condition compile-error (operation-error) ())
    12134   (define-condition compile-failed (compile-error) ())
    12135   (define-condition compile-warned (compile-error) ())
    12136 
    12137   (defun component-load-dependencies (component)
    12138     "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead."
     12335  (progn
     12336    (define-condition operation-error (error) ;; Bad, backward-compatible name
     12337      ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
     12338      ((component :reader error-component :initarg :component)
     12339       (operation :reader error-operation :initarg :operation))
     12340      (:report (lambda (c s)
     12341                 (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
     12342                         (type-of c) (error-operation c) (error-component c)))))
     12343    (define-condition compile-error (operation-error) ())
     12344    (define-condition compile-failed (compile-error) ())
     12345    (define-condition compile-warned (compile-error) ()))
     12346
     12347  ;; In Quicklisp 2015-05, still used by lisp-executable, staple, repl-utilities, cffi
     12348  (defun component-load-dependencies (component) ;; from ASDF 2.000 to 2.26
     12349    "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead; or better,
     12350define your operations with proper use of SIDEWAY-OPERATION, SELFWARD-OPERATION,
     12351or define methods on PREPARE-OP, etc."
    1213912352    ;; Old deprecated name for the same thing. Please update your software.
    1214012353    (component-sideway-dependencies component))
    1214112354
     12355  (defun* (operation-forced) (operation)
     12356    "DEPRECATED. Assume it's (constantly nil) instead -- until it disappears."
     12357    ;; This function exists for backward compatibility with swank.asd, its only user,
     12358    ;; that still abuses it as of 2016-10-01.
     12359    ;;
     12360    ;; The magic PERFORM method in swank.asd only actually loads swank if it sees
     12361    ;; that the operation was forced. But it actually fails, badly, in that case.
     12362    ;; The correctness criterion for a build specification (which is _not_
     12363    ;; specific to ASDF) requires that the effects of a build step must NOT depend
     12364    ;; on whether the step was "forced" or not. Therefore it is correct that this
     12365    ;; method should return constantly the same result. Since returning T currently
     12366    ;; causes massive failure in SLIME, it shall be constantly NIL.
     12367    ;; see also https://bugs.launchpad.net/asdf/+bug/1629582
     12368    (declare (ignore operation))
     12369    nil)
     12370
    1214212371  ;; These old interfaces from ASDF1 have never been very meaningful
    1214312372  ;; but are still used in obscure places.
     12373  ;; In Quicklisp 2015-05, still used by cl-protobufs and clx.
    1214412374  (defgeneric operation-on-warnings (operation)
    1214512375    (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead."))
     
    1215012380  (defgeneric (setf operation-on-failure) (x operation)
    1215112381    (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead."))
    12152   (defmethod operation-on-warnings ((o operation))
    12153     *compile-file-warnings-behaviour*)
    12154   (defmethod operation-on-failure ((o operation))
    12155     *compile-file-failure-behaviour*)
    12156   (defmethod (setf operation-on-warnings) (x (o operation))
    12157     (setf *compile-file-warnings-behaviour* x))
    12158   (defmethod (setf operation-on-failure) (x (o operation))
    12159     (setf *compile-file-failure-behaviour* x))
    12160 
     12382  (progn
     12383    (defmethod operation-on-warnings ((o operation))
     12384      *compile-file-warnings-behaviour*)
     12385    (defmethod operation-on-failure ((o operation))
     12386      *compile-file-failure-behaviour*)
     12387    (defmethod (setf operation-on-warnings) (x (o operation))
     12388      (setf *compile-file-warnings-behaviour* x))
     12389    (defmethod (setf operation-on-failure) (x (o operation))
     12390      (setf *compile-file-failure-behaviour* x)))
     12391
     12392  ;; Quicklisp 2015-05: Still used by SLIME's swank-asdf (!), common-lisp-stat,
     12393  ;; js-parser, osicat, babel, staple, weblocks, cl-png, plain-odbc, autoproject,
     12394  ;; cl-blapack, com.informatimago, cells-gtk3, asdf-dependency-grovel,
     12395  ;; cl-glfw, cffi, jwacs, montezuma
    1216112396  (defun system-definition-pathname (x)
    1216212397    ;; As of 2.014.8, we mean to make this function obsolete,
    1216312398    ;; but that won't happen until all clients have been updated.
    12164     ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
    1216512399    "DEPRECATED. This function used to expose ASDF internals with subtle
    1216612400differences with respect to user expectations, that have been refactored
     
    1217112405    (system-source-file x))
    1217212406
    12173 
    1217412407  ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2.
    1217512408  ;; It was never officially exposed but some people still used it.
    1217612409  (defgeneric traverse (operation component &key &allow-other-keys)
    1217712410    (:documentation
    12178      "Generate and return a plan for performing OPERATION on COMPONENT.
     12411     "DEPRECATED. Use MAKE-PLAN and PLAN-ACTIONS, or REQUIRED-COMPONENTS,
     12412or some other supported interface instead.
     12413
     12414Generate and return a plan for performing OPERATION on COMPONENT.
    1217912415
    1218012416The plan returned is a list of dotted-pairs. Each pair is the CONS
    1218112417of ASDF operation object and a COMPONENT object. The pairs will be
    1218212418processed in order by OPERATE."))
    12183   (define-convenience-action-methods traverse (operation component &key))
    12184 
     12419  (progn
     12420    (define-convenience-action-methods traverse (operation component &key)))
    1218512421  (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
    12186     (plan-actions (apply 'make-plan plan-class o c keys))))
    12187 
    12188 
    12189 ;;;; ASDF-Binary-Locations compatibility
    12190 ;; This remains supported for legacy user, but not recommended for new users.
    12191 ;; We suspect there are no more legacy users in 2016.
    12192 (with-upgradability ()
     12422    (plan-actions (apply 'make-plan plan-class o c keys)))
     12423
     12424
     12425  ;; ASDF-Binary-Locations compatibility
     12426  ;; This remains supported for legacy user, but not recommended for new users.
     12427  ;; We suspect there are no more legacy users in 2016.
    1219312428  (defun enable-asdf-binary-locations-compatibility
    1219412429      (&key
    12195        (centralize-lisp-binaries nil)
    12196        (default-toplevel-directory
    12197         (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
    12198        (include-per-user-information nil)
    12199        (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil))
    12200        (source-to-target-mappings nil)
    12201        (file-types `(,(compile-file-type)
    12202                      "build-report"
    12203                      #+clasp (compile-file-type :output-type :object)
    12204                      #+ecl (compile-file-type :type :object)
    12205                      #+mkcl (compile-file-type :fasl-p nil)
    12206                      #+clisp "lib" #+sbcl "cfasl"
    12207                      #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
     12430         (centralize-lisp-binaries nil)
     12431         (default-toplevel-directory
     12432             ;; Use ".cache/common-lisp/" instead ???
     12433             (subpathname (user-homedir-pathname) ".fasls/"))
     12434         (include-per-user-information nil)
     12435         (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil))
     12436         (source-to-target-mappings nil)
     12437         (file-types `(,(compile-file-type)
     12438                        "build-report"
     12439                        #+clasp (compile-file-type :output-type :object)
     12440                        #+ecl (compile-file-type :type :object)
     12441                        #+mkcl (compile-file-type :fasl-p nil)
     12442                        #+clisp "lib" #+sbcl "cfasl"
     12443                        #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
     12444    "DEPRECATED. Use asdf-output-translations instead."
    1220812445    #+(or clasp clisp ecl mkcl)
    1220912446    (when (null map-all-source-files)
     
    1221112448    (let* ((patterns (if map-all-source-files (list *wild-file*)
    1221212449                         (loop :for type :in file-types
    12213                                :collect (make-pathname :type type :defaults *wild-file*))))
     12450                           :collect (make-pathname :type type :defaults *wild-file*))))
    1221412451           (destination-directory
    12215              (if centralize-lisp-binaries
    12216                  `(,default-toplevel-directory
    12217                    ,@(when include-per-user-information
    12218                        (cdr (pathname-directory (user-homedir-pathname))))
    12219                    :implementation ,*wild-inferiors*)
    12220                  `(:root ,*wild-inferiors* :implementation))))
     12452            (if centralize-lisp-binaries
     12453                `(,default-toplevel-directory
     12454                     ,@(when include-per-user-information
     12455                             (cdr (pathname-directory (user-homedir-pathname))))
     12456                     :implementation ,*wild-inferiors*)
     12457                `(:root ,*wild-inferiors* :implementation))))
    1222112458      (initialize-output-translations
    1222212459       `(:output-translations
     
    1222512462         #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
    1222612463         ,@(loop :for pattern :in patterns
    12227                  :collect `((:root ,*wild-inferiors* ,pattern)
    12228                             (,@destination-directory ,pattern)))
     12464             :collect `((:root ,*wild-inferiors* ,pattern)
     12465                        (,@destination-directory ,pattern)))
    1222912466         (t t)
    1223012467         :ignore-inherited-configuration))))
    12231 
    12232   (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
    12233     (declare (ignore operation-class system args))
    12234     (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
    12235       (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
     12468  (progn
     12469    (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
     12470      (declare (ignore operation-class system args))
     12471      (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
     12472        (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
    1223612473ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
    1223712474which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
     
    1224312480
    1224412481
    12245 ;;; run-shell-command
    12246 ;; WARNING! The function below is not just deprecated but also dysfunctional.
    12247 ;; Please use asdf/run-program:run-program instead.
    12248 (with-upgradability ()
     12482  ;; run-shell-command from ASDF 2, lightly fixed from ASDF 1, copied from MK-DEFSYSTEM. Die!
    1224912483  (defun run-shell-command (control-string &rest args)
    12250     "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
    12251 synchronously execute the result using a Bourne-compatible shell, with
    12252 output to *VERBOSE-OUT*.  Returns the shell's exit code.
    12253 
    12254 PLEASE DO NOT USE.
    12255 Deprecated function, for backward-compatibility only.
     12484    "PLEASE DO NOT USE. This function is not just DEPRECATED, but also dysfunctional.
    1225612485Please use UIOP:RUN-PROGRAM instead."
    1225712486    #-(and ecl os-windows)
     
    1225912488      (asdf-message "; $ ~A~%" command)
    1226012489      (let ((exit-code
    12261               (ignore-errors
     12490             (ignore-errors
    1226212491               (nth-value 2 (run-program command :force-shell t :ignore-error-status t
    12263                                                  :output *verbose-out*)))))
     12492                                         :output *verbose-out*)))))
    1226412493        (typecase exit-code
    1226512494          ((integer 0 255) exit-code)
    1226612495          (t 255))))
    1226712496    #+(and ecl os-windows)
    12268     (not-implemented-error "run-shell-command" "for ECL on Windows.")
    12269     ))
    12270 
    12271 
    12272 (with-upgradability ()
    12273   (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
    12274 
    12275 
    12276 ;;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
    12277 (with-upgradability ()
     12497    (not-implemented-error "run-shell-command" "for ECL on Windows."))
     12498
     12499  ;; HOW do we get rid of variables??? With a symbol-macro that issues a warning?
     12500  ;; In Quicklisp 2015-05, cl-protobufs still uses it, but that should be fixed in next version.
     12501  (progn
     12502    (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
     12503
     12504  ;; Do NOT use in new code. NOT SUPPORTED.
     12505  ;; NB: When this goes away, remove the slot PROPERTY in COMPONENT.
     12506  ;; In Quicklisp 2014-05, it's still used by yaclml, amazon-ecs, blackthorn-engine, cl-tidy.
     12507  ;; See TODO for further cleanups required before to get rid of it.
    1227812508  (defgeneric component-property (component property))
    1227912509  (defgeneric (setf component-property) (new-value component property))
     
    1228812518          (setf (slot-value c 'properties)
    1228912519                (acons property new-value (slot-value c 'properties)))))
    12290     new-value))
    12291 
    12292 
    12293 ;;; This method survives from ASDF 1, but really it is superseded by action-description.
    12294 (with-upgradability ()
     12520    new-value)
     12521
     12522
     12523  ;; This method survives from ASDF 1, but really it is superseded by action-description.
    1229512524  (defgeneric explain (operation component)
    1229612525    (:documentation "Display a message describing an action.
     12526
    1229712527DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead."))
     12528  (progn
     12529    (define-convenience-action-methods explain (operation component)))
    1229812530  (defmethod explain ((o operation) (c component))
    12299     (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
    12300   (define-convenience-action-methods explain (operation component)))
    12301 
    12302 
     12531    (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))))
    1230312532;;;; -------------------------------------------------------------------------
    1230412533;;; Internal hacks for backward-compatibility
     
    1231012539(in-package :asdf/backward-internals)
    1231112540
    12312 (with-upgradability ()
     12541(with-asdf-deprecation (:style-warning "3.2")
    1231312542  (defun load-sysdef (name pathname)
    1231412543    (declare (ignore name pathname))
     
    1251912748;;;; Register ASDF itself and all its subsystems as preloaded.
    1252012749(with-upgradability ()
    12521   (dolist (s '("asdf" "uiop" "asdf-defsystem" "asdf-package-system"))
     12750  (dolist (s '("asdf" "uiop" "asdf-package-system"))
    1252212751    ;; Don't bother with these system names, no one relies on them anymore:
    12523     ;; "asdf-utils" "asdf-bundle" "asdf-driver"
     12752    ;; "asdf-utils" "asdf-bundle" "asdf-driver" "asdf-defsystem"
    1252412753    (register-preloaded-system s :version *asdf-version*)))
    1252512754
Note: See TracChangeset for help on using the changeset viewer.