Skip to content
Snippets Groups Projects
Commit 3334b3c0 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Fix tests that compare pathnames that are pathname-equal but not equal (!)

parent 9d5f5148
No related branches found
No related tags found
No related merge requests found
...@@ -447,6 +447,48 @@ is bound, write a message and exit on an error. If ...@@ -447,6 +447,48 @@ is bound, write a message and exit on an error. If
(defun in-plan-p (plan x) (member x plan :key (asym :action-path) :test 'equal)) (defun in-plan-p (plan x) (member x plan :key (asym :action-path) :test 'equal))
;;; Helpful for debugging
(defun pathname-components (p)
(when p
(let ((p (pathname p)))
(list :host (pathname-host p)
:device (pathname-device p)
:directory (pathname-directory p)
:name (pathname-name p)
:type (pathname-type p)
:version (pathname-version p)))))
(defun assert-pathname-equal-helper (qx x qy y)
(cond
((equal x y)
(format t "~S and ~S both evaluate to same path:~% ~S~%" qx qy x))
((acall :pathname-equal x y)
(format t "These two expressions yield pathname-equal yet not equal path~% ~S~%" x)
(format t "the first expression ~S yields this:~% ~S~%" qx (pathname-components x))
(format t "the other expression ~S yields that:~% ~S~%" qy (pathname-components y)))
(t
(format t "These two expressions yield paths that are not pathname-equal~%")
(format t "the first expression ~S yields this:~% ~S~% ~S~%" qx x (pathname-components x))
(format t "the other expression ~S yields that:~% ~S~% ~S~%" qy y (pathname-components y)))))
(defmacro assert-pathname-equal (x y)
`(assert-pathname-equal-helper ',x ,x ',y ,y))
(defun assert-length-equal-helper (qx qy x y)
(unless (= (length x) (length y))
(format t "These two expressions yield sequences of unequal length~%")
(format t "The first, ~S, has value ~S of length ~S~%" qx x (length x))
(format t "The other, ~S, has value ~S of length ~S~%" qy y (length y))))
(defun assert-pathnames-equal-helper (qx x qy y)
(assert-length-equal-helper qx x qy y)
(loop :for n :from 0
:for qpx = `(nth ,n ,qx)
:for qpy = `(nth ,n ,qy)
:for px :in x
:for py :in y :do
(assert-pathname-equal-helper qpx px qpy py)))
(defmacro assert-pathnames-equal (x y)
`(assert-pathnames-equal-helper ',x ,x ',y ,y))
;; These are shorthands for interactive debugging of test scripts: ;; These are shorthands for interactive debugging of test scripts:
(!a (!a
......
...@@ -15,21 +15,21 @@ ...@@ -15,21 +15,21 @@
(defparameter mlccso (make-operation 'monolithic-load-compiled-concatenated-source-op)) (defparameter mlccso (make-operation 'monolithic-load-compiled-concatenated-source-op))
(defparameter sys (find-system :test-concatenate-source)) (defparameter sys (find-system :test-concatenate-source))
(assert (operation-monolithic-p mcso)) (assert (operation-monolithic-p mcso))
(assert-equal ;; on CLISP, we get un-equal pathnames with same namestrings. Sigh. (assert-pathnames-equal
(princ-to-string (input-files mcso sys)) (input-files mcso sys)
(princ-to-string (loop :for n :in '(3 1 2) (loop :for n :in '(3 1 2) :collect (test-source (format nil "file~D.lisp" n))))
:collect (test-source (format nil "file~D.lisp" n))))) (assert-pathname-equal
(assert-equal
(output-file mcso sys) (output-file mcso sys)
(apply-output-translations (apply-output-translations
(resolve-output "asdf/test/test-concatenate-source.all-systems.lisp"))) (resolve-output "asdf/test/test-concatenate-source.all-systems.lisp")))
(assert-equal (assert-pathname-equal
(output-files mcso sys) (output-files mcso sys)
(input-files mccso sys)) (input-files mccso sys))
(assert-equal ;; on ECL, we get un-equal pathnames. ;; on ECL, we get un-equal pathnames.
(princ-to-string (output-file mccso sys)) (assert-pathname-equal
(princ-to-string (test-fasl "test-concatenate-source.all-systems.lisp"))) (output-file mccso sys)
(assert-equal (test-fasl "test-concatenate-source.all-systems.lisp"))
(assert-pathname-equal
(output-files mccso sys) (output-files mccso sys)
(input-files mlccso sys)) (input-files mlccso sys))
(operate 'monolithic-load-compiled-concatenated-source-op sys) (operate 'monolithic-load-compiled-concatenated-source-op sys)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment