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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5