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

Last change on this file since 10485 was 10485, checked in by gb, 12 years ago

Account for the possibility that the default "make" program may not
understand -C.

Note the (possible) "peer" of the target platform, and watch
for conflicts related to the peer's kernel/image when doing
svn update.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.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;;; If we distribute (e.g.) 32- and 64-bit versions for the same
476;;; machine and OS in the same svn directory, return the name of the
477;;; peer backend, or NIL. For example., the peer of :linuxppc64 is
478;;; :linuxppc32.  Note that this may change over time.
479;;; Return NIL if the concept doesn't apply.
480(defun peer-platform (&optional (target (backend-name *host-backend*)))
481  (let* ((pairs '((:darwinppc32 . :darwinppc64)
482                  (:linuxppc32 . :linuxppc64)
483                  (:darwinx8632 . :darwinx8664))))
484    (or (cdr (assoc target pairs))
485        (car (rassoc target pairs)))))
486
487(defun make-program (&optional (target (backend-name *host-backend*)))
488  ;; The Solaris "make" program is too clever to understand -C, so
489  ;; use GNU make (installed as "gmake").
490  (case target
491    (:solarisx8664 "gmake")
492    (t "make")))
493
494(defparameter *known-optional-features* '(:count-gf-calls :monitor-futex-wait))
495(defvar *build-time-optional-features* nil)
496
497
498(defun rebuild-ccl (&key update full clean kernel force (reload t) exit reload-arguments verbose optional-features)
499  (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features))
500         (*features* (append *build-time-optional-features* *features*)))
501    (when *build-time-optional-features*
502      (setq full t))
503    (when full
504      (setq clean t kernel t reload t))
505    (when update (update-ccl :verbose (not (eq update :quiet))))
506    (let* ((cd (current-directory)))
507      (unwind-protect
508           (progn
509             (setf (current-directory) "ccl:")
510             (when clean
511               (dolist (f (directory
512                           (merge-pathnames
513                            (make-pathname :name :wild
514                                           :type (pathname-type *.fasl-pathname*))
515                            "ccl:**;")))
516                 (delete-file f)))
517             (when kernel
518               (when (or clean force)
519                 ;; Do a "make -k clean".
520                 (run-program "make"
521                              (list "-k"
522                                    "-C"
523                                    (format nil "lisp-kernel/~a"
524                                            (kernel-build-directory))
525                                    "clean")))
526               (format t "~&;Building lisp-kernel ...")
527               (with-output-to-string (s)
528                                      (multiple-value-bind
529                                          (status exit-code)
530                                          (external-process-status 
531                                           (run-program (make-program)
532                                                        (list "-k" "-C" 
533                                                              (format nil "lisp-kernel/~a"
534                                                                      (kernel-build-directory))
535                                                              "-j"
536                                                           
537                                                              (format nil "~d" (1+ (cpu-count))))
538                                                        :output s
539                                                        :error :output))
540                                        (if (and (eq :exited status) (zerop exit-code))
541                                          (progn
542                                            (format t "~&;Kernel built successfully.")
543                                            (when verbose
544                                              (format t "~&;kernel build output:~%~a"
545                                                      (get-output-stream-string s)))
546                                            (sleep 1))
547                                          (error "Error(s) during kernel compilation.~%~a"
548                                                 (get-output-stream-string s))))))
549             (compile-ccl (not (null force)))
550             (if force (xload-level-0 :force) (xload-level-0))
551             (when reload
552               (with-input-from-string (cmd (format nil
553                                                    "(save-application ~s)"
554                                                    (standard-image-name)))
555                 (with-output-to-string (output)
556                                        (multiple-value-bind (status exit-code)
557                                            (external-process-status
558                                             (run-program
559                                              (format nil "./~a" (standard-kernel-name))
560                                              (list* "--image-name" (standard-boot-image-name)
561                                                     reload-arguments)
562                                              :input cmd
563                                              :output output
564                                              :error output))
565                                          (if (and (eq status :exited)
566                                                   (eql exit-code 0))
567                                            (progn
568                                              (format t "~&;Wrote heap image: ~s"
569                                                      (truename (format nil "ccl:~a"
570                                                                        (standard-image-name))))
571                                              (when verbose
572                                                (format t "~&;Reload heap image output:~%~a"
573                                                        (get-output-stream-string output))))
574                                            (error "Errors (~s ~s) reloading boot image:~&~a"
575                                                   status exit-code
576                                                   (get-output-stream-string output)))))))
577             (when exit
578               (quit)))
579        (setf (current-directory) cd)))))
580                                                 
581               
582(defun create-interfaces (dirname &key target populate-arg)
583  (let* ((backend (if target (find-backend target) *target-backend*))
584         (*default-pathname-defaults* nil)
585         (ftd (backend-target-foreign-type-data backend))
586         (d (use-interface-dir dirname ftd))
587         (populate (merge-pathnames "C/populate.sh"
588                                    (merge-pathnames
589                                     (interface-dir-subdir d)
590                                     (ftd-interface-db-directory ftd))))
591         (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate))))
592         (args (list "-c"
593                     (format nil "cd ~a && /bin/sh ~a ~@[~a~]"
594                             (native-translated-namestring cdir)
595                             (native-translated-namestring populate)
596                             populate-arg))))
597    (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate)
598    (force-output t)
599    (multiple-value-bind (status exit-code)
600        (external-process-status
601         (run-program "/bin/sh" args :output t))
602      (if (and (eq status :exited)
603               (eql exit-code 0))
604        (let* ((f 'parse-standard-ffi-files))
605          (require "PARSE-FFI")
606          (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname)
607          (funcall f dirname target)
608          (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]")
609          (funcall f dirname target))))))
610
611(defun update-ccl (&key (verbose t))
612  (let* ((changed ())
613         (conflicts ()))
614    (with-output-to-string (out)
615      (with-preserved-working-directory ("ccl:")                     
616        (when verbose (format t "~&;Running 'svn update'."))
617        (multiple-value-bind (status exit-code)
618            (external-process-status
619             (run-program "svn" '("update") :output out :error t))
620          (when verbose (format t "~&;'svn update' complete."))
621          (if (not (and (eq status :exited)
622                        (eql exit-code 0)))
623            (error "Running \"svn update\" produced exit status ~s, code ~s." status exit-code)
624            (let* ((sout (get-output-stream-string out))
625                   (added ())
626                   (deleted ())
627                   (updated ())
628                   (merged ())
629                   (binaries (list (standard-kernel-name) (standard-image-name )))
630                   (peer (peer-platform)))
631              (when peer
632                (push (standard-kernel-name peer) binaries)
633                (push (standard-image-name peer) binaries))
634              (flet ((svn-revert (string)
635                       (multiple-value-bind (status exit-code)
636                           (external-process-status (run-program "svn" `("revert" ,string)))
637                         (when (and (eq status :exited) (eql exit-code 0))
638                           (setq conflicts (delete string conflicts :test #'string=))
639                           (push string updated)))))
640                (with-input-from-string (in sout)
641                  (do* ((line (read-line in nil nil) (read-line in nil nil)))
642                       ((null line))
643                    (when (and (> (length line) 2)
644                               (eql #\space (schar line 1)))
645                      (let* ((path (string-trim " " (subseq line 2))))
646                        (case (schar line 0)
647                          (#\A (push path added))
648                          (#\D (push path deleted))
649                          (#\U (push path updated))
650                          (#\G (push path merged))
651                          (#\C (push path conflicts)))))))
652                ;; If the kernel and/or image conflict, use "svn revert"
653                ;; to replace the working copies with the (just updated)
654                ;; repository versions.
655                (setq changed (if (or added deleted updated merged conflicts) t))
656             
657                (dolist (f binaries)
658                  (when (member f conflicts :test #'string=)
659                    (svn-revert f)))
660                ;; If there are any remaining conflicts, offer
661                ;; to revert them.
662                (when conflicts
663                  (with-preserved-working-directory ()
664                    (cerror "Discard local changes to these files (using 'svn revert'."
665                            "'svn update' was unable to merge local changes to the following file~p with the updated versions:~{~&~s~~}" (length conflicts) conflicts)
666                    (dolist (c (copy-list conflicts))
667                      (svn-revert c))))
668                ;; Report other changes, if verbose.
669                (when (and verbose
670                           (or added deleted updated merged conflicts))
671                  (format t "~&;Changes from svn update:")
672                  (flet ((show-changes (herald files)
673                           (when files
674                             (format t "~&; ~a:~{~&;  ~a~}"
675                                     herald files))))
676                    (show-changes "Conflicting files" conflicts)
677                    (show-changes "New files/directories" added)
678                    (show-changes "Deleted files/directories" deleted)
679                    (show-changes "Updated files" updated)
680                    (show-changes "Files with local changes, successfully merged" merged)))))))))
681    (values changed conflicts)))
682
683(defmacro with-preserved-working-directory ((&optional dir) &body body)
684  (let ((wd (gensym)))
685    `(let ((,wd (mac-default-directory)))
686       (unwind-protect
687            (progn 
688              ,@(when dir `((cwd ,dir)))
689              ,@body)
690         (cwd ,wd)))))
691
692(defun ensure-tests-loaded (&key force update ansi ccl)
693  (unless (and (find-package "REGRESSION-TEST") (not force))
694    (if (probe-file "ccl:tests;ansi-tests;")
695      (when update
696        (cwd "ccl:tests;")
697        (run-program "svn" '("update")))
698      (let* ((svn (probe-file "ccl:.svn;entries"))
699             (repo (and svn (svn-repository)))
700             (s (make-string-output-stream)))
701        (when repo
702          (format t "~&Checking out test suite into ccl:tests;~%")
703          (cwd "ccl:")
704          (multiple-value-bind (status exit-code)
705              (external-process-status
706               (run-program "svn" (list "checkout" (format nil "~a/trunk/tests" repo) "tests")
707                            :output s
708                            :error s))
709            (unless (and (eq status :exited)
710                         (eql exit-code 0))
711              (error "Failed to check out test suite: ~%~a" (get-output-stream-string s)))))))
712    (cwd "ccl:tests;ansi-tests;")
713    (run-program "make" '("-k" "clean"))
714    (map nil 'delete-file (directory "*.*fsl"))
715    ;; Muffle the typecase "clause ignored" warnings, since there is really nothing we can do about
716    ;; it without making the test suite non-portable across platforms...
717    (handler-bind ((warning (lambda (c)
718                              (when (let ((w (or (and (typep c 'compiler-warning)
719                                                      (eq (compiler-warning-warning-type c) :program-error)
720                                                      (car (compiler-warning-args c)))
721                                                 c)))
722                                      (and (typep w 'simple-warning)
723                                           (or 
724                                            (string-equal
725                                             (simple-condition-format-control w)
726                                             "Clause ~S ignored in ~S form - shadowed by ~S .")
727                                            ;; Might as well ignore these as well, they're intentional.
728                                            (string-equal
729                                             (simple-condition-format-control w)
730                                             "Duplicate keyform ~s in ~s statement."))))
731                                (muffle-warning c)))))
732      ;; This loads the infrastructure
733      (load "ccl:tests;ansi-tests;gclload1.lsp")
734      ;; This loads the actual tests
735      (let ((redef-var (find-symbol "*WARN-IF-REDEFINE-TEST*" :REGRESSION-TEST)))
736        (progv (list redef-var) (list (if force nil (symbol-value redef-var)))
737          (when ansi
738            (load "ccl:tests;ansi-tests;gclload2.lsp"))
739          ;; And our own tests
740          (when ccl
741            (load "ccl:tests;ansi-tests;ccl.lsp")))))))
742
743(defun test-ccl (&key force (update t) verbose (catch-errors t) (ansi t) (ccl t)
744                      optimization-settings)
745  (with-preserved-working-directory ()
746    (let* ((*package* (find-package "CL-USER")))
747      (ensure-tests-loaded :force force :update update :ansi ansi :ccl ccl)
748      (cwd "ccl:tests;ansi-tests;")
749      (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST"))
750            (*print-catch-errors* nil))
751        (time (funcall do-tests :verbose verbose :compile t
752                       :catch-errors catch-errors
753                       :optimization-settings (or optimization-settings '((safety 2))))))
754      ;; Ok, here we would run any of our own tests.
755      )))
Note: See TracBrowser for help on using the repository browser.