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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (hide annotations)
Fri Aug 21 00:10:22 1992 UTC (21 years, 8 months ago) by wlott
Branch: MAIN
Changes since 1.18: +30 -0 lines
Added CAT-IF-ANYTHING-CHANGED, for use with creating {clx,hemlock}-library
only when necessary.
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 ram 1.9 ;;;; Compile utility:
132 wlott 1.1
133 ram 1.9 ;;; Switches:
134     ;;;
135 ram 1.12 (defvar *interactive* t) ; Batch compilation mode?
136 ram 1.9
137 wlott 1.1 (defvar *log-file* nil)
138 ram 1.4 (defvar *last-file-position*)
139 wlott 1.1
140 ram 1.13 (defmacro with-compiler-log-file ((name &rest wcu-keys) &body forms)
141 wlott 1.1 `(if *interactive*
142 ram 1.13 (with-compilation-unit (,@wcu-keys)
143 wlott 1.1 ,@forms)
144     (let ((*log-file* (open ,name :direction :output
145     :if-exists :append
146     :if-does-not-exist :create)))
147     (unwind-protect
148 ram 1.4 (let ((*error-output* *log-file*)
149     (*last-file-position* (file-position *log-file*)))
150 ram 1.13 (with-compilation-unit (,@wcu-keys)
151 wlott 1.1 ,@forms))
152     (close *log-file*)))))
153    
154    
155 ram 1.12 (defun comf (name &key always-once proceed load output-file assem)
156 wlott 1.1 (declare (ignore always-once))
157 ram 1.4 (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 wlott 1.1
162     (let* ((src (pathname (concatenate 'string name ".lisp")))
163     (obj (if output-file
164     (pathname output-file)
165     (make-pathname :defaults src
166 ram 1.12 :type
167     (if assem
168     "assem"
169     (c:backend-fasl-file-type c:*backend*))))))
170 wlott 1.1
171 ram 1.12 (unless (and (probe-file obj)
172     (>= (file-write-date obj) (file-write-date src)))
173 wlott 1.1 (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 ram 1.12 (catch 'blow-this-file
178     (cond
179     (*interactive*
180     (if assem
181     (c::assemble-file src :output-file obj)
182     (compile-file src :error-file nil :output-file obj))
183 wlott 1.1 (when load
184 ram 1.12 (load name :verbose t)))
185     (t
186     (handler-bind ((error #'(lambda (condition)
187     (format *error-output* "~2&~A~2&"
188     condition)
189     (when proceed
190     (format *error-output* "Proceeding...~%")
191     (continue))
192     (format *error-output* "Aborting...~%")
193     (handler-case
194     (let ((*debug-io* *error-output*))
195     (debug:backtrace))
196     (error (condition)
197     (declare (ignore condition))
198     (format t "Error in backtrace!~%")))
199     (format t "Error abort.~%")
200     (return-from comf))))
201     (if assem
202     (c::assemble-file src :output-file obj)
203     (compile-file src :error-file nil :output-file obj))
204     (when load
205     (load name :verbose t)))))))))
206 wlott 1.19
207    
208    
209     ;;; CAT-IF-ANYTHING-CHAGNED
210    
211     (defun cat-if-anything-changed (output-file &rest input-files)
212     (flet ((add-correct-type (pathname)
213     (make-pathname :type (c:backend-fasl-file-type c:*target-backend*)
214     :defaults pathname)))
215     (let* ((output-file (add-correct-type output-file))
216     (write-date (file-write-date output-file))
217     (input-namestrings
218     (mapcar #'(lambda (file)
219     (let ((file (add-correct-type file)))
220     (let ((src-write-date (file-write-date file)))
221     (unless src-write-date
222     (error "Missing file: ~S" file))
223     (when (and write-date
224     (> src-write-date write-date))
225     (setf write-date nil)))
226     (unix-namestring file)))
227     input-files)))
228     (cond ((null write-date)
229     (format t "~S out of date.~%" (namestring output-file))
230     (run-program "/bin/cat" input-namestrings
231     :output output-file
232     :if-output-exists :supersede
233     :error t))
234     (t
235     (format t "~S up to date.~%" (namestring output-file)))))))

  ViewVC Help
Powered by ViewVC 1.1.5