Commit 40f7802a authored by Gary King's avatar Gary King
Browse files

Test improvements from Fare Rideau.

* work with Common Lisp Controller by disabling it for testing

* tweak test-retry-loading-component test

* tweak test-module-pathnames for CLISP (which can return
  `nil` for component's relative-pathname)

* refactor `component-relative-pathname` for source-file's
  slightly
parent e2e973c0
......@@ -763,32 +763,20 @@ to `~a` which is not a directory.~@:>"
(defmethod source-file-type ((c html-file) (s module)) "html")
(defmethod source-file-type ((c static-file) (s module)) nil)
#+(or)
(defmethod component-relative-pathname ((component source-file))
(multiple-value-bind (relative path name)
(split-path-string (component-name component))
(let ((type (source-file-type component (component-system component)))
(relative-pathname (slot-value component 'relative-pathname))
(*default-pathname-defaults* (component-parent-pathname component)))
(if relative-pathname
(merge-pathnames
relative-pathname
(if type
(make-pathname :name name :type type)
name))
(make-pathname :directory `(,relative ,@path) :name name :type type)))))
(defun merge-component-relative-pathname (pathname name type)
(multiple-value-bind (relative path filename)
(split-path-string name)
(merge-pathnames
(or pathname (make-pathname :directory `(,relative ,@path)))
(if type
(make-pathname :name filename :type type)
filename))))
(defmethod component-relative-pathname ((component source-file))
(multiple-value-bind (relative path name)
(split-path-string (component-name component))
(let ((type (source-file-type component (component-system component)))
(relative-pathname (slot-value component 'relative-pathname)))
(merge-pathnames
(or relative-pathname (make-pathname :directory `(,relative ,@path)))
(if type
(make-pathname :name name :type type)
name)))))
(merge-component-relative-pathname
(slot-value component 'relative-pathname)
(component-name component)
(source-file-type component (component-system component))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operations
......
......@@ -3,6 +3,9 @@
#+allegro
(setf excl:*warn-on-nested-reader-conditionals* nil)
#+common-lisp-controller
(setf common-lisp-controller:*redirect-fasl-files-to-cache* nil)
;;; code adapted from cl-launch (any errors in transcription are mine!)
;; http://www.cliki.net/cl-launch
(defun leave-lisp (message return)
......
......@@ -14,8 +14,9 @@
(level1 (submodule system "sources/level1"))
(static (submodule level1 "level2/static.file"))
(test-tmp (submodule level1 "test-tmp.cl")))
(assert (equal (pathname-foo (asdf:component-relative-pathname test-tmp))
'((:relative) "test-tmp" "cl"))
(assert (member (pathname-foo (asdf:component-relative-pathname test-tmp))
'(((:relative) "test-tmp" "cl")
(nil "test-tmp" "cl")) :test 'equal)
nil
"Didn't get the name of test-tmp.cl right")
(assert (equal
......
......@@ -25,6 +25,7 @@
(assert (eq mode :external) nil "Mode of ~s was not external" name)
(let ((restart (find-restart name c)))
(assert restart)
(format t "~&restart: ~S~&" restart)
(when restart (invoke-restart restart)))))))
(asdf:oos 'asdf:load-op 'try-reloading-1))
(assert *caught-error*)
......
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