Commit 91592aa5 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Merge branch 'getenv-pathnames-nil'

parents 11a8348e 0e04498e
...@@ -318,7 +318,7 @@ MORE may contain specifications for a subpath relative to these directories: a ...@@ -318,7 +318,7 @@ MORE may contain specifications for a subpath relative to these directories: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual." also \"Configuration DSL\"\) in the ASDF manual."
(mapcar #'(lambda (d) (resolve-location `(,d ,more))) (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
(or (getenv-absolute-directories "XDG_DATA_DIRS") (or (remove nil (getenv-absolute-directories "XDG_DATA_DIRS"))
(os-cond (os-cond
((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata))) ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
(t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/"))))))) (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))))
...@@ -330,7 +330,7 @@ MORE may contain specifications for a subpath relative to these directories: ...@@ -330,7 +330,7 @@ MORE may contain specifications for a subpath relative to these directories:
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual." also \"Configuration DSL\"\) in the ASDF manual."
(mapcar #'(lambda (d) (resolve-location `(,d ,more))) (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
(or (getenv-absolute-directories "XDG_CONFIG_DIRS") (or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIRS"))
(os-cond (os-cond
((os-windows-p) (xdg-data-dirs "config/")) ((os-windows-p) (xdg-data-dirs "config/"))
(t (mapcar 'parse-unix-namestring '("/etc/xdg/"))))))) (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))
......
...@@ -209,9 +209,10 @@ but the behavior in presence of symlinks is not portable. Use IOlib to handle su ...@@ -209,9 +209,10 @@ but the behavior in presence of symlinks is not portable. Use IOlib to handle su
;; logical pathnames have restrictions on wild patterns. ;; logical pathnames have restrictions on wild patterns.
;; Not that the results are very portable when you use these patterns on physical pathnames. ;; Not that the results are very portable when you use these patterns on physical pathnames.
(when (wild-pathname-p dir) (when (wild-pathname-p dir)
(error "Invalid wild pattern in logical directory ~S" directory)) (parameter-error "~S: Invalid wild pattern in logical directory ~S"
'directory-files directory))
(unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
(error "Invalid file pattern ~S for logical directory ~S" pattern directory)) (parameter-error "~S: Invalid file pattern ~S for logical directory ~S" 'directory-files pattern directory))
(setf pattern (make-pathname-logical pattern (pathname-host dir)))) (setf pattern (make-pathname-logical pattern (pathname-host dir))))
(let* ((pat (merge-pathnames* pattern dir)) (let* ((pat (merge-pathnames* pattern dir))
(entries (ignore-errors (directory* pat)))) (entries (ignore-errors (directory* pat))))
...@@ -524,7 +525,7 @@ check constraints and normalize as per ENSURE-PATHNAME." ...@@ -524,7 +525,7 @@ check constraints and normalize as per ENSURE-PATHNAME."
check constraints and normalize each one as per ENSURE-PATHNAME. check constraints and normalize each one as per ENSURE-PATHNAME.
Any empty entries in the environment variable X will be returned as NILs." Any empty entries in the environment variable X will be returned as NILs."
(unless (getf constraints :empty-is-nil t) (unless (getf constraints :empty-is-nil t)
(error "Cannot have EMPTY-IS-NIL false for GETENV-PATHNAMES.")) (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-pathnames))
(apply 'split-native-pathnames-string (getenvp x) (apply 'split-native-pathnames-string (getenvp x)
:on-error (or on-error :on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
...@@ -641,13 +642,13 @@ If you're suicidal or extremely confident, just use :VALIDATE T." ...@@ -641,13 +642,13 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
(cond (cond
((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname) ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname)
(physical-pathname-p directory-pathname) (not (wild-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" (parameter-error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
'delete-directory-tree directory-pathname)) 'delete-directory-tree directory-pathname))
((not validatep) ((not validatep)
(error "~S was asked to delete ~S but was not provided a validation predicate" (parameter-error "~S was asked to delete ~S but was not provided a validation predicate"
'delete-directory-tree directory-pathname)) 'delete-directory-tree directory-pathname))
((not (call-function validate directory-pathname)) ((not (call-function validate directory-pathname))
(error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]" (parameter-error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
'delete-directory-tree directory-pathname validate)) 'delete-directory-tree directory-pathname validate))
((not (directory-exists-p directory-pathname)) ((not (directory-exists-p directory-pathname))
(ecase if-does-not-exist (ecase if-does-not-exist
......
...@@ -78,7 +78,7 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -78,7 +78,7 @@ This is designed to abstract away the implementation specific quit forms."
(exit `(,exit :code code :abort (not finish-output))) (exit `(,exit :code code :abort (not finish-output)))
(quit `(,quit :unix-status code :recklessly-p (not finish-output))))) (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
#-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (not-implemented-error 'quit "(called with exit code ~S)" code))
(defun die (code format &rest arguments) (defun die (code format &rest arguments)
"Die in error with some error message" "Die in error with some error message"
...@@ -352,7 +352,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ...@@ -352,7 +352,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
(setf *image-restored-p* nil) (setf *image-restored-p* nil)
#-(or clisp clozure (and cmucl executable) lispworks sbcl scl) #-(or clisp clozure (and cmucl executable) lispworks sbcl scl)
(when executable (when executable
(error "Dumping an executable is not supported on this implementation! Aborting.")) (not-implemented-error 'dump-image "dumping an executable"))
#+allegro #+allegro
(progn (progn
(sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000 (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
...@@ -410,8 +410,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ...@@ -410,8 +410,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
;; the default is :console - only works with SBCL 1.1.15 or later. ;; the default is :console - only works with SBCL 1.1.15 or later.
(when application-type (list :application-type application-type))))) (when application-type (list :application-type application-type)))))
#-(or allegro clisp clozure cmucl gcl lispworks sbcl scl) #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl)
(error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%" (not-implemented-error 'dump-image))
'dump-image filename (nth-value 1 (implementation-type))))
(defun create-image (destination lisp-object-files (defun create-image (destination lisp-object-files
&key kind output-name prologue-code epilogue-code extra-object-files &key kind output-name prologue-code epilogue-code extra-object-files
......
...@@ -26,7 +26,8 @@ as either a recognizing function or a sequence of characters." ...@@ -26,7 +26,8 @@ as either a recognizing function or a sequence of characters."
(some (some
(cond (cond
((and good-chars bad-chars) ((and good-chars bad-chars)
(error "only one of good-chars and bad-chars can be provided")) (parameter-error "~S: only one of good-chars and bad-chars can be provided"
'requires-escaping-p))
((typep good-chars 'function) ((typep good-chars 'function)
(complement good-chars)) (complement good-chars))
((typep bad-chars 'function) ((typep bad-chars 'function)
...@@ -35,7 +36,7 @@ as either a recognizing function or a sequence of characters." ...@@ -35,7 +36,7 @@ as either a recognizing function or a sequence of characters."
#'(lambda (c) (not (find c good-chars)))) #'(lambda (c) (not (find c good-chars))))
((and bad-chars (typep bad-chars 'sequence)) ((and bad-chars (typep bad-chars 'sequence))
#'(lambda (c) (find c bad-chars))) #'(lambda (c) (find c bad-chars)))
(t (error "requires-escaping-p: no good-char criterion"))) (t (parameter-error "~S: no good-char criterion" 'requires-escaping-p)))
token)) token))
(defun escape-token (token &key stream quote good-chars bad-chars escaper) (defun escape-token (token &key stream quote good-chars bad-chars escaper)
......
...@@ -771,8 +771,7 @@ it will filter them appropriately." ...@@ -771,8 +771,7 @@ it will filter them appropriately."
(defun combine-fasls (inputs output) (defun combine-fasls (inputs output)
"Combine a list of FASLs INPUTS into a single FASL OUTPUT" "Combine a list of FASLs INPUTS into a single FASL OUTPUT"
#-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl) #-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl)
(error "~A does not support ~S~%inputs ~S~%output ~S" (not-implemented-error 'combine-fasls "~%inputs: ~S~%output: ~S" inputs output)
(implementation-type) 'combine-fasls inputs output)
#+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0 #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
#+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output) #+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output)
#+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
......
...@@ -29,7 +29,7 @@ keywords explicitly." ...@@ -29,7 +29,7 @@ keywords explicitly."
((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
((eq :or (car x)) (some #'featurep (cdr x))) ((eq :or (car x)) (some #'featurep (cdr x)))
((eq :and (car x)) (every #'featurep (cdr x))) ((eq :and (car x)) (every #'featurep (cdr x)))
(t (error "Malformed feature specification ~S" x)))) (t (parameter-error "~S: malformed feature specification ~S" 'featurep x))))
;; Starting with UIOP 3.1.5, these are runtime tests. ;; 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. ;; You may bind *features* with a copy of what your target system offers to test its properties.
...@@ -112,7 +112,7 @@ use getenvp to return NIL in such a case." ...@@ -112,7 +112,7 @@ use getenvp to return NIL in such a case."
#+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
#+sbcl (sb-ext:posix-getenv x) #+sbcl (sb-ext:posix-getenv x)
#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "~S is not supported on your implementation" 'getenv)) (not-implemented-error 'getenv))
(defsetf getenv (x) (val) (defsetf getenv (x) (val)
"Set an environment variable." "Set an environment variable."
...@@ -126,7 +126,7 @@ use getenvp to return NIL in such a case." ...@@ -126,7 +126,7 @@ use getenvp to return NIL in such a case."
#+mkcl `(mkcl:setenv ,x ,val) #+mkcl `(mkcl:setenv ,x ,val)
#+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
#-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl) #-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl)
'(error "~S ~S is not supported on your implementation" 'setf 'getenv)) '(not-implemented-error '(setf getenv)))
(defun getenvp (x) (defun getenvp (x)
"Predicate that is true if the named variable is present in the libc environment, "Predicate that is true if the named variable is present in the libc environment,
...@@ -289,7 +289,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie ...@@ -289,7 +289,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
#+mkcl (mk-ext:getcwd) #+mkcl (mk-ext:getcwd)
#+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
#+xcl (extensions:current-directory) #+xcl (extensions:current-directory)
(error "getcwd not supported on your implementation"))) (not-implemented-error 'getcwd)))
(defun chdir (x) (defun chdir (x)
"Change current directory, as per POSIX chdir(2), to a given pathname object" "Change current directory, as per POSIX chdir(2), to a given pathname object"
...@@ -307,7 +307,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie ...@@ -307,7 +307,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
#+mkcl (mk-ext:chdir x) #+mkcl (mk-ext:chdir x)
#+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
(error "chdir not supported on your implementation")))) (not-implemented-error 'chdir))))
;;;; ----------------------------------------------------------------- ;;;; -----------------------------------------------------------------
......
...@@ -56,7 +56,8 @@ that is a list and not a string." ...@@ -56,7 +56,8 @@ that is a list and not a string."
((consp directory) ((consp directory)
(cons :relative directory)) (cons :relative directory))
(t (t
(error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory)))) (parameter-error (compatfmt "~@<~S: Unrecognized pathname directory component ~S~@:>")
'normalize-pathname-directory-component directory))))
(defun denormalize-pathname-directory-component (directory-component) (defun denormalize-pathname-directory-component (directory-component)
"Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
...@@ -487,7 +488,8 @@ or if it is a PATHNAME but some of its components are not recognized." ...@@ -487,7 +488,8 @@ or if it is a PATHNAME but some of its components are not recognized."
((or null string) pathname) ((or null string) pathname)
(pathname (pathname
(with-output-to-string (s) (with-output-to-string (s)
(flet ((err () #+lispworks (describe pathname) (error "Not a valid unix-namestring ~S" pathname))) (flet ((err () (parameter-error "~S: invalid unix-namestring ~S"
'unix-namestring pathname)))
(let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
(name (pathname-name pathname)) (name (pathname-name pathname))
(name (and (not (eq name :unspecific)) name)) (name (and (not (eq name :unspecific)) name))
...@@ -721,7 +723,7 @@ In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZ ...@@ -721,7 +723,7 @@ In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZ
((eq destination t) ((eq destination t)
path) path)
((not (pathnamep destination)) ((not (pathnamep destination))
(error "Invalid destination")) (parameter-error "~S: Invalid destination" 'translate-pathname*))
((not (absolute-pathname-p destination)) ((not (absolute-pathname-p destination))
(translate-pathname path absolute-source (merge-pathnames* destination root))) (translate-pathname path absolute-source (merge-pathnames* destination root)))
(root (root
......
...@@ -117,7 +117,7 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -117,7 +117,7 @@ Programmers are encouraged to define their own methods for this generic function
stream x stream x
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
(t (t
(error "Invalid ~S destination ~S" 'slurp-input-stream x))))) (parameter-error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
;;;; Vomiting a stream, typically into the input of another program. ;;;; Vomiting a stream, typically into the input of another program.
(with-upgradability () (with-upgradability ()
...@@ -194,7 +194,7 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -194,7 +194,7 @@ Programmers are encouraged to define their own methods for this generic function
x stream x stream
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
(t (t
(error "Invalid ~S source ~S" 'vomit-output-stream x))))) (parameter-error "Invalid ~S source ~S" 'vomit-output-stream x)))))
;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output. ;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output.
...@@ -250,8 +250,8 @@ or whether it's already taken care of by the implementation's underlying run-pro ...@@ -250,8 +250,8 @@ or whether it's already taken care of by the implementation's underlying run-pro
(activity-spec (if (eq actual-spec :output) (activity-spec (if (eq actual-spec :output)
(ecase direction (ecase direction
((:input :output) ((:input :output)
(error "~S not allowed as a ~S ~S spec" (parameter-error "~S does not allow ~S as a ~S spec"
:output 'run-program direction)) 'run-program :output direction))
((:error-output) ((:error-output)
nil)) nil))
actual-spec))) actual-spec)))
......
...@@ -611,7 +611,8 @@ or a string describing the format-control of a simple-condition." ...@@ -611,7 +611,8 @@ or a string describing the format-control of a simple-condition."
(format-control :initarg :format-control) (format-control :initarg :format-control)
(format-arguments :initarg :format-arguments)) (format-arguments :initarg :format-arguments))
(:report (lambda (condition stream) (:report (lambda (condition stream)
(format stream "Not implemented: ~s~@[ ~?~]" (format stream "Not (currently) implemented on ~A: ~S~@[ ~?~]"
(nth-value 1 (symbol-call :uiop :implementation-type))
(slot-value condition 'functionality) (slot-value condition 'functionality)
(slot-value condition 'format-control) (slot-value condition 'format-control)
(slot-value condition 'format-arguments))))) (slot-value condition 'format-arguments)))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment