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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (hide annotations)
Wed Mar 4 09:59:11 1992 UTC (22 years, 1 month ago) by wlott
Branch: MAIN
Changes since 1.15: +10 -14 lines
Some hacks to new-backend:  The misfeatures are now specified as an
argument instead of a defparameter, and it's not assumed that the VM
package exists.
1 wlott 1.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 ram 1.12
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 wlott 1.14 (forms `(if (find-package ,name)
21     (rename-package ,name ,name ',nicks)
22     (make-package ,name :nicknames ',nicks :use nil)))
23 ram 1.12 (when shad
24     (forms `(shadow ',(mapcar #'string shad) ,name)))))
25 ram 1.11
26 ram 1.12 (dolist (pkg packages)
27     (forms `(use-package ',(mapcar #'package-name
28     (package-use-list pkg))
29     ,(package-name pkg))))
30 ram 1.4
31 ram 1.12 (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 wlott 1.14 (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 ram 1.4
69 ram 1.12 (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 wlott 1.1
74 ram 1.12 (values))
75 ram 1.2
76 ram 1.12
77     ;;; COPY-PACKAGES -- Public
78 ram 1.8 ;;;
79 ram 1.12 (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 wlott 1.1
103 ram 1.12 (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 wlott 1.14
130    
131     ;;;; NEW-BACKEND
132    
133 wlott 1.16 (defun new-backend (name features misfeatures)
134 wlott 1.14 ;; If VM names a different package, rename that package so that VM doesn't
135     ;; name it.
136 wlott 1.16 (let ((pkg (find-package "VM")))
137     (when pkg
138     (let ((pkg-name (package-name pkg)))
139     (unless (string= pkg-name name)
140     (rename-package pkg pkg-name
141     (remove "VM" (package-nicknames pkg)
142     :test #'string=))
143     (unuse-package pkg "C")))))
144 wlott 1.14 ;; Make sure VM names our package, creating it if necessary.
145     (let* ((pkg (or (find-package name)
146     (make-package name :nicknames '("VM"))))
147     (nicknames (package-nicknames pkg)))
148     (unless (member "VM" nicknames :test #'string=)
149     (rename-package pkg name (cons "VM" nicknames)))
150     ;; And make sure we are using the necessary packages.
151     (use-package "C" pkg)
152     (use-package "ASSEM" pkg)
153     (use-package "EXT" pkg)
154     (use-package "KERNEL" pkg)
155     (use-package "SYSTEM" pkg)
156     (use-package "ALIEN" pkg)
157     (use-package "C-CALL" pkg))
158     ;; Make sure the native info env and features list are stored in
159     ;; *native-backend*
160     (unless (c:backend-info-environment c:*native-backend*)
161     (setf (c:backend-info-environment c:*native-backend*) *info-environment*))
162     (unless (c:backend-features c:*native-backend*)
163     (setf (c:backend-features c:*native-backend*) *features*))
164     ;; Cons up a backend structure, filling in the info-env and features slots.
165     (let ((backend (c::make-backend
166     :name name
167     :info-environment
168     (cons (c::make-info-environment
169     :name
170     (concatenate 'string name " backend"))
171     (remove-if #'(lambda (name)
172     (let ((len (length name)))
173     (and (> len 8)
174     (string= name " backend"
175     :start1 (- len 8)))))
176     *info-environment*
177     :key #'c::info-env-name))
178     :features
179 wlott 1.16 (append features (set-difference *features* misfeatures)))))
180 wlott 1.14 (setf c:*target-backend* backend)))
181    
182 wlott 1.1
183 ram 1.9
184     ;;;; Compile utility:
185 wlott 1.1
186 ram 1.9 ;;; Switches:
187     ;;;
188 ram 1.12 (defvar *interactive* t) ; Batch compilation mode?
189 ram 1.9
190 wlott 1.1 (defvar *log-file* nil)
191 ram 1.4 (defvar *last-file-position*)
192 wlott 1.1
193 ram 1.13 (defmacro with-compiler-log-file ((name &rest wcu-keys) &body forms)
194 wlott 1.1 `(if *interactive*
195 ram 1.13 (with-compilation-unit (,@wcu-keys)
196 wlott 1.1 ,@forms)
197     (let ((*log-file* (open ,name :direction :output
198     :if-exists :append
199     :if-does-not-exist :create)))
200     (unwind-protect
201 ram 1.4 (let ((*error-output* *log-file*)
202     (*last-file-position* (file-position *log-file*)))
203 ram 1.13 (with-compilation-unit (,@wcu-keys)
204 wlott 1.1 ,@forms))
205     (close *log-file*)))))
206    
207    
208 ram 1.12 (defun comf (name &key always-once proceed load output-file assem)
209 wlott 1.1 (declare (ignore always-once))
210 ram 1.4 (when (and *log-file*
211     (> (- (file-position *log-file*) *last-file-position*) 10000))
212     (setq *last-file-position* (file-position *log-file*))
213     (force-output *log-file*))
214 wlott 1.1
215     (let* ((src (pathname (concatenate 'string name ".lisp")))
216     (obj (if output-file
217     (pathname output-file)
218     (make-pathname :defaults src
219 ram 1.12 :type
220     (if assem
221     "assem"
222     (c:backend-fasl-file-type c:*backend*))))))
223 wlott 1.1
224 ram 1.12 (unless (and (probe-file obj)
225     (>= (file-write-date obj) (file-write-date src)))
226 wlott 1.1 (write-line name)
227     (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
228     (ext:format-universal-time nil (get-universal-time))
229     name)
230 ram 1.12 (catch 'blow-this-file
231     (cond
232     (*interactive*
233     (if assem
234     (c::assemble-file src :output-file obj)
235     (compile-file src :error-file nil :output-file obj))
236 wlott 1.1 (when load
237 ram 1.12 (load name :verbose t)))
238     (t
239     (handler-bind ((error #'(lambda (condition)
240     (format *error-output* "~2&~A~2&"
241     condition)
242     (when proceed
243     (format *error-output* "Proceeding...~%")
244     (continue))
245     (format *error-output* "Aborting...~%")
246     (handler-case
247     (let ((*debug-io* *error-output*))
248     (debug:backtrace))
249     (error (condition)
250     (declare (ignore condition))
251     (format t "Error in backtrace!~%")))
252     (format t "Error abort.~%")
253     (return-from comf))))
254     (if assem
255     (c::assemble-file src :output-file obj)
256     (compile-file src :error-file nil :output-file obj))
257     (when load
258     (load name :verbose t)))))))))
259 wlott 1.1
260 wlott 1.15
261    
262     ;;;; BACKEND-FEATUREP and TARGET-FEATUREP
263    
264     (defun target-featurep (feature)
265     (let ((*features* (c:backend-features c:*target-backend*)))
266     (lisp::featurep feature)))
267    
268     (defun backend-featurep (feature)
269     (let ((*features* (c:backend-features c:*backend*)))
270     (lisp::featurep feature)))

  ViewVC Help
Powered by ViewVC 1.1.5