1 |
|
;;; CMPMAIN Compiler main program. |
2 |
|
;;; |
3 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
4 |
|
|
5 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
6 |
|
;; |
7 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
8 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
9 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
10 |
|
;; any later version. |
11 |
|
;; |
12 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
13 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
14 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
15 |
|
;; License for more details. |
16 |
|
;; |
17 |
|
;; You should have received a copy of the GNU Library General Public License |
18 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
19 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
20 |
|
|
21 |
|
|
22 |
|
;;; **** Caution **** |
23 |
|
;;; This file is machine/OS dependant. |
24 |
|
;;; ***************** |
25 |
|
|
26 |
|
|
27 |
|
(in-package 'compiler) |
28 |
|
|
29 |
|
|
30 |
|
(export '(*compile-print* *compile-verbose*)) |
31 |
|
|
32 |
|
#+linux (push :ld-not-accept-data *features*) |
33 |
|
(defvar *compiler-in-use* nil) |
34 |
|
(defvar *compiler-input*) |
35 |
|
(defvar *compiler-output1*) |
36 |
|
(defvar *compiler-output2*) |
37 |
|
(defvar *compiler-output-data*) |
38 |
|
(defvar *compiler-output-i*) |
39 |
|
|
40 |
|
(defvar *error-p* nil) |
41 |
|
|
42 |
|
(defvar *compile-print* nil) |
43 |
|
(defvar *compile-verbose* t) |
44 |
|
(defvar *cmpinclude* "\"cmpinclude.h\"") |
45 |
|
;;If the following is a string, then it is inserted instead of |
46 |
|
;; the include file cmpinclude.h, EXCEPT for system-p calls. |
47 |
|
(defvar *cmpinclude-string* t) |
48 |
|
(defvar *compiler-default-type* #p".lsp") |
49 |
|
(defvar *compiler-normal-type* #p".lsp") |
50 |
|
|
51 |
|
(defun compiler-default-type (pname) |
52 |
|
"Set the default file extension (type) for compilable file names." |
53 |
|
(setf *compiler-default-type* (if (pathnamep pname) |
54 |
|
pname |
55 |
|
(make-pathname :type (string-left-trim "." pname))))) |
56 |
|
|
57 |
|
(defun compiler-reset-type () |
58 |
|
"Set the default file extension (type) to <.lsp>." |
59 |
|
(compiler-default-type *compiler-normal-type*)) |
60 |
|
|
61 |
|
;; Let the user write dump c-file etc to /dev/null. |
62 |
|
(defun get-output-pathname (file ext name &optional (dir (pathname-directory *default-pathname-defaults*))) |
63 |
|
(cond |
64 |
|
((equal file "/dev/null") (pathname file)) |
65 |
|
#+aix3 |
66 |
|
((and (equal name "float") |
67 |
|
(equal ext "h")) |
68 |
|
(get-output-pathname file ext "Float" )) |
69 |
|
(t |
70 |
|
(make-pathname :directory (or (and (not (null file)) |
71 |
|
(not (eq file t)) |
72 |
|
(pathname-directory file)) |
73 |
|
dir) |
74 |
|
:name (or (and (not (null file)) |
75 |
|
(not (eq file t)) |
76 |
|
(pathname-name file)) |
77 |
|
name) |
78 |
|
:type ext)))) |
79 |
|
|
80 |
|
|
81 |
|
(defun safe-system (string) |
82 |
|
(multiple-value-bind |
83 |
|
(code result) (system string) |
84 |
|
(unless (and (zerop code) (zerop result)) |
85 |
|
(cerror "Continues anyway." |
86 |
|
"(SYSTEM ~S) returned a non-zero value ~D." |
87 |
|
string |
88 |
|
result) |
89 |
|
(setq *error-p* t)) |
90 |
|
(values result))) |
91 |
|
|
92 |
|
;; If this is t we use fasd-data on all but system-p files. If it |
93 |
|
;; is :system-p we use it on all files. If nil use it on none. |
94 |
|
(defvar *fasd-data* t) |
95 |
|
(defvar *data* nil) |
96 |
|
(defvar *default-system-p* nil) |
97 |
|
(defvar *default-c-file* nil) |
98 |
|
(defvar *default-h-file* nil) |
99 |
|
(defvar *default-data-file* nil) |
100 |
|
(defvar *keep-gaz* nil) |
101 |
|
|
102 |
|
;; (list section-length split-file-names next-section-start-file-position) |
103 |
|
;; Many c compilers cannot handle the large C files resulting from large lisp files. |
104 |
|
;; If *split-files* is a number then, separate compilations for sections |
105 |
|
;; *split-files* long, with the |
106 |
|
;; will be performed for separate chunks of the lisp files. |
107 |
|
(defvar *split-files* nil) ;; if |
108 |
|
|
109 |
|
(defun check-end (form eof) |
110 |
|
(cond ((eq form eof) |
111 |
|
(setf (third *split-files*) nil)) |
112 |
|
((> (file-position *compiler-input*) |
113 |
|
(car *split-files*)) |
114 |
|
(setf (third *split-files*)(file-position *compiler-input*))))) |
115 |
|
|
116 |
|
|
117 |
|
(defun compile-file (&rest args |
118 |
|
&aux (*print-pretty* nil) |
119 |
|
(*package* *package*) (*split-files* *split-files*) |
120 |
|
(*PRINT-CIRCLE* NIL) |
121 |
|
(*PRINT-RADIX* NIL) |
122 |
|
(*PRINT-ARRAY* T) |
123 |
|
(*PRINT-LEVEL* NIL) |
124 |
|
(*PRINT-PRETTY* T) |
125 |
|
(*PRINT-LENGTH* NIL) |
126 |
|
(*PRINT-GENSYM* T) |
127 |
|
(*PRINT-CASE* :UPCASE) |
128 |
|
(*PRINT-BASE* 10) |
129 |
|
(*PRINT-ESCAPE* T) |
130 |
|
(section-length *split-files*) |
131 |
|
tem) |
132 |
|
(loop |
133 |
|
(compiler::init-env) |
134 |
|
(setq tem (apply 'compiler::compile-file1 args)) |
135 |
|
(cond ((atom *split-files*)(return tem)) |
136 |
|
((and (consp *split-files*) |
137 |
|
(null (third *split-files*))) |
138 |
|
(let ((gaz (let ((*DEFAULT-PATHNAME-DEFAULTS* (car args))) |
139 |
|
(gazonk-name))) |
140 |
|
(*readtable* (si::standard-readtable))) |
141 |
|
(setq gaz (get-output-pathname gaz "lsp" (car args))) |
142 |
|
(with-open-file (st gaz :direction :output) |
143 |
|
(print |
144 |
|
`(eval-when (load eval) |
145 |
|
(dolist (v ',(nreverse (second *split-files*))) |
146 |
|
(load (merge-pathnames v si::*load-pathname*)))) |
147 |
|
st)) |
148 |
|
(setq *split-files* nil) |
149 |
|
(or (member :output-file args) |
150 |
|
(setq args (append args (list :output-file (car args))))) |
151 |
|
(return |
152 |
|
(prog1 (apply 'compile-file gaz (cdr args)) |
153 |
|
(unless *keep-gaz* (delete-file gaz)))) |
154 |
|
)) |
155 |
|
(t nil)) |
156 |
|
(if (consp *split-files*) |
157 |
|
(setf (car *split-files*) (+ (third *split-files*) section-length))) |
158 |
|
)) |
159 |
|
|
160 |
|
|
161 |
|
(defun compile-file1 (input-pathname |
162 |
|
&key (output-file input-pathname) |
163 |
|
(o-file t) |
164 |
|
(c-file *default-c-file*) |
165 |
|
(h-file *default-h-file*) |
166 |
|
(data-file *default-data-file*) |
167 |
|
(c-debug nil) |
168 |
|
#+aosvs (ob-file nil) |
169 |
|
(system-p *default-system-p*) |
170 |
|
(print nil) |
171 |
|
(load nil) |
172 |
|
&aux (*standard-output* *standard-output*) |
173 |
|
(*error-output* *error-output*) |
174 |
|
(*compiler-in-use* *compiler-in-use*) |
175 |
|
(*c-debug* c-debug) |
176 |
|
(*compile-print* (or print *compile-print*)) |
177 |
|
(*package* *package*) |
178 |
|
(*DEFAULT-PATHNAME-DEFAULTS* #"") |
179 |
|
(*data* (list (make-array 50 :fill-pointer 0 |
180 |
|
:adjustable t |
181 |
|
) |
182 |
|
nil ;inits |
183 |
|
nil |
184 |
|
)) |
185 |
|
*init-name* |
186 |
|
(*fasd-data* *fasd-data*) |
187 |
|
(*error-count* 0)) |
188 |
|
(declare (special *c-debug* *init-name* system-p)) |
189 |
|
|
190 |
|
(cond (*compiler-in-use* |
191 |
|
(format t "~&The compiler was called recursively.~%~ |
192 |
|
Cannot compile ~a.~%" |
193 |
|
(namestring (merge-pathnames input-pathname *compiler-default-type*))) |
194 |
|
(setq *error-p* t) |
195 |
|
(return-from compile-file1 (values))) |
196 |
|
(t (setq *error-p* nil) |
197 |
|
(setq *compiler-in-use* t))) |
198 |
|
|
199 |
|
(unless (probe-file (merge-pathnames input-pathname *compiler-default-type*)) |
200 |
|
(format t "~&The source file ~a is not found.~%" |
201 |
|
(namestring (merge-pathnames input-pathname *compiler-default-type*))) |
202 |
|
(setq *error-p* t) |
203 |
|
(return-from compile-file1 (values))) |
204 |
|
|
205 |
|
(when *compile-verbose* |
206 |
|
(format t "~&Compiling ~a.~%" |
207 |
|
(namestring (merge-pathnames input-pathname *compiler-default-type*)))) |
208 |
|
|
209 |
|
(and *record-call-info* (clear-call-table)) |
210 |
|
|
211 |
|
(with-open-file |
212 |
|
(*compiler-input* (merge-pathnames input-pathname *compiler-default-type*)) |
213 |
|
|
214 |
|
|
215 |
|
(cond ((numberp *split-files*) |
216 |
|
(if (< (file-length *compiler-input*) *split-files*) |
217 |
|
(setq *split-files* nil) |
218 |
|
;;*split-files* = ( section-length split-file-names next-section-start-file-position |
219 |
|
;; package-ops) |
220 |
|
(setq *split-files* (list *split-files* nil 0 nil))))) |
221 |
|
|
222 |
|
(cond ((consp *split-files*) |
223 |
|
(file-position *compiler-input* (third *split-files*)) |
224 |
|
(setq output-file |
225 |
|
(make-pathname :directory (pathname-directory output-file) |
226 |
|
:name (format nil "~a~a" |
227 |
|
(length (second *split-files*)) |
228 |
|
(pathname-name (pathname output-file))) |
229 |
|
:type "o")) |
230 |
|
|
231 |
|
(push (pathname-name output-file) (second *split-files*)) |
232 |
|
)) |
233 |
|
|
234 |
|
|
235 |
|
|
236 |
|
|
237 |
|
(let* ((eof (cons nil nil)) |
238 |
|
(dir (or (and (not (null output-file)) |
239 |
|
(pathname-directory output-file)) |
240 |
|
(pathname-directory input-pathname))) |
241 |
|
(name (or (and (not (null output-file)) |
242 |
|
(pathname-name output-file)) |
243 |
|
(pathname-name input-pathname))) |
244 |
|
|
245 |
|
(o-pathname (get-output-pathname o-file "o" name dir)) |
246 |
|
(c-pathname (get-output-pathname c-file "c" name dir)) |
247 |
|
(h-pathname (get-output-pathname h-file "h" name dir)) |
248 |
|
(data-pathname (get-output-pathname data-file "data" name dir)) |
249 |
|
; (i-pathname (get-output-pathname data-file "i" name dir)) |
250 |
|
#+aosvs (ob-pathname (get-output-pathname ob-file "ob" name dir)) |
251 |
|
) |
252 |
|
(declare (special dir name )) |
253 |
|
|
254 |
|
(init-env) |
255 |
|
|
256 |
|
(and (boundp 'si::*gcl-version*) |
257 |
|
(not system-p) |
258 |
|
(add-init `(si::warn-version ,si::*gcl-version* ,si::*gcl-major-version*))) |
259 |
|
|
260 |
|
(when (probe-file "./cmpinit.lsp") |
261 |
|
(load "./cmpinit.lsp" |
262 |
|
:verbose *compile-verbose*)) |
263 |
|
|
264 |
|
(with-open-file (*compiler-output-data* |
265 |
|
data-pathname |
266 |
|
:direction :output) |
267 |
|
(progn |
268 |
|
(setq *fasd-data* |
269 |
|
(cond ((if system-p (eq *fasd-data* :system-p) |
270 |
|
*fasd-data*) |
271 |
|
(list |
272 |
|
(si::open-fasd *compiler-output-data* :output nil nil) |
273 |
|
;(si::open-fasd *compiler-output-i* :output nil nil) |
274 |
|
)))) |
275 |
|
|
276 |
|
(wt-data-begin) |
277 |
|
|
278 |
|
(let* ((rtb *readtable*) |
279 |
|
(prev (and (eq (get-macro-character #\# rtb) |
280 |
|
(get-macro-character |
281 |
|
#\# (si:standard-readtable))) |
282 |
|
(get-dispatch-macro-character #\# #\, rtb)))) |
283 |
|
(if (and prev (eq prev (get-dispatch-macro-character |
284 |
|
#\# #\, (si:standard-readtable)))) |
285 |
|
(set-dispatch-macro-character #\# #\, |
286 |
|
'si:sharp-comma-reader-for-compiler rtb) |
287 |
|
(setq prev nil)) |
288 |
|
|
289 |
|
;; t1expr the package ops again.. |
290 |
|
(if (consp *split-files*) |
291 |
|
(dolist (v (fourth *split-files*)) (t1expr v))) |
292 |
|
(unwind-protect |
293 |
|
(do ((form (read *compiler-input* nil eof) |
294 |
|
(read *compiler-input* nil eof)) |
295 |
|
(load-flag (or (eq :defaults *eval-when-defaults*) |
296 |
|
(member 'load *eval-when-defaults*)))) |
297 |
|
(nil) |
298 |
|
(cond |
299 |
|
((eq form eof)) |
300 |
|
(load-flag (t1expr form)) |
301 |
|
((maybe-eval nil form))) |
302 |
|
(cond |
303 |
|
((and *split-files* (check-end form eof)) |
304 |
|
(setf (fourth *split-files*) (reverse (third *data*))) |
305 |
|
(return nil)) |
306 |
|
((eq form eof) (return nil))) |
307 |
|
) |
308 |
|
|
309 |
|
|
310 |
|
(when prev (set-dispatch-macro-character #\# #\, prev rtb))))) |
311 |
|
|
312 |
|
(setq *init-name* |
313 |
|
(substitute #\_ #\- |
314 |
|
(if system-p |
315 |
|
#-aosvs (pathname-name input-pathname) |
316 |
|
#+aosvs (string-downcase |
317 |
|
(pathname-name input-pathname)) |
318 |
|
"code"))) |
319 |
|
|
320 |
|
(when (zerop *error-count*) |
321 |
|
(when *compile-verbose* (format t "~&End of Pass 1. ~%")) |
322 |
|
(compiler-pass2 c-pathname h-pathname system-p )) |
323 |
|
|
324 |
|
|
325 |
|
(wt-data-end) |
326 |
|
|
327 |
|
) ;;; *compiler-output-data* closed. |
328 |
|
|
329 |
|
(init-env) |
330 |
|
|
331 |
|
(if (zerop *error-count*) |
332 |
|
|
333 |
|
#+aosvs |
334 |
|
(progn |
335 |
|
(when *compile-verbose* (format t "~&End of Pass 2. ~%")) |
336 |
|
(when data-file |
337 |
|
(with-open-file (in fasl-pathname) |
338 |
|
(with-open-file (out data-pathname :direction :output) |
339 |
|
(si:copy-stream in out)))) |
340 |
|
(cond ((or fasl-file ob-file) |
341 |
|
(compiler-cc c-pathname ob-pathname) |
342 |
|
(cond ((probe-file ob-pathname) |
343 |
|
(when fasl-file |
344 |
|
(compiler-build ob-pathname fasl-pathname) |
345 |
|
(when load (load fasl-pathname))) |
346 |
|
(unless ob-file (delete-file ob-pathname)) |
347 |
|
(when *compile-verbose* |
348 |
|
(print-compiler-info) |
349 |
|
(format t "~&Finished compiling ~a.~%" (namestring output-file)) |
350 |
|
)) |
351 |
|
(t (format t "~&Your C compiler failed to compile the intermediate file.~%") |
352 |
|
(setq *error-p* t)))) |
353 |
|
(*compile-verbose* |
354 |
|
(print-compiler-info) |
355 |
|
(format t "~&Finished compiling ~a.~%" (namestring output-file) |
356 |
|
))) |
357 |
|
(unless c-file (delete-file c-pathname)) |
358 |
|
(unless h-file (delete-file h-pathname)) |
359 |
|
(unless fasl-file (delete-file fasl-pathname))) |
360 |
|
|
361 |
|
|
362 |
|
(progn |
363 |
|
(when *compile-verbose* (format t "~&End of Pass 2. ~%")) |
364 |
|
(cond (*record-call-info* |
365 |
|
(dump-fn-data (get-output-pathname output-file "fn" name dir)))) |
366 |
|
(cond (o-file |
367 |
|
(compiler-cc c-pathname o-pathname ) |
368 |
|
(cond ((probe-file o-pathname) |
369 |
|
(compiler-build o-pathname data-pathname) |
370 |
|
(when load (load o-pathname)) |
371 |
|
(when *compile-verbose* |
372 |
|
(print-compiler-info) |
373 |
|
(format t "~&Finished compiling ~a.~%" (namestring output-file) |
374 |
|
))) |
375 |
|
(t |
376 |
|
(format t "~&Your C compiler failed to compile the intermediate file.~%") |
377 |
|
(setq *error-p* t)))) |
378 |
|
(*compile-verbose* |
379 |
|
(print-compiler-info) |
380 |
|
(format t "~&Finished compiling ~a.~%" (namestring output-file) |
381 |
|
))) |
382 |
|
(unless c-file (delete-file c-pathname)) |
383 |
|
(unless h-file (delete-file h-pathname)) |
384 |
|
(unless (or data-file #+ld-not-accept-data t system-p) (delete-file data-pathname)) |
385 |
|
o-pathname) |
386 |
|
|
387 |
|
(progn |
388 |
|
(when (probe-file c-pathname) (delete-file c-pathname)) |
389 |
|
(when (probe-file h-pathname) (delete-file h-pathname)) |
390 |
|
(when (probe-file data-pathname) (delete-file data-pathname)) |
391 |
|
(format t "~&No FASL generated.~%") |
392 |
|
(setq *error-p* t) |
393 |
|
(values) |
394 |
|
)))))) |
395 |
|
|
396 |
|
(defun gazonk-name ( &aux tem) |
397 |
|
(dotimes (i 1000) |
398 |
|
(unless (probe-file (setq tem (merge-pathnames (format nil "gazonk~d.lsp" i)))) |
399 |
|
(return-from gazonk-name (pathname tem)))) |
400 |
|
(error "1000 gazonk names used already!")) |
401 |
|
|
402 |
|
(defun prin1-cmp (form strm) |
403 |
|
(let ((*compiler-output-data* strm) |
404 |
|
(*fasd-data* nil)) |
405 |
|
(wt-data1 form) ;; this binds all the print stuff |
406 |
|
)) |
407 |
|
|
408 |
|
|
409 |
|
(defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #".")) |
410 |
|
|
411 |
|
(cond ((not(symbolp name)) (error "Must be a name")) |
412 |
|
((and (consp def) |
413 |
|
(member (car def) '(lambda ))) |
414 |
|
(or name (setf name 'cmp-anon)) |
415 |
|
(setf (symbol-function name) |
416 |
|
def) |
417 |
|
(compile name)) |
418 |
|
(def (error "def not a lambda expression")) |
419 |
|
((setq tem (macro-function name)) |
420 |
|
(setf (symbol-function 'cmp-anon) tem) |
421 |
|
(compile 'cmp-anon) |
422 |
|
(setf (macro-function name) (macro-function name)) |
423 |
|
name) |
424 |
|
((and (setq tem (symbol-function name)) |
425 |
|
(consp tem)) |
426 |
|
(let ((na (if (symbol-package name) name 'cmp-anon))) |
427 |
|
(unless (and (fboundp 'si::init-cmp-anon) (or (si::init-cmp-anon) (fmakunbound 'si::init-cmp-anon))) |
428 |
|
(with-open-file |
429 |
|
(st (setq gaz (gazonk-name)) :direction :output) |
430 |
|
(prin1-cmp `(defun ,na ,@ (ecase (car tem) |
431 |
|
(lambda (cdr tem)) |
432 |
|
(lambda-block (cddr tem)) |
433 |
|
)) st)) |
434 |
|
(let ((fi (compile-file gaz))) |
435 |
|
(load fi) |
436 |
|
(delete-file fi)) |
437 |
|
(unless *keep-gaz* (delete-file gaz))) |
438 |
|
(or (eq na name) (setf (symbol-function name) (symbol-function na))) |
439 |
|
(symbol-function name) |
440 |
|
)) |
441 |
|
(t (error "can't compile ~a" name)))) |
442 |
|
|
443 |
|
(defun disassemble (name &aux tem) |
444 |
|
(cond ((and (consp name) |
445 |
|
(eq (car name) 'lambda)) |
446 |
|
(eval `(defun cmp-anon ,@ (cdr name))) |
447 |
|
(disassemble 'cmp-anon)) |
448 |
|
((not(symbolp name)) (error "Not a lambda or a name")) |
449 |
|
((setq tem(macro-function name)) |
450 |
|
(setf (symbol-function 'cmp-tmp-macro) tem) |
451 |
|
(disassemble 'cmp-tmp-macro) |
452 |
|
(setf (macro-function name) (macro-function name)) |
453 |
|
name) |
454 |
|
((and (setq tem (symbol-function name)) |
455 |
|
(consp tem) |
456 |
|
(eq (car tem) 'lambda-block)) |
457 |
|
(let ((gaz (gazonk-name))) |
458 |
|
(with-open-file |
459 |
|
(st gaz :direction :output) |
460 |
|
(prin1-cmp `(defun ,name ,@ (cddr tem)) st)) |
461 |
|
(compile-file gaz |
462 |
|
; :c-debug t |
463 |
|
:h-file t |
464 |
|
:c-file t |
465 |
|
:system-p 't |
466 |
|
:data-file t |
467 |
|
:o-file t) |
468 |
|
(let ((cn (get-output-pathname gaz "c" gaz )) |
469 |
|
(dn (get-output-pathname gaz "data" gaz )) |
470 |
|
(hn (get-output-pathname gaz "h" gaz )) |
471 |
|
(on (get-output-pathname gaz "o" gaz ))) |
472 |
|
(with-open-file (st cn) |
473 |
|
(si::copy-stream st *standard-output*)) |
474 |
|
(with-open-file (st dn) |
475 |
|
(si::copy-stream st *standard-output*)) |
476 |
|
(with-open-file (st hn) |
477 |
|
(si::copy-stream st *standard-output*)) |
478 |
|
(system (si::string-concatenate "objdump -d -l " |
479 |
|
(namestring on))) |
480 |
|
(delete-file cn) |
481 |
|
(delete-file dn) |
482 |
|
(delete-file hn) |
483 |
|
(delete-file on) |
484 |
|
(unless *keep-gaz* (delete-file gaz))))) |
485 |
|
(t (error "can't disassemble ~a" name)))) |
486 |
|
|
487 |
|
|
488 |
|
(defun compiler-pass2 (c-pathname h-pathname system-p ) |
489 |
|
(with-open-file (st c-pathname :direction :output) |
490 |
|
(let ((*compiler-output1* (if (eq system-p 'disassemble) *standard-output* |
491 |
|
st))) |
492 |
|
(declare (special *compiler-output1*)) |
493 |
|
(with-open-file (*compiler-output2* h-pathname :direction :output) |
494 |
|
(cond ((and |
495 |
|
(stringp *cmpinclude-string*) |
496 |
|
(not system-p) |
497 |
|
(si::fwrite *cmpinclude-string* 0 |
498 |
|
(length *cmpinclude-string*) *compiler-output1*))) |
499 |
|
(t (wt-nl1 "#include " *cmpinclude*))) |
500 |
|
(wt-nl1 "#include \"" |
501 |
|
(namestring |
502 |
|
(make-pathname :name |
503 |
|
(pathname-name h-pathname) |
504 |
|
:type (pathname-type h-pathname))) |
505 |
|
|
506 |
|
#+aosvs (string-downcase (namestring h-pathname)) |
507 |
|
"\"") |
508 |
|
|
509 |
|
(catch *cmperr-tag* (ctop-write *init-name*)) |
510 |
|
(if system-p |
511 |
|
(wt |
512 |
|
" |
513 |
|
|
514 |
|
#ifdef SYSTEM_SPECIAL_INIT |
515 |
|
SYSTEM_SPECIAL_INIT |
516 |
|
#endif |
517 |
|
")) |
518 |
|
|
519 |
|
(terpri *compiler-output1*) |
520 |
|
;; write ctl-z at end to make sure preprocessor stops! |
521 |
|
#+dos (write-char (code-char 26) *compiler-output1*) |
522 |
|
(terpri *compiler-output2*))))) |
523 |
|
|
524 |
|
|
525 |
|
(defvar *cc* "cc") |
526 |
|
(defvar *ld* "ld") |
527 |
|
(defvar *ld-libs* "ld-libs") |
528 |
|
(defvar *opt-three* "") |
529 |
|
(defvar *opt-two* "") |
530 |
|
(defvar *init-lsp* "init-lsp") |
531 |
|
|
532 |
|
(defvar *use-buggy* nil) |
533 |
|
|
534 |
|
(defun compiler-command (&rest args &aux na ) |
535 |
|
(declare (special *c-debug*)) |
536 |
|
(let ((dirlist (pathname-directory (first args))) |
537 |
|
(name (pathname-name (first args))) |
538 |
|
dir |
539 |
|
) |
540 |
|
(cond (dirlist (setq dir (namestring (make-pathname :directory dirlist)))) |
541 |
|
(t (setq dir "."))) |
542 |
|
(setq na (namestring |
543 |
|
(make-pathname :name name :type (pathname-type(first args))))) |
544 |
|
#+(or dos winnt) |
545 |
|
(format nil "~a -I~a ~a ~a -c -w ~a -o ~a" |
546 |
|
*cc* |
547 |
|
(concatenate 'string si::*system-directory* "../h") |
548 |
|
(if (and (boundp '*c-debug*) *c-debug*) " -g " "") |
549 |
|
(case *speed* |
550 |
|
(3 *opt-three* ) |
551 |
|
(2 *opt-two*) |
552 |
|
(t "")) |
553 |
|
; (case *speed* |
554 |
|
; (3 #+broken_o4_opt "-O2" #-broken_o4_opt"-O4") |
555 |
|
; (2 "-O") (t "")) |
556 |
|
(namestring (make-pathname :type "c" :defaults (first args))) |
557 |
|
(namestring (make-pathname :type "o" :defaults (first args))) |
558 |
|
) |
559 |
|
|
560 |
|
#-(or dos winnt) |
561 |
|
(format nil "(cd ~a ;~a -I~a ~a ~a -c ~a ~a)" |
562 |
|
dir *cc* |
563 |
|
(concatenate 'string si::*system-directory* "../h") |
564 |
|
(if (and (boundp '*c-debug*) *c-debug*) " -g " "") |
565 |
|
; (case *speed* |
566 |
|
; (3 #+broken_o4_opt "-O" #-broken_o4_opt"-O4") |
567 |
|
; (2 "-O") (t "")) |
568 |
|
(case *speed* |
569 |
|
(3 *opt-three* ) |
570 |
|
(2 *opt-two*) |
571 |
|
(t "")) |
572 |
|
na |
573 |
|
(prog1 |
574 |
|
#+aix3 |
575 |
|
(format nil " -w ;ar x /lib/libc.a fsavres.o ; ar qc XXXfsave fsavres.o ; echo init_~a > XXexp ; mv ~a XXX~a ; ld -r -D-1 -bexport:XXexp -bgc XXX~a -o ~a XXXfsave ; rm -f XXX~a XXexp XXXfsave fsavres.o" |
576 |
|
*init-name* |
577 |
|
(setq na (namestring (get-output-pathname na "o" nil))) |
578 |
|
na na na na na) |
579 |
|
#+(or dlopen irix5) |
580 |
|
(if (not system-p) |
581 |
|
(format nil |
582 |
|
" -w ; mv ~a XX~a ; ld ~a -shared XX~a -o ~a -lc ; rm -f XX~a" |
583 |
|
(setq na (namestring (get-output-pathname na "o" nil))) na |
584 |
|
#+ignore-unresolved "-ignore_unresolved" |
585 |
|
#+expect-unresolved "-expect_unresolved '*'" |
586 |
|
na na na)) |
587 |
|
|
588 |
|
#+bsd "-w" |
589 |
|
#-(or aix3 bsd irix3) " 2> /dev/null ") |
590 |
|
|
591 |
|
|
592 |
|
) |
593 |
|
) |
594 |
|
) |
595 |
|
|
596 |
|
|
597 |
|
(defun compiler-cc (c-pathname o-pathname ) |
598 |
|
(safe-system |
599 |
|
(format |
600 |
|
nil |
601 |
|
(prog1 |
602 |
|
#+irix5 (compiler-command c-pathname o-pathname ) |
603 |
|
#+vax "~a ~@[~*-O ~]-S -I. -w ~a ; as -J -W -o ~A ~A" |
604 |
|
#+(or system-v e15 dgux sgi ) "~a ~@[~*-O ~]-c -I. ~a 2> /dev/null" |
605 |
|
(compiler-command c-pathname o-pathname )) |
606 |
|
*cc* |
607 |
|
(if (or (= *speed* 2) (= *speed* 3)) t nil) |
608 |
|
(namestring c-pathname) |
609 |
|
(namestring o-pathname) |
610 |
|
|
611 |
|
)) |
612 |
|
|
613 |
|
#+dont_need |
614 |
|
(let ((cname (pathname-name c-pathname)) |
615 |
|
(odir (pathname-directory o-pathname)) |
616 |
|
(oname (pathname-name o-pathname))) |
617 |
|
(unless (and (equalp (truename "./") |
618 |
|
(truename (make-pathname :directory odir))) |
619 |
|
(equal cname oname)) |
620 |
|
(rename-file (make-pathname :name cname :type "o") |
621 |
|
o-pathname) |
622 |
|
))) |
623 |
|
|
624 |
|
|
625 |
|
(defun compiler-build (o-pathname data-pathname) |
626 |
|
#+(and system-v (not e15)) |
627 |
|
(safe-system (format nil "echo \"\\000\\000\\000\\000\" >> ~A" |
628 |
|
(namestring o-pathname))) |
629 |
|
#+(or hp-ux sun sgi) |
630 |
|
(with-open-file (o-file |
631 |
|
(namestring o-pathname) |
632 |
|
:direction :output |
633 |
|
:if-exists :append) |
634 |
|
; we could do a safe-system, but forking is slow on the Iris |
635 |
|
#+(or hp-ux (and sgi (not irix5))) |
636 |
|
(dotimes (i 12) |
637 |
|
(write-char #\^@ o-file)) |
638 |
|
#+sun ; we could do a safe-system, but forking is slow on the Iris |
639 |
|
(dolist (v '(0 0 4 16 0 0 0 0)) |
640 |
|
(write-byte v o-file)) |
641 |
|
|
642 |
|
) |
643 |
|
#-ld-not-accept-data |
644 |
|
(when (probe-file o-pathname) |
645 |
|
(nconc-files o-pathname data-pathname) |
646 |
|
#+never |
647 |
|
(safe-system (format nil |
648 |
|
"cat ~a >> ~A" |
649 |
|
(namestring data-pathname) |
650 |
|
(namestring o-pathname))))) |
651 |
|
|
652 |
|
(defun print-compiler-info () |
653 |
|
(format t "~&OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%" |
654 |
|
(cond ((null *compiler-check-args*) 0) |
655 |
|
((null *safe-compile*) 1) |
656 |
|
((null *compiler-push-events*) 2) |
657 |
|
(t 3)) |
658 |
|
*safe-compile* *space* *speed*)) |
659 |
|
|
660 |
|
(defun nconc-files (a b) |
661 |
|
(let* ((n 256) |
662 |
|
(tem (make-string n)) |
663 |
|
(m 0)) |
664 |
|
(with-open-file (st-a a :direction :output :if-exists :append) |
665 |
|
(with-open-file (st-b b ) |
666 |
|
(sloop::sloop |
667 |
|
do (setq m (si::fread tem 0 n st-b)) |
668 |
|
while (and m (> m 0)) |
669 |
|
do (si::fwrite tem 0 m st-a)))))) |
670 |
|
|
671 |
|
#+dos |
672 |
|
(progn |
673 |
|
(defun directory (x &aux ans) |
674 |
|
(let* ((pa (pathname x)) |
675 |
|
(temp "XXDIR") |
676 |
|
tem |
677 |
|
(name (pathname-name pa))) |
678 |
|
(setq pa (make-pathname :directory (pathname-directory pa) |
679 |
|
:name (or (pathname-name pa) :wild) |
680 |
|
:type (pathname-type pa))) |
681 |
|
(setq name (namestring pa)) |
682 |
|
(system (format nil "ls -d ~a > ~a" name temp)) |
683 |
|
(with-open-file (st temp) |
684 |
|
(loop (setq tem (read-line st nil nil)) |
685 |
|
(if (and tem (setq tem (probe-file tem))) |
686 |
|
(push tem ans) (return)))) |
687 |
|
ans)) |
688 |
|
|
689 |
|
(defvar *old-compile-file* #'compile-file) |
690 |
|
(defun compile-file (f &rest l) |
691 |
|
(let* ((p (pathname f)) dir pwd) |
692 |
|
(setq dir (pathname-directory p)) |
693 |
|
(when dir |
694 |
|
(setq dir (namestring (make-pathname :directory dir |
695 |
|
:name "."))) |
696 |
|
(setq pwd (namestring (truename "."))) |
697 |
|
) |
698 |
|
(unwind-protect |
699 |
|
(progn (if dir (si::chdir dir)) |
700 |
|
(apply *old-compile-file* f l)) |
701 |
|
(if pwd (si::chdir pwd))))) |
702 |
|
|
703 |
|
(defun user-homedir-pathname () |
704 |
|
(or (si::getenv "HOME") "/")) |
705 |
|
|
706 |
|
) |
707 |
|
|
708 |
|
; |
709 |
|
; These functions are added to build custom images requiring |
710 |
|
; the loading of binary objects on systems relocating with dlopen. |
711 |
|
; |
712 |
|
|
713 |
|
(defun make-user-init (files out &aux tem) |
714 |
|
|
715 |
|
(setq tem (concatenate 'string out ".c")) |
716 |
|
(with-open-file (st tem :direction :output) |
717 |
|
(format st "#include <string.h>~%") |
718 |
|
(format st "#include ~a~%~%" *cmpinclude*) |
719 |
|
|
720 |
|
(format st "#define load2(a) do {") |
721 |
|
(format st "printf(\"Loading %s...\\n\",(a));") |
722 |
|
(format st "load(a);") |
723 |
|
(format st "printf(\"Finished %s...\\n\",(a));} while(0)~%~%") |
724 |
|
|
725 |
|
(let ((p nil)) |
726 |
|
(dolist (tem files) |
727 |
|
(when (equal (pathname-type tem) "o") |
728 |
|
(push (list (substitute #\_ #\- (pathname-name tem)) tem) p))) |
729 |
|
|
730 |
|
(setq p (nreverse p)) |
731 |
|
|
732 |
|
(dolist (tem p) |
733 |
|
(format st "extern void init_~a(void);~%" (car tem))) |
734 |
|
(format st "~%") |
735 |
|
|
736 |
|
(format st "typedef struct {void (*fn)(void);char *s;} Fnlst;~%") |
737 |
|
(format st "#define NF ~a~%" (length p)) |
738 |
|
(format st "static Fnlst my_fnlst[NF]={") |
739 |
|
(dolist (tem p) |
740 |
|
(when (not (eq tem (car p))) |
741 |
|
(format st ",~%")) |
742 |
|
(format st "{init_~a,\"~a\"}" (car tem) (cadr tem))) |
743 |
|
(format st "};~%~%") |
744 |
|
|
745 |
|
(format st "object user_init(void) {~%") |
746 |
|
(dolist (tem files) |
747 |
|
(cond ((equal (cadr (car p)) tem) |
748 |
|
(format st "gcl_init_or_load1(init_~a,\"~a\");~%" (car (car p)) (cadr (car p))) |
749 |
|
(setq p (cdr p))) |
750 |
|
(t |
751 |
|
(format st "load2(\"~a\");~%" tem)))) |
752 |
|
(format st "return Cnil;}~%~%") |
753 |
|
|
754 |
|
(format st "int user_match(const char *s,int n) {~%") |
755 |
|
(format st " const Fnlst *f;~%") |
756 |
|
(format st " for (f=my_fnlst;f<my_fnlst+NF;f++){~%") |
757 |
|
(format st " if (!strncmp(s,f->s,n)) {~%") |
758 |
|
(format st " gcl_init_or_load1(f->fn,f->s);~%") |
759 |
|
(format st " return 1;~%") |
760 |
|
(format st " }~%") |
761 |
|
(format st " }~%") |
762 |
|
(format st " return 0;~%") |
763 |
|
(format st "}~%~%"))) |
764 |
|
|
765 |
|
(compiler-cc tem (concatenate 'string out ".o")) |
766 |
|
; (system (format nil "~a ~a" *cc* tem)) |
767 |
|
(delete-file tem) |
768 |
|
|
769 |
|
) |
770 |
|
|
771 |
|
(defun link (files image &optional post extra-libs (run-user-init t) &aux raw init) |
772 |
|
|
773 |
|
(make-user-init files "user-init") |
774 |
|
(setq raw (format nil "raw_~a" (pathname-name image))) |
775 |
|
(setq init (format nil "init_~a.lsp" (pathname-name image))) |
776 |
|
|
777 |
|
(system |
778 |
|
(format nil "~a ~a user-init.o ~a -L~a ~a ~a" |
779 |
|
*ld* |
780 |
|
raw |
781 |
|
(let ((sfiles "")) |
782 |
|
(dolist (tem files) |
783 |
|
(if (equal (pathname-type tem) "o") |
784 |
|
(setq sfiles (concatenate 'string sfiles " " tem)))) |
785 |
|
sfiles) |
786 |
|
si::*system-directory* |
787 |
|
*ld-libs* |
788 |
|
(if (stringp extra-libs) extra-libs ""))) |
789 |
|
|
790 |
|
(delete-file "user-init.o") |
791 |
|
|
792 |
|
(with-open-file (st init :direction :output) |
793 |
|
(unless run-user-init |
794 |
|
(format st "(fmakunbound 'si::user-init)~%")) |
795 |
|
(format st "(setq si::*no-init* '(") |
796 |
|
(dolist (tem files) |
797 |
|
(format st " \"~a\"" (pathname-name tem))) |
798 |
|
(format st "))~%") |
799 |
|
(with-open-file (st1 |
800 |
|
(format nil "~a~a" si::*system-directory* *init-lsp*)) |
801 |
|
(si::copy-stream st1 st)) |
802 |
|
(if (stringp post) (format st "~a~%" post)) |
803 |
|
(format st "(si::save-system \"~a\")~%" image)) |
804 |
|
|
805 |
|
(system (format nil "./~a ~a < ~a" |
806 |
|
raw |
807 |
|
si::*system-directory* |
808 |
|
init)) |
809 |
|
|
810 |
|
(delete-file raw) |
811 |
|
(delete-file init) |
812 |
|
|
813 |
|
) |