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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Wed Feb 26 01:10:20 1992 UTC (22 years, 1 month ago) by wlott
Branch: MAIN
Changes since 1.13: +79 -9 lines
Added NEW-BACKEND for use with cross-compiling.  Some tweeks to package
state dumping.
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 ;;;; NEW-BACKEND
132
133 (defparameter machine-specific-features
134 '(:small :mach :sunos :unix :pmax :decstation-3100
135 :ibm-pc-rt :ibmrt :rt :SPARCstation :sparc :sun4))
136
137 (defun new-backend (name &rest features)
138 ;; If VM names a different package, rename that package so that VM doesn't
139 ;; name it.
140 (let* ((pkg (find-package "VM"))
141 (pkg-name (package-name pkg)))
142 (unless (string= pkg-name name)
143 (rename-package pkg pkg-name
144 (remove "VM" (package-nicknames pkg) :test #'string=))
145 (unuse-package pkg "C")))
146 ;; Make sure VM names our package, creating it if necessary.
147 (let* ((pkg (or (find-package name)
148 (make-package name :nicknames '("VM"))))
149 (nicknames (package-nicknames pkg)))
150 (unless (member "VM" nicknames :test #'string=)
151 (rename-package pkg name (cons "VM" nicknames)))
152 ;; And make sure we are using the necessary packages.
153 (use-package "C" pkg)
154 (use-package "ASSEM" pkg)
155 (use-package "EXT" pkg)
156 (use-package "KERNEL" pkg)
157 (use-package "SYSTEM" pkg)
158 (use-package "ALIEN" pkg)
159 (use-package "C-CALL" pkg))
160 ;; Make sure the native info env and features list are stored in
161 ;; *native-backend*
162 (unless (c:backend-info-environment c:*native-backend*)
163 (setf (c:backend-info-environment c:*native-backend*) *info-environment*))
164 (unless (c:backend-features c:*native-backend*)
165 (setf (c:backend-features c:*native-backend*) *features*))
166 ;; Cons up a backend structure, filling in the info-env and features slots.
167 (let ((backend (c::make-backend
168 :name name
169 :info-environment
170 (cons (c::make-info-environment
171 :name
172 (concatenate 'string name " backend"))
173 (remove-if #'(lambda (name)
174 (let ((len (length name)))
175 (and (> len 8)
176 (string= name " backend"
177 :start1 (- len 8)))))
178 *info-environment*
179 :key #'c::info-env-name))
180 :features
181 (append features
182 (set-difference *features*
183 machine-specific-features)))))
184 (setf c:*target-backend* backend)))
185
186
187
188 ;;;; Compile utility:
189
190 ;;; Switches:
191 ;;;
192 (defvar *interactive* t) ; Batch compilation mode?
193
194 (defvar *log-file* nil)
195 (defvar *last-file-position*)
196
197 (defmacro with-compiler-log-file ((name &rest wcu-keys) &body forms)
198 `(if *interactive*
199 (with-compilation-unit (,@wcu-keys)
200 ,@forms)
201 (let ((*log-file* (open ,name :direction :output
202 :if-exists :append
203 :if-does-not-exist :create)))
204 (unwind-protect
205 (let ((*error-output* *log-file*)
206 (*last-file-position* (file-position *log-file*)))
207 (with-compilation-unit (,@wcu-keys)
208 ,@forms))
209 (close *log-file*)))))
210
211
212 (defun comf (name &key always-once proceed load output-file assem)
213 (declare (ignore always-once))
214 (when (and *log-file*
215 (> (- (file-position *log-file*) *last-file-position*) 10000))
216 (setq *last-file-position* (file-position *log-file*))
217 (force-output *log-file*))
218
219 (let* ((src (pathname (concatenate 'string name ".lisp")))
220 (obj (if output-file
221 (pathname output-file)
222 (make-pathname :defaults src
223 :type
224 (if assem
225 "assem"
226 (c:backend-fasl-file-type c:*backend*))))))
227
228 (unless (and (probe-file obj)
229 (>= (file-write-date obj) (file-write-date src)))
230 (write-line name)
231 (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
232 (ext:format-universal-time nil (get-universal-time))
233 name)
234 (catch 'blow-this-file
235 (cond
236 (*interactive*
237 (if assem
238 (c::assemble-file src :output-file obj)
239 (compile-file src :error-file nil :output-file obj))
240 (when load
241 (load name :verbose t)))
242 (t
243 (handler-bind ((error #'(lambda (condition)
244 (format *error-output* "~2&~A~2&"
245 condition)
246 (when proceed
247 (format *error-output* "Proceeding...~%")
248 (continue))
249 (format *error-output* "Aborting...~%")
250 (handler-case
251 (let ((*debug-io* *error-output*))
252 (debug:backtrace))
253 (error (condition)
254 (declare (ignore condition))
255 (format t "Error in backtrace!~%")))
256 (format t "Error abort.~%")
257 (return-from comf))))
258 (if assem
259 (c::assemble-file src :output-file obj)
260 (compile-file src :error-file nil :output-file obj))
261 (when load
262 (load name :verbose t)))))))))
263

  ViewVC Help
Powered by ViewVC 1.1.5