Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Jan Moringen
asdf
Commits
580e8d1e
Commit
580e8d1e
authored
Mar 01, 2014
by
Francois-Rene Rideau
Browse files
More fixes to issues found with LispWorks.
parent
30b84e80
Changes
3
Hide whitespace changes
Inline
Side-by-side
bin/install-asdf-as-module
View file @
580e8d1e
...
...
@@ -57,8 +57,7 @@ It notably doesn't work on:
(defun install-asdf-as-module ()
(let ((fasl (asdf-module-fasl)))
(ensure-directories-exist (translate-logical-pathname fasl))
(handler-bind ((warning #'muffle-warning))
(compile-file* (subpathname *asdf-dir* "build/asdf.lisp") :output-file fasl))))
(compile-file (subpathname *asdf-dir* "build/asdf.lisp") :output-file fasl)))
(trace compile-file*)
(install-asdf-as-module)
uiop/image.lisp
View file @
580e8d1e
...
...
@@ -242,6 +242,7 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die"
"Extract user arguments from command-line invocation of current process.
Assume the calling conventions of a generated script that uses --
if we are not called from a directly executable image."
(
declare
(
ignorable
arguments
))
#+
abcl
arguments
;; LispWorks command-line processing isn't transparent to the user, and
;; we need to rely on cl-launch or some other script to set it for us.
...
...
uiop/pathname.lisp
View file @
580e8d1e
...
...
@@ -544,6 +544,25 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
;; scheme-specific parts: port username password, not others:
.
#.
(
or
#+
scl
'
(
:parameters
nil
:query
nil
:fragment
nil
))))
(
defun
ensure-absolute-pathname
(
path
&optional
defaults
(
on-error
'error
))
"Given a pathname designator PATH, return an absolute pathname as specified by PATH
considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,
with a format control-string and other arguments as arguments"
(
cond
((
absolute-pathname-p
path
))
((
stringp
path
)
(
ensure-absolute-pathname
(
pathname
path
)
defaults
on-error
))
((
not
(
pathnamep
path
))
(
call-function
on-error
"not a valid pathname designator ~S"
path
))
((
let
((
default-pathname
(
if
(
pathnamep
defaults
)
defaults
(
call-function
defaults
))))
(
or
(
if
(
absolute-pathname-p
default-pathname
)
(
absolute-pathname-p
(
merge-pathnames*
path
default-pathname
))
(
call-function
on-error
"Default pathname ~S is not an absolute pathname"
default-pathname
))
(
call-function
on-error
"Failed to merge ~S with ~S into an absolute pathname"
path
default-pathname
))))
(
t
(
call-function
on-error
"Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
path
defaults
))))
(
defun
subpathp
(
maybe-subpath
base-pathname
)
"if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
...
...
@@ -558,11 +577,9 @@ when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPA
(
defun
enough-pathname
(
maybe-subpath
base-pathname
)
"if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
(
check-type
maybe-subpath
(
or
null
pathname
))
(
check-type
base-pathname
(
or
null
pathname
))
(
when
(
pathnamep
base-pathname
)
(
assert
(
absolute-pathname-p
base-pathname
)))
(
or
(
and
base-pathname
(
subpathp
maybe-subpath
base-pathname
))
maybe-subpath
))
(
let
((
sub
(
when
maybe-subpath
(
pathname
maybe-subpath
)))
(
base
(
when
base-pathname
(
ensure-absolute-pathname
(
pathname
base-pathname
)))))
(
or
(
and
base
(
subpathp
sub
base
))
sub
)))
(
defun
call-with-enough-pathname
(
maybe-subpath
defaults-pathname
thunk
)
"In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null,
...
...
@@ -576,26 +593,7 @@ given DEFAULTS-PATHNAME as a base pathname."
(
defaults
*default-pathname-defaults*
))
&body
body
)
"Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME"
`
(
call-with-enough-pathname
,
pathname
,
defaults
#'
(
lambda
(
,
pathname-var
)
,@
body
)))
(
defun
ensure-absolute-pathname
(
path
&optional
defaults
(
on-error
'error
))
"Given a pathname designator PATH, return an absolute pathname as specified by PATH
considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,
with a format control-string and other arguments as arguments"
(
cond
((
absolute-pathname-p
path
))
((
stringp
path
)
(
ensure-absolute-pathname
(
pathname
path
)
defaults
on-error
))
((
not
(
pathnamep
path
))
(
call-function
on-error
"not a valid pathname designator ~S"
path
))
((
let
((
default-pathname
(
if
(
pathnamep
defaults
)
defaults
(
call-function
defaults
))))
(
or
(
if
(
absolute-pathname-p
default-pathname
)
(
absolute-pathname-p
(
merge-pathnames*
path
default-pathname
))
(
call-function
on-error
"Default pathname ~S is not an absolute pathname"
default-pathname
))
(
call-function
on-error
"Failed to merge ~S with ~S into an absolute pathname"
path
default-pathname
))))
(
t
(
call-function
on-error
"Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
path
defaults
)))))
`
(
call-with-enough-pathname
,
pathname
,
defaults
#'
(
lambda
(
,
pathname-var
)
,@
body
))))
;;; Wildcard pathnames
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment