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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Fri Apr 27 11:52:37 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Changes since 1.7: +54 -6 lines
Added debugger package hackery.
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 #+new-compiler
9 (proclaim '(optimize (debug-info 2)))
10
11 (in-package "EXT")
12 (export '(debug *gc-verbose*))
13
14 (in-package "EVAL")
15 (export '(internal-eval interpreted-function-p
16 interpreted-function-lambda-expression
17 interpreted-function-closure
18 interpreted-function-name
19 interpreted-function-arglist
20 make-interpreted-function))
21 #-new-compiler
22 (import '*eval-stack-top* (find-package "LISP"))
23
24 #-new-compiler
25 (defmacro indirect-value (value-cell)
26 `(car ,value-cell))
27
28 #-new-compiler
29 (defmacro eval-stack-local (fp offset)
30 `(svref *eval-stack* (+ ,fp ,offset)))
31
32
33 #-new-compiler
34 (in-package "C" :use '("EXTENSIONS" "SYSTEM" "LISP"))
35
36 #-new-compiler
37 (export '(compile-for-eval lambda-eval-info-frame-size
38 lambda-eval-info-args-passed lambda-eval-info-entries
39 entry-node-info-st-top entry-node-info-nlx-tag
40 *compile-time-define-macros*))
41
42 #-new-compiler
43 (setq clc::*peep-enable* t)
44 #-new-compiler
45 (setq clc::*inline-enable* t)
46 #-new-compiler
47 (setq ext:*safe-defstruct-accessors* nil)
48
49 #-new-compiler
50 (import '(lisp::boolean lisp::enumeration))
51
52 ;;; ### system patch...
53 #-new-compiler
54 (load "/../fred/usr/ram/hash.fasl")
55
56 (defun zap-sym (name pkg)
57 (let ((found (find-symbol name (find-package pkg))))
58 (when (and found
59 (eq (symbol-package found) (find-package pkg)))
60 (unintern found pkg))))
61
62 #-new-compiler
63 (progn
64 (zap-sym "ABORT" "C")
65 (zap-sym "CONCAT-PNAMES" "LISP")
66 (zap-sym "ARG" "LISP")
67 (zap-sym "VAR" "LISP")
68 (zap-sym "ONCE-ONLY" "COMPILER")
69 (zap-sym "UNIX-PIPE" "COMPILER")
70 (zap-sym "MAKE-UNIX-PIPE" "MACH")
71 (zap-sym "UNIX-PIPE-P" "MACH"))
72
73 #-new-compiler
74 (let ((sym (find-symbol "%CHARACTER-TYPE" (find-package "SYSTEM"))))
75 (when sym
76 (makunbound sym)
77 (unintern sym (find-package "SYSTEM"))))
78
79
80 #-new-compiler
81 (in-package "EXTENSIONS")
82 #-new-compiler
83 (export '(info clear-info define-info-class define-info-type))
84 #-new-compiler
85 (export '(ignorable truly-the maybe-inline))
86 #-new-compiler
87 (export '(unix-pipe make-unix-pipe unix-pipe-p))
88 #-new-compiler
89 (export '(lisp::with-compilation-unit lisp::debug-info) "LISP")
90
91 #-new-compiler
92 (export '(system::%g-vector-structure-name-slot
93 system::find-if-in-closure
94 system::*file-input-handlers*)
95 "SYSTEM")
96
97 #-new-compiler
98 (let ((found (find-symbol "CONCAT-PNAMES" (find-package "LISP"))))
99 (when found
100 (unintern found (find-package "LISP"))))
101
102 #-new-compiler
103 (in-package "DEBUG")
104 #-new-compiler
105 (export '(var arg))
106
107
108 (in-package "DEBUG-INTERNALS" :nicknames '("DI"))
109
110 ;;; The compiler's debug-source structure is almost exactly what we want, so
111 ;;; just get these symbols and export them.
112 ;;;
113 (import '(c::debug-source-from c::debug-source-name c::debug-source-created
114 c::debug-source-compiled c::debug-source-start-positions
115 c::debug-source c::debug-source-p))
116
117 (export '(debug-variable-name debug-variable-package debug-variable-symbol
118 debug-variable-id debug-variable-value debug-variable-validity
119 debug-variable-valid-value debug-variable debug-variable-p
120
121 top-frame frame-down frame-up frame-debug-function
122 frame-code-location eval-in-frame return-from-frame frame-catches
123 frame-number frame frame-p
124
125 do-blocks debug-function-lambda-list do-debug-function-variables
126 debug-function-symbol-variables ambiguous-debug-variables
127 preprocess-for-eval function-debug-function debug-function-function
128 debug-function-kind debug-function-name debug-function
129 debug-function-p
130
131 do-debug-block-locations debug-block-successors debug-block
132 debug-block-p debug-block-elsewhere-p
133
134 make-breakpoint activate-breakpoint deactivate-breakpoint
135 breakpoint-hook-function breakpoint-info breakpoint-kind
136 breakpoint-what breakpoint breakpoint-p
137
138 code-location-debug-function code-location-debug-block
139 code-location-top-level-form-offset code-location-form-number
140 code-location-debug-source code-location code-location-p
141 unknown-code-location unknown-code-location-p
142
143 debug-source-from debug-source-name debug-source-created
144 debug-source-compiled debug-source-root-number
145 debug-source-start-positions form-number-translations
146 source-path-context debug-source debug-source-p
147
148 debug-condition no-debug-info no-debug-function-returns
149 no-debug-blocks lambda-list-unavailable
150
151 debug-error unhandled-condition invalid-control-stack-pointer
152 unknown-code-location unknown-debug-variable invalid-value))
153
154
155 #-new-compiler
156 (in-package "LISP")
157 #-new-compiler
158 (import '(
159 ct-a-val-sap ct-a-val-type ct-a-val-offset ct-a-val-size
160 ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien
161 check<= check= %alien-indirect %bind-aligned-sap
162 naturalize-integer deport-integer naturalize-boolean deport-boolean
163 sap-ref-8 sap-ref-16 sap-ref-32
164 signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32 int-sap sap-int
165 %set-sap-ref-8 %set-sap-ref-16 %set-sap-ref-32
166 %set-alien-access %standard-char-p %string-char-p
167
168 *alien-eval-when* make-alien alien-type alien-size alien-address
169 copy-alien dispose-alien defalien alien-value
170 alien-bind defoperator alien-index alien-indirect
171 bits bytes words long-words port perq-string
172 boolean defenumeration enumeration
173 system-area-pointer pointer alien alien-access
174 alien-assign alien-sap define-alien-stack
175 with-stack-alien null-terminated-string c-procedure
176 unstructured record-size
177 )
178 (find-package "C"))
179
180 (export 'function-lambda-expression)
181
182 ;;; Hack to prevent SETF from expanding these macros out of the environment,
183 ;;; since these are functions in the new system.
184 ;;;
185 #-new-compiler
186 (dolist (x '(sap-ref-8 sap-ref-16 sap-ref-32))
187 (fmakunbound x))
188
189 (in-package "C")
190 (define-condition parse-unknown-type (condition)
191 (specifier))
192
193 (in-package "USER")
194
195 ;;; Hack until real definition exists:
196 ;;;
197 #-new-compiler
198 (defmacro with-compilation-unit (glue &rest body)
199 (declare (ignore glue))
200 `(let ((lisp::*in-compilation-unit* t))
201 (declare (special lisp::*in-compilation-unit*))
202 ,@body))
203 ;;;
204 ;;; So the real WCU won't die in bootstrap env.
205 #-new-compiler
206 (defvar lisp::*in-compilation-unit* nil)
207 #-new-compiler
208 (defun c::print-summary (a b)
209 (declare (ignore a b)))
210
211
212 #-new-compiler
213 (setq lisp::*maximum-interpreter-error-checking* nil)
214
215
216 (setq *bytes-consed-between-gcs* 1500000)
217
218 (setq *gc-notify-before*
219 #'(lambda (&rest foo)
220 (declare (ignore foo))
221 (write-char #\. *terminal-io*)
222 (force-output *terminal-io*)))
223
224 (setq *gc-notify-after* #'list)
225
226
227 ;;;; Compile utility:
228
229 ;;; Switches:
230 ;;;
231 (defvar *interactive* nil) ; Batch compilation mode?
232 (defvar *new-compile* t) ; Use new compiler?
233
234 (defvar *log-file* nil)
235 (defvar *last-file-position*)
236 (defvar *compiled-files* (make-hash-table :test #'equal))
237
238
239 (defmacro with-compiler-log-file ((name) &body forms)
240 `(if *interactive*
241 (with-compilation-unit ()
242 ,@forms)
243 (let ((*log-file* (open ,name :direction :output
244 :if-exists :append
245 :if-does-not-exist :create)))
246 (unwind-protect
247 (let ((*error-output* *log-file*)
248 (*last-file-position* (file-position *log-file*)))
249 (with-compilation-unit ()
250 ,@forms))
251 (close *log-file*)))))
252
253
254 (proclaim '(special lisp::*bootstrap-defmacro*))
255
256 (defun comf (name &key always-once proceed load output-file
257 ((:bootstrap-macros lisp::*bootstrap-defmacro*) nil))
258 #+new-compiler
259 (declare (ignore always-once))
260 (when (and *log-file*
261 (> (- (file-position *log-file*) *last-file-position*) 10000))
262 (setq *last-file-position* (file-position *log-file*))
263 (force-output *log-file*))
264
265 (let* ((src (pathname (concatenate 'string name ".lisp")))
266 (obj (if output-file
267 (pathname output-file)
268 (make-pathname :defaults src
269 :type (if *new-compile* "nfasl" "fasl"))))
270 (compiler #+new-compiler #'compile-file
271 #-new-compiler (if *new-compile*
272 #'c::ncompile-file
273 #'compile-file))
274 (obj-pn (probe-file obj)))
275
276 (unless (and obj-pn
277 (>= (file-write-date obj-pn) (file-write-date src))
278 #+nil
279 (equalp (pathname-directory
280 (lisp::sub-probe-file (first (search-list src))))
281 (pathname-directory obj-pn))
282 #-new-compiler
283 (or (gethash src *compiled-files*)
284 (not always-once)))
285 (write-line name)
286 (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
287 (ext:format-universal-time nil (get-universal-time))
288 name)
289 (cond
290 (*interactive*
291 (funcall compiler src :error-file nil :output-file obj)
292 (when load
293 (load name :verbose t)))
294 (t
295 (handler-bind ((error #'(lambda (condition)
296 (format *error-output* "~2&~A~2&"
297 condition)
298 (when proceed
299 (format *error-output* "Proceeding...~%")
300 (continue))
301 (format *error-output* "Aborting...~%")
302 (handler-case
303 (let ((*debug-io* *error-output*))
304 (debug:backtrace))
305 (error (condition)
306 (declare (ignore condition))
307 (format t "Error in backtrace!~%")))
308 (format t "Error abort.~%")
309 (return-from comf))))
310 (funcall compiler src :error-file nil :output-file obj)
311 (when load
312 (load name :verbose t)))))
313 (setf (gethash src *compiled-files*) t))
314
315 ;; Only set after compilation so that it can be bound around the call.
316 (setq lisp::*bootstrap-defmacro* nil)))

  ViewVC Help
Powered by ViewVC 1.1.5