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
asdf
asdf
Commits
56589b52
Commit
56589b52
authored
Nov 30, 2009
by
Francois-Rene Rideau
Browse files
1.371: trivial shuffling around of code for better documentation value, doc typo fixes.
parent
60165185
Changes
1
Hide whitespace changes
Inline
Side-by-side
asdf.lisp
View file @
56589b52
...
...
@@ -158,6 +158,9 @@
(
in-package
#:asdf
)
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
;;;;
(
defvar
*asdf-revision*
;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
(
subseq
"REVISION:1.370"
(
1+
(
length
"REVISION"
))))
...
...
@@ -345,6 +348,20 @@ and NIL NAME and TYPE components"
(
declare
(
dynamic-extent
format-args
))
(
apply
#'
format
*verbose-out*
format-string
format-args
))
;;; with apologies to christophe rhodes ...
(
defun
split
(
string
&optional
max
(
ws
'
(
#\Space
#\Tab
)))
(
flet
((
is-ws
(
char
)
(
find
char
ws
)))
(
nreverse
(
let
((
list
nil
)
(
start
0
)
(
words
0
)
end
)
(
loop
(
when
(
and
max
(
>=
words
(
1-
max
)))
(
return
(
cons
(
subseq
string
start
)
list
)))
(
setf
end
(
position-if
#'
is-ws
string
:start
start
))
(
push
(
subseq
string
start
end
)
list
)
(
incf
words
)
(
unless
end
(
return
list
))
(
setf
start
(
1+
end
)))))))
(
defun
split-path-string
(
s
&optional
force-directory
)
(
check-type
s
string
)
(
let*
((
components
(
split
s
nil
"/"
))
...
...
@@ -361,8 +378,30 @@ and NIL NAME and TYPE components"
(
t
(
values
relative
(
butlast
components
)
last-comp
))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax
(
defun
remove-keys
(
key-names
args
)
(
loop
for
(
name
val
)
on
args
by
#'
cddr
unless
(
member
(
symbol-name
name
)
key-names
:key
#'
symbol-name
:test
'equal
)
append
(
list
name
val
)))
(
defun
remove-keyword
(
key
arglist
)
(
labels
((
aux
(
key
arglist
)
(
cond
((
null
arglist
)
nil
)
((
eq
key
(
car
arglist
))
(
cddr
arglist
))
(
t
(
cons
(
car
arglist
)
(
cons
(
cadr
arglist
)
(
remove-keyword
key
(
cddr
arglist
))))))))
(
aux
key
arglist
)))
(
defun
resolve-symlinks
(
path
)
#-
allegro
(
truename
path
)
#+
allegro
(
excl:pathname-resolve-symbolic-links
path
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; classes, condi
i
tons
;; classes, condit
i
ons
(
define-condition
system-definition-error
(
error
)
()
;; [this use of :report should be redundant, but unfortunately it's not.
...
...
@@ -520,20 +559,6 @@ and NIL NAME and TYPE components"
;;; version-satisfies
;;; with apologies to christophe rhodes ...
(
defun
split
(
string
&optional
max
(
ws
'
(
#\Space
#\Tab
)))
(
flet
((
is-ws
(
char
)
(
find
char
ws
)))
(
nreverse
(
let
((
list
nil
)
(
start
0
)
(
words
0
)
end
)
(
loop
(
when
(
and
max
(
>=
words
(
1-
max
)))
(
return
(
cons
(
subseq
string
start
)
list
)))
(
setf
end
(
position-if
#'
is-ws
string
:start
start
))
(
push
(
subseq
string
start
end
)
list
)
(
incf
words
)
(
unless
end
(
return
list
))
(
setf
start
(
1+
end
)))))))
(
defmethod
version-satisfies
((
c
component
)
version
)
(
unless
(
and
version
(
slot-boundp
c
'version
))
(
return-from
version-satisfies
t
))
...
...
@@ -1324,23 +1349,6 @@ created with the same initargs as the original one.
(
declare
(
ignore
force
verbose
version
))
(
apply
#'
operate
'test-op
system
args
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax
(
defun
remove-keyword
(
key
arglist
)
(
labels
((
aux
(
key
arglist
)
(
cond
((
null
arglist
)
nil
)
((
eq
key
(
car
arglist
))
(
cddr
arglist
))
(
t
(
cons
(
car
arglist
)
(
cons
(
cadr
arglist
)
(
remove-keyword
key
(
cddr
arglist
))))))))
(
aux
key
arglist
)))
(
defun
resolve-symlinks
(
path
)
#-
allegro
(
truename
path
)
#+
allegro
(
excl:pathname-resolve-symbolic-links
path
)
)
(
defun
determine-system-pathname
(
pathname
pathname-supplied-p
)
;; called from the defsystem macro.
;; the pathname of a system is either
...
...
@@ -1432,12 +1440,6 @@ Returns the new tree (which probably shares structure with the old one)"
new-tree
))
(
defun
remove-keys
(
key-names
args
)
(
loop
for
(
name
val
)
on
args
by
#'
cddr
unless
(
member
(
symbol-name
name
)
key-names
:key
#'
symbol-name
:test
'equal
)
append
(
list
name
val
)))
(
defvar
*serial-depends-on*
)
(
defun
sysdef-error-component
(
msg
type
name
value
)
...
...
@@ -1569,11 +1571,14 @@ Returns the new tree (which probably shares structure with the old one)"
ret
)))
;;; optional extras
;;; run-shell-command functions for other lisp implementations will be
;;; gratefully accepted, if they do the same thing. If the docstring
;;; is ambiguous, send a bug report
;;;; ---------------------------------------------------------------------------
;;;; run-shell-command
;;;;
;;;; run-shell-command functions for other lisp implementations will be
;;;; gratefully accepted, if they do the same thing.
;;;; If the docstring is ambiguous, send a bug report
;;;;
;;;; XXX fare: This probably doesn't belong here. Does anyone rely on it?
(
defun
run-shell-command
(
control-string
&rest
args
)
"Interpolate `args` into `control-string` as if by `format`, and
...
...
@@ -1631,6 +1636,9 @@ output to `*verbose-out*`. Returns the shell's exit code."
(
error
"RUN-SHELL-PROGRAM not implemented for this Lisp"
)
))
;;;; ---------------------------------------------------------------------------
;;;; system-relative-pathname
(
defmethod
system-source-file
((
system-name
t
))
(
system-source-file
(
find-system
system-name
)))
...
...
@@ -1640,14 +1648,13 @@ output to `*verbose-out*`. Returns the shell's exit code."
:defaults
(
system-source-file
system-name
)))
(
defun
system-relative-pathname
(
system
pathname
&key
name
type
)
;; you're not allowed to muck with the return value of pathname-X
(
let
((
directory
(
copy-list
(
pathname-directory
pathname
))))
(
when
(
eq
(
car
directory
)
:absolute
)
(
setf
(
car
directory
)
:relative
))
(
let
((
directory
(
pathname-directory
pathname
)))
(
merge-pathnames
(
make-pathname
:name
(
or
name
(
pathname-name
pathname
))
:type
(
or
type
(
pathname-type
pathname
))
:directory
directory
)
:directory
(
if
(
eq
(
car
directory
)
:absolute
)
(
cons
:relative
(
cdr
directory
))
directory
))
(
system-source-directory
system
))))
;;; ---------------------------------------------------------------------------
...
...
@@ -1965,8 +1972,6 @@ applied by the plain `*source-to-target-mappings*`."
(
end-of-file
()
nil
))))
(
pushnew
:asdf
*features*
)
;;;; -----------------------------------------------------------------
;;;; SBCL hook into REQUIRE
;;;;
...
...
@@ -2032,6 +2037,8 @@ applied by the plain `*source-to-target-mappings*`."
(
when
*load-verbose*
(
asdf-message
";; ASDF, revision ~a"
*asdf-revision*
))
(
pushnew
:asdf
*features*
)
(
provide
:asdf
)
;;;; The End.
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