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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (show annotations)
Thu Jul 22 08:53:56 1993 UTC (20 years, 9 months ago) by wlott
Branch: MAIN
Changes since 1.20: +1 -1 lines
Changed comf to not force the pathname type to ``lisp'' but to default it
to lisp if unsupplied.
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 &key always-once proceed load output-file assem)
156 (declare (ignore always-once))
157 (when (and *log-file*
158 (> (- (file-position *log-file*) *last-file-position*) 10000))
159 (setq *last-file-position* (file-position *log-file*))
160 (force-output *log-file*))
161
162 (let* ((src (merge-pathnames name (make-pathname :type "lisp")))
163 (obj (if output-file
164 (pathname output-file)
165 (make-pathname :defaults src
166 :type
167 (if assem
168 "assem"
169 (c:backend-fasl-file-type c:*backend*))))))
170
171 (unless (and (probe-file obj)
172 (>= (file-write-date obj) (file-write-date src)))
173 (write-line name)
174 (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
175 (ext:format-universal-time nil (get-universal-time))
176 name)
177 (catch 'blow-this-file
178 (with-simple-restart
179 (continue "Blow this file")
180 (cond
181 (*interactive*
182 (if assem
183 (c::assemble-file src :output-file obj)
184 (compile-file src :error-file nil :output-file obj))
185 (when load
186 (load name :verbose t)))
187 (t
188 (handler-bind
189 ((error #'(lambda (condition)
190 (format *error-output* "~2&~A~2&"
191 condition)
192 (when proceed
193 (format *error-output* "Proceeding...~%")
194 (continue))
195 (format *error-output* "Aborting...~%")
196 (handler-case
197 (let ((*debug-io* *error-output*))
198 (debug:backtrace))
199 (error (condition)
200 (declare (ignore condition))
201 (format t "Error in backtrace!~%")))
202 (format t "Error abort.~%")
203 (return-from comf))))
204 (if assem
205 (c::assemble-file src :output-file obj)
206 (compile-file src :error-file nil :output-file obj))
207 (when load
208 (load name :verbose t))))))))))
209
210
211
212 ;;; CAT-IF-ANYTHING-CHAGNED
213
214 (defun cat-if-anything-changed (output-file &rest input-files)
215 (flet ((add-correct-type (pathname)
216 (make-pathname :type (c:backend-fasl-file-type c:*target-backend*)
217 :defaults pathname)))
218 (let* ((output-file (add-correct-type output-file))
219 (write-date (file-write-date output-file))
220 (input-namestrings
221 (mapcar #'(lambda (file)
222 (let ((file (add-correct-type file)))
223 (let ((src-write-date (file-write-date file)))
224 (unless src-write-date
225 (error "Missing file: ~S" file))
226 (when (and write-date
227 (> src-write-date write-date))
228 (setf write-date nil)))
229 (unix-namestring file)))
230 input-files)))
231 (cond ((null write-date)
232 (format t "~S out of date.~%" (namestring output-file))
233 (run-program "/bin/cat" input-namestrings
234 :output output-file
235 :if-output-exists :supersede
236 :error t))
237 (t
238 (format t "~S up to date.~%" (namestring output-file)))))))

  ViewVC Help
Powered by ViewVC 1.1.5