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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (hide annotations)
Tue Jun 1 23:36:07 2004 UTC (9 years, 10 months ago) by cwang
Branch: MAIN
CVS Tags: snapshot-2004-06, snapshot-2004-07, prm-before-macosx-merge-tag
Changes since 1.38: +3 -2 lines
amd64 changes
1 wlott 1.1 ;;; -*- Package: USER -*-
2     ;;;
3 dtc 1.29 ;;; **********************************************************************
4     ;;;
5     (ext:file-comment
6 cwang 1.39 "$Header: /tiger/var/lib/cvsroots/cmucl/src/tools/setup.lisp,v 1.39 2004/06/01 23:36:07 cwang Exp $")
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    
27 pmai 1.33 (define-condition genesis-c-header-file-changed (warning)
28     ((name :initarg :name :reader genesis-c-header-file-name))
29     (:report
30     (lambda (c s)
31     (format s "The C header file ~S has changed.~%~
32     Be sure to re-compile the startup code."
33     (genesis-c-header-file-name c)))))
34 emarsden 1.32
35 gerd 1.36 (in-package "CL-USER")
36 pw 1.31
37 wlott 1.1
38 emarsden 1.32 ;; these forward declarations are only intended to avoid compiler
39     ;; warnings about undefined functions when building CMUCL.
40     (proclaim '(ftype (function * *)
41     c::assemble-file
42     pcl::class-direct-subclasses
43     pcl::class-direct-superclasses
44     pcl::specializer-direct-methods
45     pcl::class-slots
46     pcl::slot-boundp-using-class
47     pcl::slot-definition-name
48     pcl::slot-value-using-class
49 emarsden 1.35 ;; Simple-stream functions, that are provided when building PCL
50     stream:device-close
51     stream::%charpos
52     stream::%clear-input
53     stream::%clear-output
54     stream::%file-length
55     stream::%file-name
56     stream::%file-position
57     stream::%file-rename
58     stream::%file-string-length
59     stream::%finish-output
60     stream::%force-output
61     stream::%fresh-line
62     stream::%input-stream-p
63     stream::%interactive-stream-n
64     stream::%interactive-stream-p
65     stream::%interactive-stream-y
66     stream::%line-length
67     stream::%listen
68     stream::%open-stream-p
69     stream::%output-stream-p
70     stream::%peek-char
71     stream::%read-byte
72     stream::%read-char
73     stream::%read-line
74     stream::%read-sequence
75 emarsden 1.38 stream::%read-vector
76 emarsden 1.35 stream::%stream-external-format
77     stream::%unread-char
78     stream::%write-char
79     stream::%write-byte
80     stream::%write-sequence
81     stream::%write-string
82 emarsden 1.32 debug::all-method-functions-in-package
83     profile::reinitialize-method-function
84 gerd 1.36 lisp::make-instance
85     lisp::class-of
86     lisp::sxhash-instance
87 emarsden 1.32 hemlock::ts-stream-p
88     hemlock::ts-stream-wire
89     ext::call-display-event-handler
90     ext::disable-clx-event-handling
91     ext::flush-display-events
92     xlib::display-input-stream
93     xlib::event-listen))
94    
95    
96 ram 1.12
97     ;;; DUMP-PACKAGE-STATE -- Public
98     ;;;
99     (defun dump-package-state (packages file)
100     (declare (type (or list package symbol string) packages)
101     (type (or pathname symbol string) file))
102     (let* ((packages (lisp::package-listify packages)))
103     (collect ((forms))
104     (dolist (pkg packages)
105     (let ((nicks (package-nicknames pkg))
106     (name (package-name pkg))
107     (shad (package-shadowing-symbols pkg)))
108 wlott 1.14 (forms `(if (find-package ,name)
109     (rename-package ,name ,name ',nicks)
110     (make-package ,name :nicknames ',nicks :use nil)))
111 ram 1.12 (when shad
112     (forms `(shadow ',(mapcar #'string shad) ,name)))))
113 ram 1.11
114 ram 1.12 (dolist (pkg packages)
115     (forms `(use-package ',(mapcar #'package-name
116     (package-use-list pkg))
117     ,(package-name pkg))))
118 ram 1.4
119 ram 1.12 (dolist (old packages)
120     (collect ((exports))
121     (let ((imports (make-hash-table :test #'eq)))
122     (do-symbols (sym old)
123     (let ((pkg (symbol-package sym))
124     (name (symbol-name sym)))
125     (multiple-value-bind (found how)
126     (find-symbol name old)
127     (assert (and (eq found sym) how))
128     (cond
129     ((not pkg)
130     (warn "Not dumping uninterned symbol ~S." sym))
131     ((eq how :inherited))
132     (t
133     (unless (eq pkg old)
134     (pushnew name (gethash pkg imports) :test #'string=))
135     (when (eq how :external)
136     (exports name)))))))
137 wlott 1.14 (collect ((import-froms))
138     (maphash #'(lambda (pkg raw-names)
139     (let ((names (sort (delete-duplicates raw-names
140     :test
141     #'string=)
142     #'string<))
143     (pkg-name (package-name pkg)))
144     (when names
145     (import-froms `(:import-from ,pkg-name ,@names))
146     (dolist (name names)
147     (forms `(intern ,name ,pkg-name))))))
148     imports)
149     (forms `(defpackage ,(package-name old)
150     ,@(import-froms)
151     ,@(when (exports)
152     `((:export
153     ,@(sort (delete-duplicates (exports)
154     :test #'string=)
155     #'string<))))))))))
156 ram 1.4
157 toy 1.34 (with-open-file (s file :direction :output :if-exists :rename-and-delete)
158 ram 1.12 (dolist (form (forms))
159     (write form :stream s :pretty t)
160     (terpri s)))))
161 wlott 1.1
162 ram 1.12 (values))
163 ram 1.2
164 ram 1.12
165     ;;; COPY-PACKAGES -- Public
166 ram 1.8 ;;;
167 ram 1.12 (defun copy-packages (packages)
168     "Rename all the of the Named packages to OLD-Name, and then create new
169     packages for each name that have the same names, nicknames, imports, shadows
170     and exports. If any of the OLD-Name packages already exist, then we quietly
171     do nothing."
172     (let* ((packages (lisp::package-listify packages))
173     (names (mapcar #'package-name packages))
174     (new-names (mapcar #'(lambda (x)
175     (concatenate 'string "OLD-" x))
176     names)))
177     (unless (some #'find-package new-names)
178     (collect ((new-packages))
179     (flet ((trans-pkg (x)
180     (or (cdr (assoc x (new-packages))) x)))
181     (loop for pkg in packages and new in new-names do
182     (let ((nicks (package-nicknames pkg))
183     (name (package-name pkg)))
184     (rename-package pkg new)
185     (let ((new-pkg (make-package name :nicknames nicks :use nil))
186     (shad (package-shadowing-symbols pkg)))
187     (when shad
188     (shadow shad new-pkg))
189     (new-packages (cons pkg new-pkg)))))
190 wlott 1.1
191 ram 1.12 (loop for (old . new) in (new-packages) do
192     (dolist (use (package-use-list old))
193     (use-package (trans-pkg use) new)))
194    
195     (loop for (old . new) in (new-packages) do
196     (do-symbols (sym old)
197     (let ((pkg (symbol-package sym))
198     (name (symbol-name sym)))
199     (multiple-value-bind (found how)
200     (find-symbol name old)
201     (assert (and (eq found sym) how))
202     (cond
203     ((not pkg)
204     (warn "Not copying uninterned symbol ~S." sym))
205     ((or (eq how :inherited)
206     (and (eq how :internal) (eq pkg old))))
207     (t
208     (let* ((npkg (trans-pkg pkg))
209     (nsym (intern name npkg)))
210     (multiple-value-bind (ignore new-how)
211     (find-symbol name new)
212     (declare (ignore ignore))
213     (unless new-how (import nsym new)))
214     (when (eq how :external)
215     (export nsym new)))))))))))))
216     (values))
217 wlott 1.14
218    
219 ram 1.9 ;;;; Compile utility:
220 wlott 1.1
221 ram 1.9 ;;; Switches:
222     ;;;
223 ram 1.12 (defvar *interactive* t) ; Batch compilation mode?
224 ram 1.9
225 wlott 1.1 (defvar *log-file* nil)
226 ram 1.4 (defvar *last-file-position*)
227 wlott 1.1
228 ram 1.13 (defmacro with-compiler-log-file ((name &rest wcu-keys) &body forms)
229 wlott 1.1 `(if *interactive*
230 ram 1.13 (with-compilation-unit (,@wcu-keys)
231 wlott 1.1 ,@forms)
232     (let ((*log-file* (open ,name :direction :output
233     :if-exists :append
234     :if-does-not-exist :create)))
235     (unwind-protect
236 ram 1.4 (let ((*error-output* *log-file*)
237     (*last-file-position* (file-position *log-file*)))
238 ram 1.13 (with-compilation-unit (,@wcu-keys)
239 wlott 1.1 ,@forms))
240     (close *log-file*)))))
241    
242    
243 ram 1.24 (defun comf (name &rest keys &key proceed assem &allow-other-keys)
244 ram 1.4 (when (and *log-file*
245     (> (- (file-position *log-file*) *last-file-position*) 10000))
246     (setq *last-file-position* (file-position *log-file*))
247     (force-output *log-file*))
248 wlott 1.1
249 wlott 1.21 (let* ((src (merge-pathnames name (make-pathname :type "lisp")))
250 ram 1.24 (obj (if assem
251     (make-pathname :defaults src :type "assem")
252     (apply #'compile-file-pathname src keys))))
253 wlott 1.1
254 ram 1.12 (unless (and (probe-file obj)
255     (>= (file-write-date obj) (file-write-date src)))
256 ram 1.25 (write-line (namestring name))
257 wlott 1.1 (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
258     (ext:format-universal-time nil (get-universal-time))
259     name)
260 ram 1.12 (catch 'blow-this-file
261 wlott 1.20 (with-simple-restart
262     (continue "Blow this file")
263     (cond
264     (*interactive*
265 ram 1.12 (if assem
266     (c::assemble-file src :output-file obj)
267 ram 1.24 (apply #'compile-file src :allow-other-keys t keys)))
268 wlott 1.20 (t
269     (handler-bind
270     ((error #'(lambda (condition)
271 ram 1.23 (unless (typep condition 'c::compiler-error)
272     (format *error-output* "~2&~A~2&"
273     condition)
274     (when proceed
275     (format *error-output* "Proceeding...~%")
276     (continue))
277     (format *error-output* "Aborting...~%")
278     (handler-case
279     (let ((*debug-io* *error-output*))
280     (debug:backtrace))
281     (error (condition)
282     (declare (ignore condition))
283     (format t "Error in backtrace!~%")))
284     (format t "Error abort.~%")
285     (return-from comf)))))
286 wlott 1.20 (if assem
287     (c::assemble-file src :output-file obj)
288 ram 1.24 (apply #'compile-file src :allow-other-keys t keys))))))))))
289 wlott 1.19
290 ram 1.26
291     ;;; VMDIR -- Interface
292     ;;;
293     (defun vmdir (f)
294     (merge-pathnames
295     (make-pathname :directory nil :defaults f)
296     (merge-pathnames
297     (cond ((c:target-featurep :pmax) "mips/")
298     ((c:target-featurep :rt) "rt/")
299     ((c:target-featurep :hppa) "hppa/")
300     ((c:target-featurep :sparc) "sparc/")
301     ((c:target-featurep :x86) "x86/")
302 hallgren 1.27 ((c:target-featurep :alpha) "alpha/")
303 hallgren 1.28 ((c:target-featurep :sgi) "mips/")
304 dtc 1.30 ((c:target-featurep :ppc) "ppc/")
305 cwang 1.39 ((c:target-featurep :amd64) "amd64/")
306 ram 1.26 (t
307     (error "What machine is this?")))
308     (make-pathname :directory (pathname-directory f)))))
309 wlott 1.19
310    
311 cwang 1.39 ;;; CAT-IF-ANYTHING-CHANGED
312 wlott 1.19
313     (defun cat-if-anything-changed (output-file &rest input-files)
314     (flet ((add-correct-type (pathname)
315 ram 1.24 (or (probe-file
316     (make-pathname :type (c:backend-byte-fasl-file-type
317     c:*target-backend*)
318     :defaults pathname))
319     (make-pathname :type (c:backend-fasl-file-type
320     c:*target-backend*)
321     :defaults pathname))))
322 wlott 1.19 (let* ((output-file (add-correct-type output-file))
323     (write-date (file-write-date output-file))
324     (input-namestrings
325     (mapcar #'(lambda (file)
326     (let ((file (add-correct-type file)))
327     (let ((src-write-date (file-write-date file)))
328     (unless src-write-date
329     (error "Missing file: ~S" file))
330     (when (and write-date
331     (> src-write-date write-date))
332     (setf write-date nil)))
333     (unix-namestring file)))
334     input-files)))
335     (cond ((null write-date)
336     (format t "~S out of date.~%" (namestring output-file))
337     (run-program "/bin/cat" input-namestrings
338     :output output-file
339     :if-output-exists :supersede
340     :error t))
341     (t
342     (format t "~S up to date.~%" (namestring output-file)))))))
343 emarsden 1.32

  ViewVC Help
Powered by ViewVC 1.1.5