Loading test/script-support.lisp +18 −16 Original line number Original line Diff line number Diff line Loading @@ -32,9 +32,9 @@ Some constraints: (in-package :asdf-test) (in-package :asdf-test) (declaim (optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3) (declaim (optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3) #+(or cmu scl) (c::brevity 2))) #+(or cmu scl) (c::brevity 2))) (proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3) (proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3) #+(or cmu scl) (c::brevity 2))) #+(or cmu scl) (c::brevity 2))) (defvar *trace-symbols* (defvar *trace-symbols* `(;; If you want to trace some stuff while debugging ASDF, `(;; If you want to trace some stuff while debugging ASDF, Loading Loading @@ -123,23 +123,23 @@ Some constraints: (format t "~S and ~S both evaluate to same path:~% ~S~%" qx qy x)) (format t "~S and ~S both evaluate to same path:~% ~S~%" qx qy x)) ((acall :pathname-equal x y) ((acall :pathname-equal x y) (warn "These two expressions yield pathname-equal yet not equal path~%~ (warn "These two expressions yield pathname-equal yet not equal path~%~ the first expression ~S yields this:~% ~S~% ~S~% the first expression ~S yields this:~% ~S~% ~S~% the other expression ~S yields that:~% ~S~% ~S~%" the other expression ~S yields that:~% ~S~% ~S~%" qx x (pathname-components x) qx x (pathname-components x) qy y (pathname-components y))) qy y (pathname-components y))) (t (t (error "These two expressions yield paths that are not pathname-equal~%~ (error "These two expressions yield paths that are not pathname-equal~%~ the first expression ~S yields this:~% ~S~% ~S~% the first expression ~S yields this:~% ~S~% ~S~% the other expression ~S yields that:~% ~S~% ~S~%" the other expression ~S yields that:~% ~S~% ~S~%" qx x (pathname-components x) qx x (pathname-components x) qy y (pathname-components y))))) qy y (pathname-components y))))) (defmacro assert-pathname-equal (x y) (defmacro assert-pathname-equal (x y) `(assert-pathname-equal-helper ',x ,x ',y ,y)) `(assert-pathname-equal-helper ',x ,x ',y ,y)) (defun assert-length-equal-helper (qx x qy y) (defun assert-length-equal-helper (qx x qy y) (unless (= (length x) (length y)) (unless (= (length x) (length y)) (error "These two expressions yield sequences of unequal length~% (error "These two expressions yield sequences of unequal length~% The first, ~S, has value ~S of length ~S~% The first, ~S, has value ~S of length ~S~% The other, ~S, has value ~S of length ~S~%" The other, ~S, has value ~S of length ~S~%" qx x (length x) qy y (length y)))) qx x (length x) qy y (length y)))) (defun assert-pathnames-equal-helper (qx x qy y) (defun assert-pathnames-equal-helper (qx x qy y) (assert-length-equal-helper qx x qy y) (assert-length-equal-helper qx x qy y) Loading Loading @@ -259,15 +259,17 @@ Some constraints: #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? #+mkcl (mk-ext:quit :exit-code code) #+mkcl (mk-ext:quit :exit-code code) #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext)) #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext)) (quit* (find-symbol "QUIT" :sb-ext))) (quit* (find-symbol "QUIT" :sb-ext))) (cond (cond (exit `(,exit :code code :abort t)) (exit `(,exit :code code :abort t)) (quit* `(,quit* :unix-status code :recklessly-p t)))) (quit* `(,quit* :unix-status code :recklessly-p t)))) #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (defun leave-test (message return) (defun leave-test (message return) "Print MESSAGE and throw RETURN, which should be a POSIX error code (an integer, 0 for success), up as exit code." (finish-outputs*) (finish-outputs*) (fresh-line *error-output*) (fresh-line *error-output*) (when message (when message Loading Loading
test/script-support.lisp +18 −16 Original line number Original line Diff line number Diff line Loading @@ -32,9 +32,9 @@ Some constraints: (in-package :asdf-test) (in-package :asdf-test) (declaim (optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3) (declaim (optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3) #+(or cmu scl) (c::brevity 2))) #+(or cmu scl) (c::brevity 2))) (proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3) (proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3) #+(or cmu scl) (c::brevity 2))) #+(or cmu scl) (c::brevity 2))) (defvar *trace-symbols* (defvar *trace-symbols* `(;; If you want to trace some stuff while debugging ASDF, `(;; If you want to trace some stuff while debugging ASDF, Loading Loading @@ -123,23 +123,23 @@ Some constraints: (format t "~S and ~S both evaluate to same path:~% ~S~%" qx qy x)) (format t "~S and ~S both evaluate to same path:~% ~S~%" qx qy x)) ((acall :pathname-equal x y) ((acall :pathname-equal x y) (warn "These two expressions yield pathname-equal yet not equal path~%~ (warn "These two expressions yield pathname-equal yet not equal path~%~ the first expression ~S yields this:~% ~S~% ~S~% the first expression ~S yields this:~% ~S~% ~S~% the other expression ~S yields that:~% ~S~% ~S~%" the other expression ~S yields that:~% ~S~% ~S~%" qx x (pathname-components x) qx x (pathname-components x) qy y (pathname-components y))) qy y (pathname-components y))) (t (t (error "These two expressions yield paths that are not pathname-equal~%~ (error "These two expressions yield paths that are not pathname-equal~%~ the first expression ~S yields this:~% ~S~% ~S~% the first expression ~S yields this:~% ~S~% ~S~% the other expression ~S yields that:~% ~S~% ~S~%" the other expression ~S yields that:~% ~S~% ~S~%" qx x (pathname-components x) qx x (pathname-components x) qy y (pathname-components y))))) qy y (pathname-components y))))) (defmacro assert-pathname-equal (x y) (defmacro assert-pathname-equal (x y) `(assert-pathname-equal-helper ',x ,x ',y ,y)) `(assert-pathname-equal-helper ',x ,x ',y ,y)) (defun assert-length-equal-helper (qx x qy y) (defun assert-length-equal-helper (qx x qy y) (unless (= (length x) (length y)) (unless (= (length x) (length y)) (error "These two expressions yield sequences of unequal length~% (error "These two expressions yield sequences of unequal length~% The first, ~S, has value ~S of length ~S~% The first, ~S, has value ~S of length ~S~% The other, ~S, has value ~S of length ~S~%" The other, ~S, has value ~S of length ~S~%" qx x (length x) qy y (length y)))) qx x (length x) qy y (length y)))) (defun assert-pathnames-equal-helper (qx x qy y) (defun assert-pathnames-equal-helper (qx x qy y) (assert-length-equal-helper qx x qy y) (assert-length-equal-helper qx x qy y) Loading Loading @@ -259,15 +259,17 @@ Some constraints: #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? #+mkcl (mk-ext:quit :exit-code code) #+mkcl (mk-ext:quit :exit-code code) #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext)) #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext)) (quit* (find-symbol "QUIT" :sb-ext))) (quit* (find-symbol "QUIT" :sb-ext))) (cond (cond (exit `(,exit :code code :abort t)) (exit `(,exit :code code :abort t)) (quit* `(,quit* :unix-status code :recklessly-p t)))) (quit* `(,quit* :unix-status code :recklessly-p t)))) #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (defun leave-test (message return) (defun leave-test (message return) "Print MESSAGE and throw RETURN, which should be a POSIX error code (an integer, 0 for success), up as exit code." (finish-outputs*) (finish-outputs*) (fresh-line *error-output*) (fresh-line *error-output*) (when message (when message Loading