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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide 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 wlott 1.1 ;;; -*- Package: USER -*-
2     ;;;
3 dtc 1.29 ;;; **********************************************************************
4     ;;;
5     (ext:file-comment
6 pmai 1.40 "$Header: /tiger/var/lib/cvsroots/cmucl/src/tools/setup.lisp,v 1.40 2004/07/25 18:25:16 pmai Rel $")
7 dtc 1.29 ;;;
8     ;;; **********************************************************************
9     ;;;
10 wlott 1.1 ;;; Set up package environment and search lists for compiler. Also some
11     ;;; compilation utilities.
12     ;;;
13 gerd 1.37
14     (when (boundp 'conditions::*make-condition-accessor-methods*)
15     (setq conditions::*make-condition-accessor-methods* nil))
16 pw 1.31
17     ;;; Ensure pre-ANSI defstruct processing occurs during system builds.
18     (in-package "KERNEL")
19     (defparameter *ansi-defstruct-options-p* nil)
20    
21 emarsden 1.32
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 pmai 1.40 (ext:unlock-all-packages)
27 emarsden 1.32
28 pmai 1.33 (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 emarsden 1.32
36 gerd 1.36 (in-package "CL-USER")
37 pw 1.31
38 wlott 1.1
39 emarsden 1.32 ;; 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 emarsden 1.35 ;; 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 emarsden 1.38 stream::%read-vector
77 emarsden 1.35 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 emarsden 1.32 debug::all-method-functions-in-package
84     profile::reinitialize-method-function
85 gerd 1.36 lisp::make-instance
86     lisp::class-of
87     lisp::sxhash-instance
88 emarsden 1.32 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 ram 1.12
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 wlott 1.14 (forms `(if (find-package ,name)
110     (rename-package ,name ,name ',nicks)
111     (make-package ,name :nicknames ',nicks :use nil)))
112 ram 1.12 (when shad
113     (forms `(shadow ',(mapcar #'string shad) ,name)))))
114 ram 1.11
115 ram 1.12 (dolist (pkg packages)
116     (forms `(use-package ',(mapcar #'package-name
117     (package-use-list pkg))
118     ,(package-name pkg))))
119 ram 1.4
120 ram 1.12 (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 wlott 1.14 (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 ram 1.4
158 toy 1.34 (with-open-file (s file :direction :output :if-exists :rename-and-delete)
159 ram 1.12 (dolist (form (forms))
160     (write form :stream s :pretty t)
161     (terpri s)))))
162 wlott 1.1
163 ram 1.12 (values))
164 ram 1.2
165 ram 1.12
166     ;;; COPY-PACKAGES -- Public
167 ram 1.8 ;;;
168 ram 1.12 (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 wlott 1.1
192 ram 1.12 (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 wlott 1.14
219    
220 ram 1.9 ;;;; Compile utility:
221 wlott 1.1
222 ram 1.9 ;;; Switches:
223     ;;;
224 ram 1.12 (defvar *interactive* t) ; Batch compilation mode?
225 ram 1.9
226 wlott 1.1 (defvar *log-file* nil)
227 ram 1.4 (defvar *last-file-position*)
228 wlott 1.1
229 ram 1.13 (defmacro with-compiler-log-file ((name &rest wcu-keys) &body forms)
230 wlott 1.1 `(if *interactive*
231 ram 1.13 (with-compilation-unit (,@wcu-keys)
232 wlott 1.1 ,@forms)
233     (let ((*log-file* (open ,name :direction :output
234     :if-exists :append
235     :if-does-not-exist :create)))
236     (unwind-protect
237 ram 1.4 (let ((*error-output* *log-file*)
238     (*last-file-position* (file-position *log-file*)))
239 ram 1.13 (with-compilation-unit (,@wcu-keys)
240 wlott 1.1 ,@forms))
241     (close *log-file*)))))
242    
243    
244 ram 1.24 (defun comf (name &rest keys &key proceed assem &allow-other-keys)
245 ram 1.4 (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 wlott 1.1
250 wlott 1.21 (let* ((src (merge-pathnames name (make-pathname :type "lisp")))
251 ram 1.24 (obj (if assem
252     (make-pathname :defaults src :type "assem")
253     (apply #'compile-file-pathname src keys))))
254 wlott 1.1
255 ram 1.12 (unless (and (probe-file obj)
256     (>= (file-write-date obj) (file-write-date src)))
257 ram 1.25 (write-line (namestring name))
258 wlott 1.1 (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
259     (ext:format-universal-time nil (get-universal-time))
260     name)
261 ram 1.12 (catch 'blow-this-file
262 wlott 1.20 (with-simple-restart
263     (continue "Blow this file")
264     (cond
265     (*interactive*
266 ram 1.12 (if assem
267     (c::assemble-file src :output-file obj)
268 ram 1.24 (apply #'compile-file src :allow-other-keys t keys)))
269 wlott 1.20 (t
270     (handler-bind
271     ((error #'(lambda (condition)
272 ram 1.23 (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 wlott 1.20 (if assem
288     (c::assemble-file src :output-file obj)
289 ram 1.24 (apply #'compile-file src :allow-other-keys t keys))))))))))
290 wlott 1.19
291 ram 1.26
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 hallgren 1.27 ((c:target-featurep :alpha) "alpha/")
304 hallgren 1.28 ((c:target-featurep :sgi) "mips/")
305 dtc 1.30 ((c:target-featurep :ppc) "ppc/")
306 cwang 1.39 ((c:target-featurep :amd64) "amd64/")
307 ram 1.26 (t
308     (error "What machine is this?")))
309     (make-pathname :directory (pathname-directory f)))))
310 wlott 1.19
311    
312 cwang 1.39 ;;; CAT-IF-ANYTHING-CHANGED
313 wlott 1.19
314     (defun cat-if-anything-changed (output-file &rest input-files)
315     (flet ((add-correct-type (pathname)
316 ram 1.24 (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 wlott 1.19 (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 emarsden 1.32

  ViewVC Help
Powered by ViewVC 1.1.5