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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Fri Mar 8 19:36:20 1991 UTC (23 years, 1 month ago) by ram
Branch: MAIN
Changes since 1.11: +137 -267 lines
Merged in many changes from william's play area (mostly ripping out 
old hacks.)  Also, added some package hacks for renaming packages
and dumping package state.
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     (forms `(unless (find-package ,name)
21     (make-package ,name :nicknames ',nicks :use nil)))
22     (when shad
23     (forms `(shadow ',(mapcar #'string shad) ,name)))))
24 ram 1.11
25 ram 1.12 (dolist (pkg packages)
26     (forms `(use-package ',(mapcar #'package-name
27     (package-use-list pkg))
28     ,(package-name pkg))))
29 ram 1.4
30 ram 1.12 (dolist (old packages)
31     (collect ((exports))
32     (let ((imports (make-hash-table :test #'eq)))
33     (do-symbols (sym old)
34     (let ((pkg (symbol-package sym))
35     (name (symbol-name sym)))
36     (multiple-value-bind (found how)
37     (find-symbol name old)
38     (assert (and (eq found sym) how))
39     (cond
40     ((not pkg)
41     (warn "Not dumping uninterned symbol ~S." sym))
42     ((eq how :inherited))
43     (t
44     (unless (eq pkg old)
45     (pushnew name (gethash pkg imports) :test #'string=))
46     (when (eq how :external)
47     (exports name)))))))
48     (forms `(defpackage ,(package-name old)
49     ,@(loop for pkg being each hash-key in imports
50     for names being each hash-value in imports
51     collect `(:import-from ,(package-name pkg)
52     ,@names))
53     ,@(when (exports)
54     `((:export ,@(exports)))))))))
55 ram 1.4
56 ram 1.12 (with-open-file (s file :direction :output :if-exists :new-version)
57     (dolist (form (forms))
58     (write form :stream s :pretty t)
59     (terpri s)))))
60 wlott 1.1
61 ram 1.12 (values))
62 ram 1.2
63 ram 1.12
64     ;;; COPY-PACKAGES -- Public
65 ram 1.8 ;;;
66 ram 1.12 (defun copy-packages (packages)
67     "Rename all the of the Named packages to OLD-Name, and then create new
68     packages for each name that have the same names, nicknames, imports, shadows
69     and exports. If any of the OLD-Name packages already exist, then we quietly
70     do nothing."
71     (let* ((packages (lisp::package-listify packages))
72     (names (mapcar #'package-name packages))
73     (new-names (mapcar #'(lambda (x)
74     (concatenate 'string "OLD-" x))
75     names)))
76     (unless (some #'find-package new-names)
77     (collect ((new-packages))
78     (flet ((trans-pkg (x)
79     (or (cdr (assoc x (new-packages))) x)))
80     (loop for pkg in packages and new in new-names do
81     (let ((nicks (package-nicknames pkg))
82     (name (package-name pkg)))
83     (rename-package pkg new)
84     (let ((new-pkg (make-package name :nicknames nicks :use nil))
85     (shad (package-shadowing-symbols pkg)))
86     (when shad
87     (shadow shad new-pkg))
88     (new-packages (cons pkg new-pkg)))))
89 wlott 1.1
90 ram 1.12 (loop for (old . new) in (new-packages) do
91     (dolist (use (package-use-list old))
92     (use-package (trans-pkg use) new)))
93    
94     (loop for (old . new) in (new-packages) do
95     (do-symbols (sym old)
96     (let ((pkg (symbol-package sym))
97     (name (symbol-name sym)))
98     (multiple-value-bind (found how)
99     (find-symbol name old)
100     (assert (and (eq found sym) how))
101     (cond
102     ((not pkg)
103     (warn "Not copying uninterned symbol ~S." sym))
104     ((or (eq how :inherited)
105     (and (eq how :internal) (eq pkg old))))
106     (t
107     (let* ((npkg (trans-pkg pkg))
108     (nsym (intern name npkg)))
109     (multiple-value-bind (ignore new-how)
110     (find-symbol name new)
111     (declare (ignore ignore))
112     (unless new-how (import nsym new)))
113     (when (eq how :external)
114     (export nsym new)))))))))))))
115     (values))
116 wlott 1.1
117 ram 1.9
118     ;;;; Compile utility:
119 wlott 1.1
120 ram 1.9 ;;; Switches:
121     ;;;
122 ram 1.12 (defvar *interactive* t) ; Batch compilation mode?
123 ram 1.9
124 wlott 1.1 (defvar *log-file* nil)
125 ram 1.4 (defvar *last-file-position*)
126 wlott 1.1
127     (defmacro with-compiler-log-file ((name) &body forms)
128     `(if *interactive*
129     (with-compilation-unit ()
130     ,@forms)
131     (let ((*log-file* (open ,name :direction :output
132     :if-exists :append
133     :if-does-not-exist :create)))
134     (unwind-protect
135 ram 1.4 (let ((*error-output* *log-file*)
136     (*last-file-position* (file-position *log-file*)))
137 wlott 1.1 (with-compilation-unit ()
138     ,@forms))
139     (close *log-file*)))))
140    
141    
142 ram 1.12 (defun comf (name &key always-once proceed load output-file assem)
143 wlott 1.1 (declare (ignore always-once))
144 ram 1.4 (when (and *log-file*
145     (> (- (file-position *log-file*) *last-file-position*) 10000))
146     (setq *last-file-position* (file-position *log-file*))
147     (force-output *log-file*))
148 wlott 1.1
149     (let* ((src (pathname (concatenate 'string name ".lisp")))
150     (obj (if output-file
151     (pathname output-file)
152     (make-pathname :defaults src
153 ram 1.12 :type
154     (if assem
155     "assem"
156     (c:backend-fasl-file-type c:*backend*))))))
157 wlott 1.1
158 ram 1.12 (unless (and (probe-file obj)
159     (>= (file-write-date obj) (file-write-date src)))
160 wlott 1.1 (write-line name)
161     (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
162     (ext:format-universal-time nil (get-universal-time))
163     name)
164 ram 1.12 (catch 'blow-this-file
165     (cond
166     (*interactive*
167     (if assem
168     (c::assemble-file src :output-file obj)
169     (compile-file src :error-file nil :output-file obj))
170 wlott 1.1 (when load
171 ram 1.12 (load name :verbose t)))
172     (t
173     (handler-bind ((error #'(lambda (condition)
174     (format *error-output* "~2&~A~2&"
175     condition)
176     (when proceed
177     (format *error-output* "Proceeding...~%")
178     (continue))
179     (format *error-output* "Aborting...~%")
180     (handler-case
181     (let ((*debug-io* *error-output*))
182     (debug:backtrace))
183     (error (condition)
184     (declare (ignore condition))
185     (format t "Error in backtrace!~%")))
186     (format t "Error abort.~%")
187     (return-from comf))))
188     (if assem
189     (c::assemble-file src :output-file obj)
190     (compile-file src :error-file nil :output-file obj))
191     (when load
192     (load name :verbose t)))))))))
193 wlott 1.1

  ViewVC Help
Powered by ViewVC 1.1.5