Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
A
asdf
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
15
Issues
15
List
Boards
Labels
Service Desk
Milestones
Merge Requests
9
Merge Requests
9
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
asdf
asdf
Commits
7f4d19be
Commit
7f4d19be
authored
Dec 18, 2009
by
Francois-Rene Rideau
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Release 1.373. Remove tabs in all lisp files.
parent
faa8b05b
Changes
36
Hide whitespace changes
Inline
Side-by-side
Showing
36 changed files
with
547 additions
and
547 deletions
+547
-547
asdf-ecl.lisp
asdf-ecl.lisp
+21
-21
asdf-install.lisp
asdf-install.lisp
+129
-129
asdf.lisp
asdf.lisp
+1
-1
asdf.texinfo
asdf.texinfo
+18
-18
bin/make-helper.lisp
bin/make-helper.lisp
+91
-91
cclan-package.lisp
cclan-package.lisp
+1
-1
cclan.asd
cclan.asd
+1
-1
cclan.lisp
cclan.lisp
+29
-29
test/compile-asdf.lisp
test/compile-asdf.lisp
+9
-9
test/dweinreb-tests.lisp
test/dweinreb-tests.lisp
+129
-129
test/graveyard/test6.script
test/graveyard/test6.script
+2
-2
test/graveyard/test7.script
test/graveyard/test7.script
+2
-2
test/in-progress.lisp
test/in-progress.lisp
+6
-6
test/script-support.lisp
test/script-support.lisp
+1
-1
test/test-module-pathnames.asd
test/test-module-pathnames.asd
+5
-5
test/test-module-pathnames.script
test/test-module-pathnames.script
+15
-15
test/test-modules-serial.asd
test/test-modules-serial.asd
+8
-8
test/test-modules.asd
test/test-modules.asd
+7
-7
test/test-nested-components-1.asd
test/test-nested-components-1.asd
+4
-4
test/test-nested-components.script
test/test-nested-components.script
+6
-6
test/test-retry-loading-component-1.script
test/test-retry-loading-component-1.script
+11
-11
test/test-touch-system-1.script
test/test-touch-system-1.script
+4
-4
test/test-touch-system-2.script
test/test-touch-system-2.script
+4
-4
test/test-try-recompiling-1.script
test/test-try-recompiling-1.script
+14
-14
test/test-version.script
test/test-version.script
+2
-2
test/test1.asd
test/test1.asd
+2
-2
test/test1.script
test/test1.script
+1
-1
test/test2.asd
test/test2.asd
+1
-1
test/test2.script
test/test2.script
+4
-4
test/test2a.asd
test/test2a.asd
+1
-1
test/test2b1.asd
test/test2b1.asd
+1
-1
test/test2b2.asd
test/test2b2.asd
+1
-1
test/test2b3.asd
test/test2b3.asd
+1
-1
test/test3.asd
test/test3.asd
+5
-5
test/test3.script
test/test3.script
+6
-6
test/test5.asd
test/test5.asd
+4
-4
No files found.
asdf-ecl.lisp
View file @
7f4d19be
...
...
@@ -33,7 +33,7 @@
;; Note how we use OUTPUT-FILES to find the binary locations
;; This allows the user to override the names.
(
let*
((
input
(
output-files
o
c
))
(
output
(
compile-file-pathname
(
first
input
)
:type
:fasl
)))
(
output
(
compile-file-pathname
(
first
input
)
:type
:fasl
)))
(
c:build-fasl
output
:lisp-files
(
remove
"fas"
input
:key
#'
pathname-type
:test
#'
string=
))))
(
defmethod
perform
((
o
load-op
)
(
c
cl-source-file
))
...
...
@@ -83,11 +83,11 @@
((
type
:initform
:program
)))
(
defmethod
initialize-instance
:after
((
instance
bundle-op
)
&rest
initargs
&key
(
name-suffix
nil
name-suffix-p
)
&allow-other-keys
)
&key
(
name-suffix
nil
name-suffix-p
)
&allow-other-keys
)
(
unless
name-suffix-p
(
setf
(
slot-value
instance
'name-suffix
)
(
if
(
bundle-op-monolithic-p
instance
)
"-mono"
""
)))
(
if
(
bundle-op-monolithic-p
instance
)
"-mono"
""
)))
(
when
(
typep
instance
'monolithic-bundle-op
)
(
destructuring-bind
(
&rest
original-initargs
&key
prologue-code
epilogue-code
&allow-other-keys
)
...
...
@@ -97,8 +97,8 @@
(
monolithic-op-prologue-code
instance
)
prologue-code
(
monolithic-op-epilogue-code
instance
)
epilogue-code
)))
(
setf
(
bundle-op-build-args
instance
)
(
remove-keys
'
(
type
monolithic
name-suffix
)
(
slot-value
instance
'original-initargs
))))
(
remove-keys
'
(
type
monolithic
name-suffix
)
(
slot-value
instance
'original-initargs
))))
(
defvar
*force-load-p*
nil
)
...
...
@@ -114,12 +114,12 @@
(
tree
(
traverse
(
make-instance
'load-op
)
system
)))
(
append
(
loop
for
(
op
.
component
)
in
tree
when
(
and
(
typep
op
'load-op
)
(
typep
component
filter-type
)
(
or
(
not
filter-system
)
(
eq
(
component-system
component
)
filter-system
)))
collect
(
progn
(
when
(
eq
component
system
)
(
setf
include-self
nil
))
(
cons
operation
component
)))
when
(
and
(
typep
op
'load-op
)
(
typep
component
filter-type
)
(
or
(
not
filter-system
)
(
eq
(
component-system
component
)
filter-system
)))
collect
(
progn
(
when
(
eq
component
system
)
(
setf
include-self
nil
))
(
cons
operation
component
)))
(
and
include-self
(
list
(
cons
operation
system
))))))
;;;
...
...
@@ -150,8 +150,8 @@
;;;
(
defmethod
bundle-sub-operations
((
o
lib-op
)
c
)
(
gather-components
'compile-op
c
:filter-system
(
and
(
not
(
bundle-op-monolithic-p
o
))
c
)
:filter-type
'
(
not
system
)))
:filter-system
(
and
(
not
(
bundle-op-monolithic-p
o
))
c
)
:filter-type
'
(
not
system
)))
;;;
;;; SHARED LIBRARIES
;;;
...
...
@@ -173,7 +173,7 @@
(
loop
for
(
op
.
dep
)
in
(
bundle-sub-operations
o
c
)
when
(
typep
dep
'system
)
collect
(
list
(
class-name
(
class-of
op
))
(
component-name
dep
))))
(
component-name
dep
))))
(
defmethod
component-depends-on
((
o
lib-op
)
(
c
system
))
(
list
(
list
'compile-op
(
component-name
c
))))
...
...
@@ -187,9 +187,9 @@
(
defmethod
output-files
((
o
bundle-op
)
(
c
system
))
(
let
((
name
(
concatenate
'base-string
(
component-name
c
)
(
slot-value
o
'name-suffix
))))
(
slot-value
o
'name-suffix
))))
(
list
(
merge-pathnames
(
compile-file-pathname
name
:type
(
bundle-op-type
o
))
(
component-relative-pathname
c
)))))
(
component-relative-pathname
c
)))))
(
defmethod
output-files
((
o
fasl-op
)
(
c
system
))
(
loop
for
file
in
(
call-next-method
)
...
...
@@ -203,10 +203,10 @@
(
defmethod
perform
((
o
bundle-op
)
(
c
system
))
(
let*
((
object-files
(
remove
"fas"
(
input-files
o
c
)
:key
#'
pathname-type
:test
#'
string=
))
(
output
(
output-files
o
c
)))
(
output
(
output-files
o
c
)))
(
ensure-directories-exist
(
first
output
))
(
apply
#'
c::builder
(
bundle-op-type
o
)
(
first
output
)
:lisp-files
object-files
(
append
(
bundle-op-build-args
o
)
(
append
(
bundle-op-build-args
o
)
(
when
(
and
(
typep
o
'monolithic-bundle-op
)
(
monolithic-op-prologue-code
o
))
`
(
:prologue-code
,
(
monolithic-op-prologue-code
o
)))
...
...
@@ -229,8 +229,8 @@
(
defun
make-build
(
system
&rest
args
&key
(
monolithic
nil
)
(
type
:fasl
)
&allow-other-keys
)
(
apply
#'
operate
(
select-operation
monolithic
type
)
system
(
remove-keys
'
(
monolithic
type
)
args
)))
system
(
remove-keys
'
(
monolithic
type
)
args
)))
;;;
;;; LOAD-FASL-OP
...
...
asdf-install.lisp
View file @
7f4d19be
...
...
@@ -40,7 +40,7 @@ an immediate concern
(
defpackage
:asdf-install
(
:use
"CL"
"SB-EXT"
"SB-BSD-SOCKETS"
)
(
:export
#:*proxy*
#:*cclan-mirror*
#:*sbcl-home*
#:*verify-gpg-signatures*
#:*locations*
))
#:*verify-gpg-signatures*
#:*locations*
))
(
defpackage
:asdf-install-customize
(
:use
"CL"
"SB-EXT"
"SB-BSD-SOCKETS"
"ASDF-INSTALL"
))
...
...
@@ -57,16 +57,16 @@ an immediate concern
;; want a directory
(
let
((
path
(
pathname
name
)))
(
if
(
pathname-name
path
)
(
merge-pathnames
(
make-pathname
:directory
`
(
:relative
,
(
pathname-name
path
))
:name
""
)
path
)
path
)))
(
merge-pathnames
(
make-pathname
:directory
`
(
:relative
,
(
pathname-name
path
))
:name
""
)
path
)
path
)))
(
defvar
*sbcl-home*
(
directorify
(
posix-getenv
"SBCL_HOME"
)))
(
defvar
*dot-sbcl*
(
merge-pathnames
(
make-pathname
:directory
'
(
:relative
".sbcl"
))
(
user-homedir-pathname
)))
(
user-homedir-pathname
)))
(
defvar
*verify-gpg-signatures*
t
)
...
...
@@ -80,28 +80,28 @@ an immediate concern
(
let*
((
*package*
(
find-package
:asdf-install-customize
))
(
file
(
probe-file
(
merge-pathnames
(
make-pathname
:name
".asdf-install"
)
(
user-homedir-pathname
)))))
(
make-pathname
:name
".asdf-install"
)
(
user-homedir-pathname
)))))
(
when
file
(
load
file
)))
(
define-condition
download-error
(
error
)
((
url
:initarg
:url
:reader
download-url
)
(
response
:initarg
:response
:reader
download-response
))
(
:report
(
lambda
(
c
s
)
(
format
s
"Server responded ~A for GET ~A"
(
download-response
c
)
(
download-url
c
)))))
(
format
s
"Server responded ~A for GET ~A"
(
download-response
c
)
(
download-url
c
)))))
(
define-condition
signature-error
(
error
)
((
cause
:initarg
:cause
:reader
signature-error-cause
))
(
:report
(
lambda
(
c
s
)
(
format
s
"Cannot verify package signature: ~A"
(
signature-error-cause
c
)))))
(
format
s
"Cannot verify package signature: ~A"
(
signature-error-cause
c
)))))
(
defun
url-host
(
url
)
(
assert
(
string-equal
url
"http://"
:end1
7
))
(
let*
((
port-start
(
position
#\:
url
:start
7
))
(
host-end
(
min
(
or
(
position
#\/
url
:start
7
)
(
length
url
))
(
or
port-start
(
length
url
)))))
(
host-end
(
min
(
or
(
position
#\/
url
:start
7
)
(
length
url
))
(
or
port-start
(
length
url
)))))
(
subseq
url
7
host-end
)))
(
defun
url-port
(
url
)
...
...
@@ -111,8 +111,8 @@ an immediate concern
(
defun
url-connection
(
url
)
(
let
((
s
(
make-instance
'inet-socket
:type
:stream
:protocol
:tcp
))
(
host
(
url-host
url
))
(
port
(
url-port
url
)))
(
host
(
url-host
url
))
(
port
(
url-port
url
)))
(
socket-connect
s
(
car
(
host-ent-addresses
(
get-host-by-name
(
url-host
(
or
*proxy*
url
)))))
(
url-port
(
or
*proxy*
url
)))
...
...
@@ -120,90 +120,90 @@ an immediate concern
;; we are exceedingly unportable about proper line-endings here.
;; Anyone wishing to run this under non-SBCL should take especial care
(
format
stream
"GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
url
host
*cclan-mirror*
)
url
host
*cclan-mirror*
)
(
force-output
stream
)
(
list
(
let*
((
l
(
read-line
stream
))
(
space
(
position
#\Space
l
)))
(
parse-integer
l
:start
(
1+
space
)
:junk-allowed
t
))
(
space
(
position
#\Space
l
)))
(
parse-integer
l
:start
(
1+
space
)
:junk-allowed
t
))
(
loop
for
line
=
(
read-line
stream
nil
nil
)
until
(
or
(
null
line
)
(
eql
(
elt
line
0
)
(
code-char
13
)))
collect
(
let
((
colon
(
position
#\:
line
)))
(
cons
(
intern
(
string-upcase
(
subseq
line
0
colon
))
:keyword
)
(
string-trim
(
list
#\Space
(
code-char
13
))
(
subseq
line
(
1+
colon
))))))
until
(
or
(
null
line
)
(
eql
(
elt
line
0
)
(
code-char
13
)))
collect
(
let
((
colon
(
position
#\:
line
)))
(
cons
(
intern
(
string-upcase
(
subseq
line
0
colon
))
:keyword
)
(
string-trim
(
list
#\Space
(
code-char
13
))
(
subseq
line
(
1+
colon
))))))
stream
))))
(
defun
download
(
package-name-or-url
file-name
)
(
let
((
url
(
if
(
=
(
mismatch
package-name-or-url
"http://"
)
7
)
package-name-or-url
(
format
nil
"http://www.cliki.net/~A?download"
package-name-or-url
))))
(
if
(
=
(
mismatch
package-name-or-url
"http://"
)
7
)
package-name-or-url
(
format
nil
"http://www.cliki.net/~A?download"
package-name-or-url
))))
(
destructuring-bind
(
response
headers
stream
)
(
block
got
(
loop
(
destructuring-bind
(
response
headers
stream
)
(
url-connection
url
)
(
unless
(
member
response
'
(
301
302
))
(
return-from
got
(
list
response
headers
stream
)))
(
close
stream
)
(
setf
url
(
cdr
(
assoc
:location
headers
))))))
(
block
got
(
loop
(
destructuring-bind
(
response
headers
stream
)
(
url-connection
url
)
(
unless
(
member
response
'
(
301
302
))
(
return-from
got
(
list
response
headers
stream
)))
(
close
stream
)
(
setf
url
(
cdr
(
assoc
:location
headers
))))))
(
if
(
>=
response
400
)
(
error
'download-error
:url
url
:response
response
))
(
error
'download-error
:url
url
:response
response
))
(
let
((
length
(
parse-integer
(
or
(
cdr
(
assoc
:content-length
headers
))
""
)
:junk-allowed
t
)))
(
format
t
"Downloading ~A bytes from ~A ..."
(
if
length
length
"some unknown number of"
)
url
)
(
force-output
)
(
with-open-file
(
o
file-name
:direction
:output
)
(
if
length
(
let
((
buf
(
make-array
length
:element-type
(
stream-element-type
stream
)
)))
(
read-sequence
buf
stream
)
(
write-sequence
buf
o
))
(
sb-executable:copy-stream
stream
o
))))
(
or
(
cdr
(
assoc
:content-length
headers
))
""
)
:junk-allowed
t
)))
(
format
t
"Downloading ~A bytes from ~A ..."
(
if
length
length
"some unknown number of"
)
url
)
(
force-output
)
(
with-open-file
(
o
file-name
:direction
:output
)
(
if
length
(
let
((
buf
(
make-array
length
:element-type
(
stream-element-type
stream
)
)))
(
read-sequence
buf
stream
)
(
write-sequence
buf
o
))
(
sb-executable:copy-stream
stream
o
))))
(
close
stream
)
(
terpri
)
;; seems to have worked. let's try for a detached gpg signature too
(
when
*verify-gpg-signatures*
(
verify-gpg-signature
url
file-name
)))))
(
verify-gpg-signature
url
file-name
)))))
(
defun
verify-gpg-signature
(
url
file-name
)
(
destructuring-bind
(
response
headers
stream
)
(
url-connection
(
concatenate
'string
url
".asc"
))
(
declare
(
ignore
headers
))
(
unwind-protect
(
if
(
=
response
200
)
;; sadly, we can't pass the stream directly to run-program,
;; because (at least in sbcl 0.8) that ignores existing buffered
;; data and only reads new fresh data direct from the file
;; descriptor
(
let
((
data
(
make-string
(
parse-integer
(
cdr
(
assoc
:content-length
headers
))
:junk-allowed
t
))))
(
read-sequence
data
stream
)
(
let
((
ret
(
process-exit-code
(
sb-ext:run-program
"/usr/bin/gpg"
(
list
"--verify"
"-"
(
namestring
file-name
))
:output
t
:input
(
make-string-input-stream
data
)
:wait
t
))))
(
unless
(
zerop
ret
)
(
error
'signature-error
:cause
(
make-condition
'simple-error
:format-control
"GPG returned exit status ~A"
:format-arguments
(
list
ret
))))))
(
error
'signature-error
:cause
(
make-condition
'download-error
:url
(
concatenate
'string
url
".asc"
)
:response
response
)))
(
if
(
=
response
200
)
;; sadly, we can't pass the stream directly to run-program,
;; because (at least in sbcl 0.8) that ignores existing buffered
;; data and only reads new fresh data direct from the file
;; descriptor
(
let
((
data
(
make-string
(
parse-integer
(
cdr
(
assoc
:content-length
headers
))
:junk-allowed
t
))))
(
read-sequence
data
stream
)
(
let
((
ret
(
process-exit-code
(
sb-ext:run-program
"/usr/bin/gpg"
(
list
"--verify"
"-"
(
namestring
file-name
))
:output
t
:input
(
make-string-input-stream
data
)
:wait
t
))))
(
unless
(
zerop
ret
)
(
error
'signature-error
:cause
(
make-condition
'simple-error
:format-control
"GPG returned exit status ~A"
:format-arguments
(
list
ret
))))))
(
error
'signature-error
:cause
(
make-condition
'download-error
:url
(
concatenate
'string
url
".asc"
)
:response
response
)))
(
close
stream
))))
...
...
@@ -212,9 +212,9 @@ an immediate concern
(
defun
where
()
(
format
t
"Install where?~%"
)
(
loop
for
(
source
system
name
)
in
*locations*
for
i
from
1
do
(
format
t
"~A) ~A: ~% System in ~A~% Files in ~A ~%"
i
name
system
source
))
for
i
from
1
do
(
format
t
"~A) ~A: ~% System in ~A~% Files in ~A ~%"
i
name
system
source
))
(
format
t
" --> "
)
(
force-output
)
(
let
((
response
(
read
)))
(
when
(
>
response
0
)
...
...
@@ -225,36 +225,36 @@ an immediate concern
(
ensure-directories-exist
source
)
(
ensure-directories-exist
system
)
(
let*
((
tar
(
with-output-to-string
(
o
)
(
or
(
sb-ext:run-program
"/bin/tar"
(
list
"-C"
(
namestring
source
)
"-xzvf"
(
namestring
packagename
))
:output
o
:wait
t
)
(
error
"can't untar"
))))
(
dummy
(
princ
tar
))
(
pos-slash
(
position
#\/
tar
))
(
*default-pathname-defaults*
(
merge-pathnames
(
make-pathname
:directory
`
(
:relative
,
(
subseq
tar
0
pos-slash
)))
source
)))
(
with-output-to-string
(
o
)
(
or
(
sb-ext:run-program
"/bin/tar"
(
list
"-C"
(
namestring
source
)
"-xzvf"
(
namestring
packagename
))
:output
o
:wait
t
)
(
error
"can't untar"
))))
(
dummy
(
princ
tar
))
(
pos-slash
(
position
#\/
tar
))
(
*default-pathname-defaults*
(
merge-pathnames
(
make-pathname
:directory
`
(
:relative
,
(
subseq
tar
0
pos-slash
)))
source
)))
(
loop
for
asd
in
(
directory
(
make-pathname
:name
:wild
:type
"asd"
))
do
(
let
((
target
(
merge-pathnames
(
make-pathname
:name
(
pathname-name
asd
)
:type
(
pathname-type
asd
))
system
)))
(
when
(
probe-file
target
)
(
sb-posix:unlink
target
))
(
sb-posix:symlink
asd
target
))
collect
(
pathname-name
asd
))))
(
make-pathname
:name
:wild
:type
"asd"
))
do
(
let
((
target
(
merge-pathnames
(
make-pathname
:name
(
pathname-name
asd
)
:type
(
pathname-type
asd
))
system
)))
(
when
(
probe-file
target
)
(
sb-posix:unlink
target
))
(
sb-posix:symlink
asd
target
))
collect
(
pathname-name
asd
))))
(
defvar
*temporary-files*
)
(
defun
temp-file-name
(
p
)
(
let*
((
pos-slash
(
position
#\/
p
:from-end
t
))
(
pos-dot
(
position
#\.
p
:start
(
or
pos-slash
0
))))
(
pos-dot
(
position
#\.
p
:start
(
or
pos-slash
0
))))
(
merge-pathnames
(
make-pathname
:name
(
subseq
p
(
if
pos-slash
(
1+
pos-slash
)
0
)
pos-dot
)
...
...
@@ -265,32 +265,32 @@ an immediate concern
(
defun
run
(
&optional
(
packages
(
cdr
*posix-argv*
)))
(
destructuring-bind
(
source
system
name
)
(
where
)
(
labels
((
one-iter
(
packages
)
(
dolist
(
asd
(
loop
for
p
in
packages
unless
(
probe-file
p
)
do
(
let
((
tmp
(
temp-file-name
p
)))
(
pushnew
tmp
*temporary-files*
)
(
download
p
tmp
)
(
setf
p
tmp
))
end
do
(
format
t
"Installing ~A in ~A,~A~%"
p
source
system
)
append
(
install
source
system
p
)))
(
handler-case
(
asdf:operate
'asdf:load-op
asd
)
(
asdf:missing-dependency
(
c
)
(
format
t
"Downloading package ~A, required by ~A~%"
(
asdf::missing-requires
c
)
(
asdf:component-name
(
asdf::missing-required-by
c
)))
(
one-iter
(
list
(
symbol-name
(
asdf::missing-requires
c
)))))))))
(
dolist
(
asd
(
loop
for
p
in
packages
unless
(
probe-file
p
)
do
(
let
((
tmp
(
temp-file-name
p
)))
(
pushnew
tmp
*temporary-files*
)
(
download
p
tmp
)
(
setf
p
tmp
))
end
do
(
format
t
"Installing ~A in ~A,~A~%"
p
source
system
)
append
(
install
source
system
p
)))
(
handler-case
(
asdf:operate
'asdf:load-op
asd
)
(
asdf:missing-dependency
(
c
)
(
format
t
"Downloading package ~A, required by ~A~%"
(
asdf::missing-requires
c
)
(
asdf:component-name
(
asdf::missing-required-by
c
)))
(
one-iter
(
list
(
symbol-name
(
asdf::missing-requires
c
)))))))))
(
one-iter
packages
))))
(
handler-case
(
let
((
*temporary-files*
nil
))
(
unwind-protect
(
run
)
(
dolist
(
l
*temporary-files*
)
(
when
(
probe-file
l
)
(
delete-file
l
)))))
(
run
)
(
dolist
(
l
*temporary-files*
)
(
when
(
probe-file
l
)
(
delete-file
l
)))))
(
error
(
c
)
(
princ
"Install failed due to error:"
)
(
terpri
)
(
princ
c
)
(
terpri
)
...
...
asdf.lisp
View file @
7f4d19be
...
...
@@ -163,7 +163,7 @@
;;;;
(
defvar
*asdf-revision*
;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
(
subseq
"REVISION:1.37
2
"
(
1+
(
length
"REVISION"
))))
(
subseq
"REVISION:1.37
3
"
(
1+
(
length
"REVISION"
))))
(
defvar
*resolve-symlinks*
t
"Determine whether or not ASDF resolves symlinks when defining systems.
...
...
asdf.texinfo
View file @
7f4d19be
...
...
@@ -418,19 +418,19 @@ slightly convoluted example:
The
method
-
form
tokens
need
explaining
:
essentially
,
this
part
:
@
lisp
:
perform
(
compile
-
op
:
after
(
op
c
)
(
do
-
something
c
))
:
explain
(
compile
-
op
:
after
(
op
c
)
(
explain
-
something
c
))
:
perform
(
compile
-
op
:
after
(
op
c
)
(
do
-
something
c
))
:
explain
(
compile
-
op
:
after
(
op
c
)
(
explain
-
something
c
))
@
end
lisp
has
the
effect
of
@
lisp
(
defmethod
perform
:
after
((
op
compile
-
op
)
(
c
(
eql
...)))
(
do
-
something
c
))
(
do
-
something
c
))
(
defmethod
explain
:
after
((
op
compile
-
op
)
(
c
(
eql
...)))
(
explain
-
something
c
))
(
explain
-
something
c
))
@
end
lisp
where
@
code
{...}
is
the
component
in
question
;
note
that
although
this
...
...
@@ -452,10 +452,10 @@ option := :components component-list
|
:
default
-
component
-
class
|
:
perform
method
-
form
|
:
explain
method
-
form
|
:
output
-
files
method
-
form
|
:
output
-
files
method
-
form
|
:
operation
-
done
-
p
method
-
form
|
:
depends
-
on
(
{
dependency
-
def
}*
)
|
:
serial
[
t
|
nil
]
|
:
serial
[
t
|
nil
]
|
:
in
-
order
-
to
(
{
dependency
}+
)
component
-
list
:=
(
{
component
-
def
}*
)
...
...
@@ -497,8 +497,8 @@ is equivalent to
@
lisp
:
components
((:
file
"a"
)
(:
file
"b"
:
depends
-
on
(
"a"
))
(:
file
"c"
:
depends
-
on
(
"a"
"b"
)))
(:
file
"b"
:
depends
-
on
(
"a"
))
(:
file
"c"
:
depends
-
on
(
"a"
"b"
)))
@
end
lisp
...
...
@@ -706,13 +706,13 @@ libraries and test techniques in use in the community.
@
c
@
lisp
@
c
(
defun
version
-
satisfies
(
x
y
)
@
c
(
labels
((
bigger
(
x
y
)
@
c
(
cond
((
not
y
)
t
)
@
c
((
not
x
)
nil
)
@
c
((>
(
car
x
)
(
car
y
))
t
)
@
c
((=
(
car
x
)
(
car
y
))
@
c
(
bigger
(
cdr
x
)
(
cdr
y
))))))
@
c
(
cond
((
not
y
)
t
)
@
c
((
not
x
)
nil
)
@
c
((>
(
car
x
)
(
car
y
))
t
)
@
c
((=
(
car
x
)
(
car
y
))
@
c
(
bigger
(
cdr
x
)
(
cdr
y
))))))
@
c
(
and
(=
(
car
x
)
(
car
y
))
@
c
(
or
(
not
(
cdr
y
))
(
bigger
(
cdr
x
)
(
cdr
y
))))))
@
c
(
or
(
not
(
cdr
y
))
(
bigger
(
cdr
x
)
(
cdr
y
))))))
@
c
@
end
lisp
@
c
If
that
doesn
't work for your system, you can override it. I hope
...
...
@@ -883,7 +883,7 @@ initargs for the component, you can say
@lisp
:in-order-to ((compile-op (load-op "a" "b") (compile-op "c"))
(load-op (load-op "foo")))
(load-op (load-op "foo")))
@end lisp
This means the following things:
...
...
@@ -1381,7 +1381,7 @@ so should be.
*** Propagation of the :force option. ``I notice that
(oos '
compile
-
op
:
araneida
:
force
t
)
(oos '
compile
-
op
:
araneida
:
force
t
)
also
forces
compilation
of
every
other
system
the
:
araneida
system
depends
on
.
This
is
rarely
useful
to
me
;
usually
,
when
I
want
to
force
...
...
bin/make-helper.lisp
View file @
7f4d19be
...
...
@@ -12,7 +12,7 @@
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
defmacro
generate-time-part-function
(
part-name
position
)
(
let
((
function-name
(
intern
(
concatenate
'string
(
symbol-name
'time
)
"-"
(
symbol-name
part-name
)))))
(
symbol-name
'time
)
"-"
(
symbol-name
part-name
)))))
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
export
',function-name
)
(
defun
,
function-name
...
...
@@ -73,8 +73,8 @@ is divisible by four but not by 100 or if it is divisible by 400."
(
check-type
format
(
member
:long
:short
))
(
nth
day-of-the-week
(
case
format
(
:long
(
nth
+longer-format-index+
+dow-output-list
))
(
:short
(
nth
+shorter-format-index+
+dow-output-list
)))))
(
:long
(
nth
+longer-format-index+
+dow-output-list
))
(
:short
(
nth
+shorter-format-index+
+dow-output-list
)))))
(
defun
month->string
(
month
&optional
(
format
:long
))
"Returns the name \(in English\) of the month. Format can be :long or :short."
...
...
@@ -82,8 +82,8 @@ is divisible by four but not by 100 or if it is divisible by 400."
(
check-type
format
(
member
:long
:short
))
(
nth
(
1-
month
)
(
case
format
(
:long
(
nth
+longer-format-index+
+month-output-list+
))
(
:short
(
nth
+shorter-format-index+
+month-output-list+
)))))
(
:long
(
nth
+longer-format-index+
+month-output-list+
))
(
:short
(
nth
+shorter-format-index+
+month-output-list+
)))))
(
defun
format-date
(
format
date
&optional
stream
time-zone
)
"Formats universal dates using the same format specifiers as NSDateFormatter. The format is:
...
...
@@ -122,80 +122,80 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented."
(
format
stream
"~{~A~}"
(
loop
for
index
=
0
then
(
1+
index
)
while
(
<
index
format-length
)
collect
(
let
((
char
(
aref
format
index
)))
(
cond
((
char=
#\%
char
)
(
setf
char
(
aref
format
(
incf
index
)))
(
cond
;; %% - A '%' character
((
char=
char
#\%
)
#\%
)
while
(
<
index
format-length
)
collect
(
let
((
char
(
aref
format
index
)))
(
cond
((
char=
#\%
char
)
(
setf
char
(
aref
format
(
incf
index
)))
(
cond
;; %% - A '%' character
((
char=
char
#\%
)
#\%
)
;; %a - Abbreviated weekday name
((
char=
char
#\a
)
(
day->string
(
time-day-of-week
date
)
:short
))
;; %a - Abbreviated weekday name
((
char=
char
#\a
)
(
day->string
(
time-day-of-week
date
)
:short
))