source: trunk/source/lib/compile-ccl.lisp @ 10254

Last change on this file since 10254 was 10254, checked in by gb, 11 years ago

First cut at an UPDATE-CCL function:
(update-ccl &key (verbose t))
Runs "svn update" in the ccl directory and parses the output.
Quietly resolves (via "svn revert") conflicts involving the kernel and
image.
CERRORs on other conflicts, offering to use "svn revert" on them, too.
When "verbose", reports changed files.
Returns T iff anything changed, and a second value listing unresolved
conflicts. (That may not be too well thought out; might do the
conflict resolution under control of some other option.)

REBUILD-CCL calls UPDATE-CCL if its :UPDATE arg is non-nil, and
passes :VERBOSE T unless (rebuild-ccl :update :quiet).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 27.5 KB
Line 
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  '(x8632-arch
58    x8664-arch
59    x86-arch
60    x8632env
61    x8664env
62    x86-asm
63    x86-lap
64    x86-backend
65))
66
67(defparameter *ppc32-compiler-backend-modules*
68  '(ppc32-backend ppc32-vinsns))
69
70(defparameter *ppc64-compiler-backend-modules*
71  '(ppc64-backend ppc64-vinsns))
72
73
74(defparameter *ppc-compiler-backend-modules*
75  '(ppc2))
76
77
78(defparameter *x8632-compiler-backend-modules*
79  '(x8632-backend x8632-vinsns))
80
81(defparameter *x8664-compiler-backend-modules*
82  '(x8664-backend x8664-vinsns))
83
84(defparameter *x86-compiler-backend-modules*
85  '(x862))
86
87
88
89
90(defparameter *ppc-xload-modules* '(xppcfasload xfasload heap-image ))
91(defparameter *x8632-xload-modules* '(xx8632fasload xfasload heap-image ))
92(defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image ))
93
94
95;;; Not too OS-specific.
96(defparameter *ppc-xdev-modules* '(ppc-lapmacros ))
97(defparameter *x86-xdev-modules* '(x86-lapmacros ))
98
99(defun target-xdev-modules (&optional (target
100                                       (backend-target-arch-name
101                                        *host-backend*)))
102  (case target
103    ((:ppc32 :ppc64) *ppc-xdev-modules*)
104    ((:x8632 :x8664) *x86-xdev-modules*)))
105
106(defun target-xload-modules (&optional (target
107                                        (backend-target-arch-name *host-backend*)))
108  (case target
109    ((:ppc32 :ppc64) *ppc-xload-modules*)
110    (:x8632 *x8632-xload-modules*)
111    (:x8664 *x8664-xload-modules*)))
112
113
114
115
116
117
118(defparameter *env-modules*
119  '(hash backquote lispequ  level-2 macros
120    defstruct-macros lists chars setf setf-runtime
121    defstruct defstruct-lds 
122    foreign-types
123    db-io
124    nfcomp
125    ))
126
127(defun target-env-modules (&optional (target
128                                      (backend-name *host-backend*)))
129  (append *env-modules*
130          (list
131           (ecase target
132             (:linuxppc32 'ffi-linuxppc32)
133             (:darwinppc32 'ffi-darwinppc32)
134             (:darwinppc64 'ffi-darwinppc64)
135             (:linuxppc64 'ffi-linuxppc64)
136             (:darwinx8632 'ffi-darwinx8632)
137             (:linuxx8664 'ffi-linuxx8664)
138             (:darwinx8664 'ffi-darwinx8664)
139             (:freebsdx8664 'ffi-freebsdx8664)
140             (:solarisx8664 'ffi-solarisx8664)))))
141
142
143(defun target-compiler-modules (&optional (target
144                                           (backend-target-arch-name
145                                            *host-backend*)))
146  (case target
147    (:ppc32 (append *ppc-compiler-modules*
148                    *ppc32-compiler-backend-modules*
149                    *ppc-compiler-backend-modules*))
150    (:ppc64 (append *ppc-compiler-modules*
151                    *ppc64-compiler-backend-modules*
152                    *ppc-compiler-backend-modules*))
153    (:x8632 (append *x86-compiler-modules*
154                    *x8632-compiler-backend-modules*
155                    *x86-compiler-backend-modules*))
156    (:x8664 (append *x86-compiler-modules*
157                    *x8664-compiler-backend-modules*
158                    *x86-compiler-backend-modules*))))
159
160(defparameter *other-lib-modules*
161  '(streams pathnames backtrace
162    apropos
163    numbers 
164    dumplisp   source-files))
165
166(defun target-other-lib-modules (&optional (target
167                                            (backend-target-arch-name
168                                             *host-backend*)))
169  (append *other-lib-modules*
170          (case target
171            ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble))
172            ((:x8632 :x8664) '(x86-backtrace x86-disassemble)))))
173         
174
175(defun target-lib-modules (&optional (backend-name
176                                      (backend-name *host-backend*)))
177  (let* ((backend (or (find-backend backend-name) *host-backend*))
178         (arch-name (backend-target-arch-name backend)))
179    (append (target-env-modules backend-name) (target-other-lib-modules arch-name))))
180
181
182(defparameter *code-modules*
183      '(encapsulate
184        read misc  arrays-fry
185        sequences sort 
186        method-combination
187        case-error pprint 
188        format time 
189;        eval step
190        backtrace-lds  ccl-export-syms prepare-mcl-environment))
191
192
193
194(defparameter *aux-modules*
195      '(systems compile-ccl 
196        lisp-package
197        number-macros number-case-macro
198        loop
199        runtime
200        mcl-compat
201        arglist
202        edit-callers
203        describe
204        asdf
205        defsystem
206))
207
208
209
210
211
212
213
214(defun target-level-1-modules (&optional (target (backend-name *host-backend*)))
215  (append *level-1-modules*
216          (case target
217            ((:linuxppc32 :darwinppc32 :linuxppc64 :darwinppc64)
218             '(ppc-error-signal ppc-trap-support
219               ppc-threads-utils ppc-callback-support))
220            ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664
221              :darwinx8632)
222             '(x86-error-signal x86-trap-support
223               x86-threads-utils x86-callback-support)))))
224
225                 
226
227
228
229
230;
231
232
233
234
235
236; Needed to cross-dump an image
237
238
239
240(unless (fboundp 'xload-level-0)
241  (%fhave 'xload-level-0
242          #'(lambda (&rest rest)
243              (in-development-mode
244               (require-modules (target-xload-modules)))
245              (apply 'xload-level-0 rest))))
246
247(defun find-module (module &optional (target (backend-name *host-backend*))  &aux data fasl sources)
248  (if (setq data (assoc module *ccl-system*))
249    (let* ((backend (or (find-backend target) *host-backend*)))
250      (setq fasl (cadr data) sources (caddr data))     
251      (setq fasl (merge-pathnames (backend-target-fasl-pathname
252                                   backend) fasl))
253      (values fasl (if (listp sources) sources (list sources))))
254    (error "Module ~S not defined" module)))
255
256;compile if needed.
257(defun target-compile-modules (modules target force-compile)
258  (if (not (listp modules)) (setq modules (list modules)))
259  (in-development-mode
260   (dolist (module modules t)
261     (multiple-value-bind (fasl sources) (find-module module target)
262      (if (needs-compile-p fasl sources force-compile)
263        (progn
264          (require'nfcomp)
265          (compile-file (car sources)
266                        :output-file fasl
267                        :verbose t
268                        :target target)))))))
269
270
271
272
273
274
275(defun needs-compile-p (fasl sources force-compile)
276  (if fasl
277    (if (eq force-compile t)
278      t
279      (if (not (probe-file fasl))
280        t
281        (let ((fasldate (file-write-date fasl)))
282          (if (if (integerp force-compile) (> force-compile fasldate))
283            t
284            (dolist (source sources nil)
285              (if (> (file-write-date source) fasldate)
286                (return t)))))))))
287
288
289
290;compile if needed, load if recompiled.
291
292(defun update-modules (modules &optional force-compile)
293  (if (not (listp modules)) (setq modules (list modules)))
294  (in-development-mode
295   (dolist (module modules t)
296     (multiple-value-bind (fasl sources) (find-module module)
297       (if (needs-compile-p fasl sources force-compile)
298         (progn
299           (require'nfcomp)
300           (let* ((*warn-if-redefine* nil))
301             (compile-file (car sources) :output-file fasl :verbose t :load t))
302           (provide module)))))))
303
304(defun compile-modules (modules &optional force-compile)
305  (target-compile-modules modules (backend-name *host-backend*) force-compile)
306)
307
308(defun compile-ccl (&optional force-compile)
309  (update-modules 'nxenv force-compile)
310  (update-modules *compiler-modules* force-compile)
311  (update-modules (target-compiler-modules) force-compile)
312  (update-modules (target-xdev-modules) force-compile)
313  (update-modules (target-xload-modules)  force-compile)
314  (let* ((env-modules (target-env-modules))
315         (other-lib (target-other-lib-modules)))
316    (require-modules env-modules)
317    (update-modules env-modules force-compile)
318    (compile-modules (target-level-1-modules)  force-compile)
319    (update-modules other-lib force-compile)
320    (require-modules other-lib)
321    (require-update-modules *code-modules* force-compile))
322  (compile-modules *aux-modules* force-compile))
323
324
325
326;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
327
328(defun require-env (&optional force-load)
329  (require-modules  (target-env-modules)
330                   force-load))
331
332(defun compile-level-1 (&optional force-compile)
333  (require-env)
334  (compile-modules (target-level-1-modules (backend-name *host-backend*))
335                   force-compile))
336
337
338
339
340
341(defun compile-lib (&optional force-compile)
342  (compile-modules (target-lib-modules)
343                   force-compile))
344
345(defun compile-code (&optional force-compile)
346  (compile-modules *code-modules* force-compile))
347
348
349;Compile but don't load
350
351(defun xcompile-ccl (&optional force)
352  (compile-modules 'nxenv force)
353  (compile-modules *compiler-modules* force)
354  (compile-modules (target-compiler-modules) force)
355  (compile-modules (target-xdev-modules) force)
356  (compile-modules (target-xload-modules)  force)
357  (compile-modules (target-env-modules) force)
358  (compile-modules (target-level-1-modules) force)
359  (compile-modules (target-other-lib-modules) force)
360  (compile-modules *code-modules* force)
361  (compile-modules *aux-modules* force))
362
363(defun require-update-modules (modules &optional force-compile)
364  (if (not (listp modules)) (setq modules (list modules)))
365  (in-development-mode
366    (dolist (module modules)
367    (require-modules module)
368    (update-modules module force-compile))))
369
370(defun compile-level-1 (&optional force-compile)
371  (compile-modules (target-level-1-modules (backend-name *host-backend*))
372                   force-compile))
373
374
375
376 
377
378(defun target-xcompile-ccl (target &optional force)
379  (let* ((backend (or (find-backend target) *target-backend*))
380         (arch (backend-target-arch-name backend))
381         (*defstruct-share-accessor-functions* nil))
382    (target-compile-modules 'nxenv target force)
383    (target-compile-modules *compiler-modules* target force)
384    (target-compile-modules (target-compiler-modules arch) target force)
385    (target-compile-modules (target-level-1-modules target) target force)
386    (target-compile-modules (target-lib-modules target) target force)
387    (target-compile-modules *aux-modules* target force)
388    (target-compile-modules *code-modules* target force)
389    (target-compile-modules (target-xdev-modules arch) target force)))
390
391(defun cross-compile-ccl (target &optional force)
392  (with-cross-compilation-target (target)
393    (let* ((*target-backend* (find-backend target)))
394      (target-xcompile-ccl target force))))
395
396
397(defun require-module (module force-load)
398  (multiple-value-bind (fasl source) (find-module module)
399      (setq source (car source))
400      (if (if fasl (probe-file fasl))
401        (if force-load
402          (progn
403            (load fasl)
404            (provide module))
405          (require module fasl))
406        (if (probe-file source)
407          (progn
408            (if fasl (format t "~&Can't find ~S so requiring ~S instead"
409                             fasl source))
410            (if force-load
411              (progn
412                (load source)
413                (provide module))
414              (require module source)))
415          (error "Can't find ~S or ~S" fasl source)))))
416
417(defun require-modules (modules &optional force-load)
418  (if (not (listp modules)) (setq modules (list modules)))
419  (let ((*package* (find-package :ccl)))
420    (dolist (m modules t)
421      (require-module m force-load))))
422
423
424(defun target-xcompile-level-1 (target &optional force)
425  (target-compile-modules (target-level-1-modules target) target force))
426
427(defun standard-boot-image-name (&optional (target (backend-name *host-backend*)))
428  (ecase target
429    (:darwinppc32 "ppc-boot.image")
430    (:linuxppc32 "ppc-boot")
431    (:darwinppc64 "ppc-boot64.image")
432    (:linuxppc64 "ppc-boot64")
433    (:darwinx8632 "x86-boot32.image")
434    (:linuxx8664 "x86-boot64")
435    (:freebsdx8664 "fx86-boot64")
436    (:darwinx8664 "x86-boot64.image")
437    (:solarisx8664 "sx86-boot64")))
438
439(defun standard-kernel-name (&optional (target (backend-name *host-backend*)))
440  (ecase target
441    (:darwinppc32 "dppccl")
442    (:linuxppc32 "ppccl")
443    (:darwinppc64 "dppccl64")
444    (:darwinx8632 "dx86cl")
445    (:linuxppc64 "ppccl64")
446    (:linuxx8664 "lx86cl64")
447    (:freebsdx8664 "fx86cl64")
448    (:darwinx8664 "dx86cl64")
449    (:solarisx8664 "sx86cl64")))
450
451(defun standard-image-name (&optional (target (backend-name *host-backend*)))
452  (ecase target
453    (:darwinppc32 "dppccl.image")
454    (:linuxppc32 "PPCCL")
455    (:darwinppc64 "dppccl64.image")
456    (:linuxppc64 "PPCCL64")
457    (:darwinx8632 "dx86cl.image")
458    (:linuxx8664 "LX86CL64")
459    (:freebsdx8664 "FX86CL64")
460    (:darwinx8664 "dx86cl64.image")
461    (:solarisx8664 "SX86CL64")))
462
463(defun kernel-build-directory (&optional (target (backend-name *host-backend*)))
464  (ecase target
465    (:darwinppc32 "darwinppc")
466    (:linuxppc32 "linuxppc")
467    (:darwinppc64 "darwinppc64")
468    (:linuxppc64 "linuxppc64")
469    (:darwinx8632 "darwinx8632")
470    (:linuxx8664 "linuxx8664")
471    (:freebsdx8664 "freebsdx8664")
472    (:darwinx8664 "darwinx8664")
473    (:solarisx8664 "solarisx64")))
474
475(defparameter *known-optional-features* '(:lock-accouting :count-gf-calls :monitor-futex-wait))
476(defvar *build-time-optional-features* nil)
477
478
479(defun rebuild-ccl (&key update full clean kernel force (reload t) exit reload-arguments verbose optional-features)
480  (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features))
481         (*features* (append *build-time-optional-features* *features*)))
482    (when *build-time-optional-features*
483      (setq full t))
484    (when full
485      (setq clean t kernel t reload t))
486    (when update (update-ccl :verbose (not (eq update :quiet))))
487    (let* ((cd (current-directory)))
488      (unwind-protect
489           (progn
490             (setf (current-directory) "ccl:")
491             (when clean
492               (dolist (f (directory
493                           (merge-pathnames
494                            (make-pathname :name :wild
495                                           :type (pathname-type *.fasl-pathname*))
496                            "ccl:**;")))
497                 (delete-file f)))
498             (when kernel
499               (when (or clean force)
500                 ;; Do a "make -k clean".
501                 (run-program "make"
502                              (list "-k"
503                                    "-C"
504                                    (format nil "lisp-kernel/~a"
505                                            (kernel-build-directory))
506                                    "clean")))
507               (format t "~&;Building lisp-kernel ...")
508               (with-output-to-string (s)
509                                      (multiple-value-bind
510                                          (status exit-code)
511                                          (external-process-status 
512                                           (run-program "make"
513                                                        (list "-k" "-C" 
514                                                              (format nil "lisp-kernel/~a"
515                                                                      (kernel-build-directory))
516                                                              "-j"
517                                                           
518                                                              (format nil "~d" (1+ (cpu-count))))
519                                                        :output s
520                                                        :error s))
521                                        (if (and (eq :exited status) (zerop exit-code))
522                                          (progn
523                                            (format t "~&;Kernel built successfully.")
524                                            (when verbose
525                                              (format t "~&;kernel build output:~%~a"
526                                                      (get-output-stream-string s)))
527                                            (sleep 1))
528                                          (error "Error(s) during kernel compilation.~%~a"
529                                                 (get-output-stream-string s))))))
530             (compile-ccl (not (null force)))
531             (if force (xload-level-0 :force) (xload-level-0))
532             (when reload
533               (with-input-from-string (cmd (format nil
534                                                    "(save-application ~s)"
535                                                    (standard-image-name)))
536                 (with-output-to-string (output)
537                                        (multiple-value-bind (status exit-code)
538                                            (external-process-status
539                                             (run-program
540                                              (format nil "./~a" (standard-kernel-name))
541                                              (list* "--image-name" (standard-boot-image-name)
542                                                     reload-arguments)
543                                              :input cmd
544                                              :output output
545                                              :error output))
546                                          (if (and (eq status :exited)
547                                                   (eql exit-code 0))
548                                            (progn
549                                              (format t "~&;Wrote heap image: ~s"
550                                                      (truename (format nil "ccl:~a"
551                                                                        (standard-image-name))))
552                                              (when verbose
553                                                (format t "~&;Reload heap image output:~%~a"
554                                                        (get-output-stream-string output))))
555                                            (error "Errors (~s ~s) reloading boot image:~&~a"
556                                                   status exit-code
557                                                   (get-output-stream-string output)))))))
558             (when exit
559               (quit)))
560        (setf (current-directory) cd)))))
561                                                 
562               
563(defun create-interfaces (dirname &key target populate-arg)
564  (let* ((backend (if target (find-backend target) *target-backend*))
565         (*default-pathname-defaults* nil)
566         (ftd (backend-target-foreign-type-data backend))
567         (d (use-interface-dir dirname ftd))
568         (populate (merge-pathnames "C/populate.sh"
569                                    (merge-pathnames
570                                     (interface-dir-subdir d)
571                                     (ftd-interface-db-directory ftd))))
572         (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate))))
573         (args (list "-c"
574                     (format nil "cd ~a && /bin/sh ~a ~@[~a~]"
575                             (native-translated-namestring cdir)
576                             (native-translated-namestring populate)
577                             populate-arg))))
578    (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate)
579    (force-output t)
580    (multiple-value-bind (status exit-code)
581        (external-process-status
582         (run-program "/bin/sh" args :output t))
583      (if (and (eq status :exited)
584               (eql exit-code 0))
585        (let* ((f 'parse-standard-ffi-files))
586          (require "PARSE-FFI")
587          (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname)
588          (funcall f dirname target)
589          (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]")
590          (funcall f dirname target))))))
591
592(defun update-ccl (&key (verbose t))
593  (let* ((changed ())
594         (conflicts ()))
595    (with-output-to-string (out)
596      (with-preserved-working-directory ("ccl:")                     
597        (when verbose (format t "~&;Running 'svn update'."))
598        (multiple-value-bind (status exit-code)
599            (external-process-status
600             (run-program "svn" '("update") :output out :error t))
601          (when verbose (format t "~&;'svn update' complete."))
602          (if (not (and (eq status :exited)
603                        (eql exit-code 0)))
604            (error "Running \"svn update\" produced exit status ~s, code ~s." status exit-code)
605            (let* ((sout (get-output-stream-string out))
606                   (added ())
607                   (deleted ())
608                   (updated ())
609                   (merged ())
610                   (binaries (list (standard-kernel-name) (standard-image-name ))))
611              (flet ((svn-revert (string)
612                       (multiple-value-bind (status exit-code)
613                           (external-process-status (run-program "svn" `("revert" ,string)))
614                         (when (and (eq status :exited) (eql exit-code 0))
615                           (setq conflicts (delete string conflicts :test #'string=))
616                           (push string updated)))))
617                (with-input-from-string (in sout)
618                  (do* ((line (read-line in nil nil) (read-line in nil nil)))
619                       ((null line))
620                    (when (and (> (length line) 2)
621                               (eql #\space (schar line 1)))
622                      (let* ((path (string-trim " " (subseq line 2))))
623                        (case (schar line 0)
624                          (#\A (push path added))
625                          (#\D (push path deleted))
626                          (#\U (push path updated))
627                          (#\G (push path merged))
628                          (#\C (push path conflicts)))))))
629                ;; If the kernel and/or image conflict, use "svn revert"
630                ;; to replace the working copies with the (just updated)
631                ;; repository versions.
632                (setq changed (if (or added deleted updated merged conflicts) t))
633             
634                (dolist (f binaries)
635                  (when (member f conflicts :test #'string=)
636                    (svn-revert f)))
637                ;; If there are any remaining conflicts, offer
638                ;; to revert them.
639                (when conflicts
640                  (with-preserved-working-directory ()
641                    (cerror "Discard local changes to these files (using 'svn revert'."
642                            "'svn update' was unable to merge local changes to the following file~p with the updated versions:~{~&~s~~}" (length conflicts) conflicts)
643                    (dolist (c (copy-list conflicts))
644                      (svn-revert c))))
645                ;; Report other changes, if verbose.
646                (when (and verbose
647                           (or added deleted updated merged conflicts))
648                  (format t "~&;Changes from svn update:")
649                  (flet ((show-changes (herald files)
650                           (when files
651                             (format t "~&; ~a:~{~&;  ~a~}"
652                                     herald files))))
653                    (show-changes "Conflicting files" conflicts)
654                    (show-changes "New files/directories" added)
655                    (show-changes "Deleted files/directories" deleted)
656                    (show-changes "Updated files" updated)
657                    (show-changes "Files with local changes, successfully merged" merged)))))))))
658    (values changed conflicts)))
659
660(defmacro with-preserved-working-directory ((&optional dir) &body body)
661  (let ((wd (gensym)))
662    `(let ((,wd (mac-default-directory)))
663       (unwind-protect
664            (progn 
665              ,@(when dir `((cwd ,dir)))
666              ,@body)
667         (cwd ,wd)))))
668
669(defun ensure-tests-loaded (&key force update ansi ccl)
670  (unless (and (find-package "REGRESSION-TEST") (not force))
671    (if (probe-file "ccl:tests;ansi-tests;")
672      (when update
673        (cwd "ccl:tests;")
674        (run-program "svn" '("update")))
675      (let* ((svn (probe-file "ccl:.svn;entries"))
676             (repo (and svn (svn-repository)))
677             (s (make-string-output-stream)))
678        (when repo
679          (format t "~&Checking out test suite into ccl:tests;~%")
680          (cwd "ccl:")
681          (multiple-value-bind (status exit-code)
682              (external-process-status
683               (run-program "svn" (list "checkout" (format nil "~a/trunk/tests" repo) "tests")
684                            :output s
685                            :error s))
686            (unless (and (eq status :exited)
687                         (eql exit-code 0))
688              (error "Failed to check out test suite: ~%~a" (get-output-stream-string s)))))))
689    (cwd "ccl:tests;ansi-tests;")
690    (run-program "make" '("-k" "clean"))
691    (map nil 'delete-file (directory "*.*fsl"))
692    ;; Muffle the typecase "clause ignored" warnings, since there is really nothing we can do about
693    ;; it without making the test suite non-portable across platforms...
694    (handler-bind ((warning (lambda (c)
695                              (when (let ((w (or (and (typep c 'compiler-warning)
696                                                      (eq (compiler-warning-warning-type c) :program-error)
697                                                      (car (compiler-warning-args c)))
698                                                 c)))
699                                      (and (typep w 'simple-warning)
700                                           (or 
701                                            (string-equal
702                                             (simple-condition-format-control w)
703                                             "Clause ~S ignored in ~S form - shadowed by ~S .")
704                                            ;; Might as well ignore these as well, they're intentional.
705                                            (string-equal
706                                             (simple-condition-format-control w)
707                                             "Duplicate keyform ~s in ~s statement."))))
708                                (muffle-warning c)))))
709      ;; This loads the infrastructure
710      (load "ccl:tests;ansi-tests;gclload1.lsp")
711      ;; This loads the actual tests
712      (let ((redef-var (find-symbol "*WARN-IF-REDEFINE-TEST*" :REGRESSION-TEST)))
713        (progv (list redef-var) (list (if force nil (symbol-value redef-var)))
714          (when ansi
715            (load "ccl:tests;ansi-tests;gclload2.lsp"))
716          ;; And our own tests
717          (when ccl
718            (load "ccl:tests;ansi-tests;ccl.lsp")))))))
719
720(defun test-ccl (&key force (update t) verbose (catch-errors t) (ansi t) (ccl t)
721                      optimization-settings)
722  (with-preserved-working-directory ()
723    (let* ((*package* (find-package "CL-USER")))
724      (ensure-tests-loaded :force force :update update :ansi ansi :ccl ccl)
725      (cwd "ccl:tests;ansi-tests;")
726      (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST"))
727            (*print-catch-errors* nil))
728        (time (funcall do-tests :verbose verbose :compile t
729                       :catch-errors catch-errors
730                       :optimization-settings (or optimization-settings '((safety 2))))))
731      ;; Ok, here we would run any of our own tests.
732      )))
Note: See TracBrowser for help on using the repository browser.