Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
asdf
asdf
Commits
234a14fc
Commit
234a14fc
authored
Oct 09, 2013
by
Francois-Rene Rideau
Browse files
More docstrings for UIOP.
parent
b4dc78de
Changes
7
Hide whitespace changes
Inline
Side-by-side
uiop/configuration.lisp
View file @
234a14fc
...
...
@@ -32,8 +32,10 @@
(
condition-arguments
c
))))))
(
defun
get-folder-path
(
folder
)
(
or
;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
#+
(
and
lispworks
mswindows
)
(
sys: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."
(
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"
))
...
...
@@ -42,6 +44,7 @@
(
subpathname*
(
getenv-absolute-directory
"ALLUSERSPROFILE"
)
"Application Data/"
))))))
(
defun
user-configuration-directories
()
"Determine user configuration directories"
(
let
((
dirs
`
(
,@
(
when
(
os-unix-p
)
(
cons
...
...
@@ -56,6 +59,7 @@
:from-end
t
:test
'equal
)))
(
defun
system-configuration-directories
()
"Determine system user configuration directories"
(
cond
((
os-unix-p
)
'
(
#p"/etc/common-lisp/"
))
((
os-windows-p
)
...
...
@@ -63,23 +67,28 @@
(
list
it
)))))
(
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
(
merge-
pathname
s*
x
(
ensure-directory-pathname
dir
))))))
:thereis
(
and
dir
(
funcall
fun
(
sub
pathname
(
ensure-directory-pathname
dir
)
x
)))))
(
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
))
(
defun
configuration-inheritance-directive-p
(
x
)
"Is X a configuration inheritance directive?"
(
let
((
kw
'
(
:inherit-configuration
:ignore-inherited-configuration
)))
(
or
(
member
x
kw
)
(
and
(
length=n-p
x
1
)
(
member
(
car
x
)
kw
)))))
(
defun
report-invalid-form
(
reporter
&rest
args
)
"Report an invalid form according to REPORTER and various ARGS"
(
etypecase
reporter
(
null
(
apply
'error
'invalid-configuration
args
))
...
...
@@ -90,10 +99,12 @@
(
cons
(
apply
'apply
(
append
reporter
args
)))))
(
defvar
*ignored-configuration-form*
nil
)
(
defvar
*ignored-configuration-form*
nil
"Have configuration forms been ignored while parsing the configuration?"
)
(
defun
validate-configuration-form
(
form
tag
directive-validator
&key
location
invalid-form-reporter
)
"Validate a configuration FORM"
(
unless
(
and
(
consp
form
)
(
eq
(
car
form
)
tag
))
(
setf
*ignored-configuration-form*
t
)
(
report-invalid-form
invalid-form-reporter
:form
form
:location
location
)
...
...
@@ -122,6 +133,7 @@
(
return
(
nreverse
x
))))
(
defun
validate-configuration-file
(
file
validator
&key
description
)
"Validate a configuration file for conformance of its form with the validator function"
(
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~@:>~%"
)
...
...
@@ -154,6 +166,7 @@ values of TAG include :source-registry and :output-translations."
:inherit-configuration
)))
(
defun
resolve-relative-location
(
x
&key
ensure-directory
wilden
)
"Given a designator X for an relative location, resolve it to a pathname"
(
ensure-pathname
(
etypecase
x
(
pathname
x
)
...
...
@@ -192,6 +205,7 @@ directive.")
"A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache"
)
(
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
...
...
@@ -204,6 +218,7 @@ directive.")
(
register-image-restore-hook
'compute-user-cache
)
(
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
(
pathname
x
)
...
...
@@ -244,6 +259,7 @@ directive.")
(
:ensure-directory
boolean
))
t
)
resolve-location
))
(
defun*
(
resolve-location
)
(
x
&key
ensure-directory
wilden
directory
)
"Resolve location designator X into a PATHNAME"
;; :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
)
...
...
@@ -261,6 +277,7 @@ directive.")
:finally
(
return
path
)))
(
defun
location-designator-p
(
x
)
"Is X a designator for a location?"
(
flet
((
absolute-component-p
(
c
)
(
typep
c
'
(
or
string
pathname
(
member
:root
:home
:here
:user-cache
))))
...
...
@@ -272,6 +289,7 @@ directive.")
(
and
(
consp
x
)
(
absolute-component-p
(
first
x
))
(
every
#'
relative-component-p
(
rest
x
))))))
(
defun
location-function-p
(
x
)
"Is X the specification of a location function?"
(
and
(
length=n-p
x
2
)
(
eq
(
car
x
)
:function
)))
...
...
@@ -279,15 +297,17 @@ directive.")
(
defvar
*clear-configuration-hook*
'
())
(
defun
register-clear-configuration-hook
(
hook-function
&optional
call-now-p
)
"Register a function to be called when clearing configuration"
(
register-hook-function
'*clear-configuration-hook*
hook-function
call-now-p
))
(
defun
clear-configuration
()
"Call the functions in *CLEAR-CONFIGURATION-HOOK*"
(
call-functions
*clear-configuration-hook*
))
(
register-image-dump-hook
'clear-configuration
)
;; If a previous version of ASDF failed to read some configuration, try again.
(
defun
upgrade-configuration
()
"If a previous version of ASDF failed to read some configuration, try again now."
(
when
*ignored-configuration-form*
(
clear-configuration
)
(
setf
*ignored-configuration-form*
nil
))))
...
...
uiop/filesystem.lisp
View file @
234a14fc
...
...
@@ -157,6 +157,9 @@ Try to override the defaults to not resolving symlinks, if implementation allows
'
(
:resolve-symlinks
nil
))))))
(
defun
filter-logical-directory-results
(
directory
entries
merger
)
"Given ENTRIES in a DIRECTORY, remove if the directory is logical
the entries which are physical yet when transformed by MERGER have a different TRUENAME.
This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames."
(
if
(
logical-pathname-p
directory
)
;; Try hard to not resolve logical-pathname into physical pathnames;
;; otherwise logical-pathname users/lovers will be disappointed.
...
...
@@ -166,7 +169,7 @@ Try to override the defaults to not resolving symlinks, if implementation allows
;; translating the LPN commute.
(
loop
:for
f
:in
entries
:for
p
=
(
or
(
and
(
logical-pathname-p
f
)
f
)
(
let*
((
u
(
ignore-errors
(
fun
call
merger
f
))))
(
let*
((
u
(
ignore-errors
(
call
-function
merger
f
))))
;; The first u avoids a cumbersome (truename u) error.
;; At this point f should already be a truename,
;; but isn't quite in CLISP, for it doesn't have :version :newest
...
...
@@ -201,6 +204,7 @@ which is not very portable to override. Try not resolve symlinks if implementati
:version
(
make-pathname-component-logical
(
pathname-version
f
))))))))
(
defun
subdirectories
(
directory
)
"Given a DIRECTORY pathname designator, return a list of the subdirectories under it."
(
let*
((
directory
(
ensure-directory-pathname
directory
))
#-
(
or
abcl
cormanlisp
genera
xcl
)
(
wild
(
merge-pathnames*
...
...
@@ -238,6 +242,9 @@ which is not very portable to override. Try not resolve symlinks if implementati
:directory
(
append
prefix
(
make-pathname-component-logical
(
last
dir
)))))))))))
(
defun
collect-sub*directories
(
directory
collectp
recursep
collector
)
"Given a DIRECTORY, call-function the COLLECTOR function designator
on the directory if COLLECTP returns true when CALL-FUNCTION'ed with the directory,
and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them."
(
when
(
call-function
collectp
directory
)
(
call-function
collector
directory
))
(
dolist
(
subdir
(
subdirectories
directory
))
...
...
uiop/image.lisp
View file @
234a14fc
...
...
@@ -131,6 +131,7 @@ This is designed to abstract away the implementation specific quit forms."
stream
))
(
defun
print-backtrace
(
&rest
keys
&key
stream
count
)
"Print a backtrace"
(
declare
(
ignore
stream
count
))
(
with-safe-io-syntax
(
:package
:cl
)
(
let
((
*print-readably*
nil
)
...
...
@@ -142,6 +143,7 @@ This is designed to abstract away the implementation specific quit forms."
(
ignore-errors
(
apply
'raw-print-backtrace
keys
)))))
(
defun
print-condition-backtrace
(
condition
&key
(
stream
*stderr*
)
count
)
"Print a condition after a backtrace triggered by that condition"
;; We print the condition *after* the backtrace,
;; for the sake of who sees the backtrace at a terminal.
;; It is up to the caller to print the condition *before*, with some context.
...
...
@@ -151,10 +153,12 @@ This is designed to abstract away the implementation specific quit forms."
condition
)))
(
defun
fatal-condition-p
(
condition
)
"Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*"
(
match-any-condition-p
condition
*fatal-conditions*
))
(
defun
handle-fatal-condition
(
condition
)
"Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
"Handle a fatal CONDITION:
depending on whether *LISP-INTERACTION* is set, enter debugger or die"
(
cond
(
*lisp-interaction*
(
invoke-debugger
condition
))
...
...
@@ -164,10 +168,12 @@ This is designed to abstract away the implementation specific quit forms."
(
die
99
"~A"
condition
))))
(
defun
call-with-fatal-condition-handler
(
thunk
)
"Call THUNK in a context where fatal conditions are appropriately handled"
(
handler-bind
(((
satisfies
fatal-condition-p
)
#'
handle-fatal-condition
))
(
funcall
thunk
)))
(
defmacro
with-fatal-condition-handler
((
&optional
)
&body
body
)
"Execute BODY in a context where fatal conditions are appropriately handled"
`
(
call-with-fatal-condition-handler
#'
(
lambda
()
,@
body
)))
(
defun
shell-boolean-exit
(
x
)
...
...
@@ -178,15 +184,19 @@ This is designed to abstract away the implementation specific quit forms."
;;; Using image hooks
(
with-upgradability
()
(
defun
register-image-restore-hook
(
hook
&optional
(
call-now-p
t
))
"Regiter a hook function to be run when restoring a dumped image"
(
register-hook-function
'*image-restore-hook*
hook
call-now-p
))
(
defun
register-image-dump-hook
(
hook
&optional
(
call-now-p
nil
))
"Register a the hook function to be run before to dump an image"
(
register-hook-function
'*image-dump-hook*
hook
call-now-p
))
(
defun
call-image-restore-hook
()
"Call the hook functions registered to be run when restoring a dumped image"
(
call-functions
(
reverse
*image-restore-hook*
)))
(
defun
call-image-dump-hook
()
"Call the hook functions registered to be run before to dump an image"
(
call-functions
*image-dump-hook*
)))
...
...
@@ -230,6 +240,8 @@ if we are not called from a directly executable image."
((
:prelude
*image-prelude*
)
*image-prelude*
)
((
:entry-point
*image-entry-point*
)
*image-entry-point*
)
(
if-already-restored
'
(
cerror
"RUN RESTORE-IMAGE ANYWAY"
)))
"From a freshly restarted Lisp image, restore the saved Lisp environment
by setting appropriate variables, running various hooks, and calling any specified entry point."
(
when
*image-restored-p*
(
if
if-already-restored
(
call-function
if-already-restored
"Image already ~:[being ~;~]restored"
(
eq
*image-restored-p*
t
))
...
...
@@ -255,6 +267,7 @@ if we are not called from a directly executable image."
((
:postlude
*image-postlude*
)
*image-postlude*
)
((
:dump-hook
*image-dump-hook*
)
*image-dump-hook*
)
#+
clozure
prepend-symbols
#+
clozure
(
purify
t
))
"Dump an image of the current Lisp environment at pathname FILENAME, with various options"
(
declare
(
ignorable
filename
output-name
executable
))
(
setf
*image-dumped-p*
(
if
executable
:executable
t
))
(
setf
*image-restored-p*
:in-regress
)
...
...
@@ -321,6 +334,7 @@ if we are not called from a directly executable image."
(
entry-point
()
entry-point-p
)
build-args
)
(
declare
(
ignorable
destination
object-files
kind
output-name
prologue-code
epilogue-code
prelude
preludep
postlude
postludep
entry-point
entry-point-p
build-args
))
"On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
;; 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.
...
...
uiop/lisp-build.lisp
View file @
234a14fc
...
...
@@ -49,8 +49,10 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
;;; Optimization settings
(
with-upgradability
()
(
defvar
*optimization-settings*
nil
)
(
defvar
*previous-optimization-settings*
nil
)
(
defvar
*optimization-settings*
nil
"Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS"
)
(
defvar
*previous-optimization-settings*
nil
"Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS"
)
(
defun
get-optimization-settings
()
"Get current compiler optimization settings, ready to PROCLAIM again"
#-
(
or
clisp
clozure
cmu
ecl
sbcl
scl
)
...
...
@@ -79,6 +81,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
#+
sbcl
(
progn
(
defun
sb-grovel-unknown-constant-condition-p
(
c
)
"Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
(
and
(
typep
c
'sb-int:simple-style-warning
)
(
string-enclosed-p
"Couldn't grovel for "
...
...
@@ -124,16 +127,18 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
;;;; ----- Filtering conditions while building -----
(
with-upgradability
()
(
defun
call-with-muffled-compiler-conditions
(
thunk
)
"Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
(
call-with-muffled-conditions
thunk
(
append
*uninteresting-conditions*
*uninteresting-compiler-conditions*
)))
(
defmacro
with-muffled-compiler-conditions
((
&optional
)
&body
body
)
"
Run BODY where uninteresting compiler conditions are muffled
"
"
Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS
"
`
(
call-with-muffled-compiler-conditions
#'
(
lambda
()
,@
body
)))
(
defun
call-with-muffled-loader-conditions
(
thunk
)
"Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
(
call-with-muffled-conditions
thunk
(
append
*uninteresting-conditions*
*uninteresting-loader-conditions*
)))
(
defmacro
with-muffled-loader-conditions
((
&optional
)
&body
body
)
"
Run BODY where uninteresting compiler and additional loader conditions are muffled
"
"
Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS
"
`
(
call-with-muffled-loader-conditions
#'
(
lambda
()
,@
body
))))
...
...
@@ -159,6 +164,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(
defun
check-lisp-compile-warnings
(
warnings-p
failure-p
&optional
context-format
context-arguments
)
"Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
raise an error or warning as appropriate"
(
when
failure-p
(
case
*compile-file-failure-behaviour*
(
:warn
(
warn
'compile-failed-warning
...
...
@@ -184,6 +191,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(
defun
check-lisp-compile-results
(
output
warnings-p
failure-p
&optional
context-format
context-arguments
)
"Given the results of COMPILE-FILE, raise an error or warning as appropriate"
(
unless
output
(
error
'compile-file-error
:context-format
context-format
:context-arguments
context-arguments
))
(
check-lisp-compile-warnings
warnings-p
failure-p
context-format
context-arguments
)))
...
...
@@ -196,6 +204,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
;;; See their respective docstrings.
(
with-upgradability
()
(
defun
reify-simple-sexp
(
sexp
)
"Given a simple SEXP, return a representation of it as a portable SEXP.
Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
(
etypecase
sexp
(
symbol
(
reify-symbol
sexp
))
((
or
number
character
simple-string
pathname
)
sexp
)
...
...
@@ -203,6 +213,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(
simple-vector
(
vector
(
mapcar
'reify-simple-sexp
(
coerce
sexp
'list
))))))
(
defun
unreify-simple-sexp
(
sexp
)
"Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
(
etypecase
sexp
((
or
symbol
number
character
simple-string
pathname
)
sexp
)
(
cons
(
cons
(
unreify-simple-sexp
(
car
sexp
))
(
unreify-simple-sexp
(
cdr
sexp
))))
...
...
@@ -454,6 +465,8 @@ possibly in a different process."
(
terpri
s
))))
(
defun
warnings-file-type
(
&optional
implementation-type
)
"The pathname type for warnings files on given IMPLEMENTATION-TYPE,
where NIL designates the current one"
(
case
(
or
implementation-type
*implementation-type*
)
((
:acl
:allegro
)
"allegro-warnings"
)
;;((:clisp) "clisp-warnings")
...
...
@@ -463,21 +476,27 @@ possibly in a different process."
((
:scl
)
"scl-warnings"
)))
(
defvar
*warnings-file-type*
nil
"
T
ype for warnings files"
)
"
Pathname t
ype for warnings files
, or NIL if disabled
"
)
(
defun
enable-deferred-warnings-check
()
"Enable the saving of deferred warnings"
(
setf
*warnings-file-type*
(
warnings-file-type
)))
(
defun
disable-deferred-warnings-check
()
"Disable the saving of deferred warnings"
(
setf
*warnings-file-type*
nil
))
(
defun
warnings-file-p
(
file
&optional
implementation-type
)
"Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
(
if-let
(
type
(
if
implementation-type
(
warnings-file-type
implementation-type
)
*warnings-file-type*
))
(
equal
(
pathname-type
file
)
type
)))
(
defun
check-deferred-warnings
(
files
&optional
context-format
context-arguments
)
"Given a list of FILES in which deferred warnings were saved by CALL-WITH-DEFERRED-WARNINGS,
re-intern and raise any warnings that are still meaningful."
(
let
((
file-errors
nil
)
(
failure-p
nil
)
(
warnings-p
nil
))
...
...
@@ -518,6 +537,9 @@ possibly in a different process."
|#
(
defun
call-with-saved-deferred-warnings
(
thunk
warnings-file
)
"If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
and save those warnings to the given file for latter use,
possibly in a different process. Otherwise just call THUNK."
(
if
warnings-file
(
with-compilation-unit
(
:override
t
)
(
unwind-protect
...
...
@@ -529,21 +551,22 @@ possibly in a different process."
(
funcall
thunk
)))
(
defmacro
with-saved-deferred-warnings
((
warnings-file
)
&body
body
)
"If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY
and saves those warnings to the given file for latter use,
possibly in a different process. Otherwise just run the BODY."
"Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
`
(
call-with-saved-deferred-warnings
#'
(
lambda
()
,@
body
)
,
warnings-file
)))
;;; from ASDF
(
with-upgradability
()
(
defun
current-lisp-file-pathname
()
"Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
(
or
*compile-file-pathname*
*load-pathname*
))
(
defun
load-pathname
()
*load-pathname*
)
"Portably return the LOAD-PATHNAME of the current source file or fasl"
*load-pathname*
)
;; see magic for GCL in uiop/common-lisp
(
defun
lispize-pathname
(
input-file
)
"From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
(
make-pathname
:type
"lisp"
:defaults
input-file
))
(
defun
compile-file-type
(
&rest
keys
)
...
...
@@ -553,9 +576,11 @@ possibly in a different process. Otherwise just run the BODY."
#+
(
or
ecl
mkcl
)
(
pathname-type
(
apply
'compile-file-pathname
"foo"
keys
)))
(
defun
call-around-hook
(
hook
function
)
"Call a HOOK around the execution of FUNCTION"
(
call-function
(
or
hook
'funcall
)
function
))
(
defun
compile-file-pathname*
(
input-file
&rest
keys
&key
output-file
&allow-other-keys
)
"Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
(
let*
((
keys
(
remove-plist-keys
`
(
#+
(
and
allegro
(
not
(
version>=
8
2
)))
:external-format
,@
(
unless
output-file
'
(
:output-file
)))
keys
)))
...
...
@@ -664,6 +689,7 @@ it will filter them appropriately."
(
values
output-truename
warnings-p
failure-p
))))
(
defun
load*
(
x
&rest
keys
&key
&allow-other-keys
)
"Portable wrapper around LOAD that properly handles loading from a stream."
(
etypecase
x
((
or
pathname
string
#-
(
or
allegro
clozure
gcl2.6
genera
)
stream
)
(
apply
'load
x
...
...
@@ -686,6 +712,7 @@ it will filter them appropriately."
;;; Links FASLs together
(
with-upgradability
()
(
defun
combine-fasls
(
inputs
output
)
"Combine a list of FASLs INPUTS into a single FASL OUTPUT"
#-
(
or
abcl
allegro
clisp
clozure
cmu
lispworks
sbcl
scl
xcl
)
(
error
"~A does not support ~S~%inputs ~S~%output ~S"
(
implementation-type
)
'combine-fasls
inputs
output
)
...
...
uiop/os.lisp
View file @
234a14fc
...
...
@@ -33,25 +33,30 @@ keywords explicitly."
(
t
(
error
"Malformed feature specification ~S"
x
))))
(
defun
os-unix-p
()
"Is the underlying operating system some Unix variant?"
(
or
#+
abcl
(
featurep
:unix
)
#+
(
and
(
not
abcl
)
(
or
unix
cygwin
darwin
))
t
))
(
defun
os-macosx-p
()
;; OS-MACOSX is not mutually exclusive with OS-UNIX, in fact the
;;former implies the latter.
"Is the underlying operating system MacOS X?"
;; OS-MACOSX is not mutually exclusive with OS-UNIX,
;; in fact the former implies the latter.
(
or
#+
allegro
(
featurep
:macosx
)
#+
clisp
(
featurep
:macos
)
(
featurep
:darwin
)))
(
defun
os-windows-p
()
"Is the underlying operating system Microsoft Windows?"
(
or
#+
abcl
(
featurep
:windows
)
#+
(
and
(
not
(
or
abcl
unix
cygwin
darwin
))
(
or
win32
windows
mswindows
mingw32
))
t
))
(
defun
os-genera-p
()
"Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
(
or
#+
genera
t
))
(
defun
os-oldmac-p
()
"Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
(
or
#+
mcl
t
))
(
defun
detect-os
()
...
...
@@ -117,6 +122,7 @@ then returning the non-empty string value of the variable"
(
with-upgradability
()
(
defun
first-feature
(
feature-sets
)
"A helper for various feature detection functions"
(
dolist
(
x
feature-sets
)
(
multiple-value-bind
(
short
long
feature-expr
)
(
if
(
consp
x
)
...
...
@@ -126,15 +132,18 @@ then returning the non-empty string value of the variable"
(
return
(
values
short
long
))))))
(
defun
implementation-type
()
"The type of Lisp implementation used, as a short UIOP-standardized keyword"
(
first-feature
'
(
:abcl
(
:acl
:allegro
)
(
:ccl
:clozure
)
:clisp
(
:corman
:cormanlisp
)
(
:cmu
:cmucl
:cmu
)
:ecl
:gcl
(
:lwpe
:lispworks-personal-edition
)
(
:lw
:lispworks
)
:mcl
:mkcl
:sbcl
:scl
(
:smbx
:symbolics
)
:xcl
)))
(
defvar
*implementation-type*
(
implementation-type
))
(
defvar
*implementation-type*
(
implementation-type
)
"The type of Lisp implementation used, as a short UIOP-standardized keyword"
)
(
defun
operating-system
()
"The operating system of the current host"
(
first-feature
'
(
:cygwin
(
:win
:windows
:mswindows
:win32
:mingw32
)
;; try cygwin first!
(
:linux
:linux
:linux-target
)
;; for GCL at least, must appear before :bsd
...
...
@@ -143,6 +152,7 @@ then returning the non-empty string value of the variable"
:genera
)))
(
defun
architecture
()
"The CPU architecture of the current host"
(
first-feature
'
((
:x64
:x86-64
:x86_64
:x8664-target
:amd64
(
:and
:word-size=64
:pc386
))
(
:x86
:x86
:i386
:i486
:i586
:i686
:pentium3
:pentium4
:pc386
:iapx386
:x8632-target
)
...
...
@@ -163,6 +173,7 @@ then returning the non-empty string value of the variable"
(
error
"Can't determine fasl version."
)))
(
defun
lisp-version-string
()
"return a string that identifies the current Lisp implementation version"
(
let
((
s
(
lisp-implementation-version
)))
(
car
; as opposed to OR, this idiom prevents some unreachable code warning
(
list
...
...
@@ -213,6 +224,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
(
with-upgradability
()
(
defun
hostname
()
"return the hostname of the current host"
;; Note: untested on RMCL
#+
(
or
abcl
clozure
cmu
ecl
genera
lispworks
mcl
mkcl
sbcl
scl
xcl
)
(
machine-instance
)
#+
cormanlisp
"localhost"
;; is there a better way? Does it matter?
...
...
@@ -226,6 +238,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
#+
cmu
(
defun
parse-unix-namestring*
(
unix-namestring
)
"variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
(
multiple-value-bind
(
host
device
directory
name
type
version
)
(
lisp::parse-unix-namestring
unix-namestring
0
(
length
unix-namestring
))
(
make-pathname
:host
(
or
host
lisp::*unix-host*
)
:device
device
...
...
@@ -275,22 +288,27 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
#-
(
or
clisp
genera
)
; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera
.
#-
(
or
clisp
genera
)
; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera
that doesn't need it
(
with-upgradability
()
(
defparameter
*link-initial-dword*
76
)
(
defparameter
*link-guid*
#(
1
20
2
0
0
0
0
0
192
0
0
0
0
0
0
70
))
(
defun
read-null-terminated-string
(
s
)
"Read a null-terminated string from an octet stream S"
;; note: doesn't play well with UNICODE
(
with-output-to-string
(
out
)
(
loop
:for
code
=
(
read-byte
s
)
:until
(
zerop
code
)
:do
(
write-char
(
code-char
code
)
out
))))
(
defun
read-little-endian
(
s
&optional
(
bytes
4
))
"Read a number in little-endian format from an byte (octet) stream S,
the number having BYTES octets (defaulting to 4)."
(
loop
:for
i
:from
0
:below
bytes
:sum
(
ash
(
read-byte
s
)
(
*
8
i
))))
(
defun
parse-file-location-info
(
s
)
"helper to parse-windows-shortcut"
(
let
((
start
(
file-position
s
))
(
total-length
(
read-little-endian
s
))
(
end-of-header
(
read-little-endian
s
))
...
...
@@ -314,6 +332,8 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
(
read-null-terminated-string
s
))))))
(
defun
parse-windows-shortcut
(
pathname
)
"From a .lnk windows shortcut, extract the pathname linked to"
;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE.
(
with-open-file
(
s
pathname
:element-type
'
(
unsigned-byte
8
))
(
handler-case
(
when
(
and
(
=
(
read-little-endian
s
)
*link-initial-dword*
)
...
...
uiop/pathname.lisp
View file @
234a14fc
...
...
@@ -44,7 +44,9 @@
(
with-upgradability
()
(
defun
normalize-pathname-directory-component
(
directory
)
"Given a pathname directory component, return an equivalent form that is a list"
"Convert the DIRECTORY component from a format usable by the underlying
implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
that is a list and not a string."
#+
gcl2.6
(
setf
directory
(
substitute
:back
:parent
directory
))
(
cond
#-
(
or
cmu
sbcl
scl
)
;; these implementations already normalize directory components.
...
...
@@ -62,6 +64,8 @@
(
error
(
compatfmt
"~@<Unrecognized pathname directory component ~S~@:>"
)
directory
))))
(
defun
denormalize-pathname-directory-component
(
directory-component
)
"Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
by the underlying implementation's MAKE-PATHNAME and other primitives"
#-
gcl2.6
directory-component
#+
gcl2.6
(
let
((
d
(
substitute-if
:parent
(
lambda
(
x
)
(
member
x
'
(
:up
:back
)))
...
...
@@ -72,7 +76,7 @@
(
t
d
))))
(
defun
merge-pathname-directory-components
(
specified
defaults
)
;;
Helper for
merge-pathnames
* that handles directory components
.
"
Helper for
MERGE-PATHNAMES
* that handles directory components
"
(
let
((
directory
(
normalize-pathname-directory-component
specified
)))
(
ecase
(
first
directory
)
((
nil
)
defaults
)
...
...
@@ -99,7 +103,8 @@
;; This will be :unspecific if supported, or NIL if not.
(
defparameter
*unspecific-pathname-type*
#+
(
or
abcl
allegro
clozure
cmu
gcl
genera
lispworks
mkcl
sbcl
scl
xcl
)
:unspecific
#+
(
or
clisp
ecl
#|These haven't been tested:|#
cormanlisp
mcl
)
nil
)
#+
(
or
clisp
ecl
#|These haven't been tested:|#
cormanlisp
mcl
)
nil
"Unspecific type component to use with the underlying implementation's MAKE-PATHNAME"
)
(
defun
make-pathname*
(
&rest
keys
&key
(
directory
nil
#+
gcl2.6
directoryp
)
host
(
device
()
#+
allegro
devicep
)
name
type
version
defaults
...
...
@@ -140,11 +145,11 @@ and make a new pathname with corresponding components and specified logical HOST
if the SPECIFIED pathname does not have an absolute directory,
then the HOST and DEVICE both come from the DEFAULTS, whereas
if the SPECIFIED pathname does have an absolute directory,
then the HOST and DEVICE both come from the SPECIFIED.
then the HOST and DEVICE both come from the SPECIFIED
pathname
.
This is what users want on a modern Unix or Windows operating system,
unlike the MERGE-PATHNAME behavior.
unlike the MERGE-PATHNAME
S
behavior.
Also, if either argument is NIL, then the other argument is returned unmodified;
this is unlike MERGE-PATHNAME which always merges with a pathname,
this is unlike MERGE-PATHNAME
S
which always merges with a pathname,
by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
(
when
(
null
specified
)
(
return-from
merge-pathnames*
defaults
))
(
when
(
null
defaults
)
(
return-from
merge-pathnames*
specified
))
...
...
@@ -178,7 +183,7 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
(
defun
nil-pathname
(
&optional
(
defaults
*default-pathname-defaults*
))
"A pathname that is as neutral as possible for use as defaults
when merging, making or parsing pathnames"
when merging, making or parsing pathnames"
;; 19.2.2.2.1 says a NIL host can mean a default host;
;; see also "valid physical pathname host" in the CLHS glossary, that suggests
;; strings and lists of strings or :unspecific
...
...
@@ -192,15 +197,20 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
;; the default shouldn't matter, but we really want something physical
#-
mcl
,@'
(
:defaults
defaults
)))
(
defvar
*nil-pathname*
(
nil-pathname
(
translate-logical-pathname
(
user-homedir-pathname
))))
(
defvar
*nil-pathname*
(
nil-pathname
(
translate-logical-pathname
(
user-homedir-pathname
)))
"A pathname that is as neutral as possible for use as defaults