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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Tue Aug 31 13:50:44 1993 UTC (20 years, 7 months ago) by hallgren
Branch: MAIN
Changes since 1.26: +1 -0 lines
Added support for the Alpha.
1 ;;; -*- Package: USER -*-
2 ;;;
3 ;;; Set up package environment and search lists for compiler. Also some
4 ;;; compilation utilities.
5 ;;;
6 (in-package "USER")
7
8
9 ;;; DUMP-PACKAGE-STATE -- Public
10 ;;;
11 (defun dump-package-state (packages file)
12 (declare (type (or list package symbol string) packages)
13 (type (or pathname symbol string) file))
14 (let* ((packages (lisp::package-listify packages)))
15 (collect ((forms))
16 (dolist (pkg packages)
17 (let ((nicks (package-nicknames pkg))
18 (name (package-name pkg))
19 (shad (package-shadowing-symbols pkg)))
20 (forms `(if (find-package ,name)
21 (rename-package ,name ,name ',nicks)
22 (make-package ,name :nicknames ',nicks :use nil)))
23 (when shad
24 (forms `(shadow ',(mapcar #'string shad) ,name)))))
25
26 (dolist (pkg packages)
27 (forms `(use-package ',(mapcar #'package-name
28 (package-use-list pkg))
29 ,(package-name pkg))))
30
31 (dolist (old packages)
32 (collect ((exports))
33 (let ((imports (make-hash-table :test #'eq)))
34 (do-symbols (sym old)
35 (let ((pkg (symbol-package sym))
36 (name (symbol-name sym)))
37 (multiple-value-bind (found how)
38 (find-symbol name old)
39 (assert (and (eq found sym) how))
40 (cond
41 ((not pkg)
42 (warn "Not dumping uninterned symbol ~S." sym))
43 ((eq how :inherited))
44 (t
45 (unless (eq pkg old)
46 (pushnew name (gethash pkg imports) :test #'string=))
47 (when (eq how :external)
48 (exports name)))))))
49 (collect ((import-froms))
50 (maphash #'(lambda (pkg raw-names)
51 (let ((names (sort (delete-duplicates raw-names
52 :test
53 #'string=)
54 #'string<))
55 (pkg-name (package-name pkg)))
56 (when names
57 (import-froms `(:import-from ,pkg-name ,@names))
58 (dolist (name names)
59 (forms `(intern ,name ,pkg-name))))))
60 imports)
61 (forms `(defpackage ,(package-name old)
62 ,@(import-froms)
63 ,@(when (exports)
64 `((:export
65 ,@(sort (delete-duplicates (exports)
66 :test #'string=)
67 #'string<))))))))))
68
69 (with-open-file (s file :direction :output :if-exists :new-version)
70 (dolist (form (forms))
71 (write form :stream s :pretty t)
72 (terpri s)))))
73
74 (values))
75
76
77 ;;; COPY-PACKAGES -- Public
78 ;;;
79 (defun copy-packages (packages)
80 "Rename all the of the Named packages to OLD-Name, and then create new
81 packages for each name that have the same names, nicknames, imports, shadows
82 and exports. If any of the OLD-Name packages already exist, then we quietly
83 do nothing."
84 (let* ((packages (lisp::package-listify packages))
85 (names (mapcar #'package-name packages))
86 (new-names (mapcar #'(lambda (x)
87 (concatenate 'string "OLD-" x))
88 names)))
89 (unless (some #'find-package new-names)
90 (collect ((new-packages))
91 (flet ((trans-pkg (x)
92 (or (cdr (assoc x (new-packages))) x)))
93 (loop for pkg in packages and new in new-names do
94 (let ((nicks (package-nicknames pkg))
95 (name (package-name pkg)))
96 (rename-package pkg new)
97 (let ((new-pkg (make-package name :nicknames nicks :use nil))
98 (shad (package-shadowing-symbols pkg)))
99 (when shad
100 (shadow shad new-pkg))
101 (new-packages (cons pkg new-pkg)))))
102
103 (loop for (old . new) in (new-packages) do
104 (dolist (use (package-use-list old))
105 (use-package (trans-pkg use) new)))
106
107 (loop for (old . new) in (new-packages) do
108 (do-symbols (sym old)
109 (let ((pkg (symbol-package sym))
110 (name (symbol-name sym)))
111 (multiple-value-bind (found how)
112 (find-symbol name old)
113 (assert (and (eq found sym) how))
114 (cond
115 ((not pkg)
116 (warn "Not copying uninterned symbol ~S." sym))
117 ((or (eq how :inherited)
118 (and (eq how :internal) (eq pkg old))))
119 (t
120 (let* ((npkg (trans-pkg pkg))
121 (nsym (intern name npkg)))
122 (multiple-value-bind (ignore new-how)
123 (find-symbol name new)
124 (declare (ignore ignore))
125 (unless new-how (import nsym new)))
126 (when (eq how :external)
127 (export nsym new)))))))))))))
128 (values))
129
130
131 ;;;; Compile utility:
132
133 ;;; Switches:
134 ;;;
135 (defvar *interactive* t) ; Batch compilation mode?
136
137 (defvar *log-file* nil)
138 (defvar *last-file-position*)
139
140 (defmacro with-compiler-log-file ((name &rest wcu-keys) &body forms)
141 `(if *interactive*
142 (with-compilation-unit (,@wcu-keys)
143 ,@forms)
144 (let ((*log-file* (open ,name :direction :output
145 :if-exists :append
146 :if-does-not-exist :create)))
147 (unwind-protect
148 (let ((*error-output* *log-file*)
149 (*last-file-position* (file-position *log-file*)))
150 (with-compilation-unit (,@wcu-keys)
151 ,@forms))
152 (close *log-file*)))))
153
154
155 (defun comf (name &rest keys &key proceed assem &allow-other-keys)
156 (when (and *log-file*
157 (> (- (file-position *log-file*) *last-file-position*) 10000))
158 (setq *last-file-position* (file-position *log-file*))
159 (force-output *log-file*))
160
161 (let* ((src (merge-pathnames name (make-pathname :type "lisp")))
162 (obj (if assem
163 (make-pathname :defaults src :type "assem")
164 (apply #'compile-file-pathname src keys))))
165
166 (unless (and (probe-file obj)
167 (>= (file-write-date obj) (file-write-date src)))
168 (write-line (namestring name))
169 (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
170 (ext:format-universal-time nil (get-universal-time))
171 name)
172 (catch 'blow-this-file
173 (with-simple-restart
174 (continue "Blow this file")
175 (cond
176 (*interactive*
177 (if assem
178 (c::assemble-file src :output-file obj)
179 (apply #'compile-file src :allow-other-keys t keys)))
180 (t
181 (handler-bind
182 ((error #'(lambda (condition)
183 (unless (typep condition 'c::compiler-error)
184 (format *error-output* "~2&~A~2&"
185 condition)
186 (when proceed
187 (format *error-output* "Proceeding...~%")
188 (continue))
189 (format *error-output* "Aborting...~%")
190 (handler-case
191 (let ((*debug-io* *error-output*))
192 (debug:backtrace))
193 (error (condition)
194 (declare (ignore condition))
195 (format t "Error in backtrace!~%")))
196 (format t "Error abort.~%")
197 (return-from comf)))))
198 (if assem
199 (c::assemble-file src :output-file obj)
200 (apply #'compile-file src :allow-other-keys t keys))))))))))
201
202
203 ;;; VMDIR -- Interface
204 ;;;
205 (defun vmdir (f)
206 (merge-pathnames
207 (make-pathname :directory nil :defaults f)
208 (merge-pathnames
209 (cond ((c:target-featurep :pmax) "mips/")
210 ((c:target-featurep :rt) "rt/")
211 ((c:target-featurep :hppa) "hppa/")
212 ((c:target-featurep :sparc) "sparc/")
213 ((c:target-featurep :x86) "x86/")
214 ((c:target-featurep :alpha) "alpha/")
215 (t
216 (error "What machine is this?")))
217 (make-pathname :directory (pathname-directory f)))))
218
219
220 ;;; CAT-IF-ANYTHING-CHAGNED
221
222 (defun cat-if-anything-changed (output-file &rest input-files)
223 (flet ((add-correct-type (pathname)
224 (or (probe-file
225 (make-pathname :type (c:backend-byte-fasl-file-type
226 c:*target-backend*)
227 :defaults pathname))
228 (make-pathname :type (c:backend-fasl-file-type
229 c:*target-backend*)
230 :defaults pathname))))
231 (let* ((output-file (add-correct-type output-file))
232 (write-date (file-write-date output-file))
233 (input-namestrings
234 (mapcar #'(lambda (file)
235 (let ((file (add-correct-type file)))
236 (let ((src-write-date (file-write-date file)))
237 (unless src-write-date
238 (error "Missing file: ~S" file))
239 (when (and write-date
240 (> src-write-date write-date))
241 (setf write-date nil)))
242 (unix-namestring file)))
243 input-files)))
244 (cond ((null write-date)
245 (format t "~S out of date.~%" (namestring output-file))
246 (run-program "/bin/cat" input-namestrings
247 :output output-file
248 :if-output-exists :supersede
249 :error t))
250 (t
251 (format t "~S up to date.~%" (namestring output-file)))))))

  ViewVC Help
Powered by ViewVC 1.1.5