Changeset 16491


Ignore:
Timestamp:
Aug 3, 2015, 2:13:47 PM (4 years ago)
Author:
rme
Message:

ASDF 3.1.5.

Closes ticket:1294.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/tools/asdf.lisp

    r16141 r16491  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
    2 ;;; This is ASDF 3.1.3: Another System Definition Facility.
     2;;; This is ASDF 3.1.5: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    2020;;;  Monday; July 13, 2009)
    2121;;;
    22 ;;; Copyright (c) 2001-2014 Daniel Barlow and contributors
     22;;; Copyright (c) 2001-2015 Daniel Barlow and contributors
    2323;;;
    2424;;; Permission is hereby granted, free of charge, to any person obtaining
     
    123123  (defun find-symbol* (name package-designator &optional (error t))
    124124    "Find a symbol in a package of given string'ified NAME;
    125 unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
     125unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
    126126by letting you supply a symbol or keyword for the name;
    127127also works well when the package is not present.
     
    152152    (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
    153153  (defun shadow* (name package-designator)
    154     (shadow (string name) (find-package* package-designator)))
     154    (shadow (list (string name)) (find-package* package-designator)))
    155155  (defun make-symbol* (name)
    156156    (etypecase name
     
    820820          `(apply 'ensure-package ',(parse-define-package-form package clauses))))
    821821    `(progn
    822        #+(or ecl gcl mkcl) (defpackage ,package (:use))
     822       #+(or clasp ecl gcl mkcl) (defpackage ,package (:use))
    823823       (eval-when (:compile-toplevel :load-toplevel :execute)
    824824         ,ensure-form))))
     
    860860(in-package :uiop/common-lisp)
    861861
    862 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
     862#-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    863863(error "ASDF is not supported on your implementation. Please help us port it.")
    864864
     
    868868;;;; Early meta-level tweaks
    869869
    870 #+(or abcl allegro clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl)
     870#+(or abcl allegro clasp clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl)
    871871(eval-when (:load-toplevel :compile-toplevel :execute)
    872872  ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
    873873  ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie.
    874874  (when (and #+allegro (member :ics *features*)
    875              #+(or clisp cmu ecl mkcl) (member :unicode *features*)
     875             #+(or clasp clisp cmu ecl mkcl) (member :unicode *features*)
    876876             #+sbcl (member :sb-unicode *features*))
    877877    (pushnew :asdf-unicode *features*)))
     
    885885    (setf excl:*warn-on-nested-reader-conditionals* nil))
    886886  (setf *print-readably* nil))
     887
     888#+clasp
     889(eval-when (:load-toplevel :compile-toplevel :execute)
     890  (setf *load-verbose* nil)
     891  (defun use-ecl-byte-compiler-p () nil))
    887892
    888893#+clozure (in-package :ccl)
     
    899904#+clozure (in-package :uiop/common-lisp)
    900905
    901 
    902906#+cormanlisp
    903907(eval-when (:load-toplevel :compile-toplevel :execute)
     
    912916    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
    913917
    914 #+ecl
     918#+(and ecl (not clasp))
    915919(eval-when (:load-toplevel :compile-toplevel :execute)
    916920  (setf *load-verbose* nil)
     
    10371041  ;; import and reexport a few things defined in :uiop/common-lisp
    10381042  (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
    1039    #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
     1043   #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
    10401044  (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
    1041    #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
     1045   #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
    10421046  (:export
    10431047   ;; magic helper to define debugging functions:
     
    10541058   #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
    10551059   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
     1060   #:standard-case-symbol-name #:find-standard-case-symbol
    10561061   #:coerce-class ;; CLOS
    10571062   #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
     
    11021107                 ;; We usually try to do it only for the functions that need it,
    11031108                 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
    1104                  ,@(when (or supersede #+ecl t)
     1109                 ,@(when (or supersede #+(or clasp ecl) t)
    11051110                     `((undefine-function ',name)))
    1106                  ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
     1111                 ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl
    11071112                     `((declaim (notinline ,name))))
    11081113                 (,',def ,name ,formals ,@rest))))))
     
    12241229
    12251230;;; Characters
    1226 (with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR.
    1227   (defconstant +non-base-chars-exist-p+ #.(not (subtypep 'character 'base-char)))
    1228   #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow???
     1231(with-upgradability ()
     1232  ;; base-char != character on ECL, LW, SBCL, Genera.
     1233  ;; NB: We assume a total order on character types.
     1234  ;; If that's not true... this code will need to be updated.
     1235  (defparameter +character-types+ ;; assuming a simple hierarchy
     1236    #.(coerce (loop* :for (type next) :on
     1237                     '(;; In SCL, all characters seem to be 16-bit base-char
     1238                       ;; Yet somehow character fails to be a subtype of base-char
     1239                       #-scl base-char
     1240                       ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
     1241                       ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
     1242                       #+(and lispworks (not (or lispworks4 lispworks5 lispworks6)))
     1243                       lw:bmp-char
     1244                       #+lispworks lw:simple-char
     1245                       character)
     1246                     :unless (and next (subtypep next type))
     1247                     :collect type) 'vector))
     1248  (defparameter +max-character-type-index+ (1- (length +character-types+)))
     1249  (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+))
    12291250  (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
    1230 
    1231 (with-upgradability ()
    1232   (defparameter +character-types+ ;; assuming a simple hierarchy
    1233     #(#+non-base-chars-exist-p base-char #+lispworks lw:simple-char character))
    1234   (defparameter +max-character-type-index+ (1- (length +character-types+))))
    12351251
    12361252(with-upgradability ()
     
    12441260        (otherwise
    12451261         '(or (position-if (etypecase x
    1246                              (character  #'(lambda (type) (typep x type)))
     1262                             (character #'(lambda (type) (typep x type)))
    12471263                             (symbol #'(lambda (type) (subtypep x type))))
    12481264               +character-types+)
     
    12631279          `(aref +character-types+
    12641280            (loop :with index = 0 :for s :in strings :do
    1265               (cond
    1266                 ((= index ,+max-character-type-index+) (return index))
    1267                 ((emptyp s)) ;; NIL or empty string
    1268                 ((characterp s) (setf index (max index (character-type-index s))))
    1269                 ((stringp s) (unless (>= index (character-type-index (array-element-type s)))
    1270                                (setf index (reduce 'max s :key #'character-type-index
    1271                                                           :initial-value index))))
    1272                 (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type)))
     1281              (flet ((consider (i)
     1282                       (cond ((= i ,+max-character-type-index+) (return i))
     1283                             ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i)))))))
     1284                (cond
     1285                  ((emptyp s)) ;; NIL or empty string
     1286                  ((characterp s) (consider (character-type-index s)))
     1287                  ((stringp s) (let ((string-type-index
     1288                                       (character-type-index (array-element-type s))))
     1289                                 (unless (>= index string-type-index)
     1290                                   (loop :for c :across s :for i = (character-type-index c)
     1291                                         :do (consider i)
     1292                                         ,@(when (> +max-character-type-index+ 1)
     1293                                             `((when (= i string-type-index) (return))))))))
     1294                  (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))))
    12731295                  :finally (return index)))
    12741296          ''character))
     
    13421364    "Does STRING begin with PREFIX and end with SUFFIX?"
    13431365    (and (string-prefix-p prefix string)
    1344          (string-suffix-p string suffix))))
     1366         (string-suffix-p string suffix)))
    13451367
    13461368  (defvar +cr+ (coerce #(#\Return) 'string))
     
    13601382        (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil)))))
    13611383
     1384  (defun standard-case-symbol-name (name-designator)
     1385    "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING;
     1386if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\"
     1387platform such as Allegro with modern syntax."
     1388    (check-type name-designator (or string symbol))
     1389    (cond
     1390      ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower))
     1391       (string name-designator))
     1392      ;; Should we be doing something on CLISP?
     1393      (t (string-upcase name-designator))))
     1394
     1395  (defun find-standard-case-symbol (name-designator package-designator &optional (error t))
     1396    "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR,
     1397where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings.
     1398If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
     1399    (find-symbol* (standard-case-symbol-name name-designator)
     1400                  (etypecase package-designator
     1401                    ((or package symbol) package-designator)
     1402                    (string (standard-case-symbol-name package-designator)))
     1403                  error)))
    13621404
    13631405;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity
     
    14861528               (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super))
    14871529               found)
    1488           (call-function error "Can't coerce ~S to a ~@[class~;subclass of ~:*~S]" class super)))))
     1530          (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super)))))
    14891531
    14901532
     
    15781620    #+clozure 'ccl::format-control
    15791621    #+(or cmu scl) 'conditions::format-control
    1580     #+(or ecl mkcl) 'si::format-control
     1622    #+(or clasp ecl mkcl) 'si::format-control
    15811623    #+(or gcl lispworks) 'conditions::format-string
    15821624    #+sbcl 'sb-kernel:format-control
    1583     #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil
     1625    #-(or abcl allegro clasp clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil
    15841626    "Name of the slot for FORMAT-CONTROL in simple-condition")
    15851627
     
    16231665  (:export
    16241666   #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features
     1667   #:os-cond
    16251668   #:getenv #:getenvp ;; environment variables
    16261669   #:implementation-identifier ;; implementation identifier
     
    16481691      (t (error "Malformed feature specification ~S" x))))
    16491692
    1650   (defun os-unix-p ()
    1651     "Is the underlying operating system some Unix variant?"
    1652     (or #+abcl (featurep :unix)
    1653         #+(and (not abcl) (or unix cygwin darwin)) t))
    1654 
     1693  ;; Starting with UIOP 3.1.5, these are runtime tests.
     1694  ;; You may bind *features* with a copy of what your target system offers to test its properties.
    16551695  (defun os-macosx-p ()
    16561696    "Is the underlying operating system MacOS X?"
    16571697    ;; OS-MACOSX is not mutually exclusive with OS-UNIX,
    16581698    ;; in fact the former implies the latter.
    1659     (or
    1660      #+allegro (featurep :macosx)
    1661      #+clisp (featurep :macos)
    1662      (featurep :darwin)))
     1699    (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos))))
     1700
     1701  (defun os-unix-p ()
     1702    "Is the underlying operating system some Unix variant?"
     1703    (or (featurep '(:or :unix :cygwin)) (os-macosx-p)))
    16631704
    16641705  (defun os-windows-p ()
    16651706    "Is the underlying operating system Microsoft Windows?"
    1666     (or #+abcl (featurep :windows)
    1667         #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32 mingw64)) t))
     1707    (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32 :mingw64))))
    16681708
    16691709  (defun os-genera-p ()
    16701710    "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
    1671     (or #+genera t))
     1711    (featurep :genera))
    16721712
    16731713  (defun os-oldmac-p ()
    16741714    "Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
    1675     (or #+mcl t))
     1715    (featurep :mcl))
    16761716
    16771717  (defun detect-os ()
     
    16891729that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
    16901730
     1731  (defmacro os-cond (&rest clauses)
     1732    #+abcl `(cond ,@clauses)
     1733    #-abcl (loop* :for (test . body) :in clauses :when (eval test) :return `(progn ,@body)))
     1734
    16911735  (detect-os))
    16921736
    16931737;;;; Environment variables: getting them, and parsing them.
    1694 
    16951738(with-upgradability ()
    16961739  (defun getenv (x)
     
    16991742use getenvp to return NIL in such a case."
    17001743    (declare (ignorable x))
    1701     #+(or abcl clisp ecl xcl) (ext:getenv x)
     1744    #+(or abcl clasp clisp ecl xcl) (ext:getenv x)
    17021745    #+allegro (sys:getenv x)
    17031746    #+clozure (ccl:getenv x)
    1704     #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
     1747    #+cmu (unix:unix-getenv x)
     1748    #+scl (cdr (assoc x ext:*environment-list* :test #'string=))
    17051749    #+cormanlisp
    17061750    (let* ((buffer (ct:malloc 1))
     
    17221766    #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
    17231767    #+sbcl (sb-ext:posix-getenv x)
    1724     #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
     1768    #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    17251769    (error "~S is not supported on your implementation" 'getenv))
     1770
     1771  (defsetf getenv (x) (val)
     1772    "Set an environment variable."
     1773      (declare (ignorable x val))
     1774    #+allegro `(setf (sys:getenv ,x) ,val)
     1775    #+clisp `(system::setenv ,x ,val)
     1776    #+clozure `(ccl:setenv ,x ,val)
     1777    #+cmu `(unix:unix-setenv ,x ,val 1)
     1778    #+ecl `(ext:setenv ,x ,val)
     1779    #+lispworks `(hcl:setenv ,x ,val)
     1780    #+mkcl `(mkcl:setenv ,x ,val)
     1781    #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
     1782    #-(or allegro clisp clozure cmu ecl lispworks mkcl sbcl)
     1783    '(error "~S ~S is not supported on your implementation" 'setf 'getenv))
    17261784
    17271785  (defun getenvp (x)
     
    17521810    (first-feature
    17531811     '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
    1754        (:cmu :cmucl :cmu) :ecl :gcl
     1812       (:cmu :cmucl :cmu) :clasp :ecl :gcl
    17551813       (:lwpe :lispworks-personal-edition) (:lw :lispworks)
    17561814       :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
     
    18181876                      ;; ANSI upper case vs lower case.
    18191877                      (ecase ext:*case-mode* (:upper "") (:lower "l")))
    1820         #+ecl (format nil "~A~@[-~A~]" s
    1821                       (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    1822                         (subseq vcs-id 0 (min (length vcs-id) 8))))
     1878        #+clasp (format nil "~A-~A"
     1879                        s (core:lisp-implementation-id))
     1880        #+(and ecl (not clasp)) (format nil "~A~@[-~A~]" s
     1881                                       (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     1882                                         (subseq vcs-id 0 (min (length vcs-id) 8))))
    18231883        #+gcl (subseq s (1+ (position #\space s)))
    18241884        #+genera
     
    18461906    "return the hostname of the current host"
    18471907    ;; Note: untested on RMCL
    1848     #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
     1908    #+(or abcl clasp clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
    18491909    #+cormanlisp "localhost" ;; is there a better way? Does it matter?
    18501910    #+allegro (symbol-call :excl.osi :gethostname)
     
    18661926  (defun getcwd ()
    18671927    "Get the current working directory as per POSIX getcwd(3), as a pathname object"
    1868     (or #+abcl (truename (symbol-call :asdf/filesystem :parse-native-namestring
    1869                           (java:jstatic "getProperty" "java.lang.System" "user.dir")
    1870                           :ensure-directory t))
     1928    (or #+(or abcl genera xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
    18711929        #+allegro (excl::current-directory)
    18721930        #+clisp (ext:default-directory)
     
    18751933                        (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
    18761934        #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
    1877         #+ecl (ext:getcwd)
     1935        #+(or clasp ecl) (ext:getcwd)
    18781936        #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
    1879         #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
    1880         #+lispworks (system:current-directory)
     1937        #+lispworks (hcl:get-working-directory)
    18811938        #+mkcl (mk-ext:getcwd)
    18821939        #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
     
    18871944    "Change current directory, as per POSIX chdir(2), to a given pathname object"
    18881945    (if-let (x (pathname x))
    1889       (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
    1890           #+allegro (excl:chdir x)
    1891           #+clisp (ext:cd x)
    1892           #+clozure (setf (ccl:current-directory) x)
    1893           #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
    1894           #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
    1895                          (error "Could not set current directory to ~A" x))
    1896           #+ecl (ext:chdir x)
    1897           #+genera (setf *default-pathname-defaults* x)
    1898           #+lispworks (hcl:change-directory x)
    1899           #+mkcl (mk-ext:chdir x)
    1900           #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
    1901           (error "chdir not supported on your implementation")))))
     1946      #+(or abcl genera xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
     1947      #+allegro (excl:chdir x)
     1948      #+clisp (ext:cd x)
     1949      #+clozure (setf (ccl:current-directory) x)
     1950      #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
     1951      #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
     1952                     (error "Could not set current directory to ~A" x))
     1953      #+(or clasp ecl) (ext:chdir x)
     1954      #+gcl (system:chdir x)
     1955      #+lispworks (hcl:change-directory x)
     1956      #+mkcl (mk-ext:chdir x)
     1957      #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
     1958      #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
     1959      (error "chdir not supported on your implementation"))))
    19021960
    19031961
     
    20792137  (defparameter *unspecific-pathname-type*
    20802138    #+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific
    2081     #+(or clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil
     2139    #+(or clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil
    20822140    "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
    20832141
     
    21902248
    21912249  (defmacro with-pathname-defaults ((&optional defaults) &body body)
    2192     "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* are as neutral as possible
    2193 when merging, making or parsing pathnames"
    2194     `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body)))
     2250    "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified,
     2251where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except
     2252on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory."
     2253    `(let ((*default-pathname-defaults*
     2254             ,(or defaults
     2255                  #-(or abcl genera xcl) '*nil-pathname*
     2256                  #+(or abcl genera xcl) '*default-pathname-defaults*)))
     2257       ,@body)))
    21952258
    21962259
     
    23412404An empty string is thus read as meaning a pathname object with all fields nil.
    23422405
    2343 Note that : characters will NOT be interpreted as host specification.
     2406Note that colon characters #\: will NOT be interpreted as host specification.
    23442407Absolute pathnames are only appropriate on Unix-style systems.
    23452408
     
    23912454
    23922455Unix syntax is used whether or not the underlying system is Unix;
    2393 on such non-Unix systems it is only usable but for relative pathnames;
    2394 but especially to manipulate relative pathnames portably, it is of crucial
    2395 to possess a portable pathname syntax independent of the underlying OS.
     2456on such non-Unix systems it is reliably usable only for relative pathnames.
     2457This function is especially useful to manipulate relative pathnames portably,
     2458where it is of crucial to possess a portable pathname syntax independent of the underlying OS.
    23962459This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
    23972460
     
    241124743- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
    24122475
    2413 Directory components with an empty name the name . are removed.
    2414 Any directory named .. is read as DOT-DOT,
     2476Directory components with an empty name or the name \".\" are removed.
     2477Any directory named \"..\" is read as DOT-DOT,
    24152478which must be one of :BACK or :UP and defaults to :BACK.
    24162479
     
    25592622         (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
    25602623         (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
    2561          (with-pathname-defaults ()
     2624         (with-pathname-defaults (*nil-pathname*)
    25622625           (let ((enough (enough-namestring maybe-subpath base-pathname)))
    25632626             (and (relative-pathname-p enough) (pathname enough))))))
     
    26432706    "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
    26442707added to its DIRECTORY component. This is useful for output translations."
    2645     #+(or unix abcl)
    2646     (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
    2647       (return-from directorize-pathname-host-device pathname))
     2708    (os-cond
     2709     ((os-unix-p)
     2710      (when (physical-pathname-p pathname)
     2711        (return-from directorize-pathname-host-device pathname))))
    26482712    (let* ((root (pathname-root pathname))
    26492713           (wild-root (wilden root))
     
    27572821        #+sbcl (sb-ext:native-namestring p)
    27582822        #-(or clozure cmu sbcl scl)
    2759         (if (os-unix-p) (unix-namestring p)
    2760             (namestring p)))))
     2823        (os-cond
     2824         ((os-unix-p) (unix-namestring p))
     2825         (t (namestring p))))))
    27612826
    27622827  (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
     
    27702835                 #+sbcl (sb-ext:parse-native-namestring string)
    27712836                 #-(or clozure sbcl)
    2772                  (if (os-unix-p)
    2773                      (parse-unix-namestring string :ensure-directory ensure-directory)
    2774                      (parse-namestring string)))))
     2837                 (os-cond
     2838                  ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory))
     2839                  (t (parse-namestring string))))))
    27752840           (pathname
    27762841             (if ensure-directory
     
    27832848(with-upgradability ()
    27842849  (defun truename* (p)
    2785     "Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts"
    2786     ;; avoids both logical-pathname merging and physical resolution issues
    2787     (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
     2850    "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
     2851    (when p
     2852      (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p))))
     2853      (values
     2854       (or (ignore-errors (truename p))
     2855           ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
     2856           ;; a trailing directory separator, causes an error on some lisps.
     2857           #+(or clisp gcl) (if-let (d (ensure-directory-pathname p)) (ignore-errors (truename d)))))))
    27882858
    27892859  (defun safe-file-write-date (pathname)
     
    28062876If it exists, return its truename is ENSURE-PATHNAME is true,
    28072877or the original (parsed) pathname if it is false (the default)."
    2808     (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
    2809       (etypecase p
    2810         (null nil)
    2811         (string (probe-file* (parse-namestring p) :truename truename))
    2812         (pathname
    2813          (and (not (wild-pathname-p p))
    2814               (handler-case
    2815                   (or
    2816                    #+allegro
    2817                    (probe-file p :follow-symlinks truename)
    2818                    #+gcl
    2819                    (if truename
    2820                        (truename* p)
    2821                        (let ((kind (car (si::stat p))))
    2822                          (when (eq kind :link)
    2823                            (setf kind (ignore-errors (car (si::stat (truename* p))))))
    2824                          (ecase kind
    2825                            ((nil) nil)
    2826                            ((:file :link)
    2827                             (cond
    2828                               ((file-pathname-p p) p)
    2829                               ((directory-pathname-p p)
    2830                                (subpathname p (car (last (pathname-directory p)))))))
    2831                            (:directory (ensure-directory-pathname p)))))
    2832                    #+clisp
    2833                    #.(flet ((probe (probe)
    2834                               `(let ((foundtrue ,probe))
    2835                                  (cond
    2836                                    (truename foundtrue)
    2837                                    (foundtrue p)))))
    2838                        (let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
    2839                               (pp (find-symbol* '#:probe-pathname :ext nil))
    2840                               (resolve (if pp
    2841                                            `(ignore-errors (,pp p))
    2842                                            '(or (truename* p)
    2843                                              (truename* (ignore-errors (ensure-directory-pathname p)))))))
    2844                          (if fs
    2845                              `(if truename
    2846                                   ,resolve
    2847                                   (and (ignore-errors (,fs p)) p))
    2848                              (probe resolve))))
    2849                    #-(or allegro clisp gcl)
    2850                    (if truename
    2851                        (probe-file p)
    2852                        (ignore-errors
    2853                         (let ((pp (physicalize-pathname p)))
    2854                           (and
    2855                            #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
    2856                            #+(and lispworks unix) (system:get-file-stat pp)
    2857                            #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
    2858                            #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
    2859                            p)))))
    2860                 (file-error () nil)))))))
     2878    (values
     2879     (ignore-errors
     2880      (setf p (funcall 'ensure-pathname p
     2881                       :namestring :lisp
     2882                       :ensure-physical t
     2883                       :ensure-absolute t :defaults 'get-pathname-defaults
     2884                       :want-non-wild t
     2885                       :on-error nil))
     2886      (when p
     2887        #+allegro
     2888        (probe-file p :follow-symlinks truename)
     2889        #+gcl
     2890        (if truename
     2891            (truename* p)
     2892            (let ((kind (car (si::stat p))))
     2893              (when (eq kind :link)
     2894                (setf kind (ignore-errors (car (si::stat (truename* p))))))
     2895              (ecase kind
     2896                ((nil) nil)
     2897                ((:file :link)
     2898                 (cond
     2899                   ((file-pathname-p p) p)
     2900                   ((directory-pathname-p p)
     2901                    (subpathname p (car (last (pathname-directory p)))))))
     2902                (:directory (ensure-directory-pathname p)))))
     2903        #+clisp
     2904        #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
     2905                 (pp (find-symbol* '#:probe-pathname :ext nil)))
     2906            `(if truename
     2907                 ,(if pp
     2908                      `(values (,pp p))
     2909                      '(or (truename* p)
     2910                        (truename* (ignore-errors (ensure-directory-pathname p)))))
     2911                 ,(cond
     2912                    (fs `(and (,fs p) p))
     2913                    (pp `(nth-value 1 (,pp p)))
     2914                    (t '(or (and (truename* p) p)
     2915                         (if-let (d (ensure-directory-pathname p))
     2916                          (and (truename* d) d)))))))
     2917        #-(or allegro clisp gcl)
     2918        (if truename
     2919            (probe-file p)
     2920            (and
     2921             #+(or cmu scl) (unix:unix-stat (ext:unix-namestring p))
     2922             #+(and lispworks unix) (system:get-file-stat p)
     2923             #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
     2924             #-(or cmu (and lispworks unix) sbcl scl) (file-write-date p)
     2925             p))))))
    28612926
    28622927  (defun directory-exists-p (x)
     
    29182983  PATTERN defaults to a pattern carefully chosen based on the implementation;
    29192984override the default at your own risk.
    2920   DIRECTORY-FILES tries NOT to resolve symlinks if the implementation
    2921 permits this."
     2985  DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this,
     2986but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
    29222987    (let ((dir (pathname directory)))
    29232988      (when (logical-pathname-p dir)
     
    29453010
    29463011  (defun subdirectories (directory)
    2947     "Given a DIRECTORY pathname designator, return a list of the subdirectories under it."
     3012    "Given a DIRECTORY pathname designator, return a list of the subdirectories under it.
     3013The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
    29483014    (let* ((directory (ensure-directory-pathname directory))
    29493015           #-(or abcl cormanlisp genera xcl)
     
    29833049
    29843050  (defun collect-sub*directories (directory collectp recursep collector)
    2985     "Given a DIRECTORY, call-function the COLLECTOR function designator
    2986 on the directory if COLLECTP returns true when CALL-FUNCTION'ed with the directory,
    2987 and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them."
     3051    "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory,
     3052call-function the COLLECTOR function designator on the directory,
     3053and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them.
     3054This function will thus let you traverse a filesystem hierarchy,
     3055superseding the functionality of CL-FAD:WALK-DIRECTORY.
     3056The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
    29883057    (when (call-function collectp directory)
    2989       (call-function collector directory))
    2990     (dolist (subdir (subdirectories directory))
    2991       (when (call-function recursep subdir)
    2992         (collect-sub*directories subdir collectp recursep collector)))))
     3058      (call-function collector directory)
     3059      (dolist (subdir (subdirectories directory))
     3060        (when (call-function recursep subdir)
     3061          (collect-sub*directories subdir collectp recursep collector))))))
    29933062
    29943063;;; Resolving symlinks somewhat
     
    30493118                  on-error
    30503119                  defaults type dot-dot namestring
     3120                  empty-is-nil
    30513121                  want-pathname
    30523122                  want-logical want-physical ensure-physical
     
    30923162which is also the order in the lambda-list:
    30933163
     3164EMPTY-IS-NIL returns NIL if the argument is an empty string.
    30943165WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
    30953166Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
     
    31313202            ((or null pathname))
    31323203            (string
     3204             (when (and (emptyp p) empty-is-nil)
     3205               (return-from ensure-pathname nil))
    31333206             (setf p (case namestring
    31343207                       ((:unix nil)
     
    32133286  (defun inter-directory-separator ()
    32143287    "What character does the current OS conventionally uses to separate directories?"
    3215     (if (os-unix-p) #\: #\;))
     3288    (os-cond ((os-unix-p) #\:) (t #\;)))
    32163289
    32173290  (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
    32183291    "Given a string of pathnames specified in native OS syntax, separate them in a list,
    3219 check constraints and normalize each one as per ENSURE-PATHNAME."
     3292check constraints and normalize each one as per ENSURE-PATHNAME,
     3293where an empty string denotes NIL."
    32203294    (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
    3221           :collect (apply 'parse-native-namestring namestring constraints)))
     3295          :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints))))
    32223296
    32233297  (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
     
    32323306  (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
    32333307    "Extract a list of pathname from a user-configured environment variable, as per native OS,
    3234 check constraints and normalize each one as per ENSURE-PATHNAME."
     3308check constraints and normalize each one as per ENSURE-PATHNAME.
     3309       Any empty entries in the environment variable X will be returned as NILs."
     3310    (unless (getf constraints :empty-is-nil t)
     3311      (error "Cannot have EMPTY-IS-NIL false for GETENV-PATHNAMES."))
    32353312    (apply 'split-native-pathnames-string (getenvp x)
    32363313           :on-error (or on-error
    32373314                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
     3315           :empty-is-nil t
    32383316           constraints))
    32393317  (defun getenv-absolute-directory (x)
     
    32433321  (defun getenv-absolute-directories (x)
    32443322    "Extract a list of absolute directories from a user-configured environment variable,
    3245 as per native OS"
     3323as per native OS.  Any empty entries in the environment variable X will be returned as
     3324NILs."
    32463325    (getenv-pathnames x :want-absolute t :ensure-directory t))
    32473326
     
    32493328    "Where are the system files of the current installation of the CL implementation?"
    32503329    (declare (ignorable truename))
    3251     #+(or clozure ecl gcl mkcl sbcl)
     3330    #+(or clasp clozure ecl gcl mkcl sbcl)
    32523331    (let ((dir
    32533332            (ignore-errors
    32543333             #+clozure #p"ccl:"
    3255              #+(or ecl mkcl) #p"SYS:"
     3334             #+(or clasp ecl mkcl) #p"SYS:"
    32563335             #+gcl system::*system-directory*
    32573336             #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
     
    32833362        (ensure-directories-exist (physicalize-pathname pathname)))))
    32843363
     3364  (defun delete-file-if-exists (x)
     3365    "Delete a file X if it already exists"
     3366    (when x (handler-case (delete-file x) (file-error () nil))))
     3367
    32853368  (defun rename-file-overwriting-target (source target)
    32863369    "Rename a file, overwriting any previous file with the TARGET name,
     
    32893372    (progn (funcall 'require "syscalls")
    32903373           (symbol-call :posix :copy-file source target :method :rename))
     3374    #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic
    32913375    #-clisp
    32923376    (rename-file source target
    3293                  #+(or clozure ecl) :if-exists #+clozure :rename-and-delete #+ecl t))
    3294 
    3295   (defun delete-file-if-exists (x)
    3296     "Delete a file X if it already exists"
    3297     (when x (handler-case (delete-file x) (file-error () nil))))
     3377                 #+(or clasp clozure ecl) :if-exists #+clozure :rename-and-delete #+(or clasp ecl) t))
    32983378
    32993379  (defun delete-empty-directory (directory-pathname)
     
    33113391                                    directory-pathname (unix:get-unix-error-msg errno))))
    33123392    #+cormanlisp (win32:delete-directory directory-pathname)
    3313     #+ecl (si:rmdir directory-pathname)
     3393    #+(or clasp ecl) (si:rmdir directory-pathname)
    33143394    #+genera (fs:delete-directory directory-pathname)
    33153395    #+lispworks (lw:delete-directory directory-pathname)
     
    33193399               `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
    33203400    #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
    3321     #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
     3401    #-(or abcl allegro clasp clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
    33223402    (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
    33233403
     
    33403420                 (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
    33413421       (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
    3342               'delete-filesystem-tree directory-pathname))
     3422              'delete-directory-tree directory-pathname))
    33433423      ((not validatep)
    33443424       (error "~S was asked to delete ~S but was not provided a validation predicate"
    3345               'delete-filesystem-tree directory-pathname))
     3425              'delete-directory-tree directory-pathname))
    33463426      ((not (call-function validate directory-pathname))
    33473427       (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
    3348               'delete-filesystem-tree directory-pathname validate))
     3428              'delete-directory-tree directory-pathname validate))
    33493429      ((not (directory-exists-p directory-pathname))
    33503430       (ecase if-does-not-exist
    33513431         (:error
    33523432          (error "~S was asked to delete ~S but the directory does not exist"
    3353               'delete-filesystem-tree directory-pathname))
     3433              'delete-directory-tree directory-pathname))
    33543434         (:ignore nil)))
    33553435      #-(or allegro cmu clozure genera sbcl scl)
     
    33763456               (map () 'delete-file (directory-files d))
    33773457               (delete-empty-directory d)))))))
    3378 
    33793458;;;; ---------------------------------------------------------------------------
    33803459;;;; Utilities related to streams
     
    33913470   #:*default-encoding* #:*utf-8-external-format*
    33923471   #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
    3393    #:with-output #:output-string #:with-input
     3472   #:with-output #:output-string #:with-input #:input-string
    33943473   #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
    33953474   #:null-device-pathname #:call-with-null-input #:with-null-input
     
    34253504          #.(or #+clozure 'ccl::*stdin*
    34263505                #+(or cmu scl) 'system:*stdin*
    3427                 #+ecl 'ext::+process-standard-input+
     3506                #+(or clasp ecl) 'ext::+process-standard-input+
    34283507                #+sbcl 'sb-sys:*stdin*
    34293508                '*standard-input*)))
     
    34363515          #.(or #+clozure 'ccl::*stdout*
    34373516                #+(or cmu scl) 'system:*stdout*
    3438                 #+ecl 'ext::+process-standard-output+
     3517                #+(or clasp ecl) 'ext::+process-standard-output+
    34393518                #+sbcl 'sb-sys:*stdout*
    34403519                '*standard-output*)))
     
    34483527                #+clozure 'ccl::*stderr*
    34493528                #+(or cmu scl) 'system:*stderr*
    3450                 #+ecl 'ext::+process-error-output+
     3529                #+(or clasp ecl) 'ext::+process-error-output+
    34513530                #+sbcl 'sb-sys:*stderr*
    34523531                '*error-output*)))
     
    36423721    "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
    36433722as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
    3644     `(call-with-input ,value #'(lambda (,input-var) ,@body))))
    3645 
     3723    `(call-with-input ,value #'(lambda (,input-var) ,@body)))
     3724
     3725  (defun input-string (&optional input)
     3726    "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string
     3727and return that"
     3728    (if (stringp input)
     3729        input
     3730        (with-input (input) (funcall 'slurp-stream-string input)))))
    36463731
    36473732;;; Null device
     
    36503735    "Pathname to a bit bucket device that discards any information written to it
    36513736and always returns EOF when read from"
    3652     (cond
     3737    (os-cond
    36533738      ((os-unix-p) #p"/dev/null")
    36543739      ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
     
    39013986  (defun default-temporary-directory ()
    39023987    "Return a default directory to use for temporary files"
    3903     (or
    3904      (when (os-unix-p)
     3988    (os-cond
     3989      ((os-unix-p)
    39053990       (or (getenv-pathname "TMPDIR" :ensure-directory t)
    39063991           (parse-native-namestring "/tmp/")))
    3907      (when (os-windows-p)
     3992      ((os-windows-p)
    39083993       (getenv-pathname "TEMP" :ensure-directory t))
    3909      (subpathname (user-homedir-pathname) "tmp/")))
     3994      (t (subpathname (user-homedir-pathname) "tmp/"))))
    39103995
    39113996  (defvar *temporary-directory* nil "User-configurable location for temporary files")
     
    39744059                   (setf okp pathname)
    39754060                   (when want-stream-p
    3976                      (setf results
    3977                            (multiple-value-list
    3978                             (if want-pathname-p
    3979                                 (funcall thunk stream pathname)
    3980                                 (funcall thunk stream)))))))
    3981                (when okp
    3982                  (unless want-stream-p
    3983                    (setf results (multiple-value-list (call-function thunk pathname))))
    3984                  (when after
    3985                    (setf results (multiple-value-list (call-function after pathname))))
    3986                  (return (apply 'values results))))
     4061                     ;; Note: can't return directly from within with-open-file
     4062                     ;; or the non-local return causes the file creation to be undone.
     4063                     (setf results (multiple-value-list
     4064                                    (if want-pathname-p
     4065                                        (funcall thunk stream pathname)
     4066                                        (funcall thunk stream)))))))
     4067               (cond
     4068                 ((not okp) nil)
     4069                 (after (return (call-function after okp)))
     4070                 ((and want-pathname-p (not want-stream-p)) (return (call-function thunk okp)))
     4071                 (t (return (apply 'values results)))))
    39874072          (when (and okp (not (call-function keep)))
    39884073            (ignore-errors (delete-file-if-exists okp))))))
     
    41324217    #+(or abcl xcl) (ext:quit :status code)
    41334218    #+allegro (excl:exit code :quiet t)
     4219    #+(or clasp ecl) (si:quit code)
    41344220    #+clisp (ext:quit code)
    41354221    #+clozure (ccl:quit code)
    41364222    #+cormanlisp (win32:exitprocess code)
    41374223    #+(or cmu scl) (unix:unix-exit code)
    4138     #+ecl (si:quit code)
    41394224    #+gcl (system:quit code)
    41404225    #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
     
    41474232                 (exit `(,exit :code code :abort (not finish-output)))
    41484233                 (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
    4149     #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
     4234    #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    41504235    (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
    41514236
     
    41744259        :count (or count t)
    41754260        :all t))
     4261    #+(or clasp ecl mkcl)
     4262    (let* ((top (si:ihs-top))
     4263           (repeats (if count (min top count) top))
     4264           (backtrace (loop :for ihs :from 0 :below top
     4265                            :collect (list (si::ihs-fun ihs)
     4266                                           (si::ihs-env ihs)))))
     4267      (loop :for i :from 0 :below repeats
     4268            :for frame :in (nreverse backtrace) :do
     4269              (safe-format! stream "~&~D: ~S~%" i frame)))
    41764270    #+clisp
    41774271    (system::print-backtrace :out stream :limit count)
     
    41854279          (debug:*debug-print-length* *print-length*))
    41864280      (debug:backtrace (or count most-positive-fixnum) stream))
    4187     #+(or ecl mkcl)
    4188     (let* ((top (si:ihs-top))
    4189            (repeats (if count (min top count) top))
    4190            (backtrace (loop :for ihs :from 0 :below top
    4191                             :collect (list (si::ihs-fun ihs)
    4192                                            (si::ihs-env ihs)))))
    4193       (loop :for i :from 0 :below repeats
    4194             :for frame :in (nreverse backtrace) :do
    4195               (safe-format! stream "~&~D: ~S~%" i frame)))
    41964281    #+gcl
    41974282    (let ((*debug-io* stream))
     
    42934378    #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
    42944379    #+allegro (sys:command-line-arguments) ; default: :application t
     4380    #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
    42954381    #+clisp (coerce (ext:argv) 'list)
    4296     #+clozure (ccl::command-line-arguments)
     4382    #+clozure ccl:*command-line-argument-list*
    42974383    #+(or cmu scl) extensions:*command-line-strings*
    4298     #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
    42994384    #+gcl si:*command-args*
    43004385    #+(or genera mcl) nil
     
    43034388    #+sbcl sb-ext:*posix-argv*
    43044389    #+xcl system:*argv*
    4305     #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
     4390    #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    43064391    (error "raw-command-line-arguments not implemented yet"))
    43074392
     
    43344419       (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl)
    43354420           (first (raw-command-line-arguments))
    4336            #+ecl (si:argv 0) #+mkcl (mkcl:argv 0)))
     4421           #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0)))
    43374422      (t ;; argv[0] is the name of the interpreter.
    43384423       ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
     
    44944579    ;; only if we also track the object files that constitute the "current" image,
    44954580    ;; and otherwise simulate dump-image, including quitting at the end.
    4496     #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
    4497     #+(or ecl mkcl)
     4581    #-(or clasp ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
     4582    #+(or clasp ecl mkcl)
    44984583    (let ((epilogue-code
    4499             (if no-uiop
    4500                 epilogue-code
    4501                 (let ((forms
    4502                         (append
    4503                          (when epilogue-code `(,epilogue-code))
    4504                          (when postludep `((setf *image-postlude* ',postlude)))
    4505                          (when preludep `((setf *image-prelude* ',prelude)))
    4506                          (when entry-point-p `((setf *image-entry-point* ',entry-point)))
    4507                          (case kind
    4508                            ((:image)
    4509                             (setf kind :program) ;; to ECL, it's just another program.
    4510                             `((setf *image-dumped-p* t)
    4511                               (si::top-level #+ecl t) (quit)))
    4512                            ((:program)
    4513                             `((setf *image-dumped-p* :executable)
    4514                               (shell-boolean-exit
    4515                                (restore-image))))))))
    4516                   (when forms `(progn ,@forms))))))
    4517       #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
    4518       (apply #+ecl 'c::builder #+ecl kind
     4584           (if no-uiop
     4585               epilogue-code
     4586               (let ((forms
     4587                      (append
     4588                       (when epilogue-code `(,epilogue-code))
     4589                       (when postludep `((setf *image-postlude* ',postlude)))
     4590                       (when preludep `((setf *image-prelude* ',prelude)))
     4591                       (when entry-point-p `((setf *image-entry-point* ',entry-point)))
     4592                       (case kind
     4593                         ((:image)
     4594                          (setf kind :program) ;; to ECL, it's just another program.
     4595                          `((setf *image-dumped-p* t)
     4596                            (si::top-level #+(or clasp ecl) t) (quit)))
     4597                         ((:program)
     4598                          `((setf *image-dumped-p* :executable)
     4599                            (shell-boolean-exit
     4600                             (restore-image))))))))
     4601                 (when forms `(progn ,@forms))))))
     4602      #+(or clasp ecl) (check-type kind (member :dll :lib :static-library :program :object :fasl))
     4603      (apply #+clasp 'cmp:builder #+clasp kind
     4604             #+(and ecl (not clasp)) 'c::builder #+(and ecl (not clasp)) kind
    45194605             #+mkcl (ecase kind
    45204606                      ((:dll) 'compiler::build-shared-library)
     
    45234609                      ((:program) 'compiler::build-program))
    45244610             (pathname destination)
    4525              #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files)
    4526              #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind)
     4611             #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+(or clasp ecl) extra-object-files)
     4612             #+(or clasp ecl) :init-name #+(or clasp ecl) (c::compute-init-name (or output-name destination) :kind kind)
    45274613             (append
    45284614              (when prologue-code `(:prologue-code ,prologue-code))
     
    45714657       ((and good-chars bad-chars)
    45724658        (error "only one of good-chars and bad-chars can be provided"))
    4573        ((functionp good-chars)
     4659       ((typep good-chars 'function)
    45744660        (complement good-chars))
    4575        ((functionp bad-chars)
     4661       ((typep bad-chars 'function)
    45764662        bad-chars)
    45774663       ((and good-chars (typep good-chars 'sequence))
     
    46164702             (issue (char x i)) (setf i i+1))))))
    46174703
     4704  (defun easy-windows-character-p (x)
     4705    "Is X an \"easy\" character that does not require quoting by the shell?"
     4706    (or (alphanumericp x) (find x "+-_.,@:/=")))
     4707
    46184708  (defun escape-windows-token (token &optional s)
    46194709    "Escape a string TOKEN within double-quotes if needed
    46204710for use within a MS Windows command-line, outputing to S."
    4621     (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
     4711    (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
    46224712                        :escaper 'escape-windows-token-within-double-quotes))
    46234713
     
    46344724  (defun easy-sh-character-p (x)
    46354725    "Is X an \"easy\" character that does not require quoting by the shell?"
    4636     (or (alphanumericp x) (find x "+-_.,%@:/")))
     4726    (or (alphanumericp x) (find x "+-_.,%@:/=")))
    46374727
    46384728  (defun escape-sh-token (token &optional s)
     
    46444734  (defun escape-shell-token (token &optional s)
    46454735    "Escape a token for the current operating system shell"
    4646     (cond
     4736    (os-cond
    46474737      ((os-unix-p) (escape-sh-token token s))
    46484738      ((os-windows-p) (escape-windows-token token s))))
     
    48674957     (process :initform nil :initarg :process :reader subprocess-error-process))
    48684958    (:report (lambda (condition stream)
    4869                (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
     4959               (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
    48704960                       (subprocess-error-process condition)
    48714961                       (subprocess-error-command condition)
    48724962                       (subprocess-error-code condition)))))
     4963
     4964  ;;; find CMD.exe on windows
     4965  (defun %cmd-shell-pathname ()
     4966    (os-cond
     4967     ((os-windows-p)
     4968      (strcat (native-namestring (getenv-absolute-directory "WINDIR"))
     4969              "System32\\cmd.exe"))
     4970     (t
     4971      (error "CMD.EXE is not the command shell for this OS."))))
    48734972
    48744973  ;;; Internal helpers for run-program
     
    48814980      #+os-windows
    48824981      (string
    4883        #+mkcl (list "cmd" '#:/c command)
     4982       #+mkcl (list "cmd" "/c" command)
    48844983       ;; NB: We do NOT add cmd /c here. You might want to.
    48854984       #+(or allegro clisp) command
     
    48884987       ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
    48894988       #+clozure (cons "cmd" (strcat "/c " command))
     4989       #+sbcl (list (%cmd-shell-pathname) "/c" command)
    48904990       ;; NB: On other Windows implementations, this is utterly bogus
    48914991       ;; except in the most trivial cases where no quoting is needed.
    48924992       ;; Use at your own risk.
    4893        #-(or allegro clisp clozure mkcl) (list "cmd" "/c" command))
     4993       #-(or allegro clisp clozure mkcl sbcl) (list "cmd" "/c" command))
    48944994      #+os-windows
    48954995      (list
     
    49185018       #+allegro nil
    49195019       #+clisp :terminal
    4920        #+(or clozure cmu ecl mkcl sbcl scl) t)
    4921       #+(or allegro clozure cmu ecl lispworks mkcl sbcl scl)
     5020       #+(or clasp clozure cmu ecl mkcl sbcl scl) t)
     5021      #+(or allegro clasp clozure cmu ecl lispworks mkcl sbcl scl)
    49225022      ((eql :output)
    49235023       (if (eq role :error-output)
     
    49875087                   (list (run 'ext:run-program (car %command)
    49885088                              :arguments (cdr %command)))))
    4989                #+(or clozure cmu ecl mkcl sbcl scl)
    4990                (#-(or ecl mkcl) progn #+(or ecl mkcl) multiple-value-list
     5089               #+(or clasp clozure cmu ecl mkcl sbcl scl)
     5090               (#-(or clasp ecl mkcl) progn #+(or clasp ecl mkcl) multiple-value-list
    49915091                (apply
    49925092                 '#+(or cmu ecl scl) ext:run-program
     
    50665166                  #+(or cmu scl) (ext:process-error process*)
    50675167                  #+sbcl (sb-ext:process-error process*))))
    5068         #+(or ecl mkcl)
    5069         (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
     5168        #+(or clasp ecl mkcl)
     5169        (destructuring-bind #+(or clasp ecl) (stream code process) #+mkcl (stream process code) process*
    50705170          (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
    50715171            (cond
     
    50925192      #+(or allegro lispworks) process
    50935193      #+clozure (ccl::external-process-pid process)
    5094       #+ecl (si:external-process-pid process)
     5194      #+(or clasp ecl) (si:external-process-pid process)
    50955195      #+(or cmu scl) (ext:process-pid process)
    50965196      #+mkcl (mkcl:process-id process)
     
    51055205            #+clozure (ccl::external-process-wait process)
    51065206            #+(or cmu scl) (ext:process-wait process)
    5107             #+(and ecl os-unix) (ext:external-process-wait process)
     5207            #+(and (or clasp ecl) os-unix) (ext:external-process-wait process)
    51085208            #+sbcl (sb-ext:process-wait process)
    51095209            ;; 2- extract result
     
    51115211            #+clozure (nth-value 1 (ccl:external-process-status process))
    51125212            #+(or cmu scl) (ext:process-exit-code process)
    5113             #+ecl (nth-value 1 (ext:external-process-status process))
     5213            #+(or clasp ecl) (nth-value 1 (ext:external-process-status process))
    51145214            #+lispworks
    51155215            (if-let ((stream (or (getf process-info :input-stream)
     
    52775377  (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
    52785378    (etypecase command
    5279       (string command)
     5379      (string
     5380       (os-cond
     5381        ((os-windows-p)
     5382         #+(or allegro clisp)
     5383         (strcat (%cmd-shell-pathname) " /c " command)
     5384         #-(or allegro clisp) command)
     5385        (t command)))
    52805386      (list (escape-shell-command
    5281              (if (os-unix-p) (cons "exec" command) command)))))
     5387             (os-cond
     5388              ((os-unix-p) (cons "exec" command))
     5389              ((os-windows-p)
     5390               #+(or allegro sbcl clisp)
     5391               (cons (%cmd-shell-pathname) (cons "/c" command))
     5392               #-(or allegro sbcl clisp) command)
     5393              (t command))))))
    52825394
    52835395  (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
     
    52945406                 (list operator " "
    52955407                       (escape-shell-token (native-namestring pathname)))))))
    5296       (multiple-value-bind (before after)
    5297           (let ((normalized (%normalize-system-command command)))
    5298             (if (os-unix-p)
    5299                 (values '("exec") (list " ; " normalized))
    5300                 (values (list normalized) ())))
     5408      (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
     5409             (normalized (%normalize-system-command command))
     5410             (directory (or directory #+(or abcl xcl) (getcwd)))
     5411             (chdir (when directory
     5412                      (let ((dir-arg (escape-shell-token (native-namestring directory))))
     5413                        (os-cond
     5414                         ((os-unix-p) `("cd " ,dir-arg " ; "))
     5415                         ((os-windows-p) `("cd /d " ,dir-arg " & ")))))))
    53015416        (reduce/strcat
    5302          (append
    5303           before (redirect in " <") (redirect out " >") (redirect err " 2>")
    5304           (when (and directory (os-unix-p)) ;; NB: unless on Unix, %system uses with-current-directory
    5305             `(" ; cd " ,(escape-shell-token (native-namestring directory))))
    5306           after)))))
     5417         (os-cond
     5418          ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
     5419          ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
    53075420
    53085421  (defun %system (command &rest keys
     
    53135426    (%wait-process-result
    53145427     (apply '%run-program (%normalize-system-command command) :wait t keys))
    5315     #+(or abcl cormanlisp clisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
     5428    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
    53165429    (let ((%command (%redirected-system-command command input output error-output directory)))
    53175430      #+(and lispworks os-windows)
     
    53225435              :input :interactive :output :interactive :error-output :interactive keys))
    53235436      #-(or clisp (and lispworks os-windows))
    5324       (with-current-directory ((unless (os-unix-p) directory))
     5437      (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
    53255438        #+abcl (ext:run-shell-command %command)
    53265439        #+cormanlisp (win32:system %command)
    5327         #+ecl (let ((*standard-input* *stdin*)
     5440        #+(or clasp ecl) (let ((*standard-input* *stdin*)
    53285441                    (*standard-output* *stdout*)
    53295442                    (*error-output* *stderr*))
     
    53545467
    53555468  (defun run-program (command &rest keys
    5356                        &key ignore-error-status force-shell
     5469                       &key ignore-error-status (force-shell nil force-shell-suppliedp)
    53575470                         (input nil inputp) (if-input-does-not-exist :error)
    53585471                         output (if-output-exists :overwrite)
     
    53665479
    53675480Always call a shell (rather than directly execute the command when possible)
    5368 if FORCE-SHELL is specified.
     5481if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
     5482specified to be NIL.
    53695483
    53705484Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
     
    54125526or an indication of failure via the EXIT-CODE of the process"
    54135527    (declare (ignorable ignore-error-status))
    5414     #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
     5528    #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
    54155529    (error "RUN-PROGRAM not implemented for this Lisp")
     5530    ;; per doc string, set FORCE-SHELL to T if we get command as a string.  But
     5531    ;; don't override user's specified preference. [2015/06/29:rpg]
     5532    (when (stringp command)
     5533      (unless force-shell-suppliedp
     5534        (setf force-shell t)))
    54165535    (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
    54175536      (apply (if (or force-shell
    5418                      #+(or clisp ecl) (or (not ignore-error-status) t)
    5419                      #+clisp (eq error-output :interactive)
    5420                      #+(or abcl clisp) (eq :error-output :output)
     5537                     #+(or clasp clisp ecl) (or (not ignore-error-status) t)
     5538                     #+clisp (member error-output '(:interactive :output))
    54215539                     #+(and lispworks os-unix) (%interactivep input output error-output)
    54225540                     #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
     
    54995617                    ccl::*nx-debug* ccl::*nx-cspeed*)
    55005618        #+(or cmu scl) '(c::*default-cookie*)
    5501         #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
     5619        #+(and ecl (not clasp)) (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
     5620        #+clasp '()
    55025621        #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
    55035622        #+lispworks '(compiler::*optimization-level*)
     
    55065625  (defun get-optimization-settings ()
    55075626    "Get current compiler optimization settings, ready to PROCLAIM again"
    5508     #-(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
     5627    #-(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
    55095628    (warn "~S does not support ~S. Please help me fix that."
    55105629          'get-optimization-settings (implementation-type))
    5511     #+(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
     5630    #+(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
    55125631    (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
    55135632      #.`(loop #+(or allegro clozure)
     
    55155634                   #+clozure (ccl:declaration-information 'optimize nil))
    55165635               :for x :in settings
    5517                ,@(or #+(or abcl ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
     5636               ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
    55185637               :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
    55195638                            #+clisp (gethash x system::*optimize* 1)
    5520                             #+(or abcl ecl mkcl xcl) (symbol-value v)
     5639                            #+(or abcl clasp ecl mkcl xcl) (symbol-value v)
    55215640                            #+(or cmu scl) (slot-value c::*default-cookie*
    55225641                                                       (case x (compilation-speed 'c::cspeed)
    55235642                                                             (otherwise x)))
    55245643                            #+lispworks (slot-value compiler::*optimization-level* x)
    5525                             #+sbcl (cdr (assoc x sb-c::*policy*)))
     5644                            #+sbcl (sb-c::policy-quality sb-c::*policy* x))
    55265645               :when y :collect (list x y))))
    55275646  (defun proclaim-optimization-settings ()
     
    60426161    "pathname TYPE for lisp FASt Loading files"
    60436162    (declare (ignorable keys))
    6044     #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
    6045     #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
     6163    #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
     6164    #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
    60466165
    60476166  (defun call-around-hook (hook function)
     
    60686187  (defun* (compile-file*) (input-file &rest keys
    60696188                                      &key (compile-check *compile-check*) output-file warnings-file
    6070                                       #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
     6189                                      #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl
    60716190                                      &allow-other-keys)
    60726191    "This function provides a portable wrapper around COMPILE-FILE.
     
    60886207On implementations that erroneously do not recognize standard keyword arguments,
    60896208it will filter them appropriately."
    6090     #+ecl (when (and object-file (equal (compile-file-type) (pathname object-file)))
     6209    #+(or clasp ecl) (when (and object-file (equal (compile-file-type) (pathname object-file)))
    60916210            (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
    60926211                    'compile-file* output-file object-file)
     
    60946213    (let* ((keywords (remove-plist-keys
    60956214                      `(:output-file :compile-check :warnings-file
    6096                                      #+clisp :lib-file #+(or ecl mkcl) :object-file) keys))
     6215                                     #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys))
    60976216           (output-file
    60986217             (or output-file
    60996218                 (apply 'compile-file-pathname* input-file :output-file output-file keywords)))
    6100            #+ecl
     6219           #+(or clasp ecl)
    61016220           (object-file
    61026221             (unless (use-ecl-byte-compiler-p)
    61036222               (or object-file
    6104                    (compile-file-pathname output-file :type :object))))
     6223                   #+ecl(compile-file-pathname output-file :type :object)
     6224                   #+clasp (compile-file-pathname output-file :output-type :object)
     6225                   )))
    61056226           #+mkcl
    61066227           (object-file
     
    61226243            (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
    61236244              (with-muffled-compiler-conditions ()
    6124                 (or #-(or ecl mkcl)
     6245                (or #-(or clasp ecl mkcl)
    61256246                    (apply 'compile-file input-file :output-file tmp-file
    61266247                           #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
    61276248                           #-sbcl keywords)
    61286249                    #+ecl (apply 'compile-file input-file :output-file
    6129                                  (if object-file
    6130                                      (list* object-file :system-p t keywords)
    6131                                      (list* tmp-file keywords)))
     6250                                (if object-file
     6251                                    (list* object-file :system-p t keywords)
     6252                                    (list* tmp-file keywords)))
     6253                    #+clasp (apply 'compile-file input-file :output-file
     6254                                  (if object-file
     6255                                      (list* object-file :output-type :object #|:system-p t|# keywords)
     6256                                      (list* tmp-file keywords)))
    61326257                    #+mkcl (apply 'compile-file input-file
    61336258                                  :output-file object-file :fasl-p nil keywords)))))
     
    61396264                       (check-flag warnings-p *compile-file-warnings-behaviour*)))
    61406265                (progn
    6141                   #+(or ecl mkcl)
    6142                   (when (and #+ecl object-file)
     6266                  #+(or clasp ecl mkcl)
     6267                  (when (and #+(or clasp ecl) object-file)
    61436268                    (setf output-truename
    6144                           (compiler::build-fasl
    6145                            tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files
    6146                                     (list object-file))))
     6269                          (compiler::build-fasl tmp-file
     6270                           #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list object-file))))
    61476271                  (or (not compile-check)
    6148                       (apply compile-check input-file :output-file tmp-file keywords))))
     6272                      (apply compile-check input-file
     6273                             :output-file #-(or clasp ecl) output-file #+(or clasp ecl) tmp-file
     6274                             keywords))))
    61496275           (delete-file-if-exists output-file)
    61506276           (when output-truename
     6277             #+clasp (when output-truename (rename-file-overwriting-target tmp-file output-truename))
    61516278             #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
    61526279             #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
    61536280             (rename-file-overwriting-target output-truename output-file)
    61546281             (setf output-truename (truename output-file)))
     6282           #+clasp (delete-file-if-exists tmp-file)
    61556283           #+clisp (delete-file-if-exists tmp-lib))
    61566284          (t ;; error or failed check
     
    62116339        (loop :for f :in fasls :do (ignore-errors (delete-file f)))
    62126340        (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
    6213 
    62146341;;;; ---------------------------------------------------------------------------
    62156342;;;; Generic support for configuration files
     
    62216348   :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
    62226349  (:export
     6350   #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
     6351   #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem
    62236352   #:get-folder-path
    6224    #:user-configuration-directories #:system-configuration-directories
    6225    #:in-first-directory
    6226    #:in-user-configuration-directory #:in-system-configuration-directory
     6353   #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
     6354   #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
     6355   #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames
     6356   #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname
    62276357   #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
    62286358   #:configuration-inheritance-directive-p
     
    62446374                       (list* (condition-form c) (condition-location c)
    62456375                              (condition-arguments c))))))
    6246 
    6247   (defun get-folder-path (folder)
    6248     "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
    6249 this function tries to locate the Windows FOLDER for one of
    6250 :LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA."
    6251     (or #+(and lispworks mswindows) (sys:get-folder-path folder)
    6252         ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    6253         (ecase folder
    6254           (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
    6255           (:appdata (getenv-absolute-directory "APPDATA"))
    6256           (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
    6257                                (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
    6258 
    6259   (defun user-configuration-directories ()
    6260     "Determine user configuration directories"
    6261     (let ((dirs
    6262             `(,@(when (os-unix-p)
    6263                   (cons
    6264                    (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
    6265                    (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
    6266                          :collect (subpathname* dir "common-lisp/"))))
    6267               ,@(when (os-windows-p)
    6268                   `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
    6269                     ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
    6270               ,(subpathname (user-homedir-pathname) ".config/common-lisp/"))))
    6271       (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
    6272                          :from-end t :test 'equal)))
    6273 
    6274   (defun system-configuration-directories ()
    6275     "Determine system user configuration directories"
    6276     (cond
    6277       ((os-unix-p) '(#p"/etc/common-lisp/"))
    6278       ((os-windows-p)
    6279        (if-let (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/"))
    6280          (list it)))))
    6281 
    6282   (defun in-first-directory (dirs x &key (direction :input))
    6283     "Determine system user configuration directories"
    6284     (loop :with fun = (ecase direction
    6285                         ((nil :input :probe) 'probe-file*)
    6286                         ((:output :io) 'identity))
    6287           :for dir :in dirs
    6288           :thereis (and dir (funcall fun (subpathname (ensure-directory-pathname dir) x)))))
    6289 
    6290   (defun in-user-configuration-directory (x &key (direction :input))
    6291     "return pathname under user configuration directory, subpathname X"
    6292     (in-first-directory (user-configuration-directories) x :direction direction))
    6293   (defun in-system-configuration-directory (x &key (direction :input))
    6294     "return pathname under system configuration directory, subpathname X"
    6295     (in-first-directory (system-configuration-directories) x :direction direction))
    62966376
    62976377  (defun configuration-inheritance-directive-p (x)
     
    63186398  (defun validate-configuration-form (form tag directive-validator
    63196399                                            &key location invalid-form-reporter)
    6320     "Validate a configuration FORM"
     6400    "Validate a configuration FORM. By default it will raise an error if the
     6401FORM is not valid.  Otherwise it will return the validated form.
     6402     Arguments control the behavior:
     6403     The configuration FORM should be of the form (TAG . <rest>)
     6404     Each element of <rest> will be checked by first seeing if it's a configuration inheritance
     6405directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
     6406on it.
     6407     In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
     6408reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
     6409the configuration form appeared."
    63216410    (unless (and (consp form) (eq (car form) tag))
    63226411      (setf *ignored-configuration-form* t)
     
    63516440
    63526441  (defun validate-configuration-file (file validator &key description)
    6353     "Validate a configuration file for conformance of its form with the validator function"
     6442    "Validate a configuration FILE.  The configuration file should have only one s-expression
     6443in it, which will be checked with the VALIDATOR FORM.  DESCRIPTION argument used for error
     6444reporting."
    63546445    (let ((forms (read-file-forms file)))
    63556446      (unless (length=n-p forms 1)
     
    63846475
    63856476  (defun resolve-relative-location (x &key ensure-directory wilden)
    6386     "Given a designator X for an relative location, resolve it to a pathname"
     6477    "Given a designator X for an relative location, resolve it to a pathname."
    63876478    (ensure-pathname
    63886479     (etypecase x
     6480       (null nil)
    63896481       (pathname x)
    63906482       (string (parse-unix-namestring
     
    64226514    "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
    64236515
    6424   (defun compute-user-cache ()
    6425     "Compute the location of the default user-cache for translate-output objects"
    6426     (setf *user-cache*
    6427           (flet ((try (x &rest sub) (and x `(,x ,@sub))))
    6428             (or
    6429              (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
    6430              (when (os-windows-p)
    6431                (try (or (get-folder-path :local-appdata)
    6432                         (get-folder-path :appdata))
    6433                     "common-lisp" "cache" :implementation))
    6434              '(:home ".cache" "common-lisp" :implementation)))))
    6435   (register-image-restore-hook 'compute-user-cache)
    6436 
    64376516  (defun resolve-absolute-location (x &key ensure-directory wilden)
    64386517    "Given a designator X for an absolute location, resolve it to a pathname"
    64396518    (ensure-pathname
    64406519     (etypecase x
     6520       (null nil)
    64416521       (pathname x)
    64426522       (string
     
    64816561    (loop* :with dirp = (or directory ensure-directory)
    64826562           :with (first . rest) = (if (atom x) (list x) x)
    6483            :with path = (resolve-absolute-location
    6484                          first :ensure-directory (and (or dirp rest) t)
    6485                                :wilden (and wilden (null rest)))
     6563           :with path = (or (resolve-absolute-location
     6564                             first :ensure-directory (and (or dirp rest) t)
     6565                                   :wilden (and wilden (null rest)))
     6566                            (return nil))
    64866567           :for (element . morep) :on rest
    64876568           :for dir = (and (or morep dirp) t)
     
    64966577  (defun location-designator-p (x)
    64976578    "Is X a designator for a location?"
     6579    ;; NIL means "skip this entry", or as an output translation, same as translation input.
     6580    ;; T means "any input" for a translation, or as output, same as translation input.
    64986581    (flet ((absolute-component-p (c)
    64996582             (typep c '(or string pathname
     
    65086591  (defun location-function-p (x)
    65096592    "Is X the specification of a location function?"
    6510     (and
    6511      (length=n-p x 2)
    6512      (eq (car x) :function)))
     6593    ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
     6594    (and (length=n-p x 2) (eq (car x) :function)))
    65136595
    65146596  (defvar *clear-configuration-hook* '())
     
    65286610    (when *ignored-configuration-form*
    65296611      (clear-configuration)
    6530       (setf *ignored-configuration-form* nil))))
    6531 
    6532 
     6612      (setf *ignored-configuration-form* nil)))
     6613
     6614
     6615  (defun get-folder-path (folder)
     6616    "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
     6617this function tries to locate the Windows FOLDER for one of
     6618:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
     6619     Returns NIL when the folder is not defined (e.g., not on Windows)."
     6620    (or #+(and lispworks mswindows) (sys:get-folder-path folder)
     6621        ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
     6622        (ecase folder
     6623          (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
     6624                              (subpathname* (get-folder-path :appdata) "Local")))
     6625          (:appdata (getenv-absolute-directory "APPDATA"))
     6626          (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
     6627                               (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
     6628
     6629
     6630  ;; Support for the XDG Base Directory Specification
     6631  (defun xdg-data-home (&rest more)
     6632    "Returns an absolute pathname for the directory containing user-specific data files.
     6633MORE may contain specifications for a subpath relative to this directory: a
     6634subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6635also \"Configuration DSL\"\) in the ASDF manual."
     6636    (resolve-absolute-location
     6637     `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
     6638            (os-cond
     6639             ((os-windows-p) (get-folder-path :local-appdata))
     6640             (t (subpathname (user-homedir-pathname) ".local/share/"))))
     6641       ,more)))
     6642
     6643  (defun xdg-config-home (&rest more)
     6644    "Returns a pathname for the directory containing user-specific configuration files.
     6645MORE may contain specifications for a subpath relative to this directory: a
     6646subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6647also \"Configuration DSL\"\) in the ASDF manual."
     6648    (resolve-absolute-location
     6649     `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
     6650            (os-cond
     6651             ((os-windows-p) (xdg-data-home "config/"))
     6652             (t (subpathname (user-homedir-pathname) ".config/"))))
     6653       ,more)))
     6654
     6655  (defun xdg-data-dirs (&rest more)
     6656    "The preference-ordered set of additional paths to search for data files.
     6657Returns a list of absolute directory pathnames.
     6658MORE may contain specifications for a subpath relative to these directories: a
     6659subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6660also \"Configuration DSL\"\) in the ASDF manual."
     6661    (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
     6662            (or (getenv-absolute-directories "XDG_DATA_DIRS")
     6663                (os-cond
     6664                 ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
     6665                 (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))))
     6666
     6667  (defun xdg-config-dirs (&rest more)
     6668    "The preference-ordered set of additional base paths to search for configuration files.
     6669Returns a list of absolute directory pathnames.
     6670MORE may contain specifications for a subpath relative to these directories:
     6671subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6672also \"Configuration DSL\"\) in the ASDF manual."
     6673    (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
     6674            (or (getenv-absolute-directories "XDG_CONFIG_DIRS")
     6675                (os-cond
     6676                 ((os-windows-p) (xdg-data-dirs "config/"))
     6677                 (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))
     6678
     6679  (defun xdg-cache-home (&rest more)
     6680    "The base directory relative to which user specific non-essential data files should be stored.
     6681Returns an absolute directory pathname.
     6682MORE may contain specifications for a subpath relative to this directory: a
     6683subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6684also \"Configuration DSL\"\) in the ASDF manual."
     6685    (resolve-absolute-location
     6686     `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
     6687            (os-cond
     6688             ((os-windows-p) (xdg-data-home "cache"))
     6689             (t (subpathname* (user-homedir-pathname) ".cache/"))))
     6690       ,more)))
     6691
     6692  (defun xdg-runtime-dir (&rest more)
     6693    "Pathname for user-specific non-essential runtime files and other file objects,
     6694such as sockets, named pipes, etc.
     6695Returns an absolute directory pathname.
     6696MORE may contain specifications for a subpath relative to this directory: a
     6697subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6698also \"Configuration DSL\"\) in the ASDF manual."
     6699    ;; The XDG spec says that if not provided by the login system, the application should
     6700    ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
     6701    (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
     6702
     6703  ;;; NOTE: modified the docstring because "system user configuration
     6704  ;;; directories" seems self-contradictory. I'm not sure my wording is right.
     6705  (defun system-config-pathnames (&rest more)
     6706    "Return a list of directories where are stored the system's default user configuration information.
     6707MORE may contain specifications for a subpath relative to these directories: a
     6708subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6709also \"Configuration DSL\"\) in the ASDF manual."
     6710    (declare (ignorable more))
     6711    (os-cond
     6712     ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more))))))
     6713
     6714  (defun filter-pathname-set (dirs)
     6715    "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
     6716    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))
     6717
     6718  (defun xdg-data-pathnames (&rest more)
     6719    "Return a list of absolute pathnames for application data directories.  With APP,
     6720returns directory for data for that application, without APP, returns the set of directories
     6721for storing all application configurations.
     6722MORE may contain specifications for a subpath relative to these directories: a
     6723subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6724also \"Configuration DSL\"\) in the ASDF manual."
     6725    (filter-pathname-set
     6726     `(,(xdg-data-home more)
     6727       ,@(xdg-data-dirs more))))
     6728
     6729  (defun xdg-config-pathnames (&rest more)
     6730    "Return a list of pathnames for application configuration.
     6731MORE may contain specifications for a subpath relative to these directories: a
     6732subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6733also \"Configuration DSL\"\) in the ASDF manual."
     6734    (filter-pathname-set
     6735     `(,(xdg-config-home more)
     6736       ,@(xdg-config-dirs more))))
     6737
     6738  (defun find-preferred-file (files &key (direction :input))
     6739    "Find first file in the list of FILES that exists (for direction :input or :probe)
     6740or just the first one (for direction :output or :io).
     6741    Note that when we say \"file\" here, the files in question may be directories."
     6742    (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))
     6743
     6744  (defun xdg-data-pathname (&optional more (direction :input))
     6745    (find-preferred-file (xdg-data-pathnames more) :direction direction))
     6746
     6747  (defun xdg-config-pathname (&optional more (direction :input))
     6748    (find-preferred-file (xdg-config-pathnames more) :direction direction))
     6749
     6750  (defun compute-user-cache ()
     6751    "Compute (and return) the location of the default user-cache for translate-output
     6752objects. Side-effects for cached file location computation."
     6753    (setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
     6754  (register-image-restore-hook 'compute-user-cache))
    65336755;;;; -------------------------------------------------------------------------
    65346756;;; Hacks for backward-compatibility of the driver
     
    65396761  (:use :uiop/common-lisp :uiop/package :uiop/utility
    65406762   :uiop/pathname :uiop/stream :uiop/os :uiop/image
    6541    :uiop/run-program :uiop/lisp-build
    6542    :uiop/configuration)
     6763   :uiop/run-program :uiop/lisp-build :uiop/configuration)
    65436764  (:export
    65446765   #:coerce-pathname #:component-name-to-pathname-components
    6545    #+(or ecl mkcl) #:compile-file-keeping-object
     6766   #+(or clasp ecl mkcl) #:compile-file-keeping-object
     6767   #:user-configuration-directories #:system-configuration-directories
     6768   #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory
    65466769   ))
    65476770(in-package :uiop/backward-driver)
     
    65706793      (values relabs path filename)))
    65716794
    6572   #+(or ecl mkcl)
    6573   (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
     6795  #+(or clasp ecl mkcl)
     6796  (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args))
     6797
     6798  ;; Backward compatibility for ASDF 2.27 to 3.1.4
     6799  (defun user-configuration-directories ()
     6800    "Return the current user's list of user configuration directories
     6801for configuring common-lisp.
     6802    DEPRECATED. Use uiop:xdg-config-pathnames instead."
     6803    (xdg-config-pathnames "common-lisp"))
     6804  (defun system-configuration-directories ()
     6805    "Return the list of system configuration directories for common-lisp.
     6806    DEPRECATED. Use uiop:config-system-pathnames instead."
     6807    (system-config-pathnames "common-lisp"))
     6808  (defun in-first-directory (dirs x &key (direction :input))
     6809    "Finds the first appropriate file named X in the list of DIRS for I/O
     6810in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
     6811   If direction is :INPUT or :PROBE, will return the first extant file named
     6812X in one of the DIRS.
     6813   If direction is :OUTPUT or :IO, will simply return the file named X in the
     6814first element of DIRS that exists. DEPRECATED."
     6815    (find-preferred-file
     6816     (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs)
     6817     :direction direction))
     6818  (defun in-user-configuration-directory (x &key (direction :input))
     6819    "Return the file named X in the user configuration directory for common-lisp.
     6820DEPRECATED."
     6821    (xdg-config-pathname `("common-lisp" ,x) direction))
     6822  (defun in-system-configuration-directory (x &key (direction :input))
     6823    "Return the pathname for the file named X under the system configuration directory
     6824for common-lisp. DEPRECATED."
     6825    (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction)))
    65746826;;;; ---------------------------------------------------------------------------
    65756827;;;; Re-export all the functionality in UIOP
     
    66596911         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    66606912         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    6661          (asdf-version "3.1.3")
     6913         (asdf-version "3.1.5")
    66626914         (existing-version (asdf-version)))
    66636915    (setf *asdf-version* asdf-version)
     
    67426994
    67436995  (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration))
     6996
     6997;;;; -------------------------------------------------------------------------
     6998;;;; Stamp cache
     6999
     7000(uiop/package:define-package :asdf/cache
     7001  (:use :uiop/common-lisp :uiop :asdf/upgrade)
     7002  (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
     7003           #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
     7004           #:do-asdf-cache #:normalize-namestring
     7005           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
     7006           #:clear-configuration-and-retry #:retry))
     7007(in-package :asdf/cache)
     7008
     7009;;; This stamp cache is useful for:
     7010;; * consistency of stamps used within a single run
     7011;; * fewer accesses to the filesystem
     7012;; * the ability to test with fake timestamps, without touching files
     7013
     7014(with-upgradability ()
     7015  (defvar *asdf-cache* nil)
     7016
     7017  (defun set-asdf-cache-entry (key value-list)
     7018    (apply 'values
     7019           (if *asdf-cache*
     7020               (setf (gethash key *asdf-cache*) value-list)
     7021               value-list)))
     7022
     7023  (defun unset-asdf-cache-entry (key)
     7024    (when *asdf-cache*
     7025      (remhash key *asdf-cache*)))
     7026
     7027  (defun consult-asdf-cache (key &optional thunk)
     7028    (if *asdf-cache*
     7029        (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
     7030          (if foundp
     7031              (apply 'values results)
     7032              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
     7033        (call-function thunk)))
     7034
     7035  (defmacro do-asdf-cache (key &body body)
     7036    `(consult-asdf-cache ,key #'(lambda () ,@body)))
     7037
     7038  (defun call-with-asdf-cache (thunk &key override key)
     7039    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
     7040      (if (and *asdf-cache* (not override))
     7041          (funcall fun)
     7042          (loop
     7043            (restart-case
     7044                (let ((*asdf-cache* (make-hash-table :test 'equal)))
     7045                  (return (funcall fun)))
     7046              (retry ()
     7047                :report (lambda (s)
     7048                          (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
     7049              (clear-configuration-and-retry ()
     7050                :report (lambda (s)
     7051                          (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
     7052                (clear-configuration)))))))
     7053
     7054  (defmacro with-asdf-cache ((&key key override) &body body)
     7055    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
     7056
     7057  (defun normalize-namestring (pathname)
     7058    (let ((resolved (resolve-symlinks*
     7059                     (ensure-absolute-pathname
     7060                      (physicalize-pathname pathname)
     7061                      'get-pathname-defaults))))
     7062      (with-pathname-defaults () (namestring resolved))))
     7063
     7064  (defun compute-file-stamp (normalized-namestring)
     7065    (with-pathname-defaults ()
     7066      (safe-file-write-date normalized-namestring)))
     7067
     7068  (defun register-file-stamp (file &optional (stamp nil stampp))
     7069    (let* ((namestring (normalize-namestring file))
     7070           (stamp (if stampp stamp (compute-file-stamp namestring))))
     7071      (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
     7072
     7073  (defun get-file-stamp (file)
     7074    (when file
     7075      (let ((namestring (normalize-namestring file)))
     7076        (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
    67447077
    67457078;;;; -------------------------------------------------------------------------
     
    69757308  (defmethod component-relative-pathname ((component component))
    69767309    ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
    6977     ;; We ought to be able to extract this from the component alone with COMPONENT-TYPE.
    6978     ;; TODO: track who uses it, and have them not use it anymore;
     7310    ;; We ought to be able to extract this from the component alone with FILE-TYPE.
     7311    ;; TODO: track who uses it in Quicklisp, and have them not use it anymore;
    69797312    ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
    69807313    (parse-unix-namestring
     
    71587491
    71597492;;;; -------------------------------------------------------------------------
    7160 ;;;; Stamp cache
    7161 
    7162 (uiop/package:define-package :asdf/cache
    7163   (:use :uiop/common-lisp :uiop :asdf/upgrade)
    7164   (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
    7165            #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
    7166            #:do-asdf-cache #:normalize-namestring
    7167            #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
    7168            #:clear-configuration-and-retry #:retry))
    7169 (in-package :asdf/cache)
    7170 
    7171 ;;; This stamp cache is useful for:
    7172 ;; * consistency of stamps used within a single run
    7173 ;; * fewer accesses to the filesystem
    7174 ;; * the ability to test with fake timestamps, without touching files
    7175 
    7176 (with-upgradability ()
    7177   (defvar *asdf-cache* nil)
    7178 
    7179   (defun set-asdf-cache-entry (key value-list)
    7180     (apply 'values
    7181            (if *asdf-cache*
    7182                (setf (gethash key *asdf-cache*) value-list)
    7183                value-list)))
    7184 
    7185   (defun unset-asdf-cache-entry (key)
    7186     (when *asdf-cache*
    7187       (remhash key *asdf-cache*)))
    7188 
    7189   (defun consult-asdf-cache (key &optional thunk)
    7190     (if *asdf-cache*
    7191         (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
    7192           (if foundp
    7193               (apply 'values results)
    7194               (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
    7195         (call-function thunk)))
    7196 
    7197   (defmacro do-asdf-cache (key &body body)
    7198     `(consult-asdf-cache ,key #'(lambda () ,@body)))
    7199 
    7200   (defun call-with-asdf-cache (thunk &key override key)
    7201     (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
    7202       (if (and *asdf-cache* (not override))
    7203           (funcall fun)
    7204           (loop
    7205             (restart-case
    7206                 (let ((*asdf-cache* (make-hash-table :test 'equal)))
    7207                   (return (funcall fun)))
    7208               (retry ()
    7209                 :report (lambda (s)
    7210                           (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
    7211               (clear-configuration-and-retry ()
    7212                 :report (lambda (s)
    7213                           (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
    7214                 (clear-configuration)))))))
    7215 
    7216   (defmacro with-asdf-cache ((&key key override) &body body)
    7217     `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
    7218 
    7219   (defun normalize-namestring (pathname)
    7220     (let ((resolved (resolve-symlinks*
    7221                      (ensure-absolute-pathname
    7222                       (physicalize-pathname pathname)
    7223                       'get-pathname-defaults))))
    7224       (with-pathname-defaults () (namestring resolved))))
    7225 
    7226   (defun compute-file-stamp (normalized-namestring)
    7227     (with-pathname-defaults ()
    7228       (safe-file-write-date normalized-namestring)))
    7229 
    7230   (defun register-file-stamp (file &optional (stamp nil stampp))
    7231     (let* ((namestring (normalize-namestring file))
    7232            (stamp (if stampp stamp (compute-file-stamp namestring))))
    7233       (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
    7234 
    7235   (defun get-file-stamp (file)
    7236     (when file
    7237       (let ((namestring (normalize-namestring file)))
    7238         (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
    7239 
    7240 ;;;; -------------------------------------------------------------------------
    72417493;;;; Finding systems
    72427494
     
    72587510   #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
    72597511   #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
    7260    #:clear-defined-system #:clear-defined-systems #:*defined-systems*
    7261    #:*immutable-systems*
     7512   #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems*
     7513   #:*defined-systems* #:clear-defined-systems
    72627514   ;; defined in source-registry, but specially mentioned here:
    72637515   #:initialize-source-registry #:sysdef-source-registry-search))
     
    73297581                    system)))))
    73307582
    7331   (defun clear-defined-system (system)
     7583  (defvar *preloaded-systems* (make-hash-table :test 'equal))
     7584
     7585  (defun make-preloaded-system (name keys)
     7586    (apply 'make-instance (getf keys :class 'system)
     7587           :name name :source-file (getf keys :source-file)
     7588           (remove-plist-keys '(:class :name :source-file) keys)))
     7589
     7590  (defun sysdef-preloaded-system-search (requested)
     7591    (let ((name (coerce-name requested)))
     7592      (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
     7593        (when foundp
     7594          (make-preloaded-system name keys)))))
     7595
     7596  (defun register-preloaded-system (system-name &rest keys)
     7597    (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
     7598
     7599  (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
     7600    ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
     7601    (register-preloaded-system s :version *asdf-version*))
     7602
     7603  (defvar *immutable-systems* nil
     7604    "An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
     7605i.e. already loaded in memory and not to be refreshed from the filesystem.
     7606They will be treated specially by find-system, and passed as :force-not argument to make-plan.
     7607
     7608If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
     7609for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
     7610downgrade, before you dump an image, use:
     7611   (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
     7612
     7613  (defun sysdef-immutable-system-search (requested)
     7614    (let ((name (coerce-name requested)))
     7615      (when (and *immutable-systems* (gethash name *immutable-systems*))
     7616        (or (cdr (system-registered-p requested))
     7617            (sysdef-preloaded-system-search name)
     7618            (error 'formatted-system-definition-error
     7619                   :format-control "Requested system ~A is in the *immutable-systems* set, ~
     7620but not loaded in memory"
     7621                   :format-arguments (list name))))))
     7622
     7623  (defun register-immutable-system (system-name &key (version t))
     7624    (let* ((system-name (coerce-name system-name))
     7625           (registered-system (cdr (system-registered-p system-name)))
     7626           (default-version? (eql version t))
     7627           (version (cond ((and default-version? registered-system)
     7628                           (component-version registered-system))
     7629                          (default-version? nil)
     7630                          (t version))))
     7631      (unless registered-system
     7632        (register-system (make-preloaded-system system-name (list :version version))))
     7633      (register-preloaded-system system-name :version version)
     7634      (unless *immutable-systems*
     7635        (setf *immutable-systems* (list-to-hash-set nil)))
     7636      (setf (gethash (coerce-name system-name) *immutable-systems*) t)))
     7637
     7638  (defun clear-system (system)
     7639    "Clear the entry for a SYSTEM in the database of systems previously loaded,
     7640unless the system appears in the table of *IMMUTABLE-SYSTEMS*.
     7641Note that this does NOT in any way cause the code of the system to be unloaded.
     7642Returns T if cleared or already cleared,
     7643NIL if not cleared because the system was found to be immutable."
     7644    ;; There is no "unload" operation in Common Lisp, and
     7645    ;; a general such operation cannot be portably written,
     7646    ;; considering how much CL relies on side-effects to global data structures.
    73327647    (let ((name (coerce-name system)))
    7333       (remhash name *defined-systems*)
    7334       (unset-asdf-cache-entry `(locate-system ,name))
    7335       (unset-asdf-cache-entry `(find-system ,name))
    7336       nil))
     7648      (unless (and *immutable-systems* (gethash name *immutable-systems*))
     7649        (remhash (coerce-name name) *defined-systems*)
     7650        (unset-asdf-cache-entry `(locate-system ,name))
     7651        (unset-asdf-cache-entry `(find-system ,name))
     7652        t)))
    73377653
    73387654  (defun clear-defined-systems ()
    73397655    ;; Invalidate all systems but ASDF itself, if registered.
    73407656    (loop :for name :being :the :hash-keys :of *defined-systems*
    7341           :unless (equal name "asdf")
    7342             :do (clear-defined-system name)))
     7657          :unless (equal name "asdf") :do (clear-system name)))
    73437658
    73447659  (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
    7345 
    7346   (defun clear-system (name)
    7347     "Clear the entry for a system in the database of systems previously loaded.
    7348 Note that this does NOT in any way cause the code of the system to be unloaded."
    7349     ;; There is no "unload" operation in Common Lisp, and
    7350     ;; a general such operation cannot be portably written,
    7351     ;; considering how much CL relies on side-effects to global data structures.
    7352     (remhash (coerce-name name) *defined-systems*))
    73537660
    73547661  (defun map-systems (fn)
     
    74147721          (return file))
    74157722        #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
    7416         (when (and (os-windows-p) (physical-pathname-p defaults))
    7417           (let ((shortcut
    7418                   (make-pathname
    7419                    :defaults defaults :case :local
    7420                    :name (strcat name ".asd")
    7421                    :type "lnk")))
    7422             (when (probe-file* shortcut)
    7423               (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))
     7723        (os-cond
     7724         ((os-windows-p)
     7725          (when (physical-pathname-p defaults)
     7726            (let ((shortcut
     7727                    (make-pathname
     7728                     :defaults defaults :case :local
     7729                     :name (strcat name ".asd")
     7730                     :type "lnk")))
     7731              (when (probe-file* shortcut)
     7732                (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))))
    74247733
    74257734  (defun sysdef-central-registry-search (system)
     
    74707779                            (subseq *central-registry* (1+ position))))))))))
    74717780
    7472   (defvar *preloaded-systems* (make-hash-table :test 'equal))
    7473 
    7474   (defun make-preloaded-system (name keys)
    7475     (apply 'make-instance (getf keys :class 'system)
    7476            :name name :source-file (getf keys :source-file)
    7477            (remove-plist-keys '(:class :name :source-file) keys)))
    7478 
    7479   (defun sysdef-preloaded-system-search (requested)
    7480     (let ((name (coerce-name requested)))
    7481       (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
    7482         (when foundp
    7483           (make-preloaded-system name keys)))))
    7484 
    7485   (defun register-preloaded-system (system-name &rest keys)
    7486     (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
    7487 
    7488   (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
    7489     ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
    7490     (register-preloaded-system s :version *asdf-version*))
    7491 
    74927781  (defmethod find-system ((name null) &optional (error-p t))
    74937782    (when error-p
     
    75017790    (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
    75027791
    7503   (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
     7792  (defun load-asd (pathname
     7793                   &key name (external-format (encoding-external-format (detect-encoding pathname)))
     7794                   &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
    75047795    ;; Tries to load system definition with canonical NAME from PATHNAME.
    75057796    (with-asdf-cache ()
     
    75697860             nil))))) ;; only issue the warning the first time, but always return nil
    75707861
    7571   (defvar *immutable-systems* nil
    7572     "An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
    7573 i.e. already loaded in memory and not to be refreshed from the filesystem.
    7574 They will be treated specially by find-system, and passed as :force-not argument to make-plan.
    7575 
    7576 If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
    7577 for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
    7578 downgrade, before you dump an image, use:
    7579    (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
    7580 
    7581   (defun sysdef-immutable-system-search (requested)
    7582     (let ((name (coerce-name requested)))
    7583       (when (and *immutable-systems* (gethash name *immutable-systems*))
    7584         (or (cdr (system-registered-p requested))
    7585             (error 'formatted-system-definition-error
    7586                    :format-control "Requested system ~A is in the *immutable-systems* set, ~
    7587 but not loaded in memory"
    7588                    :format-arguments (list name))))))
    7589 
    75907862  (defun locate-system (name)
    75917863    "Given a system NAME designator, try to locate where to load the system from.
     
    76277899          (find-system primary-name nil)))
    76287900      (or (and *immutable-systems* (gethash name *immutable-systems*)
    7629                (cdr (system-registered-p name)))
     7901               (or (cdr (system-registered-p name))
     7902                   (sysdef-preloaded-system-search name)))
    76307903          (multiple-value-bind (foundp found-system pathname previous previous-time)
    76317904              (locate-system name)
     
    83438616              (output-file
    83448617               &optional
     8618                 #+(or clasp ecl mkcl) object-file
    83458619                 #+clisp lib-file
    8346                  #+(or ecl mkcl) object-file
    83478620                 warnings-file) outputs
    83488621            (call-with-around-compile-hook
     
    83548627                          (append
    83558628                           #+clisp (list :lib-file lib-file)
    8356                            #+(or ecl mkcl) (list :object-file object-file)
     8629                           #+(or clasp ecl mkcl) (list :object-file object-file)
    83578630                           flags (compile-op-flags o))))))
    83588631        (check-lisp-compile-results output warnings-p failure-p
     
    83798652    (let* ((i (first (input-files o c)))
    83808653           (f (compile-file-pathname
    8381                i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
     8654               i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl
     8655               #+mkcl :fasl-p #+mkcl t)))
    83828656      `(,f ;; the fasl is the primary output, in first position
     8657        #+clasp
     8658        ,@(unless nil ;; was (use-ecl-byte-compiler-p)
     8659            `(,(compile-file-pathname i :output-type :object)))
    83838660        #+clisp
    83848661        ,@`(,(make-pathname :type "lib" :defaults f))
     
    90189295               (operation (let ((name (type-of operation))
    90199296                                (initargs (operation-original-initargs operation)))
    9020                             #'(lambda () (make-operation name :original-initargs initargs initargs))))
     9297                            #'(lambda () (apply 'make-operation name :original-initargs initargs initargs))))
    90219298               ((or symbol string) (constantly operation))))
    90229299           (component-path (typecase component ;; to remake the component after ASDF upgrade
     
    91209397    t))
    91219398
    9122 
    9123 ;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
     9399;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE,
     9400;; only tries to load its specified target if it's not loaded yet.
     9401(with-upgradability ()
     9402  (defun component-loaded-p (component)
     9403    "has given COMPONENT been successfully loaded in the current image (yet)?"
     9404    (action-already-done-p nil (make-instance 'load-op) (find-component component ())))
     9405
     9406  (defun already-loaded-systems ()
     9407    "return a list of the names of the systems that have been successfully loaded so far"
     9408    (remove-if-not 'component-loaded-p (registered-systems)))
     9409
     9410  (defun require-system (system &rest keys &key &allow-other-keys)
     9411    "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but skip any update to the
     9412system or its dependencies if they have already been loaded."
     9413    (apply 'load-system system :force-not (already-loaded-systems) keys)))
     9414
     9415
     9416;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
    91249417;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
    91259418(with-upgradability ()
    9126   (defun component-loaded-p (c)
    9127     (action-already-done-p nil (make-instance 'load-op) (find-component c ())))
    9128 
    9129   (defun already-loaded-systems ()
    9130     (remove-if-not 'component-loaded-p (registered-systems)))
    9131 
    9132   (defun require-system (s &rest keys &key &allow-other-keys)
    9133     (apply 'load-system s :force-not (already-loaded-systems) keys))
    9134 
    91359419  (defvar *modules-being-required* nil)
    91369420
     
    91949478
    91959479
    9196 ;;;; ---------------------------------------------------------------------------
    9197 ;;;; asdf-output-translations
    9198 
    9199 (uiop/package:define-package :asdf/output-translations
    9200   (:recycle :asdf/output-translations :asdf)
    9201   (:use :uiop/common-lisp :uiop :asdf/upgrade)
    9202   (:export
    9203    #:*output-translations* #:*output-translations-parameter*
    9204    #:invalid-output-translation
    9205    #:output-translations #:output-translations-initialized-p
    9206    #:initialize-output-translations #:clear-output-translations
    9207    #:disable-output-translations #:ensure-output-translations
    9208    #:apply-output-translations
    9209    #:validate-output-translations-directive #:validate-output-translations-form
    9210    #:validate-output-translations-file #:validate-output-translations-directory
    9211    #:parse-output-translations-string #:wrapping-output-translations
    9212    #:user-output-translations-pathname #:system-output-translations-pathname
    9213    #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
    9214    #:environment-output-translations #:process-output-translations
    9215    #:compute-output-translations
    9216    #+abcl #:translate-jar-pathname
    9217    ))
    9218 (in-package :asdf/output-translations)
    9219 
    9220 (when-upgrading () (undefine-function '(setf output-translations)))
    9221 
    9222 (with-upgradability ()
    9223   (define-condition invalid-output-translation (invalid-configuration warning)
    9224     ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    9225 
    9226   (defvar *output-translations* ()
    9227     "Either NIL (for uninitialized), or a list of one element,
    9228 said element itself being a sorted list of mappings.
    9229 Each mapping is a pair of a source pathname and destination pathname,
    9230 and the order is by decreasing length of namestring of the source pathname.")
    9231 
    9232   (defun output-translations ()
    9233     (car *output-translations*))
    9234 
    9235   (defun set-output-translations (new-value)
    9236     (setf *output-translations*
    9237           (list
    9238            (stable-sort (copy-list new-value) #'>
    9239                         :key #'(lambda (x)
    9240                                  (etypecase (car x)
    9241                                    ((eql t) -1)
    9242                                    (pathname
    9243                                     (let ((directory (pathname-directory (car x))))
    9244                                       (if (listp directory) (length directory) 0))))))))
    9245     new-value)
    9246   (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
    9247 
    9248   (defun output-translations-initialized-p ()
    9249     (and *output-translations* t))
    9250 
    9251   (defun clear-output-translations ()
    9252     "Undoes any initialization of the output translations."
    9253     (setf *output-translations* '())
    9254     (values))
    9255   (register-clear-configuration-hook 'clear-output-translations)
    9256 
    9257   (defun validate-output-translations-directive (directive)
    9258     (or (member directive '(:enable-user-cache :disable-cache nil))
    9259         (and (consp directive)
    9260              (or (and (length=n-p directive 2)
    9261                       (or (and (eq (first directive) :include)
    9262                                (typep (second directive) '(or string pathname null)))
    9263                           (and (location-designator-p (first directive))
    9264                                (or (location-designator-p (second directive))
    9265                                    (location-function-p (second directive))))))
    9266                  (and (length=n-p directive 1)
    9267                       (location-designator-p (first directive)))))))
    9268 
    9269   (defun validate-output-translations-form (form &key location)
    9270     (validate-configuration-form
    9271      form
    9272      :output-translations
    9273      'validate-output-translations-directive
    9274      :location location :invalid-form-reporter 'invalid-output-translation))
    9275 
    9276   (defun validate-output-translations-file (file)
    9277     (validate-configuration-file
    9278      file 'validate-output-translations-form :description "output translations"))
    9279 
    9280   (defun validate-output-translations-directory (directory)
    9281     (validate-configuration-directory
    9282      directory :output-translations 'validate-output-translations-directive
    9283                :invalid-form-reporter 'invalid-output-translation))
    9284 
    9285   (defun parse-output-translations-string (string &key location)
    9286     (cond
    9287       ((or (null string) (equal string ""))
    9288        '(:output-translations :inherit-configuration))
    9289       ((not (stringp string))
    9290        (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
    9291       ((eql (char string 0) #\")
    9292        (parse-output-translations-string (read-from-string string) :location location))
    9293       ((eql (char string 0) #\()
    9294        (validate-output-translations-form (read-from-string string) :location location))
    9295       (t
    9296        (loop
    9297          :with inherit = nil
    9298          :with directives = ()
    9299          :with start = 0
    9300          :with end = (length string)
    9301          :with source = nil
    9302          :with separator = (inter-directory-separator)
    9303          :for i = (or (position separator string :start start) end) :do
    9304            (let ((s (subseq string start i)))
    9305              (cond
    9306                (source
    9307                 (push (list source (if (equal "" s) nil s)) directives)
    9308                 (setf source nil))
    9309                ((equal "" s)
    9310                 (when inherit
    9311                   (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    9312                          string))
    9313                 (setf inherit t)
    9314                 (push :inherit-configuration directives))
    9315                (t
    9316                 (setf source s)))
    9317              (setf start (1+ i))
    9318              (when (> start end)
    9319                (when source
    9320                  (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
    9321                         string))
    9322                (unless inherit
    9323                  (push :ignore-inherited-configuration directives))
    9324                (return `(:output-translations ,@(nreverse directives)))))))))
    9325 
    9326   (defparameter* *default-output-translations*
    9327     '(environment-output-translations
    9328       user-output-translations-pathname
    9329       user-output-translations-directory-pathname
    9330       system-output-translations-pathname
    9331       system-output-translations-directory-pathname))
    9332 
    9333   (defun wrapping-output-translations ()
    9334     `(:output-translations
    9335     ;; Some implementations have precompiled ASDF systems,
    9336     ;; so we must disable translations for implementation paths.
    9337       #+(or #|clozure|# ecl mkcl sbcl)
    9338       ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
    9339           (when h `(((,h ,*wild-path*) ()))))
    9340       #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
    9341       ;; All-import, here is where we want user stuff to be:
    9342       :inherit-configuration
    9343       ;; These are for convenience, and can be overridden by the user:
    9344       #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
    9345       #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    9346       ;; We enable the user cache by default, and here is the place we do:
    9347       :enable-user-cache))
    9348 
    9349   (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
    9350   (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
    9351 
    9352   (defun user-output-translations-pathname (&key (direction :input))
    9353     (in-user-configuration-directory *output-translations-file* :direction direction))
    9354   (defun system-output-translations-pathname (&key (direction :input))
    9355     (in-system-configuration-directory *output-translations-file* :direction direction))
    9356   (defun user-output-translations-directory-pathname (&key (direction :input))
    9357     (in-user-configuration-directory *output-translations-directory* :direction direction))
    9358   (defun system-output-translations-directory-pathname (&key (direction :input))
    9359     (in-system-configuration-directory *output-translations-directory* :direction direction))
    9360   (defun environment-output-translations ()
    9361     (getenv "ASDF_OUTPUT_TRANSLATIONS"))
    9362 
    9363   (defgeneric process-output-translations (spec &key inherit collect))
    9364 
    9365   (defun inherit-output-translations (inherit &key collect)
    9366     (when inherit
    9367       (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
    9368 
    9369   (defun* (process-output-translations-directive) (directive &key inherit collect)
    9370     (if (atom directive)
    9371         (ecase directive
    9372           ((:enable-user-cache)
    9373            (process-output-translations-directive '(t :user-cache) :collect collect))
    9374           ((:disable-cache)
    9375            (process-output-translations-directive '(t t) :collect collect))
    9376           ((:inherit-configuration)
    9377            (inherit-output-translations inherit :collect collect))
    9378           ((:ignore-inherited-configuration :ignore-invalid-entries nil)
    9379            nil))
    9380         (let ((src (first directive))
    9381               (dst (second directive)))
    9382           (if (eq src :include)
    9383               (when dst
    9384                 (process-output-translations (pathname dst) :inherit nil :collect collect))
    9385               (when src
    9386                 (let ((trusrc (or (eql src t)
    9387                                   (let ((loc (resolve-location src :ensure-directory t :wilden t)))
    9388                                     (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
    9389                   (cond
    9390                     ((location-function-p dst)
    9391                      (funcall collect
    9392                               (list trusrc (ensure-function (second dst)))))
    9393                     ((eq dst t)
    9394                      (funcall collect (list trusrc t)))
    9395                     (t
    9396                      (let* ((trudst (if dst
    9397                                         (resolve-location dst :ensure-directory t :wilden t)
    9398                                         trusrc)))
    9399                        (funcall collect (list trudst t))
    9400                        (funcall collect (list trusrc trudst)))))))))))
    9401 
    9402   (defmethod process-output-translations ((x symbol) &key
    9403                                                        (inherit *default-output-translations*)
    9404                                                        collect)
    9405     (process-output-translations (funcall x) :inherit inherit :collect collect))
    9406   (defmethod process-output-translations ((pathname pathname) &key inherit collect)
    9407     (cond
    9408       ((directory-pathname-p pathname)
    9409        (process-output-translations (validate-output-translations-directory pathname)
    9410                                     :inherit inherit :collect collect))
    9411       ((probe-file* pathname :truename *resolve-symlinks*)
    9412        (process-output-translations (validate-output-translations-file pathname)
    9413                                     :inherit inherit :collect collect))
    9414       (t
    9415        (inherit-output-translations inherit :collect collect))))
    9416   (defmethod process-output-translations ((string string) &key inherit collect)
    9417     (process-output-translations (parse-output-translations-string string)
    9418                                  :inherit inherit :collect collect))
    9419   (defmethod process-output-translations ((x null) &key inherit collect)
    9420     (inherit-output-translations inherit :collect collect))
    9421   (defmethod process-output-translations ((form cons) &key inherit collect)
    9422     (dolist (directive (cdr (validate-output-translations-form form)))
    9423       (process-output-translations-directive directive :inherit inherit :collect collect)))
    9424 
    9425   (defun compute-output-translations (&optional parameter)
    9426     "read the configuration, return it"
    9427     (remove-duplicates
    9428      (while-collecting (c)
    9429        (inherit-output-translations
    9430         `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
    9431      :test 'equal :from-end t))
    9432 
    9433   (defvar *output-translations-parameter* nil)
    9434 
    9435   (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
    9436     "read the configuration, initialize the internal configuration variable,
    9437 return the configuration"
    9438     (setf *output-translations-parameter* parameter
    9439           (output-translations) (compute-output-translations parameter)))
    9440 
    9441   (defun disable-output-translations ()
    9442     "Initialize output translations in a way that maps every file to itself,
    9443 effectively disabling the output translation facility."
    9444     (initialize-output-translations
    9445      '(:output-translations :disable-cache :ignore-inherited-configuration)))
    9446 
    9447   ;; checks an initial variable to see whether the state is initialized
    9448   ;; or cleared. In the former case, return current configuration; in
    9449   ;; the latter, initialize.  ASDF will call this function at the start
    9450   ;; of (asdf:find-system).
    9451   (defun ensure-output-translations ()
    9452     (if (output-translations-initialized-p)
    9453         (output-translations)
    9454         (initialize-output-translations)))
    9455 
    9456   (defun* (apply-output-translations) (path)
    9457     (etypecase path
    9458       (logical-pathname
    9459        path)
    9460       ((or pathname string)
    9461        (ensure-output-translations)
    9462        (loop* :with p = (resolve-symlinks* path)
    9463               :for (source destination) :in (car *output-translations*)
    9464               :for root = (when (or (eq source t)
    9465                                     (and (pathnamep source)
    9466                                          (not (absolute-pathname-p source))))
    9467                             (pathname-root p))
    9468               :for absolute-source = (cond
    9469                                        ((eq source t) (wilden root))
    9470                                        (root (merge-pathnames* source root))
    9471                                        (t source))
    9472               :when (or (eq source t) (pathname-match-p p absolute-source))
    9473               :return (translate-pathname* p absolute-source destination root source)
    9474               :finally (return p)))))
    9475 
    9476   ;; Hook into uiop's output-translation mechanism
    9477   #-cormanlisp
    9478   (setf *output-translation-function* 'apply-output-translations)
    9479 
    9480   #+abcl
    9481   (defun translate-jar-pathname (source wildcard)
    9482     (declare (ignore wildcard))
    9483     (flet ((normalize-device (pathname)
    9484              (if (find :windows *features*)
    9485                  pathname
    9486                  (make-pathname :defaults pathname :device :unspecific))))
    9487       (let* ((jar
    9488                (pathname (first (pathname-device source))))
    9489              (target-root-directory-namestring
    9490                (format nil "/___jar___file___root___/~@[~A/~]"
    9491                        (and (find :windows *features*)
    9492                             (pathname-device jar))))
    9493              (relative-source
    9494                (relativize-pathname-directory source))
    9495              (relative-jar
    9496                (relativize-pathname-directory (ensure-directory-pathname jar)))
    9497              (target-root-directory
    9498                (normalize-device
    9499                 (pathname-directory-pathname
    9500                  (parse-namestring target-root-directory-namestring))))
    9501              (target-root
    9502                (merge-pathnames* relative-jar target-root-directory))
    9503              (target
    9504                (merge-pathnames* relative-source target-root)))
    9505         (normalize-device (apply-output-translations target))))))
    9506 
    9507 ;;;; -----------------------------------------------------------------
    9508 ;;;; Source Registry Configuration, by Francois-Rene Rideau
    9509 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
    9510 
    9511 (uiop/package:define-package :asdf/source-registry
    9512   (:recycle :asdf/source-registry :asdf)
    9513   (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
    9514   (:export
    9515    #:*source-registry-parameter* #:*default-source-registries*
    9516    #:invalid-source-registry
    9517    #:source-registry-initialized-p
    9518    #:initialize-source-registry #:clear-source-registry #:*source-registry*
    9519    #:ensure-source-registry #:*source-registry-parameter*
    9520    #:*default-source-registry-exclusions* #:*source-registry-exclusions*
    9521    #:*wild-asd* #:directory-asd-files #:register-asd-directory
    9522    #:collect-asds-in-directory #:collect-sub*directories-asd-files
    9523    #:validate-source-registry-directive #:validate-source-registry-form
    9524    #:validate-source-registry-file #:validate-source-registry-directory
    9525    #:parse-source-registry-string #:wrapping-source-registry
    9526    #:default-user-source-registry #:default-system-source-registry
    9527    #:user-source-registry #:system-source-registry
    9528    #:user-source-registry-directory #:system-source-registry-directory
    9529    #:environment-source-registry #:process-source-registry
    9530    #:compute-source-registry #:flatten-source-registry
    9531    #:sysdef-source-registry-search))
    9532 (in-package :asdf/source-registry)
    9533 
    9534 (with-upgradability ()
    9535   (define-condition invalid-source-registry (invalid-configuration warning)
    9536     ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    9537 
    9538   ;; Using ack 1.2 exclusions
    9539   (defvar *default-source-registry-exclusions*
    9540     '(".bzr" ".cdv"
    9541       ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
    9542       ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    9543       "_sgbak" "autom4te.cache" "cover_db" "_build"
    9544       "debian")) ;; debian often builds stuff under the debian directory... BAD.
    9545 
    9546   (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    9547 
    9548   (defvar *source-registry* nil
    9549     "Either NIL (for uninitialized), or an equal hash-table, mapping
    9550 system names to pathnames of .asd files")
    9551 
    9552   (defun source-registry-initialized-p ()
    9553     (typep *source-registry* 'hash-table))
    9554 
    9555   (defun clear-source-registry ()
    9556     "Undoes any initialization of the source registry."
    9557     (setf *source-registry* nil)
    9558     (values))
    9559   (register-clear-configuration-hook 'clear-source-registry)
    9560 
    9561   (defparameter *wild-asd*
    9562     (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
    9563 
    9564   (defun directory-asd-files (directory)
    9565     (directory-files directory *wild-asd*))
    9566 
    9567   (defun collect-asds-in-directory (directory collect)
    9568     (map () collect (directory-asd-files directory)))
    9569 
    9570   (defun collect-sub*directories-asd-files
    9571       (directory &key (exclude *default-source-registry-exclusions*) collect)
    9572     (collect-sub*directories
    9573      directory
    9574      (constantly t)
    9575      #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
    9576      #'(lambda (dir) (collect-asds-in-directory dir collect))))
    9577 
    9578   (defun validate-source-registry-directive (directive)
    9579     (or (member directive '(:default-registry))
    9580         (and (consp directive)
    9581              (let ((rest (rest directive)))
    9582                (case (first directive)
    9583                  ((:include :directory :tree)
    9584                   (and (length=n-p rest 1)
    9585                        (location-designator-p (first rest))))
    9586                  ((:exclude :also-exclude)
    9587                   (every #'stringp rest))
    9588                  ((:default-registry)
    9589                   (null rest)))))))
    9590 
    9591   (defun validate-source-registry-form (form &key location)
    9592     (validate-configuration-form
    9593      form :source-registry 'validate-source-registry-directive
    9594           :location location :invalid-form-reporter 'invalid-source-registry))
    9595 
    9596   (defun validate-source-registry-file (file)
    9597     (validate-configuration-file
    9598      file 'validate-source-registry-form :description "a source registry"))
    9599 
    9600   (defun validate-source-registry-directory (directory)
    9601     (validate-configuration-directory
    9602      directory :source-registry 'validate-source-registry-directive
    9603                :invalid-form-reporter 'invalid-source-registry))
    9604 
    9605   (defun parse-source-registry-string (string &key location)
    9606     (cond
    9607       ((or (null string) (equal string ""))
    9608        '(:source-registry :inherit-configuration))
    9609       ((not (stringp string))
    9610        (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
    9611       ((find (char string 0) "\"(")
    9612        (validate-source-registry-form (read-from-string string) :location location))
    9613       (t
    9614        (loop
    9615          :with inherit = nil
    9616          :with directives = ()
    9617          :with start = 0
    9618          :with end = (length string)
    9619          :with separator = (inter-directory-separator)
    9620          :for pos = (position separator string :start start) :do
    9621            (let ((s (subseq string start (or pos end))))
    9622              (flet ((check (dir)
    9623                       (unless (absolute-pathname-p dir)
    9624                         (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
    9625                       dir))
    9626                (cond
    9627                  ((equal "" s) ; empty element: inherit
    9628                   (when inherit
    9629                     (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    9630                            string))
    9631                   (setf inherit t)
    9632                   (push ':inherit-configuration directives))
    9633                  ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
    9634                   (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
    9635                  (t
    9636                   (push `(:directory ,(check s)) directives))))
    9637              (cond
    9638                (pos
    9639                 (setf start (1+ pos)))
    9640                (t
    9641                 (unless inherit
    9642                   (push '(:ignore-inherited-configuration) directives))
    9643                 (return `(:source-registry ,@(nreverse directives))))))))))
    9644 
    9645   (defun register-asd-directory (directory &key recurse exclude collect)
    9646     (if (not recurse)
    9647         (collect-asds-in-directory directory collect)
    9648         (collect-sub*directories-asd-files
    9649          directory :exclude exclude :collect collect)))
    9650 
    9651   (defparameter* *default-source-registries*
    9652     '(environment-source-registry
    9653       user-source-registry
    9654       user-source-registry-directory
    9655       default-user-source-registry
    9656       system-source-registry
    9657       system-source-registry-directory
    9658       default-system-source-registry)
    9659     "List of default source registries" "3.1.0.102")
    9660 
    9661   (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
    9662   (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
    9663 
    9664   (defun wrapping-source-registry ()
    9665     `(:source-registry
    9666       #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
    9667       :inherit-configuration
    9668       #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
    9669       #+cmu (:tree #p"modules:")
    9670       #+scl (:tree #p"file://modules/")))
    9671   (defun default-user-source-registry ()
    9672     `(:source-registry
    9673       (:tree (:home "common-lisp/"))
    9674       #+sbcl (:directory (:home ".sbcl/systems/"))
    9675       ,@(loop :for dir :in
    9676               `(,@(when (os-unix-p)
    9677                     `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
    9678                            (subpathname (user-homedir-pathname) ".local/share/"))))
    9679                 ,@(when (os-windows-p)
    9680                     (mapcar 'get-folder-path '(:local-appdata :appdata))))
    9681               :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
    9682               :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
    9683       :inherit-configuration))
    9684   (defun default-system-source-registry ()
    9685     `(:source-registry
    9686       ,@(loop :for dir :in
    9687               `(,@(when (os-unix-p)
    9688                     (or (getenv-absolute-directories "XDG_DATA_DIRS")
    9689                         '("/usr/local/share" "/usr/share")))
    9690                 ,@(when (os-windows-p)
    9691                     (list (get-folder-path :common-appdata))))
    9692               :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
    9693               :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
    9694       :inherit-configuration))
    9695   (defun user-source-registry (&key (direction :input))
    9696     (in-user-configuration-directory *source-registry-file* :direction direction))
    9697   (defun system-source-registry (&key (direction :input))
    9698     (in-system-configuration-directory *source-registry-file* :direction direction))
    9699   (defun user-source-registry-directory (&key (direction :input))
    9700     (in-user-configuration-directory *source-registry-directory* :direction direction))
    9701   (defun system-source-registry-directory (&key (direction :input))
    9702     (in-system-configuration-directory *source-registry-directory* :direction direction))
    9703   (defun environment-source-registry ()
    9704     (getenv "CL_SOURCE_REGISTRY"))
    9705 
    9706   (defgeneric* (process-source-registry) (spec &key inherit register))
    9707 
    9708   (defun* (inherit-source-registry) (inherit &key register)
    9709     (when inherit
    9710       (process-source-registry (first inherit) :register register :inherit (rest inherit))))
    9711 
    9712   (defun* (process-source-registry-directive) (directive &key inherit register)
    9713     (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
    9714       (ecase kw
    9715         ((:include)
    9716          (destructuring-bind (pathname) rest
    9717            (process-source-registry (resolve-location pathname) :inherit nil :register register)))
    9718         ((:directory)
    9719          (destructuring-bind (pathname) rest
    9720            (when pathname
    9721              (funcall register (resolve-location pathname :ensure-directory t)))))
    9722         ((:tree)
    9723          (destructuring-bind (pathname) rest
    9724            (when pathname
    9725              (funcall register (resolve-location pathname :ensure-directory t)
    9726                       :recurse t :exclude *source-registry-exclusions*))))
    9727         ((:exclude)
    9728          (setf *source-registry-exclusions* rest))
    9729         ((:also-exclude)
    9730          (appendf *source-registry-exclusions* rest))
    9731         ((:default-registry)
    9732          (inherit-source-registry '(default-source-registry) :register register))
    9733         ((:inherit-configuration)
    9734          (inherit-source-registry inherit :register register))
    9735         ((:ignore-inherited-configuration)
    9736          nil)))
    9737     nil)
    9738 
    9739   (defmethod process-source-registry ((x symbol) &key inherit register)
    9740     (process-source-registry (funcall x) :inherit inherit :register register))
    9741   (defmethod process-source-registry ((pathname pathname) &key inherit register)
    9742     (cond
    9743       ((directory-pathname-p pathname)
    9744        (let ((*here-directory* (resolve-symlinks* pathname)))
    9745          (process-source-registry (validate-source-registry-directory pathname)
    9746                                   :inherit inherit :register register)))
    9747       ((probe-file* pathname :truename *resolve-symlinks*)
    9748        (let ((*here-directory* (pathname-directory-pathname pathname)))
    9749          (process-source-registry (validate-source-registry-file pathname)
    9750                                   :inherit inherit :register register)))
    9751       (t
    9752        (inherit-source-registry inherit :register register))))
    9753   (defmethod process-source-registry ((string string) &key inherit register)
    9754     (process-source-registry (parse-source-registry-string string)
    9755                              :inherit inherit :register register))
    9756   (defmethod process-source-registry ((x null) &key inherit register)
    9757     (inherit-source-registry inherit :register register))
    9758   (defmethod process-source-registry ((form cons) &key inherit register)
    9759     (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
    9760       (dolist (directive (cdr (validate-source-registry-form form)))
    9761         (process-source-registry-directive directive :inherit inherit :register register))))
    9762 
    9763   (defun flatten-source-registry (&optional parameter)
    9764     (remove-duplicates
    9765      (while-collecting (collect)
    9766        (with-pathname-defaults () ;; be location-independent
    9767          (inherit-source-registry
    9768           `(wrapping-source-registry
    9769             ,parameter
    9770             ,@*default-source-registries*)
    9771           :register #'(lambda (directory &key recurse exclude)
    9772                         (collect (list directory :recurse recurse :exclude exclude))))))
    9773      :test 'equal :from-end t))
    9774 
    9775   ;; Will read the configuration and initialize all internal variables.
    9776   (defun compute-source-registry (&optional parameter (registry *source-registry*))
    9777     (dolist (entry (flatten-source-registry parameter))
    9778       (destructuring-bind (directory &key recurse exclude) entry
    9779         (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
    9780           (register-asd-directory
    9781            directory :recurse recurse :exclude exclude :collect
    9782            #'(lambda (asd)
    9783                (let* ((name (pathname-name asd))
    9784                       (name (if (typep asd 'logical-pathname)
    9785                                 ;; logical pathnames are upper-case,
    9786                                 ;; at least in the CLHS and on SBCL,
    9787                                 ;; yet (coerce-name :foo) is lower-case.
    9788                                 ;; won't work well with (load-system "Foo")
    9789                                 ;; instead of (load-system 'foo)
    9790                                 (string-downcase name)
    9791                                 name)))
    9792                  (cond
    9793                    ((gethash name registry) ; already shadowed by something else
    9794                     nil)
    9795                    ((gethash name h) ; conflict at current level
    9796                     (when *verbose-out*
    9797                       (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
    9798                                 found several entries for ~A - picking ~S over ~S~:>")
    9799                             directory recurse name (gethash name h) asd)))
    9800                    (t
    9801                     (setf (gethash name registry) asd)
    9802                     (setf (gethash name h) asd))))))
    9803           h)))
    9804     (values))
    9805 
    9806   (defvar *source-registry-parameter* nil)
    9807 
    9808   (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
    9809     ;; Record the parameter used to configure the registry
    9810     (setf *source-registry-parameter* parameter)
    9811     ;; Clear the previous registry database:
    9812     (setf *source-registry* (make-hash-table :test 'equal))
    9813     ;; Do it!
    9814     (compute-source-registry parameter))
    9815 
    9816   ;; Checks an initial variable to see whether the state is initialized
    9817   ;; or cleared. In the former case, return current configuration; in
    9818   ;; the latter, initialize.  ASDF will call this function at the start
    9819   ;; of (asdf:find-system) to make sure the source registry is initialized.
    9820   ;; However, it will do so *without* a parameter, at which point it
    9821   ;; will be too late to provide a parameter to this function, though
    9822   ;; you may override the configuration explicitly by calling
    9823   ;; initialize-source-registry directly with your parameter.
    9824   (defun ensure-source-registry (&optional parameter)
    9825     (unless (source-registry-initialized-p)
    9826       (initialize-source-registry parameter))
    9827     (values))
    9828 
    9829   (defun sysdef-source-registry-search (system)
    9830     (ensure-source-registry)
    9831     (values (gethash (primary-system-name system) *source-registry*))))
    9832 
    9833 
    9834 ;;;; -------------------------------------------------------------------------
    9835 ;;; Internal hacks for backward-compatibility
    9836 
    9837 (uiop/package:define-package :asdf/backward-internals
    9838   (:recycle :asdf/backward-internals :asdf)
    9839   (:use :uiop/common-lisp :uiop :asdf/upgrade
    9840    :asdf/system :asdf/component :asdf/operation
    9841    :asdf/find-system :asdf/action :asdf/lisp-action)
    9842   (:export ;; for internal use
    9843    #:load-sysdef #:make-temporary-package
    9844    #:%refresh-component-inline-methods
    9845    #:make-sub-operation
    9846    #:load-sysdef #:make-temporary-package))
    9847 (in-package :asdf/backward-internals)
    9848 
    9849 ;;;; Backward compatibility with "inline methods"
    9850 (with-upgradability ()
    9851   (defparameter* +asdf-methods+
    9852     '(perform-with-restarts perform explain output-files operation-done-p))
    9853 
    9854   (defun %remove-component-inline-methods (component)
    9855     (dolist (name +asdf-methods+)
    9856       (map ()
    9857            ;; this is inefficient as most of the stored
    9858            ;; methods will not be for this particular gf
    9859            ;; But this is hardly performance-critical
    9860            #'(lambda (m)
    9861                (remove-method (symbol-function name) m))
    9862            (component-inline-methods component)))
    9863     (component-inline-methods component) nil)
    9864 
    9865   (defun %define-component-inline-methods (ret rest)
    9866     (loop* :for (key value) :on rest :by #'cddr
    9867            :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
    9868            :when name :do
    9869            (destructuring-bind (op &rest body) value
    9870              (loop :for arg = (pop body)
    9871                    :while (atom arg)
    9872                    :collect arg :into qualifiers
    9873                    :finally
    9874                       (destructuring-bind (o c) arg
    9875                         (pushnew
    9876                          (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
    9877                          (component-inline-methods ret)))))))
    9878 
    9879   (defun %refresh-component-inline-methods (component rest)
    9880     ;; clear methods, then add the new ones
    9881     (%remove-component-inline-methods component)
    9882     (%define-component-inline-methods component rest)))
    9883 
    9884 (when-upgrading (:when (fboundp 'make-sub-operation))
    9885   (defun make-sub-operation (c o dep-c dep-o)
    9886     (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
    9887 
    9888 
    9889 ;;;; load-sysdef
    9890 (with-upgradability ()
    9891   (defun load-sysdef (name pathname)
    9892     (load-asd pathname :name name))
    9893 
    9894   (defun make-temporary-package ()
    9895     ;; For loading a .asd file, we don't make a temporary package anymore,
    9896     ;; but use ASDF-USER. I'd like to have this function do this,
    9897     ;; but since whoever uses it is likely to delete-package the result afterwards,
    9898     ;; this would be a bad idea, so preserve the old behavior.
    9899     (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
    9900 
    9901 
    99029480;;;; -------------------------------------------------------------------------
    99039481;;;; Defsystem
     
    99089486  (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
    99099487   :asdf/cache :asdf/component :asdf/system
    9910    :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
    9911    :asdf/backward-internals)
     9488   :asdf/find-system :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
    99129489  (:import-from :asdf/system #:depends-on #:weakly-depends-on)
    99139490  (:export
     
    100239600          (unparse-version pv)
    100249601          (invalid))))))
     9602
     9603
     9604;;; "inline methods"
     9605(with-upgradability ()
     9606  (defparameter* +asdf-methods+
     9607    '(perform-with-restarts perform explain output-files operation-done-p))
     9608
     9609  (defun %remove-component-inline-methods (component)
     9610    (dolist (name +asdf-methods+)
     9611      (map ()
     9612           ;; this is inefficient as most of the stored
     9613           ;; methods will not be for this particular gf
     9614           ;; But this is hardly performance-critical
     9615           #'(lambda (m)
     9616               (remove-method (symbol-function name) m))
     9617           (component-inline-methods component)))
     9618    (component-inline-methods component) nil)
     9619
     9620  (defun %define-component-inline-methods (ret rest)
     9621    (loop* :for (key value) :on rest :by #'cddr
     9622           :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
     9623           :when name :do
     9624           (destructuring-bind (op &rest body) value
     9625             (loop :for arg = (pop body)
     9626                   :while (atom arg)
     9627                   :collect arg :into qualifiers
     9628                   :finally
     9629                      (destructuring-bind (o c) arg
     9630                        (pushnew
     9631                         (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
     9632                         (component-inline-methods ret)))))))
     9633
     9634  (defun %refresh-component-inline-methods (component rest)
     9635    ;; clear methods, then add the new ones
     9636    (%remove-component-inline-methods component)
     9637    (%define-component-inline-methods component rest)))
    100259638
    100269639
     
    101529765             (component-options
    101539766              (remove-plist-keys '(:defsystem-depends-on :class) options))
    10154              (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
    10155                                            (resolve-dependency-spec nil spec))))
     9767             (defsystem-dependencies (loop :for spec :in defsystem-depends-on
     9768                                           :when (resolve-dependency-spec nil spec)
     9769                                           :collect :it)))
    101569770        ;; cache defsystem-depends-on in canonical form
    101579771        (when defsystem-depends-on
     
    101889802   #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
    101899803   #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
    10190    #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op
    101919804   #:basic-compile-bundle-op #:prepare-bundle-op
    101929805   #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
     
    102059818     (name-suffix :initarg :name-suffix :initform nil)
    102069819     (bundle-type :initform :no-output-file :reader bundle-type)
    10207      #+ecl (lisp-files :initform nil :accessor extra-object-files)))
     9820     #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files)))
    102089821
    102099822  (defclass monolithic-op (operation) ()
     
    102689881
    102699882  (defclass prepare-bundle-op (sideway-operation)
    10270     ((sideway-operation :initform #+(or ecl mkcl) 'load-bundle-op #-(or ecl mkcl) 'load-op
    10271                         :allocation :class)))
     9883    ((sideway-operation
     9884      :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
     9885      :allocation :class)))
    102729886
    102739887  (defclass lib-op (link-op gather-op non-propagating-operation)
     
    102769890
    102779891  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
    10278                                #+(or ecl mkcl) link-op #-ecl gather-op)
    10279     ((selfward-operation :initform '(prepare-bundle-op #+ecl lib-op) :allocation :class)))
     9892                               #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op)
     9893    ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
     9894                         :allocation :class)))
    102809895
    102819896  (defclass load-bundle-op (basic-load-op selfward-operation)
     
    102929907
    102939908  (defclass deliver-asd-op (basic-compile-op selfward-operation)
    10294     ((selfward-operation :initform '(compile-bundle-op #+(or ecl mkcl) lib-op) :allocation :class))
     9909    ((selfward-operation :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) :allocation :class))
    102959910    (:documentation "produce an asd file for delivering the system as a single fasl"))
    102969911
    102979912
    102989913  (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
    10299     ((selfward-operation :initform '(monolithic-compile-bundle-op #+(or ecl mkcl) monolithic-lib-op)
    10300                          :allocation :class))
     9914    ((selfward-operation
     9915      :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
     9916      :allocation :class))
    103019917    (:documentation "produce fasl and asd files for combined system and dependencies."))
    103029918
    103039919  (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op
    10304                                           #+(or ecl mkcl) link-op gather-op non-propagating-operation)
    10305     ((gather-op :initform #+(or ecl mkcl) 'lib-op #-(or ecl mkcl) 'compile-bundle-op :allocation :class))
     9920                                          #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation)
     9921    ((gather-op :initform #+(or clasp ecl mkcl) 'lib-op #-(or clasp ecl mkcl) 'compile-bundle-op :allocation :class))
    103069922    (:documentation "Create a single fasl for the system and its dependencies."))
    103079923
     
    103189934
    103199935  (defclass image-op (monolithic-bundle-op selfward-operation
    10320                       #+(or ecl mkcl) link-op #+(or ecl mkcl) gather-op)
     9936                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
    103219937    ((bundle-type :initform :image)
    10322      (selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class))
     9938     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
    103239939    (:documentation "create an image file from the system and its dependencies"))
    103249940
     
    103319947      ((eql :no-output-file) nil) ;; should we error out instead?
    103329948      ((or null string) bundle-type)
    10333       ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
    10334       #+ecl
     9949      ((eql :fasl) #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")
     9950      #+(or clasp ecl)
    103359951      ((member :dll :lib :shared-library :static-library :program :object :program)
    103369952       (compile-file-type :type bundle-type))
    10337       ((member :image) #-allegro "image" #+allegro "dxl")
    10338       ((member :dll :shared-library) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
    10339       ((member :lib :static-library) (cond ((os-unix-p) "a")
    10340                                            ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
    10341       ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
     9953      ((member :image) #+allegro "dxl" #+(and clisp os-windows) "exe" #-(or allegro (and clisp os-windows)) "image")
     9954      ((member :dll :shared-library) (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
     9955      ((member :lib :static-library) (os-cond ((os-unix-p) "a")
     9956                                              ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
     9957      ((eql :program) (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
    103429958
    103439959  (defun bundle-output-files (o c)
     
    103549970    (bundle-output-files o c))
    103559971
    10356   #-(or ecl mkcl)
     9972  #-(or clasp ecl mkcl)
    103579973  (progn
    103589974    (defmethod perform ((o image-op) (c system))
     
    103629978
    103639979  (defclass compiled-file (file-component)
    10364     ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
     9980    ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")))
    103659981
    103669982  (defclass precompiled-system (system)
     
    1038810004      (setf (slot-value instance 'name-suffix)
    1038910005            (unless (typep instance 'program-op)
    10390               (if (operation-monolithic-p instance) "--all-systems" #-(or ecl mkcl) "--system")))) ; . no good for Logical Pathnames
     10006              ;; "." is no good separator for Logical Pathnames, so we use "--"
     10007              (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system"))))
    1039110008    (when (typep instance 'monolithic-bundle-op)
    1039210009      (destructuring-bind (&key lisp-files prologue-code epilogue-code
     
    1039510012        (setf (prologue-code instance) prologue-code
    1039610013              (epilogue-code instance) epilogue-code)
    10397         #-ecl (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
    10398         #+ecl (setf (extra-object-files instance) lisp-files)))
     10014        #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
     10015        #+(or clasp ecl) (setf (extra-object-files instance) lisp-files)))
    1039910016    (setf (extra-build-args instance)
    1040010017          (remove-plist-keys
     
    1040610023    (let ((type (pathname-type pathname)))
    1040710024      (declare (ignorable type))
    10408       (or #+ecl (or (equalp type (compile-file-type :type :object))
    10409                     (equalp type (compile-file-type :type :static-library)))
     10025      (or #+(or clasp ecl) (or (equalp type (compile-file-type :type :object))
     10026                               (equalp type (compile-file-type :type :static-library)))
    1041010027          #+mkcl (or (equalp type (compile-file-type :fasl-p nil))
    1041110028                     #+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW
     
    1060610223          (terpri s)))))
    1060710224
    10608   #-(or ecl mkcl)
     10225  #-(or clasp ecl mkcl)
    1060910226  (defmethod perform ((o basic-compile-bundle-op) (c system))
    1061010227    (let* ((input-files (input-files o c))
     
    1064010257|#
    1064110258
    10642 #+(or ecl mkcl)
     10259#+(or clasp ecl mkcl)
    1064310260(with-upgradability ()
    1064410261  ;; I think that Juanjo intended for this to be,
     
    1064610263  ;; and also it makes mkcl fail test-logical-pathname.script,
    1064710264  ;; and ecl fail test-bundle.script.
    10648   ;;(unless (or #+ecl (use-ecl-byte-compiler-p))
     10265  ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p))
    1064910266  ;;  (setf *load-system-operation* 'load-bundle-op))
    1065010267
     10268  (defun uiop-library-pathname ()
     10269    #+clasp (probe-file* (compile-file-pathname "sys:uiop" :output-type :object))
     10270    #+ecl (or (probe-file* (compile-file-pathname "sys:uiop" :type :lib)) ;; new style
     10271              (probe-file* (compile-file-pathname "sys:uiop" :type :object))) ;; old style
     10272    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;uiop"))
     10273
    1065110274  (defun asdf-library-pathname ()
     10275    #+clasp (probe-file* (compile-file-pathname "sys:asdf" :output-type :object))
    1065210276    #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style
    1065310277              (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style
     
    1065510279
    1065610280  (defun compiler-library-pathname ()
     10281    #+clasp (compile-file-pathname "sys:cmp" :output-type :lib)
    1065710282    #+ecl (compile-file-pathname "sys:cmp" :type :lib)
    1065810283    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))
     
    1067010295                   "cmp" (compiler-library-pathname))))
    1067110296           ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
    10672                `(,(cond
    10673                     ((system-source-directory :uiop) (find-system :uiop))
    10674                     ((system-source-directory :asdf) (find-system :asdf))
    10675                     (t (make-library-system "asdf" (asdf-library-pathname))))))
     10297               `(cond
     10298                  ((system-source-directory :uiop) `(,(find-system :uiop)))
     10299                  ((system-source-directory :asdf) `(,(find-system :asdf)))
     10300                  (t `(,@(if-let (uiop (uiop-library-pathname))
     10301                           `(,(make-library-system "uiop" uiop)))
     10302                       ,(make-library-system "asdf" (asdf-library-pathname))))))
    1067610303           ,@deps)))))
    1067710304
     
    1069710324
    1069810325#+(and (not asdf-use-unsafe-mac-bundle-op)
    10699        (or (and ecl darwin)
     10326       (or (and clasp ecl darwin)
    1070010327           (and abcl darwin (not abcl-bundle-op-supported))))
    1070110328(defmethod perform :before ((o basic-compile-bundle-op) (c component))
     
    1070810335
    1070910336;;; Backward compatibility with pre-3.1.2 names
    10710 (defclass fasl-op (selfward-operation)
    10711   ((selfward-operation :initform 'compile-bundle-op :allocation :class)))
    10712 (defclass load-fasl-op (selfward-operation)
    10713   ((selfward-operation :initform 'load-bundle-op :allocation :class)))
    10714 (defclass binary-op (selfward-operation)
    10715   ((selfward-operation :initform 'deliver-asd-op :allocation :class)))
    10716 (defclass monolithic-fasl-op (selfward-operation)
    10717   ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)))
    10718 (defclass monolithic-load-fasl-op (selfward-operation)
    10719   ((selfward-operation :initform 'monolithic-load-bundle-op :allocation :class)))
    10720 (defclass monolithic-binary-op (selfward-operation)
    10721   ((selfward-operation :initform 'monolithic-deliver-asd-op :allocation :class)))
     10337;; (defclass fasl-op (selfward-operation)
     10338;;   ((selfward-operation :initform 'compile-bundle-op :allocation :class)))
     10339;; (defclass load-fasl-op (selfward-operation)
     10340;;   ((selfward-operation :initform 'load-bundle-op :allocation :class)))
     10341;; (defclass binary-op (selfward-operation)
     10342;;   ((selfward-operation :initform 'deliver-asd-op :allocation :class)))
     10343;; (defclass monolithic-fasl-op (selfward-operation)
     10344;;   ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)))
     10345;; (defclass monolithic-load-fasl-op (selfward-operation)
     10346;;   ((selfward-operation :initform 'monolithic-load-bundle-op :allocation :class)))
     10347;; (defclass monolithic-binary-op (selfward-operation)
     10348;;   ((selfward-operation :initform 'monolithic-deliver-asd-op :allocation :class)))
    1072210349;;;; -------------------------------------------------------------------------
    1072310350;;;; Concatenate-source
     
    1081110438    (perform-lisp-load-fasl o s)))
    1081210439
     10440;;;; ---------------------------------------------------------------------------
     10441;;;; asdf-output-translations
     10442
     10443(uiop/package:define-package :asdf/output-translations
     10444  (:recycle :asdf/output-translations :asdf)
     10445  (:use :uiop/common-lisp :uiop :asdf/upgrade)
     10446  (:export
     10447   #:*output-translations* #:*output-translations-parameter*
     10448   #:invalid-output-translation
     10449   #:output-translations #:output-translations-initialized-p
     10450   #:initialize-output-translations #:clear-output-translations
     10451   #:disable-output-translations #:ensure-output-translations
     10452   #:apply-output-translations
     10453   #:validate-output-translations-directive #:validate-output-translations-form
     10454   #:validate-output-translations-file #:validate-output-translations-directory
     10455   #:parse-output-translations-string #:wrapping-output-translations
     10456   #:user-output-translations-pathname #:system-output-translations-pathname
     10457   #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
     10458   #:environment-output-translations #:process-output-translations
     10459   #:compute-output-translations
     10460   #+abcl #:translate-jar-pathname
     10461   ))
     10462(in-package :asdf/output-translations)
     10463
     10464(when-upgrading () (undefine-function '(setf output-translations)))
     10465
     10466(with-upgradability ()
     10467  (define-condition invalid-output-translation (invalid-configuration warning)
     10468    ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
     10469
     10470  (defvar *output-translations* ()
     10471    "Either NIL (for uninitialized), or a list of one element,
     10472said element itself being a sorted list of mappings.
     10473Each mapping is a pair of a source pathname and destination pathname,
     10474and the order is by decreasing length of namestring of the source pathname.")
     10475
     10476  (defun output-translations ()
     10477    (car *output-translations*))
     10478
     10479  (defun set-output-translations (new-value)
     10480    (setf *output-translations*
     10481          (list
     10482           (stable-sort (copy-list new-value) #'>
     10483                        :key #'(lambda (x)
     10484                                 (etypecase (car x)
     10485                                   ((eql t) -1)
     10486                                   (pathname
     10487                                    (let ((directory (pathname-directory (car x))))
     10488                                      (if (listp directory) (length directory) 0))))))))
     10489    new-value)
     10490  (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
     10491
     10492  (defun output-translations-initialized-p ()
     10493    (and *output-translations* t))
     10494
     10495  (defun clear-output-translations ()
     10496    "Undoes any initialization of the output translations."
     10497    (setf *output-translations* '())
     10498    (values))
     10499  (register-clear-configuration-hook 'clear-output-translations)
     10500
     10501  (defun validate-output-translations-directive (directive)
     10502    (or (member directive '(:enable-user-cache :disable-cache nil))
     10503        (and (consp directive)
     10504             (or (and (length=n-p directive 2)
     10505                      (or (and (eq (first directive) :include)
     10506                               (typep (second directive) '(or string pathname null)))
     10507                          (and (location-designator-p (first directive))
     10508                               (or (location-designator-p (second directive))
     10509                                   (location-function-p (second directive))))))
     10510                 (and (length=n-p directive 1)
     10511                      (location-designator-p (first directive)))))))
     10512
     10513  (defun validate-output-translations-form (form &key location)
     10514    (validate-configuration-form
     10515     form
     10516     :output-translations
     10517     'validate-output-translations-directive
     10518     :location location :invalid-form-reporter 'invalid-output-translation))
     10519
     10520  (defun validate-output-translations-file (file)
     10521    (validate-configuration-file
     10522     file 'validate-output-translations-form :description "output translations"))
     10523
     10524  (defun validate-output-translations-directory (directory)
     10525    (validate-configuration-directory
     10526     directory :output-translations 'validate-output-translations-directive
     10527               :invalid-form-reporter 'invalid-output-translation))
     10528
     10529  (defun parse-output-translations-string (string &key location)
     10530    (cond
     10531      ((or (null string) (equal string ""))
     10532       '(:output-translations :inherit-configuration))
     10533      ((not (stringp string))
     10534       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     10535      ((eql (char string 0) #\")
     10536       (parse-output-translations-string (read-from-string string) :location location))
     10537      ((eql (char string 0) #\()
     10538       (validate-output-translations-form (read-from-string string) :location location))
     10539      (t
     10540       (loop
     10541         :with inherit = nil
     10542         :with directives = ()
     10543         :with start = 0
     10544         :with end = (length string)
     10545         :with source = nil
     10546         :with separator = (inter-directory-separator)
     10547         :for i = (or (position separator string :start start) end) :do
     10548           (let ((s (subseq string start i)))
     10549             (cond
     10550               (source
     10551                (push (list source (if (equal "" s) nil s)) directives)
     10552                (setf source nil))
     10553               ((equal "" s)
     10554                (when inherit
     10555                  (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     10556                         string))
     10557                (setf inherit t)
     10558                (push :inherit-configuration directives))
     10559               (t
     10560                (setf source s)))
     10561             (setf start (1+ i))
     10562             (when (> start end)
     10563               (when source
     10564                 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
     10565                        string))
     10566               (unless inherit
     10567                 (push :ignore-inherited-configuration directives))
     10568               (return `(:output-translations ,@(nreverse directives)))))))))
     10569
     10570  (defparameter* *default-output-translations*
     10571    '(environment-output-translations
     10572      user-output-translations-pathname
     10573      user-output-translations-directory-pathname
     10574      system-output-translations-pathname
     10575      system-output-translations-directory-pathname))
     10576
     10577  (defun wrapping-output-translations ()
     10578    `(:output-translations
     10579    ;; Some implementations have precompiled ASDF systems,
     10580    ;; so we must disable translations for implementation paths.
     10581      #+(or clasp #|clozure|# ecl mkcl sbcl)
     10582      ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
     10583          (when h `(((,h ,*wild-path*) ()))))
     10584      #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
     10585      ;; All-import, here is where we want user stuff to be:
     10586      :inherit-configuration
     10587      ;; These are for convenience, and can be overridden by the user:
     10588      #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     10589      #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
     10590      ;; We enable the user cache by default, and here is the place we do:
     10591      :enable-user-cache))
     10592
     10593  (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
     10594  (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
     10595
     10596  (defun user-output-translations-pathname (&key (direction :input))
     10597    (xdg-config-pathname *output-translations-file* direction))
     10598  (defun system-output-translations-pathname (&key (direction :input))
     10599    (find-preferred-file (system-config-pathnames *output-translations-file*)
     10600                         :direction direction))
     10601  (defun user-output-translations-directory-pathname (&key (direction :input))
     10602    (xdg-config-pathname *output-translations-directory* direction))
     10603  (defun system-output-translations-directory-pathname (&key (direction :input))
     10604    (find-preferred-file (system-config-pathnames *output-translations-directory*)
     10605                         :direction direction))
     10606  (defun environment-output-translations ()
     10607    (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     10608
     10609  (defgeneric process-output-translations (spec &key inherit collect))
     10610
     10611  (defun inherit-output-translations (inherit &key collect)
     10612    (when inherit
     10613      (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
     10614
     10615  (defun* (process-output-translations-directive) (directive &key inherit collect)
     10616    (if (atom directive)
     10617        (ecase directive
     10618          ((:enable-user-cache)
     10619           (process-output-translations-directive '(t :user-cache) :collect collect))
     10620          ((:disable-cache)
     10621           (process-output-translations-directive '(t t) :collect collect))
     10622          ((:inherit-configuration)
     10623           (inherit-output-translations inherit :collect collect))
     10624          ((:ignore-inherited-configuration :ignore-invalid-entries nil)
     10625           nil))
     10626        (let ((src (first directive))
     10627              (dst (second directive)))
     10628          (if (eq src :include)
     10629              (when dst
     10630                (process-output-translations (pathname dst) :inherit nil :collect collect))
     10631              (when src
     10632                (let ((trusrc (or (eql src t)
     10633                                  (let ((loc (resolve-location src :ensure-directory t :wilden t)))
     10634                                    (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
     10635                  (cond
     10636                    ((location-function-p dst)
     10637                     (funcall collect
     10638                              (list trusrc (ensure-function (second dst)))))
     10639                    ((typep dst 'boolean)
     10640                     (funcall collect (list trusrc t)))
     10641                    (t
     10642                     (let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
     10643                       (funcall collect (list trudst t))
     10644                       (funcall collect (list trusrc trudst)))))))))))
     10645
     10646  (defmethod process-output-translations ((x symbol) &key
     10647                                                       (inherit *default-output-translations*)
     10648                                                       collect)
     10649    (process-output-translations (funcall x) :inherit inherit :collect collect))
     10650  (defmethod process-output-translations ((pathname pathname) &key inherit collect)
     10651    (cond
     10652      ((directory-pathname-p pathname)
     10653       (process-output-translations (validate-output-translations-directory pathname)
     10654                                    :inherit inherit :collect collect))
     10655      ((probe-file* pathname :truename *resolve-symlinks*)
     10656       (process-output-translations (validate-output-translations-file pathname)
     10657                                    :inherit inherit :collect collect))
     10658      (t
     10659       (inherit-output-translations inherit :collect collect))))
     10660  (defmethod process-output-translations ((string string) &key inherit collect)
     10661    (process-output-translations (parse-output-translations-string string)
     10662                                 :inherit inherit :collect collect))
     10663  (defmethod process-output-translations ((x null) &key inherit collect)
     10664    (inherit-output-translations inherit :collect collect))
     10665  (defmethod process-output-translations ((form cons) &key inherit collect)
     10666    (dolist (directive (cdr (validate-output-translations-form form)))
     10667      (process-output-translations-directive directive :inherit inherit :collect collect)))
     10668
     10669  (defun compute-output-translations (&optional parameter)
     10670    "read the configuration, return it"
     10671    (remove-duplicates
     10672     (while-collecting (c)
     10673       (inherit-output-translations
     10674        `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
     10675     :test 'equal :from-end t))
     10676
     10677  (defvar *output-translations-parameter* nil)
     10678
     10679  (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
     10680    "read the configuration, initialize the internal configuration variable,
     10681return the configuration"
     10682    (setf *output-translations-parameter* parameter
     10683          (output-translations) (compute-output-translations parameter)))
     10684
     10685  (defun disable-output-translations ()
     10686    "Initialize output translations in a way that maps every file to itself,
     10687effectively disabling the output translation facility."
     10688    (initialize-output-translations
     10689     '(:output-translations :disable-cache :ignore-inherited-configuration)))
     10690
     10691  ;; checks an initial variable to see whether the state is initialized
     10692  ;; or cleared. In the former case, return current configuration; in
     10693  ;; the latter, initialize.  ASDF will call this function at the start
     10694  ;; of (asdf:find-system).
     10695  (defun ensure-output-translations ()
     10696    (if (output-translations-initialized-p)
     10697        (output-translations)
     10698        (initialize-output-translations)))
     10699
     10700  (defun* (apply-output-translations) (path)
     10701    (etypecase path
     10702      (logical-pathname
     10703       path)
     10704      ((or pathname string)
     10705       (ensure-output-translations)
     10706       (loop* :with p = (resolve-symlinks* path)
     10707              :for (source destination) :in (car *output-translations*)
     10708              :for root = (when (or (eq source t)
     10709                                    (and (pathnamep source)
     10710                                         (not (absolute-pathname-p source))))
     10711                            (pathname-root p))
     10712              :for absolute-source = (cond
     10713                                       ((eq source t) (wilden root))
     10714                                       (root (merge-pathnames* source root))
     10715                                       (t source))
     10716              :when (or (eq source t) (pathname-match-p p absolute-source))
     10717              :return (translate-pathname* p absolute-source destination root source)
     10718              :finally (return p)))))
     10719
     10720  ;; Hook into uiop's output-translation mechanism
     10721  #-cormanlisp
     10722  (setf *output-translation-function* 'apply-output-translations)
     10723
     10724  #+abcl
     10725  (defun translate-jar-pathname (source wildcard)
     10726    (declare (ignore wildcard))
     10727    (flet ((normalize-device (pathname)
     10728             (if (find :windows *features*)
     10729                 pathname
     10730                 (make-pathname :defaults pathname :device :unspecific))))
     10731      (let* ((jar
     10732               (pathname (first (pathname-device source))))
     10733             (target-root-directory-namestring
     10734               (format nil "/___jar___file___root___/~@[~A/~]"
     10735                       (and (find :windows *features*)
     10736                            (pathname-device jar))))
     10737             (relative-source
     10738               (relativize-pathname-directory source))
     10739             (relative-jar
     10740               (relativize-pathname-directory (ensure-directory-pathname jar)))
     10741             (target-root-directory
     10742               (normalize-device
     10743                (pathname-directory-pathname
     10744                 (parse-namestring target-root-directory-namestring))))
     10745             (target-root
     10746               (merge-pathnames* relative-jar target-root-directory))
     10747             (target
     10748               (merge-pathnames* relative-source target-root)))
     10749        (normalize-device (apply-output-translations target))))))
     10750
     10751;;;; -----------------------------------------------------------------
     10752;;;; Source Registry Configuration, by Francois-Rene Rideau
     10753;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
     10754
     10755(uiop/package:define-package :asdf/source-registry
     10756  (:recycle :asdf/source-registry :asdf)
     10757  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
     10758  (:export
     10759   #:*source-registry-parameter* #:*default-source-registries*
     10760   #:invalid-source-registry
     10761   #:source-registry-initialized-p
     10762   #:initialize-source-registry #:clear-source-registry #:*source-registry*
     10763   #:ensure-source-registry #:*source-registry-parameter*
     10764   #:*default-source-registry-exclusions* #:*source-registry-exclusions*
     10765   #:*wild-asd* #:directory-asd-files #:register-asd-directory
     10766   #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files
     10767   #:validate-source-registry-directive #:validate-source-registry-form
     10768   #:validate-source-registry-file #:validate-source-registry-directory
     10769   #:parse-source-registry-string #:wrapping-source-registry
     10770   #:default-user-source-registry #:default-system-source-registry
     10771   #:user-source-registry #:system-source-registry
     10772   #:user-source-registry-directory #:system-source-registry-directory
     10773   #:environment-source-registry #:process-source-registry
     10774   #:compute-source-registry #:flatten-source-registry
     10775   #:sysdef-source-registry-search))
     10776(in-package :asdf/source-registry)
     10777
     10778(with-upgradability ()
     10779  (define-condition invalid-source-registry (invalid-configuration warning)
     10780    ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
     10781
     10782  ;; Using ack 1.2 exclusions
     10783  (defvar *default-source-registry-exclusions*
     10784    '(".bzr" ".cdv"
     10785      ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
     10786      ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
     10787      "_sgbak" "autom4te.cache" "cover_db" "_build"
     10788      "debian")) ;; debian often builds stuff under the debian directory... BAD.
     10789
     10790  (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
     10791
     10792  (defvar *source-registry* nil
     10793    "Either NIL (for uninitialized), or an equal hash-table, mapping
     10794system names to pathnames of .asd files")
     10795
     10796  (defun source-registry-initialized-p ()
     10797    (typep *source-registry* 'hash-table))
     10798
     10799  (defun clear-source-registry ()
     10800    "Undoes any initialization of the source registry."
     10801    (setf *source-registry* nil)
     10802    (values))
     10803  (register-clear-configuration-hook 'clear-source-registry)
     10804
     10805  (defparameter *wild-asd*
     10806    (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
     10807
     10808  (defun directory-asd-files (directory)
     10809    (directory-files directory *wild-asd*))
     10810
     10811  (defun collect-asds-in-directory (directory collect)
     10812    (let ((asds (directory-asd-files directory)))
     10813      (map () collect asds)
     10814      asds))
     10815
     10816  (defvar *recurse-beyond-asds* t
     10817    "Should :tree entries of the source-registry recurse in subdirectories
     10818after having found a .asd file? True by default.")
     10819
     10820  (defun process-source-registry-cache (directory collect)
     10821    (let ((cache (ignore-errors
     10822                  (safe-read-file-form (subpathname directory ".cl-source-registry.cache")))))
     10823      (when (and (listp cache) (eq :source-registry-cache (first cache)))
     10824        (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s)))
     10825        t)))
     10826
     10827  (defun collect-sub*directories-asd-files
     10828      (directory &key (exclude *default-source-registry-exclusions*) collect
     10829                   (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache)
     10830    (collect-sub*directories
     10831     directory
     10832     #'(lambda (dir)
     10833         (unless (and (not ignore-cache) (process-source-registry-cache directory collect))
     10834           (let ((asds (collect-asds-in-directory dir collect)))
     10835             (or recurse-beyond-asds (not asds)))))
     10836     #'(lambda (x)
     10837         (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
     10838     (constantly nil)))
     10839
     10840  (defun validate-source-registry-directive (directive)
     10841    (or (member directive '(:default-registry))
     10842        (and (consp directive)
     10843             (let ((rest (rest directive)))
     10844               (case (first directive)
     10845                 ((:include :directory :tree)
     10846                  (and (length=n-p rest 1)
     10847                       (location-designator-p (first rest))))
     10848                 ((:exclude :also-exclude)
     10849                  (every #'stringp rest))
     10850                 ((:default-registry)
     10851                  (null rest)))))))
     10852
     10853  (defun validate-source-registry-form (form &key location)
     10854    (validate-configuration-form
     10855     form :source-registry 'validate-source-registry-directive
     10856          :location location :invalid-form-reporter 'invalid-source-registry))
     10857
     10858  (defun validate-source-registry-file (file)
     10859    (validate-configuration-file
     10860     file 'validate-source-registry-form :description "a source registry"))
     10861
     10862  (defun validate-source-registry-directory (directory)
     10863    (validate-configuration-directory
     10864     directory :source-registry 'validate-source-registry-directive
     10865               :invalid-form-reporter 'invalid-source-registry))
     10866
     10867  (defun parse-source-registry-string (string &key location)
     10868    (cond
     10869      ((or (null string) (equal string ""))
     10870       '(:source-registry :inherit-configuration))
     10871      ((not (stringp string))
     10872       (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     10873      ((find (char string 0) "\"(")
     10874       (validate-source-registry-form (read-from-string string) :location location))
     10875      (t
     10876       (loop
     10877         :with inherit = nil
     10878         :with directives = ()
     10879         :with start = 0
     10880         :with end = (length string)
     10881         :with separator = (inter-directory-separator)
     10882         :for pos = (position separator string :start start) :do
     10883           (let ((s (subseq string start (or pos end))))
     10884             (flet ((check (dir)
     10885                      (unless (absolute-pathname-p dir)
     10886                        (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
     10887                      dir))
     10888               (cond
     10889                 ((equal "" s) ; empty element: inherit
     10890                  (when inherit
     10891                    (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     10892                           string))
     10893                  (setf inherit t)
     10894                  (push ':inherit-configuration directives))
     10895                 ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
     10896                  (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
     10897                 (t
     10898                  (push `(:directory ,(check s)) directives))))
     10899             (cond
     10900               (pos
     10901                (setf start (1+ pos)))
     10902               (t
     10903                (unless inherit
     10904                  (push '(:ignore-inherited-configuration) directives))
     10905                (return `(:source-registry ,@(nreverse directives))))))))))
     10906
     10907  (defun register-asd-directory (directory &key recurse exclude collect)
     10908    (if (not recurse)
     10909        (collect-asds-in-directory directory collect)
     10910        (collect-sub*directories-asd-files
     10911         directory :exclude exclude :collect collect)))
     10912
     10913  (defparameter* *default-source-registries*
     10914    '(environment-source-registry
     10915      user-source-registry
     10916      user-source-registry-directory
     10917      default-user-source-registry
     10918      system-source-registry
     10919      system-source-registry-directory
     10920      default-system-source-registry)
     10921    "List of default source registries" "3.1.0.102")
     10922
     10923  (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
     10924  (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
     10925
     10926  (defun wrapping-source-registry ()
     10927    `(:source-registry
     10928      #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
     10929      :inherit-configuration
     10930      #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
     10931      #+cmu (:tree #p"modules:")
     10932      #+scl (:tree #p"file://modules/")))
     10933  (defun default-user-source-registry ()
     10934    `(:source-registry
     10935      (:tree (:home "common-lisp/"))
     10936      #+sbcl (:directory (:home ".sbcl/systems/"))
     10937      (:directory ,(xdg-data-home "common-lisp/systems/"))
     10938      (:tree ,(xdg-data-home "common-lisp/source/"))
     10939      :inherit-configuration))
     10940  (defun default-system-source-registry ()
     10941    `(:source-registry
     10942      ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
     10943              :collect `(:directory (,dir "systems/"))
     10944              :collect `(:tree (,dir "source/")))
     10945      :inherit-configuration))
     10946  (defun user-source-registry (&key (direction :input))
     10947    (xdg-config-pathname *source-registry-file* direction))
     10948  (defun system-source-registry (&key (direction :input))
     10949    (find-preferred-file (system-config-pathnames *source-registry-file*)
     10950                         :direction direction))
     10951  (defun user-source-registry-directory (&key (direction :input))
     10952    (xdg-config-pathname *source-registry-directory* direction))
     10953  (defun system-source-registry-directory (&key (direction :input))
     10954    (find-preferred-file (system-config-pathnames *source-registry-directory*)
     10955                         :direction direction))
     10956  (defun environment-source-registry ()
     10957    (getenv "CL_SOURCE_REGISTRY"))
     10958
     10959  (defgeneric* (process-source-registry) (spec &key inherit register))
     10960
     10961  (defun* (inherit-source-registry) (inherit &key register)
     10962    (when inherit
     10963      (process-source-registry (first inherit) :register register :inherit (rest inherit))))
     10964
     10965  (defun* (process-source-registry-directive) (directive &key inherit register)
     10966    (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
     10967      (ecase kw
     10968        ((:include)
     10969         (destructuring-bind (pathname) rest
     10970           (process-source-registry (resolve-location pathname) :inherit nil :register register)))
     10971        ((:directory)
     10972         (destructuring-bind (pathname) rest
     10973           (when pathname
     10974             (funcall register (resolve-location pathname :ensure-directory t)))))
     10975        ((:tree)
     10976         (destructuring-bind (pathname) rest
     10977           (when pathname
     10978             (funcall register (resolve-location pathname :ensure-directory t)
     10979                      :recurse t :exclude *source-registry-exclusions*))))
     10980        ((:exclude)
     10981         (setf *source-registry-exclusions* rest))
     10982        ((:also-exclude)
     10983         (appendf *source-registry-exclusions* rest))
     10984        ((:default-registry)
     10985         (inherit-source-registry
     10986          '(default-user-source-registry default-system-source-registry) :register register))
     10987        ((:inherit-configuration)
     10988         (inherit-source-registry inherit :register register))
     10989        ((:ignore-inherited-configuration)
     10990         nil)))
     10991    nil)
     10992
     10993  (defmethod process-source-registry ((x symbol) &key inherit register)
     10994    (process-source-registry (funcall x) :inherit inherit :register register))
     10995  (defmethod process-source-registry ((pathname pathname) &key inherit register)
     10996    (cond
     10997      ((directory-pathname-p pathname)
     10998       (let ((*here-directory* (resolve-symlinks* pathname)))
     10999         (process-source-registry (validate-source-registry-directory pathname)
     11000                                  :inherit inherit :register register)))
     11001      ((probe-file* pathname :truename *resolve-symlinks*)
     11002       (let ((*here-directory* (pathname-directory-pathname pathname)))
     11003         (process-source-registry (validate-source-registry-file pathname)
     11004                                  :inherit inherit :register register)))
     11005      (t
     11006       (inherit-source-registry inherit :register register))))
     11007  (defmethod process-source-registry ((string string) &key inherit register)
     11008    (process-source-registry (parse-source-registry-string string)
     11009                             :inherit inherit :register register))
     11010  (defmethod process-source-registry ((x null) &key inherit register)
     11011    (inherit-source-registry inherit :register register))
     11012  (defmethod process-source-registry ((form cons) &key inherit register)
     11013    (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
     11014      (dolist (directive (cdr (validate-source-registry-form form)))
     11015        (process-source-registry-directive directive :inherit inherit :register register))))
     11016
     11017  (defun flatten-source-registry (&optional parameter)
     11018    (remove-duplicates
     11019     (while-collecting (collect)
     11020       (with-pathname-defaults () ;; be location-independent
     11021         (inherit-source-registry
     11022          `(wrapping-source-registry
     11023            ,parameter
     11024            ,@*default-source-registries*)
     11025          :register #'(lambda (directory &key recurse exclude)
     11026                        (collect (list directory :recurse recurse :exclude exclude))))))
     11027     :test 'equal :from-end t))
     11028
     11029  ;; Will read the configuration and initialize all internal variables.
     11030  (defun compute-source-registry (&optional parameter (registry *source-registry*))
     11031    (dolist (entry (flatten-source-registry parameter))
     11032      (destructuring-bind (directory &key recurse exclude) entry
     11033        (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
     11034          (register-asd-directory
     11035           directory :recurse recurse :exclude exclude :collect
     11036           #'(lambda (asd)
     11037               (let* ((name (pathname-name asd))
     11038                      (name (if (typep asd 'logical-pathname)
     11039                                ;; logical pathnames are upper-case,
     11040                                ;; at least in the CLHS and on SBCL,
     11041                                ;; yet (coerce-name :foo) is lower-case.
     11042                                ;; won't work well with (load-system "Foo")
     11043                                ;; instead of (load-system 'foo)
     11044                                (string-downcase name)
     11045                                name)))
     11046                 (cond
     11047                   ((gethash name registry) ; already shadowed by something else
     11048                    nil)
     11049                   ((gethash name h) ; conflict at current level
     11050                    (when *verbose-out*
     11051                      (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
     11052                                found several entries for ~A - picking ~S over ~S~:>")
     11053                            directory recurse name (gethash name h) asd)))
     11054                   (t
     11055                    (setf (gethash name registry) asd)
     11056                    (setf (gethash name h) asd))))))
     11057          h)))
     11058    (values))
     11059
     11060  (defvar *source-registry-parameter* nil)
     11061
     11062  (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
     11063    ;; Record the parameter used to configure the registry
     11064    (setf *source-registry-parameter* parameter)
     11065    ;; Clear the previous registry database:
     11066    (setf *source-registry* (make-hash-table :test 'equal))
     11067    ;; Do it!
     11068    (compute-source-registry parameter))
     11069
     11070  ;; Checks an initial variable to see whether the state is initialized
     11071  ;; or cleared. In the former case, return current configuration; in
     11072  ;; the latter, initialize.  ASDF will call this function at the start
     11073  ;; of (asdf:find-system) to make sure the source registry is initialized.
     11074  ;; However, it will do so *without* a parameter, at which point it
     11075  ;; will be too late to provide a parameter to this function, though
     11076  ;; you may override the configuration explicitly by calling
     11077  ;; initialize-source-registry directly with your parameter.
     11078  (defun ensure-source-registry (&optional parameter)
     11079    (unless (source-registry-initialized-p)
     11080      (initialize-source-registry parameter))
     11081    (values))
     11082
     11083  (defun sysdef-source-registry-search (system)
     11084    (ensure-source-registry)
     11085    (values (gethash (primary-system-name system) *source-registry*))))
     11086
     11087
     11088;;;; -------------------------------------------------------------------------
     11089;;;; Package systems in the style of quick-build or faslpath
     11090
     11091(uiop:define-package :asdf/package-inferred-system
     11092  (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
     11093  (:use :uiop/common-lisp :uiop
     11094        :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
     11095        :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
     11096  (:export
     11097   #:package-inferred-system #:sysdef-package-inferred-system-search
     11098   #:package-system ;; backward compatibility only. To be removed.
     11099   #:register-system-packages
     11100   #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
     11101(in-package :asdf/package-inferred-system)
     11102
     11103(with-upgradability ()
     11104  (defparameter *defpackage-forms* '(defpackage define-package))
     11105
     11106  (defun initial-package-inferred-systems-table ()
     11107    (let ((h (make-hash-table :test 'equal)))
     11108      (dolist (p (list-all-packages))
     11109        (dolist (n (package-names p))
     11110          (setf (gethash n h) t)))
     11111      h))
     11112
     11113  (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
     11114
     11115  (defclass package-inferred-system (system)
     11116    ())
     11117
     11118  ;; For backward compatibility only. To be removed in an upcoming release:
     11119  (defclass package-system (package-inferred-system) ())
     11120
     11121  (defun defpackage-form-p (form)
     11122    (and (consp form)
     11123         (member (car form) *defpackage-forms*)))
     11124
     11125  (defun stream-defpackage-form (stream)
     11126    (loop :for form = (read stream nil nil) :while form
     11127          :when (defpackage-form-p form) :return form))
     11128
     11129  (defun file-defpackage-form (file)
     11130    "Return the first DEFPACKAGE form in FILE."
     11131    (with-input-file (f file)
     11132      (stream-defpackage-form f)))
     11133
     11134  (define-condition package-inferred-system-missing-package-error (system-definition-error)
     11135    ((system :initarg :system :reader error-system)
     11136     (pathname :initarg :pathname :reader error-pathname))
     11137    (:report (lambda (c s)
     11138               (format s (compatfmt "~@<No package form found while ~
     11139                                     trying to define package-inferred-system ~A from file ~A~>")
     11140                       (error-system c) (error-pathname c)))))
     11141
     11142  (defun package-dependencies (defpackage-form)
     11143    "Return a list of packages depended on by the package
     11144defined in DEFPACKAGE-FORM.  A package is depended upon if
     11145the DEFPACKAGE-FORM uses it or imports a symbol from it."
     11146    (assert (defpackage-form-p defpackage-form))
     11147    (remove-duplicates
     11148     (while-collecting (dep)
     11149       (loop* :for (option . arguments) :in (cddr defpackage-form) :do
     11150              (ecase option
     11151                ((:use :mix :reexport :use-reexport :mix-reexport)
     11152                 (dolist (p arguments) (dep (string p))))
     11153                ((:import-from :shadowing-import-from)
     11154                 (dep (string (first arguments))))
     11155                ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
     11156     :from-end t :test 'equal))
     11157
     11158  (defun package-designator-name (package)
     11159    (etypecase package
     11160      (package (package-name package))
     11161      (string package)
     11162      (symbol (string package))))
     11163
     11164  (defun register-system-packages (system packages)
     11165    "Register SYSTEM as providing PACKAGES."
     11166    (let ((name (or (eq system t) (coerce-name system))))
     11167      (dolist (p (ensure-list packages))
     11168        (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
     11169
     11170  (defun package-name-system (package-name)
     11171    "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
     11172otherwise return a default system name computed from PACKAGE-NAME."
     11173    (check-type package-name string)
     11174    (if-let ((system-name (gethash package-name *package-inferred-systems*)))
     11175      system-name
     11176      (string-downcase package-name)))
     11177
     11178  (defun package-inferred-system-file-dependencies (file &optional system)
     11179    (if-let (defpackage-form (file-defpackage-form file))
     11180      (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
     11181      (error 'package-inferred-system-missing-package-error :system system :pathname file)))
     11182
     11183  (defun same-package-inferred-system-p (system name directory subpath dependencies)
     11184    (and (eq (type-of system) 'package-inferred-system)
     11185         (equal (component-name system) name)
     11186         (pathname-equal directory (component-pathname system))
     11187         (equal dependencies (component-sideway-dependencies system))
     11188         (let ((children (component-children system)))
     11189           (and (length=n-p children 1)
     11190                (let ((child (first children)))
     11191                  (and (eq (type-of child) 'cl-source-file)
     11192                       (equal (component-name child) "lisp")
     11193                       (and (slot-boundp child 'relative-pathname)
     11194                            (equal (slot-value child 'relative-pathname) subpath))))))))
     11195
     11196  (defun sysdef-package-inferred-system-search (system)
     11197    (let ((primary (primary-system-name system)))
     11198      (unless (equal primary system)
     11199        (let ((top (find-system primary nil)))
     11200          (when (typep top 'package-inferred-system)
     11201            (if-let (dir (system-source-directory top))
     11202              (let* ((sub (subseq system (1+ (length primary))))
     11203                     (f (probe-file* (subpathname dir sub :type "lisp")
     11204                                     :truename *resolve-symlinks*)))
     11205                (when (file-pathname-p f)
     11206                  (let ((dependencies (package-inferred-system-file-dependencies f system))
     11207                        (previous (cdr (system-registered-p system))))
     11208                    (if (same-package-inferred-system-p previous system dir sub dependencies)
     11209                        previous
     11210                        (eval `(defsystem ,system
     11211                                 :class package-inferred-system
     11212                                 :source-file nil
     11213                                 :pathname ,dir
     11214                                 :depends-on ,dependencies
     11215                                 :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
     11216
     11217(with-upgradability ()
     11218  (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
     11219  (setf *system-definition-search-functions*
     11220        (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
     11221                *system-definition-search-functions*)))
    1081311222;;;; -------------------------------------------------------------------------
    1081411223;;; Backward-compatible interfaces
     
    1089911308        (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
    1090011309       (include-per-user-information nil)
    10901        (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
     11310       (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil))
    1090211311       (source-to-target-mappings nil)
    1090311312       (file-types `(,(compile-file-type)
    1090411313                     "build-report"
    10905                      #+ecl (compile-file-type :type :object)
     11314                     #+(or clasp ecl) (compile-file-type :type :object)
    1090611315                     #+mkcl (compile-file-type :fasl-p nil)
    1090711316                     #+clisp "lib" #+sbcl "cfasl"
    1090811317                     #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
    10909     #+(or clisp ecl mkcl)
     11318    #+(or clasp clisp ecl mkcl)
    1091011319    (when (null map-all-source-files)
    1091111320      (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
     
    1098511394    new-value))
    1098611395;;;; -------------------------------------------------------------------------
    10987 ;;;; Package systems in the style of quick-build or faslpath
    10988 
    10989 (uiop:define-package :asdf/package-inferred-system
    10990   (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
    10991   (:use :uiop/common-lisp :uiop
    10992         :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
    10993         :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
    10994   (:export
    10995    #:package-inferred-system #:sysdef-package-inferred-system-search
    10996    #:package-system ;; backward compatibility only. To be removed.
    10997    #:register-system-packages
    10998    #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
    10999 (in-package :asdf/package-inferred-system)
    11000 
    11001 (with-upgradability ()
    11002   (defparameter *defpackage-forms* '(defpackage define-package))
    11003 
    11004   (defun initial-package-inferred-systems-table ()
    11005     (let ((h (make-hash-table :test 'equal)))
    11006       (dolist (p (list-all-packages))
    11007         (dolist (n (package-names p))
    11008           (setf (gethash n h) t)))
    11009       h))
    11010 
    11011   (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
    11012 
    11013   (defclass package-inferred-system (system)
    11014     ())
    11015 
    11016   ;; For backward compatibility only. To be removed in an upcoming release:
    11017   (defclass package-system (package-inferred-system) ())
    11018 
    11019   (defun defpackage-form-p (form)
    11020     (and (consp form)
    11021          (member (car form) *defpackage-forms*)))
    11022 
    11023   (defun stream-defpackage-form (stream)
    11024     (loop :for form = (read stream nil nil) :while form
    11025           :when (defpackage-form-p form) :return form))
    11026 
    11027   (defun file-defpackage-form (file)
    11028     "Return the first DEFPACKAGE form in FILE."
    11029     (with-input-file (f file)
    11030       (stream-defpackage-form f)))
    11031 
    11032   (define-condition package-inferred-system-missing-package-error (system-definition-error)
    11033     ((system :initarg :system :reader error-system)
    11034      (pathname :initarg :pathname :reader error-pathname))
    11035     (:report (lambda (c s)
    11036                (format s (compatfmt "~@<No package form found while ~
    11037                                      trying to define package-inferred-system ~A from file ~A~>")
    11038                        (error-system c) (error-pathname c)))))
    11039 
    11040   (defun package-dependencies (defpackage-form)
    11041     "Return a list of packages depended on by the package
    11042 defined in DEFPACKAGE-FORM.  A package is depended upon if
    11043 the DEFPACKAGE-FORM uses it or imports a symbol from it."
    11044     (assert (defpackage-form-p defpackage-form))
    11045     (remove-duplicates
    11046      (while-collecting (dep)
    11047        (loop* :for (option . arguments) :in (cddr defpackage-form) :do
    11048               (ecase option
    11049                 ((:use :mix :reexport :use-reexport :mix-reexport)
    11050                  (dolist (p arguments) (dep (string p))))
    11051                 ((:import-from :shadowing-import-from)
    11052                  (dep (string (first arguments))))
    11053                 ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
    11054      :from-end t :test 'equal))
    11055 
    11056   (defun package-designator-name (package)
    11057     (etypecase package
    11058       (package (package-name package))
    11059       (string package)
    11060       (symbol (string package))))
    11061 
    11062   (defun register-system-packages (system packages)
    11063     "Register SYSTEM as providing PACKAGES."
    11064     (let ((name (or (eq system t) (coerce-name system))))
    11065       (dolist (p (ensure-list packages))
    11066         (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
    11067 
    11068   (defun package-name-system (package-name)
    11069     "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
    11070 otherwise return a default system name computed from PACKAGE-NAME."
    11071     (check-type package-name string)
    11072     (if-let ((system-name (gethash package-name *package-inferred-systems*)))
    11073       system-name
    11074       (string-downcase package-name)))
    11075 
    11076   (defun package-inferred-system-file-dependencies (file &optional system)
    11077     (if-let (defpackage-form (file-defpackage-form file))
    11078       (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
    11079       (error 'package-inferred-system-missing-package-error :system system :pathname file)))
    11080 
    11081   (defun same-package-inferred-system-p (system name directory subpath dependencies)
    11082     (and (eq (type-of system) 'package-inferred-system)
    11083          (equal (component-name system) name)
    11084          (pathname-equal directory (component-pathname system))
    11085          (equal dependencies (component-sideway-dependencies system))
    11086          (let ((children (component-children system)))
    11087            (and (length=n-p children 1)
    11088                 (let ((child (first children)))
    11089                   (and (eq (type-of child) 'cl-source-file)
    11090                        (equal (component-name child) "lisp")
    11091                        (and (slot-boundp child 'relative-pathname)
    11092                             (equal (slot-value child 'relative-pathname) subpath))))))))
    11093 
    11094   (defun sysdef-package-inferred-system-search (system)
    11095     (let ((primary (primary-system-name system)))
    11096       (unless (equal primary system)
    11097         (let ((top (find-system primary nil)))
    11098           (when (typep top 'package-inferred-system)
    11099             (if-let (dir (system-source-directory top))
    11100               (let* ((sub (subseq system (1+ (length primary))))
    11101                      (f (probe-file* (subpathname dir sub :type "lisp")
    11102                                      :truename *resolve-symlinks*)))
    11103                 (when (file-pathname-p f)
    11104                   (let ((dependencies (package-inferred-system-file-dependencies f system))
    11105                         (previous (cdr (system-registered-p system))))
    11106                     (if (same-package-inferred-system-p previous system dir sub dependencies)
    11107                         previous
    11108                         (eval `(defsystem ,system
    11109                                  :class package-inferred-system
    11110                                  :source-file nil
    11111                                  :pathname ,dir
    11112                                  :depends-on ,dependencies
    11113                                  :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
    11114 
    11115 (with-upgradability ()
    11116   (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
    11117   (setf *system-definition-search-functions*
    11118         (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
    11119                 *system-definition-search-functions*)))
     11396;;; Internal hacks for backward-compatibility
     11397
     11398(uiop/package:define-package :asdf/backward-internals
     11399  (:recycle :asdf/backward-internals :asdf)
     11400  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
     11401  (:export ;; for internal use
     11402   #:make-sub-operation
     11403   #:load-sysdef #:make-temporary-package))
     11404(in-package :asdf/backward-internals)
     11405
     11406(when-upgrading (:when (fboundp 'make-sub-operation))
     11407  (defun make-sub-operation (c o dep-c dep-o)
     11408    (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
     11409
     11410;;;; load-sysdef
     11411(with-upgradability ()
     11412  (defun load-sysdef (name pathname)
     11413    (load-asd pathname :name name))
     11414
     11415  (defun make-temporary-package ()
     11416    ;; For loading a .asd file, we don't make a temporary package anymore,
     11417    ;; but use ASDF-USER. I'd like to have this function do this,
     11418    ;; but since whoever uses it is likely to delete-package the result afterwards,
     11419    ;; this would be a bad idea, so preserve the old behavior.
     11420    (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
     11421
    1112011422;;;; ---------------------------------------------------------------------------
    1112111423;;;; Handle ASDF package upgrade, including implementation-dependent magic.
     
    1113611438  ;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
    1113711439  (:export
    11138    #:defsystem #:find-system #:locate-system #:coerce-name #:primary-system-name
     11440   #:defsystem #:find-system #:load-asd #:locate-system #:coerce-name #:primary-system-name
    1113911441   #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
    1114011442   #:system-definition-pathname
     
    1115611458   #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
    1115711459   #:program-system #:make-build
    11158    #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op
    1115911460   #:basic-compile-bundle-op #:prepare-bundle-op
    1116011461   #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
     
    1117811479   #:static-file #:doc-file #:html-file
    1117911480   #:file-type #:source-file-type
     11481
     11482   #:register-preloaded-system #:sysdef-preloaded-system-search
     11483   #:register-immutable-system #:sysdef-immutable-system-search
    1118011484
    1118111485   #:package-inferred-system #:register-system-packages
     
    1122311527   #:*compile-file-failure-behaviour*
    1122411528   #:*resolve-symlinks*
    11225    #:*load-system-operation* #:*immutable-systems*
     11529   #:*load-system-operation*
    1122611530   #:*asdf-verbose* ;; unused. For backward-compatibility only.
    1122711531   #:*verbose-out*
     
    1130711611(uiop/package:define-package :asdf/footer
    1130811612  (:recycle :asdf/footer :asdf)
    11309   (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/operate :asdf/bundle))
     11613  (:use :uiop/common-lisp :uiop
     11614        :asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle))
    1131011615(in-package :asdf/footer)
    1131111616
    1131211617;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
    11313 #+(or abcl clisp clozure cmu ecl mkcl sbcl)
     11618#+(or abcl clasp clisp clozure cmu ecl mkcl sbcl)
    1131411619(with-upgradability ()
    1131511620  (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
    1131611621    (eval `(pushnew 'module-provide-asdf
    1131711622                    #+abcl sys::*module-provider-functions*
     11623                    #+(or clasp cmu ecl) ext:*module-provider-functions*
    1131811624                    #+clisp ,x
    1131911625                    #+clozure ccl:*module-provider-functions*
    11320                     #+(or cmu ecl) ext:*module-provider-functions*
    1132111626                    #+mkcl mk-ext:*module-provider-functions*
    1132211627                    #+sbcl sb-ext:*module-provider-functions*)))
    1132311628
    11324   #+(or ecl mkcl)
     11629  #+(or clasp ecl mkcl)
    1132511630  (progn
    1132611631    (pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car)
    1132711632
    11328     #+(or (and ecl win32) (and mkcl windows))
    11329     (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
    11330       (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
    11331 
    11332     (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
    11333           (loop :for f :in #+ecl ext:*module-provider-functions*
     11633    #+(or (and clasp windows) (and ecl win32) (and mkcl windows))
     11634    (unless (assoc "asd" #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
     11635      (appendf #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
     11636
     11637    (setf #+(or clasp ecl) ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
     11638          (loop :for f :in #+(or clasp ecl) ext:*module-provider-functions*
    1133411639                #+mkcl mk-ext::*module-provider-functions*
    1133511640                :collect
     
    1133711642                    #'(lambda (name)
    1133811643                        (let ((l (multiple-value-list (funcall f name))))
    11339                           (and (first l) (register-pre-built-system (coerce-name name)))
     11644                          (and (first l) (register-preloaded-system (coerce-name name)))
    1134011645                          (values-list l))))))))
    1134111646
     
    1136211667(when *load-verbose*
    1136311668  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
    11364 
Note: See TracChangeset for help on using the changeset viewer.