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
284ff146
Commit
284ff146
authored
Jan 13, 2013
by
Francois-Rene Rideau
Browse files
2.26.84: more portability with GCL, ECL, LispWorks
parent
602d43dc
Changes
19
Hide whitespace changes
Inline
Side-by-side
asdf.asd
View file @
284ff146
...
...
@@ -15,7 +15,7 @@
:licence
"MIT"
:description
"Another System Definition Facility"
:long-description
"ASDF builds Common Lisp software organized into defined systems."
:version
"2.26.8
3
"
;; to be automatically updated by bin/bump-revision
:version
"2.26.8
4
"
;; to be automatically updated by bin/bump-revision
:depends-on
()
:components
((
:module
"build"
:components
((
:file
"asdf"
))))
:in-order-to
(
#+
asdf2.27
(
compile-op
(
monolithic-load-concatenated-source-op
generate-asdf
))))
...
...
bundle.lisp
View file @
284ff146
...
...
@@ -277,7 +277,7 @@
nil
)
(
defmethod
perform
((
o
load-fasl-op
)
(
c
system
))
(
if-bind
(
it
(
first
(
input-files
o
c
)))
(
load
it
)
))
(
perform-lisp-load-fasl
o
c
))
(
defmethod
mark-operation-done
:after
((
o
load-fasl-op
)
(
c
system
))
(
mark-operation-done
(
find-operation
o
'load-op
)
c
))
; need we recurse on gather-components?
...
...
@@ -299,8 +299,7 @@
(
declare
(
ignorable
o
))
(
component-pathname
c
))
(
defmethod
perform
((
o
load-op
)
(
c
compiled-file
))
(
declare
(
ignorable
o
))
(
load
(
first
(
input-files
o
c
))))
(
perform-lisp-load-fasl
o
c
))
(
defmethod
perform
((
o
load-source-op
)
(
c
compiled-file
))
(
perform
(
find-operation
o
'load-op
)
c
))
(
defmethod
perform
((
o
load-fasl-op
)
(
c
compiled-file
))
...
...
compatibility.lisp
View file @
284ff146
...
...
@@ -54,7 +54,9 @@
(
when
(
or
(
<
system::*gcl-major-version*
2
)
;; GCL 2.6 lacks output-translations and more.
(
and
(
=
system::*gcl-major-version*
2
)
(
<
system::*gcl-minor-version*
7
)))
(
format
t
"Detected an old GCL 2.6. Only limited functionality available.~%"
)
(
shadow
'type-of
:asdf/compatibility
)
(
export
'with-standard-io-syntax
)
(
pushnew
'ignorable
pcl::*variable-declarations-without-argument*
)
(
pushnew
:gcl<2.7
*features*
))
(
unless
(
member
:ansi-cl
*features*
)
...
...
@@ -81,6 +83,7 @@
#+
gcl<2.7
(
progn
;; Doesn't support either logical-pathnames or output-translations.
(
defvar
*gcl<2.7*
t
)
(
deftype
logical-pathname
()
nil
)
(
defun
type-of
(
x
)
(
class-name
(
class-of
x
)))
(
defun
wild-pathname-p
(
path
)
(
declare
(
ignore
path
))
nil
)
...
...
@@ -94,6 +97,8 @@
(
format
stream
"#<~@[~S ~]"
(
when
type
(
type-of
object
)))
(
funcall
thunk
)
(
format
stream
"~@[ ~X~]>"
(
when
identity
(
system:address
object
))))
(
defmacro
with-standard-io-syntax
(
&body
body
)
`
(
progn
,@
body
))
(
defmacro
with-compilation-unit
(
options
&body
body
)
(
declare
(
ignore
options
))
`
(
progn
,@
body
))
(
defmacro
print-unreadable-object
((
object
stream
&key
type
identity
)
&body
body
)
...
...
find-system.lisp
View file @
284ff146
...
...
@@ -4,7 +4,7 @@
(
asdf/package:define-package
:asdf/find-system
(
:recycle
:asdf/find-system
:asdf
)
(
:use
:common-lisp
:asdf/compatibility
:asdf/utility
:asdf/pathname
:asdf/stream
:asdf/os
:asdf/upgrade
:asdf/component
:asdf/system
)
:asdf/lisp-build
:asdf/upgrade
:asdf/component
:asdf/system
)
(
:export
#:coerce-name
#:find-system
#:locate-system
#:load-sysdef
#:with-system-definitions
#:system-registered-p
#:register-system
#:registered-systems
#:clear-system
#:map-systems
...
...
@@ -251,7 +251,8 @@ Going forward, we recommend new users should be using the source-registry.
(
external-format
(
encoding-external-format
(
detect-encoding
pathname
))))
(
asdf-message
(
compatfmt
"~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
)
pathname
package
)
(
load
pathname
#-
gcl<2.7
:external-format
#-
gcl<2.7
external-format
)))
(
with-controlled-loader-conditions
()
(
load*
pathname
:external-format
external-format
))))
(
delete-package
package
)))))
(
defun*
locate-system
(
name
)
...
...
header.lisp
View file @
284ff146
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.8
3
: Another System Definition Facility.
;;; This is ASDF 2.26.8
4
: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
...
...
lisp-action.lisp
View file @
284ff146
...
...
@@ -158,8 +158,8 @@
(
component-name
c
)))
(
perform
(
find-operation
o
'compile-op
)
c
)))))
(
defun*
perform-lisp-load-fasl
(
o
c
)
(
with-controlled-loader-conditions
(
)
(
load
(
first
(
input-files
o
c
)
))))
(
if-bind
(
fasl
(
first
(
input-files
o
c
))
)
(
with-controlled-loader-conditions
()
(
load*
fasl
))))
(
defmethod
perform
((
o
load-op
)
(
c
cl-source-file
))
(
perform-lisp-load-fasl
o
c
))
(
defmethod
perform
((
o
load-op
)
(
c
static-file
))
...
...
lisp-build.lisp
View file @
284ff146
...
...
@@ -145,13 +145,13 @@ or a string describing the format-control of a simple-condition."
(
defun*
call-with-controlled-compiler-conditions
(
thunk
)
(
call-with-muffled-uninteresting-conditions
thunk
*uninteresting-compiler-conditions*
))
(
defmacro
with-controlled-compiler-conditions
(()
&body
body
)
(
defmacro
with-controlled-compiler-conditions
((
&optional
)
&body
body
)
"Run BODY where uninteresting compiler conditions are muffled"
`
(
call-with-controlled-compiler-conditions
#'
(
lambda
()
,@
body
)))
(
defun*
call-with-controlled-loader-conditions
(
thunk
)
(
call-with-muffled-uninteresting-conditions
thunk
(
append
*uninteresting-compiler-conditions*
*uninteresting-loader-conditions*
)))
(
defmacro
with-controlled-loader-conditions
(()
&body
body
)
(
defmacro
with-controlled-loader-conditions
((
&optional
)
&body
body
)
"Run BODY where uninteresting compiler and additional loader conditions are muffled"
`
(
call-with-muffled-uninteresting-conditions
#'
(
lambda
()
,@
body
)))
...
...
@@ -261,10 +261,9 @@ for processing later (possibly in a different process)."
(
remove-keys
`
(
#+
(
and
allegro
(
not
(
version>=
8
2
)))
:external-format
,@
(
unless
output-file
'
(
:output-file
)))
keys
)))))
(
defun*
load*
(
x
&rest
keys
&key
external-format
&allow-other-keys
)
(
declare
(
ignorable
external-format
))
(
defun*
load*
(
x
&rest
keys
&key
&allow-other-keys
)
(
etypecase
x
((
or
pathname
string
#-
(
or
gcl
-pre
2.7
clozure
allegro
)
stream
)
((
or
pathname
string
#-
(
or
gcl
<
2.7
clozure
allegro
)
stream
)
(
apply
'load
x
#-
gcl<2.7
keys
#+
gcl<2.7
(
remove-keyword
:external-format
keys
)))
#-
(
or
gcl<2.7
clozure
allegro
)
...
...
@@ -272,9 +271,10 @@ for processing later (possibly in a different process)."
;; ClozureCL 1.6 can only load from file input stream
;; Allegro 5, I don't remember but it must have been broken when I tested.
(
stream
;; make do this way
(
let
((
*load-pathname*
nil
)
(
*load-truename*
nil
)
#+
clozure
(
ccl::*default-external-format*
external-format
))
(
let
((
*package*
*package*
)
(
*readtable*
*readtable*
)
(
*load-pathname*
nil
)
(
*load-truename*
nil
))
(
eval-input
x
)))))
(
defun*
load-from-string
(
string
)
...
...
@@ -293,8 +293,8 @@ for processing later (possibly in a different process)."
(
#+
ecl
if
#+
ecl
(
use-ecl-byte-compiler-p
)
#+
ecl
(
apply
'compile-file*
input-file
keys
)
#+
mkcl
progn
(
let
((
object-file
(
apply
'
compile-file-pathname
output-file
#+
ecl
:type
#+
ecl
:object
#+
mkcl
:fasl-p
#+
mkcl
nil
)))
(
compile-file-pathname
output-file
#+
ecl
:type
#+
ecl
:object
#+
mkcl
:fasl-p
#+
mkcl
nil
)))
(
multiple-value-bind
(
result
flags1
flags2
)
(
apply
'compile-file*
input-file
#+
ecl
:system-p
#+
ecl
t
#+
mkcl
:fasl-p
#+
mkcl
nil
...
...
os.lisp
View file @
284ff146
...
...
@@ -14,7 +14,8 @@
#:implementation-type
#:operating-system
#:architecture
#:lisp-version-string
#:hostname
#:user-homedir
#:lisp-implementation-directory
#:getcwd
#:chdir
#:call-with-current-directory
#:with-current-directory
#:*temporary-directory*
#:temporary-directory
#:default-temporary-directory
#:with-temporary-file
))
#:*temporary-directory*
#:temporary-directory
#:default-temporary-directory
#:call-with-temporary-file
#:with-temporary-file
))
(
in-package
:asdf/os
)
;;; Features
...
...
@@ -282,6 +283,7 @@ then returning the non-empty string value of the variable"
prefix
keep
(
direction
:io
)
(
element-type
*default-stream-element-type*
)
(
external-format
:default
))
#+
gcl<2.7
(
declare
(
ignorable
external-format
))
(
check-type
direction
(
member
:output
:io
))
(
loop
:with
prefix
=
(
or
prefix
(
format
nil
"~Atmp"
(
native-namestring
(
temporary-directory
))))
...
...
@@ -292,7 +294,8 @@ then returning the non-empty string value of the variable"
;; TODO: on Unix, use CFFI and mkstemp -- but the master is precisely meant to not depend on CFFI or on anything! Grrrr.
(
with-open-file
(
stream
pathname
:direction
direction
:element-type
element-type
:external-format
external-format
:element-type
element-type
#-
gcl<2.7
:external-format
#-
gcl<2.7
external-format
:if-exists
nil
:if-does-not-exist
:create
)
(
when
stream
(
return
...
...
package.lisp
View file @
284ff146
...
...
@@ -38,7 +38,7 @@ If optional ERROR argument is NIL, return NIL instead of an error
when the symbol is not found."
(
block
nil
(
let
((
package
(
find-package*
package-designator
error
)))
(
when
package
(
when
package
;; package error handled by find-package* already
(
multiple-value-bind
(
symbol
status
)
(
find-symbol
(
string
name
)
package
)
(
cond
(
status
(
return
(
values
symbol
status
)))
...
...
run-program.lisp
View file @
284ff146
...
...
@@ -134,12 +134,14 @@ by /bin/sh in POSIX"
(
defgeneric*
slurp-input-stream
(
processor
input-stream
&key
&allow-other-keys
))
#-
(
or
gcl<2.7
genera
)
(
defmethod
slurp-input-stream
((
function
function
)
input-stream
&key
&allow-other-keys
)
(
funcall
function
input-stream
))
(
defmethod
slurp-input-stream
((
list
cons
)
input-stream
&key
&allow-other-keys
)
(
apply
(
first
list
)
(
cons
input-stream
(
rest
list
))))
#-
(
or
gcl<2.7
genera
)
(
defmethod
slurp-input-stream
((
output-stream
stream
)
input-stream
&key
(
element-type
'character
)
&allow-other-keys
)
(
copy-stream-to-stream
...
...
@@ -165,6 +167,18 @@ by /bin/sh in POSIX"
(
declare
(
ignorable
x
))
(
slurp-stream-forms
stream
))
(
defmethod
slurp-input-stream
(
x
stream
&key
(
element-type
'character
)
&allow-other-keys
)
(
declare
(
ignorable
stream
element-type
))
(
cond
#+
(
or
gcl<2.7
genera
)
((
functionp
x
)
(
funcall
x
stream
))
#+
(
or
gcl<2.7
genera
)
((
output-stream-p
x
)
(
copy-stream-to-stream
stream
x
:element-type
element-type
))
(
t
(
error
"Invalid ~S destination ~S"
'slurp-input-stream
x
))))
;;;; ----- Running an external program -----
;;; Simple variant of run-program with no input, and capturing output
...
...
@@ -261,8 +275,8 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
:output
(
if
pipe
:stream
t
)
.
#.
(
append
#+
(
or
clozure
cmu
ecl
sbcl
scl
)
'
(
:error
t
)
#+
sbcl
'
(
:search
t
#|
:external-format external-format
; not in old SBCLs|#
)))))
;; note: :external-format requires a recent SBCL
#+
sbcl
'
(
:search
t
:external-format
external-format
)))))
(
process
#+
(
or
allegro
lispworks
)
(
if
pipe
(
third
process*
)
(
first
process*
))
#+
ecl
(
third
process*
)
...
...
@@ -352,7 +366,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process
:direction
:input
:if-does-not-exist
:error
:element-type
element-type
:external-format
external-format
)
#-
gcl<2.7
:external-format
#-
gcl<2.7
external-format
)
(
slurp-input-stream
output
stream
)))
(
call-system
(
system-command
command
)
:interactive
interactive
)))))
(
if
(
and
(
not
force-shell
)
...
...
stream.lisp
View file @
284ff146
...
...
@@ -44,34 +44,24 @@
;;; Output to a stream or string, FORMAT-style
(
defgeneric
call-with-output
(
x
thunk
)
(
:documentation
;; code from fare-utils base/streams where it's now named
;; call-with-output-stream to avoid the package clash in a lot of my code.
"Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing:
(
defun*
call-with-output
(
x
thunk
)
"Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing:
If OBJ is a stream, use it as the stream.
If OBJ is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
If OBJ is T, use *STANDARD-OUTPUT* as the stream.
If OBJ is a string with a fill-pointer, use it as a string-output-stream.
Otherwise, signal an error."
)
(
:method
((
x
null
)
thunk
)
(
declare
(
ignorable
x
))
(
with-output-to-string
(
s
)
(
funcall
thunk
s
)))
(
:method
((
x
(
eql
t
))
thunk
)
(
declare
(
ignorable
x
))
(
funcall
thunk
*standard-output*
)
nil
)
#-
genera
(
:method
((
x
stream
)
thunk
)
(
funcall
thunk
x
)
nil
)
(
:method
((
x
string
)
thunk
)
(
assert
(
fill-pointer
x
))
(
with-output-to-string
(
s
x
)
(
funcall
thunk
s
)))
(
:method
(
x
thunk
)
(
declare
(
ignorable
thunk
))
(
cond
#+
genera
((
typep
x
'stream
)
(
funcall
thunk
x
)
nil
)
(
t
(
error
"not a valid stream designator ~S"
x
)))))
Otherwise, signal an error."
(
typecase
x
(
null
(
with-output-to-string
(
s
)
(
funcall
thunk
s
)))
((
eql
t
)
(
funcall
thunk
*standard-output*
))
(
stream
(
funcall
thunk
x
))
(
string
(
assert
(
fill-pointer
x
))
(
with-output-to-string
(
s
x
)
(
funcall
thunk
s
)))
(
t
(
error
"not a valid stream designator ~S"
x
))))
(
defmacro
with-output
((
x
&optional
(
value
x
))
&body
body
)
"Bind X to an output stream, coercing VALUE (default: previous binding of X)
...
...
@@ -112,8 +102,10 @@ Otherwise, signal an error."
&key
(
element-type
*default-stream-element-type*
)
(
external-format
:default
))
"Open FILE for input with given options, call THUNK with the resulting stream."
#+
gcl<2.7
(
declare
(
ignore
external-format
))
(
with-open-file
(
s
pathname
:direction
:input
:element-type
element-type
:external-format
external-format
:element-type
element-type
#-
gcl<2.7
:external-format
#-
gcl<2.7
external-format
:if-does-not-exist
:error
)
(
funcall
thunk
s
)))
...
...
test/asdf-pathname-test.script
View file @
284ff146
...
...
@@ -49,7 +49,9 @@
(*print-pretty* nil)
(start-time 0))
(with-open-file (result-stream (asdf::merge-pathnames* "output.txt" root)
(with-open-file (result-stream (asdf::subpathname
*build-directory*
(format nil "results/~(~A~)-pathnames.txt" *implementation*))
:direction :output
:if-exists :supersede :if-does-not-exist :create)
(flet ((src-dir (&rest path) (append (or (pathname-directory root) (list :relative))
...
...
@@ -122,7 +124,7 @@
:defaults root)
,(make-pathname :directory (src-dir "system2" "module4") :name "file" :type "lisp"
:defaults root)
,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name "file" :type "lisp"
,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name "file" :type "lisp"
:version nil
:defaults root)
,(parse-namestring "ASDFTEST:system2;module4;file.lisp")
,@(when support-string-pathnames
...
...
@@ -221,9 +223,7 @@
((error (lambda (c)
(incf system-failures)
(format *error-output* "~&error! ~a~%sysdef:~% ~S~%" c system-definition)
#+sbcl (sb-debug:backtrace 69)
#+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
#+clisp (system::print-backtrace)
(asdf::print-condition-backtrace c :stream *error-output*)
(format result-stream "~&~%***~%error: ~a~%~s"
c system-definition)
(return-from :test-system))))
...
...
test/run-tests.sh
View file @
284ff146
...
...
@@ -288,6 +288,9 @@ clean_up () {
rm
-rf
../build/test-source-registry-conf.d ../build/test-asdf-output-translations-conf.d
}
test_clean_load
()
{
case
$lisp
in
gcl
)
return
0
;;
# GCL 2.6 is hopeless
esac
nop
=
build/results/
${
lisp
}
-nop
.text
load
=
build/results/
${
lisp
}
-load
.text
${
command
}
${
eval
}
\
...
...
test/script-support.lisp
View file @
284ff146
...
...
@@ -31,7 +31,7 @@ Some constraints:
#+
(
or
cmu
scl
)
(
c::brevity
2
)))
(
defvar
*trace-symbols*
'
(
;; If you want to trace some stuff while debugging ASDF,
`
(
;; If you want to trace some stuff while debugging ASDF,
;; here's a nice place to say what.
;; These string designators will be interned in ASDF after it is loaded.
))
...
...
@@ -57,7 +57,10 @@ Some constraints:
;;; Survival utilities
(
defun
asym
(
name
)
(
find-symbol
(
string
name
)
:asdf
))
(
let
((
asdf
(
find-package
:asdf
)))
(
unless
asdf
(
error
"Can't find package ASDF"
))
(
or
(
find-symbol
(
string
name
)
asdf
)
(
error
"Can't find symbol ~A in ASDF"
name
))))
(
defun
acall
(
name
&rest
args
)
(
apply
(
asym
name
)
args
))
...
...
@@ -98,7 +101,7 @@ Some constraints:
#+
cmu
:cmucl
#+
corman
:cormanlisp
#+
digitool
:mcl
#+
ecl
:ecl
#+
ecl
(
or
#+
ecl-bytecmp
:ecl_bytecodes
:ecl
)
#+
gcl
:gcl
#+
lispworks
:lispworks
#+
mkcl
:mkcl
...
...
@@ -181,7 +184,7 @@ Some constraints:
(
finish-outputs
)
(
throw
:asdf-test-done
return
))
(
defmacro
with-test
(()
&body
body
)
(
defmacro
with-test
((
&optional
)
&body
body
)
`
(
call-with-test
(
lambda
()
,@
body
)))
(
defun
call-with-test
(
thunk
)
...
...
test/static-and-serial.asd
deleted
100644 → 0
View file @
602d43dc
#|
make sure that serial t and static-files don't cause full rebuilds all
the time...
|#
(
defsystem
static-and-serial
:version
"0.1"
:serial
t
:components
((
:static-file
"file2.lisp"
)
(
:static-file
"run-tests.sh"
)
(
:file
"file1"
)))
test/test-encodings.script
View file @
284ff146
...
...
@@ -43,6 +43,9 @@
(defsystem :test-encoding-explicit-u8
:components ((:file "lambda" :encoding :utf-8))))
#-asdf-unicode
(leave-test "No Unicode support to test on this lisp implementation" 0)
;; NB: recent clozure can autodetect without asdf-encodings with :default (!)
#+(and asdf-unicode sbcl)
...
...
test/test-static-and-serial.script
View file @
284ff146
;;; -*- Lisp -*-
#|
make sure that serial t and static-files
don't cause full rebuilds all the time...
|#
(load "script-support.lisp")
(load-asdf)
(in-package :asdf-test)
#+gcl (trace coerce-pathname)
(with-test ()
(format t "dpd: ~S~%f1: ~S~%" *default-pathname-defaults* (asdf::merge-pathnames* "file1"))
(
setf asdf:*central-registry* '(*default-pathname-defaults*)
)
(
load-test-system 'static-and-serial
)
(asdf:operate 'asdf:load-op 'static-and-serial)
(let* ((file1 (asdf:compile-file-pathname* "file1.lisp"))
(file1-date (file-write-date file1))
(date1 (- file1-date 600))
...
...
@@ -22,9 +22,10 @@
(format t "file: ~S~%date: ~S~%" file1 file1-date)
;; date should stay same
(asdf:clear-system 'static-and-serial)
(clear-system 'static-and-serial)
(touch-file "static-and-serial.asd" :offset -10000)
(touch-file "file2.lisp" :timestamp date1)
(touch-file "file1.lisp" :timestamp date2)
(touch-file file1 :timestamp date3)
(
asdf:operate 'asdf:
load-op 'static-and-serial)
(assert
(
equal (file-write-date file1) date3)))
)
(
DBG "load again" (oos '
load-op 'static-and-serial)
)
(assert
-
equal (file-write-date file1) date3)))
test/wild-module.script
View file @
284ff146
...
...
@@ -6,4 +6,5 @@
(asdf:defsystem :wild-module
:version "0.0"
:components ((:wild-module "systems" :pathname #p"*.asd")))
#-gcl<2.7
(load-system :wild-module))
upgrade.lisp
View file @
284ff146
...
...
@@ -32,7 +32,7 @@
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(
asdf-version
"2.26.8
3
"
)
(
asdf-version
"2.26.8
4
"
)
(
existing-asdf
(
find-class
(
find-symbol*
:component
:asdf
nil
)
nil
))
(
existing-version
*asdf-version*
)
(
already-there
(
equal
asdf-version
existing-version
)))
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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