<html lang='en'>
<head>
<meta content='text/html; charset=utf-8' http-equiv='Content-Type'>
<title>
GitLab
</title>
</meta>
</head>
<style>
img {
max-width: 100%;
height: auto;
}
p.details {
font-style:italic;
color:#777
}
.footer p {
font-size:small;
color:#777
}
pre.commit-message {
white-space: pre-wrap;
}
.file-stats a {
text-decoration: none;
}
.file-stats .new-file {
color: #090;
}
.file-stats .deleted-file {
color: #B00;
}
</style>
<body>
<div class='content'>
<h3>Raymond Toy pushed to branch master at <a href="https://gitlab.common-lisp.net/cmucl/cmucl">cmucl / cmucl</a></h3>
<h4>
Commits:
</h4>
<ul>
<li>
<strong><a href="https://gitlab.common-lisp.net/cmucl/cmucl/commit/627b5fafb698aca6ac71db89bd7f5ca0bbeb9955">627b5faf</a></strong>
<div>
<span>by Raymond Toy</span>
<i>at 2015-07-21T21:50:49Z</i>
</div>
<pre class='commit-message'>Update to upstream ASDF 3.1.5.</pre>
</li>
</ul>
<h4>1 changed file:</h4>
<ul>
<li class='file-stats'>
<a href='#diff-0'>
src/contrib/asdf/asdf.lisp
</a>
</li>
</ul>
<h4>Changes:</h4>
<li id='diff-0'>
<a href='https://gitlab.common-lisp.net/cmucl/cmucl/commit/627b5fafb698aca6ac71db89bd7f5ca0bbeb9955#diff-0'>
<strong>
src/contrib/asdf/asdf.lisp
</strong>
</a>
<hr>
<pre class="highlight"><code><span style="color: #000000;background-color: #ffdddd">--- a/src/contrib/asdf/asdf.lisp
</span><span style="color: #000000;background-color: #ddffdd">+++ b/src/contrib/asdf/asdf.lisp
</span><span style="color: #aaaaaa">@@ -1,5 +1,5 @@
</span> ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
-;;; This is ASDF 3.1.4: Another System Definition Facility.
<span style="color: #000000;background-color: #ddffdd">+;;; This is ASDF 3.1.5: Another System Definition Facility.
</span> ;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
<span style="color: #aaaaaa">@@ -19,7 +19,7 @@
</span> ;;; http://www.opensource.org/licenses/mit-license.html on or about
;;; Monday; July 13, 2009)
;;;
-;;; Copyright (c) 2001-2014 Daniel Barlow and contributors
<span style="color: #000000;background-color: #ddffdd">+;;; Copyright (c) 2001-2015 Daniel Barlow and contributors
</span> ;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
<span style="color: #aaaaaa">@@ -122,7 +122,7 @@
</span> (t nil))))
(defun find-symbol* (name package-designator &optional (error t))
"Find a symbol in a package of given string'ified NAME;
-unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
<span style="color: #000000;background-color: #ddffdd">+unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
</span> by letting you supply a symbol or keyword for the name;
also works well when the package is not present.
If optional ERROR argument is NIL, return NIL instead of an error
<span style="color: #aaaaaa">@@ -819,7 +819,7 @@ UNINTERN -- Remove symbols here from PACKAGE."
</span> (let ((ensure-form
`(apply 'ensure-package ',(parse-define-package-form package clauses))))
`(progn
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl gcl mkcl) (defpackage ,package (:use))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl gcl mkcl) (defpackage ,package (:use))
</span> (eval-when (:compile-toplevel :load-toplevel :execute)
,ensure-form))))
<span style="color: #aaaaaa">@@ -859,7 +859,7 @@ UNINTERN -- Remove symbols here from PACKAGE."
</span> #+mcl (:shadow #:user-homedir-pathname))
(in-package :uiop/common-lisp)
-#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
<span style="color: #000000;background-color: #ddffdd">+#-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
</span> (error "ASDF is not supported on your implementation. Please help us port it.")
;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
<span style="color: #aaaaaa">@@ -867,12 +867,12 @@ UNINTERN -- Remove symbols here from PACKAGE."
</span>
;;;; Early meta-level tweaks
-#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl)
<span style="color: #000000;background-color: #ddffdd">+#+(or abcl allegro clasp clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl)
</span> (eval-when (:load-toplevel :compile-toplevel :execute)
;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie.
(when (and #+allegro (member :ics *features*)
<span style="color: #000000;background-color: #ffdddd">- #+(or clisp cmu ecl mkcl) (member :unicode *features*)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp clisp cmu ecl mkcl) (member :unicode *features*)
</span> #+sbcl (member :sb-unicode *features*))
(pushnew :asdf-unicode *features*)))
<span style="color: #aaaaaa">@@ -885,6 +885,11 @@ UNINTERN -- Remove symbols here from PACKAGE."
</span> (setf excl:*warn-on-nested-reader-conditionals* nil))
(setf *print-readably* nil))
<span style="color: #000000;background-color: #ddffdd">+#+clasp
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (setf *load-verbose* nil)
+ (defun use-ecl-byte-compiler-p () nil))
+
</span> #+clozure (in-package :ccl)
#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117
(eval-when (:load-toplevel :compile-toplevel :execute)
<span style="color: #aaaaaa">@@ -898,7 +903,6 @@ UNINTERN -- Remove symbols here from PACKAGE."
</span> (external-process-%status proc))))))
#+clozure (in-package :uiop/common-lisp)
-
#+cormanlisp
(eval-when (:load-toplevel :compile-toplevel :execute)
(deftype logical-pathname () nil)
<span style="color: #aaaaaa">@@ -911,7 +915,7 @@ UNINTERN -- Remove symbols here from PACKAGE."
</span> (setf p (pathname p))
(format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
-#+ecl
<span style="color: #000000;background-color: #ddffdd">+#+(and ecl (not clasp))
</span> (eval-when (:load-toplevel :compile-toplevel :execute)
(setf *load-verbose* nil)
(defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
<span style="color: #aaaaaa">@@ -1036,9 +1040,9 @@ Return a string made of the parts not omitted or emitted by FROB."
</span> (:use :uiop/common-lisp :uiop/package)
;; import and reexport a few things defined in :uiop/common-lisp
(:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
<span style="color: #000000;background-color: #ffdddd">- #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
</span> (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
<span style="color: #000000;background-color: #ffdddd">- #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
</span> (:export
;; magic helper to define debugging functions:
#:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
<span style="color: #aaaaaa">@@ -1053,6 +1057,7 @@ Return a string made of the parts not omitted or emitted by FROB."
</span> #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
#:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
#:string-prefix-p #:string-enclosed-p #:string-suffix-p
<span style="color: #000000;background-color: #ddffdd">+ #:standard-case-symbol-name #:find-standard-case-symbol
</span> #:coerce-class ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
#:earlier-stamp #:stamps-earliest #:earliest-stamp
<span style="color: #aaaaaa">@@ -1101,9 +1106,9 @@ Return a string made of the parts not omitted or emitted by FROB."
</span> `(progn
;; We usually try to do it only for the functions that need it,
;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
<span style="color: #000000;background-color: #ffdddd">- ,@(when (or supersede #+ecl t)
</span><span style="color: #000000;background-color: #ddffdd">+ ,@(when (or supersede #+(or clasp ecl) t)
</span> `((undefine-function ',name)))
<span style="color: #000000;background-color: #ffdddd">- ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
</span><span style="color: #000000;background-color: #ddffdd">+ ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl
</span> `((declaim (notinline ,name))))
(,',def ,name ,formals ,@rest))))))
(defdef defgeneric* defgeneric)
<span style="color: #aaaaaa">@@ -1223,15 +1228,26 @@ Returns two values: \(A B C\) and \(1 2 3\)."
</span>
;;; Characters
-(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR.
<span style="color: #000000;background-color: #ffdddd">- (defconstant +non-base-chars-exist-p+ #.(not (subtypep 'character 'base-char)))
- #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow???
- (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
</span>-
(with-upgradability ()
<span style="color: #000000;background-color: #ddffdd">+ ;; base-char != character on ECL, LW, SBCL, Genera.
+ ;; NB: We assume a total order on character types.
+ ;; If that's not true... this code will need to be updated.
</span> (defparameter +character-types+ ;; assuming a simple hierarchy
<span style="color: #000000;background-color: #ffdddd">- #(#+non-base-chars-exist-p base-char #+lispworks lw:simple-char character))
- (defparameter +max-character-type-index+ (1- (length +character-types+))))
</span><span style="color: #000000;background-color: #ddffdd">+ #.(coerce (loop* :for (type next) :on
+ '(;; In SCL, all characters seem to be 16-bit base-char
+ ;; Yet somehow character fails to be a subtype of base-char
+ #-scl base-char
+ ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
+ ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
+ #+(and lispworks (not (or lispworks4 lispworks5 lispworks6)))
+ lw:bmp-char
+ #+lispworks lw:simple-char
+ character)
+ :unless (and next (subtypep next type))
+ :collect type) 'vector))
+ (defparameter +max-character-type-index+ (1- (length +character-types+)))
+ (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+))
+ (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
</span>
(with-upgradability ()
(defun character-type-index (x)
<span style="color: #aaaaaa">@@ -1243,7 +1259,7 @@ Returns two values: \(A B C\) and \(1 2 3\)."
</span> (symbol (if (subtypep x 'base-char) 0 1))))
(otherwise
'(or (position-if (etypecase x
<span style="color: #000000;background-color: #ffdddd">- (character #'(lambda (type) (typep x type)))
</span><span style="color: #000000;background-color: #ddffdd">+ (character #'(lambda (type) (typep x type)))
</span> (symbol #'(lambda (type) (subtypep x type))))
+character-types+)
(error "Not a character or character type: ~S" x))))))
<span style="color: #aaaaaa">@@ -1262,14 +1278,20 @@ Returns two values: \(A B C\) and \(1 2 3\)."
</span> #.(if +non-base-chars-exist-p+
`(aref +character-types+
(loop :with index = 0 :for s :in strings :do
<span style="color: #000000;background-color: #ffdddd">- (cond
- ((= index ,+max-character-type-index+) (return index))
- ((emptyp s)) ;; NIL or empty string
- ((characterp s) (setf index (max index (character-type-index s))))
- ((stringp s) (unless (>= index (character-type-index (array-element-type s)))
- (setf index (reduce 'max s :key #'character-type-index
- :initial-value index))))
- (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type)))
</span><span style="color: #000000;background-color: #ddffdd">+ (flet ((consider (i)
+ (cond ((= i ,+max-character-type-index+) (return i))
+ ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i)))))))
+ (cond
+ ((emptyp s)) ;; NIL or empty string
+ ((characterp s) (consider (character-type-index s)))
+ ((stringp s) (let ((string-type-index
+ (character-type-index (array-element-type s))))
+ (unless (>= index string-type-index)
+ (loop :for c :across s :for i = (character-type-index c)
+ :do (consider i)
+ ,@(when (> +max-character-type-index+ 1)
+ `((when (= i string-type-index) (return))))))))
+ (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))))
</span> :finally (return index)))
''character))
<span style="color: #aaaaaa">@@ -1341,7 +1363,7 @@ starting the separation from the end, e.g. when called with arguments
</span> (defun string-enclosed-p (prefix string suffix)
"Does STRING begin with PREFIX and end with SUFFIX?"
(and (string-prefix-p prefix string)
<span style="color: #000000;background-color: #ffdddd">- (string-suffix-p string suffix))))
</span><span style="color: #000000;background-color: #ddffdd">+ (string-suffix-p string suffix)))
</span>
(defvar +cr+ (coerce #(#\Return) 'string))
(defvar +lf+ (coerce #(#\Linefeed) 'string))
<span style="color: #aaaaaa">@@ -1359,6 +1381,26 @@ the two results passed to STRCAT always reconstitute the original string"
</span> (return (values (subseq x 0 (- (length x) (length end))) end)))))
(when x (c +crlf+) (c +lf+) (c +cr+) (values x nil)))))
<span style="color: #000000;background-color: #ddffdd">+ (defun standard-case-symbol-name (name-designator)
+ "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING;
+if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\"
+platform such as Allegro with modern syntax."
+ (check-type name-designator (or string symbol))
+ (cond
+ ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower))
+ (string name-designator))
+ ;; Should we be doing something on CLISP?
+ (t (string-upcase name-designator))))
+
+ (defun find-standard-case-symbol (name-designator package-designator &optional (error t))
+ "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR,
+where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings.
+If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
+ (find-symbol* (standard-case-symbol-name name-designator)
+ (etypecase package-designator
+ ((or package symbol) package-designator)
+ (string (standard-case-symbol-name package-designator)))
+ error)))
</span>
;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
<span style="color: #aaaaaa">@@ -1577,10 +1619,10 @@ with later being determined by a lexicographical comparison of minor numbers."
</span> #+clisp 'system::$format-control
#+clozure 'ccl::format-control
#+(or cmu scl) 'conditions::format-control
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl) 'si::format-control
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl) 'si::format-control
</span> #+(or gcl lispworks) 'conditions::format-string
#+sbcl 'sb-kernel:format-control
<span style="color: #000000;background-color: #ffdddd">- #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or abcl allegro clasp clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil
</span> "Name of the slot for FORMAT-CONTROL in simple-condition")
(defun match-condition-p (x condition)
<span style="color: #aaaaaa">@@ -1622,6 +1664,7 @@ or a string describing the format-control of a simple-condition."
</span> (:use :uiop/common-lisp :uiop/package :uiop/utility)
(:export
#:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features
<span style="color: #000000;background-color: #ddffdd">+ #:os-cond
</span> #:getenv #:getenvp ;; environment variables
#:implementation-identifier ;; implementation identifier
#:implementation-type #:*implementation-type*
<span style="color: #aaaaaa">@@ -1647,32 +1690,29 @@ keywords explicitly."
</span> ((eq :and (car x)) (every #'featurep (cdr x)))
(t (error "Malformed feature specification ~S" x))))
<span style="color: #000000;background-color: #ffdddd">- (defun os-unix-p ()
- "Is the underlying operating system some Unix variant?"
- (or #+abcl (featurep :unix)
- #+(and (not abcl) (or unix cygwin darwin)) t))
</span>-
<span style="color: #000000;background-color: #ddffdd">+ ;; Starting with UIOP 3.1.5, these are runtime tests.
+ ;; You may bind *features* with a copy of what your target system offers to test its properties.
</span> (defun os-macosx-p ()
"Is the underlying operating system MacOS X?"
;; OS-MACOSX is not mutually exclusive with OS-UNIX,
;; in fact the former implies the latter.
<span style="color: #000000;background-color: #ffdddd">- (or
- #+allegro (featurep :macosx)
- #+clisp (featurep :macos)
- (featurep :darwin)))
</span><span style="color: #000000;background-color: #ddffdd">+ (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos))))
+
+ (defun os-unix-p ()
+ "Is the underlying operating system some Unix variant?"
+ (or (featurep '(:or :unix :cygwin)) (os-macosx-p)))
</span>
(defun os-windows-p ()
"Is the underlying operating system Microsoft Windows?"
<span style="color: #000000;background-color: #ffdddd">- (or #+abcl (featurep :windows)
- #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32 mingw64)) t))
</span><span style="color: #000000;background-color: #ddffdd">+ (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32 :mingw64))))
</span>
(defun os-genera-p ()
"Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
<span style="color: #000000;background-color: #ffdddd">- (or #+genera t))
</span><span style="color: #000000;background-color: #ddffdd">+ (featurep :genera))
</span>
(defun os-oldmac-p ()
"Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
<span style="color: #000000;background-color: #ffdddd">- (or #+mcl t))
</span><span style="color: #000000;background-color: #ddffdd">+ (featurep :mcl))
</span>
(defun detect-os ()
"Detects the current operating system. Only needs be run at compile-time,
<span style="color: #aaaaaa">@@ -1688,20 +1728,24 @@ except on ABCL where it might change between FASL compilation and runtime."
</span> (return (or o (error "Congratulations for trying ASDF on an operating system~%~
that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
<span style="color: #000000;background-color: #ddffdd">+ (defmacro os-cond (&rest clauses)
+ #+abcl `(cond ,@clauses)
+ #-abcl (loop* :for (test . body) :in clauses :when (eval test) :return `(progn ,@body)))
+
</span> (detect-os))
;;;; Environment variables: getting them, and parsing them.
-
(with-upgradability ()
(defun getenv (x)
"Query the environment, as in C getenv.
Beware: may return empty string if a variable is present but empty;
use getenvp to return NIL in such a case."
(declare (ignorable x))
<span style="color: #000000;background-color: #ffdddd">- #+(or abcl clisp ecl xcl) (ext:getenv x)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or abcl clasp clisp ecl xcl) (ext:getenv x)
</span> #+allegro (sys:getenv x)
#+clozure (ccl:getenv x)
<span style="color: #000000;background-color: #ffdddd">- #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
</span><span style="color: #000000;background-color: #ddffdd">+ #+cmu (unix:unix-getenv x)
+ #+scl (cdr (assoc x ext:*environment-list* :test #'string=))
</span> #+cormanlisp
(let* ((buffer (ct:malloc 1))
(cname (ct:lisp-string-to-c-string x))
<span style="color: #aaaaaa">@@ -1721,9 +1765,23 @@ use getenvp to return NIL in such a case."
</span> (ccl:%get-cstring value))))
#+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
#+sbcl (sb-ext:posix-getenv x)
<span style="color: #000000;background-color: #ffdddd">- #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
</span> (error "~S is not supported on your implementation" 'getenv))
<span style="color: #000000;background-color: #ddffdd">+ (defsetf getenv (x) (val)
+ "Set an environment variable."
+ (declare (ignorable x val))
+ #+allegro `(setf (sys:getenv ,x) ,val)
+ #+clisp `(system::setenv ,x ,val)
+ #+clozure `(ccl:setenv ,x ,val)
+ #+cmu `(unix:unix-setenv ,x ,val 1)
+ #+ecl `(ext:setenv ,x ,val)
+ #+lispworks `(hcl:setenv ,x ,val)
+ #+mkcl `(mkcl:setenv ,x ,val)
+ #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
+ #-(or allegro clisp clozure cmu ecl lispworks mkcl sbcl)
+ '(error "~S ~S is not supported on your implementation" 'setf 'getenv))
+
</span> (defun getenvp (x)
"Predicate that is true if the named variable is present in the libc environment,
then returning the non-empty string value of the variable"
<span style="color: #aaaaaa">@@ -1751,7 +1809,7 @@ then returning the non-empty string value of the variable"
</span> "The type of Lisp implementation used, as a short UIOP-standardized keyword"
(first-feature
'(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
<span style="color: #000000;background-color: #ffdddd">- (:cmu :cmucl :cmu) :ecl :gcl
</span><span style="color: #000000;background-color: #ddffdd">+ (:cmu :cmucl :cmu) :clasp :ecl :gcl
</span> (:lwpe :lispworks-personal-edition) (:lw :lispworks)
:mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
<span style="color: #aaaaaa">@@ -1817,9 +1875,11 @@ then returning the non-empty string value of the variable"
</span> #+scl (format nil "~A~A" s
;; ANSI upper case vs lower case.
(ecase ext:*case-mode* (:upper "") (:lower "l")))
<span style="color: #000000;background-color: #ffdddd">- #+ecl (format nil "~A~@[-~A~]" s
- (let ((vcs-id (ext:lisp-implementation-vcs-id)))
- (subseq vcs-id 0 (min (length vcs-id) 8))))
</span><span style="color: #000000;background-color: #ddffdd">+ #+clasp (format nil "~A-~A"
+ s (core:lisp-implementation-id))
+ #+(and ecl (not clasp)) (format nil "~A~@[-~A~]" s
+ (let ((vcs-id (ext:lisp-implementation-vcs-id)))
+ (subseq vcs-id 0 (min (length vcs-id) 8))))
</span> #+gcl (subseq s (1+ (position #\space s)))
#+genera
(multiple-value-bind (major minor) (sct:get-system-version "System")
<span style="color: #aaaaaa">@@ -1845,7 +1905,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
</span> (defun hostname ()
"return the hostname of the current host"
;; Note: untested on RMCL
<span style="color: #000000;background-color: #ffdddd">- #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or abcl clasp clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
</span> #+cormanlisp "localhost" ;; is there a better way? Does it matter?
#+allegro (symbol-call :excl.osi :gethostname)
#+clisp (first (split-string (machine-instance) :separator " "))
<span style="color: #aaaaaa">@@ -1865,18 +1925,15 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
</span>
(defun getcwd ()
"Get the current working directory as per POSIX getcwd(3), as a pathname object"
<span style="color: #000000;background-color: #ffdddd">- (or #+abcl (truename (symbol-call :asdf/filesystem :parse-native-namestring
- (java:jstatic "getProperty" "java.lang.System" "user.dir")
- :ensure-directory t))
</span><span style="color: #000000;background-color: #ddffdd">+ (or #+(or abcl genera xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
</span> #+allegro (excl::current-directory)
#+clisp (ext:default-directory)
#+clozure (ccl:current-directory)
#+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring
(strcat (nth-value 1 (unix:unix-current-directory)) "/"))
#+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
<span style="color: #000000;background-color: #ffdddd">- #+ecl (ext:getcwd)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (ext:getcwd)
</span> #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
<span style="color: #000000;background-color: #ffdddd">- #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
</span> #+lispworks (hcl:get-working-directory)
#+mkcl (mk-ext:getcwd)
#+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
<span style="color: #aaaaaa">@@ -1886,20 +1943,19 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
</span> (defun chdir (x)
"Change current directory, as per POSIX chdir(2), to a given pathname object"
(if-let (x (pathname x))
<span style="color: #000000;background-color: #ffdddd">- #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or abcl genera xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
</span> #+allegro (excl:chdir x)
#+clisp (ext:cd x)
#+clozure (setf (ccl:current-directory) x)
#+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
#+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
(error "Could not set current directory to ~A" x))
<span style="color: #000000;background-color: #ffdddd">- #+ecl (ext:chdir x)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (ext:chdir x)
</span> #+gcl (system:chdir x)
<span style="color: #000000;background-color: #ffdddd">- #+genera (setf *default-pathname-defaults* x)
</span> #+lispworks (hcl:change-directory x)
#+mkcl (mk-ext:chdir x)
#+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
<span style="color: #000000;background-color: #ffdddd">- #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl)
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
</span> (error "chdir not supported on your implementation"))))
<span style="color: #aaaaaa">@@ -2080,7 +2136,7 @@ by the underlying implementation's MAKE-PATHNAME and other primitives"
</span> ;; This will be :unspecific if supported, or NIL if not.
(defparameter *unspecific-pathname-type*
#+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific
<span style="color: #000000;background-color: #ffdddd">- #+(or clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil
</span> "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
(defun make-pathname* (&rest keys &key (directory nil)
<span style="color: #aaaaaa">@@ -2191,9 +2247,14 @@ when merging, making or parsing pathnames"
</span> when merging, making or parsing pathnames")
(defmacro with-pathname-defaults ((&optional defaults) &body body)
<span style="color: #000000;background-color: #ffdddd">- "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* are as neutral as possible
</span>-when merging, making or parsing pathnames"
<span style="color: #000000;background-color: #ffdddd">- `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body)))
</span><span style="color: #000000;background-color: #ddffdd">+ "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified,
+where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except
+on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory."
+ `(let ((*default-pathname-defaults*
+ ,(or defaults
+ #-(or abcl genera xcl) '*nil-pathname*
+ #+(or abcl genera xcl) '*default-pathname-defaults*)))
+ ,@body)))
</span>
;;; Some pathname predicates
<span style="color: #aaaaaa">@@ -2392,9 +2453,9 @@ For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
</span> "Coerce NAME into a PATHNAME using standard Unix syntax.
Unix syntax is used whether or not the underlying system is Unix;
-on such non-Unix systems it is only usable but for relative pathnames;
-but especially to manipulate relative pathnames portably, it is of crucial
-to possess a portable pathname syntax independent of the underlying OS.
<span style="color: #000000;background-color: #ddffdd">+on such non-Unix systems it is reliably usable only for relative pathnames.
+This function is especially useful to manipulate relative pathnames portably,
+where it is of crucial to possess a portable pathname syntax independent of the underlying OS.
</span> This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
When given a PATHNAME object, just return it untouched.
<span style="color: #aaaaaa">@@ -2412,8 +2473,8 @@ The last #\\/-separated substring is interpreted as follows:
</span> are separated by SPLIT-NAME-TYPE.
3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
-Directory components with an empty name the name . are removed.
-Any directory named .. is read as DOT-DOT,
<span style="color: #000000;background-color: #ddffdd">+Directory components with an empty name or the name \".\" are removed.
+Any directory named \"..\" is read as DOT-DOT,
</span> which must be one of :BACK or :UP and defaults to :BACK.
HOST, DEVICE and VERSION components are taken from DEFAULTS,
<span style="color: #aaaaaa">@@ -2560,7 +2621,7 @@ when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPA
</span> (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
(directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
(pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
<span style="color: #000000;background-color: #ffdddd">- (with-pathname-defaults ()
</span><span style="color: #000000;background-color: #ddffdd">+ (with-pathname-defaults (*nil-pathname*)
</span> (let ((enough (enough-namestring maybe-subpath base-pathname)))
(and (relative-pathname-p enough) (pathname enough))))))
<span style="color: #aaaaaa">@@ -2644,9 +2705,10 @@ given DEFAULTS-PATHNAME as a base pathname."
</span> (defun directorize-pathname-host-device (pathname)
"Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
added to its DIRECTORY component. This is useful for output translations."
<span style="color: #000000;background-color: #ffdddd">- #+(or unix abcl)
- (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
- (return-from directorize-pathname-host-device pathname))
</span><span style="color: #000000;background-color: #ddffdd">+ (os-cond
+ ((os-unix-p)
+ (when (physical-pathname-p pathname)
+ (return-from directorize-pathname-host-device pathname))))
</span> (let* ((root (pathname-root pathname))
(wild-root (wilden root))
(absolute-pathname (merge-pathnames* pathname root))
<span style="color: #aaaaaa">@@ -2758,8 +2820,9 @@ you need to still be able to use compile-op on that lisp file."))
</span> #+(or cmu scl) (ext:unix-namestring p nil)
#+sbcl (sb-ext:native-namestring p)
#-(or clozure cmu sbcl scl)
<span style="color: #000000;background-color: #ffdddd">- (if (os-unix-p) (unix-namestring p)
- (namestring p)))))
</span><span style="color: #000000;background-color: #ddffdd">+ (os-cond
+ ((os-unix-p) (unix-namestring p))
+ (t (namestring p))))))
</span>
(defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
"From a native namestring suitable for use by the operating system, return
<span style="color: #aaaaaa">@@ -2771,9 +2834,9 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
</span> #+clozure (ccl:native-to-pathname string)
#+sbcl (sb-ext:parse-native-namestring string)
#-(or clozure sbcl)
<span style="color: #000000;background-color: #ffdddd">- (if (os-unix-p)
- (parse-unix-namestring string :ensure-directory ensure-directory)
- (parse-namestring string)))))
</span><span style="color: #000000;background-color: #ddffdd">+ (os-cond
+ ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory))
+ (t (parse-namestring string))))))
</span> (pathname
(if ensure-directory
(and pathname (ensure-directory-pathname pathname))
<span style="color: #aaaaaa">@@ -2784,9 +2847,14 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
</span> ;;; Probing the filesystem
(with-upgradability ()
(defun truename* (p)
<span style="color: #000000;background-color: #ffdddd">- "Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts"
- ;; avoids both logical-pathname merging and physical resolution issues
- (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
</span><span style="color: #000000;background-color: #ddffdd">+ "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
+ (when p
+ (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p))))
+ (values
+ (or (ignore-errors (truename p))
+ ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
+ ;; a trailing directory separator, causes an error on some lisps.
+ #+(or clisp gcl) (if-let (d (ensure-directory-pathname p)) (ignore-errors (truename d)))))))
</span>
(defun safe-file-write-date (pathname)
"Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
<span style="color: #aaaaaa">@@ -2807,59 +2875,54 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
</span> probes the filesystem for a file or directory with given pathname.
If it exists, return its truename is ENSURE-PATHNAME is true,
or the original (parsed) pathname if it is false (the default)."
<span style="color: #000000;background-color: #ffdddd">- (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
- (etypecase p
- (null nil)
- (string (probe-file* (parse-namestring p) :truename truename))
- (pathname
- (and (not (wild-pathname-p p))
- (handler-case
- (or
- #+allegro
- (probe-file p :follow-symlinks truename)
- #+gcl
- (if truename
- (truename* p)
- (let ((kind (car (si::stat p))))
- (when (eq kind :link)
- (setf kind (ignore-errors (car (si::stat (truename* p))))))
- (ecase kind
- ((nil) nil)
- ((:file :link)
- (cond
- ((file-pathname-p p) p)
- ((directory-pathname-p p)
- (subpathname p (car (last (pathname-directory p)))))))
- (:directory (ensure-directory-pathname p)))))
- #+clisp
- #.(flet ((probe (probe)
- `(let ((foundtrue ,probe))
- (cond
- (truename foundtrue)
- (foundtrue p)))))
- (let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
- (pp (find-symbol* '#:probe-pathname :ext nil))
- (resolve (if pp
- `(ignore-errors (,pp p))
- '(or (truename* p)
- (truename* (ignore-errors (ensure-directory-pathname p)))))))
- (if fs
- `(if truename
- ,resolve
- (and (ignore-errors (,fs p)) p))
- (probe resolve))))
- #-(or allegro clisp gcl)
- (if truename
- (probe-file p)
- (ignore-errors
- (let ((pp (physicalize-pathname p)))
- (and
- #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
- #+(and lispworks unix) (system:get-file-stat pp)
- #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
- #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
- p)))))
- (file-error () nil)))))))
</span><span style="color: #000000;background-color: #ddffdd">+ (values
+ (ignore-errors
+ (setf p (funcall 'ensure-pathname p
+ :namestring :lisp
+ :ensure-physical t
+ :ensure-absolute t :defaults 'get-pathname-defaults
+ :want-non-wild t
+ :on-error nil))
+ (when p
+ #+allegro
+ (probe-file p :follow-symlinks truename)
+ #+gcl
+ (if truename
+ (truename* p)
+ (let ((kind (car (si::stat p))))
+ (when (eq kind :link)
+ (setf kind (ignore-errors (car (si::stat (truename* p))))))
+ (ecase kind
+ ((nil) nil)
+ ((:file :link)
+ (cond
+ ((file-pathname-p p) p)
+ ((directory-pathname-p p)
+ (subpathname p (car (last (pathname-directory p)))))))
+ (:directory (ensure-directory-pathname p)))))
+ #+clisp
+ #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
+ (pp (find-symbol* '#:probe-pathname :ext nil)))
+ `(if truename
+ ,(if pp
+ `(values (,pp p))
+ '(or (truename* p)
+ (truename* (ignore-errors (ensure-directory-pathname p)))))
+ ,(cond
+ (fs `(and (,fs p) p))
+ (pp `(nth-value 1 (,pp p)))
+ (t '(or (and (truename* p) p)
+ (if-let (d (ensure-directory-pathname p))
+ (and (truename* d) d)))))))
+ #-(or allegro clisp gcl)
+ (if truename
+ (probe-file p)
+ (and
+ #+(or cmu scl) (unix:unix-stat (ext:unix-namestring p))
+ #+(and lispworks unix) (system:get-file-stat p)
+ #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
+ #-(or cmu (and lispworks unix) sbcl scl) (file-write-date p)
+ p))))))
</span>
(defun directory-exists-p (x)
"Is X the name of a directory that exists on the filesystem?"
<span style="color: #aaaaaa">@@ -3054,6 +3117,7 @@ Defaults to T.")
</span> (pathname &key
on-error
defaults type dot-dot namestring
<span style="color: #000000;background-color: #ddffdd">+ empty-is-nil
</span> want-pathname
want-logical want-physical ensure-physical
want-relative want-absolute ensure-absolute ensure-subpath
<span style="color: #aaaaaa">@@ -3097,6 +3161,7 @@ You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
</span> The transformations and constraint checks are done in this order,
which is also the order in the lambda-list:
<span style="color: #000000;background-color: #ddffdd">+EMPTY-IS-NIL returns NIL if the argument is an empty string.
</span> WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
<span style="color: #aaaaaa">@@ -3136,6 +3201,8 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
</span> (etypecase p
((or null pathname))
(string
<span style="color: #000000;background-color: #ddffdd">+ (when (and (emptyp p) empty-is-nil)
+ (return-from ensure-pathname nil))
</span> (setf p (case namestring
((:unix nil)
(parse-unix-namestring
<span style="color: #aaaaaa">@@ -3218,13 +3285,14 @@ Note that this operation is usually NOT thread-safe."
</span> (with-upgradability ()
(defun inter-directory-separator ()
"What character does the current OS conventionally uses to separate directories?"
<span style="color: #000000;background-color: #ffdddd">- (if (os-unix-p) #\: #\;))
</span><span style="color: #000000;background-color: #ddffdd">+ (os-cond ((os-unix-p) #\:) (t #\;)))
</span>
(defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
"Given a string of pathnames specified in native OS syntax, separate them in a list,
-check constraints and normalize each one as per ENSURE-PATHNAME."
<span style="color: #000000;background-color: #ddffdd">+check constraints and normalize each one as per ENSURE-PATHNAME,
+where an empty string denotes NIL."
</span> (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
<span style="color: #000000;background-color: #ffdddd">- :collect (apply 'parse-native-namestring namestring constraints)))
</span><span style="color: #000000;background-color: #ddffdd">+ :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints))))
</span>
(defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
"Extract a pathname from a user-configured environment variable, as per native OS,
<span style="color: #aaaaaa">@@ -3237,10 +3305,14 @@ check constraints and normalize as per ENSURE-PATHNAME."
</span> constraints))
(defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
"Extract a list of pathname from a user-configured environment variable, as per native OS,
-check constraints and normalize each one as per ENSURE-PATHNAME."
<span style="color: #000000;background-color: #ddffdd">+check constraints and normalize each one as per ENSURE-PATHNAME.
+ Any empty entries in the environment variable X will be returned as NILs."
+ (unless (getf constraints :empty-is-nil t)
+ (error "Cannot have EMPTY-IS-NIL false for GETENV-PATHNAMES."))
</span> (apply 'split-native-pathnames-string (getenvp x)
:on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
<span style="color: #000000;background-color: #ddffdd">+ :empty-is-nil t
</span> constraints))
(defun getenv-absolute-directory (x)
"Extract an absolute directory pathname from a user-configured environment variable,
<span style="color: #aaaaaa">@@ -3248,17 +3320,18 @@ as per native OS"
</span> (getenv-pathname x :want-absolute t :ensure-directory t))
(defun getenv-absolute-directories (x)
"Extract a list of absolute directories from a user-configured environment variable,
-as per native OS"
<span style="color: #000000;background-color: #ddffdd">+as per native OS. Any empty entries in the environment variable X will be returned as
+NILs."
</span> (getenv-pathnames x :want-absolute t :ensure-directory t))
(defun lisp-implementation-directory (&key truename)
"Where are the system files of the current installation of the CL implementation?"
(declare (ignorable truename))
<span style="color: #000000;background-color: #ffdddd">- #+(or clozure ecl gcl mkcl sbcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp clozure ecl gcl mkcl sbcl)
</span> (let ((dir
(ignore-errors
#+clozure #p"ccl:"
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl) #p"SYS:"
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl) #p"SYS:"
</span> #+gcl system::*system-directory*
#+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
(funcall it)
<span style="color: #aaaaaa">@@ -3288,19 +3361,20 @@ as per native OS"
</span> (when pathname
(ensure-directories-exist (physicalize-pathname pathname)))))
<span style="color: #000000;background-color: #ddffdd">+ (defun delete-file-if-exists (x)
+ "Delete a file X if it already exists"
+ (when x (handler-case (delete-file x) (file-error () nil))))
+
</span> (defun rename-file-overwriting-target (source target)
"Rename a file, overwriting any previous file with the TARGET name,
in an atomic way if the implementation allows."
#+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
(progn (funcall 'require "syscalls")
(symbol-call :posix :copy-file source target :method :rename))
<span style="color: #000000;background-color: #ddffdd">+ #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic
</span> #-clisp
(rename-file source target
<span style="color: #000000;background-color: #ffdddd">- #+(or clozure ecl) :if-exists #+clozure :rename-and-delete #+ecl t))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun delete-file-if-exists (x)
- "Delete a file X if it already exists"
- (when x (handler-case (delete-file x) (file-error () nil))))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp clozure ecl) :if-exists #+clozure :rename-and-delete #+(or clasp ecl) t))
</span>
(defun delete-empty-directory (directory-pathname)
"Delete an empty directory"
<span style="color: #aaaaaa">@@ -3316,7 +3390,7 @@ in an atomic way if the implementation allows."
</span> #+scl (error "~@<Error deleting ~S: ~A~@:>"
directory-pathname (unix:get-unix-error-msg errno))))
#+cormanlisp (win32:delete-directory directory-pathname)
<span style="color: #000000;background-color: #ffdddd">- #+ecl (si:rmdir directory-pathname)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (si:rmdir directory-pathname)
</span> #+genera (fs:delete-directory directory-pathname)
#+lispworks (lw:delete-directory directory-pathname)
#+mkcl (mkcl:rmdir directory-pathname)
<span style="color: #aaaaaa">@@ -3324,7 +3398,7 @@ in an atomic way if the implementation allows."
</span> `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
`(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
#+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
<span style="color: #000000;background-color: #ffdddd">- #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or abcl allegro clasp clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
</span> (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
(defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
<span style="color: #aaaaaa">@@ -3345,18 +3419,18 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
</span> ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname)
(physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
(error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
<span style="color: #000000;background-color: #ffdddd">- 'delete-filesystem-tree directory-pathname))
</span><span style="color: #000000;background-color: #ddffdd">+ 'delete-directory-tree directory-pathname))
</span> ((not validatep)
(error "~S was asked to delete ~S but was not provided a validation predicate"
<span style="color: #000000;background-color: #ffdddd">- 'delete-filesystem-tree directory-pathname))
</span><span style="color: #000000;background-color: #ddffdd">+ 'delete-directory-tree directory-pathname))
</span> ((not (call-function validate directory-pathname))
(error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
<span style="color: #000000;background-color: #ffdddd">- 'delete-filesystem-tree directory-pathname validate))
</span><span style="color: #000000;background-color: #ddffdd">+ 'delete-directory-tree directory-pathname validate))
</span> ((not (directory-exists-p directory-pathname))
(ecase if-does-not-exist
(:error
(error "~S was asked to delete ~S but the directory does not exist"
<span style="color: #000000;background-color: #ffdddd">- 'delete-filesystem-tree directory-pathname))
</span><span style="color: #000000;background-color: #ddffdd">+ 'delete-directory-tree directory-pathname))
</span> (:ignore nil)))
#-(or allegro cmu clozure genera sbcl scl)
((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
<span style="color: #aaaaaa">@@ -3381,7 +3455,6 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
</span> (dolist (d (nreverse sub*directories))
(map () 'delete-file (directory-files d))
(delete-empty-directory d)))))))
-
;;;; ---------------------------------------------------------------------------
;;;; Utilities related to streams
<span style="color: #aaaaaa">@@ -3430,7 +3503,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
</span> (setf *stdin*
#.(or #+clozure 'ccl::*stdin*
#+(or cmu scl) 'system:*stdin*
<span style="color: #000000;background-color: #ffdddd">- #+ecl 'ext::+process-standard-input+
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) 'ext::+process-standard-input+
</span> #+sbcl 'sb-sys:*stdin*
'*standard-input*)))
<span style="color: #aaaaaa">@@ -3441,7 +3514,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
</span> (setf *stdout*
#.(or #+clozure 'ccl::*stdout*
#+(or cmu scl) 'system:*stdout*
<span style="color: #000000;background-color: #ffdddd">- #+ecl 'ext::+process-standard-output+
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) 'ext::+process-standard-output+
</span> #+sbcl 'sb-sys:*stdout*
'*standard-output*)))
<span style="color: #aaaaaa">@@ -3453,7 +3526,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
</span> #.(or #+allegro 'excl::*stderr*
#+clozure 'ccl::*stderr*
#+(or cmu scl) 'system:*stderr*
<span style="color: #000000;background-color: #ffdddd">- #+ecl 'ext::+process-error-output+
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) 'ext::+process-error-output+
</span> #+sbcl 'sb-sys:*stderr*
'*error-output*)))
<span style="color: #aaaaaa">@@ -3661,7 +3734,7 @@ and return that"
</span> (defun null-device-pathname ()
"Pathname to a bit bucket device that discards any information written to it
and always returns EOF when read from"
<span style="color: #000000;background-color: #ffdddd">- (cond
</span><span style="color: #000000;background-color: #ddffdd">+ (os-cond
</span> ((os-unix-p) #p"/dev/null")
((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
(t (error "No /dev/null on your OS"))))
<span style="color: #aaaaaa">@@ -3912,13 +3985,13 @@ If a string, repeatedly read and evaluate from it, returning the last values."
</span> (with-upgradability ()
(defun default-temporary-directory ()
"Return a default directory to use for temporary files"
<span style="color: #000000;background-color: #ffdddd">- (or
- (when (os-unix-p)
</span><span style="color: #000000;background-color: #ddffdd">+ (os-cond
+ ((os-unix-p)
</span> (or (getenv-pathname "TMPDIR" :ensure-directory t)
(parse-native-namestring "/tmp/")))
<span style="color: #000000;background-color: #ffdddd">- (when (os-windows-p)
</span><span style="color: #000000;background-color: #ddffdd">+ ((os-windows-p)
</span> (getenv-pathname "TEMP" :ensure-directory t))
<span style="color: #000000;background-color: #ffdddd">- (subpathname (user-homedir-pathname) "tmp/")))
</span><span style="color: #000000;background-color: #ddffdd">+ (t (subpathname (user-homedir-pathname) "tmp/"))))
</span>
(defvar *temporary-directory* nil "User-configurable location for temporary files")
<span style="color: #aaaaaa">@@ -3985,17 +4058,17 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e
</span> (when stream
(setf okp pathname)
(when want-stream-p
<span style="color: #000000;background-color: #ffdddd">- (setf results
- (multiple-value-list
- (if want-pathname-p
- (funcall thunk stream pathname)
- (funcall thunk stream)))))))
- (when okp
- (unless want-stream-p
- (setf results (multiple-value-list (call-function thunk pathname))))
- (when after
- (setf results (multiple-value-list (call-function after pathname))))
- (return (apply 'values results))))
</span><span style="color: #000000;background-color: #ddffdd">+ ;; Note: can't return directly from within with-open-file
+ ;; or the non-local return causes the file creation to be undone.
+ (setf results (multiple-value-list
+ (if want-pathname-p
+ (funcall thunk stream pathname)
+ (funcall thunk stream)))))))
+ (cond
+ ((not okp) nil)
+ (after (return (call-function after okp)))
+ ((and want-pathname-p (not want-stream-p)) (return (call-function thunk okp)))
+ (t (return (apply 'values results)))))
</span> (when (and okp (not (call-function keep)))
(ignore-errors (delete-file-if-exists okp))))))
<span style="color: #aaaaaa">@@ -4143,11 +4216,11 @@ This is designed to abstract away the implementation specific quit forms."
</span> (finish-outputs))
#+(or abcl xcl) (ext:quit :status code)
#+allegro (excl:exit code :quiet t)
<span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (si:quit code)
</span> #+clisp (ext:quit code)
#+clozure (ccl:quit code)
#+cormanlisp (win32:exitprocess code)
#+(or cmu scl) (unix:unix-exit code)
<span style="color: #000000;background-color: #ffdddd">- #+ecl (si:quit code)
</span> #+gcl (system:quit code)
#+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
#+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
<span style="color: #aaaaaa">@@ -4158,7 +4231,7 @@ This is designed to abstract away the implementation specific quit forms."
</span> (cond
(exit `(,exit :code code :abort (not finish-output)))
(quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
<span style="color: #000000;background-color: #ffdddd">- #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
</span> (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
(defun die (code format &rest arguments)
<span style="color: #aaaaaa">@@ -4185,6 +4258,15 @@ This is designed to abstract away the implementation specific quit forms."
</span> :from-read-eval-print-loop nil
:count (or count t)
:all t))
<span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl)
+ (let* ((top (si:ihs-top))
+ (repeats (if count (min top count) top))
+ (backtrace (loop :for ihs :from 0 :below top
+ :collect (list (si::ihs-fun ihs)
+ (si::ihs-env ihs)))))
+ (loop :for i :from 0 :below repeats
+ :for frame :in (nreverse backtrace) :do
+ (safe-format! stream "~&~D: ~S~%" i frame)))
</span> #+clisp
(system::print-backtrace :out stream :limit count)
#+(or clozure mcl)
<span style="color: #aaaaaa">@@ -4196,15 +4278,6 @@ This is designed to abstract away the implementation specific quit forms."
</span> (let ((debug:*debug-print-level* *print-level*)
(debug:*debug-print-length* *print-length*))
(debug:backtrace (or count most-positive-fixnum) stream))
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl)
- (let* ((top (si:ihs-top))
- (repeats (if count (min top count) top))
- (backtrace (loop :for ihs :from 0 :below top
- :collect (list (si::ihs-fun ihs)
- (si::ihs-env ihs)))))
- (loop :for i :from 0 :below repeats
- :for frame :in (nreverse backtrace) :do
- (safe-format! stream "~&~D: ~S~%" i frame)))
</span> #+gcl
(let ((*debug-io* stream))
(ignore-errors
<span style="color: #aaaaaa">@@ -4304,17 +4377,17 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die"
</span> "Find what the actual command line for this process was."
#+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
#+allegro (sys:command-line-arguments) ; default: :application t
<span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
</span> #+clisp (coerce (ext:argv) 'list)
#+clozure ccl:*command-line-argument-list*
#+(or cmu scl) extensions:*command-line-strings*
<span style="color: #000000;background-color: #ffdddd">- #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
</span> #+gcl si:*command-args*
#+(or genera mcl) nil
#+lispworks sys:*line-arguments-list*
#+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i))
#+sbcl sb-ext:*posix-argv*
#+xcl system:*argv*
<span style="color: #000000;background-color: #ffdddd">- #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
</span> (error "raw-command-line-arguments not implemented yet"))
(defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
<span style="color: #aaaaaa">@@ -4345,7 +4418,7 @@ Otherwise, return NIL."
</span> ;; NB: not currently available on ABCL, Corman, Genera, MCL
(or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl)
(first (raw-command-line-arguments))
<span style="color: #000000;background-color: #ffdddd">- #+ecl (si:argv 0) #+mkcl (mkcl:argv 0)))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0)))
</span> (t ;; argv[0] is the name of the interpreter.
;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
(getenvp "__CL_ARGV0"))))
<span style="color: #aaaaaa">@@ -4505,37 +4578,38 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
</span> ;; Is it meaningful to run these in the current environment?
;; only if we also track the object files that constitute the "current" image,
;; and otherwise simulate dump-image, including quitting at the end.
<span style="color: #000000;background-color: #ffdddd">- #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
- #+(or ecl mkcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or clasp ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
+ #+(or clasp ecl mkcl)
</span> (let ((epilogue-code
<span style="color: #000000;background-color: #ffdddd">- (if no-uiop
- epilogue-code
- (let ((forms
- (append
- (when epilogue-code `(,epilogue-code))
- (when postludep `((setf *image-postlude* ',postlude)))
- (when preludep `((setf *image-prelude* ',prelude)))
- (when entry-point-p `((setf *image-entry-point* ',entry-point)))
- (case kind
- ((:image)
- (setf kind :program) ;; to ECL, it's just another program.
- `((setf *image-dumped-p* t)
- (si::top-level #+ecl t) (quit)))
- ((:program)
- `((setf *image-dumped-p* :executable)
- (shell-boolean-exit
- (restore-image))))))))
- (when forms `(progn ,@forms))))))
- #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
- (apply #+ecl 'c::builder #+ecl kind
</span><span style="color: #000000;background-color: #ddffdd">+ (if no-uiop
+ epilogue-code
+ (let ((forms
+ (append
+ (when epilogue-code `(,epilogue-code))
+ (when postludep `((setf *image-postlude* ',postlude)))
+ (when preludep `((setf *image-prelude* ',prelude)))
+ (when entry-point-p `((setf *image-entry-point* ',entry-point)))
+ (case kind
+ ((:image)
+ (setf kind :program) ;; to ECL, it's just another program.
+ `((setf *image-dumped-p* t)
+ (si::top-level #+(or clasp ecl) t) (quit)))
+ ((:program)
+ `((setf *image-dumped-p* :executable)
+ (shell-boolean-exit
+ (restore-image))))))))
+ (when forms `(progn ,@forms))))))
+ #+(or clasp ecl) (check-type kind (member :dll :lib :static-library :program :object :fasl))
+ (apply #+clasp 'cmp:builder #+clasp kind
+ #+(and ecl (not clasp)) 'c::builder #+(and ecl (not clasp)) kind
</span> #+mkcl (ecase kind
((:dll) 'compiler::build-shared-library)
((:lib :static-library) 'compiler::build-static-library)
((:fasl) 'compiler::build-bundle)
((:program) 'compiler::build-program))
(pathname destination)
<span style="color: #000000;background-color: #ffdddd">- #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files)
- #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+(or clasp ecl) extra-object-files)
+ #+(or clasp ecl) :init-name #+(or clasp ecl) (c::compute-init-name (or output-name destination) :kind kind)
</span> (append
(when prologue-code `(:prologue-code ,prologue-code))
(when epilogue-code `(:epilogue-code ,epilogue-code))
<span style="color: #aaaaaa">@@ -4582,9 +4656,9 @@ as either a recognizing function or a sequence of characters."
</span> (cond
((and good-chars bad-chars)
(error "only one of good-chars and bad-chars can be provided"))
<span style="color: #000000;background-color: #ffdddd">- ((functionp good-chars)
</span><span style="color: #000000;background-color: #ddffdd">+ ((typep good-chars 'function)
</span> (complement good-chars))
<span style="color: #000000;background-color: #ffdddd">- ((functionp bad-chars)
</span><span style="color: #000000;background-color: #ddffdd">+ ((typep bad-chars 'function)
</span> bad-chars)
((and good-chars (typep good-chars 'sequence))
#'(lambda (c) (not (find c good-chars))))
<span style="color: #aaaaaa">@@ -4627,10 +4701,14 @@ for use within a MS Windows command-line, outputing to S."
</span> (otherwise
(issue (char x i)) (setf i i+1))))))
<span style="color: #000000;background-color: #ddffdd">+ (defun easy-windows-character-p (x)
+ "Is X an \"easy\" character that does not require quoting by the shell?"
+ (or (alphanumericp x) (find x "+-_.,@:/=")))
+
</span> (defun escape-windows-token (token &optional s)
"Escape a string TOKEN within double-quotes if needed
for use within a MS Windows command-line, outputing to S."
<span style="color: #000000;background-color: #ffdddd">- (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
</span><span style="color: #000000;background-color: #ddffdd">+ (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
</span> :escaper 'escape-windows-token-within-double-quotes))
(defun escape-sh-token-within-double-quotes (x s &key (quote t))
<span style="color: #aaaaaa">@@ -4645,7 +4723,7 @@ omit the outer double-quotes if key argument :QUOTE is NIL"
</span>
(defun easy-sh-character-p (x)
"Is X an \"easy\" character that does not require quoting by the shell?"
<span style="color: #000000;background-color: #ffdddd">- (or (alphanumericp x) (find x "+-_.,%@:/")))
</span><span style="color: #000000;background-color: #ddffdd">+ (or (alphanumericp x) (find x "+-_.,%@:/=")))
</span>
(defun escape-sh-token (token &optional s)
"Escape a string TOKEN within double-quotes if needed
<span style="color: #aaaaaa">@@ -4655,7 +4733,7 @@ for use within a POSIX Bourne shell, outputing to S."
</span>
(defun escape-shell-token (token &optional s)
"Escape a token for the current operating system shell"
<span style="color: #000000;background-color: #ffdddd">- (cond
</span><span style="color: #000000;background-color: #ddffdd">+ (os-cond
</span> ((os-unix-p) (escape-sh-token token s))
((os-windows-p) (escape-windows-token token s))))
<span style="color: #aaaaaa">@@ -4878,11 +4956,20 @@ Programmers are encouraged to define their own methods for this generic function
</span> (command :initform nil :initarg :command :reader subprocess-error-command)
(process :initform nil :initarg :process :reader subprocess-error-process))
(:report (lambda (condition stream)
<span style="color: #000000;background-color: #ffdddd">- (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
</span><span style="color: #000000;background-color: #ddffdd">+ (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
</span> (subprocess-error-process condition)
(subprocess-error-command condition)
(subprocess-error-code condition)))))
<span style="color: #000000;background-color: #ddffdd">+ ;;; find CMD.exe on windows
+ (defun %cmd-shell-pathname ()
+ (os-cond
+ ((os-windows-p)
+ (strcat (native-namestring (getenv-absolute-directory "WINDIR"))
+ "System32\\cmd.exe"))
+ (t
+ (error "CMD.EXE is not the command shell for this OS."))))
+
</span> ;;; Internal helpers for run-program
(defun %normalize-command (command)
"Given a COMMAND as a list or string, transform it in a format suitable
<span style="color: #aaaaaa">@@ -4892,17 +4979,18 @@ for the implementation's underlying run-program function"
</span> #+os-unix (list command)
#+os-windows
(string
<span style="color: #000000;background-color: #ffdddd">- #+mkcl (list "cmd" '#:/c command)
</span><span style="color: #000000;background-color: #ddffdd">+ #+mkcl (list "cmd" "/c" command)
</span> ;; NB: We do NOT add cmd /c here. You might want to.
#+(or allegro clisp) command
;; On ClozureCL for Windows, we assume you are using
;; r15398 or later in 1.9 or later,
;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
#+clozure (cons "cmd" (strcat "/c " command))
<span style="color: #000000;background-color: #ddffdd">+ #+sbcl (list (%cmd-shell-pathname) "/c" command)
</span> ;; NB: On other Windows implementations, this is utterly bogus
;; except in the most trivial cases where no quoting is needed.
;; Use at your own risk.
<span style="color: #000000;background-color: #ffdddd">- #-(or allegro clisp clozure mkcl) (list "cmd" "/c" command))
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or allegro clisp clozure mkcl sbcl) (list "cmd" "/c" command))
</span> #+os-windows
(list
#+allegro (escape-windows-command command)
<span style="color: #aaaaaa">@@ -4929,8 +5017,8 @@ argument to pass to the internal RUN-PROGRAM"
</span> ((eql :interactive)
#+allegro nil
#+clisp :terminal
<span style="color: #000000;background-color: #ffdddd">- #+(or clozure cmu ecl mkcl sbcl scl) t)
- #+(or allegro clozure cmu ecl lispworks mkcl sbcl scl)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp clozure cmu ecl mkcl sbcl scl) t)
+ #+(or allegro clasp clozure cmu ecl lispworks mkcl sbcl scl)
</span> ((eql :output)
(if (eq role :error-output)
:output
<span style="color: #aaaaaa">@@ -4998,8 +5086,8 @@ It returns a process-info plist with possible keys:
</span> #+os-windows (string (run 'ext:run-shell-command %command))
(list (run 'ext:run-program (car %command)
:arguments (cdr %command)))))
<span style="color: #000000;background-color: #ffdddd">- #+(or clozure cmu ecl mkcl sbcl scl)
- (#-(or ecl mkcl) progn #+(or ecl mkcl) multiple-value-list
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp clozure cmu ecl mkcl sbcl scl)
+ (#-(or clasp ecl mkcl) progn #+(or clasp ecl mkcl) multiple-value-list
</span> (apply
'#+(or cmu ecl scl) ext:run-program
#+clozure ccl:run-program #+sbcl sb-ext:run-program #+mkcl mk-ext:run-program
<span style="color: #aaaaaa">@@ -5077,8 +5165,8 @@ It returns a process-info plist with possible keys:
</span> #+clozure (ccl:external-process-error-stream process*)
#+(or cmu scl) (ext:process-error process*)
#+sbcl (sb-ext:process-error process*))))
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl)
- (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl)
+ (destructuring-bind #+(or clasp ecl) (stream code process) #+mkcl (stream process code) process*
</span> (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
(cond
((zerop mode))
<span style="color: #aaaaaa">@@ -5103,7 +5191,7 @@ It returns a process-info plist with possible keys:
</span> (declare (ignorable process))
#+(or allegro lispworks) process
#+clozure (ccl::external-process-pid process)
<span style="color: #000000;background-color: #ffdddd">- #+ecl (si:external-process-pid process)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (si:external-process-pid process)
</span> #+(or cmu scl) (ext:process-pid process)
#+mkcl (mkcl:process-id process)
#+sbcl (sb-ext:process-pid process)
<span style="color: #aaaaaa">@@ -5116,13 +5204,13 @@ It returns a process-info plist with possible keys:
</span> ;; 1- wait
#+clozure (ccl::external-process-wait process)
#+(or cmu scl) (ext:process-wait process)
<span style="color: #000000;background-color: #ffdddd">- #+(and ecl os-unix) (ext:external-process-wait process)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(and (or clasp ecl) os-unix) (ext:external-process-wait process)
</span> #+sbcl (sb-ext:process-wait process)
;; 2- extract result
#+allegro (sys:reap-os-subprocess :pid process :wait t)
#+clozure (nth-value 1 (ccl:external-process-status process))
#+(or cmu scl) (ext:process-exit-code process)
<span style="color: #000000;background-color: #ffdddd">- #+ecl (nth-value 1 (ext:external-process-status process))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (nth-value 1 (ext:external-process-status process))
</span> #+lispworks
(if-let ((stream (or (getf process-info :input-stream)
(getf process-info :output-stream)
<span style="color: #aaaaaa">@@ -5288,9 +5376,21 @@ It returns a process-info plist with possible keys:
</span>
(defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
(etypecase command
<span style="color: #000000;background-color: #ffdddd">- (string command)
</span><span style="color: #000000;background-color: #ddffdd">+ (string
+ (os-cond
+ ((os-windows-p)
+ #+(or allegro clisp)
+ (strcat (%cmd-shell-pathname) " /c " command)
+ #-(or allegro clisp) command)
+ (t command)))
</span> (list (escape-shell-command
<span style="color: #000000;background-color: #ffdddd">- (if (os-unix-p) (cons "exec" command) command)))))
</span><span style="color: #000000;background-color: #ddffdd">+ (os-cond
+ ((os-unix-p) (cons "exec" command))
+ ((os-windows-p)
+ #+(or allegro sbcl clisp)
+ (cons (%cmd-shell-pathname) (cons "/c" command))
+ #-(or allegro sbcl clisp) command)
+ (t command))))))
</span>
(defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
(flet ((redirect (spec operator)
<span style="color: #aaaaaa">@@ -5305,17 +5405,18 @@ It returns a process-info plist with possible keys:
</span> (when pathname
(list operator " "
(escape-shell-token (native-namestring pathname)))))))
<span style="color: #000000;background-color: #ffdddd">- (multiple-value-bind (before after)
- (let ((normalized (%normalize-system-command command)))
- (if (os-unix-p)
- (values '("exec") (list " ; " normalized))
- (values (list normalized) ())))
</span><span style="color: #000000;background-color: #ddffdd">+ (let* ((redirections (append (redirect in " <") (redirect out " >") (redirect err " 2>")))
+ (normalized (%normalize-system-command command))
+ (directory (or directory #+(or abcl xcl) (getcwd)))
+ (chdir (when directory
+ (let ((dir-arg (escape-shell-token (native-namestring directory))))
+ (os-cond
+ ((os-unix-p) `("cd " ,dir-arg " ; "))
+ ((os-windows-p) `("cd /d " ,dir-arg " & ")))))))
</span> (reduce/strcat
<span style="color: #000000;background-color: #ffdddd">- (append
- before (redirect in " <") (redirect out " >") (redirect err " 2>")
- (when (and directory (os-unix-p)) ;; NB: unless on Unix, %system uses with-current-directory
- `(" ; cd " ,(escape-shell-token (native-namestring directory))))
- after)))))
</span><span style="color: #000000;background-color: #ddffdd">+ (os-cond
+ ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
+ ((os-windows-p) `(,@chdir ,@redirections " " ,normalized)))))))
</span>
(defun %system (command &rest keys
&key input output error-output directory &allow-other-keys)
<span style="color: #aaaaaa">@@ -5324,7 +5425,7 @@ It returns a process-info plist with possible keys:
</span> #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
(%wait-process-result
(apply '%run-program (%normalize-system-command command) :wait t keys))
<span style="color: #000000;background-color: #ffdddd">- #+(or abcl cormanlisp clisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
</span> (let ((%command (%redirected-system-command command input output error-output directory)))
#+(and lispworks os-windows)
(system:call-system %command :current-directory directory :wait t)
<span style="color: #aaaaaa">@@ -5333,10 +5434,10 @@ It returns a process-info plist with possible keys:
</span> (apply '%run-program %command :wait t
:input :interactive :output :interactive :error-output :interactive keys))
#-(or clisp (and lispworks os-windows))
<span style="color: #000000;background-color: #ffdddd">- (with-current-directory ((unless (os-unix-p) directory))
</span><span style="color: #000000;background-color: #ddffdd">+ (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
</span> #+abcl (ext:run-shell-command %command)
#+cormanlisp (win32:system %command)
<span style="color: #000000;background-color: #ffdddd">- #+ecl (let ((*standard-input* *stdin*)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (let ((*standard-input* *stdin*)
</span> (*standard-output* *stdout*)
(*error-output* *stderr*))
(ext:system %command))
<span style="color: #aaaaaa">@@ -5365,7 +5466,7 @@ It returns a process-info plist with possible keys:
</span> (values output-result error-output-result exit-code)))
(defun run-program (command &rest keys
<span style="color: #000000;background-color: #ffdddd">- &key ignore-error-status force-shell
</span><span style="color: #000000;background-color: #ddffdd">+ &key ignore-error-status (force-shell nil force-shell-suppliedp)
</span> (input nil inputp) (if-input-does-not-exist :error)
output (if-output-exists :overwrite)
(error-output nil error-output-p) (if-error-output-exists :overwrite)
<span style="color: #aaaaaa">@@ -5377,7 +5478,8 @@ either a list of strings specifying a program and list of arguments,
</span> or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
Always call a shell (rather than directly execute the command when possible)
-if FORCE-SHELL is specified.
<span style="color: #000000;background-color: #ddffdd">+if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is
+specified to be NIL.
</span>
Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
unless IGNORE-ERROR-STATUS is specified.
<span style="color: #aaaaaa">@@ -5423,13 +5525,17 @@ RUN-PROGRAM returns 3 values:
</span> 2- either 0 if the subprocess exited with success status,
or an indication of failure via the EXIT-CODE of the process"
(declare (ignorable ignore-error-status))
<span style="color: #000000;background-color: #ffdddd">- #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
</span> (error "RUN-PROGRAM not implemented for this Lisp")
<span style="color: #000000;background-color: #ddffdd">+ ;; per doc string, set FORCE-SHELL to T if we get command as a string. But
+ ;; don't override user's specified preference. [2015/06/29:rpg]
+ (when (stringp command)
+ (unless force-shell-suppliedp
+ (setf force-shell t)))
</span> (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
(apply (if (or force-shell
<span style="color: #000000;background-color: #ffdddd">- #+(or clisp ecl) (or (not ignore-error-status) t)
- #+clisp (eq error-output :interactive)
- #+(or abcl clisp) (eq :error-output :output)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp clisp ecl) (or (not ignore-error-status) t)
+ #+clisp (member error-output '(:interactive :output))
</span> #+(and lispworks os-unix) (%interactivep input output error-output)
#+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
'%use-system '%use-run-program)
<span style="color: #aaaaaa">@@ -5510,31 +5616,32 @@ This can help you produce more deterministic output for FASLs."))
</span> #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety*
ccl::*nx-debug* ccl::*nx-cspeed*)
#+(or cmu scl) '(c::*default-cookie*)
<span style="color: #000000;background-color: #ffdddd">- #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(and ecl (not clasp)) (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
+ #+clasp '()
</span> #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
#+lispworks '(compiler::*optimization-level*)
#+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*)
#+sbcl '(sb-c::*policy*)))
(defun get-optimization-settings ()
"Get current compiler optimization settings, ready to PROCLAIM again"
<span style="color: #000000;background-color: #ffdddd">- #-(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
</span> (warn "~S does not support ~S. Please help me fix that."
'get-optimization-settings (implementation-type))
<span style="color: #000000;background-color: #ffdddd">- #+(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
</span> (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
#.`(loop #+(or allegro clozure)
,@'(:with info = #+allegro (sys:declaration-information 'optimize)
#+clozure (ccl:declaration-information 'optimize nil))
:for x :in settings
<span style="color: #000000;background-color: #ffdddd">- ,@(or #+(or abcl ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
</span><span style="color: #000000;background-color: #ddffdd">+ ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
</span> :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
#+clisp (gethash x system::*optimize* 1)
<span style="color: #000000;background-color: #ffdddd">- #+(or abcl ecl mkcl xcl) (symbol-value v)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or abcl clasp ecl mkcl xcl) (symbol-value v)
</span> #+(or cmu scl) (slot-value c::*default-cookie*
(case x (compilation-speed 'c::cspeed)
(otherwise x)))
#+lispworks (slot-value compiler::*optimization-level* x)
<span style="color: #000000;background-color: #ffdddd">- #+sbcl (cdr (assoc x sb-c::*policy*)))
</span><span style="color: #000000;background-color: #ddffdd">+ #+sbcl (sb-c::policy-quality sb-c::*policy* x))
</span> :when y :collect (list x y))))
(defun proclaim-optimization-settings ()
"Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
<span style="color: #aaaaaa">@@ -6053,8 +6160,8 @@ possibly in a different process. Otherwise just call THUNK."
</span> (defun compile-file-type (&rest keys)
"pathname TYPE for lisp FASt Loading files"
(declare (ignorable keys))
<span style="color: #000000;background-color: #ffdddd">- #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
- #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
+ #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
</span>
(defun call-around-hook (hook function)
"Call a HOOK around the execution of FUNCTION"
<span style="color: #aaaaaa">@@ -6079,7 +6186,7 @@ possibly in a different process. Otherwise just call THUNK."
</span>
(defun* (compile-file*) (input-file &rest keys
&key (compile-check *compile-check*) output-file warnings-file
<span style="color: #000000;background-color: #ffdddd">- #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
</span><span style="color: #000000;background-color: #ddffdd">+ #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl
</span> &allow-other-keys)
"This function provides a portable wrapper around COMPILE-FILE.
It ensures that the OUTPUT-FILE value is only returned and
<span style="color: #aaaaaa">@@ -6099,21 +6206,23 @@ If WARNINGS-FILE is defined, deferred warnings are saved to that file.
</span> On ECL or MKCL, it creates both the linkable object and loadable fasl files.
On implementations that erroneously do not recognize standard keyword arguments,
it will filter them appropriately."
<span style="color: #000000;background-color: #ffdddd">- #+ecl (when (and object-file (equal (compile-file-type) (pathname object-file)))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (when (and object-file (equal (compile-file-type) (pathname object-file)))
</span> (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
'compile-file* output-file object-file)
(rotatef output-file object-file))
(let* ((keywords (remove-plist-keys
`(:output-file :compile-check :warnings-file
<span style="color: #000000;background-color: #ffdddd">- #+clisp :lib-file #+(or ecl mkcl) :object-file) keys))
</span><span style="color: #000000;background-color: #ddffdd">+ #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys))
</span> (output-file
(or output-file
(apply 'compile-file-pathname* input-file :output-file output-file keywords)))
<span style="color: #000000;background-color: #ffdddd">- #+ecl
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl)
</span> (object-file
(unless (use-ecl-byte-compiler-p)
(or object-file
<span style="color: #000000;background-color: #ffdddd">- (compile-file-pathname output-file :type :object))))
</span><span style="color: #000000;background-color: #ddffdd">+ #+ecl(compile-file-pathname output-file :type :object)
+ #+clasp (compile-file-pathname output-file :output-type :object)
+ )))
</span> #+mkcl
(object-file
(or object-file
<span style="color: #aaaaaa">@@ -6133,14 +6242,18 @@ it will filter them appropriately."
</span> (with-enough-pathname (input-file :defaults *base-build-directory*)
(with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
(with-muffled-compiler-conditions ()
<span style="color: #000000;background-color: #ffdddd">- (or #-(or ecl mkcl)
</span><span style="color: #000000;background-color: #ddffdd">+ (or #-(or clasp ecl mkcl)
</span> (apply 'compile-file input-file :output-file tmp-file
#+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
#-sbcl keywords)
#+ecl (apply 'compile-file input-file :output-file
<span style="color: #000000;background-color: #ffdddd">- (if object-file
- (list* object-file :system-p t keywords)
- (list* tmp-file keywords)))
</span><span style="color: #000000;background-color: #ddffdd">+ (if object-file
+ (list* object-file :system-p t keywords)
+ (list* tmp-file keywords)))
+ #+clasp (apply 'compile-file input-file :output-file
+ (if object-file
+ (list* object-file :output-type :object #|:system-p t|# keywords)
+ (list* tmp-file keywords)))
</span> #+mkcl (apply 'compile-file input-file
:output-file object-file :fasl-p nil keywords)))))
(cond
<span style="color: #aaaaaa">@@ -6150,20 +6263,23 @@ it will filter them appropriately."
</span> (and (check-flag failure-p *compile-file-failure-behaviour*)
(check-flag warnings-p *compile-file-warnings-behaviour*)))
(progn
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl)
- (when (and #+ecl object-file)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl)
+ (when (and #+(or clasp ecl) object-file)
</span> (setf output-truename
<span style="color: #000000;background-color: #ffdddd">- (compiler::build-fasl
- tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files
- (list object-file))))
</span><span style="color: #000000;background-color: #ddffdd">+ (compiler::build-fasl tmp-file
+ #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list object-file))))
</span> (or (not compile-check)
<span style="color: #000000;background-color: #ffdddd">- (apply compile-check input-file :output-file tmp-file keywords))))
</span><span style="color: #000000;background-color: #ddffdd">+ (apply compile-check input-file
+ :output-file #-(or clasp ecl) output-file #+(or clasp ecl) tmp-file
+ keywords))))
</span> (delete-file-if-exists output-file)
(when output-truename
<span style="color: #000000;background-color: #ddffdd">+ #+clasp (when output-truename (rename-file-overwriting-target tmp-file output-truename))
</span> #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
#+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
(rename-file-overwriting-target output-truename output-file)
(setf output-truename (truename output-file)))
<span style="color: #000000;background-color: #ddffdd">+ #+clasp (delete-file-if-exists tmp-file)
</span> #+clisp (delete-file-if-exists tmp-lib))
(t ;; error or failed check
(delete-file-if-exists output-truename)
<span style="color: #aaaaaa">@@ -6222,7 +6338,6 @@ it will filter them appropriately."
</span> (scm:concatenate-system output :fasls-to-concatenate))
(loop :for f :in fasls :do (ignore-errors (delete-file f)))
(ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
-
;;;; ---------------------------------------------------------------------------
;;;; Generic support for configuration files
<span style="color: #aaaaaa">@@ -6232,10 +6347,13 @@ it will filter them appropriately."
</span> (:use :uiop/common-lisp :uiop/utility
:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
(:export
<span style="color: #000000;background-color: #ddffdd">+ #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
+ #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem
</span> #:get-folder-path
<span style="color: #000000;background-color: #ffdddd">- #:user-configuration-directories #:system-configuration-directories
- #:in-first-directory
- #:in-user-configuration-directory #:in-system-configuration-directory
</span><span style="color: #000000;background-color: #ddffdd">+ #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
+ #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
+ #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames
+ #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname
</span> #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
#:configuration-inheritance-directive-p
#:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
<span style="color: #aaaaaa">@@ -6256,56 +6374,6 @@ it will filter them appropriately."
</span> (list* (condition-form c) (condition-location c)
(condition-arguments c))))))
<span style="color: #000000;background-color: #ffdddd">- (defun get-folder-path (folder)
- "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
</span>-this function tries to locate the Windows FOLDER for one of
-:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA."
<span style="color: #000000;background-color: #ffdddd">- (or #+(and lispworks mswindows) (sys:get-folder-path folder)
- ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
- (ecase folder
- (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
- (:appdata (getenv-absolute-directory "APPDATA"))
- (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
- (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun user-configuration-directories ()
- "Determine user configuration directories"
- (let ((dirs
- `(,@(when (os-unix-p)
- (cons
- (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
- (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
- :collect (subpathname* dir "common-lisp/"))))
- ,@(when (os-windows-p)
- `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
- ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
- ,(subpathname (user-homedir-pathname) ".config/common-lisp/"))))
- (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
- :from-end t :test 'equal)))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun system-configuration-directories ()
- "Determine system user configuration directories"
- (cond
- ((os-unix-p) '(#p"/etc/common-lisp/"))
- ((os-windows-p)
- (if-let (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/"))
- (list it)))))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun in-first-directory (dirs x &key (direction :input))
- "Determine system user configuration directories"
- (loop :with fun = (ecase direction
- ((nil :input :probe) 'probe-file*)
- ((:output :io) 'identity))
- :for dir :in dirs
- :thereis (and dir (funcall fun (subpathname (ensure-directory-pathname dir) x)))))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun in-user-configuration-directory (x &key (direction :input))
- "return pathname under user configuration directory, subpathname X"
- (in-first-directory (user-configuration-directories) x :direction direction))
- (defun in-system-configuration-directory (x &key (direction :input))
- "return pathname under system configuration directory, subpathname X"
- (in-first-directory (system-configuration-directories) x :direction direction))
</span>-
(defun configuration-inheritance-directive-p (x)
"Is X a configuration inheritance directive?"
(let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
<span style="color: #aaaaaa">@@ -6329,7 +6397,16 @@ this function tries to locate the Windows FOLDER for one of
</span>
(defun validate-configuration-form (form tag directive-validator
&key location invalid-form-reporter)
<span style="color: #000000;background-color: #ffdddd">- "Validate a configuration FORM"
</span><span style="color: #000000;background-color: #ddffdd">+ "Validate a configuration FORM. By default it will raise an error if the
+FORM is not valid. Otherwise it will return the validated form.
+ Arguments control the behavior:
+ The configuration FORM should be of the form (TAG . <rest>)
+ Each element of <rest> will be checked by first seeing if it's a configuration inheritance
+directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
+on it.
+ In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
+reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
+the configuration form appeared."
</span> (unless (and (consp form) (eq (car form) tag))
(setf *ignored-configuration-form* t)
(report-invalid-form invalid-form-reporter :form form :location location)
<span style="color: #aaaaaa">@@ -6362,7 +6439,9 @@ this function tries to locate the Windows FOLDER for one of
</span> (return (nreverse x))))
(defun validate-configuration-file (file validator &key description)
<span style="color: #000000;background-color: #ffdddd">- "Validate a configuration file for conformance of its form with the validator function"
</span><span style="color: #000000;background-color: #ddffdd">+ "Validate a configuration FILE. The configuration file should have only one s-expression
+in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error
+reporting."
</span> (let ((forms (read-file-forms file)))
(unless (length=n-p forms 1)
(error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
<span style="color: #aaaaaa">@@ -6395,9 +6474,10 @@ values of TAG include :source-registry and :output-translations."
</span> :inherit-configuration)))
(defun resolve-relative-location (x &key ensure-directory wilden)
<span style="color: #000000;background-color: #ffdddd">- "Given a designator X for an relative location, resolve it to a pathname"
</span><span style="color: #000000;background-color: #ddffdd">+ "Given a designator X for an relative location, resolve it to a pathname."
</span> (ensure-pathname
(etypecase x
<span style="color: #000000;background-color: #ddffdd">+ (null nil)
</span> (pathname x)
(string (parse-unix-namestring
x :ensure-directory ensure-directory))
<span style="color: #aaaaaa">@@ -6433,23 +6513,11 @@ directive.")
</span> (defvar *user-cache* nil
"A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
<span style="color: #000000;background-color: #ffdddd">- (defun compute-user-cache ()
- "Compute the location of the default user-cache for translate-output objects"
- (setf *user-cache*
- (flet ((try (x &rest sub) (and x `(,x ,@sub))))
- (or
- (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
- (when (os-windows-p)
- (try (or (get-folder-path :local-appdata)
- (get-folder-path :appdata))
- "common-lisp" "cache" :implementation))
- '(:home ".cache" "common-lisp" :implementation)))))
- (register-image-restore-hook 'compute-user-cache)
</span>-
(defun resolve-absolute-location (x &key ensure-directory wilden)
"Given a designator X for an absolute location, resolve it to a pathname"
(ensure-pathname
(etypecase x
<span style="color: #000000;background-color: #ddffdd">+ (null nil)
</span> (pathname x)
(string
(let ((p #-mcl (parse-namestring x)
<span style="color: #aaaaaa">@@ -6492,9 +6560,10 @@ directive.")
</span> ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
(loop* :with dirp = (or directory ensure-directory)
:with (first . rest) = (if (atom x) (list x) x)
<span style="color: #000000;background-color: #ffdddd">- :with path = (resolve-absolute-location
- first :ensure-directory (and (or dirp rest) t)
- :wilden (and wilden (null rest)))
</span><span style="color: #000000;background-color: #ddffdd">+ :with path = (or (resolve-absolute-location
+ first :ensure-directory (and (or dirp rest) t)
+ :wilden (and wilden (null rest)))
+ (return nil))
</span> :for (element . morep) :on rest
:for dir = (and (or morep dirp) t)
:for wild = (and wilden (not morep))
<span style="color: #aaaaaa">@@ -6507,6 +6576,8 @@ directive.")
</span>
(defun location-designator-p (x)
"Is X a designator for a location?"
<span style="color: #000000;background-color: #ddffdd">+ ;; NIL means "skip this entry", or as an output translation, same as translation input.
+ ;; T means "any input" for a translation, or as output, same as translation input.
</span> (flet ((absolute-component-p (c)
(typep c '(or string pathname
(member :root :home :here :user-cache))))
<span style="color: #aaaaaa">@@ -6519,9 +6590,8 @@ directive.")
</span>
(defun location-function-p (x)
"Is X the specification of a location function?"
<span style="color: #000000;background-color: #ffdddd">- (and
- (length=n-p x 2)
- (eq (car x) :function)))
</span><span style="color: #000000;background-color: #ddffdd">+ ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
+ (and (length=n-p x 2) (eq (car x) :function)))
</span>
(defvar *clear-configuration-hook* '())
<span style="color: #aaaaaa">@@ -6539,9 +6609,149 @@ directive.")
</span> "If a previous version of ASDF failed to read some configuration, try again now."
(when *ignored-configuration-form*
(clear-configuration)
<span style="color: #000000;background-color: #ffdddd">- (setf *ignored-configuration-form* nil))))
</span><span style="color: #000000;background-color: #ddffdd">+ (setf *ignored-configuration-form* nil)))
+
+
+ (defun get-folder-path (folder)
+ "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
+this function tries to locate the Windows FOLDER for one of
+:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
+ Returns NIL when the folder is not defined (e.g., not on Windows)."
+ (or #+(and lispworks mswindows) (sys:get-folder-path folder)
+ ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+ (ecase folder
+ (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
+ (subpathname* (get-folder-path :appdata) "Local")))
+ (:appdata (getenv-absolute-directory "APPDATA"))
+ (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
+ (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
+
</span>
<span style="color: #000000;background-color: #ddffdd">+ ;; Support for the XDG Base Directory Specification
+ (defun xdg-data-home (&rest more)
+ "Returns an absolute pathname for the directory containing user-specific data files.
+MORE may contain specifications for a subpath relative to this directory: a
+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
+also \"Configuration DSL\"\) in the ASDF manual."
+ (resolve-absolute-location
+ `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
+ (os-cond
+ ((os-windows-p) (get-folder-path :local-appdata))
+ (t (subpathname (user-homedir-pathname) ".local/share/"))))
+ ,more)))
+
+ (defun xdg-config-home (&rest more)
+ "Returns a pathname for the directory containing user-specific configuration files.
+MORE may contain specifications for a subpath relative to this directory: a
+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
+also \"Configuration DSL\"\) in the ASDF manual."
+ (resolve-absolute-location
+ `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
+ (os-cond
+ ((os-windows-p) (xdg-data-home "config/"))
+ (t (subpathname (user-homedir-pathname) ".config/"))))
+ ,more)))
+
+ (defun xdg-data-dirs (&rest more)
+ "The preference-ordered set of additional paths to search for data files.
+Returns a list of absolute directory pathnames.
+MORE may contain specifications for a subpath relative to these directories: a
+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
+also \"Configuration DSL\"\) in the ASDF manual."
+ (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
+ (or (getenv-absolute-directories "XDG_DATA_DIRS")
+ (os-cond
+ ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
+ (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))))
+
+ (defun xdg-config-dirs (&rest more)
+ "The preference-ordered set of additional base paths to search for configuration files.
+Returns a list of absolute directory pathnames.
+MORE may contain specifications for a subpath relative to these directories:
+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
+also \"Configuration DSL\"\) in the ASDF manual."
+ (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
+ (or (getenv-absolute-directories "XDG_CONFIG_DIRS")
+ (os-cond
+ ((os-windows-p) (xdg-data-dirs "config/"))
+ (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))
+
+ (defun xdg-cache-home (&rest more)
+ "The base directory relative to which user specific non-essential data files should be stored.
+Returns an absolute directory pathname.
+MORE may contain specifications for a subpath relative to this directory: a
+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
+also \"Configuration DSL\"\) in the ASDF manual."
+ (resolve-absolute-location
+ `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
+ (os-cond
+ ((os-windows-p) (xdg-data-home "cache"))
+ (t (subpathname* (user-homedir-pathname) ".cache/"))))
+ ,more)))
+
+ (defun xdg-runtime-dir (&rest more)
+ "Pathname for user-specific non-essential runtime files and other file objects,
+such as sockets, named pipes, etc.
+Returns an absolute directory pathname.
+MORE may contain specifications for a subpath relative to this directory: a
+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
+also \"Configuration DSL\"\) in the ASDF manual."
+ ;; The XDG spec says that if not provided by the login system, the application should
+ ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
+ (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
+
+ ;;; NOTE: modified the docstring because "system user configuration
+ ;;; directories" seems self-contradictory. I'm not sure my wording is right.
+ (defun system-config-pathnames (&rest more)
+ "Return a list of directories where are stored the system's default user configuration information.
+MORE may contain specifications for a subpath relative to these directories: a
+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
+also \"Configuration DSL\"\) in the ASDF manual."
+ (declare (ignorable more))
+ (os-cond
+ ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more))))))
+
+ (defun filter-pathname-set (dirs)
+ "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
+ (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))
+
+ (defun xdg-data-pathnames (&rest more)
+ "Return a list of absolute pathnames for application data directories. With APP,
+returns directory for data for that application, without APP, returns the set of directories
+for storing all application configurations.
+MORE may contain specifications for a subpath relative to these directories: a
+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
+also \"Configuration DSL\"\) in the ASDF manual."
+ (filter-pathname-set
+ `(,(xdg-data-home more)
+ ,@(xdg-data-dirs more))))
+
+ (defun xdg-config-pathnames (&rest more)
+ "Return a list of pathnames for application configuration.
+MORE may contain specifications for a subpath relative to these directories: a
+subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
+also \"Configuration DSL\"\) in the ASDF manual."
+ (filter-pathname-set
+ `(,(xdg-config-home more)
+ ,@(xdg-config-dirs more))))
+
+ (defun find-preferred-file (files &key (direction :input))
+ "Find first file in the list of FILES that exists (for direction :input or :probe)
+or just the first one (for direction :output or :io).
+ Note that when we say \"file\" here, the files in question may be directories."
+ (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))
+
+ (defun xdg-data-pathname (&optional more (direction :input))
+ (find-preferred-file (xdg-data-pathnames more) :direction direction))
+
+ (defun xdg-config-pathname (&optional more (direction :input))
+ (find-preferred-file (xdg-config-pathnames more) :direction direction))
</span>
<span style="color: #000000;background-color: #ddffdd">+ (defun compute-user-cache ()
+ "Compute (and return) the location of the default user-cache for translate-output
+objects. Side-effects for cached file location computation."
+ (setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
+ (register-image-restore-hook 'compute-user-cache))
</span> ;;;; -------------------------------------------------------------------------
;;; Hacks for backward-compatibility of the driver
<span style="color: #aaaaaa">@@ -6550,11 +6760,12 @@ directive.")
</span> (:recycle :uiop/backward-driver :asdf/backward-driver :asdf)
(:use :uiop/common-lisp :uiop/package :uiop/utility
:uiop/pathname :uiop/stream :uiop/os :uiop/image
<span style="color: #000000;background-color: #ffdddd">- :uiop/run-program :uiop/lisp-build
- :uiop/configuration)
</span><span style="color: #000000;background-color: #ddffdd">+ :uiop/run-program :uiop/lisp-build :uiop/configuration)
</span> (:export
#:coerce-pathname #:component-name-to-pathname-components
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl) #:compile-file-keeping-object
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl) #:compile-file-keeping-object
+ #:user-configuration-directories #:system-configuration-directories
+ #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory
</span> ))
(in-package :uiop/backward-driver)
<span style="color: #aaaaaa">@@ -6581,8 +6792,37 @@ directive.")
</span> unix-style-namestring))
(values relabs path filename)))
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl)
- (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl)
+ (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args))
+
+ ;; Backward compatibility for ASDF 2.27 to 3.1.4
+ (defun user-configuration-directories ()
+ "Return the current user's list of user configuration directories
+for configuring common-lisp.
+ DEPRECATED. Use uiop:xdg-config-pathnames instead."
+ (xdg-config-pathnames "common-lisp"))
+ (defun system-configuration-directories ()
+ "Return the list of system configuration directories for common-lisp.
+ DEPRECATED. Use uiop:config-system-pathnames instead."
+ (system-config-pathnames "common-lisp"))
+ (defun in-first-directory (dirs x &key (direction :input))
+ "Finds the first appropriate file named X in the list of DIRS for I/O
+in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
+ If direction is :INPUT or :PROBE, will return the first extant file named
+X in one of the DIRS.
+ If direction is :OUTPUT or :IO, will simply return the file named X in the
+first element of DIRS that exists. DEPRECATED."
+ (find-preferred-file
+ (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs)
+ :direction direction))
+ (defun in-user-configuration-directory (x &key (direction :input))
+ "Return the file named X in the user configuration directory for common-lisp.
+DEPRECATED."
+ (xdg-config-pathname `("common-lisp" ,x) direction))
+ (defun in-system-configuration-directory (x &key (direction :input))
+ "Return the pathname for the file named X under the system configuration directory
+for common-lisp. DEPRECATED."
+ (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction)))
</span> ;;;; ---------------------------------------------------------------------------
;;;; Re-export all the functionality in UIOP
<span style="color: #aaaaaa">@@ -6670,7 +6910,7 @@ previously-loaded version of ASDF."
</span> ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
<span style="color: #000000;background-color: #ffdddd">- (asdf-version "3.1.4")
</span><span style="color: #000000;background-color: #ddffdd">+ (asdf-version "3.1.5")
</span> (existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
<span style="color: #aaaaaa">@@ -6986,8 +7226,8 @@ children.")))
</span>
(defmethod component-relative-pathname ((component component))
;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
<span style="color: #000000;background-color: #ffdddd">- ;; We ought to be able to extract this from the component alone with COMPONENT-TYPE.
- ;; TODO: track who uses it, and have them not use it anymore;
</span><span style="color: #000000;background-color: #ddffdd">+ ;; We ought to be able to extract this from the component alone with FILE-TYPE.
+ ;; TODO: track who uses it in Quicklisp, and have them not use it anymore;
</span> ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
(parse-unix-namestring
(or (and (slot-boundp component 'relative-pathname)
<span style="color: #aaaaaa">@@ -7269,8 +7509,8 @@ in which the system specification (.asd file) is located."
</span> #:find-system-if-being-defined
#:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
#:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
<span style="color: #000000;background-color: #ffdddd">- #:clear-defined-system #:clear-defined-systems #:*defined-systems*
- #:*immutable-systems*
</span><span style="color: #000000;background-color: #ddffdd">+ #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems*
+ #:*defined-systems* #:clear-defined-systems
</span> ;; defined in source-registry, but specially mentioned here:
#:initialize-source-registry #:sysdef-source-registry-search))
(in-package :asdf/find-system)
<span style="color: #aaaaaa">@@ -7340,29 +7580,84 @@ of which is a system object.")
</span> (get-file-stamp file))
system)))))
<span style="color: #000000;background-color: #ffdddd">- (defun clear-defined-system (system)
</span><span style="color: #000000;background-color: #ddffdd">+ (defvar *preloaded-systems* (make-hash-table :test 'equal))
+
+ (defun make-preloaded-system (name keys)
+ (apply 'make-instance (getf keys :class 'system)
+ :name name :source-file (getf keys :source-file)
+ (remove-plist-keys '(:class :name :source-file) keys)))
+
+ (defun sysdef-preloaded-system-search (requested)
+ (let ((name (coerce-name requested)))
+ (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
+ (when foundp
+ (make-preloaded-system name keys)))))
+
+ (defun register-preloaded-system (system-name &rest keys)
+ (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
+
+ (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
+ ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
+ (register-preloaded-system s :version *asdf-version*))
+
+ (defvar *immutable-systems* nil
+ "An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
+i.e. already loaded in memory and not to be refreshed from the filesystem.
+They will be treated specially by find-system, and passed as :force-not argument to make-plan.
+
+If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
+for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
+downgrade, before you dump an image, use:
+ (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
+
+ (defun sysdef-immutable-system-search (requested)
+ (let ((name (coerce-name requested)))
+ (when (and *immutable-systems* (gethash name *immutable-systems*))
+ (or (cdr (system-registered-p requested))
+ (sysdef-preloaded-system-search name)
+ (error 'formatted-system-definition-error
+ :format-control "Requested system ~A is in the *immutable-systems* set, ~
+but not loaded in memory"
+ :format-arguments (list name))))))
+
+ (defun register-immutable-system (system-name &key (version t))
+ (let* ((system-name (coerce-name system-name))
+ (registered-system (cdr (system-registered-p system-name)))
+ (default-version? (eql version t))
+ (version (cond ((and default-version? registered-system)
+ (component-version registered-system))
+ (default-version? nil)
+ (t version))))
+ (unless registered-system
+ (register-system (make-preloaded-system system-name (list :version version))))
+ (register-preloaded-system system-name :version version)
+ (unless *immutable-systems*
+ (setf *immutable-systems* (list-to-hash-set nil)))
+ (setf (gethash (coerce-name system-name) *immutable-systems*) t)))
+
+ (defun clear-system (system)
+ "Clear the entry for a SYSTEM in the database of systems previously loaded,
+unless the system appears in the table of *IMMUTABLE-SYSTEMS*.
+Note that this does NOT in any way cause the code of the system to be unloaded.
+Returns T if cleared or already cleared,
+NIL if not cleared because the system was found to be immutable."
+ ;; There is no "unload" operation in Common Lisp, and
+ ;; a general such operation cannot be portably written,
+ ;; considering how much CL relies on side-effects to global data structures.
</span> (let ((name (coerce-name system)))
<span style="color: #000000;background-color: #ffdddd">- (remhash name *defined-systems*)
- (unset-asdf-cache-entry `(locate-system ,name))
- (unset-asdf-cache-entry `(find-system ,name))
- nil))
</span><span style="color: #000000;background-color: #ddffdd">+ (unless (and *immutable-systems* (gethash name *immutable-systems*))
+ (remhash (coerce-name name) *defined-systems*)
+ (unset-asdf-cache-entry `(locate-system ,name))
+ (unset-asdf-cache-entry `(find-system ,name))
+ t)))
</span>
(defun clear-defined-systems ()
;; Invalidate all systems but ASDF itself, if registered.
(loop :for name :being :the :hash-keys :of *defined-systems*
<span style="color: #000000;background-color: #ffdddd">- :unless (equal name "asdf")
- :do (clear-defined-system name)))
</span><span style="color: #000000;background-color: #ddffdd">+ :unless (equal name "asdf") :do (clear-system name)))
</span>
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
<span style="color: #000000;background-color: #ffdddd">- (defun clear-system (name)
- "Clear the entry for a system in the database of systems previously loaded.
</span>-Note that this does NOT in any way cause the code of the system to be unloaded."
<span style="color: #000000;background-color: #ffdddd">- ;; There is no "unload" operation in Common Lisp, and
- ;; a general such operation cannot be portably written,
- ;; considering how much CL relies on side-effects to global data structures.
- (remhash (coerce-name name) *defined-systems*))
</span>-
(defun map-systems (fn)
"Apply FN to each defined system.
<span style="color: #aaaaaa">@@ -7425,14 +7720,16 @@ Going forward, we recommend new users should be using the source-registry.
</span> :truename truename))
(return file))
#-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
<span style="color: #000000;background-color: #ffdddd">- (when (and (os-windows-p) (physical-pathname-p defaults))
- (let ((shortcut
- (make-pathname
- :defaults defaults :case :local
- :name (strcat name ".asd")
- :type "lnk")))
- (when (probe-file* shortcut)
- (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))
</span><span style="color: #000000;background-color: #ddffdd">+ (os-cond
+ ((os-windows-p)
+ (when (physical-pathname-p defaults)
+ (let ((shortcut
+ (make-pathname
+ :defaults defaults :case :local
+ :name (strcat name ".asd")
+ :type "lnk")))
+ (when (probe-file* shortcut)
+ (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))))
</span>
(defun sysdef-central-registry-search (system)
(let ((name (primary-system-name system))
<span style="color: #aaaaaa">@@ -7481,26 +7778,6 @@ Going forward, we recommend new users should be using the source-registry.
</span> (list new)
(subseq *central-registry* (1+ position))))))))))
<span style="color: #000000;background-color: #ffdddd">- (defvar *preloaded-systems* (make-hash-table :test 'equal))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun make-preloaded-system (name keys)
- (apply 'make-instance (getf keys :class 'system)
- :name name :source-file (getf keys :source-file)
- (remove-plist-keys '(:class :name :source-file) keys)))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun sysdef-preloaded-system-search (requested)
- (let ((name (coerce-name requested)))
- (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
- (when foundp
- (make-preloaded-system name keys)))))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun register-preloaded-system (system-name &rest keys)
- (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
- ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
- (register-preloaded-system s :version *asdf-version*))
</span>-
(defmethod find-system ((name null) &optional (error-p t))
(when error-p
(sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
<span style="color: #aaaaaa">@@ -7512,7 +7789,9 @@ Going forward, we recommend new users should be using the source-registry.
</span> ;; notable side effect: mark the system as being defined, to avoid infinite loops
(first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
<span style="color: #000000;background-color: #ffdddd">- (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
</span><span style="color: #000000;background-color: #ddffdd">+ (defun load-asd (pathname
+ &key name (external-format (encoding-external-format (detect-encoding pathname)))
+ &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
</span> ;; Tries to load system definition with canonical NAME from PATHNAME.
(with-asdf-cache ()
(with-standard-io-syntax
<span style="color: #aaaaaa">@@ -7580,25 +7859,6 @@ Going forward, we recommend new users should be using the source-registry.
</span> old-version old-pathname version pathname))))
nil))))) ;; only issue the warning the first time, but always return nil
<span style="color: #000000;background-color: #ffdddd">- (defvar *immutable-systems* nil
- "An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
</span>-i.e. already loaded in memory and not to be refreshed from the filesystem.
-They will be treated specially by find-system, and passed as :force-not argument to make-plan.
-
-If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
-for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
-downgrade, before you dump an image, use:
<span style="color: #000000;background-color: #ffdddd">- (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun sysdef-immutable-system-search (requested)
- (let ((name (coerce-name requested)))
- (when (and *immutable-systems* (gethash name *immutable-systems*))
- (or (cdr (system-registered-p requested))
- (error 'formatted-system-definition-error
- :format-control "Requested system ~A is in the *immutable-systems* set, ~
</span>-but not loaded in memory"
<span style="color: #000000;background-color: #ffdddd">- :format-arguments (list name))))))
</span>-
(defun locate-system (name)
"Given a system NAME designator, try to locate where to load the system from.
Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
<span style="color: #aaaaaa">@@ -7638,7 +7898,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
</span> (unless (equal name primary-name)
(find-system primary-name nil)))
(or (and *immutable-systems* (gethash name *immutable-systems*)
<span style="color: #000000;background-color: #ffdddd">- (cdr (system-registered-p name)))
</span><span style="color: #000000;background-color: #ddffdd">+ (or (cdr (system-registered-p name))
+ (sysdef-preloaded-system-search name)))
</span> (multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name)
(assert (eq foundp (and (or found-system pathname previous) t)))
<span style="color: #aaaaaa">@@ -8354,8 +8615,8 @@ in some previous image, or T if it needs to be done.")
</span> (destructuring-bind
(output-file
&optional
<span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl) object-file
</span> #+clisp lib-file
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl) object-file
</span> warnings-file) outputs
(call-with-around-compile-hook
c #'(lambda (&rest flags)
<span style="color: #aaaaaa">@@ -8365,7 +8626,7 @@ in some previous image, or T if it needs to be done.")
</span> :warnings-file warnings-file
(append
#+clisp (list :lib-file lib-file)
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl) (list :object-file object-file)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl) (list :object-file object-file)
</span> flags (compile-op-flags o))))))
(check-lisp-compile-results output warnings-p failure-p
"~/asdf-action::format-action/" (list (cons o c))))))
<span style="color: #aaaaaa">@@ -8390,8 +8651,12 @@ in some previous image, or T if it needs to be done.")
</span> (defun lisp-compilation-output-files (o c)
(let* ((i (first (input-files o c)))
(f (compile-file-pathname
<span style="color: #000000;background-color: #ffdddd">- i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
</span><span style="color: #000000;background-color: #ddffdd">+ i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl
+ #+mkcl :fasl-p #+mkcl t)))
</span> `(,f ;; the fasl is the primary output, in first position
<span style="color: #000000;background-color: #ddffdd">+ #+clasp
+ ,@(unless nil ;; was (use-ecl-byte-compiler-p)
+ `(,(compile-file-pathname i :output-type :object)))
</span> #+clisp
,@`(,(make-pathname :type "lib" :defaults f))
#+ecl
<span style="color: #aaaaaa">@@ -9131,19 +9396,26 @@ to load it in current image."
</span> (apply 'operate 'test-op system args)
t))
-
-;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
-;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
<span style="color: #000000;background-color: #ddffdd">+;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE,
+;; only tries to load its specified target if it's not loaded yet.
</span> (with-upgradability ()
<span style="color: #000000;background-color: #ffdddd">- (defun component-loaded-p (c)
- (action-already-done-p nil (make-instance 'load-op) (find-component c ())))
</span><span style="color: #000000;background-color: #ddffdd">+ (defun component-loaded-p (component)
+ "has given COMPONENT been successfully loaded in the current image (yet)?"
+ (action-already-done-p nil (make-instance 'load-op) (find-component component ())))
</span>
(defun already-loaded-systems ()
<span style="color: #000000;background-color: #ddffdd">+ "return a list of the names of the systems that have been successfully loaded so far"
</span> (remove-if-not 'component-loaded-p (registered-systems)))
<span style="color: #000000;background-color: #ffdddd">- (defun require-system (s &rest keys &key &allow-other-keys)
- (apply 'load-system s :force-not (already-loaded-systems) keys))
</span><span style="color: #000000;background-color: #ddffdd">+ (defun require-system (system &rest keys &key &allow-other-keys)
+ "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but skip any update to the
+system or its dependencies if they have already been loaded."
+ (apply 'load-system system :force-not (already-loaded-systems) keys)))
</span>
<span style="color: #000000;background-color: #ddffdd">+
+;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
+;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
+(with-upgradability ()
</span> (defvar *modules-being-required* nil)
(defclass require-system (system)
<span style="color: #aaaaaa">@@ -9346,7 +9618,7 @@ and the order is by decreasing length of namestring of the source pathname.")
</span> `(:output-translations
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
<span style="color: #000000;background-color: #ffdddd">- #+(or #|clozure|# ecl mkcl sbcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp #|clozure|# ecl mkcl sbcl)
</span> ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
(when h `(((,h ,*wild-path*) ()))))
#+mkcl (,(translate-logical-pathname "CONTRIB:") ())
<span style="color: #aaaaaa">@@ -9358,17 +9630,19 @@ and the order is by decreasing length of namestring of the source pathname.")
</span> ;; We enable the user cache by default, and here is the place we do:
:enable-user-cache))
<span style="color: #000000;background-color: #ffdddd">- (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
- (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
</span><span style="color: #000000;background-color: #ddffdd">+ (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
+ (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
</span>
(defun user-output-translations-pathname (&key (direction :input))
<span style="color: #000000;background-color: #ffdddd">- (in-user-configuration-directory *output-translations-file* :direction direction))
</span><span style="color: #000000;background-color: #ddffdd">+ (xdg-config-pathname *output-translations-file* direction))
</span> (defun system-output-translations-pathname (&key (direction :input))
<span style="color: #000000;background-color: #ffdddd">- (in-system-configuration-directory *output-translations-file* :direction direction))
</span><span style="color: #000000;background-color: #ddffdd">+ (find-preferred-file (system-config-pathnames *output-translations-file*)
+ :direction direction))
</span> (defun user-output-translations-directory-pathname (&key (direction :input))
<span style="color: #000000;background-color: #ffdddd">- (in-user-configuration-directory *output-translations-directory* :direction direction))
</span><span style="color: #000000;background-color: #ddffdd">+ (xdg-config-pathname *output-translations-directory* direction))
</span> (defun system-output-translations-directory-pathname (&key (direction :input))
<span style="color: #000000;background-color: #ffdddd">- (in-system-configuration-directory *output-translations-directory* :direction direction))
</span><span style="color: #000000;background-color: #ddffdd">+ (find-preferred-file (system-config-pathnames *output-translations-directory*)
+ :direction direction))
</span> (defun environment-output-translations ()
(getenv "ASDF_OUTPUT_TRANSLATIONS"))
<span style="color: #aaaaaa">@@ -9402,12 +9676,10 @@ and the order is by decreasing length of namestring of the source pathname.")
</span> ((location-function-p dst)
(funcall collect
(list trusrc (ensure-function (second dst)))))
<span style="color: #000000;background-color: #ffdddd">- ((eq dst t)
</span><span style="color: #000000;background-color: #ddffdd">+ ((typep dst 'boolean)
</span> (funcall collect (list trusrc t)))
(t
<span style="color: #000000;background-color: #ffdddd">- (let* ((trudst (if dst
- (resolve-location dst :ensure-directory t :wilden t)
- trusrc)))
</span><span style="color: #000000;background-color: #ddffdd">+ (let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
</span> (funcall collect (list trudst t))
(funcall collect (list trusrc trudst)))))))))))
<span style="color: #aaaaaa">@@ -9688,12 +9960,12 @@ after having found a .asd file? True by default.")
</span> default-system-source-registry)
"List of default source registries" "3.1.0.102")
<span style="color: #000000;background-color: #ffdddd">- (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
- (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
</span><span style="color: #000000;background-color: #ddffdd">+ (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
+ (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
</span>
(defun wrapping-source-registry ()
`(:source-registry
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
</span> :inherit-configuration
#+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
#+cmu (:tree #p"modules:")
<span style="color: #aaaaaa">@@ -9702,34 +9974,25 @@ after having found a .asd file? True by default.")
</span> `(:source-registry
(:tree (:home "common-lisp/"))
#+sbcl (:directory (:home ".sbcl/systems/"))
<span style="color: #000000;background-color: #ffdddd">- ,@(loop :for dir :in
- `(,@(when (os-unix-p)
- `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
- (subpathname (user-homedir-pathname) ".local/share/"))))
- ,@(when (os-windows-p)
- (mapcar 'get-folder-path '(:local-appdata :appdata))))
- :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
- :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
</span><span style="color: #000000;background-color: #ddffdd">+ (:directory ,(xdg-data-home "common-lisp/systems/"))
+ (:tree ,(xdg-data-home "common-lisp/source/"))
</span> :inherit-configuration))
(defun default-system-source-registry ()
`(:source-registry
<span style="color: #000000;background-color: #ffdddd">- ,@(loop :for dir :in
- `(,@(when (os-unix-p)
- (or (getenv-absolute-directories "XDG_DATA_DIRS")
- '("/usr/local/share" "/usr/share")))
- ,@(when (os-windows-p)
- (list (get-folder-path :common-appdata))))
- :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
- :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
</span><span style="color: #000000;background-color: #ddffdd">+ ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
+ :collect `(:directory (,dir "systems/"))
+ :collect `(:tree (,dir "source/")))
</span> :inherit-configuration))
(defun user-source-registry (&key (direction :input))
<span style="color: #000000;background-color: #ffdddd">- (in-user-configuration-directory *source-registry-file* :direction direction))
</span><span style="color: #000000;background-color: #ddffdd">+ (xdg-config-pathname *source-registry-file* direction))
</span> (defun system-source-registry (&key (direction :input))
<span style="color: #000000;background-color: #ffdddd">- (in-system-configuration-directory *source-registry-file* :direction direction))
</span><span style="color: #000000;background-color: #ddffdd">+ (find-preferred-file (system-config-pathnames *source-registry-file*)
+ :direction direction))
</span> (defun user-source-registry-directory (&key (direction :input))
<span style="color: #000000;background-color: #ffdddd">- (in-user-configuration-directory *source-registry-directory* :direction direction))
</span><span style="color: #000000;background-color: #ddffdd">+ (xdg-config-pathname *source-registry-directory* direction))
</span> (defun system-source-registry-directory (&key (direction :input))
<span style="color: #000000;background-color: #ffdddd">- (in-system-configuration-directory *source-registry-directory* :direction direction))
</span><span style="color: #000000;background-color: #ddffdd">+ (find-preferred-file (system-config-pathnames *source-registry-directory*)
+ :direction direction))
</span> (defun environment-source-registry ()
(getenv "CL_SOURCE_REGISTRY"))
<span style="color: #aaaaaa">@@ -9863,116 +10126,47 @@ after having found a .asd file? True by default.")
</span>
;;;; -------------------------------------------------------------------------
-;;; Internal hacks for backward-compatibility
<span style="color: #000000;background-color: #ddffdd">+;;;; Defsystem
</span>
-(uiop/package:define-package :asdf/backward-internals
<span style="color: #000000;background-color: #ffdddd">- (:recycle :asdf/backward-internals :asdf)
- (:use :uiop/common-lisp :uiop :asdf/upgrade
- :asdf/system :asdf/component :asdf/operation
- :asdf/find-system :asdf/action :asdf/lisp-action)
- (:export ;; for internal use
- #:load-sysdef #:make-temporary-package
- #:%refresh-component-inline-methods
- #:make-sub-operation
- #:load-sysdef #:make-temporary-package))
</span>-(in-package :asdf/backward-internals)
<span style="color: #000000;background-color: #ddffdd">+(uiop/package:define-package :asdf/parse-defsystem
+ (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
+ (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
+ (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
+ :asdf/cache :asdf/component :asdf/system
+ :asdf/find-system :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
+ (:import-from :asdf/system #:depends-on #:weakly-depends-on)
+ (:export
+ #:defsystem #:register-system-definition
+ #:class-for-type #:*default-component-class*
+ #:determine-system-directory #:parse-component-form
+ #:non-toplevel-system #:non-system-system
+ #:sysdef-error-component #:check-component-input))
+(in-package :asdf/parse-defsystem)
</span>
-;;;; Backward compatibility with "inline methods"
<span style="color: #000000;background-color: #ddffdd">+;;; Pathname
</span> (with-upgradability ()
<span style="color: #000000;background-color: #ffdddd">- (defparameter* +asdf-methods+
- '(perform-with-restarts perform explain output-files operation-done-p))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun %remove-component-inline-methods (component)
- (dolist (name +asdf-methods+)
- (map ()
- ;; this is inefficient as most of the stored
- ;; methods will not be for this particular gf
- ;; But this is hardly performance-critical
- #'(lambda (m)
- (remove-method (symbol-function name) m))
- (component-inline-methods component)))
- (component-inline-methods component) nil)
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun %define-component-inline-methods (ret rest)
- (loop* :for (key value) :on rest :by #'cddr
- :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
- :when name :do
- (destructuring-bind (op &rest body) value
- (loop :for arg = (pop body)
- :while (atom arg)
- :collect arg :into qualifiers
- :finally
- (destructuring-bind (o c) arg
- (pushnew
- (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
- (component-inline-methods ret)))))))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun %refresh-component-inline-methods (component rest)
- ;; clear methods, then add the new ones
- (%remove-component-inline-methods component)
- (%define-component-inline-methods component rest)))
</span>-
-(when-upgrading (:when (fboundp 'make-sub-operation))
<span style="color: #000000;background-color: #ffdddd">- (defun make-sub-operation (c o dep-c dep-o)
- (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
</span>-
-
-;;;; load-sysdef
-(with-upgradability ()
<span style="color: #000000;background-color: #ffdddd">- (defun load-sysdef (name pathname)
- (load-asd pathname :name name))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun make-temporary-package ()
- ;; For loading a .asd file, we don't make a temporary package anymore,
- ;; but use ASDF-USER. I'd like to have this function do this,
- ;; but since whoever uses it is likely to delete-package the result afterwards,
- ;; this would be a bad idea, so preserve the old behavior.
- (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
</span>-
-
-;;;; -------------------------------------------------------------------------
-;;;; Defsystem
-
-(uiop/package:define-package :asdf/parse-defsystem
<span style="color: #000000;background-color: #ffdddd">- (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
- (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
- (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
- :asdf/cache :asdf/component :asdf/system
- :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
- :asdf/backward-internals)
- (:import-from :asdf/system #:depends-on #:weakly-depends-on)
- (:export
- #:defsystem #:register-system-definition
- #:class-for-type #:*default-component-class*
- #:determine-system-directory #:parse-component-form
- #:non-toplevel-system #:non-system-system
- #:sysdef-error-component #:check-component-input))
</span>-(in-package :asdf/parse-defsystem)
-
-;;; Pathname
-(with-upgradability ()
<span style="color: #000000;background-color: #ffdddd">- (defun determine-system-directory (pathname)
- ;; The defsystem macro calls this function to determine
- ;; the pathname of a system as follows:
- ;; 1. if the pathname argument is an pathname object (NOT a namestring),
- ;; that is already an absolute pathname, return it.
- ;; 2. otherwise, the directory containing the LOAD-PATHNAME
- ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
- ;; if it is indeed available and an absolute pathname, then
- ;; the PATHNAME argument is normalized to a relative pathname
- ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
- ;; and merged into that DIRECTORY as per SUBPATHNAME.
- ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
- ;; and may be from within the EVAL-WHEN of a file compilation.
- ;; If no absolute pathname was found, we return NIL.
- (check-type pathname (or null string pathname))
- (pathname-directory-pathname
- (resolve-symlinks*
- (ensure-absolute-pathname
- (parse-unix-namestring pathname :type :directory)
- #'(lambda () (ensure-absolute-pathname
- (load-pathname) 'get-pathname-defaults nil))
- nil)))))
</span><span style="color: #000000;background-color: #ddffdd">+ (defun determine-system-directory (pathname)
+ ;; The defsystem macro calls this function to determine
+ ;; the pathname of a system as follows:
+ ;; 1. if the pathname argument is an pathname object (NOT a namestring),
+ ;; that is already an absolute pathname, return it.
+ ;; 2. otherwise, the directory containing the LOAD-PATHNAME
+ ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
+ ;; if it is indeed available and an absolute pathname, then
+ ;; the PATHNAME argument is normalized to a relative pathname
+ ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
+ ;; and merged into that DIRECTORY as per SUBPATHNAME.
+ ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
+ ;; and may be from within the EVAL-WHEN of a file compilation.
+ ;; If no absolute pathname was found, we return NIL.
+ (check-type pathname (or null string pathname))
+ (pathname-directory-pathname
+ (resolve-symlinks*
+ (ensure-absolute-pathname
+ (parse-unix-namestring pathname :type :directory)
+ #'(lambda () (ensure-absolute-pathname
+ (load-pathname) 'get-pathname-defaults nil))
+ nil)))))
</span>
;;; Component class
<span style="color: #aaaaaa">@@ -10055,6 +10249,42 @@ after having found a .asd file? True by default.")
</span> (invalid))))))
<span style="color: #000000;background-color: #ddffdd">+;;; "inline methods"
+(with-upgradability ()
+ (defparameter* +asdf-methods+
+ '(perform-with-restarts perform explain output-files operation-done-p))
+
+ (defun %remove-component-inline-methods (component)
+ (dolist (name +asdf-methods+)
+ (map ()
+ ;; this is inefficient as most of the stored
+ ;; methods will not be for this particular gf
+ ;; But this is hardly performance-critical
+ #'(lambda (m)
+ (remove-method (symbol-function name) m))
+ (component-inline-methods component)))
+ (component-inline-methods component) nil)
+
+ (defun %define-component-inline-methods (ret rest)
+ (loop* :for (key value) :on rest :by #'cddr
+ :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
+ :when name :do
+ (destructuring-bind (op &rest body) value
+ (loop :for arg = (pop body)
+ :while (atom arg)
+ :collect arg :into qualifiers
+ :finally
+ (destructuring-bind (o c) arg
+ (pushnew
+ (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
+ (component-inline-methods ret)))))))
+
+ (defun %refresh-component-inline-methods (component rest)
+ ;; clear methods, then add the new ones
+ (%remove-component-inline-methods component)
+ (%define-component-inline-methods component rest)))
+
+
</span> ;;; Main parsing function
(with-upgradability ()
(defun* parse-dependency-def (dd)
<span style="color: #aaaaaa">@@ -10182,8 +10412,9 @@ system names contained using COERCE-NAME. Return the result."
</span> :name name :source-file source-file))
(component-options
(remove-plist-keys '(:defsystem-depends-on :class) options))
<span style="color: #000000;background-color: #ffdddd">- (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
- (resolve-dependency-spec nil spec))))
</span><span style="color: #000000;background-color: #ddffdd">+ (defsystem-dependencies (loop :for spec :in defsystem-depends-on
+ :when (resolve-dependency-spec nil spec)
+ :collect :it)))
</span> ;; cache defsystem-depends-on in canonical form
(when defsystem-depends-on
(setf component-options
<span style="color: #aaaaaa">@@ -10234,7 +10465,7 @@ system names contained using COERCE-NAME. Return the result."
</span> ((build-args :initarg :args :initform nil :accessor extra-build-args)
(name-suffix :initarg :name-suffix :initform nil)
(bundle-type :initform :no-output-file :reader bundle-type)
<span style="color: #000000;background-color: #ffdddd">- #+ecl (lisp-files :initform nil :accessor extra-object-files)))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files)))
</span>
(defclass monolithic-op (operation) ()
(:documentation "A MONOLITHIC operation operates on a system *and all of its
<span style="color: #aaaaaa">@@ -10297,16 +10528,18 @@ itself.")) ;; operation on a system and its dependencies
</span> ((bundle-type :initform :fasl)))
(defclass prepare-bundle-op (sideway-operation)
<span style="color: #000000;background-color: #ffdddd">- ((sideway-operation :initform #+(or ecl mkcl) 'load-bundle-op #-(or ecl mkcl) 'load-op
- :allocation :class)))
</span><span style="color: #000000;background-color: #ddffdd">+ ((sideway-operation
+ :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
+ :allocation :class)))
</span>
(defclass lib-op (link-op gather-op non-propagating-operation)
((bundle-type :initform :lib))
(:documentation "compile the system and produce linkable (.a) library for it."))
(defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl) link-op #-ecl gather-op)
- ((selfward-operation :initform '(prepare-bundle-op #+ecl lib-op) :allocation :class)))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op)
+ ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
+ :allocation :class)))
</span>
(defclass load-bundle-op (basic-load-op selfward-operation)
((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)))
<span style="color: #aaaaaa">@@ -10321,18 +10554,19 @@ itself.")) ;; operation on a system and its dependencies
</span> (:documentation "compile the system and produce dynamic (.so/.dll) library for it."))
(defclass deliver-asd-op (basic-compile-op selfward-operation)
<span style="color: #000000;background-color: #ffdddd">- ((selfward-operation :initform '(compile-bundle-op #+(or ecl mkcl) lib-op) :allocation :class))
</span><span style="color: #000000;background-color: #ddffdd">+ ((selfward-operation :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) :allocation :class))
</span> (:documentation "produce an asd file for delivering the system as a single fasl"))
(defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
<span style="color: #000000;background-color: #ffdddd">- ((selfward-operation :initform '(monolithic-compile-bundle-op #+(or ecl mkcl) monolithic-lib-op)
- :allocation :class))
</span><span style="color: #000000;background-color: #ddffdd">+ ((selfward-operation
+ :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
+ :allocation :class))
</span> (:documentation "produce fasl and asd files for combined system and dependencies."))
(defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl) link-op gather-op non-propagating-operation)
- ((gather-op :initform #+(or ecl mkcl) 'lib-op #-(or ecl mkcl) 'compile-bundle-op :allocation :class))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation)
+ ((gather-op :initform #+(or clasp ecl mkcl) 'lib-op #-(or clasp ecl mkcl) 'compile-bundle-op :allocation :class))
</span> (:documentation "Create a single fasl for the system and its dependencies."))
(defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op)
<span style="color: #aaaaaa">@@ -10347,9 +10581,9 @@ itself.")) ;; operation on a system and its dependencies
</span> (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
(defclass image-op (monolithic-bundle-op selfward-operation
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl) link-op #+(or ecl mkcl) gather-op)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
</span> ((bundle-type :initform :image)
<span style="color: #000000;background-color: #ffdddd">- (selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class))
</span><span style="color: #000000;background-color: #ddffdd">+ (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
</span> (:documentation "create an image file from the system and its dependencies"))
(defclass program-op (image-op)
<span style="color: #aaaaaa">@@ -10360,15 +10594,15 @@ itself.")) ;; operation on a system and its dependencies
</span> (etypecase bundle-type
((eql :no-output-file) nil) ;; should we error out instead?
((or null string) bundle-type)
<span style="color: #000000;background-color: #ffdddd">- ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
- #+ecl
</span><span style="color: #000000;background-color: #ddffdd">+ ((eql :fasl) #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")
+ #+(or clasp ecl)
</span> ((member :dll :lib :shared-library :static-library :program :object :program)
(compile-file-type :type bundle-type))
<span style="color: #000000;background-color: #ffdddd">- ((member :image) #-allegro "image" #+allegro "dxl")
- ((member :dll :shared-library) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
- ((member :lib :static-library) (cond ((os-unix-p) "a")
- ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
- ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
</span><span style="color: #000000;background-color: #ddffdd">+ ((member :image) #+allegro "dxl" #+(and clisp os-windows) "exe" #-(or allegro (and clisp os-windows)) "image")
+ ((member :dll :shared-library) (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
+ ((member :lib :static-library) (os-cond ((os-unix-p) "a")
+ ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
+ ((eql :program) (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
</span>
(defun bundle-output-files (o c)
(let ((bundle-type (bundle-type o)))
<span style="color: #aaaaaa">@@ -10383,7 +10617,7 @@ itself.")) ;; operation on a system and its dependencies
</span> (defmethod output-files ((o bundle-op) (c system))
(bundle-output-files o c))
<span style="color: #000000;background-color: #ffdddd">- #-(or ecl mkcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or clasp ecl mkcl)
</span> (progn
(defmethod perform ((o image-op) (c system))
(dump-image (output-file o c) :executable (typep o 'program-op)))
<span style="color: #aaaaaa">@@ -10391,7 +10625,7 @@ itself.")) ;; operation on a system and its dependencies
</span> (setf *image-entry-point* (ensure-function (component-entry-point c)))))
(defclass compiled-file (file-component)
<span style="color: #000000;background-color: #ffdddd">- ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
</span><span style="color: #000000;background-color: #ddffdd">+ ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")))
</span>
(defclass precompiled-system (system)
((build-pathname :initarg :fasl)))
<span style="color: #aaaaaa">@@ -10417,15 +10651,16 @@ itself.")) ;; operation on a system and its dependencies
</span> (unless name-suffix-p
(setf (slot-value instance 'name-suffix)
(unless (typep instance 'program-op)
<span style="color: #000000;background-color: #ffdddd">- (if (operation-monolithic-p instance) "--all-systems" #-(or ecl mkcl) "--system")))) ; . no good for Logical Pathnames
</span><span style="color: #000000;background-color: #ddffdd">+ ;; "." is no good separator for Logical Pathnames, so we use "--"
+ (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system"))))
</span> (when (typep instance 'monolithic-bundle-op)
(destructuring-bind (&key lisp-files prologue-code epilogue-code
&allow-other-keys)
(operation-original-initargs instance)
(setf (prologue-code instance) prologue-code
(epilogue-code instance) epilogue-code)
<span style="color: #000000;background-color: #ffdddd">- #-ecl (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
- #+ecl (setf (extra-object-files instance) lisp-files)))
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
+ #+(or clasp ecl) (setf (extra-object-files instance) lisp-files)))
</span> (setf (extra-build-args instance)
(remove-plist-keys
'(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files
<span style="color: #aaaaaa">@@ -10435,8 +10670,8 @@ itself.")) ;; operation on a system and its dependencies
</span> (defun bundlable-file-p (pathname)
(let ((type (pathname-type pathname)))
(declare (ignorable type))
<span style="color: #000000;background-color: #ffdddd">- (or #+ecl (or (equalp type (compile-file-type :type :object))
- (equalp type (compile-file-type :type :static-library)))
</span><span style="color: #000000;background-color: #ddffdd">+ (or #+(or clasp ecl) (or (equalp type (compile-file-type :type :object))
+ (equalp type (compile-file-type :type :static-library)))
</span> #+mkcl (or (equalp type (compile-file-type :fasl-p nil))
#+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW
#+(and windows (not (or mingw32 mingw64))) (equalp type "lib"))
<span style="color: #aaaaaa">@@ -10635,7 +10870,7 @@ itself.")) ;; operation on a system and its dependencies
</span> s)
(terpri s)))))
<span style="color: #000000;background-color: #ffdddd">- #-(or ecl mkcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #-(or clasp ecl mkcl)
</span> (defmethod perform ((o basic-compile-bundle-op) (c system))
(let* ((input-files (input-files o c))
(fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
<span style="color: #aaaaaa">@@ -10669,26 +10904,29 @@ itself.")) ;; operation on a system and its dependencies
</span> (asdf:load-system :precompiled-asdf-utils)
|#
-#+(or ecl mkcl)
<span style="color: #000000;background-color: #ddffdd">+#+(or clasp ecl mkcl)
</span> (with-upgradability ()
;; I think that Juanjo intended for this to be,
;; but beware the weird bug in test-xach-update-bug.script,
;; and also it makes mkcl fail test-logical-pathname.script,
;; and ecl fail test-bundle.script.
<span style="color: #000000;background-color: #ffdddd">- ;;(unless (or #+ecl (use-ecl-byte-compiler-p))
</span><span style="color: #000000;background-color: #ddffdd">+ ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p))
</span> ;; (setf *load-system-operation* 'load-bundle-op))
(defun uiop-library-pathname ()
<span style="color: #000000;background-color: #ddffdd">+ #+clasp (probe-file* (compile-file-pathname "sys:uiop" :output-type :object))
</span> #+ecl (or (probe-file* (compile-file-pathname "sys:uiop" :type :lib)) ;; new style
(probe-file* (compile-file-pathname "sys:uiop" :type :object))) ;; old style
#+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;uiop"))
(defun asdf-library-pathname ()
<span style="color: #000000;background-color: #ddffdd">+ #+clasp (probe-file* (compile-file-pathname "sys:asdf" :output-type :object))
</span> #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style
(probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style
#+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))
(defun compiler-library-pathname ()
<span style="color: #000000;background-color: #ddffdd">+ #+clasp (compile-file-pathname "sys:cmp" :output-type :lib)
</span> #+ecl (compile-file-pathname "sys:cmp" :type :lib)
#+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))
<span style="color: #aaaaaa">@@ -10733,7 +10971,7 @@ itself.")) ;; operation on a system and its dependencies
</span> (when programp `(:entry-point ,(component-entry-point c))))))))
#+(and (not asdf-use-unsafe-mac-bundle-op)
<span style="color: #000000;background-color: #ffdddd">- (or (and ecl darwin)
</span><span style="color: #000000;background-color: #ddffdd">+ (or (and clasp ecl darwin)
</span> (and abcl darwin (not abcl-bundle-op-supported))))
(defmethod perform :before ((o basic-compile-bundle-op) (c component))
(unless (featurep :asdf-use-unsafe-mac-bundle-op)
<span style="color: #aaaaaa">@@ -10848,6 +11086,167 @@ Please report to ASDF-DEVEL if this works for you.")))
</span> (perform-lisp-load-fasl o s)))
;;;; -------------------------------------------------------------------------
<span style="color: #000000;background-color: #ddffdd">+;;;; Package systems in the style of quick-build or faslpath
+
+(uiop:define-package :asdf/package-inferred-system
+ (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
+ (:use :uiop/common-lisp :uiop
+ :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
+ :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
+ (:export
+ #:package-inferred-system #:sysdef-package-inferred-system-search
+ #:package-system ;; backward compatibility only. To be removed.
+ #:register-system-packages
+ #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
+(in-package :asdf/package-inferred-system)
+
+(with-upgradability ()
+ (defparameter *defpackage-forms* '(defpackage define-package))
+
+ (defun initial-package-inferred-systems-table ()
+ (let ((h (make-hash-table :test 'equal)))
+ (dolist (p (list-all-packages))
+ (dolist (n (package-names p))
+ (setf (gethash n h) t)))
+ h))
+
+ (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
+
+ (defclass package-inferred-system (system)
+ ())
+
+ ;; For backward compatibility only. To be removed in an upcoming release:
+ (defclass package-system (package-inferred-system) ())
+
+ (defun defpackage-form-p (form)
+ (and (consp form)
+ (member (car form) *defpackage-forms*)))
+
+ (defun stream-defpackage-form (stream)
+ (loop :for form = (read stream nil nil) :while form
+ :when (defpackage-form-p form) :return form))
+
+ (defun file-defpackage-form (file)
+ "Return the first DEFPACKAGE form in FILE."
+ (with-input-file (f file)
+ (stream-defpackage-form f)))
+
+ (define-condition package-inferred-system-missing-package-error (system-definition-error)
+ ((system :initarg :system :reader error-system)
+ (pathname :initarg :pathname :reader error-pathname))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<No package form found while ~
+ trying to define package-inferred-system ~A from file ~A~>")
+ (error-system c) (error-pathname c)))))
+
+ (defun package-dependencies (defpackage-form)
+ "Return a list of packages depended on by the package
+defined in DEFPACKAGE-FORM. A package is depended upon if
+the DEFPACKAGE-FORM uses it or imports a symbol from it."
+ (assert (defpackage-form-p defpackage-form))
+ (remove-duplicates
+ (while-collecting (dep)
+ (loop* :for (option . arguments) :in (cddr defpackage-form) :do
+ (ecase option
+ ((:use :mix :reexport :use-reexport :mix-reexport)
+ (dolist (p arguments) (dep (string p))))
+ ((:import-from :shadowing-import-from)
+ (dep (string (first arguments))))
+ ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
+ :from-end t :test 'equal))
+
+ (defun package-designator-name (package)
+ (etypecase package
+ (package (package-name package))
+ (string package)
+ (symbol (string package))))
+
+ (defun register-system-packages (system packages)
+ "Register SYSTEM as providing PACKAGES."
+ (let ((name (or (eq system t) (coerce-name system))))
+ (dolist (p (ensure-list packages))
+ (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
+
+ (defun package-name-system (package-name)
+ "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
+otherwise return a default system name computed from PACKAGE-NAME."
+ (check-type package-name string)
+ (if-let ((system-name (gethash package-name *package-inferred-systems*)))
+ system-name
+ (string-downcase package-name)))
+
+ (defun package-inferred-system-file-dependencies (file &optional system)
+ (if-let (defpackage-form (file-defpackage-form file))
+ (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
+ (error 'package-inferred-system-missing-package-error :system system :pathname file)))
+
+ (defun same-package-inferred-system-p (system name directory subpath dependencies)
+ (and (eq (type-of system) 'package-inferred-system)
+ (equal (component-name system) name)
+ (pathname-equal directory (component-pathname system))
+ (equal dependencies (component-sideway-dependencies system))
+ (let ((children (component-children system)))
+ (and (length=n-p children 1)
+ (let ((child (first children)))
+ (and (eq (type-of child) 'cl-source-file)
+ (equal (component-name child) "lisp")
+ (and (slot-boundp child 'relative-pathname)
+ (equal (slot-value child 'relative-pathname) subpath))))))))
+
+ (defun sysdef-package-inferred-system-search (system)
+ (let ((primary (primary-system-name system)))
+ (unless (equal primary system)
+ (let ((top (find-system primary nil)))
+ (when (typep top 'package-inferred-system)
+ (if-let (dir (system-source-directory top))
+ (let* ((sub (subseq system (1+ (length primary))))
+ (f (probe-file* (subpathname dir sub :type "lisp")
+ :truename *resolve-symlinks*)))
+ (when (file-pathname-p f)
+ (let ((dependencies (package-inferred-system-file-dependencies f system))
+ (previous (cdr (system-registered-p system))))
+ (if (same-package-inferred-system-p previous system dir sub dependencies)
+ previous
+ (eval `(defsystem ,system
+ :class package-inferred-system
+ :source-file nil
+ :pathname ,dir
+ :depends-on ,dependencies
+ :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
+
+(with-upgradability ()
+ (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
+ (setf *system-definition-search-functions*
+ (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
+ *system-definition-search-functions*)))
+;;;; -------------------------------------------------------------------------
+;;; Internal hacks for backward-compatibility
+
+(uiop/package:define-package :asdf/backward-internals
+ (:recycle :asdf/backward-internals :asdf)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
+ (:export ;; for internal use
+ #:make-sub-operation
+ #:load-sysdef #:make-temporary-package))
+(in-package :asdf/backward-internals)
+
+(when-upgrading (:when (fboundp 'make-sub-operation))
+ (defun make-sub-operation (c o dep-c dep-o)
+ (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
+
+;;;; load-sysdef
+(with-upgradability ()
+ (defun load-sysdef (name pathname)
+ (load-asd pathname :name name))
+
+ (defun make-temporary-package ()
+ ;; For loading a .asd file, we don't make a temporary package anymore,
+ ;; but use ASDF-USER. I'd like to have this function do this,
+ ;; but since whoever uses it is likely to delete-package the result afterwards,
+ ;; this would be a bad idea, so preserve the old behavior.
+ (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
+
+;;;; -------------------------------------------------------------------------
</span> ;;; Backward-compatible interfaces
(uiop/package:define-package :asdf/backward-interface
<span style="color: #aaaaaa">@@ -10935,15 +11334,15 @@ processed in order by OPERATE."))
</span> (default-toplevel-directory
(subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
(include-per-user-information nil)
<span style="color: #000000;background-color: #ffdddd">- (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
</span><span style="color: #000000;background-color: #ddffdd">+ (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil))
</span> (source-to-target-mappings nil)
(file-types `(,(compile-file-type)
"build-report"
<span style="color: #000000;background-color: #ffdddd">- #+ecl (compile-file-type :type :object)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl) (compile-file-type :type :object)
</span> #+mkcl (compile-file-type :fasl-p nil)
#+clisp "lib" #+sbcl "cfasl"
#+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
<span style="color: #000000;background-color: #ffdddd">- #+(or clisp ecl mkcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp clisp ecl mkcl)
</span> (when (null map-all-source-files)
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
(let* ((patterns (if map-all-source-files (list *wild-file*)
<span style="color: #aaaaaa">@@ -11020,140 +11419,6 @@ Please use UIOP:RUN-PROGRAM instead."
</span> (setf (slot-value c 'properties)
(acons property new-value (slot-value c 'properties)))))
new-value))
-;;;; -------------------------------------------------------------------------
-;;;; Package systems in the style of quick-build or faslpath
-
-(uiop:define-package :asdf/package-inferred-system
<span style="color: #000000;background-color: #ffdddd">- (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
- (:use :uiop/common-lisp :uiop
- :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
- :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
- (:export
- #:package-inferred-system #:sysdef-package-inferred-system-search
- #:package-system ;; backward compatibility only. To be removed.
- #:register-system-packages
- #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
</span>-(in-package :asdf/package-inferred-system)
-
-(with-upgradability ()
<span style="color: #000000;background-color: #ffdddd">- (defparameter *defpackage-forms* '(defpackage define-package))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun initial-package-inferred-systems-table ()
- (let ((h (make-hash-table :test 'equal)))
- (dolist (p (list-all-packages))
- (dolist (n (package-names p))
- (setf (gethash n h) t)))
- h))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defclass package-inferred-system (system)
- ())
</span>-
<span style="color: #000000;background-color: #ffdddd">- ;; For backward compatibility only. To be removed in an upcoming release:
- (defclass package-system (package-inferred-system) ())
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun defpackage-form-p (form)
- (and (consp form)
- (member (car form) *defpackage-forms*)))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun stream-defpackage-form (stream)
- (loop :for form = (read stream nil nil) :while form
- :when (defpackage-form-p form) :return form))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun file-defpackage-form (file)
- "Return the first DEFPACKAGE form in FILE."
- (with-input-file (f file)
- (stream-defpackage-form f)))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (define-condition package-inferred-system-missing-package-error (system-definition-error)
- ((system :initarg :system :reader error-system)
- (pathname :initarg :pathname :reader error-pathname))
- (:report (lambda (c s)
- (format s (compatfmt "~@<No package form found while ~
- trying to define package-inferred-system ~A from file ~A~>")
- (error-system c) (error-pathname c)))))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun package-dependencies (defpackage-form)
- "Return a list of packages depended on by the package
</span>-defined in DEFPACKAGE-FORM. A package is depended upon if
-the DEFPACKAGE-FORM uses it or imports a symbol from it."
<span style="color: #000000;background-color: #ffdddd">- (assert (defpackage-form-p defpackage-form))
- (remove-duplicates
- (while-collecting (dep)
- (loop* :for (option . arguments) :in (cddr defpackage-form) :do
- (ecase option
- ((:use :mix :reexport :use-reexport :mix-reexport)
- (dolist (p arguments) (dep (string p))))
- ((:import-from :shadowing-import-from)
- (dep (string (first arguments))))
- ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
- :from-end t :test 'equal))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun package-designator-name (package)
- (etypecase package
- (package (package-name package))
- (string package)
- (symbol (string package))))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun register-system-packages (system packages)
- "Register SYSTEM as providing PACKAGES."
- (let ((name (or (eq system t) (coerce-name system))))
- (dolist (p (ensure-list packages))
- (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun package-name-system (package-name)
- "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
</span>-otherwise return a default system name computed from PACKAGE-NAME."
<span style="color: #000000;background-color: #ffdddd">- (check-type package-name string)
- (if-let ((system-name (gethash package-name *package-inferred-systems*)))
- system-name
- (string-downcase package-name)))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun package-inferred-system-file-dependencies (file &optional system)
- (if-let (defpackage-form (file-defpackage-form file))
- (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
- (error 'package-inferred-system-missing-package-error :system system :pathname file)))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun same-package-inferred-system-p (system name directory subpath dependencies)
- (and (eq (type-of system) 'package-inferred-system)
- (equal (component-name system) name)
- (pathname-equal directory (component-pathname system))
- (equal dependencies (component-sideway-dependencies system))
- (let ((children (component-children system)))
- (and (length=n-p children 1)
- (let ((child (first children)))
- (and (eq (type-of child) 'cl-source-file)
- (equal (component-name child) "lisp")
- (and (slot-boundp child 'relative-pathname)
- (equal (slot-value child 'relative-pathname) subpath))))))))
</span>-
<span style="color: #000000;background-color: #ffdddd">- (defun sysdef-package-inferred-system-search (system)
- (let ((primary (primary-system-name system)))
- (unless (equal primary system)
- (let ((top (find-system primary nil)))
- (when (typep top 'package-inferred-system)
- (if-let (dir (system-source-directory top))
- (let* ((sub (subseq system (1+ (length primary))))
- (f (probe-file* (subpathname dir sub :type "lisp")
- :truename *resolve-symlinks*)))
- (when (file-pathname-p f)
- (let ((dependencies (package-inferred-system-file-dependencies f system))
- (previous (cdr (system-registered-p system))))
- (if (same-package-inferred-system-p previous system dir sub dependencies)
- previous
- (eval `(defsystem ,system
- :class package-inferred-system
- :source-file nil
- :pathname ,dir
- :depends-on ,dependencies
- :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
</span>-
-(with-upgradability ()
<span style="color: #000000;background-color: #ffdddd">- (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
- (setf *system-definition-search-functions*
- (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
- *system-definition-search-functions*)))
</span> ;;;; ---------------------------------------------------------------------------
;;;; Handle ASDF package upgrade, including implementation-dependent magic.
<span style="color: #aaaaaa">@@ -11172,7 +11437,7 @@ otherwise return a default system name computed from PACKAGE-NAME."
</span> ;; Note: (1) we are NOT automatically reexporting everything from previous packages.
;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
(:export
<span style="color: #000000;background-color: #ffdddd">- #:defsystem #:find-system #:locate-system #:coerce-name #:primary-system-name
</span><span style="color: #000000;background-color: #ddffdd">+ #:defsystem #:find-system #:load-asd #:locate-system #:coerce-name #:primary-system-name
</span> #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
#:system-definition-pathname
#:search-for-system-definition #:find-component #:component-find-path
<span style="color: #aaaaaa">@@ -11214,6 +11479,9 @@ otherwise return a default system name computed from PACKAGE-NAME."
</span> #:static-file #:doc-file #:html-file
#:file-type #:source-file-type
<span style="color: #000000;background-color: #ddffdd">+ #:register-preloaded-system #:sysdef-preloaded-system-search
+ #:register-immutable-system #:sysdef-immutable-system-search
+
</span> #:package-inferred-system #:register-system-packages
#:package-system ;; backward-compatibility during migration, to be removed in a further release.
<span style="color: #aaaaaa">@@ -11258,7 +11526,7 @@ otherwise return a default system name computed from PACKAGE-NAME."
</span> #:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
#:*resolve-symlinks*
<span style="color: #000000;background-color: #ffdddd">- #:*load-system-operation* #:*immutable-systems*
</span><span style="color: #000000;background-color: #ddffdd">+ #:*load-system-operation*
</span> #:*asdf-verbose* ;; unused. For backward-compatibility only.
#:*verbose-out*
<span style="color: #aaaaaa">@@ -11347,27 +11615,27 @@ otherwise return a default system name computed from PACKAGE-NAME."
</span> (in-package :asdf/footer)
;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
-#+(or abcl clisp clozure cmu ecl mkcl sbcl)
<span style="color: #000000;background-color: #ddffdd">+#+(or abcl clasp clisp clozure cmu ecl mkcl sbcl)
</span> (with-upgradability ()
(if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
(eval `(pushnew 'module-provide-asdf
#+abcl sys::*module-provider-functions*
<span style="color: #000000;background-color: #ddffdd">+ #+(or clasp cmu ecl) ext:*module-provider-functions*
</span> #+clisp ,x
#+clozure ccl:*module-provider-functions*
<span style="color: #000000;background-color: #ffdddd">- #+(or cmu ecl) ext:*module-provider-functions*
</span> #+mkcl mk-ext:*module-provider-functions*
#+sbcl sb-ext:*module-provider-functions*)))
<span style="color: #000000;background-color: #ffdddd">- #+(or ecl mkcl)
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or clasp ecl mkcl)
</span> (progn
(pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car)
<span style="color: #000000;background-color: #ffdddd">- #+(or (and ecl win32) (and mkcl windows))
- (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
- (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
</span><span style="color: #000000;background-color: #ddffdd">+ #+(or (and clasp windows) (and ecl win32) (and mkcl windows))
+ (unless (assoc "asd" #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
+ (appendf #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
</span>
<span style="color: #000000;background-color: #ffdddd">- (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
- (loop :for f :in #+ecl ext:*module-provider-functions*
</span><span style="color: #000000;background-color: #ddffdd">+ (setf #+(or clasp ecl) ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
+ (loop :for f :in #+(or clasp ecl) ext:*module-provider-functions*
</span> #+mkcl mk-ext::*module-provider-functions*
:collect
(if (eq f 'module-provide-asdf) f
</code></pre>
<br>
</li>
</div>
<div class='footer' style='margin-top: 10px;'>
<p>
—
<br>
<a href="https://gitlab.common-lisp.net/cmucl/cmucl/commit/627b5fafb698aca6ac71db89bd7f5ca0bbeb9955">View it on GitLab</a>
<script type="application/ld+json">{"@context":"http://schema.org","@type":"EmailMessage","action":{"@type":"ViewAction","name":"View Commit","url":"https://gitlab.common-lisp.net/cmucl/cmucl/commit/627b5fafb698aca6ac71db89bd7f5ca0bbeb9955"}}</script>
</p>
</div>
</body>
</html>