;;;;; 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. |# (defpackage :asdf-test (:use :common-lisp) (:export #:asym #:acall #:*test-directory* #:*asdf-directory* #: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 #:assert-equal #:leave-test #:quietly)) (in-package :asdf-test) (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* `(;; 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. )) (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)) #+gcl (lisp:system (format nil "mkdir -p ~S" (namestring (make-pathname :name nil :type nil :defaults path)))))) ;;; Survival utilities (defun asym (name) (let ((asdf (find-package :asdf))) (unless asdf (error "Can't find package ASDF")) (or (find-symbol (string name) asdf) (error "Can't find symbol ~A in ASDF" name)))) (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*)) (redirect-outputs) ;; Put everything on standard output, for the sake of scripts ;;; 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. (defparameter *test-directory* (truename (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 (or #+ecl-bytecmp :ecl_bytecodes :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) (compile-file-pathname (make-pathname :name (pathname-name file) :type "lisp" :defaults *early-fasl-directory*))) (defun asdf-fasl (&optional tag) (early-compile-file-pathname (asdf-lisp tag))) ;;; 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))) (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) (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))))) (defun hash-table->alist (table) (loop :for key :being :the :hash-keys :of table :using (:hash-value value) :collect (cons key value))) (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) #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext)) (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)) (defun leave-test (message return) (finish-outputs) (fresh-line *error-output*) (when message (format *error-output* message) (fresh-line *error-output*)) (finish-outputs) (throw :asdf-test-done return)) (defmacro with-test ((&optional) &body body) `(call-with-test (lambda () ,@body))) (defun call-with-test (thunk) "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." (redirect-outputs) (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)))) ;;; 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))) (defun load-asdf-lisp (&optional tag) (quietly (load (asdf-lisp tag)))) (defun load-asdf-fasl (&optional tag) (quietly (load (asdf-fasl tag)))) (defun register-directory (dir) (pushnew dir (symbol-value (asym :*central-registry*)))) (defun load-asdf-system (&rest keys) (quietly (register-directory *asdf-directory*) (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))) (defun testing-asdf (thunk) (with-test () (funcall thunk) (register-directory *test-directory*) (load-test-system :test-module-depend))) (defmacro test-asdf (&body body) ;; used by test-upgrade `(testing-asdf #'(lambda () ,@body))) (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 ((,*test-directory* :**/ :*.*.*) (,*asdf-directory* "build/fasls" :implementation "test")) (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))) (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)) |#