test-stamp-propagation.lisp 4.83 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
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
105
106
107
;; NB: this file is supposed to work using old defsystems
;; including not just ASDF2, but also legacy defsystems from allegro, genera, lispworks

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

(unless (find-package :asdf)
  (asdf-test::load-asdf)
  (asdf-test::frob-packages))

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

(defparameter asdf::*asdf-cache* nil) ;; disable any surrounding cache on ASDF3.

#+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"))

(defvar *default-defsystem* (or #+(or allegro genera lispworks) :native
                                #+asdf :asdf
                                #+mk-defsystem :mk-defsystem))

(defun reload (&optional (defsystem *default-defsystem*))
  (format t "~&ASDF-CACHE ~S~%" asdf::*asdf-cache*)
  (setf *eval-notes* nil)
  (setf *compile-verbose* t *load-verbose* t)
  (ecase defsystem
    #+asdf
    (:asdf
     (note-eval :compiling :system)
     (asdf:compile-system :test-stamp-propagation)
     (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))

108
109
110
111
112
113
(defun touch (filename)
  #+genera filename ;; do something with it!
  #-genera
  (uiop:run-program `("touch" ,(native-namestring filename))
                    :output t :error-output t))

114
(defun touch-file1.lisp ()
115
  (touch (asdf::subpathname *tsp* "file1.lisp")))
116
117

(defun touch-file1.fasl (&optional (defsystem *default-defsystem*))
118
119
120
  (touch (funcall
          (case defsystem (:asdf 'asdf::compile-file-pathname*) (t 'compile-file-pathname))
          (asdf::subpathname *tsp* "file1.lisp"))))
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

(defun sanitize-log (log)
  (remove-duplicates
   (remove '(:loading :system) log :test 'equal)
   :test 'equal :from-end t))

(defun test-defsystem (&optional (defsystem *default-defsystem*))
  (format t "~&Testing stamp propagation by defsystem ~S~%" defsystem)
  (DBG "loading system")
  (reload defsystem)
  (sleep 1)
  (DBG "touching first source file and reloading")
  (DBG "defsystem should recompile & reload everything")
  (touch-file1.lisp)
  (assert-equal (sanitize-log (reload defsystem))
                '((:compiling :system) (:compile-toplevel :file1) (:load-toplevel :file1)
                  (:compile-toplevel :file2) (:load-toplevel :file2)))
  (sleep 1)
  (DBG "touching first fasl file and reloading")
  (DBG "defsystem should reload it, recompile & reload the other")
  (touch-file1.fasl defsystem)
  (assert-equal (sanitize-log (reload defsystem))
                '((:compiling :system) (:load-toplevel :file1)
                  (:compile-toplevel :file2) (:load-toplevel :file2))))

(test-defsystem :asdf)

#+(or genera)
(test-defsystem :native)

#+(or allegro lispworks)
(signals error (test-defsystem :native))

#+mkdefsystem
(signals error (test-defsystem :mk-defsystem))