script-support.lisp 10.6 KB
Newer Older
1
2
3
4
5
(defpackage :asdf-test
  (:use :common-lisp)
  (:export
   #:*test-directory* #:*asdf-directory*
   #:load-asdf
6
   #:register-directory #:asdf-load
7
8
9
   #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl #:compile-load-asdf #:load-asdf-system
   #:quit-on-error #:test-asdf
   #:native-namestring
10
   #:assert-equal
11
12
   #:exit-lisp #:leave-lisp
   #:quietly))
13

14
(in-package :asdf-test)
15

16
17
(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)))
(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)))
18

19
20
;; NB: can't print anything because of forward-ref test.
;; (DBG "Evaluating asdf/test/script-support") 
21

22
;; We can't use asdf::merge-pathnames* because ASDF isn't loaded yet.
23
;; We still want to work despite and host/device funkiness.
24
25
(defparameter *test-directory*
  (make-pathname :name nil :type nil :version nil
26
27
                 :defaults (or #+gcl (truename system:*load-pathname*)
                               *load-truename* *compile-file-truename*)))
28
(defparameter *asdf-directory*
29
30
31
32
  (truename
   (merge-pathnames
    (make-pathname :directory '(#-gcl :relative #-gcl :back #+gcl :parent) :defaults *test-directory*)
    *test-directory*)))
33
(defparameter *asdf-lisp*
34
35
36
  (merge-pathnames
   (make-pathname :directory '(#-gcl :relative "build") :name "asdf" :type "lisp" :defaults *asdf-directory*)
   *asdf-directory*))
37
(defparameter *asdf-fasl*
38
  (compile-file-pathname
Francois-Rene Rideau's avatar
1.647:    
Francois-Rene Rideau committed
39
   (let ((impl (string-downcase
40
41
42
                (or #+allegro
                    (ecase excl:*current-case-mode*
                      (:case-sensitive-lower :mlisp)
43
                      (:case-insensitive-upper :alisp))
44
45
46
47
48
49
50
51
52
                    #+armedbear :abcl
                    #+clisp :clisp
                    #+clozure :ccl
                    #+cmu :cmucl
                    #+corman :cormanlisp
                    #+digitool :mcl
                    #+ecl :ecl
                    #+gcl :gcl
                    #+lispworks :lispworks
53
		    #+mkcl :mkcl
54
                    #+sbcl :sbcl
55
56
                    #+scl :scl
                    #+xcl :xcl))))
Francois-Rene Rideau's avatar
1.647:    
Francois-Rene Rideau committed
57
     (merge-pathnames
58
      (make-pathname :directory `(#-gcl :relative "fasls" ,impl)
59
                     :defaults *asdf-directory*)
Francois-Rene Rideau's avatar
1.647:    
Francois-Rene Rideau committed
60
      *asdf-lisp*))))
61

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
62
63
64
(defun load-old-asdf (tag)
  (let ((old-asdf
          (merge-pathnames
65
           (make-pathname :directory `(#-gcl :relative "build")
66
                          :name (format nil "asdf-~A" tag) :type "lisp"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
67
                          :defaults *asdf-directory*)
68
           *asdf-directory*)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
69
70
71
    (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning))
      (load old-asdf))))

72
73
74
(defvar *debug-symbols*
  '( #|:COMPILE-FILE* :perform-lisp-compilation|# ))

75
(defun configure-asdf ()
76
  (eval `(trace ,@(loop :for s :in *debug-symbols* :collect (find-symbol (string s) :asdf))))
77
78
  (funcall (find-symbol (string :initialize-source-registry) :asdf)
           `(:source-registry :ignore-inherited-configuration))
79
80
81
82
83
  (funcall (find-symbol (string :initialize-output-translations) :asdf)
           `(:output-translations
             (,*test-directory* (,*asdf-directory* "build/fasls" :implementation "test"))
             (t (,*asdf-directory* "build/fasls" :implementation "root"))
             :ignore-inherited-configuration))
84
85
86
  (let ((registry (find-symbol (string :*central-registry*) :asdf)))
    (set registry `(,*asdf-directory* ,*test-directory*))))

87
88
89
90
91
92
93
(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)
      (funcall (find-symbol (string :run-shell-command) :asdf)
               "touch -t ~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D ~S"
               year month day hr min sec (namestring file)))))

94
(defun load-asdf ()
95
96
  (load *asdf-fasl*)
  (use-package :asdf :asdf-test)
97
  (import 'DBG :asdf)
98
  (configure-asdf)
99
100
  (setf *package* (find-package :asdf-test)))

101
102
103
104
(defun hash-table->alist (table)
  (loop :for key :being :the :hash-keys :of table :using (:hash-value value)
    :collect (cons key value)))

105
106
(defun common-lisp-user::load-asdf ()
  (load-asdf))
107

108
109
110
#+allegro
(setf excl:*warn-on-nested-reader-conditionals* nil)

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
111
(defun native-namestring (x)
112
  (let ((p (pathname x)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
113
    #+clozure (ccl:native-translated-namestring p)
114
    #+(or cmu scl) (ext:unix-namestring p nil)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
115
116
117
    #+sbcl (sb-ext:native-namestring p)
    #-(or clozure cmu sbcl scl) (namestring p)))

118
;;; code adapted from cl-launch http://www.cliki.net/cl-launch
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
119
(defun exit-lisp (return)
120
121
122
123
124
  #+allegro
  (excl:exit return)
  #+clisp
  (ext:quit return)
  #+(or cmu scl)
125
  (unix:unix-exit return)
126
  #+ecl
127
128
  (si:quit return)
  #+gcl
129
  (lisp:quit return)
130
  #+lispworks
131
  (lispworks:quit :status return :confirm nil :return nil :ignore-errors-p t)
132
133
  #+(or openmcl mcl)
  (ccl::quit return)
134
135
  #+mkcl
  (mk-ext:quit :exit-code return)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
136
137
138
139
140
  #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext))
                 (quit (find-symbol "QUIT" :sb-ext)))
             (cond
               (exit `(,exit :code return :abort t))
               (quit `(,quit :unix-status return :recklessly-p t))))
141
  #+(or abcl xcl)
142
  (ext:quit :status return)
143
144
  (error "Don't know how to quit Lisp; wanting to use exit code ~a" return))

145
146
147
148
149
150
151
152
153
(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*))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
154
(defun leave-lisp (message return)
155
  (finish-outputs)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
156
157
158
159
  (fresh-line *error-output*)
  (when message
    (format *error-output* message)
    (terpri *error-output*))
160
  (finish-outputs)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
161
  (exit-lisp return))
Robert P. Goldman's avatar
   
Robert P. Goldman committed
162

163
164
165
166
(defmacro assert-equal (x y)
  `(assert (equal ,x ,y) () "These two expressions are not equal:~% ~S evaluates to ~S~% ~S evaluates to ~S~%"
           ',x ,x ',y ,y))

167
(defmacro quit-on-error (&body body)
168
169
170
  `(call-quitting-on-error (lambda () ,@body)))

(defun call-quitting-on-error (thunk)
Robert P. Goldman's avatar
   
Robert P. Goldman committed
171
172
173
  "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."
174
  (redirect-outputs)
175
176
  (handler-bind
      ((error (lambda (c)
177
                (format *error-output* "~&~a~&" c)
178
179
180
181
                (cond
                  ((ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST"))
                   (break))
                  (t
182
183
                   (finish-output *standard-output*)
                   (finish-output *trace-output*)
184
                   (format *error-output* "~&ABORTING:~% ~A~%" c)
185
                   (finish-output *error-output*)
186
187
                   #+sbcl (sb-debug:backtrace 69)
                   #+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
188
                   #+clisp (system::print-backtrace)
189
                   #+ecl (si::tpl-backtrace)
190
                   (format *error-output* "~&ABORTING:~% ~A~%" c)
191
                   (finish-output *error-output*)
192
193
                   (finish-output *standard-output*)
                   (finish-output *trace-output*)
194
                   (leave-lisp "Script failed" 1))))))
195
    (funcall thunk)
196
    (leave-lisp "Script succeeded" 0)))
197
198
199
200
201
202
203
204
205
206
207
208
209
210


;;; 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*))

211
212
213
214
215
216
217
#+(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))))))

(defun compile-asdf (&optional (output *asdf-fasl*))
218
  (ensure-directories-exist *asdf-fasl*)
219
  ;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
220
  (handler-bind (#+sbcl ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning) #'muffle-warning)
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
                 #+(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-warning
                   #'(lambda (w)
                       ;; escalate style-warnings to warnings - we don't want them.
                       (warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A"
                             (type-of w) w)
                       (muffle-warning w))))
    (compile-file *asdf-lisp* :output-file output #-gcl :verbose #-gcl t :print t)))
236
237
238
239
240
241
242
243
244
245
246
247
248

(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))))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
249
(defun asdf-load (x &key verbose)
250
  (let ((xoos (find-symbol (string :oos) :asdf))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
251
252
253
254
        (xload-op (find-symbol (string :load-op) :asdf))
        (*load-print* verbose)
        (*load-verbose* verbose))
    (funcall xoos xload-op x :verbose verbose)))
255

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
256
(defun load-asdf-system (&rest keys)
257
258
  (quietly
   (register-directory *asdf-directory*)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
259
   (apply 'asdf-load :asdf keys)))
260
261
262
263
264
265
266
267
268
269

(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)))
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286

(defmacro DBG (tag &rest exprs)
  "simple debug statement macro:
outputs a tag plus a list of variable and their values, returns the last value"
  ;"if not in debugging mode, just compute and return last value"
  ; #-do-test (declare (ignore tag)) #-do-test (car (last exprs)) #+do-test
  (let ((res (gensym))(f (gensym)))
  `(let (,res (*print-readably* nil))
    (flet ((,f (fmt &rest args) (apply #'format *error-output* fmt args)))
      (,f "~&~A~%" ,tag)
      ,@(mapcan
         #'(lambda (x)
            `((,f "~&  ~S => " ',x)
              (,f "~{~S~^ ~}~%" (setf ,res (multiple-value-list ,x)))))
         exprs)
      (apply 'values ,res)))))

287
288
(pushnew :DBG *features*)

289
290
291
292
293
#+gcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (DBG :script-support *package* *test-directory* *asdf-directory* *asdf-lisp* *asdf-fasl*
       ))

294
#|
295
(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))
296
|#