1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | (in-package "CCL") |
---|
18 | |
---|
19 | (require 'systems) |
---|
20 | |
---|
21 | ; Interim PPC support |
---|
22 | ; sequences is here since l1-typesys REQUIREs it |
---|
23 | (defparameter *level-1-modules* |
---|
24 | '(level-1 |
---|
25 | l1-cl-package |
---|
26 | l1-boot-1 l1-boot-2 l1-boot-3 |
---|
27 | l1-utils l1-init l1-symhash l1-numbers l1-aprims |
---|
28 | l1-sort l1-dcode l1-clos-boot l1-clos |
---|
29 | l1-unicode l1-streams l1-files l1-io |
---|
30 | l1-format l1-readloop l1-reader |
---|
31 | l1-sysio l1-pathnames l1-events |
---|
32 | l1-boot-lds l1-readloop-lds |
---|
33 | l1-lisp-threads l1-application l1-processes |
---|
34 | l1-typesys sysutils l1-error-system |
---|
35 | l1-error-signal version l1-callbacks |
---|
36 | l1-sockets linux-files |
---|
37 | |
---|
38 | )) |
---|
39 | |
---|
40 | (defparameter *compiler-modules* |
---|
41 | '(nx optimizers dll-node arch vreg vinsn |
---|
42 | reg subprims backend)) |
---|
43 | |
---|
44 | |
---|
45 | (defparameter *ppc-compiler-modules* |
---|
46 | '(ppc32-arch |
---|
47 | ppc64-arch |
---|
48 | ppc-arch |
---|
49 | ppcenv |
---|
50 | ppc-asm |
---|
51 | risc-lap |
---|
52 | ppc-lap |
---|
53 | ppc-backend |
---|
54 | )) |
---|
55 | |
---|
56 | (defparameter *x86-compiler-modules* |
---|
57 | '(x86-arch |
---|
58 | x86-asm |
---|
59 | x86-lap |
---|
60 | x8664-arch |
---|
61 | x8664env |
---|
62 | x86-backend |
---|
63 | ) |
---|
64 | ) |
---|
65 | |
---|
66 | (defparameter *ppc32-compiler-backend-modules* |
---|
67 | '(ppc32-backend ppc32-vinsns)) |
---|
68 | |
---|
69 | (defparameter *ppc64-compiler-backend-modules* |
---|
70 | '(ppc64-backend ppc64-vinsns)) |
---|
71 | |
---|
72 | |
---|
73 | (defparameter *ppc-compiler-backend-modules* |
---|
74 | '(ppc2)) |
---|
75 | |
---|
76 | |
---|
77 | (defparameter *x8632-compiler-backend-modules* |
---|
78 | '(x8632-backend x8632-vinsns)) |
---|
79 | |
---|
80 | (defparameter *x8664-compiler-backend-modules* |
---|
81 | '(x8664-backend x8664-vinsns)) |
---|
82 | |
---|
83 | (defparameter *x86-compiler-backend-modules* |
---|
84 | '(x862)) |
---|
85 | |
---|
86 | |
---|
87 | |
---|
88 | |
---|
89 | (defparameter *ppc-xload-modules* '(xppcfasload xfasload heap-image )) |
---|
90 | (defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image )) |
---|
91 | |
---|
92 | |
---|
93 | ;;; Not too OS-specific. |
---|
94 | (defparameter *ppc-xdev-modules* '(ppc-lapmacros )) |
---|
95 | (defparameter *x86-xdev-modules* '(x86-lapmacros )) |
---|
96 | |
---|
97 | (defun target-xdev-modules (&optional (target |
---|
98 | (backend-target-arch-name |
---|
99 | *host-backend*))) |
---|
100 | (case target |
---|
101 | ((:ppc32 :ppc64) *ppc-xdev-modules*) |
---|
102 | ((:x8632 :x8664) *x86-xdev-modules*))) |
---|
103 | |
---|
104 | (defun target-xload-modules (&optional (target |
---|
105 | (backend-target-arch-name *host-backend*))) |
---|
106 | (case target |
---|
107 | ((:ppc32 :ppc64) *ppc-xload-modules*) |
---|
108 | (:x8664 *x8664-xload-modules*))) |
---|
109 | |
---|
110 | |
---|
111 | |
---|
112 | |
---|
113 | |
---|
114 | |
---|
115 | (defparameter *env-modules* |
---|
116 | '(hash backquote lispequ level-2 macros |
---|
117 | defstruct-macros lists chars setf setf-runtime |
---|
118 | defstruct defstruct-lds |
---|
119 | foreign-types |
---|
120 | db-io |
---|
121 | nfcomp |
---|
122 | )) |
---|
123 | |
---|
124 | (defun target-env-modules (&optional (target |
---|
125 | (backend-name *host-backend*))) |
---|
126 | (append *env-modules* |
---|
127 | (list |
---|
128 | (ecase target |
---|
129 | (:linuxppc32 'ffi-linuxppc32) |
---|
130 | (:darwinppc32 'ffi-darwinppc32) |
---|
131 | (:darwinppc64 'ffi-darwinppc64) |
---|
132 | (:linuxppc64 'ffi-linuxppc64) |
---|
133 | (:linuxx8664 'ffi-linuxx8664) |
---|
134 | (:darwinx8664 'ffi-darwinx8664) |
---|
135 | (:freebsdx8664 'ffi-freebsdx8664))))) |
---|
136 | |
---|
137 | |
---|
138 | (defun target-compiler-modules (&optional (target |
---|
139 | (backend-target-arch-name |
---|
140 | *host-backend*))) |
---|
141 | (case target |
---|
142 | (:ppc32 (append *ppc-compiler-modules* |
---|
143 | *ppc32-compiler-backend-modules* |
---|
144 | *ppc-compiler-backend-modules*)) |
---|
145 | (:ppc64 (append *ppc-compiler-modules* |
---|
146 | *ppc64-compiler-backend-modules* |
---|
147 | *ppc-compiler-backend-modules*)) |
---|
148 | (:x8664 (append *x86-compiler-modules* |
---|
149 | *x8664-compiler-backend-modules* |
---|
150 | *x86-compiler-backend-modules*)))) |
---|
151 | |
---|
152 | (defparameter *other-lib-modules* |
---|
153 | '(streams pathnames backtrace |
---|
154 | apropos |
---|
155 | numbers |
---|
156 | dumplisp source-files)) |
---|
157 | |
---|
158 | (defun target-other-lib-modules (&optional (target |
---|
159 | (backend-target-arch-name |
---|
160 | *host-backend*))) |
---|
161 | (append *other-lib-modules* |
---|
162 | (case target |
---|
163 | ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble)) |
---|
164 | (:x8664 '(x86-backtrace x86-disassemble))))) |
---|
165 | |
---|
166 | |
---|
167 | (defun target-lib-modules (&optional (backend-name |
---|
168 | (backend-name *host-backend*))) |
---|
169 | (let* ((backend (or (find-backend backend-name) *host-backend*)) |
---|
170 | (arch-name (backend-target-arch-name backend))) |
---|
171 | (append (target-env-modules backend-name) (target-other-lib-modules arch-name)))) |
---|
172 | |
---|
173 | |
---|
174 | (defparameter *code-modules* |
---|
175 | '(encapsulate |
---|
176 | read misc arrays-fry |
---|
177 | sequences sort |
---|
178 | method-combination |
---|
179 | case-error pprint |
---|
180 | format time |
---|
181 | ; eval step |
---|
182 | backtrace-lds ccl-export-syms prepare-mcl-environment)) |
---|
183 | |
---|
184 | |
---|
185 | |
---|
186 | (defparameter *aux-modules* |
---|
187 | '(systems compile-ccl |
---|
188 | lisp-package |
---|
189 | number-macros number-case-macro |
---|
190 | loop |
---|
191 | runtime |
---|
192 | mcl-compat |
---|
193 | arglist |
---|
194 | edit-callers |
---|
195 | describe |
---|
196 | asdf |
---|
197 | defsystem |
---|
198 | )) |
---|
199 | |
---|
200 | |
---|
201 | |
---|
202 | |
---|
203 | |
---|
204 | |
---|
205 | |
---|
206 | (defun target-level-1-modules (&optional (target (backend-name *host-backend*))) |
---|
207 | (append *level-1-modules* |
---|
208 | (case target |
---|
209 | ((:linuxppc32 :darwinppc32 :linuxppc64 :darwinppc64) |
---|
210 | '(ppc-error-signal ppc-trap-support |
---|
211 | ppc-threads-utils ppc-callback-support)) |
---|
212 | ((:linuxx8664 :freebsdx8664 :darwinx8664) |
---|
213 | '(x86-error-signal x86-trap-support |
---|
214 | x86-threads-utils x86-callback-support))))) |
---|
215 | |
---|
216 | |
---|
217 | |
---|
218 | |
---|
219 | |
---|
220 | |
---|
221 | ; |
---|
222 | |
---|
223 | |
---|
224 | |
---|
225 | |
---|
226 | |
---|
227 | ; Needed to cross-dump an image |
---|
228 | |
---|
229 | |
---|
230 | |
---|
231 | (unless (fboundp 'xload-level-0) |
---|
232 | (%fhave 'xload-level-0 |
---|
233 | #'(lambda (&rest rest) |
---|
234 | (in-development-mode |
---|
235 | (require-modules (target-xload-modules))) |
---|
236 | (apply 'xload-level-0 rest)))) |
---|
237 | |
---|
238 | (defun find-module (module &optional (target (backend-name *host-backend*)) &aux data fasl sources) |
---|
239 | (if (setq data (assoc module *ccl-system*)) |
---|
240 | (let* ((backend (or (find-backend target) *host-backend*))) |
---|
241 | (setq fasl (cadr data) sources (caddr data)) |
---|
242 | (setq fasl (merge-pathnames (backend-target-fasl-pathname |
---|
243 | backend) fasl)) |
---|
244 | (values fasl (if (listp sources) sources (list sources)))) |
---|
245 | (error "Module ~S not defined" module))) |
---|
246 | |
---|
247 | ;compile if needed. |
---|
248 | (defun target-compile-modules (modules target force-compile) |
---|
249 | (if (not (listp modules)) (setq modules (list modules))) |
---|
250 | (in-development-mode |
---|
251 | (dolist (module modules t) |
---|
252 | (multiple-value-bind (fasl sources) (find-module module target) |
---|
253 | (if (needs-compile-p fasl sources force-compile) |
---|
254 | (progn |
---|
255 | (require'nfcomp) |
---|
256 | (compile-file (car sources) |
---|
257 | :output-file fasl |
---|
258 | :verbose t |
---|
259 | :target target))))))) |
---|
260 | |
---|
261 | |
---|
262 | |
---|
263 | |
---|
264 | |
---|
265 | |
---|
266 | (defun needs-compile-p (fasl sources force-compile) |
---|
267 | (if fasl |
---|
268 | (if (eq force-compile t) |
---|
269 | t |
---|
270 | (if (not (probe-file fasl)) |
---|
271 | t |
---|
272 | (let ((fasldate (file-write-date fasl))) |
---|
273 | (if (if (integerp force-compile) (> force-compile fasldate)) |
---|
274 | t |
---|
275 | (dolist (source sources nil) |
---|
276 | (if (> (file-write-date source) fasldate) |
---|
277 | (return t))))))))) |
---|
278 | |
---|
279 | |
---|
280 | |
---|
281 | ;compile if needed, load if recompiled. |
---|
282 | |
---|
283 | (defun update-modules (modules &optional force-compile) |
---|
284 | (if (not (listp modules)) (setq modules (list modules))) |
---|
285 | (in-development-mode |
---|
286 | (dolist (module modules t) |
---|
287 | (multiple-value-bind (fasl sources) (find-module module) |
---|
288 | (if (needs-compile-p fasl sources force-compile) |
---|
289 | (progn |
---|
290 | (require'nfcomp) |
---|
291 | (let* ((*warn-if-redefine* nil)) |
---|
292 | (compile-file (car sources) :output-file fasl :verbose t :load t)) |
---|
293 | (provide module))))))) |
---|
294 | |
---|
295 | (defun compile-modules (modules &optional force-compile) |
---|
296 | (target-compile-modules modules (backend-name *host-backend*) force-compile) |
---|
297 | ) |
---|
298 | |
---|
299 | (defun compile-ccl (&optional force-compile) |
---|
300 | (update-modules 'nxenv force-compile) |
---|
301 | (update-modules *compiler-modules* force-compile) |
---|
302 | (update-modules (target-compiler-modules) force-compile) |
---|
303 | (update-modules (target-xdev-modules) force-compile) |
---|
304 | (update-modules (target-xload-modules) force-compile) |
---|
305 | (let* ((env-modules (target-env-modules)) |
---|
306 | (other-lib (target-other-lib-modules))) |
---|
307 | (require-modules env-modules) |
---|
308 | (update-modules env-modules force-compile) |
---|
309 | (compile-modules (target-level-1-modules) force-compile) |
---|
310 | (update-modules other-lib force-compile) |
---|
311 | (require-modules other-lib) |
---|
312 | (require-update-modules *code-modules* force-compile)) |
---|
313 | (compile-modules *aux-modules* force-compile)) |
---|
314 | |
---|
315 | |
---|
316 | |
---|
317 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
318 | |
---|
319 | (defun require-env (&optional force-load) |
---|
320 | (require-modules (target-env-modules) |
---|
321 | force-load)) |
---|
322 | |
---|
323 | (defun compile-level-1 (&optional force-compile) |
---|
324 | (require-env) |
---|
325 | (compile-modules (target-level-1-modules (backend-name *host-backend*)) |
---|
326 | force-compile)) |
---|
327 | |
---|
328 | |
---|
329 | |
---|
330 | |
---|
331 | |
---|
332 | (defun compile-lib (&optional force-compile) |
---|
333 | (compile-modules (target-lib-modules) |
---|
334 | force-compile)) |
---|
335 | |
---|
336 | (defun compile-code (&optional force-compile) |
---|
337 | (compile-modules *code-modules* force-compile)) |
---|
338 | |
---|
339 | |
---|
340 | ;Compile but don't load |
---|
341 | |
---|
342 | (defun xcompile-ccl (&optional force) |
---|
343 | (compile-modules 'nxenv force) |
---|
344 | (compile-modules *compiler-modules* force) |
---|
345 | (compile-modules (target-compiler-modules) force) |
---|
346 | (compile-modules (target-xdev-modules) force) |
---|
347 | (compile-modules (target-xload-modules) force) |
---|
348 | (compile-modules (target-env-modules) force) |
---|
349 | (compile-modules (target-level-1-modules) force) |
---|
350 | (compile-modules (target-other-lib-modules) force) |
---|
351 | (compile-modules *code-modules* force) |
---|
352 | (compile-modules *aux-modules* force)) |
---|
353 | |
---|
354 | (defun require-update-modules (modules &optional force-compile) |
---|
355 | (if (not (listp modules)) (setq modules (list modules))) |
---|
356 | (in-development-mode |
---|
357 | (dolist (module modules) |
---|
358 | (require-modules module) |
---|
359 | (update-modules module force-compile)))) |
---|
360 | |
---|
361 | (defun compile-level-1 (&optional force-compile) |
---|
362 | (compile-modules (target-level-1-modules (backend-name *host-backend*)) |
---|
363 | force-compile)) |
---|
364 | |
---|
365 | |
---|
366 | |
---|
367 | |
---|
368 | |
---|
369 | (defun target-xcompile-ccl (target &optional force) |
---|
370 | (let* ((backend (or (find-backend target) *target-backend*)) |
---|
371 | (arch (backend-target-arch-name backend)) |
---|
372 | (*defstruct-share-accessor-functions* nil)) |
---|
373 | (target-compile-modules 'nxenv target force) |
---|
374 | (target-compile-modules *compiler-modules* target force) |
---|
375 | (target-compile-modules (target-compiler-modules arch) target force) |
---|
376 | (target-compile-modules (target-level-1-modules target) target force) |
---|
377 | (target-compile-modules (target-lib-modules target) target force) |
---|
378 | (target-compile-modules *aux-modules* target force) |
---|
379 | (target-compile-modules *code-modules* target force) |
---|
380 | (target-compile-modules (target-xdev-modules arch) target force))) |
---|
381 | |
---|
382 | (defun cross-compile-ccl (target &optional force) |
---|
383 | (with-cross-compilation-target (target) |
---|
384 | (let* ((*target-backend* (find-backend target))) |
---|
385 | (target-xcompile-ccl target force)))) |
---|
386 | |
---|
387 | |
---|
388 | (defun require-module (module force-load) |
---|
389 | (multiple-value-bind (fasl source) (find-module module) |
---|
390 | (setq source (car source)) |
---|
391 | (if (if fasl (probe-file fasl)) |
---|
392 | (if force-load |
---|
393 | (progn |
---|
394 | (load fasl) |
---|
395 | (provide module)) |
---|
396 | (require module fasl)) |
---|
397 | (if (probe-file source) |
---|
398 | (progn |
---|
399 | (if fasl (format t "~&Can't find ~S so requiring ~S instead" |
---|
400 | fasl source)) |
---|
401 | (if force-load |
---|
402 | (progn |
---|
403 | (load source) |
---|
404 | (provide module)) |
---|
405 | (require module source))) |
---|
406 | (error "Can't find ~S or ~S" fasl source))))) |
---|
407 | |
---|
408 | (defun require-modules (modules &optional force-load) |
---|
409 | (if (not (listp modules)) (setq modules (list modules))) |
---|
410 | (let ((*package* (find-package :ccl))) |
---|
411 | (dolist (m modules t) |
---|
412 | (require-module m force-load)))) |
---|
413 | |
---|
414 | |
---|
415 | (defun target-xcompile-level-1 (target &optional force) |
---|
416 | (target-compile-modules (target-level-1-modules target) target force)) |
---|
417 | |
---|
418 | (defun standard-boot-image-name (&optional (target (backend-name *host-backend*))) |
---|
419 | (ecase target |
---|
420 | (:darwinppc32 "ppc-boot.image") |
---|
421 | (:linuxppc32 "ppc-boot") |
---|
422 | (:darwinppc64 "ppc-boot64.image") |
---|
423 | (:linuxppc64 "ppc-boot64") |
---|
424 | (:linuxx8664 "x86-boot64") |
---|
425 | (:freebsdx8664 "fx86-boot64") |
---|
426 | (:darwinx8664 "x86-boot64.image"))) |
---|
427 | |
---|
428 | (defun standard-kernel-name (&optional (target (backend-name *host-backend*))) |
---|
429 | (ecase target |
---|
430 | (:darwinppc32 "dppccl") |
---|
431 | (:linuxppc32 "ppccl") |
---|
432 | (:darwinppc64 "dppccl64") |
---|
433 | (:linuxppc64 "ppccl64") |
---|
434 | (:linuxx8664 "lx86cl64") |
---|
435 | (:freebsdx8664 "fx86cl64") |
---|
436 | (:darwinx8664 "dx86cl64"))) |
---|
437 | |
---|
438 | (defun standard-image-name (&optional (target (backend-name *host-backend*))) |
---|
439 | (ecase target |
---|
440 | (:darwinppc32 "dppccl.image") |
---|
441 | (:linuxppc32 "PPCCL") |
---|
442 | (:darwinppc64 "dppccl64.image") |
---|
443 | (:linuxppc64 "PPCCL64") |
---|
444 | (:linuxx8664 "LX86CL64") |
---|
445 | (:freebsdx8664 "FX86CL64") |
---|
446 | (:darwinx8664 "dx86cl64.image"))) |
---|
447 | |
---|
448 | (defun kernel-build-directory (&optional (target (backend-name *host-backend*))) |
---|
449 | (ecase target |
---|
450 | (:darwinppc32 "darwinppc") |
---|
451 | (:linuxppc32 "linuxppc") |
---|
452 | (:darwinppc64 "darwinppc64") |
---|
453 | (:linuxppc64 "linuxppc64") |
---|
454 | (:linuxx8664 "linuxx8664") |
---|
455 | (:freebsdx8664 "freebsdx8664") |
---|
456 | (:darwinx8664 "darwinx8664"))) |
---|
457 | |
---|
458 | (defparameter *known-optional-features* '(:lock-accouting :count-gf-calls :monitor-futex-wait)) |
---|
459 | (defvar *build-time-optional-features* nil) |
---|
460 | |
---|
461 | |
---|
462 | (defun rebuild-ccl (&key update full clean kernel force (reload t) exit reload-arguments verbose optional-features) |
---|
463 | (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features)) |
---|
464 | (*features* (append *build-time-optional-features* *features*))) |
---|
465 | (when *build-time-optional-features* |
---|
466 | (setq full t)) |
---|
467 | (when full |
---|
468 | (setq clean t kernel t reload t)) |
---|
469 | (when update (update-ccl)) |
---|
470 | (let* ((cd (current-directory))) |
---|
471 | (unwind-protect |
---|
472 | (progn |
---|
473 | (setf (current-directory) "ccl:") |
---|
474 | (when clean |
---|
475 | (dolist (f (directory |
---|
476 | (merge-pathnames |
---|
477 | (make-pathname :name :wild |
---|
478 | :type (pathname-type *.fasl-pathname*)) |
---|
479 | "ccl:**;"))) |
---|
480 | (delete-file f))) |
---|
481 | (when kernel |
---|
482 | (when (or clean force) |
---|
483 | ;; Do a "make -k clean". |
---|
484 | (run-program "make" |
---|
485 | (list "-k" |
---|
486 | "-C" |
---|
487 | (format nil "lisp-kernel/~a" |
---|
488 | (kernel-build-directory)) |
---|
489 | "clean"))) |
---|
490 | (format t "~&;Building lisp-kernel ...") |
---|
491 | (with-output-to-string (s) |
---|
492 | (multiple-value-bind |
---|
493 | (status exit-code) |
---|
494 | (external-process-status |
---|
495 | (run-program "make" |
---|
496 | (list "-k" "-C" |
---|
497 | (format nil "lisp-kernel/~a" |
---|
498 | (kernel-build-directory)) |
---|
499 | "-j" |
---|
500 | |
---|
501 | (format nil "~d" (1+ (cpu-count)))) |
---|
502 | :output s |
---|
503 | :error s)) |
---|
504 | (if (and (eq :exited status) (zerop exit-code)) |
---|
505 | (progn |
---|
506 | (format t "~&;Kernel built successfully.") |
---|
507 | (when verbose |
---|
508 | (format t "~&;kernel build output:~%~a" |
---|
509 | (get-output-stream-string s))) |
---|
510 | (sleep 1)) |
---|
511 | (error "Error(s) during kernel compilation.~%~a" |
---|
512 | (get-output-stream-string s)))))) |
---|
513 | (compile-ccl (not (null force))) |
---|
514 | (if force (xload-level-0 :force) (xload-level-0)) |
---|
515 | (when reload |
---|
516 | (with-input-from-string (cmd (format nil |
---|
517 | "(save-application ~s)" |
---|
518 | (standard-image-name))) |
---|
519 | (with-output-to-string (output) |
---|
520 | (multiple-value-bind (status exit-code) |
---|
521 | (external-process-status |
---|
522 | (run-program |
---|
523 | (format nil "./~a" (standard-kernel-name)) |
---|
524 | (list* "--image-name" (standard-boot-image-name) |
---|
525 | reload-arguments) |
---|
526 | :input cmd |
---|
527 | :output output |
---|
528 | :error output)) |
---|
529 | (if (and (eq status :exited) |
---|
530 | (eql exit-code 0)) |
---|
531 | (progn |
---|
532 | (format t "~&;Wrote heap image: ~s" |
---|
533 | (truename (format nil "ccl:~a" |
---|
534 | (standard-image-name)))) |
---|
535 | (when verbose |
---|
536 | (format t "~&;Reload heap image output:~%~a" |
---|
537 | (get-output-stream-string output)))) |
---|
538 | (error "Errors (~s ~s) reloading boot image:~&~a" |
---|
539 | status exit-code |
---|
540 | (get-output-stream-string output))))))) |
---|
541 | (when exit |
---|
542 | (quit))) |
---|
543 | (setf (current-directory) cd))))) |
---|
544 | |
---|
545 | |
---|
546 | (defun create-interfaces (dirname &key target populate-arg) |
---|
547 | (let* ((backend (if target (find-backend target) *target-backend*)) |
---|
548 | (*default-pathname-defaults* nil) |
---|
549 | (ftd (backend-target-foreign-type-data backend)) |
---|
550 | (d (use-interface-dir dirname ftd)) |
---|
551 | (populate (merge-pathnames "C/populate.sh" |
---|
552 | (merge-pathnames |
---|
553 | (interface-dir-subdir d) |
---|
554 | (ftd-interface-db-directory ftd)))) |
---|
555 | (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate)))) |
---|
556 | (args (list "-c" |
---|
557 | (format nil "cd ~a && /bin/sh ~a ~@[~a~]" |
---|
558 | (native-translated-namestring cdir) |
---|
559 | (native-translated-namestring populate) |
---|
560 | populate-arg)))) |
---|
561 | (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate) |
---|
562 | (force-output t) |
---|
563 | (multiple-value-bind (status exit-code) |
---|
564 | (external-process-status |
---|
565 | (run-program "/bin/sh" args :output t)) |
---|
566 | (if (and (eq status :exited) |
---|
567 | (eql exit-code 0)) |
---|
568 | (let* ((f 'parse-standard-ffi-files)) |
---|
569 | (require "PARSE-FFI") |
---|
570 | (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname) |
---|
571 | (funcall f dirname target) |
---|
572 | (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]") |
---|
573 | (funcall f dirname target)))))) |
---|
574 | |
---|
575 | (defun update-ccl () |
---|
576 | (let* ((cvs-update "cvs -q update -d -P") |
---|
577 | (svn-update "svn update") |
---|
578 | (use-cvs (probe-file "ccl:\.svnrev")) |
---|
579 | (s (make-string-output-stream))) |
---|
580 | (multiple-value-bind (status exit-code) |
---|
581 | (external-process-status |
---|
582 | (run-program "/bin/sh" |
---|
583 | (list "-c" |
---|
584 | (format nil "cd ~a && ~a" |
---|
585 | (native-translated-namestring "ccl:") |
---|
586 | (if use-cvs cvs-update svn-update))) |
---|
587 | :output s)) |
---|
588 | (when (and (eq status :exited) |
---|
589 | (eql exit-code 0)) |
---|
590 | (format t "~&~a" (get-output-stream-string s)) |
---|
591 | t)))) |
---|
592 | |
---|
593 | (defmacro with-preserved-working-directory ((&optional dir) &body body) |
---|
594 | (let ((wd (gensym))) |
---|
595 | `(let ((,wd (mac-default-directory))) |
---|
596 | (unwind-protect |
---|
597 | (progn |
---|
598 | ,@(when dir `((cwd ,dir))) |
---|
599 | ,@body) |
---|
600 | (cwd ,wd))))) |
---|
601 | |
---|
602 | (defun ensure-tests-loaded (&key force update ansi ccl) |
---|
603 | (unless (and (find-package "REGRESSION-TEST") (not force)) |
---|
604 | (if (probe-file "ccl:tests;ansi-tests;") |
---|
605 | (when update |
---|
606 | (cwd "ccl:tests;") |
---|
607 | (run-program "svn" '("update"))) |
---|
608 | (let* ((svn (probe-file "ccl:.svn;entries")) |
---|
609 | (repo (and svn (svn-repository))) |
---|
610 | (s (make-string-output-stream))) |
---|
611 | (when repo |
---|
612 | (format t "~&Checking out test suite into ccl:tests;~%") |
---|
613 | (cwd "ccl:") |
---|
614 | (multiple-value-bind (status exit-code) |
---|
615 | (external-process-status |
---|
616 | (run-program "svn" (list "checkout" (format nil "~a/trunk/tests" repo) "tests") |
---|
617 | :output s |
---|
618 | :error s)) |
---|
619 | (unless (and (eq status :exited) |
---|
620 | (eql exit-code 0)) |
---|
621 | (error "Failed to check out test suite: ~%~a" (get-output-stream-string s))))))) |
---|
622 | (cwd "ccl:tests;ansi-tests;") |
---|
623 | (run-program "make" '("-k" "clean")) |
---|
624 | (map nil 'delete-file (directory "*.*fsl")) |
---|
625 | ;; Muffle the typecase "clause ignored" warnings, since there is really nothing we can do about |
---|
626 | ;; it without making the test suite non-portable across platforms... |
---|
627 | (handler-bind ((warning (lambda (c) |
---|
628 | (when (let ((w (or (and (typep c 'compiler-warning) |
---|
629 | (eq (compiler-warning-warning-type c) :program-error) |
---|
630 | (car (compiler-warning-args c))) |
---|
631 | c))) |
---|
632 | (and (typep w 'simple-warning) |
---|
633 | (or |
---|
634 | (string-equal |
---|
635 | (simple-condition-format-control w) |
---|
636 | "Clause ~S ignored in ~S form - shadowed by ~S .") |
---|
637 | ;; Might as well ignore these as well, they're intentional. |
---|
638 | (string-equal |
---|
639 | (simple-condition-format-control w) |
---|
640 | "Duplicate keyform ~s in ~s statement.")))) |
---|
641 | (muffle-warning c))))) |
---|
642 | ;; This loads the infrastructure |
---|
643 | (load "ccl:tests;ansi-tests;gclload1.lsp") |
---|
644 | ;; This loads the actual tests |
---|
645 | (let ((redef-var (find-symbol "*WARN-IF-REDEFINE-TEST*" :REGRESSION-TEST))) |
---|
646 | (progv (list redef-var) (list (if force nil (symbol-value redef-var))) |
---|
647 | (when ansi |
---|
648 | (load "ccl:tests;ansi-tests;gclload2.lsp")) |
---|
649 | ;; And our own tests |
---|
650 | (when ccl |
---|
651 | (load "ccl:tests;ansi-tests;ccl.lsp"))))))) |
---|
652 | |
---|
653 | (defun test-ccl (&key force (update t) verbose (catch-errors t) (ansi t) (ccl t) |
---|
654 | optimization-settings) |
---|
655 | (with-preserved-working-directory () |
---|
656 | (let* ((*package* (find-package "CL-USER"))) |
---|
657 | (ensure-tests-loaded :force force :update update :ansi ansi :ccl ccl) |
---|
658 | (cwd "ccl:tests;ansi-tests;") |
---|
659 | (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST")) |
---|
660 | (*print-catch-errors* nil)) |
---|
661 | (time (funcall do-tests :verbose verbose :compile t |
---|
662 | :catch-errors catch-errors |
---|
663 | :optimization-settings (or optimization-settings '((safety 2)))))) |
---|
664 | ;; Ok, here we would run any of our own tests. |
---|
665 | ))) |
---|