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

Merge branch 'getenv-pathnames-nil'

parents 11a8348e 0e04498e
......@@ -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
also \"Configuration DSL\"\) in the ASDF manual."
(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-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
(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:
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")
(or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIRS"))
(os-cond
((os-windows-p) (xdg-data-dirs "config/"))
(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
;; logical pathnames have restrictions on wild patterns.
;; Not that the results are very portable when you use these patterns on physical pathnames.
(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)
(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))))
(let* ((pat (merge-pathnames* pattern dir))
(entries (ignore-errors (directory* pat))))
......@@ -524,7 +525,7 @@ check constraints and normalize 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."
(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)
:on-error (or on-error
`(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."
(cond
((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"
(parameter-error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
'delete-directory-tree directory-pathname))
((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))
((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))
((not (directory-exists-p directory-pathname))
(ecase if-does-not-exist
......
......@@ -78,7 +78,7 @@ This is designed to abstract away the implementation specific quit forms."
(exit `(,exit :code code :abort (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)
(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)
"Die in error with some error message"
......@@ -352,7 +352,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
(setf *image-restored-p* nil)
#-(or clisp clozure (and cmucl executable) lispworks sbcl scl)
(when executable
(error "Dumping an executable is not supported on this implementation! Aborting."))
(not-implemented-error 'dump-image "dumping an executable"))
#+allegro
(progn
(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."
;; the default is :console - only works with SBCL 1.1.15 or later.
(when application-type (list :application-type application-type)))))
#-(or allegro clisp clozure cmucl gcl lispworks sbcl scl)
(error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
'dump-image filename (nth-value 1 (implementation-type))))
(not-implemented-error 'dump-image))
(defun create-image (destination lisp-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."
(some
(cond
((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)
(complement good-chars))
((typep bad-chars 'function)
......@@ -35,7 +36,7 @@ as either a recognizing function or a sequence of characters."
#'(lambda (c) (not (find c good-chars))))
((and bad-chars (typep bad-chars 'sequence))
#'(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))
(defun escape-token (token &key stream quote good-chars bad-chars escaper)
......
......@@ -771,8 +771,7 @@ it will filter them appropriately."
(defun combine-fasls (inputs output)
"Combine a list of FASLs INPUTS into a single FASL OUTPUT"
#-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl)
(error "~A does not support ~S~%inputs ~S~%output ~S"
(implementation-type) 'combine-fasls inputs output)
(not-implemented-error 'combine-fasls "~%inputs: ~S~%output: ~S" inputs output)
#+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
#+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output)
#+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
......
......@@ -29,7 +29,7 @@ keywords explicitly."
((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
((eq :or (car x)) (some #'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.
;; 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."
#+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
#+sbcl (sb-ext:posix-getenv x)
#-(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)
"Set an environment variable."
......@@ -126,7 +126,7 @@ use getenvp to return NIL in such a case."
#+mkcl `(mkcl:setenv ,x ,val)
#+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
#-(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)
"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
#+mkcl (mk-ext:getcwd)
#+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
#+xcl (extensions:current-directory)
(error "getcwd not supported on your implementation")))
(not-implemented-error 'getcwd)))
(defun chdir (x)
"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
#+mkcl (mk-ext:chdir 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)
(error "chdir not supported on your implementation"))))
(not-implemented-error 'chdir))))
;;;; -----------------------------------------------------------------
......
......@@ -56,7 +56,8 @@ that is a list and not a string."
((consp directory)
(cons :relative directory))
(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)
"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."
((or null string) pathname)
(pathname
(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)))
(name (pathname-name pathname))
(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
((eq destination t)
path)
((not (pathnamep destination))
(error "Invalid destination"))
(parameter-error "~S: Invalid destination" 'translate-pathname*))
((not (absolute-pathname-p destination))
(translate-pathname path absolute-source (merge-pathnames* destination root)))
(root
......
......@@ -117,7 +117,7 @@ Programmers are encouraged to define their own methods for this generic function
stream x
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
(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.
(with-upgradability ()
......@@ -194,7 +194,7 @@ Programmers are encouraged to define their own methods for this generic function
x stream
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
(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.
......@@ -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)
(ecase direction
((:input :output)
(error "~S not allowed as a ~S ~S spec"
:output 'run-program direction))
(parameter-error "~S does not allow ~S as a ~S spec"
'run-program :output direction))
((:error-output)
nil))
actual-spec)))
......
......@@ -611,7 +611,8 @@ or a string describing the format-control of a simple-condition."
(format-control :initarg :format-control)
(format-arguments :initarg :format-arguments))
(: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 'format-control)
(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