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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5