/[cmucl]/src/tools/setup.lisp
ViewVC logotype

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (show annotations)
Sat May 31 23:58:12 2003 UTC (10 years, 10 months ago) by pmai
Branch: MAIN
Changes since 1.32: +8 -1 lines
Changed genesis (actually emit-c-header) to signal warnings of the newly
defined type genesis-c-header-file-changed when internals.h has changed
(or been newly created).  This can be handled by build-scripts in whatever
way they like.
1 ;;; -*- Package: USER -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;;
5 (ext:file-comment
6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/tools/setup.lisp,v 1.33 2003/05/31 23:58:12 pmai Exp $")
7 ;;;
8 ;;; **********************************************************************
9 ;;;
10 ;;; Set up package environment and search lists for compiler. Also some
11 ;;; compilation utilities.
12 ;;;
13
14 ;;; Ensure pre-ANSI defstruct processing occurs during system builds.
15 (in-package "KERNEL")
16 (defparameter *ansi-defstruct-options-p* nil)
17
18
19 ;; Disable package locks while rebuilding CMUCL. This variable is
20 ;; enabled upon startup from the function PACKAGE-LOCKS-INIT.
21 (in-package "LISP")
22 (defparameter *enable-package-locked-errors* nil)
23
24 (define-condition genesis-c-header-file-changed (warning)
25 ((name :initarg :name :reader genesis-c-header-file-name))
26 (:report
27 (lambda (c s)
28 (format s "The C header file ~S has changed.~%~
29 Be sure to re-compile the startup code."
30 (genesis-c-header-file-name c)))))
31
32 (in-package "USER")
33
34
35 ;; these forward declarations are only intended to avoid compiler
36 ;; warnings about undefined functions when building CMUCL.
37 (proclaim '(ftype (function * *)
38 c::assemble-file
39 pcl::class-direct-subclasses
40 pcl::class-direct-superclasses
41 pcl::specializer-direct-methods
42 pcl::class-slots
43 pcl::slot-boundp-using-class
44 pcl::slot-definition-name
45 pcl::slot-value-using-class
46 debug::all-method-functions-in-package
47 profile::reinitialize-method-function
48 cl::make-instance
49 cl::class-of
50 cl::sxhash-instance
51 hemlock::ts-stream-p
52 hemlock::ts-stream-wire
53 ext::call-display-event-handler
54 ext::disable-clx-event-handling
55 ext::flush-display-events
56 xlib::display-input-stream
57 xlib::event-listen))
58
59
60
61 ;;; DUMP-PACKAGE-STATE -- Public
62 ;;;
63 (defun dump-package-state (packages file)
64 (declare (type (or list package symbol string) packages)
65 (type (or pathname symbol string) file))
66 (let* ((packages (lisp::package-listify packages)))
67 (collect ((forms))
68 (dolist (pkg packages)
69 (let ((nicks (package-nicknames pkg))
70 (name (package-name pkg))
71 (shad (package-shadowing-symbols pkg)))
72 (forms `(if (find-package ,name)
73 (rename-package ,name ,name ',nicks)
74 (make-package ,name :nicknames ',nicks :use nil)))
75 (when shad
76 (forms `(shadow ',(mapcar #'string shad) ,name)))))
77
78 (dolist (pkg packages)
79 (forms `(use-package ',(mapcar #'package-name
80 (package-use-list pkg))
81 ,(package-name pkg))))
82
83 (dolist (old packages)
84 (collect ((exports))
85 (let ((imports (make-hash-table :test #'eq)))
86 (do-symbols (sym old)
87 (let ((pkg (symbol-package sym))
88 (name (symbol-name sym)))
89 (multiple-value-bind (found how)
90 (find-symbol name old)
91 (assert (and (eq found sym) how))
92 (cond
93 ((not pkg)
94 (warn "Not dumping uninterned symbol ~S." sym))
95 ((eq how :inherited))
96 (t
97 (unless (eq pkg old)
98 (pushnew name (gethash pkg imports) :test #'string=))
99 (when (eq how :external)
100 (exports name)))))))
101 (collect ((import-froms))
102 (maphash #'(lambda (pkg raw-names)
103 (let ((names (sort (delete-duplicates raw-names
104 :test
105 #'string=)
106 #'string<))
107 (pkg-name (package-name pkg)))
108 (when names
109 (import-froms `(:import-from ,pkg-name ,@names))
110 (dolist (name names)
111 (forms `(intern ,name ,pkg-name))))))
112 imports)
113 (forms `(defpackage ,(package-name old)
114 ,@(import-froms)
115 ,@(when (exports)
116 `((:export
117 ,@(sort (delete-duplicates (exports)
118 :test #'string=)
119 #'string<))))))))))
120
121 (with-open-file (s file :direction :output :if-exists :new-version)
122 (dolist (form (forms))
123 (write form :stream s :pretty t)
124 (terpri s)))))
125
126 (values))
127
128
129 ;;; COPY-PACKAGES -- Public
130 ;;;
131 (defun copy-packages (packages)
132 "Rename all the of the Named packages to OLD-Name, and then create new
133 packages for each name that have the same names, nicknames, imports, shadows
134 and exports. If any of the OLD-Name packages already exist, then we quietly
135 do nothing."
136 (let* ((packages (lisp::package-listify packages))
137 (names (mapcar #'package-name packages))
138 (new-names (mapcar #'(lambda (x)
139 (concatenate 'string "OLD-" x))
140 names)))
141 (unless (some #'find-package new-names)
142 (collect ((new-packages))
143 (flet ((trans-pkg (x)
144 (or (cdr (assoc x (new-packages))) x)))
145 (loop for pkg in packages and new in new-names do
146 (let ((nicks (package-nicknames pkg))
147 (name (package-name pkg)))
148 (rename-package pkg new)
149 (let ((new-pkg (make-package name :nicknames nicks :use nil))
150 (shad (package-shadowing-symbols pkg)))
151 (when shad
152 (shadow shad new-pkg))
153 (new-packages (cons pkg new-pkg)))))
154
155 (loop for (old . new) in (new-packages) do
156 (dolist (use (package-use-list old))
157 (use-package (trans-pkg use) new)))
158
159 (loop for (old . new) in (new-packages) do
160 (do-symbols (sym old)
161 (let ((pkg (symbol-package sym))
162 (name (symbol-name sym)))
163 (multiple-value-bind (found how)
164 (find-symbol name old)
165 (assert (and (eq found sym) how))
166 (cond
167 ((not pkg)
168 (warn "Not copying uninterned symbol ~S." sym))
169 ((or (eq how :inherited)
170 (and (eq how :internal) (eq pkg old))))
171 (t
172 (let* ((npkg (trans-pkg pkg))
173 (nsym (intern name npkg)))
174 (multiple-value-bind (ignore new-how)
175 (find-symbol name new)
176 (declare (ignore ignore))
177 (unless new-how (import nsym new)))
178 (when (eq how :external)
179 (export nsym new)))))))))))))
180 (values))
181
182
183 ;;;; Compile utility:
184
185 ;;; Switches:
186 ;;;
187 (defvar *interactive* t) ; Batch compilation mode?
188
189 (defvar *log-file* nil)
190 (defvar *last-file-position*)
191
192 (defmacro with-compiler-log-file ((name &rest wcu-keys) &body forms)
193 `(if *interactive*
194 (with-compilation-unit (,@wcu-keys)
195 ,@forms)
196 (let ((*log-file* (open ,name :direction :output
197 :if-exists :append
198 :if-does-not-exist :create)))
199 (unwind-protect
200 (let ((*error-output* *log-file*)
201 (*last-file-position* (file-position *log-file*)))
202 (with-compilation-unit (,@wcu-keys)
203 ,@forms))
204 (close *log-file*)))))
205
206
207 (defun comf (name &rest keys &key proceed assem &allow-other-keys)
208 (when (and *log-file*
209 (> (- (file-position *log-file*) *last-file-position*) 10000))
210 (setq *last-file-position* (file-position *log-file*))
211 (force-output *log-file*))
212
213 (let* ((src (merge-pathnames name (make-pathname :type "lisp")))
214 (obj (if assem
215 (make-pathname :defaults src :type "assem")
216 (apply #'compile-file-pathname src keys))))
217
218 (unless (and (probe-file obj)
219 (>= (file-write-date obj) (file-write-date src)))
220 (write-line (namestring name))
221 (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
222 (ext:format-universal-time nil (get-universal-time))
223 name)
224 (catch 'blow-this-file
225 (with-simple-restart
226 (continue "Blow this file")
227 (cond
228 (*interactive*
229 (if assem
230 (c::assemble-file src :output-file obj)
231 (apply #'compile-file src :allow-other-keys t keys)))
232 (t
233 (handler-bind
234 ((error #'(lambda (condition)
235 (unless (typep condition 'c::compiler-error)
236 (format *error-output* "~2&~A~2&"
237 condition)
238 (when proceed
239 (format *error-output* "Proceeding...~%")
240 (continue))
241 (format *error-output* "Aborting...~%")
242 (handler-case
243 (let ((*debug-io* *error-output*))
244 (debug:backtrace))
245 (error (condition)
246 (declare (ignore condition))
247 (format t "Error in backtrace!~%")))
248 (format t "Error abort.~%")
249 (return-from comf)))))
250 (if assem
251 (c::assemble-file src :output-file obj)
252 (apply #'compile-file src :allow-other-keys t keys))))))))))
253
254
255 ;;; VMDIR -- Interface
256 ;;;
257 (defun vmdir (f)
258 (merge-pathnames
259 (make-pathname :directory nil :defaults f)
260 (merge-pathnames
261 (cond ((c:target-featurep :pmax) "mips/")
262 ((c:target-featurep :rt) "rt/")
263 ((c:target-featurep :hppa) "hppa/")
264 ((c:target-featurep :sparc) "sparc/")
265 ((c:target-featurep :x86) "x86/")
266 ((c:target-featurep :alpha) "alpha/")
267 ((c:target-featurep :sgi) "mips/")
268 ((c:target-featurep :ppc) "ppc/")
269 (t
270 (error "What machine is this?")))
271 (make-pathname :directory (pathname-directory f)))))
272
273
274 ;;; CAT-IF-ANYTHING-CHAGNED
275
276 (defun cat-if-anything-changed (output-file &rest input-files)
277 (flet ((add-correct-type (pathname)
278 (or (probe-file
279 (make-pathname :type (c:backend-byte-fasl-file-type
280 c:*target-backend*)
281 :defaults pathname))
282 (make-pathname :type (c:backend-fasl-file-type
283 c:*target-backend*)
284 :defaults pathname))))
285 (let* ((output-file (add-correct-type output-file))
286 (write-date (file-write-date output-file))
287 (input-namestrings
288 (mapcar #'(lambda (file)
289 (let ((file (add-correct-type file)))
290 (let ((src-write-date (file-write-date file)))
291 (unless src-write-date
292 (error "Missing file: ~S" file))
293 (when (and write-date
294 (> src-write-date write-date))
295 (setf write-date nil)))
296 (unix-namestring file)))
297 input-files)))
298 (cond ((null write-date)
299 (format t "~S out of date.~%" (namestring output-file))
300 (run-program "/bin/cat" input-namestrings
301 :output output-file
302 :if-output-exists :supersede
303 :error t))
304 (t
305 (format t "~S up to date.~%" (namestring output-file)))))))
306

  ViewVC Help
Powered by ViewVC 1.1.5