Newer
Older
(defpackage :asdf-test (:use :common-lisp))
(in-package #:asdf-test)
Francois-Rene Rideau
committed
(declaim (optimize (speed 2) (safety 3) #-allegro (debug 3)))
(proclaim '(optimize (speed 2) (safety 3) #-allegro (debug 3)))
(format t "Evaluating asdf/test/script-support~%")
;; We can't use asdf:merge-pathnames* because ASDF isn't loaded yet.
;; We still want to work despite and host/device funkiness.
(defparameter *test-directory*
(make-pathname :name nil :type nil :version nil
:defaults (or *load-truename* *compile-file-truename*)))
(defparameter *asdf-directory*
(merge-pathnames
(make-pathname :directory '(:relative :back) :defaults *test-directory*)
*test-directory*))
(defparameter *asdf-lisp*
(make-pathname :name "asdf" :type "lisp" :defaults *asdf-directory*))
(defparameter *asdf-fasl*
(compile-file-pathname
(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
#+sbcl :sbcl
#+scl :scl
#+xcl :xcl))))
(merge-pathnames
(make-pathname :directory `(:relative "tmp" "fasls" ,impl)
:defaults *asdf-directory*)
(defun load-asdf ()
(load *asdf-fasl*)
(use-package :asdf :asdf-test)
(setf *package* (find-package :asdf-test)))
(defun common-lisp-user::load-asdf ()
(load-asdf))
#+allegro
(setf excl:*warn-on-nested-reader-conditionals* nil)
(let ((p (pathname x)))
#+(or cmu scl) (ext:unix-namestring p nil)
#+sbcl (sb-ext:native-namestring p)
#-(or clozure cmu sbcl scl) (namestring p)))
;;; code adapted from cl-launch http://www.cliki.net/cl-launch
Francois-Rene Rideau
committed
(fresh-line *error-output*)
(format *error-output* message)
(terpri *error-output*))
(finish-output *error-output*)
(finish-output *standard-output*)
#+allegro
(excl:exit return)
#+clisp
(ext:quit return)
#+(or cmu scl)
Francois-Rene Rideau
committed
#+ecl
(lispworks:quit :status return :confirm nil :return nil :ignore-errors-p t)
#+(or openmcl mcl)
(ccl::quit return)
#+sbcl
(sb-ext:quit :unix-status return)
Francois-Rene Rideau
committed
#+(or abcl xcl)
(error "Don't know how to quit Lisp; wanting to use exit code ~a" return))
(defmacro quit-on-error (&body body)
`(call-quitting-on-error (lambda () ,@body)))
(defun call-quitting-on-error (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."
(handler-bind
((error (lambda (c)
(format *error-output* "~&~a~&" c)
(cond
((ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST"))
(break))
(t
(finish-output *standard-output*)
(finish-output *trace-output*)
(format *error-output* "~&ABORTING:~% ~S~%" c)
#+sbcl (sb-debug:backtrace 69)
#+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
#+clisp (system::print-backtrace)
(format *error-output* "~&ABORTING:~% ~S~%" c)
(finish-output *error-output*)
(leave-lisp "~&Script failed~%" 1))))))
(funcall thunk)
(leave-lisp "~&Script succeeded~%" 0)))
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
;;; 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 ()
(load *asdf-lisp*))
(defun compile-asdf ()
(ensure-directories-exist *asdf-fasl*)
(compile-file *asdf-lisp* :output-file *asdf-fasl* :verbose t :print t))
(defun load-asdf-fasl ()
(load *asdf-fasl*))
(defun compile-load-asdf ()
;; emulate the way asdf upgrades itself: load source, compile, load fasl.
(load-asdf-lisp)
(compile-asdf)
(load-asdf-fasl))
(defun register-directory (dir)
(pushnew dir (symbol-value (find-symbol (string :*central-registry*) :asdf))))
(defun asdf-load (x)
(let ((xoos (find-symbol (string :oos) :asdf))
(xload-op (find-symbol (string :load-op) :asdf)))
(funcall xoos xload-op x :verbose t)))
(defun load-asdf-system ()
(quietly
(register-directory *asdf-directory*)
(asdf-load :asdf)))
(defun testing-asdf (thunk)
(quit-on-error
(quietly
(funcall thunk)
(register-directory *test-directory*)
(asdf-load :test-module-depend))))
(defmacro test-asdf (&body body)
`(testing-asdf #'(lambda () ,@body)))