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
Loading
Loading
Loading
Loading
+12 −24
Original line number Diff line number Diff line
@@ -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
(defun merge-component-relative-pathname (pathname name type)
  (multiple-value-bind (relative path filename)
      (split-path-string name)
  (merge-pathnames
         relative-pathname
   (or pathname (make-pathname :directory `(,relative ,@path)))
   (if type
           (make-pathname :name name :type type)
           name))
        (make-pathname :directory `(,relative ,@path) :name name :type 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 −0
Original line number Diff line number Diff line
@@ -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)
+3 −2
Original line number Diff line number Diff line
@@ -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
+1 −0
Original line number Diff line number Diff line
@@ -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*)