From 38eb8a7cebe9299f1969a3e84b1b4d7369151384 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Sat, 28 Mar 2015 14:22:26 -0400 Subject: [PATCH] Introduce macro os-cond On ABCL, os testing is at runtime. On all other implementations, it's at compile-time. SBCL can optimize some runtime tests and then complain about unreachable code. os-cond abstracts over OS conditionalization and makes everyone happy. Needed by an upcoming configuration change. Plus minor typographical fixes. --- bundle.lisp | 8 ++++---- uiop/os.lisp | 16 ++++++++++------ uiop/pathname.lisp | 6 +++--- uiop/run-program.lisp | 2 +- uiop/stream.lisp | 10 +++++----- 5 files changed, 23 insertions(+), 19 deletions(-) diff --git a/bundle.lisp b/bundle.lisp index 72f4a6ef..b6d40eda 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -160,10 +160,10 @@ itself.")) ;; operation on a system and its dependencies ((member :dll :lib :shared-library :static-library :program :object :program) (compile-file-type :type bundle-type)) ((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"))))) + ((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"))))) (defun bundle-output-files (o c) (let ((bundle-type (bundle-type o))) diff --git a/uiop/os.lisp b/uiop/os.lisp index 1c5a9d92..173f61cf 100644 --- a/uiop/os.lisp +++ b/uiop/os.lisp @@ -7,6 +7,7 @@ (: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 + #:os-cond #:getenv #:getenvp ;; environment variables #:implementation-identifier ;; implementation identifier #:implementation-type #:*implementation-type* @@ -73,6 +74,10 @@ except on ABCL where it might change between FASL compilation and runtime." (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."))))) + (defmacro os-cond (&rest clauses) + #+abcl `(cond ,@clauses) + #-abcl (loop* :for (test . body) :in clauses :when (eval test) :return `(progn ,@body))) + (detect-os)) ;;;; Environment variables: getting them, and parsing them. @@ -109,20 +114,19 @@ use getenvp to return NIL in such a case." #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv)) - - (defsetf getenv (x) (val) + (defsetf getenv (x) (val) "Set an environment variable." (declare (ignorable x val)) - #+clisp `(system::setenv ,x ,val) - #+ecl `(ext:setenv ,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 ecl lispworks mkcl sbcl cmu) - '(error "SETF ~S is not supported on your implementation" 'getenv)) + #-(or allegro clisp clozure cmu ecl lispworks mkcl sbcl) + '(error "~S ~S is not supported on your implementation" 'setf 'getenv)) (defun getenvp (x) "Predicate that is true if the named variable is present in the libc environment, diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp index 19cbf132..74177b8e 100644 --- a/uiop/pathname.lisp +++ b/uiop/pathname.lisp @@ -404,9 +404,9 @@ For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned." "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. +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. This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF. When given a PATHNAME object, just return it untouched. diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp index 1e43cd0c..7fdaf817 100644 --- a/uiop/run-program.lisp +++ b/uiop/run-program.lisp @@ -104,7 +104,7 @@ for use within a POSIX Bourne shell, outputing to S." (defun escape-shell-token (token &optional s) "Escape a token for the current operating system shell" - (cond + (os-cond ((os-unix-p) (escape-sh-token token s)) ((os-windows-p) (escape-windows-token token s)))) diff --git a/uiop/stream.lisp b/uiop/stream.lisp index 9a6ceef2..6c184014 100644 --- a/uiop/stream.lisp +++ b/uiop/stream.lisp @@ -277,7 +277,7 @@ and return that" (defun null-device-pathname () "Pathname to a bit bucket device that discards any information written to it and always returns EOF when read from" - (cond + (os-cond ((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")))) @@ -528,13 +528,13 @@ If a string, repeatedly read and evaluate from it, returning the last values." (with-upgradability () (defun default-temporary-directory () "Return a default directory to use for temporary files" - (or - (when (os-unix-p) + (os-cond + ((os-unix-p) (or (getenv-pathname "TMPDIR" :ensure-directory t) (parse-native-namestring "/tmp/"))) - (when (os-windows-p) + ((os-windows-p) (getenv-pathname "TEMP" :ensure-directory t)) - (subpathname (user-homedir-pathname) "tmp/"))) + (t (subpathname (user-homedir-pathname) "tmp/")))) (defvar *temporary-directory* nil "User-configurable location for temporary files") -- GitLab