Commit 2f979dc5 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Support XCL again, by working around implementation bugs, documented in TODO.

parent 8e5e42f2
......@@ -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}
......
......@@ -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
......
......@@ -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.
......
......@@ -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)))
......
......@@ -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))))
......
......@@ -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"
......
......@@ -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)
......
......@@ -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),
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment