Changeset 14838


Ignore:
Timestamp:
10/21/15 21:23:04 (6 years ago)
Author:
Mark Evenson
Message:

Upgrade to asdf-3.1.6

N.b. one will have to do a full clean of existing fasls for this
change to compile. Otherwise one gets errors about "wrong number of
arguments for DEFSETF".

N.b. the configuration directory under Windows has changed in
incompatible ways. We intend to "fix" this in a backwards compatible
manner before releasing a version of ABCL based on this change but
wish to get asdf-3.1.6 out into circulation as a first step.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r14734 r14838  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
    2 ;;; This is ASDF 3.1.4: Another System Definition Facility.
     2;;; This is ASDF 3.1.6: 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.
     
    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
     
    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!
    18801937        #+lispworks (hcl:get-working-directory)
    18811938        #+mkcl (mk-ext:getcwd)
     
    18871944    "Change current directory, as per POSIX chdir(2), to a given pathname object"
    18881945    (if-let (x (pathname x))
    1889       #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
     1946      #+(or abcl genera xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
    18901947      #+allegro (excl:chdir x)
    18911948      #+clisp (ext:cd x)
     
    18941951      #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
    18951952                     (error "Could not set current directory to ~A" x))
    1896       #+ecl (ext:chdir x)
     1953      #+(or clasp ecl) (ext:chdir x)
    18971954      #+gcl (system:chdir x)
    1898       #+genera (setf *default-pathname-defaults* x)
    18991955      #+lispworks (hcl:change-directory x)
    19001956      #+mkcl (mk-ext:chdir x)
    19011957      #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
    1902       #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl)
     1958      #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
    19031959      (error "chdir not supported on your implementation"))))
    19041960
     
    20812137  (defparameter *unspecific-pathname-type*
    20822138    #+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific
    2083     #+(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
    20842140    "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
    20852141
     
    21922248
    21932249  (defmacro with-pathname-defaults ((&optional defaults) &body body)
    2194     "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* are as neutral as possible
    2195 when merging, making or parsing pathnames"
    2196     `(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)))
    21972258
    21982259
     
    23932454
    23942455Unix syntax is used whether or not the underlying system is Unix;
    2395 on such non-Unix systems it is only usable but for relative pathnames;
    2396 but especially to manipulate relative pathnames portably, it is of crucial
    2397 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.
    23982459This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
    23992460
     
    241324743- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
    24142475
    2415 Directory components with an empty name the name . are removed.
    2416 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,
    24172478which must be one of :BACK or :UP and defaults to :BACK.
    24182479
     
    25612622         (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
    25622623         (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
    2563          (with-pathname-defaults ()
     2624         (with-pathname-defaults (*nil-pathname*)
    25642625           (let ((enough (enough-namestring maybe-subpath base-pathname)))
    25652626             (and (relative-pathname-p enough) (pathname enough))))))
     
    26452706    "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
    26462707added to its DIRECTORY component. This is useful for output translations."
    2647     #+(or unix abcl)
    2648     (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
    2649       (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))))
    26502712    (let* ((root (pathname-root pathname))
    26512713           (wild-root (wilden root))
     
    27592821        #+sbcl (sb-ext:native-namestring p)
    27602822        #-(or clozure cmu sbcl scl)
    2761         (if (os-unix-p) (unix-namestring p)
    2762             (namestring p)))))
     2823        (os-cond
     2824         ((os-unix-p) (unix-namestring p))
     2825         (t (namestring p))))))
    27632826
    27642827  (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
     
    27722835                 #+sbcl (sb-ext:parse-native-namestring string)
    27732836                 #-(or clozure sbcl)
    2774                  (if (os-unix-p)
    2775                      (parse-unix-namestring string :ensure-directory ensure-directory)
    2776                      (parse-namestring string)))))
     2837                 (os-cond
     2838                  ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory))
     2839                  (t (parse-namestring string))))))
    27772840           (pathname
    27782841             (if ensure-directory
     
    27852848(with-upgradability ()
    27862849  (defun truename* (p)
    2787     "Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts"
    2788     ;; avoids both logical-pathname merging and physical resolution issues
    2789     (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)))))))
    27902858
    27912859  (defun safe-file-write-date (pathname)
     
    28082876If it exists, return its truename is ENSURE-PATHNAME is true,
    28092877or the original (parsed) pathname if it is false (the default)."
    2810     (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
    2811       (etypecase p
    2812         (null nil)
    2813         (string (probe-file* (parse-namestring p) :truename truename))
    2814         (pathname
    2815          (and (not (wild-pathname-p p))
    2816               (handler-case
    2817                   (or
    2818                    #+allegro
    2819                    (probe-file p :follow-symlinks truename)
    2820                    #+gcl
    2821                    (if truename
    2822                        (truename* p)
    2823                        (let ((kind (car (si::stat p))))
    2824                          (when (eq kind :link)
    2825                            (setf kind (ignore-errors (car (si::stat (truename* p))))))
    2826                          (ecase kind
    2827                            ((nil) nil)
    2828                            ((:file :link)
    2829                             (cond
    2830                               ((file-pathname-p p) p)
    2831                               ((directory-pathname-p p)
    2832                                (subpathname p (car (last (pathname-directory p)))))))
    2833                            (:directory (ensure-directory-pathname p)))))
    2834                    #+clisp
    2835                    #.(flet ((probe (probe)
    2836                               `(let ((foundtrue ,probe))
    2837                                  (cond
    2838                                    (truename foundtrue)
    2839                                    (foundtrue p)))))
    2840                        (let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
    2841                               (pp (find-symbol* '#:probe-pathname :ext nil))
    2842                               (resolve (if pp
    2843                                            `(ignore-errors (,pp p))
    2844                                            '(or (truename* p)
    2845                                              (truename* (ignore-errors (ensure-directory-pathname p)))))))
    2846                          (if fs
    2847                              `(if truename
    2848                                   ,resolve
    2849                                   (and (ignore-errors (,fs p)) p))
    2850                              (probe resolve))))
    2851                    #-(or allegro clisp gcl)
    2852                    (if truename
    2853                        (probe-file p)
    2854                        (ignore-errors
    2855                         (let ((pp (physicalize-pathname p)))
    2856                           (and
    2857                            #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
    2858                            #+(and lispworks unix) (system:get-file-stat pp)
    2859                            #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
    2860                            #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
    2861                            p)))))
    2862                 (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))))))
    28632926
    28642927  (defun directory-exists-p (x)
     
    30553118                  on-error
    30563119                  defaults type dot-dot namestring
     3120                  empty-is-nil
    30573121                  want-pathname
    30583122                  want-logical want-physical ensure-physical
     
    30983162which is also the order in the lambda-list:
    30993163
     3164EMPTY-IS-NIL returns NIL if the argument is an empty string.
    31003165WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
    31013166Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
     
    31373202            ((or null pathname))
    31383203            (string
     3204             (when (and (emptyp p) empty-is-nil)
     3205               (return-from ensure-pathname nil))
    31393206             (setf p (case namestring
    31403207                       ((:unix nil)
     
    32193286  (defun inter-directory-separator ()
    32203287    "What character does the current OS conventionally uses to separate directories?"
    3221     (if (os-unix-p) #\: #\;))
     3288    (os-cond ((os-unix-p) #\:) (t #\;)))
    32223289
    32233290  (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
    32243291    "Given a string of pathnames specified in native OS syntax, separate them in a list,
    3225 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."
    32263294    (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
    3227           :collect (apply 'parse-native-namestring namestring constraints)))
     3295          :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints))))
    32283296
    32293297  (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
     
    32383306  (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
    32393307    "Extract a list of pathname from a user-configured environment variable, as per native OS,
    3240 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."))
    32413312    (apply 'split-native-pathnames-string (getenvp x)
    32423313           :on-error (or on-error
    32433314                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
     3315           :empty-is-nil t
    32443316           constraints))
    32453317  (defun getenv-absolute-directory (x)
     
    32493321  (defun getenv-absolute-directories (x)
    32503322    "Extract a list of absolute directories from a user-configured environment variable,
    3251 as per native OS"
     3323as per native OS.  Any empty entries in the environment variable X will be returned as
     3324NILs."
    32523325    (getenv-pathnames x :want-absolute t :ensure-directory t))
    32533326
     
    32553328    "Where are the system files of the current installation of the CL implementation?"
    32563329    (declare (ignorable truename))
    3257     #+(or clozure ecl gcl mkcl sbcl)
    32583330    (let ((dir
    3259             (ignore-errors
    3260              #+clozure #p"ccl:"
    3261              #+(or ecl mkcl) #p"SYS:"
    3262              #+gcl system::*system-directory*
    3263              #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
    3264                       (funcall it)
    3265                       (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
     3331            #+abcl extensions:*lisp-home*
     3332            #+(or allegro clasp ecl mkcl) #p"SYS:"
     3333            ;;#+clisp custom:*lib-directory* ; causes failure in asdf-pathname-test(!)
     3334            #+clozure #p"ccl:"
     3335            #+cmu (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
     3336            #+gcl system::*system-directory*
     3337            #+lispworks lispworks:*lispworks-directory*
     3338            #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
     3339                     (funcall it)
     3340                     (getenv-pathname "SBCL_HOME" :ensure-directory t))
     3341            #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/")))
     3342            #+xcl ext:*xcl-home*))
    32663343      (if (and dir truename)
    32673344          (truename* dir)
     
    32893366        (ensure-directories-exist (physicalize-pathname pathname)))))
    32903367
     3368  (defun delete-file-if-exists (x)
     3369    "Delete a file X if it already exists"
     3370    (when x (handler-case (delete-file x) (file-error () nil))))
     3371
    32913372  (defun rename-file-overwriting-target (source target)
    32923373    "Rename a file, overwriting any previous file with the TARGET name,
     
    32953376    (progn (funcall 'require "syscalls")
    32963377           (symbol-call :posix :copy-file source target :method :rename))
     3378    #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic
    32973379    #-clisp
    32983380    (rename-file source target
    3299                  #+(or clozure ecl) :if-exists #+clozure :rename-and-delete #+ecl t))
    3300 
    3301   (defun delete-file-if-exists (x)
    3302     "Delete a file X if it already exists"
    3303     (when x (handler-case (delete-file x) (file-error () nil))))
     3381                 #+(or clasp clozure ecl) :if-exists #+clozure :rename-and-delete #+(or clasp ecl) t))
    33043382
    33053383  (defun delete-empty-directory (directory-pathname)
     
    33173395                                    directory-pathname (unix:get-unix-error-msg errno))))
    33183396    #+cormanlisp (win32:delete-directory directory-pathname)
    3319     #+ecl (si:rmdir directory-pathname)
     3397    #+(or clasp ecl) (si:rmdir directory-pathname)
    33203398    #+genera (fs:delete-directory directory-pathname)
    33213399    #+lispworks (lw:delete-directory directory-pathname)
     
    33253403               `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
    33263404    #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
    3327     #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
     3405    #-(or abcl allegro clasp clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
    33283406    (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
    33293407
     
    33463424                 (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
    33473425       (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
    3348               'delete-filesystem-tree directory-pathname))
     3426              'delete-directory-tree directory-pathname))
    33493427      ((not validatep)
    33503428       (error "~S was asked to delete ~S but was not provided a validation predicate"
    3351               'delete-filesystem-tree directory-pathname))
     3429              'delete-directory-tree directory-pathname))
    33523430      ((not (call-function validate directory-pathname))
    33533431       (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
    3354               'delete-filesystem-tree directory-pathname validate))
     3432              'delete-directory-tree directory-pathname validate))
    33553433      ((not (directory-exists-p directory-pathname))
    33563434       (ecase if-does-not-exist
    33573435         (:error
    33583436          (error "~S was asked to delete ~S but the directory does not exist"
    3359               'delete-filesystem-tree directory-pathname))
     3437              'delete-directory-tree directory-pathname))
    33603438         (:ignore nil)))
    33613439      #-(or allegro cmu clozure genera sbcl scl)
     
    33823460               (map () 'delete-file (directory-files d))
    33833461               (delete-empty-directory d)))))))
    3384 
    33853462;;;; ---------------------------------------------------------------------------
    33863463;;;; Utilities related to streams
     
    34313508          #.(or #+clozure 'ccl::*stdin*
    34323509                #+(or cmu scl) 'system:*stdin*
    3433                 #+ecl 'ext::+process-standard-input+
     3510                #+(or clasp ecl) 'ext::+process-standard-input+
    34343511                #+sbcl 'sb-sys:*stdin*
    34353512                '*standard-input*)))
     
    34423519          #.(or #+clozure 'ccl::*stdout*
    34433520                #+(or cmu scl) 'system:*stdout*
    3444                 #+ecl 'ext::+process-standard-output+
     3521                #+(or clasp ecl) 'ext::+process-standard-output+
    34453522                #+sbcl 'sb-sys:*stdout*
    34463523                '*standard-output*)))
     
    34543531                #+clozure 'ccl::*stderr*
    34553532                #+(or cmu scl) 'system:*stderr*
    3456                 #+ecl 'ext::+process-error-output+
     3533                #+(or clasp ecl) 'ext::+process-error-output+
    34573534                #+sbcl 'sb-sys:*stderr*
    34583535                '*error-output*)))
     
    36623739    "Pathname to a bit bucket device that discards any information written to it
    36633740and always returns EOF when read from"
    3664     (cond
     3741    (os-cond
    36653742      ((os-unix-p) #p"/dev/null")
    36663743      ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
     
    39133990  (defun default-temporary-directory ()
    39143991    "Return a default directory to use for temporary files"
    3915     (or
    3916      (when (os-unix-p)
     3992    (os-cond
     3993      ((os-unix-p)
    39173994       (or (getenv-pathname "TMPDIR" :ensure-directory t)
    39183995           (parse-native-namestring "/tmp/")))
    3919      (when (os-windows-p)
     3996      ((os-windows-p)
    39203997       (getenv-pathname "TEMP" :ensure-directory t))
    3921      (subpathname (user-homedir-pathname) "tmp/")))
     3998      (t (subpathname (user-homedir-pathname) "tmp/"))))
    39223999
    39234000  (defvar *temporary-directory* nil "User-configurable location for temporary files")
     
    39614038    (assert (or want-stream-p want-pathname-p))
    39624039    (loop
    3963       :with prefix = (native-namestring
    3964                       (ensure-absolute-pathname
    3965                        (or prefix "tmp")
    3966                        (or (ensure-pathname directory :namestring :native :ensure-directory t)
    3967                            #'temporary-directory)))
    3968       :with results = ()
     4040      :with prefix-pn = (ensure-absolute-pathname
     4041                         (or prefix "tmp")
     4042                         (or (ensure-pathname directory :namestring :native :ensure-directory t)
     4043                             #'temporary-directory))
     4044      :with prefix-nns = (native-namestring prefix-pn)
     4045      :with results = (progn (ensure-directories-exist prefix-pn)
     4046                             ())
    39694047      :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
    39704048      :for pathname = (parse-native-namestring
    3971                        (format nil "~A~36R~@[~A~]~@[.~A~]" prefix counter suffix type))
     4049                       (format nil "~A~36R~@[~A~]~@[.~A~]"
     4050                               prefix-nns counter suffix (unless (eq type :unspecific) type)))
    39724051      :for okp = nil :do
    39734052        ;; TODO: on Unix, do something about umask
     
    39784057        (unwind-protect
    39794058             (progn
     4059               (ensure-directories-exist pathname)
    39804060               (with-open-file (stream pathname
    39814061                                       :direction direction
     
    39864066                   (setf okp pathname)
    39874067                   (when want-stream-p
    3988                      (setf results
    3989                            (multiple-value-list
    3990                             (if want-pathname-p
    3991                                 (funcall thunk stream pathname)
    3992                                 (funcall thunk stream)))))))
    3993                (when okp
    3994                  (unless want-stream-p
    3995                    (setf results (multiple-value-list (call-function thunk pathname))))
    3996                  (when after
    3997                    (setf results (multiple-value-list (call-function after pathname))))
    3998                  (return (apply 'values results))))
     4068                     ;; Note: can't return directly from within with-open-file
     4069                     ;; or the non-local return causes the file creation to be undone.
     4070                     (setf results (multiple-value-list
     4071                                    (if want-pathname-p
     4072                                        (funcall thunk stream pathname)
     4073                                        (funcall thunk stream)))))))
     4074               (cond
     4075                 ((not okp) nil)
     4076                 (after (return (call-function after okp)))
     4077                 ((and want-pathname-p (not want-stream-p)) (return (call-function thunk okp)))
     4078                 (t (return (apply 'values results)))))
    39994079          (when (and okp (not (call-function keep)))
    40004080            (ignore-errors (delete-file-if-exists okp))))))
     
    40574137
    40584138  (defun tmpize-pathname (x)
    4059     "Return a new pathname modified from X by adding a trivial deterministic suffix"
    4060     (add-pathname-suffix x "-TMP"))
     4139    "Return a new pathname modified from X by adding a trivial random suffix.
     4140A new empty file with said temporary pathname is created, to ensure there is no
     4141clash with any concurrent process attempting the same thing."
     4142    (let* ((px (ensure-pathname x))
     4143           (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp"))
     4144           (directory (translate-logical-pathname (pathname-directory-pathname px))))
     4145      (get-temporary-file :directory directory :prefix prefix :type (pathname-type px))))
    40614146
    40624147  (defun call-with-staging-pathname (pathname fun)
     
    40764161    "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
    40774162    `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
    4078 
    40794163;;;; -------------------------------------------------------------------------
    40804164;;;; Starting, Stopping, Dumping a Lisp image
     
    41444228    #+(or abcl xcl) (ext:quit :status code)
    41454229    #+allegro (excl:exit code :quiet t)
     4230    #+(or clasp ecl) (si:quit code)
    41464231    #+clisp (ext:quit code)
    41474232    #+clozure (ccl:quit code)
    41484233    #+cormanlisp (win32:exitprocess code)
    41494234    #+(or cmu scl) (unix:unix-exit code)
    4150     #+ecl (si:quit code)
    41514235    #+gcl (system:quit code)
    41524236    #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
     
    41594243                 (exit `(,exit :code code :abort (not finish-output)))
    41604244                 (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
    4161     #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
     4245    #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    41624246    (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
    41634247
     
    41864270        :count (or count t)
    41874271        :all t))
     4272    #+(or clasp ecl mkcl)
     4273    (let* ((top (si:ihs-top))
     4274           (repeats (if count (min top count) top))
     4275           (backtrace (loop :for ihs :from 0 :below top
     4276                            :collect (list (si::ihs-fun ihs)
     4277                                           (si::ihs-env ihs)))))
     4278      (loop :for i :from 0 :below repeats
     4279            :for frame :in (nreverse backtrace) :do
     4280              (safe-format! stream "~&~D: ~S~%" i frame)))
    41884281    #+clisp
    41894282    (system::print-backtrace :out stream :limit count)
     
    41974290          (debug:*debug-print-length* *print-length*))
    41984291      (debug:backtrace (or count most-positive-fixnum) stream))
    4199     #+(or ecl mkcl)
    4200     (let* ((top (si:ihs-top))
    4201            (repeats (if count (min top count) top))
    4202            (backtrace (loop :for ihs :from 0 :below top
    4203                             :collect (list (si::ihs-fun ihs)
    4204                                            (si::ihs-env ihs)))))
    4205       (loop :for i :from 0 :below repeats
    4206             :for frame :in (nreverse backtrace) :do
    4207               (safe-format! stream "~&~D: ~S~%" i frame)))
    42084292    #+gcl
    42094293    (let ((*debug-io* stream))
     
    42214305      (dbg:bug-backtrace nil))
    42224306    #+sbcl
    4223     (sb-debug:backtrace
    4224      #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
    4225      stream)
     4307    (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum))
    42264308    #+xcl
    42274309    (loop :for i :from 0 :below (or count most-positive-fixnum)
     
    43054387    #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
    43064388    #+allegro (sys:command-line-arguments) ; default: :application t
     4389    #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
    43074390    #+clisp (coerce (ext:argv) 'list)
    43084391    #+clozure ccl:*command-line-argument-list*
    43094392    #+(or cmu scl) extensions:*command-line-strings*
    4310     #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
    43114393    #+gcl si:*command-args*
    43124394    #+(or genera mcl) nil
     
    43154397    #+sbcl sb-ext:*posix-argv*
    43164398    #+xcl system:*argv*
    4317     #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
     4399    #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    43184400    (error "raw-command-line-arguments not implemented yet"))
    43194401
     
    43464428       (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl)
    43474429           (first (raw-command-line-arguments))
    4348            #+ecl (si:argv 0) #+mkcl (mkcl:argv 0)))
     4430           #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0)))
    43494431      (t ;; argv[0] is the name of the interpreter.
    43504432       ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
     
    45064588    ;; only if we also track the object files that constitute the "current" image,
    45074589    ;; and otherwise simulate dump-image, including quitting at the end.
    4508     #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
    4509     #+(or ecl mkcl)
     4590    #-(or clasp ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
     4591    #+(or clasp ecl mkcl)
    45104592    (let ((epilogue-code
    4511             (if no-uiop
    4512                 epilogue-code
    4513                 (let ((forms
    4514                         (append
    4515                          (when epilogue-code `(,epilogue-code))
    4516                          (when postludep `((setf *image-postlude* ',postlude)))
    4517                          (when preludep `((setf *image-prelude* ',prelude)))
    4518                          (when entry-point-p `((setf *image-entry-point* ',entry-point)))
    4519                          (case kind
    4520                            ((:image)
    4521                             (setf kind :program) ;; to ECL, it's just another program.
    4522                             `((setf *image-dumped-p* t)
    4523                               (si::top-level #+ecl t) (quit)))
    4524                            ((:program)
    4525                             `((setf *image-dumped-p* :executable)
    4526                               (shell-boolean-exit
    4527                                (restore-image))))))))
    4528                   (when forms `(progn ,@forms))))))
    4529       #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
    4530       (apply #+ecl 'c::builder #+ecl kind
     4593           (if no-uiop
     4594               epilogue-code
     4595               (let ((forms
     4596                      (append
     4597                       (when epilogue-code `(,epilogue-code))
     4598                       (when postludep `((setf *image-postlude* ',postlude)))
     4599                       (when preludep `((setf *image-prelude* ',prelude)))
     4600                       (when entry-point-p `((setf *image-entry-point* ',entry-point)))
     4601                       (case kind
     4602                         ((:image)
     4603                          (setf kind :program) ;; to ECL, it's just another program.
     4604                          `((setf *image-dumped-p* t)
     4605                            (si::top-level #+(or clasp ecl) t) (quit)))
     4606                         ((:program)
     4607                          `((setf *image-dumped-p* :executable)
     4608                            (shell-boolean-exit
     4609                             (restore-image))))))))
     4610                 (when forms `(progn ,@forms))))))
     4611      #+(or clasp ecl) (check-type kind (member :dll :lib :static-library :program :object :fasl))
     4612      (apply #+clasp 'cmp:builder #+clasp kind
     4613             #+(and ecl (not clasp)) 'c::builder #+(and ecl (not clasp)) kind
    45314614             #+mkcl (ecase kind
    45324615                      ((:dll) 'compiler::build-shared-library)
     
    45354618                      ((:program) 'compiler::build-program))
    45364619             (pathname destination)
    4537              #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files)
    4538              #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind)
     4620             #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+(or clasp ecl) extra-object-files)
     4621             #+(or clasp ecl) :init-name #+(or clasp ecl) (c::compute-init-name (or output-name destination) :kind kind)
    45394622             (append
    45404623              (when prologue-code `(:prologue-code ,prologue-code))
     
    45834666       ((and good-chars bad-chars)
    45844667        (error "only one of good-chars and bad-chars can be provided"))
    4585        ((functionp good-chars)
     4668       ((typep good-chars 'function)
    45864669        (complement good-chars))
    4587        ((functionp bad-chars)
     4670       ((typep bad-chars 'function)
    45884671        bad-chars)
    45894672       ((and good-chars (typep good-chars 'sequence))
     
    46284711             (issue (char x i)) (setf i i+1))))))
    46294712
     4713  (defun easy-windows-character-p (x)
     4714    "Is X an \"easy\" character that does not require quoting by the shell?"
     4715    (or (alphanumericp x) (find x "+-_.,@:/=")))
     4716
    46304717  (defun escape-windows-token (token &optional s)
    46314718    "Escape a string TOKEN within double-quotes if needed
    46324719for use within a MS Windows command-line, outputing to S."
    4633     (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
     4720    (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
    46344721                        :escaper 'escape-windows-token-within-double-quotes))
    46354722
     
    46464733  (defun easy-sh-character-p (x)
    46474734    "Is X an \"easy\" character that does not require quoting by the shell?"
    4648     (or (alphanumericp x) (find x "+-_.,%@:/")))
     4735    (or (alphanumericp x) (find x "+-_.,%@:/=")))
    46494736
    46504737  (defun escape-sh-token (token &optional s)
     
    46564743  (defun escape-shell-token (token &optional s)
    46574744    "Escape a token for the current operating system shell"
    4658     (cond
     4745    (os-cond
    46594746      ((os-unix-p) (escape-sh-token token s))
    46604747      ((os-windows-p) (escape-windows-token token s))))
     
    48794966     (process :initform nil :initarg :process :reader subprocess-error-process))
    48804967    (:report (lambda (condition stream)
    4881                (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
     4968               (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
    48824969                       (subprocess-error-process condition)
    48834970                       (subprocess-error-command condition)
    48844971                       (subprocess-error-code condition)))))
     4972
     4973  ;;; find CMD.exe on windows
     4974  (defun %cmd-shell-pathname ()
     4975    (os-cond
     4976     ((os-windows-p)
     4977      (strcat (native-namestring (getenv-absolute-directory "WINDIR"))
     4978              "System32\\cmd.exe"))
     4979     (t
     4980      (error "CMD.EXE is not the command shell for this OS."))))
    48854981
    48864982  ;;; Internal helpers for run-program
     
    48934989      #+os-windows
    48944990      (string
    4895        #+mkcl (list "cmd" '#:/c command)
     4991       #+mkcl (list "cmd" "/c" command)
    48964992       ;; NB: We do NOT add cmd /c here. You might want to.
    48974993       #+(or allegro clisp) command
     
    49004996       ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
    49014997       #+clozure (cons "cmd" (strcat "/c " command))
     4998       #+sbcl (list (%cmd-shell-pathname) "/c" command)
    49024999       ;; NB: On other Windows implementations, this is utterly bogus
    49035000       ;; except in the most trivial cases where no quoting is needed.
    49045001       ;; Use at your own risk.
    4905        #-(or allegro clisp clozure mkcl) (list "cmd" "/c" command))
     5002       #-(or allegro clisp clozure mkcl sbcl) (list "cmd" "/c" command))
    49065003      #+os-windows
    49075004      (list
     
    49305027       #+allegro nil
    49315028       #+clisp :terminal
    4932        #+(or clozure cmu ecl mkcl sbcl scl) t)
    4933       #+(or allegro clozure cmu ecl lispworks mkcl sbcl scl)
     5029       #+(or clasp clozure cmu ecl mkcl sbcl scl) t)
     5030      #+(or allegro clasp clozure cmu ecl lispworks mkcl sbcl scl)
    49345031      ((eql :output)
    49355032       (if (eq role :error-output)
     
    49615058It returns a process-info plist with possible keys:
    49625059     PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
    4963     ;; NB: these implementations have unix vs windows set at compile-time.
     5060    ;; NB: these implementations have Unix vs Windows set at compile-time.
    49645061    (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
    49655062    (assert (not (and wait (member :stream (list input output error-output)))))
    4966     #-(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl)
     5063    #-(or allegro clasp clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl)
    49675064    (progn command keys directory
    49685065           (error "run-program not available"))
    4969     #+(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl)
     5066    #+(or allegro clasp clisp clozure cmu ecl (and lispworks os-unix) mkcl sbcl scl)
    49705067    (let* ((%command (%normalize-command command))
    49715068           (%input (%normalize-io-specifier input :input))
    49725069           (%output (%normalize-io-specifier output :output))
    49735070           (%error-output (%normalize-io-specifier error-output :error-output))
    4974            #+(and allegro os-windows) (interactive (%interactivep input output error-output))
     5071           #+(and allegro os-windows)
     5072           (interactive (%interactivep input output error-output))
    49755073           (process*
    4976              #+allegro
    4977              (multiple-value-list
     5074             (nest
     5075              #+clisp (progn
     5076                        ;; clisp cannot redirect stderr, so check we don't.
     5077                        ;; Also, since we now always return a code, we cannot use this code path
     5078                        ;; if any of the input, output or error-output is :stream.
     5079                        (assert (eq %error-output :terminal)))
     5080              #-(or allegro mkcl sbcl) (with-current-directory (directory))
     5081              #+(or allegro clasp clisp ecl lispworks mkcl) (multiple-value-list)
    49785082              (apply
    4979                'excl:run-shell-command
    4980                #+os-unix (coerce (cons (first %command) %command) 'vector)
    4981                #+os-windows %command
    4982                :input %input
    4983                :output %output
    4984                :error-output %error-output
    4985                :directory directory :wait wait
    4986                #+os-windows :show-window #+os-windows (if interactive nil :hide)
    4987                :allow-other-keys t keys))
    4988              #-allegro
    4989              (with-current-directory (#-(or sbcl mkcl) directory)
     5083               #+allegro 'excl:run-shell-command
     5084               #+(and allegro os-unix) (coerce (cons (first %command) %command) 'vector)
     5085               #+(and allegro os-windows) %command
    49905086               #+clisp
    4991                (flet ((run (f x &rest args)
    4992                         (multiple-value-list
    4993                          (apply f x :input %input :output %output
    4994                                     :allow-other-keys t `(,@args ,@keys)))))
    4995                  (assert (eq %error-output :terminal))
    4996                  ;;; since we now always return a code, we can't use this code path, anyway!
    4997                  (etypecase %command
    4998                    #+os-windows (string (run 'ext:run-shell-command %command))
    4999                    (list (run 'ext:run-program (car %command)
    5000                               :arguments (cdr %command)))))
    5001                #+(or clozure cmu ecl mkcl sbcl scl)
    5002                (#-(or ecl mkcl) progn #+(or ecl mkcl) multiple-value-list
    5003                 (apply
    5004                  '#+(or cmu ecl scl) ext:run-program
    5005                  #+clozure ccl:run-program #+sbcl sb-ext:run-program #+mkcl mk-ext:run-program
    5006                  (car %command) (cdr %command)
    5007                  :input %input
    5008                  :output %output
    5009                  :error %error-output
    5010                  :wait wait
    5011                  :allow-other-keys t
    5012                  (append
    5013                   #+(or clozure cmu mkcl sbcl scl)
    5014                   `(:if-input-does-not-exist ,if-input-does-not-exist
    5015                     :if-output-exists ,if-output-exists
    5016                     :if-error-exists ,if-error-output-exists)
    5017                   #+sbcl `(:search t
    5018                            :if-output-does-not-exist :create
    5019                            :if-error-does-not-exist :create)
    5020                   #-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys)))))
    5021                #+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case
    5022                (multiple-value-list
    5023                 (apply
    5024                  'system:run-shell-command
    5025                  (cons "/usr/bin/env" %command) ; lispworks wants a full path.
    5026                  :input %input :if-input-does-not-exist if-input-does-not-exist
    5027                  :output %output :if-output-exists if-output-exists
    5028                  :error-output %error-output :if-error-output-exists if-error-output-exists
    5029                  :wait wait :save-exit-status t :allow-other-keys t keys))))
     5087               (etypecase %command
     5088                 #+os-windows
     5089                 (string (lambda (&rest keys) (apply 'ext:run-shell-command %command keys)))
     5090                 (list (lambda (&rest keys)
     5091                         (apply 'ext:run-program (car %command) :arguments (cdr %command) keys))))
     5092               #+clozure 'ccl:run-program
     5093               #+(or cmu ecl scl) 'ext:run-program
     5094               #+lispworks 'system:run-shell-command
     5095               #+lispworks (cons "/usr/bin/env" %command) ; LW wants a full path
     5096               #+mkcl 'mk-ext:run-program
     5097               #+sbcl 'sb-ext:run-program
     5098               (append
     5099                #+(or clozure cmu ecl mkcl sbcl scl) `(,(car %command) ,(cdr %command))
     5100                `(:input ,%input :output ,%output :wait ,wait :allow-other-keys t)
     5101                #-clisp `(#+(or allegro lispworks) :error-output #-(or allegro lispworks) :error
     5102                            ,%error-output)
     5103                #+(and allegro os-windows) `(:show-window ,(if interactive nil :hide))
     5104                #+(or clozure cmu ecl lispworks mkcl sbcl scl)
     5105                `(:if-input-does-not-exist ,if-input-does-not-exist
     5106                  :if-output-exists ,if-output-exists
     5107                  #-lispworks :if-error-exists #+lispworks :if-error-output-exists
     5108                  ,if-error-output-exists)
     5109                #+lispworks `(:save-exit-status t)
     5110                #+sbcl `(:search t
     5111                         :if-output-does-not-exist :create
     5112                         :if-error-does-not-exist :create)
     5113                #+mkcl `(:directory ,(native-namestring directory))
     5114                #-sbcl keys
     5115                #+sbcl (if directory keys (remove-plist-key :directory keys))))))
    50305116           (process-info-r ()))
    50315117      (flet ((prop (key value) (push key process-info-r) (push value process-info-r)))
     
    50585144             (2 (prop :output-stream (first process*)))
    50595145             (3 (prop :bidir-stream (pop process*))
    5060                 (prop :input-stream (pop process*))
    5061                 (prop :output-stream (pop process*))))))
     5146              (prop :input-stream (pop process*))
     5147              (prop :output-stream (pop process*))))))
    50625148        #+(or clozure cmu sbcl scl)
    50635149        (progn
     
    50785164                  #+(or cmu scl) (ext:process-error process*)
    50795165                  #+sbcl (sb-ext:process-error process*))))
    5080         #+(or ecl mkcl)
    5081         (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
     5166        #+(or clasp ecl mkcl)
     5167        (destructuring-bind #+(or clasp ecl) (stream code process) #+mkcl (stream process code) process*
    50825168          (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
    50835169            (cond
     
    51045190      #+(or allegro lispworks) process
    51055191      #+clozure (ccl::external-process-pid process)
    5106       #+ecl (si:external-process-pid process)
     5192      #+(or clasp ecl) (si:external-process-pid process)
    51075193      #+(or cmu scl) (ext:process-pid process)
    51085194      #+mkcl (mkcl:process-id process)
     
    51175203            #+clozure (ccl::external-process-wait process)
    51185204            #+(or cmu scl) (ext:process-wait process)
    5119             #+(and ecl os-unix) (ext:external-process-wait process)
    51205205            #+sbcl (sb-ext:process-wait process)
    51215206            ;; 2- extract result
     
    51235208            #+clozure (nth-value 1 (ccl:external-process-status process))
    51245209            #+(or cmu scl) (ext:process-exit-code process)
    5125             #+ecl (nth-value 1 (ext:external-process-status process))
     5210            #+(or clasp ecl) (nth-value 1 (ext:external-process-wait process t))
    51265211            #+lispworks
    51275212            (if-let ((stream (or (getf process-info :input-stream)
     
    52895374  (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
    52905375    (etypecase command
    5291       (string command)
     5376      (string
     5377       (os-cond
     5378        ((os-windows-p)
     5379         #+(or allegro clisp)
     5380         (strcat (%cmd-shell-pathname) " /c " command)
     5381         #-(or allegro clisp) command)
     5382        (t command)))
    52925383      (list (escape-shell-command
    5293              (if (os-unix-p) (cons "exec" command) command)))))
     5384             (os-cond
     5385              ((os-unix-p) (cons "exec" command))
     5386              ((os-windows-p)
     5387               #+(or allegro sbcl clisp)
     5388               (cons (%cmd-shell-pathname) (cons "/c" command))
     5389               #-(or allegro sbcl clisp) command)
     5390              (t command))))))
    52945391
    52955392  (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
     
    53065403                 (list operator " "
    53075404                       (escape-shell-token (native-namestring pathname)))))))
    5308       (multiple-value-bind (before after)
    5309           (let ((normalized (%normalize-system-command command)))
    5310             (if (os-unix-p)
    5311                 (values '("exec") (list " ; " normalized))
    5312                 (values (list normalized) ())))
     5405      (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
     5406             (normalized (%normalize-system-command command))
     5407             (directory (or directory #+(or abcl xcl) (getcwd)))
     5408             (chdir (when directory
     5409                      (let ((dir-arg (escape-shell-token (native-namestring directory))))
     5410                        (os-cond
     5411                         ((os-unix-p) `("cd " ,dir-arg " ; "))
     5412                         ((os-windows-p) `("cd /d " ,dir-arg " & ")))))))
    53135413        (reduce/strcat
    5314          (append
    5315           before (redirect in " <") (redirect out " >") (redirect err " 2>")
    5316           (when (and directory (os-unix-p)) ;; NB: unless on Unix, %system uses with-current-directory
    5317             `(" ; cd " ,(escape-shell-token (native-namestring directory))))
    5318           after)))))
     5414         (os-cond
     5415          ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
     5416          ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
    53195417
    53205418  (defun %system (command &rest keys
     
    53255423    (%wait-process-result
    53265424     (apply '%run-program (%normalize-system-command command) :wait t keys))
    5327     #+(or abcl cormanlisp clisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
     5425    #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
    53285426    (let ((%command (%redirected-system-command command input output error-output directory)))
    53295427      #+(and lispworks os-windows)
     
    53345432              :input :interactive :output :interactive :error-output :interactive keys))
    53355433      #-(or clisp (and lispworks os-windows))
    5336       (with-current-directory ((unless (os-unix-p) directory))
     5434      (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
    53375435        #+abcl (ext:run-shell-command %command)
    53385436        #+cormanlisp (win32:system %command)
    5339         #+ecl (let ((*standard-input* *stdin*)
     5437        #+(or clasp ecl) (let ((*standard-input* *stdin*)
    53405438                    (*standard-output* *stdout*)
    53415439                    (*error-output* *stderr*))
     
    53665464
    53675465  (defun run-program (command &rest keys
    5368                        &key ignore-error-status force-shell
     5466                       &key ignore-error-status (force-shell nil force-shell-suppliedp)
    53695467                         (input nil inputp) (if-input-does-not-exist :error)
    53705468                         output (if-output-exists :overwrite)
     
    53755473    "Run program specified by COMMAND,
    53765474either a list of strings specifying a program and list of arguments,
    5377 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
     5475or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
     5476_synchronously_ process its output as specified and return the processing results
     5477when the program and its output processing are complete.
    53785478
    53795479Always call a shell (rather than directly execute the command when possible)
    5380 if FORCE-SHELL is specified.
     5480if FORCE-SHELL is specified.  Similarly, never call a shell if FORCE-SHELL is
     5481specified to be NIL.
    53815482
    53825483Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
     
    54245525or an indication of failure via the EXIT-CODE of the process"
    54255526    (declare (ignorable ignore-error-status))
    5426     #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
     5527    #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
    54275528    (error "RUN-PROGRAM not implemented for this Lisp")
     5529    ;; per doc string, set FORCE-SHELL to T if we get command as a string.  But
     5530    ;; don't override user's specified preference. [2015/06/29:rpg]
     5531    (when (stringp command)
     5532      (unless force-shell-suppliedp
     5533        #-(and sbcl os-windows) ;; force-shell t isn't working properly on windows as of sbcl 1.2.16
     5534        (setf force-shell t)))
    54285535    (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
    54295536      (apply (if (or force-shell
    5430                      #+(or clisp ecl) (or (not ignore-error-status) t)
    5431                      #+clisp (eq error-output :interactive)
    5432                      #+(or abcl clisp) (eq :error-output :output)
     5537                     #+(or clasp clisp) (or (not ignore-error-status) t)
     5538                     #+clisp (member error-output '(:interactive :output))
     5539                     ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
     5540                     #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
     5541                               (lexicographic<= '< ver '(16 0 1)))
    54335542                     #+(and lispworks os-unix) (%interactivep input output error-output)
    54345543                     #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
     
    54415550             :if-error-output-exists if-error-output-exists
    54425551             :element-type element-type :external-format external-format
    5443            keys))))
     5552             keys))))
    54445553;;;; -------------------------------------------------------------------------
    54455554;;;; Support to build (compile and load) Lisp files
     
    55115620                    ccl::*nx-debug* ccl::*nx-cspeed*)
    55125621        #+(or cmu scl) '(c::*default-cookie*)
    5513         #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
     5622        #+(and ecl (not clasp)) (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
     5623        #+clasp '()
    55145624        #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
    55155625        #+lispworks '(compiler::*optimization-level*)
     
    55185628  (defun get-optimization-settings ()
    55195629    "Get current compiler optimization settings, ready to PROCLAIM again"
    5520     #-(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)
    55215631    (warn "~S does not support ~S. Please help me fix that."
    55225632          'get-optimization-settings (implementation-type))
    5523     #+(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
     5633    #+(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
    55245634    (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
    55255635      #.`(loop #+(or allegro clozure)
     
    55275637                   #+clozure (ccl:declaration-information 'optimize nil))
    55285638               :for x :in settings
    5529                ,@(or #+(or abcl ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
     5639               ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
    55305640               :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
    55315641                            #+clisp (gethash x system::*optimize* 1)
    5532                             #+(or abcl ecl mkcl xcl) (symbol-value v)
     5642                            #+(or abcl clasp ecl mkcl xcl) (symbol-value v)
    55335643                            #+(or cmu scl) (slot-value c::*default-cookie*
    55345644                                                       (case x (compilation-speed 'c::cspeed)
    55355645                                                             (otherwise x)))
    55365646                            #+lispworks (slot-value compiler::*optimization-level* x)
    5537                             #+sbcl (cdr (assoc x sb-c::*policy*)))
     5647                            #+sbcl (sb-c::policy-quality sb-c::*policy* x))
    55385648               :when y :collect (list x y))))
    55395649  (defun proclaim-optimization-settings ()
     
    60546164    "pathname TYPE for lisp FASt Loading files"
    60556165    (declare (ignorable keys))
    6056     #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
    6057     #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
     6166    #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
     6167    #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
    60586168
    60596169  (defun call-around-hook (hook function)
     
    60806190  (defun* (compile-file*) (input-file &rest keys
    60816191                                      &key (compile-check *compile-check*) output-file warnings-file
    6082                                       #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
     6192                                      #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl
    60836193                                      &allow-other-keys)
    60846194    "This function provides a portable wrapper around COMPILE-FILE.
     
    61006210On implementations that erroneously do not recognize standard keyword arguments,
    61016211it will filter them appropriately."
    6102     #+ecl (when (and object-file (equal (compile-file-type) (pathname object-file)))
     6212    #+(or clasp ecl) (when (and object-file (equal (compile-file-type) (pathname object-file)))
    61036213            (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
    61046214                    'compile-file* output-file object-file)
     
    61066216    (let* ((keywords (remove-plist-keys
    61076217                      `(:output-file :compile-check :warnings-file
    6108                                      #+clisp :lib-file #+(or ecl mkcl) :object-file) keys))
     6218                                     #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys))
    61096219           (output-file
    61106220             (or output-file
    61116221                 (apply 'compile-file-pathname* input-file :output-file output-file keywords)))
    6112            #+ecl
     6222           #+(or clasp ecl)
    61136223           (object-file
    61146224             (unless (use-ecl-byte-compiler-p)
    61156225               (or object-file
    6116                    (compile-file-pathname output-file :type :object))))
     6226                   #+ecl(compile-file-pathname output-file :type :object)
     6227                   #+clasp (compile-file-pathname output-file :output-type :object))))
    61176228           #+mkcl
    61186229           (object-file
     
    61346245            (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
    61356246              (with-muffled-compiler-conditions ()
    6136                 (or #-(or ecl mkcl)
     6247                (or #-(or clasp ecl mkcl)
    61376248                    (apply 'compile-file input-file :output-file tmp-file
    61386249                           #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
    61396250                           #-sbcl keywords)
    61406251                    #+ecl (apply 'compile-file input-file :output-file
    6141                                  (if object-file
    6142                                      (list* object-file :system-p t keywords)
    6143                                      (list* tmp-file keywords)))
     6252                                (if object-file
     6253                                    (list* object-file :system-p t keywords)
     6254                                    (list* tmp-file keywords)))
     6255                    #+clasp (apply 'compile-file input-file :output-file
     6256                                  (if object-file
     6257                                      (list* object-file :output-type :object #|:system-p t|# keywords)
     6258                                      (list* tmp-file keywords)))
    61446259                    #+mkcl (apply 'compile-file input-file
    61456260                                  :output-file object-file :fasl-p nil keywords)))))
     
    61516266                       (check-flag warnings-p *compile-file-warnings-behaviour*)))
    61526267                (progn
    6153                   #+(or ecl mkcl)
    6154                   (when (and #+ecl object-file)
     6268                  #+(or clasp ecl mkcl)
     6269                  (when (and #+(or clasp ecl) object-file)
    61556270                    (setf output-truename
    6156                           (compiler::build-fasl
    6157                            tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files
    6158                                     (list object-file))))
     6271                          (compiler::build-fasl tmp-file
     6272                           #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list object-file))))
    61596273                  (or (not compile-check)
    6160                       (apply compile-check input-file :output-file tmp-file keywords))))
     6274                      (apply compile-check input-file
     6275                             :output-file #-(or clasp ecl) output-file #+(or clasp ecl) tmp-file
     6276                             keywords))))
    61616277           (delete-file-if-exists output-file)
    61626278           (when output-truename
     6279             #+clasp (when output-truename (rename-file-overwriting-target tmp-file output-truename))
    61636280             #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
    61646281             #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
    61656282             (rename-file-overwriting-target output-truename output-file)
    61666283             (setf output-truename (truename output-file)))
     6284           #+clasp (delete-file-if-exists tmp-file)
    61676285           #+clisp (delete-file-if-exists tmp-lib))
    61686286          (t ;; error or failed check
     
    62206338                      ,(loop :for f :in (reverse fasls)
    62216339                             :collect `(,(namestring f) :load-only t))))
    6222              (scm:concatenate-system output :fasls-to-concatenate))
     6340             (scm:concatenate-system output :fasls-to-concatenate :force t))
    62236341        (loop :for f :in fasls :do (ignore-errors (delete-file f)))
    62246342        (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
    6225 
    62266343;;;; ---------------------------------------------------------------------------
    62276344;;;; Generic support for configuration files
     
    62336350   :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
    62346351  (:export
     6352   #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
     6353   #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem
    62356354   #:get-folder-path
    6236    #:user-configuration-directories #:system-configuration-directories
    6237    #:in-first-directory
    6238    #:in-user-configuration-directory #:in-system-configuration-directory
     6355   #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
     6356   #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
     6357   #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames
     6358   #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname
    62396359   #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
    62406360   #:configuration-inheritance-directive-p
     
    62566376                       (list* (condition-form c) (condition-location c)
    62576377                              (condition-arguments c))))))
    6258 
    6259   (defun get-folder-path (folder)
    6260     "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
    6261 this function tries to locate the Windows FOLDER for one of
    6262 :LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA."
    6263     (or #+(and lispworks mswindows) (sys:get-folder-path folder)
    6264         ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    6265         (ecase folder
    6266           (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
    6267           (:appdata (getenv-absolute-directory "APPDATA"))
    6268           (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
    6269                                (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
    6270 
    6271   (defun user-configuration-directories ()
    6272     "Determine user configuration directories"
    6273     (let ((dirs
    6274             `(,@(when (os-unix-p)
    6275                   (cons
    6276                    (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
    6277                    (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
    6278                          :collect (subpathname* dir "common-lisp/"))))
    6279               ,@(when (os-windows-p)
    6280                   `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
    6281                     ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
    6282               ,(subpathname (user-homedir-pathname) ".config/common-lisp/"))))
    6283       (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
    6284                          :from-end t :test 'equal)))
    6285 
    6286   (defun system-configuration-directories ()
    6287     "Determine system user configuration directories"
    6288     (cond
    6289       ((os-unix-p) '(#p"/etc/common-lisp/"))
    6290       ((os-windows-p)
    6291        (if-let (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/"))
    6292          (list it)))))
    6293 
    6294   (defun in-first-directory (dirs x &key (direction :input))
    6295     "Determine system user configuration directories"
    6296     (loop :with fun = (ecase direction
    6297                         ((nil :input :probe) 'probe-file*)
    6298                         ((:output :io) 'identity))
    6299           :for dir :in dirs
    6300           :thereis (and dir (funcall fun (subpathname (ensure-directory-pathname dir) x)))))
    6301 
    6302   (defun in-user-configuration-directory (x &key (direction :input))
    6303     "return pathname under user configuration directory, subpathname X"
    6304     (in-first-directory (user-configuration-directories) x :direction direction))
    6305   (defun in-system-configuration-directory (x &key (direction :input))
    6306     "return pathname under system configuration directory, subpathname X"
    6307     (in-first-directory (system-configuration-directories) x :direction direction))
    63086378
    63096379  (defun configuration-inheritance-directive-p (x)
     
    63306400  (defun validate-configuration-form (form tag directive-validator
    63316401                                            &key location invalid-form-reporter)
    6332     "Validate a configuration FORM"
     6402    "Validate a configuration FORM. By default it will raise an error if the
     6403FORM is not valid.  Otherwise it will return the validated form.
     6404     Arguments control the behavior:
     6405     The configuration FORM should be of the form (TAG . <rest>)
     6406     Each element of <rest> will be checked by first seeing if it's a configuration inheritance
     6407directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
     6408on it.
     6409     In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
     6410reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
     6411the configuration form appeared."
    63336412    (unless (and (consp form) (eq (car form) tag))
    63346413      (setf *ignored-configuration-form* t)
     
    63636442
    63646443  (defun validate-configuration-file (file validator &key description)
    6365     "Validate a configuration file for conformance of its form with the validator function"
     6444    "Validate a configuration FILE.  The configuration file should have only one s-expression
     6445in it, which will be checked with the VALIDATOR FORM.  DESCRIPTION argument used for error
     6446reporting."
    63666447    (let ((forms (read-file-forms file)))
    63676448      (unless (length=n-p forms 1)
     
    63966477
    63976478  (defun resolve-relative-location (x &key ensure-directory wilden)
    6398     "Given a designator X for an relative location, resolve it to a pathname"
     6479    "Given a designator X for an relative location, resolve it to a pathname."
    63996480    (ensure-pathname
    64006481     (etypecase x
     6482       (null nil)
    64016483       (pathname x)
    64026484       (string (parse-unix-namestring
     
    64346516    "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
    64356517
    6436   (defun compute-user-cache ()
    6437     "Compute the location of the default user-cache for translate-output objects"
    6438     (setf *user-cache*
    6439           (flet ((try (x &rest sub) (and x `(,x ,@sub))))
    6440             (or
    6441              (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
    6442              (when (os-windows-p)
    6443                (try (or (get-folder-path :local-appdata)
    6444                         (get-folder-path :appdata))
    6445                     "common-lisp" "cache" :implementation))
    6446              '(:home ".cache" "common-lisp" :implementation)))))
    6447   (register-image-restore-hook 'compute-user-cache)
    6448 
    64496518  (defun resolve-absolute-location (x &key ensure-directory wilden)
    64506519    "Given a designator X for an absolute location, resolve it to a pathname"
    64516520    (ensure-pathname
    64526521     (etypecase x
     6522       (null nil)
    64536523       (pathname x)
    64546524       (string
     
    64936563    (loop* :with dirp = (or directory ensure-directory)
    64946564           :with (first . rest) = (if (atom x) (list x) x)
    6495            :with path = (resolve-absolute-location
    6496                          first :ensure-directory (and (or dirp rest) t)
    6497                                :wilden (and wilden (null rest)))
     6565           :with path = (or (resolve-absolute-location
     6566                             first :ensure-directory (and (or dirp rest) t)
     6567                                   :wilden (and wilden (null rest)))
     6568                            (return nil))
    64986569           :for (element . morep) :on rest
    64996570           :for dir = (and (or morep dirp) t)
     
    65086579  (defun location-designator-p (x)
    65096580    "Is X a designator for a location?"
     6581    ;; NIL means "skip this entry", or as an output translation, same as translation input.
     6582    ;; T means "any input" for a translation, or as output, same as translation input.
    65106583    (flet ((absolute-component-p (c)
    65116584             (typep c '(or string pathname
     
    65206593  (defun location-function-p (x)
    65216594    "Is X the specification of a location function?"
    6522     (and
    6523      (length=n-p x 2)
    6524      (eq (car x) :function)))
     6595    ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
     6596    (and (length=n-p x 2) (eq (car x) :function)))
    65256597
    65266598  (defvar *clear-configuration-hook* '())
     
    65406612    (when *ignored-configuration-form*
    65416613      (clear-configuration)
    6542       (setf *ignored-configuration-form* nil))))
    6543 
    6544 
     6614      (setf *ignored-configuration-form* nil)))
     6615
     6616
     6617  (defun get-folder-path (folder)
     6618    "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
     6619this function tries to locate the Windows FOLDER for one of
     6620:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
     6621     Returns NIL when the folder is not defined (e.g., not on Windows)."
     6622    (or #+(and lispworks mswindows) (sys:get-folder-path folder)
     6623        ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
     6624        (ecase folder
     6625          (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
     6626                              (subpathname* (get-folder-path :appdata) "Local")))
     6627          (:appdata (getenv-absolute-directory "APPDATA"))
     6628          (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
     6629                               (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
     6630
     6631
     6632  ;; Support for the XDG Base Directory Specification
     6633  (defun xdg-data-home (&rest more)
     6634    "Returns an absolute pathname for the directory containing user-specific data files.
     6635MORE may contain specifications for a subpath relative to this directory: a
     6636subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6637also \"Configuration DSL\"\) in the ASDF manual."
     6638    (resolve-absolute-location
     6639     `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
     6640            (os-cond
     6641             ((os-windows-p) (get-folder-path :local-appdata))
     6642             (t (subpathname (user-homedir-pathname) ".local/share/"))))
     6643       ,more)))
     6644
     6645  (defun xdg-config-home (&rest more)
     6646    "Returns a pathname for the directory containing user-specific configuration files.
     6647MORE may contain specifications for a subpath relative to this directory: a
     6648subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6649also \"Configuration DSL\"\) in the ASDF manual."
     6650    (resolve-absolute-location
     6651     `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
     6652            (os-cond
     6653             ((os-windows-p) (xdg-data-home "config/"))
     6654             (t (subpathname (user-homedir-pathname) ".config/"))))
     6655       ,more)))
     6656
     6657  (defun xdg-data-dirs (&rest more)
     6658    "The preference-ordered set of additional paths to search for data files.
     6659Returns a list of absolute directory pathnames.
     6660MORE may contain specifications for a subpath relative to these directories: a
     6661subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6662also \"Configuration DSL\"\) in the ASDF manual."
     6663    (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
     6664            (or (getenv-absolute-directories "XDG_DATA_DIRS")
     6665                (os-cond
     6666                 ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
     6667                 (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))))
     6668
     6669  (defun xdg-config-dirs (&rest more)
     6670    "The preference-ordered set of additional base paths to search for configuration files.
     6671Returns a list of absolute directory pathnames.
     6672MORE may contain specifications for a subpath relative to these directories:
     6673subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6674also \"Configuration DSL\"\) in the ASDF manual."
     6675    (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
     6676            (or (getenv-absolute-directories "XDG_CONFIG_DIRS")
     6677                (os-cond
     6678                 ((os-windows-p) (xdg-data-dirs "config/"))
     6679                 (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))
     6680
     6681  (defun xdg-cache-home (&rest more)
     6682    "The base directory relative to which user specific non-essential data files should be stored.
     6683Returns an absolute directory pathname.
     6684MORE may contain specifications for a subpath relative to this directory: a
     6685subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6686also \"Configuration DSL\"\) in the ASDF manual."
     6687    (resolve-absolute-location
     6688     `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
     6689            (os-cond
     6690             ((os-windows-p) (xdg-data-home "cache/"))
     6691             (t (subpathname* (user-homedir-pathname) ".cache/"))))
     6692       ,more)))
     6693
     6694  (defun xdg-runtime-dir (&rest more)
     6695    "Pathname for user-specific non-essential runtime files and other file objects,
     6696such as sockets, named pipes, etc.
     6697Returns an absolute directory pathname.
     6698MORE may contain specifications for a subpath relative to this directory: a
     6699subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6700also \"Configuration DSL\"\) in the ASDF manual."
     6701    ;; The XDG spec says that if not provided by the login system, the application should
     6702    ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
     6703    (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
     6704
     6705  ;;; NOTE: modified the docstring because "system user configuration
     6706  ;;; directories" seems self-contradictory. I'm not sure my wording is right.
     6707  (defun system-config-pathnames (&rest more)
     6708    "Return a list of directories where are stored the system's default user configuration information.
     6709MORE may contain specifications for a subpath relative to these directories: a
     6710subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6711also \"Configuration DSL\"\) in the ASDF manual."
     6712    (declare (ignorable more))
     6713    (os-cond
     6714     ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more))))))
     6715
     6716  (defun filter-pathname-set (dirs)
     6717    "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
     6718    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))
     6719
     6720  (defun xdg-data-pathnames (&rest more)
     6721    "Return a list of absolute pathnames for application data directories.  With APP,
     6722returns directory for data for that application, without APP, returns the set of directories
     6723for storing all application configurations.
     6724MORE may contain specifications for a subpath relative to these directories: a
     6725subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6726also \"Configuration DSL\"\) in the ASDF manual."
     6727    (filter-pathname-set
     6728     `(,(xdg-data-home more)
     6729       ,@(xdg-data-dirs more))))
     6730
     6731  (defun xdg-config-pathnames (&rest more)
     6732    "Return a list of pathnames for application configuration.
     6733MORE may contain specifications for a subpath relative to these directories: a
     6734subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
     6735also \"Configuration DSL\"\) in the ASDF manual."
     6736    (filter-pathname-set
     6737     `(,(xdg-config-home more)
     6738       ,@(xdg-config-dirs more))))
     6739
     6740  (defun find-preferred-file (files &key (direction :input))
     6741    "Find first file in the list of FILES that exists (for direction :input or :probe)
     6742or just the first one (for direction :output or :io).
     6743    Note that when we say \"file\" here, the files in question may be directories."
     6744    (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))
     6745
     6746  (defun xdg-data-pathname (&optional more (direction :input))
     6747    (find-preferred-file (xdg-data-pathnames more) :direction direction))
     6748
     6749  (defun xdg-config-pathname (&optional more (direction :input))
     6750    (find-preferred-file (xdg-config-pathnames more) :direction direction))
     6751
     6752  (defun compute-user-cache ()
     6753    "Compute (and return) the location of the default user-cache for translate-output
     6754objects. Side-effects for cached file location computation."
     6755    (setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
     6756  (register-image-restore-hook 'compute-user-cache))
    65456757;;;; -------------------------------------------------------------------------
    65466758;;; Hacks for backward-compatibility of the driver
     
    65516763  (:use :uiop/common-lisp :uiop/package :uiop/utility
    65526764   :uiop/pathname :uiop/stream :uiop/os :uiop/image
    6553    :uiop/run-program :uiop/lisp-build
    6554    :uiop/configuration)
     6765   :uiop/run-program :uiop/lisp-build :uiop/configuration)
    65556766  (:export
    65566767   #:coerce-pathname #:component-name-to-pathname-components
    6557    #+(or ecl mkcl) #:compile-file-keeping-object
     6768   #+(or clasp ecl mkcl) #:compile-file-keeping-object
     6769   #:user-configuration-directories #:system-configuration-directories
     6770   #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory
    65586771   ))
    65596772(in-package :uiop/backward-driver)
     
    65826795      (values relabs path filename)))
    65836796
    6584   #+(or ecl mkcl)
    6585   (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
     6797  #+(or clasp ecl mkcl)
     6798  (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args))
     6799
     6800  ;; Backward compatibility for ASDF 2.27 to 3.1.4
     6801  (defun user-configuration-directories ()
     6802    "Return the current user's list of user configuration directories
     6803for configuring common-lisp.
     6804    DEPRECATED. Use uiop:xdg-config-pathnames instead."
     6805    (xdg-config-pathnames "common-lisp"))
     6806  (defun system-configuration-directories ()
     6807    "Return the list of system configuration directories for common-lisp.
     6808    DEPRECATED. Use uiop:config-system-pathnames instead."
     6809    (system-config-pathnames "common-lisp"))
     6810  (defun in-first-directory (dirs x &key (direction :input))
     6811    "Finds the first appropriate file named X in the list of DIRS for I/O
     6812in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
     6813   If direction is :INPUT or :PROBE, will return the first extant file named
     6814X in one of the DIRS.
     6815   If direction is :OUTPUT or :IO, will simply return the file named X in the
     6816first element of DIRS that exists. DEPRECATED."
     6817    (find-preferred-file
     6818     (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs)
     6819     :direction direction))
     6820  (defun in-user-configuration-directory (x &key (direction :input))
     6821    "Return the file named X in the user configuration directory for common-lisp.
     6822DEPRECATED."
     6823    (xdg-config-pathname `("common-lisp" ,x) direction))
     6824  (defun in-system-configuration-directory (x &key (direction :input))
     6825    "Return the pathname for the file named X under the system configuration directory
     6826for common-lisp. DEPRECATED."
     6827    (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction)))
    65866828;;;; ---------------------------------------------------------------------------
    65876829;;;; Re-export all the functionality in UIOP
     
    66716913         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    66726914         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    6673          (asdf-version "3.1.4")
     6915         (asdf-version "3.1.6")
    66746916         (existing-version (asdf-version)))
    66756917    (setf *asdf-version* asdf-version)
     
    69877229  (defmethod component-relative-pathname ((component component))
    69887230    ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
    6989     ;; We ought to be able to extract this from the component alone with COMPONENT-TYPE.
    6990     ;; TODO: track who uses it, and have them not use it anymore;
     7231    ;; We ought to be able to extract this from the component alone with FILE-TYPE.
     7232    ;; TODO: track who uses it in Quicklisp, and have them not use it anymore;
    69917233    ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
    69927234    (parse-unix-namestring
     
    72707512   #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
    72717513   #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
    7272    #:clear-defined-system #:clear-defined-systems #:*defined-systems*
    7273    #:*immutable-systems*
     7514   #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems*
     7515   #:*defined-systems* #:clear-defined-systems
    72747516   ;; defined in source-registry, but specially mentioned here:
    72757517   #:initialize-source-registry #:sysdef-source-registry-search))
     
    73417583                    system)))))
    73427584
    7343   (defun clear-defined-system (system)
     7585  (defvar *preloaded-systems* (make-hash-table :test 'equal))
     7586
     7587  (defun make-preloaded-system (name keys)
     7588    (apply 'make-instance (getf keys :class 'system)
     7589           :name name :source-file (getf keys :source-file)
     7590           (remove-plist-keys '(:class :name :source-file) keys)))
     7591
     7592  (defun sysdef-preloaded-system-search (requested)
     7593    (let ((name (coerce-name requested)))
     7594      (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
     7595        (when foundp
     7596          (make-preloaded-system name keys)))))
     7597
     7598  (defun register-preloaded-system (system-name &rest keys)
     7599    (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
     7600
     7601  (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
     7602    ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
     7603    (register-preloaded-system s :version *asdf-version*))
     7604
     7605  (defvar *immutable-systems* nil
     7606    "An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
     7607i.e. already loaded in memory and not to be refreshed from the filesystem.
     7608They will be treated specially by find-system, and passed as :force-not argument to make-plan.
     7609
     7610If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
     7611for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
     7612downgrade, before you dump an image, use:
     7613   (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
     7614
     7615  (defun sysdef-immutable-system-search (requested)
     7616    (let ((name (coerce-name requested)))
     7617      (when (and *immutable-systems* (gethash name *immutable-systems*))
     7618        (or (cdr (system-registered-p requested))
     7619            (sysdef-preloaded-system-search name)
     7620            (error 'formatted-system-definition-error
     7621                   :format-control "Requested system ~A is in the *immutable-systems* set, ~
     7622but not loaded in memory"
     7623                   :format-arguments (list name))))))
     7624
     7625  (defun register-immutable-system (system-name &key (version t))
     7626    (let* ((system-name (coerce-name system-name))
     7627           (registered-system (cdr (system-registered-p system-name)))
     7628           (default-version? (eql version t))
     7629           (version (cond ((and default-version? registered-system)
     7630                           (component-version registered-system))
     7631                          (default-version? nil)
     7632                          (t version))))
     7633      (unless registered-system
     7634        (register-system (make-preloaded-system system-name (list :version version))))
     7635      (register-preloaded-system system-name :version version)
     7636      (unless *immutable-systems*
     7637        (setf *immutable-systems* (list-to-hash-set nil)))
     7638      (setf (gethash (coerce-name system-name) *immutable-systems*) t)))
     7639
     7640  (defun clear-system (system)
     7641    "Clear the entry for a SYSTEM in the database of systems previously loaded,
     7642unless the system appears in the table of *IMMUTABLE-SYSTEMS*.
     7643Note that this does NOT in any way cause the code of the system to be unloaded.
     7644Returns T if cleared or already cleared,
     7645NIL if not cleared because the system was found to be immutable."
     7646    ;; There is no "unload" operation in Common Lisp, and
     7647    ;; a general such operation cannot be portably written,
     7648    ;; considering how much CL relies on side-effects to global data structures.
    73447649    (let ((name (coerce-name system)))
    7345       (remhash name *defined-systems*)
    7346       (unset-asdf-cache-entry `(locate-system ,name))
    7347       (unset-asdf-cache-entry `(find-system ,name))
    7348       nil))
     7650      (unless (and *immutable-systems* (gethash name *immutable-systems*))
     7651        (remhash (coerce-name name) *defined-systems*)
     7652        (unset-asdf-cache-entry `(locate-system ,name))
     7653        (unset-asdf-cache-entry `(find-system ,name))
     7654        t)))
    73497655
    73507656  (defun clear-defined-systems ()
    73517657    ;; Invalidate all systems but ASDF itself, if registered.
    73527658    (loop :for name :being :the :hash-keys :of *defined-systems*
    7353           :unless (equal name "asdf")
    7354             :do (clear-defined-system name)))
     7659          :unless (equal name "asdf") :do (clear-system name)))
    73557660
    73567661  (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
    7357 
    7358   (defun clear-system (name)
    7359     "Clear the entry for a system in the database of systems previously loaded.
    7360 Note that this does NOT in any way cause the code of the system to be unloaded."
    7361     ;; There is no "unload" operation in Common Lisp, and
    7362     ;; a general such operation cannot be portably written,
    7363     ;; considering how much CL relies on side-effects to global data structures.
    7364     (remhash (coerce-name name) *defined-systems*))
    73657662
    73667663  (defun map-systems (fn)
     
    74267723          (return file))
    74277724        #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
    7428         (when (and (os-windows-p) (physical-pathname-p defaults))
    7429           (let ((shortcut
    7430                   (make-pathname
    7431                    :defaults defaults :case :local
    7432                    :name (strcat name ".asd")
    7433                    :type "lnk")))
    7434             (when (probe-file* shortcut)
    7435               (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))
     7725        (os-cond
     7726         ((os-windows-p)
     7727          (when (physical-pathname-p defaults)
     7728            (let ((shortcut
     7729                    (make-pathname
     7730                     :defaults defaults :case :local
     7731                     :name (strcat name ".asd")
     7732                     :type "lnk")))
     7733              (when (probe-file* shortcut)
     7734                (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))))
    74367735
    74377736  (defun sysdef-central-registry-search (system)
     
    74827781                            (subseq *central-registry* (1+ position))))))))))
    74837782
    7484   (defvar *preloaded-systems* (make-hash-table :test 'equal))
    7485 
    7486   (defun make-preloaded-system (name keys)
    7487     (apply 'make-instance (getf keys :class 'system)
    7488            :name name :source-file (getf keys :source-file)
    7489            (remove-plist-keys '(:class :name :source-file) keys)))
    7490 
    7491   (defun sysdef-preloaded-system-search (requested)
    7492     (let ((name (coerce-name requested)))
    7493       (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
    7494         (when foundp
    7495           (make-preloaded-system name keys)))))
    7496 
    7497   (defun register-preloaded-system (system-name &rest keys)
    7498     (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
    7499 
    7500   (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
    7501     ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
    7502     (register-preloaded-system s :version *asdf-version*))
    7503 
    75047783  (defmethod find-system ((name null) &optional (error-p t))
    75057784    (when error-p
     
    75137792    (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
    75147793
    7515   (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
     7794  (defun load-asd (pathname
     7795                   &key name (external-format (encoding-external-format (detect-encoding pathname)))
     7796                   &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
    75167797    ;; Tries to load system definition with canonical NAME from PATHNAME.
    75177798    (with-asdf-cache ()
     
    75817862             nil))))) ;; only issue the warning the first time, but always return nil
    75827863
    7583   (defvar *immutable-systems* nil
    7584     "An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
    7585 i.e. already loaded in memory and not to be refreshed from the filesystem.
    7586 They will be treated specially by find-system, and passed as :force-not argument to make-plan.
    7587 
    7588 If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
    7589 for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
    7590 downgrade, before you dump an image, use:
    7591    (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
    7592 
    7593   (defun sysdef-immutable-system-search (requested)
    7594     (let ((name (coerce-name requested)))
    7595       (when (and *immutable-systems* (gethash name *immutable-systems*))
    7596         (or (cdr (system-registered-p requested))
    7597             (error 'formatted-system-definition-error
    7598                    :format-control "Requested system ~A is in the *immutable-systems* set, ~
    7599 but not loaded in memory"
    7600                    :format-arguments (list name))))))
    7601 
    76027864  (defun locate-system (name)
    76037865    "Given a system NAME designator, try to locate where to load the system from.
     
    76397901          (find-system primary-name nil)))
    76407902      (or (and *immutable-systems* (gethash name *immutable-systems*)
    7641                (cdr (system-registered-p name)))
     7903               (or (cdr (system-registered-p name))
     7904                   (sysdef-preloaded-system-search name)))
    76427905          (multiple-value-bind (foundp found-system pathname previous previous-time)
    76437906              (locate-system name)
     
    83558618              (output-file
    83568619               &optional
     8620                 #+(or clasp ecl mkcl) object-file
    83578621                 #+clisp lib-file
    8358                  #+(or ecl mkcl) object-file
    8359                  warnings-file) outputs
     8622                 warnings-file &rest rest) outputs
     8623            ;; Allow for extra outputs that are not of type warnings-file
     8624            ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional.
     8625            (declare (ignore rest))
     8626            (when warnings-file
     8627              (unless (equal (pathname-type warnings-file) (warnings-file-type))
     8628                (setf warnings-file nil)))
    83608629            (call-with-around-compile-hook
    83618630             c #'(lambda (&rest flags)
     
    83668635                          (append
    83678636                           #+clisp (list :lib-file lib-file)
    8368                            #+(or ecl mkcl) (list :object-file object-file)
     8637                           #+(or clasp ecl mkcl) (list :object-file object-file)
    83698638                           flags (compile-op-flags o))))))
    83708639        (check-lisp-compile-results output warnings-p failure-p
     
    83918660    (let* ((i (first (input-files o c)))
    83928661           (f (compile-file-pathname
    8393                i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
     8662               i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl
     8663               #+mkcl :fasl-p #+mkcl t)))
    83948664      `(,f ;; the fasl is the primary output, in first position
     8665        #+clasp
     8666        ,@(unless nil ;; was (use-ecl-byte-compiler-p)
     8667            `(,(compile-file-pathname i :output-type :object)))
    83958668        #+clisp
    83968669        ,@`(,(make-pathname :type "lib" :defaults f))
     
    87108983       (when (and missing-in (not just-done)) (return (values t nil))))
    87118984     ;; collect timestamps from outputs, and exit early if any is missing
    8712      (let* ((out-files (output-files o c))
     8985     (let* ((out-files (remove-if 'null (output-files o c)))
    87138986            (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
    87148987            (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
     
    91329405    t))
    91339406
    9134 
    9135 ;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
     9407;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE,
     9408;; only tries to load its specified target if it's not loaded yet.
     9409(with-upgradability ()
     9410  (defun component-loaded-p (component)
     9411    "has given COMPONENT been successfully loaded in the current image (yet)?"
     9412    (action-already-done-p nil (make-instance 'load-op) (find-component component ())))
     9413
     9414  (defun already-loaded-systems ()
     9415    "return a list of the names of the systems that have been successfully loaded so far"
     9416    (remove-if-not 'component-loaded-p (registered-systems)))
     9417
     9418  (defun require-system (system &rest keys &key &allow-other-keys)
     9419    "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but skip any update to the
     9420system or its dependencies if they have already been loaded."
     9421    (apply 'load-system system :force-not (already-loaded-systems) keys)))
     9422
     9423
     9424;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
    91369425;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
    91379426(with-upgradability ()
    9138   (defun component-loaded-p (c)
    9139     (action-already-done-p nil (make-instance 'load-op) (find-component c ())))
    9140 
    9141   (defun already-loaded-systems ()
    9142     (remove-if-not 'component-loaded-p (registered-systems)))
    9143 
    9144   (defun require-system (s &rest keys &key &allow-other-keys)
    9145     (apply 'load-system s :force-not (already-loaded-systems) keys))
    9146 
    91479427  (defvar *modules-being-required* nil)
    91489428
     
    93479627    ;; Some implementations have precompiled ASDF systems,
    93489628    ;; so we must disable translations for implementation paths.
    9349       #+(or #|clozure|# ecl mkcl sbcl)
     9629      #+(or clasp #|clozure|# ecl mkcl sbcl)
    93509630      ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
    93519631          (when h `(((,h ,*wild-path*) ()))))
     
    93599639      :enable-user-cache))
    93609640
    9361   (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
    9362   (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
     9641  (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
     9642  (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
    93639643
    93649644  (defun user-output-translations-pathname (&key (direction :input))
    9365     (in-user-configuration-directory *output-translations-file* :direction direction))
     9645    (xdg-config-pathname *output-translations-file* direction))
    93669646  (defun system-output-translations-pathname (&key (direction :input))
    9367     (in-system-configuration-directory *output-translations-file* :direction direction))
     9647    (find-preferred-file (system-config-pathnames *output-translations-file*)
     9648                         :direction direction))
    93689649  (defun user-output-translations-directory-pathname (&key (direction :input))
    9369     (in-user-configuration-directory *output-translations-directory* :direction direction))
     9650    (xdg-config-pathname *output-translations-directory* direction))
    93709651  (defun system-output-translations-directory-pathname (&key (direction :input))
    9371     (in-system-configuration-directory *output-translations-directory* :direction direction))
     9652    (find-preferred-file (system-config-pathnames *output-translations-directory*)
     9653                         :direction direction))
    93729654  (defun environment-output-translations ()
    93739655    (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     
    94039685                     (funcall collect
    94049686                              (list trusrc (ensure-function (second dst)))))
    9405                     ((eq dst t)
     9687                    ((typep dst 'boolean)
    94069688                     (funcall collect (list trusrc t)))
    94079689                    (t
    9408                      (let* ((trudst (if dst
    9409                                         (resolve-location dst :ensure-directory t :wilden t)
    9410                                         trusrc)))
     9690                     (let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
    94119691                       (funcall collect (list trudst t))
    94129692                       (funcall collect (list trusrc trudst)))))))))))
     
    95399819   #:user-source-registry #:system-source-registry
    95409820   #:user-source-registry-directory #:system-source-registry-directory
    9541    #:environment-source-registry #:process-source-registry
     9821   #:environment-source-registry #:process-source-registry #:inherit-source-registry
    95429822   #:compute-source-registry #:flatten-source-registry
    95439823   #:sysdef-source-registry-search))
     
    95619841    "Either NIL (for uninitialized), or an equal hash-table, mapping
    95629842system names to pathnames of .asd files")
     9843
     9844  (defvar *source-registry-parameter* nil)
    95639845
    95649846  (defun source-registry-initialized-p ()
     
    96899971    "List of default source registries" "3.1.0.102")
    96909972
    9691   (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
    9692   (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
     9973  (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
     9974  (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
    96939975
    96949976  (defun wrapping-source-registry ()
    96959977    `(:source-registry
    9696       #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
     9978      #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
    96979979      :inherit-configuration
    96989980      #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
     
    97039985      (:tree (:home "common-lisp/"))
    97049986      #+sbcl (:directory (:home ".sbcl/systems/"))
    9705       ,@(loop :for dir :in
    9706               `(,@(when (os-unix-p)
    9707                     `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
    9708                            (subpathname (user-homedir-pathname) ".local/share/"))))
    9709                 ,@(when (os-windows-p)
    9710                     (mapcar 'get-folder-path '(:local-appdata :appdata))))
    9711               :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
    9712               :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
     9987      (:directory ,(xdg-data-home "common-lisp/systems/"))
     9988      (:tree ,(xdg-data-home "common-lisp/source/"))
    97139989      :inherit-configuration))
    97149990  (defun default-system-source-registry ()
    97159991    `(:source-registry
    9716       ,@(loop :for dir :in
    9717               `(,@(when (os-unix-p)
    9718                     (or (getenv-absolute-directories "XDG_DATA_DIRS")
    9719                         '("/usr/local/share" "/usr/share")))
    9720                 ,@(when (os-windows-p)
    9721                     (list (get-folder-path :common-appdata))))
    9722               :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
    9723               :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
     9992      ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
     9993              :collect `(:directory (,dir "systems/"))
     9994              :collect `(:tree (,dir "source/")))
    97249995      :inherit-configuration))
    97259996  (defun user-source-registry (&key (direction :input))
    9726     (in-user-configuration-directory *source-registry-file* :direction direction))
     9997    (xdg-config-pathname *source-registry-file* direction))
    97279998  (defun system-source-registry (&key (direction :input))
    9728     (in-system-configuration-directory *source-registry-file* :direction direction))
     9999    (find-preferred-file (system-config-pathnames *source-registry-file*)
     10000                         :direction direction))
    972910001  (defun user-source-registry-directory (&key (direction :input))
    9730     (in-user-configuration-directory *source-registry-directory* :direction direction))
     10002    (xdg-config-pathname *source-registry-directory* direction))
    973110003  (defun system-source-registry-directory (&key (direction :input))
    9732     (in-system-configuration-directory *source-registry-directory* :direction direction))
     10004    (find-preferred-file (system-config-pathnames *source-registry-directory*)
     10005                         :direction direction))
    973310006  (defun environment-source-registry ()
    973410007    (getenv "CL_SOURCE_REGISTRY"))
     
    979210065        (process-source-registry-directive directive :inherit inherit :register register))))
    979310066
    9794   (defun flatten-source-registry (&optional parameter)
     10067  (defun flatten-source-registry (&optional (parameter *source-registry-parameter*))
    979510068    (remove-duplicates
    979610069     (while-collecting (collect)
     
    980510078
    980610079  ;; Will read the configuration and initialize all internal variables.
    9807   (defun compute-source-registry (&optional parameter (registry *source-registry*))
     10080  (defun compute-source-registry (&optional (parameter *source-registry-parameter*) (registry *source-registry*))
    980810081    (dolist (entry (flatten-source-registry parameter))
    980910082      (destructuring-bind (directory &key recurse exclude) entry
     
    983510108    (values))
    983610109
    9837   (defvar *source-registry-parameter* nil)
    9838 
    983910110  (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
    984010111    ;; Record the parameter used to configure the registry
     
    986410135
    986510136;;;; -------------------------------------------------------------------------
    9866 ;;; Internal hacks for backward-compatibility
    9867 
    9868 (uiop/package:define-package :asdf/backward-internals
    9869   (:recycle :asdf/backward-internals :asdf)
    9870   (:use :uiop/common-lisp :uiop :asdf/upgrade
    9871    :asdf/system :asdf/component :asdf/operation
    9872    :asdf/find-system :asdf/action :asdf/lisp-action)
    9873   (:export ;; for internal use
    9874    #:load-sysdef #:make-temporary-package
    9875    #:%refresh-component-inline-methods
    9876    #:make-sub-operation
    9877    #:load-sysdef #:make-temporary-package))
    9878 (in-package :asdf/backward-internals)
    9879 
    9880 ;;;; Backward compatibility with "inline methods"
    9881 (with-upgradability ()
    9882   (defparameter* +asdf-methods+
    9883     '(perform-with-restarts perform explain output-files operation-done-p))
    9884 
    9885   (defun %remove-component-inline-methods (component)
    9886     (dolist (name +asdf-methods+)
    9887       (map ()
    9888            ;; this is inefficient as most of the stored
    9889            ;; methods will not be for this particular gf
    9890            ;; But this is hardly performance-critical
    9891            #'(lambda (m)
    9892                (remove-method (symbol-function name) m))
    9893            (component-inline-methods component)))
    9894     (component-inline-methods component) nil)
    9895 
    9896   (defun %define-component-inline-methods (ret rest)
    9897     (loop* :for (key value) :on rest :by #'cddr
    9898            :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
    9899            :when name :do
    9900            (destructuring-bind (op &rest body) value
    9901              (loop :for arg = (pop body)
    9902                    :while (atom arg)
    9903                    :collect arg :into qualifiers
    9904                    :finally
    9905                       (destructuring-bind (o c) arg
    9906                         (pushnew
    9907                          (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
    9908                          (component-inline-methods ret)))))))
    9909 
    9910   (defun %refresh-component-inline-methods (component rest)
    9911     ;; clear methods, then add the new ones
    9912     (%remove-component-inline-methods component)
    9913     (%define-component-inline-methods component rest)))
    9914 
    9915 (when-upgrading (:when (fboundp 'make-sub-operation))
    9916   (defun make-sub-operation (c o dep-c dep-o)
    9917     (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
    9918 
    9919 
    9920 ;;;; load-sysdef
    9921 (with-upgradability ()
    9922   (defun load-sysdef (name pathname)
    9923     (load-asd pathname :name name))
    9924 
    9925   (defun make-temporary-package ()
    9926     ;; For loading a .asd file, we don't make a temporary package anymore,
    9927     ;; but use ASDF-USER. I'd like to have this function do this,
    9928     ;; but since whoever uses it is likely to delete-package the result afterwards,
    9929     ;; this would be a bad idea, so preserve the old behavior.
    9930     (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
    9931 
    9932 
    9933 ;;;; -------------------------------------------------------------------------
    993410137;;;; Defsystem
    993510138
     
    993910142  (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
    994010143   :asdf/cache :asdf/component :asdf/system
    9941    :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
    9942    :asdf/backward-internals)
     10144   :asdf/find-system :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
    994310145  (:import-from :asdf/system #:depends-on #:weakly-depends-on)
    994410146  (:export
     
    1005410256          (unparse-version pv)
    1005510257          (invalid))))))
     10258
     10259
     10260;;; "inline methods"
     10261(with-upgradability ()
     10262  (defparameter* +asdf-methods+
     10263    '(perform-with-restarts perform explain output-files operation-done-p))
     10264
     10265  (defun %remove-component-inline-methods (component)
     10266    (dolist (name +asdf-methods+)
     10267      (map ()
     10268           ;; this is inefficient as most of the stored
     10269           ;; methods will not be for this particular gf
     10270           ;; But this is hardly performance-critical
     10271           #'(lambda (m)
     10272               (remove-method (symbol-function name) m))
     10273           (component-inline-methods component)))
     10274    (component-inline-methods component) nil)
     10275
     10276  (defun %define-component-inline-methods (ret rest)
     10277    (loop* :for (key value) :on rest :by #'cddr
     10278           :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
     10279           :when name :do
     10280           (destructuring-bind (op &rest body) value
     10281             (loop :for arg = (pop body)
     10282                   :while (atom arg)
     10283                   :collect arg :into qualifiers
     10284                   :finally
     10285                      (destructuring-bind (o c) arg
     10286                        (pushnew
     10287                         (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
     10288                         (component-inline-methods ret)))))))
     10289
     10290  (defun %refresh-component-inline-methods (component rest)
     10291    ;; clear methods, then add the new ones
     10292    (%remove-component-inline-methods component)
     10293    (%define-component-inline-methods component rest)))
    1005610294
    1005710295
     
    1018310421             (component-options
    1018410422              (remove-plist-keys '(:defsystem-depends-on :class) options))
    10185              (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
    10186                                            (resolve-dependency-spec nil spec))))
     10423             (defsystem-dependencies (loop :for spec :in defsystem-depends-on
     10424                                           :when (resolve-dependency-spec nil spec)
     10425                                           :collect :it)))
    1018710426        ;; cache defsystem-depends-on in canonical form
    1018810427        (when defsystem-depends-on
     
    1021710456  (:export
    1021810457   #:bundle-op #:bundle-type #:program-system
    10219    #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
     10458   #:bundle-system #:bundle-pathname-type #:direct-dependency-files
    1022010459   #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
    1022110460   #:basic-compile-bundle-op #:prepare-bundle-op
     
    1023510474     (name-suffix :initarg :name-suffix :initform nil)
    1023610475     (bundle-type :initform :no-output-file :reader bundle-type)
    10237      #+ecl (lisp-files :initform nil :accessor extra-object-files)))
     10476     #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files)))
    1023810477
    1023910478  (defclass monolithic-op (operation) ()
     
    1027510514
    1027610515  (defclass gather-op (bundle-op)
    10277     ((gather-op :initform nil :allocation :class :reader gather-op))
     10516    ((gather-op :initform nil :allocation :class :reader gather-op)
     10517     (gather-type :initform :no-output-file :allocation :class :reader gather-type))
    1027810518    (:documentation "Abstract operation for gathering many input files from a system"))
    1027910519
     
    1029510535  ;; create a single fasl for the entire library
    1029610536  (defclass basic-compile-bundle-op (bundle-op)
    10297     ((bundle-type :initform :fasl)))
     10537    ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
     10538                  :allocation :class)
     10539     (bundle-type :initform :fasl :allocation :class)))
    1029810540
    1029910541  (defclass prepare-bundle-op (sideway-operation)
    10300     ((sideway-operation :initform #+(or ecl mkcl) 'load-bundle-op #-(or ecl mkcl) 'load-op
    10301                         :allocation :class)))
     10542    ((sideway-operation
     10543      :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
     10544      :allocation :class)))
    1030210545
    1030310546  (defclass lib-op (link-op gather-op non-propagating-operation)
    10304     ((bundle-type :initform :lib))
    10305     (:documentation "compile the system and produce linkable (.a) library for it."))
     10547    ((gather-type :initform :object :allocation :class)
     10548     (bundle-type :initform :lib :allocation :class))
     10549    (:documentation "Compile the system and produce a linkable static library (.a/.lib)
     10550for all the linkable object files associated with the system. Compare with DLL-OP.
     10551
     10552On most implementations, these object files only include extensions to the runtime
     10553written in C or another language with a compiler producing linkable object files.
     10554On CLASP, ECL, MKCL, these object files also include the contents of Lisp files
     10555themselves. In any case, this operation will produce what you need to further build
     10556a static runtime for your system, or a dynamic library to load in an existing runtime."))
    1030610557
    1030710558  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
    10308                                #+(or ecl mkcl) link-op #-ecl gather-op)
    10309     ((selfward-operation :initform '(prepare-bundle-op #+ecl lib-op) :allocation :class)))
     10559                               #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op)
     10560    ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
     10561                         :allocation :class))
     10562    (:documentation "This operator is an alternative to COMPILE-OP. Build a system
     10563and all of its dependencies, but build only a single (\"monolithic\") FASL, instead
     10564of one per source file, which may be more resource efficient.  That monolithic
     10565FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP."))
    1031010566
    1031110567  (defclass load-bundle-op (basic-load-op selfward-operation)
    10312     ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)))
     10568    ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))
     10569    (:documentation "This operator is an alternative to LOAD-OP. Build a system
     10570and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with
     10571respect to LOAD-OP is that it builds only a single FASL, which may be
     10572faster and more resource efficient."))
    1031310573
    1031410574  ;; NB: since the monolithic-op's can't be sideway-operation's,
     
    1031810578
    1031910579  (defclass dll-op (link-op gather-op non-propagating-operation)
    10320     ((bundle-type :initform :dll))
    10321     (:documentation "compile the system and produce dynamic (.so/.dll) library for it."))
     10580    ((gather-type :initform :object :allocation :class)
     10581     (bundle-type :initform :dll :allocation :class))
     10582    (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
     10583for all the linkable object files associated with the system. Compare with LIB-OP."))
    1032210584
    1032310585  (defclass deliver-asd-op (basic-compile-op selfward-operation)
    10324     ((selfward-operation :initform '(compile-bundle-op #+(or ecl mkcl) lib-op) :allocation :class))
     10586    ((selfward-operation
     10587      ;; TODO: implement link-op on all implementations, and make that
     10588      ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op)
     10589      :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op)
     10590      :allocation :class))
    1032510591    (:documentation "produce an asd file for delivering the system as a single fasl"))
    1032610592
    1032710593
    1032810594  (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
    10329     ((selfward-operation :initform '(monolithic-compile-bundle-op #+(or ecl mkcl) monolithic-lib-op)
    10330                          :allocation :class))
     10595    ((selfward-operation
     10596      ;; TODO: implement link-op on all implementations, and make that
     10597      ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
     10598      :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
     10599      :allocation :class))
    1033110600    (:documentation "produce fasl and asd files for combined system and dependencies."))
    1033210601
    10333   (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op
    10334                                           #+(or ecl mkcl) link-op gather-op non-propagating-operation)
    10335     ((gather-op :initform #+(or ecl mkcl) 'lib-op #-(or ecl mkcl) 'compile-bundle-op :allocation :class))
     10602  (defclass monolithic-compile-bundle-op
     10603      (monolithic-bundle-op basic-compile-bundle-op
     10604       #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation)
     10605    ((gather-op :initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op
     10606                :allocation :class)
     10607     (gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :static-library
     10608                  :allocation :class))
    1033610609    (:documentation "Create a single fasl for the system and its dependencies."))
    1033710610
     
    1034010613    (:documentation "Load a single fasl for the system and its dependencies."))
    1034110614
    10342   (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation) ()
    10343     (:documentation "Create a single linkable library for the system and its dependencies."))
     10615  (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation)
     10616    ((gather-type :initform :static-library :allocation :class))
     10617    (:documentation "Compile the system and produce a linkable static library (.a/.lib)
     10618for all the linkable object files associated with the system or its dependencies. See LIB-OP."))
    1034410619
    1034510620  (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation)
    10346     ((bundle-type :initform :dll))
    10347     (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
     10621    ((gather-type :initform :static-library :allocation :class))
     10622    (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
     10623for all the linkable object files associated with the system or its dependencies. See LIB-OP"))
    1034810624
    1034910625  (defclass image-op (monolithic-bundle-op selfward-operation
    10350                       #+(or ecl mkcl) link-op #+(or ecl mkcl) gather-op)
     10626                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
    1035110627    ((bundle-type :initform :image)
    10352      (selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class))
     10628     #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
     10629     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
    1035310630    (:documentation "create an image file from the system and its dependencies"))
    1035410631
     
    1035910636  (defun bundle-pathname-type (bundle-type)
    1036010637    (etypecase bundle-type
    10361       ((eql :no-output-file) nil) ;; should we error out instead?
    10362       ((or null string) bundle-type)
    10363       ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
    10364       #+ecl
    10365       ((member :dll :lib :shared-library :static-library :program :object :program)
    10366        (compile-file-type :type bundle-type))
    10367       ((member :image) #-allegro "image" #+allegro "dxl")
    10368       ((member :dll :shared-library) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
    10369       ((member :lib :static-library) (cond ((os-unix-p) "a")
    10370                                            ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
    10371       ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
     10638      ((or null string) ;; pass through nil or string literal
     10639       bundle-type)
     10640      ((eql :no-output-file) ;; marker for a bundle-type that has NO output file
     10641       (error "No output file, therefore no pathname type"))
     10642      ((eql :fasl) ;; the type of a fasl
     10643       #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output
     10644       #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles
     10645      ((member :image)
     10646       #+allegro "dxl"
     10647       #+(and clisp os-windows) "exe"
     10648       #-(or allegro (and clisp os-windows)) "image")
     10649      ;; NB: on CLASP and ECL these implementations, we better agree with
     10650      ;; (compile-file-type :type bundle-type))
     10651      ((eql :object) ;; the type of a linkable object file
     10652       (os-cond ((os-unix-p) "o")
     10653                ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj"))))
     10654      ((member :lib :static-library) ;; the type of a linkable library
     10655       (os-cond ((os-unix-p) "a")
     10656                ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
     10657      ((member :dll :shared-library) ;; the type of a shared library
     10658       (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
     10659      ((eql :program) ;; the type of an executable program
     10660       (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
    1037210661
    1037310662  (defun bundle-output-files (o c)
     
    1037910668              (type (bundle-pathname-type bundle-type)))
    1038010669          (values (list (subpathname (component-pathname c) name :type type))
    10381                   (eq (type-of o) (component-build-operation c)))))))
     10670                  (eq (type-of o) (coerce-class (component-build-operation c)
     10671                                                :package :asdf/interface
     10672                                                :super 'operation
     10673                                                :error nil)))))))
    1038210674
    1038310675  (defmethod output-files ((o bundle-op) (c system))
    1038410676    (bundle-output-files o c))
    1038510677
    10386   #-(or ecl mkcl)
     10678  #-(or clasp ecl mkcl)
    1038710679  (progn
    1038810680    (defmethod perform ((o image-op) (c system))
     
    1039210684
    1039310685  (defclass compiled-file (file-component)
    10394     ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
     10686    ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")))
    1039510687
    1039610688  (defclass precompiled-system (system)
     
    1041810710      (setf (slot-value instance 'name-suffix)
    1041910711            (unless (typep instance 'program-op)
    10420               (if (operation-monolithic-p instance) "--all-systems" #-(or ecl mkcl) "--system")))) ; . no good for Logical Pathnames
     10712              ;; "." is no good separator for Logical Pathnames, so we use "--"
     10713              (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system"))))
    1042110714    (when (typep instance 'monolithic-bundle-op)
    1042210715      (destructuring-bind (&key lisp-files prologue-code epilogue-code
     
    1042510718        (setf (prologue-code instance) prologue-code
    1042610719              (epilogue-code instance) epilogue-code)
    10427         #-ecl (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
    10428         #+ecl (setf (extra-object-files instance) lisp-files)))
     10720        #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
     10721        #+(or clasp ecl) (setf (extra-object-files instance) lisp-files)))
    1042910722    (setf (extra-build-args instance)
    1043010723          (remove-plist-keys
     
    1043210725             :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments
    1043310726           (operation-original-initargs instance))))
    10434 
    10435   (defun bundlable-file-p (pathname)
    10436     (let ((type (pathname-type pathname)))
    10437       (declare (ignorable type))
    10438       (or #+ecl (or (equalp type (compile-file-type :type :object))
    10439                     (equalp type (compile-file-type :type :static-library)))
    10440           #+mkcl (or (equalp type (compile-file-type :fasl-p nil))
    10441                      #+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW
    10442                      #+(and windows (not (or mingw32 mingw64))) (equalp type "lib"))
    10443           #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
    1044410727
    1044510728  (defgeneric* (trivial-system-p) (component))
     
    1047110754                       :when (funcall test f) :do (collect f))))))
    1047210755
     10756  (defun pathname-type-equal-function (type)
     10757    #'(lambda (p) (equal (pathname-type p) type)))
     10758
    1047310759  (defmethod input-files ((o gather-op) (c system))
    1047410760    (unless (eq (bundle-type o) :no-output-file)
    10475       (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)))
     10761      (direct-dependency-files
     10762       o c :key 'output-files
     10763           :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
    1047610764
    1047710765  (defun select-bundle-operation (type &optional monolithic)
     
    1063610924          (terpri s)))))
    1063710925
    10638   #-(or ecl mkcl)
     10926  #-(or clasp ecl mkcl)
    1063910927  (defmethod perform ((o basic-compile-bundle-op) (c system))
    1064010928    (let* ((input-files (input-files o c))
     
    1067010958|#
    1067110959
    10672 #+(or ecl mkcl)
    10673 (with-upgradability ()
    10674   ;; I think that Juanjo intended for this to be,
    10675   ;; but beware the weird bug in test-xach-update-bug.script,
    10676   ;; and also it makes mkcl fail test-logical-pathname.script,
    10677   ;; and ecl fail test-bundle.script.
    10678   ;;(unless (or #+ecl (use-ecl-byte-compiler-p))
     10960#+(or clasp ecl mkcl)
     10961(with-upgradability ()
     10962  ;; I think that Juanjo intended for this to be, but it was disabled before 3.1
     10963  ;; due to implementation bugs in ECL and MKCL that seem to have been fixed since
     10964  ;; -- see for ECL test-xach-update-bug.script and test-bundle.script,
     10965  ;; and for MKCL test-logical-pathname.script.
     10966  ;; We should probably reenable these after consulting with ECL and MKCL maintainers.
     10967  ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p))
    1067910968  ;;  (setf *load-system-operation* 'load-bundle-op))
    1068010969
    1068110970  (defun uiop-library-pathname ()
     10971    #+clasp (probe-file* (compile-file-pathname "sys:uiop" :output-type :object))
    1068210972    #+ecl (or (probe-file* (compile-file-pathname "sys:uiop" :type :lib)) ;; new style
    1068310973              (probe-file* (compile-file-pathname "sys:uiop" :type :object))) ;; old style
     
    1068510975
    1068610976  (defun asdf-library-pathname ()
     10977    #+clasp (probe-file* (compile-file-pathname "sys:asdf" :output-type :object))
    1068710978    #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style
    1068810979              (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style
     
    1069010981
    1069110982  (defun compiler-library-pathname ()
     10983    #+clasp (compile-file-pathname "sys:cmp" :output-type :lib)
    1069210984    #+ecl (compile-file-pathname "sys:cmp" :type :lib)
    1069310985    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))
     
    1070510997                   "cmp" (compiler-library-pathname))))
    1070610998           ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
    10707                `(cond
    10708                   ((system-source-directory :uiop) `(,(find-system :uiop)))
    10709                   ((system-source-directory :asdf) `(,(find-system :asdf)))
    10710                   (t `(,@(if-let (uiop (uiop-library-pathname))
    10711                            `(,(make-library-system "uiop" uiop)))
    10712                        ,(make-library-system "asdf" (asdf-library-pathname))))))
     10999               (cond
     11000                 ((system-source-directory :uiop) `(,(find-system :uiop)))
     11001                 ((system-source-directory :asdf) `(,(find-system :asdf)))
     11002                 (t `(,@(if-let (uiop (uiop-library-pathname))
     11003                          `(,(make-library-system "uiop" uiop)))
     11004                      ,(make-library-system "asdf" (asdf-library-pathname))))))
    1071311005           ,@deps)))))
    1071411006
     
    1073411026
    1073511027#+(and (not asdf-use-unsafe-mac-bundle-op)
    10736        (or (and ecl darwin)
     11028       (or (and clasp ecl darwin)
    1073711029           (and abcl darwin (not abcl-bundle-op-supported))))
    1073811030(defmethod perform :before ((o basic-compile-bundle-op) (c component))
     
    1074211034To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~
    1074311035Please report to ASDF-DEVEL if this works for you.")))
    10744 
    10745 
    10746 ;;; Backward compatibility with pre-3.1.2 names
    10747 ;; (defclass fasl-op (selfward-operation)
    10748 ;;   ((selfward-operation :initform 'compile-bundle-op :allocation :class)))
    10749 ;; (defclass load-fasl-op (selfward-operation)
    10750 ;;   ((selfward-operation :initform 'load-bundle-op :allocation :class)))
    10751 ;; (defclass binary-op (selfward-operation)
    10752 ;;   ((selfward-operation :initform 'deliver-asd-op :allocation :class)))
    10753 ;; (defclass monolithic-fasl-op (selfward-operation)
    10754 ;;   ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)))
    10755 ;; (defclass monolithic-load-fasl-op (selfward-operation)
    10756 ;;   ((selfward-operation :initform 'monolithic-load-bundle-op :allocation :class)))
    10757 ;; (defclass monolithic-binary-op (selfward-operation)
    10758 ;;   ((selfward-operation :initform 'monolithic-deliver-asd-op :allocation :class)))
    1075911036;;;; -------------------------------------------------------------------------
    1076011037;;;; Concatenate-source
     
    1084911126
    1085011127;;;; -------------------------------------------------------------------------
     11128;;;; Package systems in the style of quick-build or faslpath
     11129
     11130(uiop:define-package :asdf/package-inferred-system
     11131  (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
     11132  (:use :uiop/common-lisp :uiop
     11133        :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
     11134        :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
     11135  (:export
     11136   #:package-inferred-system #:sysdef-package-inferred-system-search
     11137   #:package-system ;; backward compatibility only. To be removed.
     11138   #:register-system-packages
     11139   #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
     11140(in-package :asdf/package-inferred-system)
     11141
     11142(with-upgradability ()
     11143  (defparameter *defpackage-forms* '(defpackage define-package))
     11144
     11145  (defun initial-package-inferred-systems-table ()
     11146    (let ((h (make-hash-table :test 'equal)))
     11147      (dolist (p (list-all-packages))
     11148        (dolist (n (package-names p))
     11149          (setf (gethash n h) t)))
     11150      h))
     11151
     11152  (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
     11153
     11154  (defclass package-inferred-system (system)
     11155    ())
     11156
     11157  ;; For backward compatibility only. To be removed in an upcoming release:
     11158  (defclass package-system (package-inferred-system) ())
     11159
     11160  (defun defpackage-form-p (form)
     11161    (and (consp form)
     11162         (member (car form) *defpackage-forms*)))
     11163
     11164  (defun stream-defpackage-form (stream)
     11165    (loop :for form = (read stream nil nil) :while form
     11166          :when (defpackage-form-p form) :return form))
     11167
     11168  (defun file-defpackage-form (file)
     11169    "Return the first DEFPACKAGE form in FILE."
     11170    (with-input-file (f file)
     11171      (stream-defpackage-form f)))
     11172
     11173  (define-condition package-inferred-system-missing-package-error (system-definition-error)
     11174    ((system :initarg :system :reader error-system)
     11175     (pathname :initarg :pathname :reader error-pathname))
     11176    (:report (lambda (c s)
     11177               (format s (compatfmt "~@<No package form found while ~
     11178                                     trying to define package-inferred-system ~A from file ~A~>")
     11179                       (error-system c) (error-pathname c)))))
     11180
     11181  (defun package-dependencies (defpackage-form)
     11182    "Return a list of packages depended on by the package
     11183defined in DEFPACKAGE-FORM.  A package is depended upon if
     11184the DEFPACKAGE-FORM uses it or imports a symbol from it."
     11185    (assert (defpackage-form-p defpackage-form))
     11186    (remove-duplicates
     11187     (while-collecting (dep)
     11188       (loop* :for (option . arguments) :in (cddr defpackage-form) :do
     11189              (ecase option
     11190                ((:use :mix :reexport :use-reexport :mix-reexport)
     11191                 (dolist (p arguments) (dep (string p))))
     11192                ((:import-from :shadowing-import-from)
     11193                 (dep (string (first arguments))))
     11194                ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
     11195     :from-end t :test 'equal))
     11196
     11197  (defun package-designator-name (package)
     11198    (etypecase package
     11199      (package (package-name package))
     11200      (string package)
     11201      (symbol (string package))))
     11202
     11203  (defun register-system-packages (system packages)
     11204    "Register SYSTEM as providing PACKAGES."
     11205    (let ((name (or (eq system t) (coerce-name system))))
     11206      (dolist (p (ensure-list packages))
     11207        (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
     11208
     11209  (defun package-name-system (package-name)
     11210    "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
     11211otherwise return a default system name computed from PACKAGE-NAME."
     11212    (check-type package-name string)
     11213    (if-let ((system-name (gethash package-name *package-inferred-systems*)))
     11214      system-name
     11215      (string-downcase package-name)))
     11216
     11217  (defun package-inferred-system-file-dependencies (file &optional system)
     11218    (if-let (defpackage-form (file-defpackage-form file))
     11219      (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
     11220      (error 'package-inferred-system-missing-package-error :system system :pathname file)))
     11221
     11222  (defun same-package-inferred-system-p (system name directory subpath dependencies)
     11223    (and (eq (type-of system) 'package-inferred-system)
     11224         (equal (component-name system) name)
     11225         (pathname-equal directory (component-pathname system))
     11226         (equal dependencies (component-sideway-dependencies system))
     11227         (let ((children (component-children system)))
     11228           (and (length=n-p children 1)
     11229                (let ((child (first children)))
     11230                  (and (eq (type-of child) 'cl-source-file)
     11231                       (equal (component-name child) "lisp")
     11232                       (and (slot-boundp child 'relative-pathname)
     11233                            (equal (slot-value child 'relative-pathname) subpath))))))))
     11234
     11235  (defun sysdef-package-inferred-system-search (system)
     11236    (let ((primary (primary-system-name system)))
     11237      (unless (equal primary system)
     11238        (let ((top (find-system primary nil)))
     11239          (when (typep top 'package-inferred-system)
     11240            (if-let (dir (component-pathname top))
     11241              (let* ((sub (subseq system (1+ (length primary))))
     11242                     (f (probe-file* (subpathname dir sub :type "lisp")
     11243                                     :truename *resolve-symlinks*)))
     11244                (when (file-pathname-p f)
     11245                  (let ((dependencies (package-inferred-system-file-dependencies f system))
     11246                        (previous (cdr (system-registered-p system))))
     11247                    (if (same-package-inferred-system-p previous system dir sub dependencies)
     11248                        previous
     11249                        (eval `(defsystem ,system
     11250                                 :class package-inferred-system
     11251                                 :source-file nil
     11252                                 :pathname ,dir
     11253                                 :depends-on ,dependencies
     11254                                 :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
     11255
     11256(with-upgradability ()
     11257  (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
     11258  (setf *system-definition-search-functions*
     11259        (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
     11260                *system-definition-search-functions*)))
     11261;;;; -------------------------------------------------------------------------
     11262;;; Internal hacks for backward-compatibility
     11263
     11264(uiop/package:define-package :asdf/backward-internals
     11265  (:recycle :asdf/backward-internals :asdf)
     11266  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
     11267  (:export ;; for internal use
     11268   #:make-sub-operation
     11269   #:load-sysdef #:make-temporary-package))
     11270(in-package :asdf/backward-internals)
     11271
     11272(when-upgrading (:when (fboundp 'make-sub-operation))
     11273  (defun make-sub-operation (c o dep-c dep-o)
     11274    (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
     11275
     11276;;;; load-sysdef
     11277(with-upgradability ()
     11278  (defun load-sysdef (name pathname)
     11279    (load-asd pathname :name name))
     11280
     11281  (defun make-temporary-package ()
     11282    ;; For loading a .asd file, we don't make a temporary package anymore,
     11283    ;; but use ASDF-USER. I'd like to have this function do this,
     11284    ;; but since whoever uses it is likely to delete-package the result afterwards,
     11285    ;; this would be a bad idea, so preserve the old behavior.
     11286    (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
     11287
     11288;;;; -------------------------------------------------------------------------
    1085111289;;; Backward-compatible interfaces
    1085211290
     
    1093611374        (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
    1093711375       (include-per-user-information nil)
    10938        (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
     11376       (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil))
    1093911377       (source-to-target-mappings nil)
    1094011378       (file-types `(,(compile-file-type)
    1094111379                     "build-report"
    10942                      #+ecl (compile-file-type :type :object)
     11380                     #+(or clasp ecl) (compile-file-type :type :object)
    1094311381                     #+mkcl (compile-file-type :fasl-p nil)
    1094411382                     #+clisp "lib" #+sbcl "cfasl"
    1094511383                     #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
    10946     #+(or clisp ecl mkcl)
     11384    #+(or clasp clisp ecl mkcl)
    1094711385    (when (null map-all-source-files)
    1094811386      (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
     
    1102111459                (acons property new-value (slot-value c 'properties)))))
    1102211460    new-value))
    11023 ;;;; -------------------------------------------------------------------------
    11024 ;;;; Package systems in the style of quick-build or faslpath
    11025 
    11026 (uiop:define-package :asdf/package-inferred-system
    11027   (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
    11028   (:use :uiop/common-lisp :uiop
    11029         :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
    11030         :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
    11031   (:export
    11032    #:package-inferred-system #:sysdef-package-inferred-system-search
    11033    #:package-system ;; backward compatibility only. To be removed.
    11034    #:register-system-packages
    11035    #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
    11036 (in-package :asdf/package-inferred-system)
    11037 
    11038 (with-upgradability ()
    11039   (defparameter *defpackage-forms* '(defpackage define-package))
    11040 
    11041   (defun initial-package-inferred-systems-table ()
    11042     (let ((h (make-hash-table :test 'equal)))
    11043       (dolist (p (list-all-packages))
    11044         (dolist (n (package-names p))
    11045           (setf (gethash n h) t)))
    11046       h))
    11047 
    11048   (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
    11049 
    11050   (defclass package-inferred-system (system)
    11051     ())
    11052 
    11053   ;; For backward compatibility only. To be removed in an upcoming release:
    11054   (defclass package-system (package-inferred-system) ())
    11055 
    11056   (defun defpackage-form-p (form)
    11057     (and (consp form)
    11058          (member (car form) *defpackage-forms*)))
    11059 
    11060   (defun stream-defpackage-form (stream)
    11061     (loop :for form = (read stream nil nil) :while form
    11062           :when (defpackage-form-p form) :return form))
    11063 
    11064   (defun file-defpackage-form (file)
    11065     "Return the first DEFPACKAGE form in FILE."
    11066     (with-input-file (f file)
    11067       (stream-defpackage-form f)))
    11068 
    11069   (define-condition package-inferred-system-missing-package-error (system-definition-error)
    11070     ((system :initarg :system :reader error-system)
    11071      (pathname :initarg :pathname :reader error-pathname))
    11072     (:report (lambda (c s)
    11073                (format s (compatfmt "~@<No package form found while ~
    11074                                      trying to define package-inferred-system ~A from file ~A~>")
    11075                        (error-system c) (error-pathname c)))))
    11076 
    11077   (defun package-dependencies (defpackage-form)
    11078     "Return a list of packages depended on by the package
    11079 defined in DEFPACKAGE-FORM.  A package is depended upon if
    11080 the DEFPACKAGE-FORM uses it or imports a symbol from it."
    11081     (assert (defpackage-form-p defpackage-form))
    11082     (remove-duplicates
    11083      (while-collecting (dep)
    11084        (loop* :for (option . arguments) :in (cddr defpackage-form) :do
    11085               (ecase option
    11086                 ((:use :mix :reexport :use-reexport :mix-reexport)
    11087                  (dolist (p arguments) (dep (string p))))
    11088                 ((:import-from :shadowing-import-from)
    11089                  (dep (string (first arguments))))
    11090                 ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
    11091      :from-end t :test 'equal))
    11092 
    11093   (defun package-designator-name (package)
    11094     (etypecase package
    11095       (package (package-name package))
    11096       (string package)
    11097       (symbol (string package))))
    11098 
    11099   (defun register-system-packages (system packages)
    11100     "Register SYSTEM as providing PACKAGES."
    11101     (let ((name (or (eq system t) (coerce-name system))))
    11102       (dolist (p (ensure-list packages))
    11103         (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
    11104 
    11105   (defun package-name-system (package-name)
    11106     "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
    11107 otherwise return a default system name computed from PACKAGE-NAME."
    11108     (check-type package-name string)
    11109     (if-let ((system-name (gethash package-name *package-inferred-systems*)))
    11110       system-name
    11111       (string-downcase package-name)))
    11112 
    11113   (defun package-inferred-system-file-dependencies (file &optional system)
    11114     (if-let (defpackage-form (file-defpackage-form file))
    11115       (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
    11116       (error 'package-inferred-system-missing-package-error :system system :pathname file)))
    11117 
    11118   (defun same-package-inferred-system-p (system name directory subpath dependencies)
    11119     (and (eq (type-of system) 'package-inferred-system)
    11120          (equal (component-name system) name)
    11121          (pathname-equal directory (component-pathname system))
    11122          (equal dependencies (component-sideway-dependencies system))
    11123          (let ((children (component-children system)))
    11124            (and (length=n-p children 1)
    11125                 (let ((child (first children)))
    11126                   (and (eq (type-of child) 'cl-source-file)
    11127                        (equal (component-name child) "lisp")
    11128                        (and (slot-boundp child 'relative-pathname)
    11129                             (equal (slot-value child 'relative-pathname) subpath))))))))
    11130 
    11131   (defun sysdef-package-inferred-system-search (system)
    11132     (let ((primary (primary-system-name system)))
    11133       (unless (equal primary system)
    11134         (let ((top (find-system primary nil)))
    11135           (when (typep top 'package-inferred-system)
    11136             (if-let (dir (system-source-directory top))
    11137               (let* ((sub (subseq system (1+ (length primary))))
    11138                      (f (probe-file* (subpathname dir sub :type "lisp")
    11139                                      :truename *resolve-symlinks*)))
    11140                 (when (file-pathname-p f)
    11141                   (let ((dependencies (package-inferred-system-file-dependencies f system))
    11142                         (previous (cdr (system-registered-p system))))
    11143                     (if (same-package-inferred-system-p previous system dir sub dependencies)
    11144                         previous
    11145                         (eval `(defsystem ,system
    11146                                  :class package-inferred-system
    11147                                  :source-file nil
    11148                                  :pathname ,dir
    11149                                  :depends-on ,dependencies
    11150                                  :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
    11151 
    11152 (with-upgradability ()
    11153   (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
    11154   (setf *system-definition-search-functions*
    11155         (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
    11156                 *system-definition-search-functions*)))
    1115711461;;;; ---------------------------------------------------------------------------
    1115811462;;;; Handle ASDF package upgrade, including implementation-dependent magic.
     
    1117311477  ;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
    1117411478  (:export
    11175    #:defsystem #:find-system #:locate-system #:coerce-name #:primary-system-name
     11479   #:defsystem #:find-system #:load-asd #:locate-system #:coerce-name #:primary-system-name
    1117611480   #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
    1117711481   #:system-definition-pathname
     
    1121511519   #:file-type #:source-file-type
    1121611520
     11521   #:register-preloaded-system #:sysdef-preloaded-system-search
     11522   #:register-immutable-system #:sysdef-immutable-system-search
     11523
    1121711524   #:package-inferred-system #:register-system-packages
    1121811525   #:package-system ;; backward-compatibility during migration, to be removed in a further release.
     
    1125911566   #:*compile-file-failure-behaviour*
    1126011567   #:*resolve-symlinks*
    11261    #:*load-system-operation* #:*immutable-systems*
     11568   #:*load-system-operation*
    1126211569   #:*asdf-verbose* ;; unused. For backward-compatibility only.
    1126311570   #:*verbose-out*
     
    1134811655
    1134911656;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
    11350 #+(or abcl clisp clozure cmu ecl mkcl sbcl)
     11657#+(or abcl clasp clisp clozure cmu ecl mkcl sbcl)
    1135111658(with-upgradability ()
    1135211659  (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
    1135311660    (eval `(pushnew 'module-provide-asdf
    1135411661                    #+abcl sys::*module-provider-functions*
     11662                    #+(or clasp cmu ecl) ext:*module-provider-functions*
    1135511663                    #+clisp ,x
    1135611664                    #+clozure ccl:*module-provider-functions*
    11357                     #+(or cmu ecl) ext:*module-provider-functions*
    1135811665                    #+mkcl mk-ext:*module-provider-functions*
    1135911666                    #+sbcl sb-ext:*module-provider-functions*)))
    1136011667
    11361   #+(or ecl mkcl)
     11668  #+(or clasp ecl mkcl)
    1136211669  (progn
    1136311670    (pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car)
    1136411671
    11365     #+(or (and ecl win32) (and mkcl windows))
    11366     (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
    11367       (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
    11368 
    11369     (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
    11370           (loop :for f :in #+ecl ext:*module-provider-functions*
     11672    #+(or (and clasp windows) (and ecl win32) (and mkcl windows))
     11673    (unless (assoc "asd" #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
     11674      (appendf #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
     11675
     11676    (setf #+(or clasp ecl) ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
     11677          (loop :for f :in #+(or clasp ecl) ext:*module-provider-functions*
    1137111678                #+mkcl mk-ext::*module-provider-functions*
    1137211679                :collect
Note: See TracChangeset for help on using the changeset viewer.