script-support.lisp 13.4 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
;;;;; Minimal life-support for testing ASDF from a blank Lisp image.
#|
Some constraints:
* We cannot rely on any test library that could be loaded by ASDF.
 And we cannot even rely on ASDF being present until we load it.
 But we *can* rely on ASDF being present *after* we load it.
* evaluating this file MUST NOT print anything,
 because we use it in the forward-ref test to check that nothing is printed.
|#

11 12 13
(defpackage :asdf-test
  (:use :common-lisp)
  (:export
14
   #:asym #:acall
15
   #:*test-directory* #:*asdf-directory*
16 17 18 19 20 21
   #:load-asdf #:maybe-compile-asdf
   #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl
   #:compile-load-asdf #:load-asdf-system
   #:register-directory #:load-test-system
   #:with-test #:test-asdf #:debug-asdf
   #:assert-compare
22
   #:assert-equal
23
   #:leave-test
24
   #:quietly))
25

26
(in-package :asdf-test)
27

28 29 30 31 32 33
(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)
		   #+(or cmu scl) (c::brevity 2)))
(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)
		     #+(or cmu scl) (c::brevity 2)))

(defvar *trace-symbols*
34 35 36
  '(;; If you want to trace some stuff while debugging ASDF,
    ;; here's a nice place to say what.
    ;; These string designators will be interned in ASDF after it is loaded.
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
    ))

(defvar *debug-asdf* nil)

;;; Minimal compatibility layer
(eval-when (:compile-toplevel :load-toplevel :execute)
  #+allegro (setf excl:*warn-on-nested-reader-conditionals* nil)

  #+gcl
  (when (or (< system::*gcl-major-version* 2)
            (and (= system::*gcl-major-version* 2)
                 (< system::*gcl-minor-version* 7)))
    (shadowing-import 'system:*load-pathname* :asdf-test)))

#+(or gcl genera)
(unless (fboundp 'ensure-directories-exist)
  (defun ensure-directories-exist (path)
    #+genera (fs:create-directories-recursively (pathname path))
55 56
    #+gcl (lisp:system (format nil "mkdir -p ~S"
                               (namestring (make-pathname :name nil :type nil :defaults path))))))
57 58 59 60 61 62 63 64 65 66 67 68 69 70

;;; Survival utilities
(defun asym (name)
  (find-symbol (string name) :asdf))
(defun acall (name &rest args)
  (apply (asym name) args))

(defun finish-outputs ()
  (loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*)
        :do (finish-output s)))
(defun redirect-outputs ()
  (finish-outputs)
  (setf *error-output* *standard-output*
        *trace-output* *standard-output*))
71

72
(redirect-outputs) ;; Put everything on standard output, for the sake of scripts
73

74 75 76 77
;;; First, some pathname madness.
;; We can't use goodies from asdf/pathnames because ASDF isn't loaded yet.
;; We still want to work despite and host/device funkiness,
;; so we do it the hard way.
78
(defparameter *test-directory*
79
  (truename
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
   (make-pathname :name nil :type nil :version nil
                  :defaults (or *load-pathname* *compile-file-pathname*))))
(defun make-sub-pathname (&rest keys &key defaults &allow-other-keys)
  (merge-pathnames (apply 'make-pathname keys) defaults))
(defun relative-dir (&rest dir) #-gcl (cons ':relative dir) #+gcl dir)
(defun back-dir () #-gcl :back #+gcl :parent)
(defparameter *asdf-directory*
  (truename (make-sub-pathname :directory (relative-dir (back-dir)) :defaults *test-directory*)))
(defparameter *build-directory*
  (make-sub-pathname :directory (relative-dir "build") :defaults *asdf-directory*))
(defparameter *implementation*
  (or #+allegro
      (ecase excl:*current-case-mode*
        (:case-sensitive-lower :mlisp)
        (:case-insensitive-upper :alisp))
      #+armedbear :abcl
      #+clisp :clisp
      #+clozure :ccl
      #+cmu :cmucl
      #+corman :cormanlisp
      #+digitool :mcl
      #+ecl :ecl
      #+gcl :gcl
      #+lispworks :lispworks
      #+mkcl :mkcl
      #+sbcl :sbcl
      #+scl :scl
      #+xcl :xcl))
(defparameter *early-fasl-directory*
  (make-sub-pathname :directory (relative-dir "fasls" (string-downcase *implementation*))
                     :defaults *build-directory*))

(defun asdf-name (&optional tag)
  (format nil "asdf~@[-~A~]" tag))
(defun asdf-lisp (&optional tag)
  (make-pathname :name (asdf-name tag) :type "lisp" :defaults *build-directory*))
(defun debug-lisp ()
  (make-sub-pathname :directory (relative-dir "contrib") :name "debug" :type "lisp" :defaults *asdf-directory*))
(defun early-compile-file-pathname (file)
119
  (compile-file-pathname
120 121 122
   (make-pathname :name (pathname-name file) :type "lisp" :defaults *early-fasl-directory*)))
(defun asdf-fasl (&optional tag)
  (early-compile-file-pathname (asdf-lisp tag)))
123

124 125 126 127 128 129 130 131 132 133 134 135 136 137 138

;;; Test helper functions

(defmacro assert-compare (expr)
  (destructuring-bind (op x y) expr
    `(assert-compare-helper ',op ',x ',y ,x ,y)))

(defun assert-compare-helper (op qx qy x y)
  (unless (funcall op x y)
    (error "These two expressions fail comparison with ~S:~%~
            ~S evaluates to ~S~% ~S evaluates to ~S~%"
            op qx x qy y)))

(defmacro assert-equal (x y)
  `(assert-compare (equal ,x ,y)))
139

140 141 142
(defun touch-file (file &key (offset 0) timestamp)
  (let ((timestamp (or timestamp (+ offset (get-universal-time)))))
    (multiple-value-bind (sec min hr day month year) (decode-universal-time timestamp)
143 144 145
      (acall :run-shell-command
             "touch -t ~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D ~S"
             year month day hr min sec (namestring file)))))
146

147 148 149 150
(defun hash-table->alist (table)
  (loop :for key :being :the :hash-keys :of table :using (:hash-value value)
    :collect (cons key value)))

151

152 153 154 155 156 157 158 159 160 161 162 163 164 165
(defun exit-lisp (&optional (code 0)) ;; Simplified from asdf/image:quit
  (finish-outputs)
  #+(or abcl xcl) (ext:quit :status code)
  #+allegro (excl:exit code :quiet t)
  #+clisp (ext:quit code)
  #+clozure (ccl:quit code)
  #+cormanlisp (win32:exitprocess code)
  #+(or cmu scl) (unix:unix-exit code)
  #+ecl (si:quit code)
  #+gcl (lisp:quit code)
  #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
  #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
  #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
  #+mkcl (mk-ext:quit :exit-code code)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
166
  #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext))
167 168 169 170 171 172
		 (quit (find-symbol "QUIT" :sb-ext)))
	     (cond
	       (exit `(,exit :code code :abort t))
	       (quit `(,quit :unix-status code :recklessly-p t))))
  #-(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))
173 174


175
(defun leave-test (message return)
176
  (finish-outputs)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
177 178 179
  (fresh-line *error-output*)
  (when message
    (format *error-output* message)
180
    (fresh-line *error-output*))
181
  (finish-outputs)
182
  (throw :asdf-test-done return))
183

184 185
(defmacro with-test (() &body body)
  `(call-with-test (lambda () ,@body)))
186

187
(defun call-with-test (thunk)
Robert P. Goldman's avatar
 
Robert P. Goldman committed
188 189 190
  "Unless the environment variable DEBUG_ASDF_TEST
is bound, write a message and exit on an error.  If
*asdf-test-debug* is true, enter the debugger."
191
  (redirect-outputs)
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
  (let ((result
          (catch :asdf-test-done
            (handler-bind
                ((error (lambda (c)
                          (format *error-output* "~&TEST ABORTED: ~A~&" c)
                          (finish-outputs)
                          (cond
                            (*debug-asdf* (break))
                            (t
                             (acall :print-condition-backtrace
                                    c :count 69 :stream *error-output*)
                             (leave-test "Script failed" 1))))))
              (funcall thunk)
              (leave-test "Script succeeded" 0)))))
    (unless *debug-asdf*
      (exit-lisp result))))
208 209 210 211 212 213 214 215 216 217

;;; These are used by the upgrade tests

(defmacro quietly (&body body)
  `(call-quietly #'(lambda () ,@body)))

(defun call-quietly (thunk)
  (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning))
    (funcall thunk)))

218 219
(defun load-asdf-lisp (&optional tag)
  (quietly (load (asdf-lisp tag))))
220

221 222
(defun load-asdf-fasl (&optional tag)
  (quietly (load (asdf-fasl tag))))
223 224

(defun register-directory (dir)
225
  (pushnew dir (symbol-value (asym :*central-registry*))))
226

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
227
(defun load-asdf-system (&rest keys)
228 229
  (quietly
   (register-directory *asdf-directory*)
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318
   (apply (asym :oos) (asym :load-op) :asdf keys)))

(defun compile-asdf (&optional tag verbose)
  (let* ((alisp (asdf-lisp tag))
         (afasl (asdf-fasl tag))
         (tmp (make-pathname :name "asdf-tmp" :defaults afasl)))
    (ensure-directories-exist afasl)
    (multiple-value-bind (result warnings-p errors-p)
        (handler-bind (#+sbcl
                       ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning)
                         #'muffle-warning)
                       #+(and ecl (not ecl-bytecmp))
                       ((or c:compiler-note c::compiler-debug-note
                            c:compiler-warning) ;; ECL emits more serious warnings than it should.
                         #'muffle-warning)
                       #+mkcl
                       ((or compiler:compiler-note) #'muffle-warning)
                       #-(or cmu scl)
                       ;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
                       (style-warning
                         #'(lambda (w)
                             ;; escalate style-warnings to warnings - we don't want them.
                             (when verbose
                               (warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A"
                                     (type-of w) w))
                             (muffle-warning w))))
          (compile-file alisp :output-file tmp #-gcl :verbose #-gcl verbose :print verbose))
      (flet ((bad (key)
               (when result (ignore-errors (delete-file result)))
               key)
             (good (key)
               (when (probe-file afasl) (delete-file afasl))
               (rename-file tmp afasl)
               key))
        (cond
          (errors-p (bad :errors))
          (warnings-p
           (or
            ;; ECL 11.1.1 has spurious warnings, same with XCL 0.0.0.291.
            ;; SCL has no warning but still raises the warningp flag since 2.20.15 (?)
            #+(or cmu ecl scl xcl) (good :expected-warnings)
            (bad :unexpected-warnings)))
          (t (good :success)))))))

(defun maybe-compile-asdf (&optional tag)
  (let ((alisp (asdf-lisp tag))
        (afasl (asdf-fasl tag)))
    (cond
      ((not (probe-file alisp))
       :not-found)
      ((and (probe-file afasl)
            (> (file-write-date afasl) (file-write-date alisp))
            (ignore-errors (load-asdf-fasl tag)))
       :previously-compiled)
      (t
       (load-asdf-lisp tag)
       (compile-asdf tag)))))

(defun compile-asdf-script ()
  (with-test ()
    (ecase (maybe-compile-asdf)
      (:not-found
       (leave-test "Testsuite failed: unable to find ASDF source" 3))
      (:previously-compiled
       (leave-test "Reusing previously-compiled ASDF" 0))
      (:errors
       (leave-test "Testsuite failed: ASDF compiled with ERRORS" 2))
      (:unexpected-warnings
       (leave-test "Testsuite failed: ASDF compiled with unexpected warnings" 1))
      (:expected-warnings
       (leave-test "ASDF compiled with warnings, ignored for your implementation" 0))
      (:success
       (leave-test "ASDF compiled cleanly" 0)))))

(defun compile-load-asdf (&optional tag)
  ;; emulate the way asdf upgrades itself: load source, compile, load fasl.
  (load-asdf-lisp tag)
  (ecase (compile-asdf tag)
    ((:errors :unexpected-warnings) (leave-test "failed to compile ASDF" 1))
    ((:expected-warnings :success)
     (load-asdf-fasl tag))))

;;; Now, functions to compile and load ASDF.

(defun load-test-system (x &key verbose)
  (let ((*load-print* verbose)
        (*load-verbose* verbose))
    (register-directory *test-directory*)
    (acall :oos (asym :load-op) x :verbose verbose)))
319 320

(defun testing-asdf (thunk)
321
  (with-test ()
322 323
    (funcall thunk)
    (register-directory *test-directory*)
324
    (load-test-system :test-module-depend)))
325

326
(defmacro test-asdf (&body body) ;; used by test-upgrade
327
  `(testing-asdf #'(lambda () ,@body)))
328

329 330 331 332 333 334 335 336
(defun configure-asdf ()
  (untrace)
  (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST")))
  (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s))))
  (acall :initialize-source-registry
         `(:source-registry :ignore-inherited-configuration))
  (acall :initialize-output-translations
         `(:output-translations
337
           ((,*test-directory* :**/ :*.*.*) (,*asdf-directory* "build/fasls" :implementation "test"))
338 339 340 341 342 343 344 345 346 347 348 349 350
           (t (,*asdf-directory* "build/fasls" :implementation "root"))
           :ignore-inherited-configuration))
  (set (asym :*central-registry*) `(,*test-directory*))
  (set (asym :*verbose-out*) *standard-output*)
  (set (asym :*asdf-verbose*) t))

(defun load-asdf (&optional tag)
  (setf *package* (find-package :asdf-test))
  (load (debug-lisp))
  (load-asdf-fasl tag)
  (use-package :asdf :asdf-test)
  (configure-asdf)
  (setf *package* (find-package :asdf-test)))
351

352 353 354 355 356 357 358 359 360 361 362 363 364
(defun debug-asdf ()
  (setf *debug-asdf* t)
  (setf *package* (find-package :asdf-test)))

(defun common-lisp-user::load-asdf ()
  (load-asdf))
(defun common-lisp-user::debug-asdf ()
  (debug-asdf))

#| The following form is sometimes useful to insert in compute-action-stamp to find out what's happening.
It depends on the DBG macro in contrib/debug.lisp, that you should load in your ASDF.

#+DBG-ASDF (DBG :cas o c just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c))
365
|#