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
2f979dc5
Commit
2f979dc5
authored
Dec 19, 2013
by
Francois-Rene Rideau
Browse files
Support XCL again, by working around implementation bugs, documented in TODO.
parent
8e5e42f2
Changes
8
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
2f979dc5
...
...
@@ -10,13 +10,13 @@ sourceDirectory := $(shell pwd)
ifdef
ASDF_TEST_LISPS
lisps
?=
${ASDF_TEST_LISPS}
else
lisps
?=
ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern gcl
lisps
?=
ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern gcl
xcl
endif
## NOT SUPPORTED BY OUR AUTOMATED TESTS:
## cormancl genera lispworks-personal-edition mkcl rmcl
## Some are manually tested once in a while.
## FAIL: gcl -- most implementation bugs are now fixed, but some remain. See TODO.
## FAIL: xcl -- implementation bugs
now prevent ASDF3 from working at all
. See TODO.
## FAIL: xcl -- implementation bugs
require lots of papering over during tests
. See TODO.
## grep for #+/#- features in the test/ directory to see plenty of disabled tests.
ifdef
ASDF_TEST_SYSTEMS
s
?=
${ASDF_TEST_SYSTEMS}
...
...
TODO
View file @
2f979dc5
...
...
@@ -19,21 +19,21 @@
** Modify SBCL and other implementations so they provide UIOP
independently from ASDF?
* XCL is no longer supported due to an implementation bug:
the return in search-for-system-definition fails to return from the
(block nil ...) and seems to mistakenly return from
some implicit internal block.
TODO: either get it fixed, or provide a workaround in uiop/common-lisp.
In the meantime, XCL is officially not supported anymore.
XCL also has a bug in make-pathname, and probably other bugs;
it takes a long time for errors to propagate to the REPL —
* XCL has bad bugs:
make-pathname doesn't handle :type nil properly and
has massive lossage in logical-pathname support.
If using block () and return in search-for-system-definition
instead of return-from, XCL mistakenly has the return jump
to the end of the try function or something.
It also takes a long time for errors to propagate into a debugging REPL —
Maybe O(n^3) behavior or worse in walking the C++ stack?
The backtrace frames may contains unprintable objects.
* GCL is almost working again; but implementation bugs remain.
See November 2013 discussion on gcl-devel
* Some out-of-line configuration mechanism for various options?
i.e.
have
files
that
override some variables around compilation of some systems.
i.e.
let configuration
files override some variables around compilation of some systems.
* Find an easier way to bind variables around compilation and loading of files
...
...
find-system.lisp
View file @
2f979dc5
...
...
@@ -137,12 +137,11 @@ called with an object of type asdf:system."
(
cleanup-system-definition-search-functions
)
(
defun
search-for-system-definition
(
system
)
(
block
()
(
let
((
name
(
coerce-name
system
)))
(
flet
((
try
(
f
)
(
if-let
((
x
(
funcall
f
name
)))
(
return
x
))))
(
try
'find-system-if-being-defined
)
(
map
()
#'
try
*system-definition-search-functions*
)
(
try
'sysdef-preloaded-system-search
)))))
(
let
((
name
(
coerce-name
system
)))
(
flet
((
try
(
f
)
(
if-let
((
x
(
funcall
f
name
)))
(
return-from
search-for-system-definition
x
))))
(
try
'find-system-if-being-defined
)
(
map
()
#'
try
*system-definition-search-functions*
)
(
try
'sysdef-preloaded-system-search
))))
(
defvar
*central-registry*
nil
"A list of 'system directory designators' ASDF uses to find systems.
...
...
test/asdf-pathname-test.script
View file @
2f979dc5
...
...
@@ -3,6 +3,10 @@
(defpackage :asdf-pathname-test (:use :asdf :uiop :uiop/common-lisp :asdf/cache :asdf-test))
(in-package :asdf-pathname-test)
(eval-when (:compile-toplevel :load-toplevel :execute)
#-xcl (push :asdf-test-logical-pathname *features*)
#+xcl (push :buggy-untyped-file *features*))
;;(setf *unspecific-pathname-type* nil)
;;; test asdf pathname specifications
...
...
@@ -37,6 +41,8 @@
;;; (:static-file "module1-1/file3.lisp") means #p"module1-1/file3.lisp"
(defun setup-asdftest-logical-host (&key (root *build-directory*) (bin-type (compile-file-type)))
(declare (ignorable root bin-type))
#+asdf-test-logical-pathname
(setf (logical-pathname-translations "ASDFTEST")
`((,(format nil "**;*.~a" bin-type)
,(subpathname root (make-pathname :directory '(:relative :wild-inferiors)
...
...
@@ -74,8 +80,8 @@
:components
((:file "file" :pathname ,file-pathname)
(:file "module2/file" :pathname ,file-pathname)
,@(unless (or (
typep system-pathname 'logical
-pathname)
(
typep module-pathname 'logical
-pathname))
,@(unless (or (
logical-pathname-p system
-pathname)
(
logical-pathname-p module
-pathname))
`((:file "typed-file.type" :pathname ,file-pathname)
(:static-file "static-file.type" :pathname ,file-pathname)
(:file "module2/typed-file.type" :pathname ,file-pathname)
...
...
@@ -105,22 +111,24 @@
success)))
(defparameter *backtraces* 0)
(defparameter *max-backtraces*
4
)
(defparameter *max-backtraces*
10
)
(defun test-file (file &key configuration (test-status *test-status*) (start-time 0))
(with-slots (system-count directory-count file-count
system-failures directory-failures file-failures all-tests) test-status
(let ((success
(block
nil
(block
:foo
(handler-bind ((error #'(lambda (c)
(incf *backtraces*)
(dolist (o (list *trace-output*))
(format o "BACKTRACES: ~S (max ~S)~%"
*backtraces* *max-backtraces*)
(when (<= *backtraces* *max-backtraces*)
(print-condition-backtrace c :stream o)))
(return nil))))
(assert (probe-file* (component-pathname file)))
#+xcl (safe-format! stream "~&Condition:~%~A~&" c)
#-xcl (print-condition-backtrace c :stream o)))
(return-from :foo nil))))
(assert (probe-file* (component-pathname file)) ()
"Can't find pathname ~S for component ~S" (component-pathname file) file)
(with-open-file (stream (component-pathname file)
:direction :output :if-exists
(or #+(and sbcl os-windows) :rename-and-delete :supersede)
...
...
@@ -188,6 +196,7 @@
:untouched)
:missing)))
test-files))
#+asdf-test-logical-pathname
(format result-stream "~&~%~% translations: ~a: ~s" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))
(format result-stream "~&~%~% variations:~% systems: ~s~% modules: ~s~% files: ~s"
systems modules files)
...
...
@@ -228,8 +237,9 @@
(root-directory-namestring (namestring root)))
(let ((systems
`(,(subpathname root "asdf-src/system1/")
,(make-pathname :host "ASDFTEST" :directory '(:absolute "system1"))
,(parse-namestring "ASDFTEST:system1;")
#+asdf-test-logical-pathname
,@'(,(make-pathname :host "ASDFTEST" :directory '(:absolute "system1"))
,(parse-namestring "ASDFTEST:system1;"))
,@(when support-string-pathnames
`(,(format nil "~{/~a~}/asdf-src/system1" (rest (pathname-directory root)))))))
(modules
...
...
@@ -238,9 +248,10 @@
,(make-pathname :directory '(:relative "module2") :name nil :type nil)
,(make-pathname :directory '(:relative "module2" "module3") :name nil :type nil)
,(subpathname root "asdf-src/system2/module4/")
,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4")
:name nil :type nil)
,(parse-namestring "ASDFTEST:system2;module4;")
#+asdf-test-logical-pathname
,@'(,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4")
:name nil :type nil)
,(parse-namestring "ASDFTEST:system2;module4;"))
,@(when support-string-pathnames
`(""
"module2"
...
...
@@ -255,23 +266,24 @@
,(strcat root-directory-namestring "asdf-src/system2/module4/")))))))
(files
`(nil
,(parse-unix-namestring "./untyped-file")
,(parse-unix-namestring "file")
#-buggy-untyped-file
,(parse-unix-namestring "./untyped-file")
#-buggy-untyped-file
,(parse-unix-namestring "file")
,(parse-unix-namestring "./file.lisp")
,(parse-unix-namestring "typed-file.type")
,(parse-unix-namestring "module2/untyped-file")
#-buggy-untyped-file
,(parse-unix-namestring "module2/untyped-file")
,(parse-unix-namestring "module2/file.lisp")
,(parse-unix-namestring "module2/module3/file.lisp")
,(subpathname root "asdf-src/system1/module1/untyped-file")
#-buggy-untyped-file
,(subpathname root "asdf-src/system1/module1/untyped-file")
,(subpathname root "asdf-src/system1/module1/file.lisp")
,(subpathname root "asdf-src/system1/module2/untyped-file")
#-buggy-untyped-file
,(subpathname root "asdf-src/system1/module2/untyped-file")
,(subpathname root "asdf-src/system1/module2/file.lisp")
,(subpathname root "asdf-src/system1/module2/module3/file.lisp")
,(subpathname root "asdf-src/system2/module4/file.lisp")
,(make-pathname :host "ASDFTEST" :device nil
:directory '(:absolute "system2" "module4")
:name "file" :type "lisp" :version nil)
,(parse-namestring "ASDFTEST:system2;module4;file.lisp")
#+asdf-test-logical-pathname
,@'(,(make-pathname :host "ASDFTEST" :device nil
:directory '(:absolute "system2" "module4")
:name "file" :type "lisp" :version nil)
,(parse-namestring "ASDFTEST:system2;module4;file.lisp"))
,@(when support-string-pathnames
`(,(strcat root-directory-namestring "asdf-src/system1/module1/file.lisp")))))
(test-files
...
...
@@ -290,11 +302,13 @@
(src-dir "system1" "module2" "module3")
(src-dir "system2" "module4")))
;; :pathname #p"untyped-file"
#-buggy-untyped-file #-buggy-untyped-file
collect (make-pathname :directory directory :name "untyped-file" :type nil
:defaults root)
;; :file "file"
collect (make-pathname :directory directory :name "file" :type "lisp"
:defaults root) ; for source files
#-buggy-untyped-file #-buggy-untyped-file
collect (make-pathname :directory directory :name "file" :type nil
:defaults root) ; for static files
;; :file "typed-file.type"
...
...
@@ -311,12 +325,13 @@
;; :file "module2/typed-file.type"
collect (make-pathname :directory directory :name "typed-file.type" :type "lisp"
:defaults root) ; for source files
;;collect (make-pathname :directory directory :name "typed-file.type" :type nil) ; for static files ;; invalid as static file, unlike the below.
;; :static-file "module2/static-file.type"
;;
collect (make-pathname :directory directory :name "typed-file.type" :type nil) ; for static files ;; invalid as static file, unlike the below.
;; :static-file "module2/static-file.type"
collect (make-pathname :directory directory :name "static-file" :type "type"
:defaults root)
;;; source file pathname variations
#-buggy-untyped-file #-buggy-untyped-file
collect (make-pathname :directory (append directory '("module2")) :name "untyped-file" :type nil
:defaults root)
collect (make-pathname :directory (append directory '("module2")) :name "file" :type "lisp"
...
...
@@ -396,16 +411,16 @@
:modules modules
:systems systems)))))
(when delete-host
(setf (logical-pathname-translations "ASDFTEST") nil))
(clear-system "test-system")))
#+asdf-test-logical-pathname
(when delete-host
(setf (logical-pathname-translations "ASDFTEST") nil))
(clear-system "test-system")))
(asdf:initialize-source-registry)
(format t "source registry: ~S~%" (hash-table->alist asdf::*source-registry*))
(asdf:initialize-output-translations)
(format t "output translations: ~S~%" (asdf::output-translations))
;;#-xcl ;;---*** pathnames are known to be massively broken on XCL
(progn
;; we're testing with unix or some emulation, are we not?
(assert-pathname-equal (resolve-location '(:home)) (truename (user-homedir-pathname)))
...
...
test/test-run-program.script
View file @
2f979dc5
...
...
@@ -11,6 +11,7 @@
(return (subseq x 0 (1- (length x)))))
x))
(DBG "Testing echo ok 1 via run-program as a list")
(assert-equal "ok 1"
(dewindowize (run-program '("echo" "ok" "1") :output '(:string :stripped t))))
...
...
uiop/image.lisp
View file @
2f979dc5
...
...
@@ -93,9 +93,10 @@ This is designed to abstract away the implementation specific quit forms."
(
defun
raw-print-backtrace
(
&key
(
stream
*debug-io*
)
count
)
"Print a backtrace, directly accessing the implementation"
(
declare
(
ignorable
stream
count
))
#+
abcl
(
dolist
(
frame
(
sys:backtrace
))
(
println
frame
stream
))
#+
(
or
abcl
xcl
)
(
loop
:for
i
:from
0
:for
frame
:in
#+
abcl
(
sys:backtrace
)
#+
xcl
(
extensions:backtrace-as-list
)
:do
(
safe-format!
stream
"~&~D: ~S~%"
i
frame
))
#+
allegro
(
let
((
*terminal-io*
stream
)
(
*standard-output*
stream
)
...
...
@@ -135,10 +136,7 @@ This is designed to abstract away the implementation specific quit forms."
#+
sbcl
(
sb-debug:backtrace
#.
(
if
(
find-symbol*
"*VERBOSITY*"
"SB-DEBUG"
nil
)
:stream
'
(
or
count
most-positive-fixnum
))
stream
)
#+
xcl
(
dolist
(
frame
(
extensions:backtrace-as-list
))
(
println
frame
stream
)))
stream
))
(
defun
print-backtrace
(
&rest
keys
&key
stream
count
)
"Print a backtrace"
...
...
uiop/run-program.lisp
View file @
2f979dc5
...
...
@@ -777,7 +777,7 @@ It returns a process-info plist with possible keys:
(
system:call-system
%command
:current-directory
directory
:wait
t
)
#-
(
and
lispworks
os-windows
)
(
with-current-directory
((
unless
(
os-unix-p
)
directory
))
#+
(
or
abcl
xcl
)
(
ext:run-shell-command
%command
)
#+
abcl
(
ext:run-shell-command
%command
)
#+
clisp
(
clisp-exit-code
(
ext:shell
%command
))
#+
cormanlisp
(
win32:system
%command
)
#+
ecl
(
let
((
*standard-input*
*stdin*
)
...
...
@@ -790,7 +790,8 @@ It returns a process-info plist with possible keys:
(
multiple-value-bind
(
io
process
exit-code
)
(
mkcl:run-program
#+
windows
%command
#+
windows
()
#-
windows
"/bin/sh"
#-
windows
(
list
"-c"
%command
)
:input
t
:output
t
)))))
:input
t
:output
t
))
#+
xcl
(
system:%run-shell-command
%command
))))
(
defun
%use-system
(
command
&rest
keys
&key
input
output
error-output
ignore-error-status
&allow-other-keys
)
...
...
uiop/stream.lisp
View file @
2f979dc5
...
...
@@ -535,13 +535,14 @@ If a string, repeatedly read and evaluate from it, returning the last values."
(
defun
call-with-temporary-file
(
thunk
&key
(
want-stream-p
t
)
(
want-pathname-p
t
)
(
direction
:io
)
keep
after
directory
prefix
suffix
type
directory
prefix
suffix
(
type
".tmp"
)
(
element-type
*default-stream-element-type*
)
(
external-format
*utf-8-external-format*
))
"Call a THUNK with stream and/or pathname arguments identifying a temporary file.
The temporary file's pathname will be based on concatenating
PREFIX (defaults to \"tmp\"), a random alphanumeric string, and optional SUFFIX and TYPE,
PREFIX (defaults to \"uiop\"), a random alphanumeric string,
and optional SUFFIX and TYPE (defaults to \".tmp\"),
within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
The file will be open with specified DIRECTION (defaults to :IO),
...
...
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