test-stamp-propagation.lisp 7.88 KB
Newer Older
1
2
;; NB: This test file is supposed to work using old defsystems:
;; not just ASDF 2.26, but also legacy defsystems from Allegro, Genera, LispWorks
3
4
5

(unless (find-package :asdf-test)
  (load (merge-pathnames
6
         (make-pathname :defaults *load-pathname*
7
8
9
10
11
                        :name "script-support" :directory '(:relative :back))
         *load-pathname*)))

(unless (find-package :asdf)
  (asdf-test::load-asdf)
12
13
  (asdf-test::frob-packages)
  (use-package :uiop :asdf))
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

(in-package :asdf-test)

(DBG :foo)

(defparameter *eval-notes* ())
(defun note-eval (when file)
  (format t "~&XXX ~S ~S~%" when file)
  (push `(,when ,file #|,*load-pathname* ,*compile-file-pathname*|#) *eval-notes*))
(defun eval-notes ()
  (prog1 (reverse *eval-notes*) (setf *eval-notes* nil)))
(defmacro eval-note (&optional x)
  `(progn
     (eval-when (:compile-toplevel) (note-eval :compile-toplevel ',x))
     (eval-when (:load-toplevel) (note-eval :load-toplevel ',x))
     (eval-when (:execute) (note-eval :execute ',x))))


(eval-note :tsp)

(defvar *tsp* (asdf::pathname-directory-pathname *load-pathname*))
35
36
37
38
39
(defparameter *defsystems* '(#+(or allegro genera lispworks) :native
                             #+mk-defsystem :mk-defsystem
                             #+asdf :asdf))
(defvar *default-defsystem* (first *defsystems*))
(defvar asdf::*asdf-cache* nil) ;; if defparameter instead of defvar, disable any surrounding cache
40
(defvar asdf::*asdf-session* nil) ;; if defparameter instead of defvar, disable any surrounding cache
41

42
43
44
45
46
47
48
49
50
51
(defun lisppath (filename) (asdf::subpathname *tsp* filename))
(defun faslpath (lisppath &optional (defsystem *default-defsystem*))
  (funcall
   (if (and (eq defsystem :asdf) (fboundp 'asdf::compile-file-pathname*))
       'asdf::compile-file-pathname*
       'compile-file-pathname)
   (etypecase lisppath
     (pathname lisppath)
     (string (lisppath lisppath)))))

52

53
54
(defun use-cache-p (defsystem)
  (and (eq defsystem :asdf)
55
56
57
58
59
       (cond
         ((asdf:version-satisfies (asdf:asdf-version) "3.1.7.30")
          asdf::*asdf-session*)
         ((asdf:version-satisfies (asdf:asdf-version) "2.27")
          asdf::*asdf-cache*))))
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104

#+allegro
(excl:defsystem :test-stamp-propagation
  (:default-pathname #.*tsp*)
  (:definitions
   "file1.lisp"
   "file2.lisp"))

#+genera
(sct:defsystem :test-stamp-propagation
  (:default-pathname #.*tsp* :patchable nil)
  (:definitions
   "file1.lisp"
   "file2.lisp"))

#+lispworks
(scm:defsystem :test-stamp-propagation
  (:default-pathname #.*tsp*)
  :members ("file1" "file2")
  :rules ((:in-order-to :compile ("file2")
           (:caused-by (:compile "file1"))
           (:requires (:load "file1")))))

#+asdf
(asdf:defsystem :test-stamp-propagation
  :pathname #.*tsp* :source-file nil
  :serial t
  :components
  ((:file "file1")
   (:file "file2")))

#+mk-defsystem
(mk:defsystem :test-stamp-propagation
  (:default-pathname #.*tsp* :patchable nil)
  (:serial
   "file1.lisp"
   "file2.lisp"))

(defun reload (&optional (defsystem *default-defsystem*))
  (setf *eval-notes* nil)
  (setf *compile-verbose* t *load-verbose* t)
  (ecase defsystem
    #+asdf
    (:asdf
     (note-eval :compiling :system)
105
106
     (unless (use-cache-p :asdf) ;; faking the cache only works for one plan
       (asdf:compile-system :test-stamp-propagation))
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
     (note-eval :loading :system)
     (asdf:load-system :test-stamp-propagation))
    #+mk-defsystem
    (:mk-defsystem
     (note-eval :compiling :system)
     (mk:compile-system :test-stamp-propagation)
     (note-eval :loading :system)
     (mk:load-system :test-stamp-propagation))
    (:native
     (note-eval :compiling :system)
     #+allegro (excl:compile-system :test-stamp-propagation)
     #+lispworks (scm:compile-system :test-stamp-propagation)
     #+genera (sct:compile-system :test-stamp-propagation)
     (note-eval :loading :system)
     #+allegro (excl:load-system :test-stamp-propagation)
     #+lispworks (scm:load-system :test-stamp-propagation)
     #+genera (sct:load-system :test-stamp-propagation)))
  (let ((n (eval-notes)))
    (format t "~&EVAL-NOTES ~S~%" n)
    n))

128
129
130
131
132
133
134
135
136
137
138
(defun clear-sys (&optional (defsystem *default-defsystem*))
  #+asdf
  (when (eq defsystem :asdf)
    (asdf:clear-system :test-stamp-propagation)
    (asdf:defsystem :test-stamp-propagation
      :pathname #.*tsp* :source-file nil
      :serial t
      :components
      ((:file "file1")
       (:file "file2")))))

139
(defun touch (filename)
140
  #+genera filename ;; TODO: do something with it!
141
  #-genera
142
  (uiop:run-program `("touch" ,(uiop:native-namestring filename))
143
144
                    :output t :error-output t))

145
146
(defun clear-fasls (&optional (defsystem *default-defsystem*))
  (loop :for file :in '("file1.lisp" "file2.lisp")
147
        :for faslpath = (faslpath file defsystem)
148
        :do (if (use-cache-p defsystem)
149
150
151
                (mark-file-deleted faslpath)
                (delete-file-if-exists faslpath))))

152
153
154
155
156
(defun sanitize-log (log)
  (remove-duplicates
   (remove '(:loading :system) log :test 'equal)
   :test 'equal :from-end t))

157
(defun adjust-stamp-cache (base l1 f1 l2 f2)
158
  (clrhash (asdf::asdf-cache))
159
160
  (touch-file (lisppath "file1.lisp") :timestamp base :offset l1)
  (touch-file (faslpath "file1.lisp") :timestamp base :offset f1)
161
  (dolist (l (asdf:output-files 'asdf:compile-op '(:test-stamp-propagation "file1")))
162
163
164
    (touch-file l :timestamp base :offset f1))
  (touch-file (lisppath "file2.lisp") :timestamp base :offset l2)
  (touch-file (faslpath "file2.lisp") :timestamp base :offset f2)
165
  (dolist (l (asdf:output-files 'asdf:compile-op '(:test-stamp-propagation "file2")))
166
167
    (touch-file l :timestamp base :offset f2)))

168
(defun test-defsystem (&optional (defsystem *default-defsystem*))
169
170
171
172
  (format t "~%~%Testing stamp propagation by defsystem ~S~%" defsystem)
  #+(or allegro clisp)
  (progn (DBG "removing any old fasls from another flavor of the implementation")
         (clear-fasls defsystem))
173
  (when (use-cache-p defsystem)
174
    (adjust-stamp-cache (file-write-date (lisppath "file1.lisp")) -1000 -10000 -1000 -10000))
175
176
  (DBG "loading system")
  (reload defsystem)
177
  (clear-sys defsystem)
178
179
180
  (cond
    ((use-cache-p defsystem)
     (DBG "marking all files old but first source file, and reloading")
181
     (adjust-stamp-cache (file-write-date (lisppath "file1.lisp")) 0 -1000 -1000 -1000))
182
183
184
185
    (t
     (DBG "touching first source file and reloading")
     (sleep #-os-windows 3 #+os-windows 5)
     (touch (lisppath "file1.lisp"))))
186
187
188
189
  (DBG "defsystem should recompile & reload everything")
  (assert-equal (sanitize-log (reload defsystem))
                '((:compiling :system) (:compile-toplevel :file1) (:load-toplevel :file1)
                  (:compile-toplevel :file2) (:load-toplevel :file2)))
190
  (clear-sys defsystem)
191
192
193
  (cond
    ((use-cache-p defsystem)
     (DBG "marking the old fasl new, the second one up to date")
194
     (adjust-stamp-cache (file-write-date (lisppath "file1.lisp")) 100 500 100 100))
195
196
197
198
    (t
     (DBG "touching first fasl file and reloading")
     (sleep #-os-windows 3 #+os-windows 5)
     (touch (faslpath "file1.lisp" defsystem))))
199
200
201
  (DBG "defsystem should reload it, recompile & reload the other")
  (assert-equal (sanitize-log (reload defsystem))
                '((:compiling :system) (:load-toplevel :file1)
202
203
204
205
                  (:compile-toplevel :file2) (:load-toplevel :file2)))
  (DBG "cleaning up")
  (clear-fasls defsystem))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
206
207
208
209
210
211
212
213
214
215
;; The test should work on ASDF3 and later:
;; (this is THE bug that motivated the rewrite from ASDF 2 to ASDF 3).
(nest
 #-asdf3 (signals error)
 ;; TODO: figure out why ABCL and XCL require this with-asdf-session.
 #+(and asdf3.3 (or abcl xcl)) (with-asdf-session () (load-system "asdf"))
 (test-defsystem :asdf))

;; Genera's and Lispworks' defsystem have a bug fix, though
;; users need to manually specify non-default dependencies
216
#+(or genera lispworks)
217
218
(test-defsystem :native)

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
219
;; Allegro's defsystem has the bug
220
#+(or allegro)
221
222
(signals error (test-defsystem :native))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
223
224
;; MK-DEFSYSTEM has the bug
#+mk-defsystem
225
(signals error (test-defsystem :mk-defsystem))