Newer
Older
Francois-Rene Rideau
committed
(declaim (optimize (speed 2) (safety 3) #-allegro (debug 3)))
(proclaim '(optimize (speed 2) (safety 3) #-allegro (debug 3)))
;; 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*))
#+allegro
(setf excl:*warn-on-nested-reader-conditionals* nil)
(defun native-namestring (x)
(let* ((p (pathname x)))
#+clozure (ccl:native-translated-namestring p)
#+(or cmu scl) (ext:unix-namestring p)
#+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
(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)
(leave-lisp "~&Script failed~%" 1))))))
(funcall thunk)
(leave-lisp "~&Script succeeded~%" 0)))