script-support.lisp 2.92 KB
Newer Older
1
2
(in-package #:common-lisp-user)

3
4
5
6
7
8
9
10
11
12
;; We can't use asdf:merge-pathnames* because ASDF isn't loaded yet.
;; We still want to work despite and host/device funkiness.
(defvar *asdf-lisp*
  (truename
   (merge-pathnames
    (make-pathname :directory '(:relative :up) :name "asdf" :type "lisp"
                   :defaults *load-truename*)
    *load-truename*)))
(defvar *asdf-fasl*
  (compile-file-pathname
Francois-Rene Rideau's avatar
1.647:    
Francois-Rene Rideau committed
13
   (let ((impl (string-downcase
14
15
16
17
                (or #+allegro
                    (ecase excl:*current-case-mode*
                      (:case-sensitive-lower :mlisp)
                      (:case-sensitive-upper :alisp))
18
19
20
21
22
23
24
25
26
27
28
                    #+armedbear :abcl
                    #+clisp :clisp
                    #+clozure :ccl
                    #+cmu :cmucl
                    #+corman :cormanlisp
                    #+digitool :mcl
                    #+ecl :ecl
                    #+gcl :gcl
                    #+lispworks :lispworks
                    #+sbcl :sbcl
                    #+scl scl))))
Francois-Rene Rideau's avatar
1.647:    
Francois-Rene Rideau committed
29
30
31
32
     (merge-pathnames
      (make-pathname :directory `(:relative "tmp" "fasls" ,impl)
                     :defaults *asdf-lisp*)
      *asdf-lisp*))))
33

34
35
(defun load-asdf ()
  (load *asdf-fasl*))
36

37
38
39
40
41
42
43
#+allegro
(setf excl:*warn-on-nested-reader-conditionals* nil)

;;; code adapted from cl-launch (any errors in transcription are mine!)
;; http://www.cliki.net/cl-launch
(defun leave-lisp (message return)
  (when message
44
45
46
47
    (format *error-output* message)
    (terpri *error-output*))
  (finish-output *error-output*)
  (finish-output *standard-output*)
48
49
50
51
52
  #+allegro
  (excl:exit return)
  #+clisp
  (ext:quit return)
  #+(or cmu scl)
53
  (unix:unix-exit return)
54
  #+ecl
55
56
  (si:quit return)
  #+gcl
57
  (lisp:quit return)
58
  #+lispworks
59
  (lispworks:quit :status return :confirm nil :return nil :ignore-errors-p t)
60
61
62
63
  #+(or openmcl mcl)
  (ccl::quit return)
  #+sbcl
  (sb-ext:quit :unix-status return)
64
65
  #+abcl
  (ext:quit :status return)
66
67
  (error "Don't know how to quit Lisp; wanting to use exit code ~a" return))

Robert P. Goldman's avatar
   
Robert P. Goldman committed
68

69
(defmacro quit-on-error (&body body)
70
71
72
  `(call-quitting-on-error (lambda () ,@body)))

(defun call-quitting-on-error (thunk)
Robert P. Goldman's avatar
   
Robert P. Goldman committed
73
74
75
  "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."
76
77
78
  (handler-bind
      ((error (lambda (c)
                (format *error-output* "~a" c)
79
80
81
82
                (cond
                  ((ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST"))
                   (break))
                  (t
83
                   (format *error-output* "ABORTING:~% ~S~%" c)
84
85
                   #+sbcl (sb-debug:backtrace 69)
                   #+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
86
                   #+clisp (system::print-backtrace)
87
                   (format *error-output* "ABORTING:~% ~S~%" c)
88
                   (leave-lisp "~&Script failed~%" 1))))))
89
90
    (funcall thunk)
    (leave-lisp "~&Script succeeded~%" 0)))