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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Fri Apr 6 18:29:46 1990 UTC (24 years ago) by ram
Branch: MAIN
Changes since 1.3: +24 -12 lines
Noew and fixed features.
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 #-new-compiler
33 (in-package "C" :use '("EXTENSIONS" "SYSTEM" "LISP"))
34
35 #-new-compiler
36 (export '(compile-for-eval lambda-eval-info-frame-size
37 lambda-eval-info-args-passed lambda-eval-info-entries
38 entry-node-info-st-top entry-node-info-nlx-tag
39 *compile-time-define-macros*))
40
41 #-new-compiler
42 (setq clc::*peep-enable* t)
43 #-new-compiler
44 (setq clc::*inline-enable* t)
45 #-new-compiler
46 (setq ext:*safe-defstruct-accessors* nil)
47
48 #-new-compiler
49 (import '(lisp::boolean lisp::enumeration))
50
51 ;;; ### system patch...
52 #-new-compiler
53 (load "/../fred/usr/ram/hash.fasl")
54
55 (defun zap-sym (name pkg)
56 (let ((found (find-symbol name (find-package pkg))))
57 (when (and found
58 (eq (symbol-package found) (find-package pkg)))
59 (unintern found pkg))))
60
61 #-new-compiler
62 (progn
63 (zap-sym "ABORT" "C")
64 (zap-sym "CONCAT-PNAMES" "LISP")
65 (zap-sym "ONCE-ONLY" "COMPILER")
66 (zap-sym "UNIX-PIPE" "COMPILER")
67 (zap-sym "CONSTANT" "COMPILER")
68 (zap-sym "MAKE-UNIX-PIPE" "MACH")
69 (zap-sym "UNIX-PIPE-P" "MACH"))
70
71 #-new-compiler
72 (let ((sym (find-symbol "%CHARACTER-TYPE" (find-package "SYSTEM"))))
73 (when sym
74 (makunbound sym)
75 (unintern sym (find-package "SYSTEM"))))
76
77
78 #-new-compiler
79 (in-package "EXTENSIONS")
80 #-new-compiler
81 (export '(info clear-info define-info-class define-info-type))
82 #-new-compiler
83 (export '(ignorable truly-the maybe-inline))
84 #-new-compiler
85 (export '(unix-pipe make-unix-pipe unix-pipe-p))
86 #-new-compiler
87 (export '(lisp::with-compilation-unit lisp::debug-info) "LISP")
88
89 #-new-compiler
90 (export '(system::%g-vector-structure-name-slot
91 system::find-if-in-closure
92 system::*file-input-handlers*)
93 "SYSTEM")
94
95 #-new-compiler
96 (let ((found (find-symbol "CONCAT-PNAMES" (find-package "LISP"))))
97 (when found
98 (unintern found (find-package "LISP"))))
99
100 #-new-compiler
101 (in-package "LISP")
102 #-new-compiler
103 (import '(
104 ct-a-val-sap ct-a-val-type ct-a-val-offset ct-a-val-size
105 ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien
106 check<= check= %alien-indirect %bind-aligned-sap
107 naturalize-integer deport-integer naturalize-boolean deport-boolean
108 sap-ref-8 sap-ref-16 sap-ref-32
109 signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32 int-sap sap-int
110 %set-sap-ref-8 %set-sap-ref-16 %set-sap-ref-32
111 %set-alien-access %standard-char-p %string-char-p
112
113 *alien-eval-when* make-alien alien-type alien-size alien-address
114 copy-alien dispose-alien defalien alien-value
115 alien-bind defoperator alien-index alien-indirect
116 bits bytes words long-words port perq-string
117 boolean defenumeration enumeration
118 system-area-pointer pointer alien alien-access
119 alien-assign alien-sap define-alien-stack
120 with-stack-alien null-terminated-string c-procedure
121 unstructured record-size
122 )
123 (find-package "C"))
124
125 (export 'function-lambda-expression)
126
127 ;;; Hack to prevent SETF from expanding these macros out of the environment,
128 ;;; since these are functions in the new system.
129 ;;;
130 #-new-compiler
131 (dolist (x '(sap-ref-8 sap-ref-16 sap-ref-32))
132 (fmakunbound x))
133
134 (in-package "USER")
135
136 ;;; Hack until real definition exists:
137 ;;;
138 #-new-compiler
139 (defmacro with-compilation-unit (glue &rest body)
140 (declare (ignore glue))
141 `(let ((lisp::*in-compilation-unit* t))
142 (declare (special lisp::*in-compilation-unit*))
143 ,@body))
144 ;;;
145 ;;; So the real WCU won't die in bootstrap env.
146 #-new-compiler
147 (defvar lisp::*in-compilation-unit* nil)
148 #-new-compiler
149 (defun c::print-summary (a b)
150 (declare (ignore a b)))
151
152
153 #-new-compiler
154 (setq lisp::*maximum-interpreter-error-checking* nil)
155
156
157 (setq *bytes-consed-between-gcs* 1500000)
158
159 (setq *gc-notify-before*
160 #'(lambda (&rest foo)
161 (declare (ignore foo))
162 (write-char #\. *terminal-io*)
163 (force-output *terminal-io*)))
164
165 (setq *gc-notify-after* #'list)
166
167
168 ;;;; Compile utility:
169
170 ;;; Switches:
171 ;;;
172 (defvar *interactive* nil) ; Batch compilation mode?
173 (defvar *new-compile* t) ; Use new compiler?
174
175 (defvar *log-file* nil)
176 (defvar *last-file-position*)
177 (defvar *compiled-files* (make-hash-table :test #'equal))
178
179
180 (defmacro with-compiler-log-file ((name) &body forms)
181 `(if *interactive*
182 (with-compilation-unit ()
183 ,@forms)
184 (let ((*log-file* (open ,name :direction :output
185 :if-exists :append
186 :if-does-not-exist :create)))
187 (unwind-protect
188 (let ((*error-output* *log-file*)
189 (*last-file-position* (file-position *log-file*)))
190 (with-compilation-unit ()
191 ,@forms))
192 (close *log-file*)))))
193
194
195 (proclaim '(special lisp::*bootstrap-defmacro*))
196
197 (defun comf (name &key always-once proceed load output-file
198 ((:bootstrap-macros lisp::*bootstrap-defmacro*) nil))
199 #+new-compiler
200 (declare (ignore always-once))
201 (when (and *log-file*
202 (> (- (file-position *log-file*) *last-file-position*) 10000))
203 (setq *last-file-position* (file-position *log-file*))
204 (force-output *log-file*))
205
206 (let* ((src (pathname (concatenate 'string name ".lisp")))
207 (obj (if output-file
208 (pathname output-file)
209 (make-pathname :defaults src
210 :type (if *new-compile* "nfasl" "fasl"))))
211 (compiler #+new-compiler #'compile-file
212 #-new-compiler (if *new-compile*
213 #'c::ncompile-file
214 #'compile-file))
215 (obj-pn (probe-file obj)))
216
217 (unless (and obj-pn
218 (>= (file-write-date obj-pn) (file-write-date src))
219 #+nil
220 (equalp (pathname-directory
221 (lisp::sub-probe-file (first (search-list src))))
222 (pathname-directory obj-pn))
223 #-new-compiler
224 (or (gethash src *compiled-files*)
225 (not always-once)))
226 (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 (cond
231 (*interactive*
232 (funcall compiler src :error-file nil :output-file obj)
233 (when load
234 (load name :verbose t)))
235 (t
236 (handler-bind ((error #'(lambda (condition)
237 (format *error-output* "~2&~A~2&"
238 condition)
239 (when proceed
240 (format *error-output* "Proceeding...~%")
241 (continue))
242 (format *error-output* "Aborting...~%")
243 (handler-case
244 (let ((*debug-io* *error-output*))
245 (debug:backtrace))
246 (error (condition)
247 (declare (ignore condition))
248 (format t "Error in backtrace!~%")))
249 (format t "Error abort.~%")
250 (return-from comf))))
251 (funcall compiler src :error-file nil :output-file obj)
252 (when load
253 (load name :verbose t)))))
254 (setf (gethash src *compiled-files*) t))
255
256 ;; Only set after compilation so that it can be bound around the call.
257 (setq lisp::*bootstrap-defmacro* nil)))

  ViewVC Help
Powered by ViewVC 1.1.5