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

Contents of /src/tools/setup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5