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

parent 9d5f5148
 ... ... @@ -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)) ;;; 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: (!a ... ...
 ... ... @@ -15,21 +15,21 @@ (defparameter mlccso (make-operation 'monolithic-load-compiled-concatenated-source-op)) (defparameter sys (find-system :test-concatenate-source)) (assert (operation-monolithic-p mcso)) (assert-equal ;; on CLISP, we get un-equal pathnames with same namestrings. Sigh. (princ-to-string (input-files mcso sys)) (princ-to-string (loop :for n :in '(3 1 2) :collect (test-source (format nil "file~D.lisp" n))))) (assert-equal (assert-pathnames-equal (input-files mcso sys) (loop :for n :in '(3 1 2) :collect (test-source (format nil "file~D.lisp" n)))) (assert-pathname-equal (output-file mcso sys) (apply-output-translations (resolve-output "asdf/test/test-concatenate-source.all-systems.lisp"))) (assert-equal (assert-pathname-equal (output-files mcso sys) (input-files mccso sys)) (assert-equal ;; on ECL, we get un-equal pathnames. (princ-to-string (output-file mccso sys)) (princ-to-string (test-fasl "test-concatenate-source.all-systems.lisp"))) (assert-equal ;; on ECL, we get un-equal pathnames. (assert-pathname-equal (output-file mccso sys) (test-fasl "test-concatenate-source.all-systems.lisp")) (assert-pathname-equal (output-files mccso sys) (input-files mlccso sys)) (operate 'monolithic-load-compiled-concatenated-source-op sys) ... ...
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
{"ft_lang_label":"__label__en","ft_lang_prob":0.53962797,"math_prob":0.9096935,"size":3384,"snap":"2020-45-2020-50","text_gpt3_token_len":1021,"char_repetition_ratio":0.1781065,"word_repetition_ratio":0.10232558,"special_character_ratio":0.320922,"punctuation_ratio":0.16282642,"nsfw_num_words":0,"has_unicode_error":false,"math_prob_llama3":0.99152344,"pos_list":[0],"im_url_duplicate_count":[null],"WARC_HEADER":"{\"WARC-Type\":\"response\",\"WARC-Date\":\"2020-10-29T17:18:27Z\",\"WARC-Record-ID\":\"<urn:uuid:ebf60685-c909-4715-9ecf-f15e2bfec37d>\",\"Content-Length\":\"178443\",\"Content-Type\":\"application/http; msgtype=response\",\"WARC-Warcinfo-ID\":\"<urn:uuid:e3d08e26-d636-4cc0-ba34-c665496d65c2>\",\"WARC-Concurrent-To\":\"<urn:uuid:1a086139-a095-45b8-918b-06057ec5653c>\",\"WARC-IP-Address\":\"148.251.208.23\",\"WARC-Target-URI\":\"https://gitlab.common-lisp.net/asdf/asdf/commit/3334b3c095edd02c5c45f84a4f61194e097a389f\",\"WARC-Payload-Digest\":\"sha1:3J6BFRFIYASCZAHFBA3WF2XQ5TFZADIV\",\"WARC-Block-Digest\":\"sha1:TZHCYWX44MJI554PQ6QKBX5AC55JCZUX\",\"WARC-Identified-Payload-Type\":\"text/html\",\"warc_filename\":\"/cc_download/warc_2020/CC-MAIN-2020-45/CC-MAIN-2020-45_segments_1603107904834.82_warc_CC-MAIN-20201029154446-20201029184446-00257.warc.gz\"}"}