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

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

DESCRIBE-EXTERNAL-PROCESS-FAILURE: if an external process exits with
an error or (on Unix) exits with #$EX_OSERR, return a string which describes
the failure, embedded in some contextual description.

In REBUILD-CCL, use DESCRIBE-EXTERNAL-PROCESS-FAILURE to detect exec failure
and note that this may be because developer tools aren't installed.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 29.9 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(defparameter *sysdef-modules*
22  '(systems compile-ccl))
23
24(defparameter *level-1-modules*
25  '(level-1
26    l1-cl-package
27    l1-boot-1 l1-boot-2 l1-boot-3
28    l1-utils l1-init l1-symhash l1-numbers l1-aprims 
29    l1-sort l1-dcode l1-clos-boot l1-clos
30    l1-unicode l1-streams l1-files l1-io 
31    l1-format l1-readloop l1-reader
32    l1-sysio l1-pathnames l1-events
33    l1-boot-lds  l1-readloop-lds 
34    l1-lisp-threads  l1-application l1-processes
35    l1-typesys sysutils l1-error-system
36    l1-error-signal version l1-callbacks
37    l1-sockets linux-files
38    ))
39
40(defparameter *compiler-modules*
41  '(nx optimizers dll-node arch vreg vinsn 
42    reg subprims  backend nx2))
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             (:win64 'ffi-win64)
142             (:linuxx8632 'ffi-linuxx8632)
143             (:win32 'ffi-win32)
144             (:solarisx8632 'ffi-solarisx8632)
145             (:freebsdx8632 'ffi-freebsdx8632)))))
146
147
148(defun target-compiler-modules (&optional (target
149                                           (backend-target-arch-name
150                                            *host-backend*)))
151  (case target
152    (:ppc32 (append *ppc-compiler-modules*
153                    *ppc32-compiler-backend-modules*
154                    *ppc-compiler-backend-modules*))
155    (:ppc64 (append *ppc-compiler-modules*
156                    *ppc64-compiler-backend-modules*
157                    *ppc-compiler-backend-modules*))
158    (:x8632 (append *x86-compiler-modules*
159                    *x8632-compiler-backend-modules*
160                    *x86-compiler-backend-modules*))
161    (:x8664 (append *x86-compiler-modules*
162                    *x8664-compiler-backend-modules*
163                    *x86-compiler-backend-modules*))))
164
165(defparameter *other-lib-modules*
166  '(streams pathnames backtrace
167    apropos
168    numbers 
169    dumplisp   source-files))
170
171(defun target-other-lib-modules (&optional (target
172                                            (backend-target-arch-name
173                                             *host-backend*)))
174  (append *other-lib-modules*
175          (case target
176            ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble))
177            ((:x8632 :x8664) '(x86-backtrace x86-disassemble)))))
178         
179
180(defun target-lib-modules (&optional (backend-name
181                                      (backend-name *host-backend*)))
182  (let* ((backend (or (find-backend backend-name) *host-backend*))
183         (arch-name (backend-target-arch-name backend)))
184    (append (target-env-modules backend-name) (target-other-lib-modules arch-name))))
185
186
187(defparameter *code-modules*
188  '(encapsulate
189    read misc  arrays-fry
190    sequences sort 
191    method-combination
192    case-error pprint 
193    format time 
194;        eval step
195    backtrace-lds  ccl-export-syms prepare-mcl-environment))
196
197
198
199(defparameter *aux-modules*
200  '(number-macros number-case-macro
201    loop
202    runtime
203    mcl-compat
204    arglist
205    edit-callers
206    describe
207    leaks
208    asdf
209    defsystem
210    ))
211
212
213
214
215
216
217
218(defun target-level-1-modules (&optional (target (backend-name *host-backend*)))
219  (append *level-1-modules*
220          (case target
221            ((:linuxppc32 :darwinppc32 :linuxppc64 :darwinppc64)
222             '(ppc-error-signal ppc-trap-support
223               ppc-threads-utils ppc-callback-support))
224            ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664
225                          :darwinx8632 :win64  :linuxx8632 :win32 :solarisx8632
226                          :freebsdx8632)
227             '(x86-error-signal x86-trap-support
228               x86-threads-utils x86-callback-support)))))
229
230
231;;; Needed to cross-dump an image
232
233
234(unless (fboundp 'xload-level-0)
235  (%fhave 'xload-level-0
236          #'(lambda (&rest rest)
237              (in-development-mode
238               (require-modules (target-xload-modules)))
239              (apply 'xload-level-0 rest))))
240
241(defun find-module (module &optional (target (backend-name *host-backend*))  &aux data fasl sources)
242  (if (setq data (assoc module *ccl-system*))
243    (let* ((backend (or (find-backend target) *host-backend*)))
244      (setq fasl (cadr data) sources (caddr data))     
245      (setq fasl (merge-pathnames (backend-target-fasl-pathname
246                                   backend) fasl))
247      (values fasl (if (listp sources) sources (list sources))))
248    (error "Module ~S not defined" module)))
249
250;compile if needed.
251(defun target-compile-modules (modules target force-compile)
252  (if (not (listp modules)) (setq modules (list modules)))
253  (in-development-mode
254   (dolist (module modules t)
255     (multiple-value-bind (fasl sources) (find-module module target)
256      (if (needs-compile-p fasl sources force-compile)
257        (progn
258          (require'nfcomp)
259          (compile-file (car sources)
260                        :output-file fasl
261                        :verbose t
262                        :target target)))))))
263
264
265(defun needs-compile-p (fasl sources force-compile)
266  (if fasl
267    (if (eq force-compile t)
268      t
269      (if (not (probe-file fasl))
270        t
271        (let ((fasldate (file-write-date fasl)))
272          (if (if (integerp force-compile) (> force-compile fasldate))
273            t
274            (dolist (source sources nil)
275              (if (> (file-write-date source) fasldate)
276                (return t)))))))))
277
278
279
280;;;compile if needed, load if recompiled.
281
282(defun update-modules (modules &optional force-compile)
283  (if (not (listp modules)) (setq modules (list modules)))
284  (in-development-mode
285   (dolist (module modules t)
286     (multiple-value-bind (fasl sources) (find-module module)
287       (if (needs-compile-p fasl sources force-compile)
288         (progn
289           (require'nfcomp)
290           (let* ((*warn-if-redefine* nil))
291             (compile-file (car sources) :output-file fasl :verbose t :load t))
292           (provide module)))))))
293
294(defun compile-modules (modules &optional force-compile)
295  (target-compile-modules modules (backend-name *host-backend*) force-compile)
296)
297
298(defun compile-ccl (&optional force-compile)
299  (with-compilation-unit ()
300    (update-modules *sysdef-modules* force-compile)
301    (update-modules 'nxenv force-compile)
302    (update-modules *compiler-modules* force-compile)
303    (update-modules (target-compiler-modules) force-compile)
304    (update-modules (target-xdev-modules) force-compile)
305    (update-modules (target-xload-modules)  force-compile)
306    (let* ((env-modules (target-env-modules))
307           (other-lib (target-other-lib-modules)))
308      (require-modules env-modules)
309      (update-modules env-modules force-compile)
310      (compile-modules (target-level-1-modules)  force-compile)
311      (update-modules other-lib force-compile)
312      (require-modules other-lib)
313      (require-update-modules *code-modules* force-compile))
314    (compile-modules *aux-modules* force-compile)))
315
316
317
318;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
319
320(defun require-env (&optional force-load)
321  (require-modules  (target-env-modules)
322                   force-load))
323
324(defun compile-level-1 (&optional force-compile)
325  (require-env)
326  (compile-modules (target-level-1-modules (backend-name *host-backend*))
327                   force-compile))
328
329
330
331
332
333(defun compile-lib (&optional force-compile)
334  (compile-modules (target-lib-modules)
335                   force-compile))
336
337(defun compile-code (&optional force-compile)
338  (compile-modules *code-modules* force-compile))
339
340
341;Compile but don't load
342
343(defun xcompile-ccl (&optional force)
344  (with-compilation-unit ()
345    (compile-modules *sysdef-modules* force)
346    (compile-modules 'nxenv force)
347    (compile-modules *compiler-modules* force)
348    (compile-modules (target-compiler-modules) force)
349    (compile-modules (target-xdev-modules) force)
350    (compile-modules (target-xload-modules)  force)
351    (compile-modules (target-env-modules) force)
352    (compile-modules (target-level-1-modules) force)
353    (compile-modules (target-other-lib-modules) force)
354    (compile-modules *code-modules* force)
355    (compile-modules *aux-modules* force)))
356
357(defun require-update-modules (modules &optional force-compile)
358  (if (not (listp modules)) (setq modules (list modules)))
359  (in-development-mode
360    (dolist (module modules)
361    (require-modules module)
362    (update-modules module force-compile))))
363
364
365(defun target-xcompile-ccl (target &optional force)
366  (require-update-modules *sysdef-modules* force) ;in the host
367  (let* ((backend (or (find-backend target) *target-backend*))
368         (arch (backend-target-arch-name backend))
369         (*defstruct-share-accessor-functions* nil))
370    (target-compile-modules 'nxenv target force)
371    (target-compile-modules *compiler-modules* target force)
372    (target-compile-modules (target-compiler-modules arch) target force)
373    (target-compile-modules (target-level-1-modules target) target force)
374    (target-compile-modules (target-lib-modules target) target force)
375    (target-compile-modules *sysdef-modules* target force)
376    (target-compile-modules *aux-modules* target force)
377    (target-compile-modules *code-modules* target force)
378    (target-compile-modules (target-xdev-modules arch) target force)))
379
380(defun cross-compile-ccl (target &optional force)
381  (with-cross-compilation-target (target)
382    (let* ((*target-backend* (find-backend target)))
383      (target-xcompile-ccl target force))))
384
385
386(defun require-module (module force-load)
387  (multiple-value-bind (fasl source) (find-module module)
388      (setq source (car source))
389      (if (if fasl (probe-file fasl))
390        (if force-load
391          (progn
392            (load fasl)
393            (provide module))
394          (require module fasl))
395        (if (probe-file source)
396          (progn
397            (if fasl (format t "~&Can't find ~S so requiring ~S instead"
398                             fasl source))
399            (if force-load
400              (progn
401                (load source)
402                (provide module))
403              (require module source)))
404          (error "Can't find ~S or ~S" fasl source)))))
405
406(defun require-modules (modules &optional force-load)
407  (if (not (listp modules)) (setq modules (list modules)))
408  (let ((*package* (find-package :ccl)))
409    (dolist (m modules t)
410      (require-module m force-load))))
411
412
413(defun target-xcompile-level-1 (target &optional force)
414  (target-compile-modules (target-level-1-modules target) target force))
415
416(defun standard-boot-image-name (&optional (target (backend-name *host-backend*)))
417  (ecase target
418    (:darwinppc32 "ppc-boot.image")
419    (:linuxppc32 "ppc-boot")
420    (:darwinppc64 "ppc-boot64.image")
421    (:linuxppc64 "ppc-boot64")
422    (:darwinx8632 "x86-boot32.image")
423    (:linuxx8664 "x86-boot64")
424    (:freebsdx8664 "fx86-boot64")
425    (:darwinx8664 "x86-boot64.image")
426    (:solarisx8664 "sx86-boot64")
427    (:win64 "wx86-boot64.image")
428    (:linuxx8632 "x86-boot32")
429    (:win32 "wx86-boot32.image")
430    (:solarisx8632 "sx86-boot32")
431    (:freebsdx8632 "fx86-boot32")))
432
433(defun standard-kernel-name (&optional (target (backend-name *host-backend*)))
434  (ecase target
435    (:darwinppc32 "dppccl")
436    (:linuxppc32 "ppccl")
437    (:darwinppc64 "dppccl64")
438    (:darwinx8632 "dx86cl")
439    (:linuxppc64 "ppccl64")
440    (:linuxx8664 "lx86cl64")
441    (:freebsdx8664 "fx86cl64")
442    (:darwinx8664 "dx86cl64")
443    (:solarisx8664 "sx86cl64")
444    (:win64 "wx86cl64.exe")
445    (:linuxx8632 "lx86cl")
446    (:win32 "wx86cl.exe")
447    (:solarisx8632 "sx86cl")
448    (:freebsdx8632 "fx86cl")))
449
450(defun standard-image-name (&optional (target (backend-name *host-backend*)))
451  (concatenate 'string (pathname-name (standard-kernel-name target)) ".image"))
452
453(defun kernel-build-directory (&optional (target (backend-name *host-backend*)))
454  (ecase target
455    (:darwinppc32 "darwinppc")
456    (:linuxppc32 "linuxppc")
457    (:darwinppc64 "darwinppc64")
458    (:linuxppc64 "linuxppc64")
459    (:darwinx8632 "darwinx8632")
460    (:linuxx8664 "linuxx8664")
461    (:freebsdx8664 "freebsdx8664")
462    (:darwinx8664 "darwinx8664")
463    (:solarisx8664 "solarisx64")
464    (:win64 "win64")
465    (:linuxx8632 "linuxx8632")
466    (:win32 "win32")
467    (:solarisx8632 "solarisx86")
468    (:freebsdx8632 "freebsdx8632")))
469
470;;; If we distribute (e.g.) 32- and 64-bit versions for the same
471;;; machine and OS in the same svn directory, return the name of the
472;;; peer backend, or NIL. For example., the peer of :linuxppc64 is
473;;; :linuxppc32.  Note that this may change over time.
474;;; Return NIL if the concept doesn't apply.
475(defun peer-platform (&optional (target (backend-name *host-backend*)))
476  (let* ((pairs '((:darwinppc32 . :darwinppc64)
477                  (:linuxppc32 . :linuxppc64)
478                  (:darwinx8632 . :darwinx8664)
479                  (:linuxx8632 . :linuxx8664)
480                  (:win32 . :win64)
481                  (:solarisx8632 . :solarisx8664)
482                  (:freebsdx8632 . :freebsdx8664))))
483    (or (cdr (assoc target pairs))
484        (car (rassoc target pairs)))))
485
486(defun make-program (&optional (target (backend-name *host-backend*)))
487  ;; The Solaris "make" program is too clever to understand -C, so
488  ;; use GNU make (installed as "gmake").
489  (case target
490    ((:solarisx8664 :solarisx8632) "gmake")
491    (t "make")))
492
493
494(defun describe-external-process-failure (proc reminder)
495  "If it appears that the external-process PROC failed in some way,
496try to return a string that describes that failure.  If it seems
497to have succeeded or if we can't tell why it failed, return NIL.
498This is mostly intended to describe process-creation/fork/exec failures,
499not runtime errors reported by a successfully created process."
500  (multiple-value-bind (status exit-code)
501      (external-process-status proc)
502    (let* ((procname (car (external-process-args proc)))
503           (string
504            (case status
505              (:error
506               (%strerror exit-code))
507              #-windows-target
508              (:exited
509               (when(= exit-code #$EX_OSERR)
510                 "generic OS error in fork/exec")))))
511      (when string
512        (format nil "Error executing ~a: ~a~&~a" procname string reminder)))))
513
514(defparameter *known-optional-features* '(:count-gf-calls :monitor-futex-wait :unique-dcode))
515(defvar *build-time-optional-features* nil)
516
517
518(defun rebuild-ccl (&key update full clean kernel force (reload t) exit reload-arguments verbose optional-features)
519  (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features))
520         (*features* (append *build-time-optional-features* *features*)))
521    (when *build-time-optional-features*
522      (setq full t))
523    (when full
524      (setq clean t kernel t reload t))
525    (when update (update-ccl :verbose (not (eq update :quiet))))
526    (when (or clean force)
527      ;; for better bug reports...
528      (format t "~&Rebuilding ~a using ~a"
529              (lisp-implementation-type)
530              (lisp-implementation-version)))
531    (let* ((cd (current-directory)))
532      (unwind-protect
533           (progn
534             (setf (current-directory) "ccl:")
535             (when clean
536               (dolist (f (directory
537                           (merge-pathnames
538                            (make-pathname :name :wild
539                                           :type (pathname-type *.fasl-pathname*))
540                            "ccl:**;")))
541                 (delete-file f)))
542             (when kernel
543               (when (or clean force)
544                 ;; Do a "make -k clean".
545                 (run-program "make"
546                              (list "-k"
547                                    "-C"
548                                    (format nil "lisp-kernel/~a"
549                                            (kernel-build-directory))
550                                    "clean")))
551               (format t "~&;Building lisp-kernel ...")
552               (with-output-to-string (s)
553                 (let* ((proc (run-program (make-program)
554                                           (list "-k" "-C" 
555                                                 (format nil "lisp-kernel/~a"
556                                                         (kernel-build-directory))
557                                                 "-j"
558                                                           
559                                                 (format nil "~d" (1+ (cpu-count))))
560                                           :output s
561                                           :error :output)))
562                   (multiple-value-bind (status exit-code)
563                       (external-process-status proc)
564                     (if (and (eq :exited status) (zerop exit-code))
565                       (progn
566                         (format t "~&;Kernel built successfully.")
567                         (when verbose
568                           (format t "~&;kernel build output:~%~a"
569                                   (get-output-stream-string s)))
570                         (sleep 1))
571                       (error "Error(s) during kernel compilation.~%~a"
572                              (or
573                               (describe-external-process-failure
574                                proc
575                                "Developer tools may not be installed correctly.")
576                               (get-output-stream-string s))))))))
577             (compile-ccl (not (null force)))
578             (if force (xload-level-0 :force) (xload-level-0))
579             (when reload
580               (with-input-from-string (cmd (format nil
581                                              "(save-application ~s)"
582                                              (standard-image-name)))
583                 (with-output-to-string (output)
584                   (multiple-value-bind (status exit-code)
585                       (external-process-status
586                        (run-program
587                         (format nil "./~a" (standard-kernel-name))
588                         (list* "--image-name" (standard-boot-image-name)
589                                reload-arguments)
590                         :input cmd
591                         :output output
592                         :error output))
593                     (if (and (eq status :exited)
594                              (eql exit-code 0))
595                       (progn
596                         (format t "~&;Wrote heap image: ~s"
597                                 (truename (format nil "ccl:~a"
598                                                   (standard-image-name))))
599                         (when verbose
600                           (format t "~&;Reload heap image output:~%~a"
601                                   (get-output-stream-string output))))
602                       (error "Errors (~s ~s) reloading boot image:~&~a"
603                              status exit-code
604                              (get-output-stream-string output)))))))
605             (when exit
606               (quit)))
607        (setf (current-directory) cd)))))
608                                                 
609               
610(defun create-interfaces (dirname &key target populate-arg)
611  (let* ((backend (if target (find-backend target) *target-backend*))
612         (*default-pathname-defaults* nil)
613         (ftd (backend-target-foreign-type-data backend))
614         (d (use-interface-dir dirname ftd))
615         (populate (merge-pathnames "C/populate.sh"
616                                    (merge-pathnames
617                                     (interface-dir-subdir d)
618                                     (ftd-interface-db-directory ftd))))
619         (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate))))
620         (args (list "-c"
621                     (format nil "cd ~a && /bin/sh ~a ~@[~a~]"
622                             (native-translated-namestring cdir)
623                             (native-translated-namestring populate)
624                             populate-arg))))
625    (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate)
626    (force-output t)
627    (multiple-value-bind (status exit-code)
628        (external-process-status
629         (run-program "/bin/sh" args :output t))
630      (if (and (eq status :exited)
631               (eql exit-code 0))
632        (let* ((f 'parse-standard-ffi-files))
633          (require "PARSE-FFI")
634          (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname)
635          (funcall f dirname target)
636          (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]")
637          (funcall f dirname target))))))
638
639(defun update-ccl (&key (verbose t))
640  (let* ((changed ())
641         (conflicts ()))
642    (with-output-to-string (out)
643      (with-preserved-working-directory ("ccl:")                     
644        (when verbose (format t "~&;Running 'svn update'."))
645        (multiple-value-bind (status exit-code)
646            (external-process-status
647             (run-program "svn" '("update" "--non-interactive") :output out :error t))
648          (when verbose (format t "~&;'svn update' complete."))
649          (if (not (and (eq status :exited)
650                        (eql exit-code 0)))
651            (error "Running \"svn update\" produced exit status ~s, code ~s." status exit-code)
652            (let* ((sout (get-output-stream-string out))
653                   (added ())
654                   (deleted ())
655                   (updated ())
656                   (merged ())
657                   (binaries (list (standard-kernel-name) (standard-image-name )))
658                   (peer (peer-platform)))
659              (when peer
660                (push (standard-kernel-name peer) binaries)
661                (push (standard-image-name peer) binaries))
662              (flet ((svn-revert (string)
663                       (multiple-value-bind (status exit-code)
664                           (external-process-status (run-program "svn" `("revert" ,string)))
665                         (when (and (eq status :exited) (eql exit-code 0))
666                           (setq conflicts (delete string conflicts :test #'string=))
667                           (push string updated)))))
668                (with-input-from-string (in sout)
669                  (do* ((line (read-line in nil nil) (read-line in nil nil)))
670                       ((null line))
671                    (when (and (> (length line) 2)
672                               (eql #\space (schar line 1)))
673                      (let* ((path (string-trim " " (subseq line 2))))
674                        (case (schar line 0)
675                          (#\A (push path added))
676                          (#\D (push path deleted))
677                          (#\U (push path updated))
678                          (#\G (push path merged))
679                          (#\C (push path conflicts)))))))
680                ;; If the kernel and/or image conflict, use "svn revert"
681                ;; to replace the working copies with the (just updated)
682                ;; repository versions.
683                (setq changed (if (or added deleted updated merged conflicts) t))
684             
685                (dolist (f binaries)
686                  (when (member f conflicts :test #'string=)
687                    (svn-revert f)))
688                ;; If there are any remaining conflicts, offer
689                ;; to revert them.
690                (when conflicts
691                  (with-preserved-working-directory ()
692                    (cerror "Discard local changes to these files (using 'svn revert'."
693                            "'svn update' was unable to merge local changes to the following file~p with the updated versions:~{~&~s~~}" (length conflicts) conflicts)
694                    (dolist (c (copy-list conflicts))
695                      (svn-revert c))))
696                ;; Report other changes, if verbose.
697                (when (and verbose
698                           (or added deleted updated merged conflicts))
699                  (format t "~&;Changes from svn update:")
700                  (flet ((show-changes (herald files)
701                           (when files
702                             (format t "~&; ~a:~{~&;  ~a~}"
703                                     herald files))))
704                    (show-changes "Conflicting files" conflicts)
705                    (show-changes "New files/directories" added)
706                    (show-changes "Deleted files/directories" deleted)
707                    (show-changes "Updated files" updated)
708                    (show-changes "Files with local changes, successfully merged" merged)))))))))
709    (values changed conflicts)))
710
711(defmacro with-preserved-working-directory ((&optional dir) &body body)
712  (let ((wd (gensym)))
713    `(let ((,wd (mac-default-directory)))
714       (unwind-protect
715            (progn 
716              ,@(when dir `((cwd ,dir)))
717              ,@body)
718         (cwd ,wd)))))
719
720(defun ensure-tests-loaded (&key force update ansi ccl)
721  (unless (and (find-package "REGRESSION-TEST") (not force))
722    (if (probe-file "ccl:tests;ansi-tests;")
723      (when update
724        (cwd "ccl:tests;")
725        (run-program "svn" '("update")))
726      (let* ((svn (probe-file "ccl:.svn;entries"))
727             (repo (and svn (svn-repository)))
728             (s (make-string-output-stream)))
729        (when repo
730          (format t "~&Checking out test suite into ccl:tests;~%")
731          (cwd "ccl:")
732          (multiple-value-bind (status exit-code)
733              (external-process-status
734               (run-program "svn" (list "checkout" (format nil "~a/trunk/tests" repo) "tests")
735                            :output s
736                            :error s))
737            (unless (and (eq status :exited)
738                         (eql exit-code 0))
739              (error "Failed to check out test suite: ~%~a" (get-output-stream-string s)))))))
740    (cwd "ccl:tests;ansi-tests;")
741    (run-program "make" '("-k" "clean"))
742    (map nil 'delete-file (directory "*.*fsl"))
743    ;; Muffle the typecase "clause ignored" warnings, since there is really nothing we can do about
744    ;; it without making the test suite non-portable across platforms...
745    (handler-bind ((warning (lambda (c)
746                              (when (let ((w (or (and (typep c 'compiler-warning)
747                                                      (eq (compiler-warning-warning-type c) :program-error)
748                                                      (car (compiler-warning-args c)))
749                                                 c)))
750                                      (and (typep w 'simple-warning)
751                                           (or 
752                                            (string-equal
753                                             (simple-condition-format-control w)
754                                             "Clause ~S ignored in ~S form - shadowed by ~S .")
755                                            ;; Might as well ignore these as well, they're intentional.
756                                            (string-equal
757                                             (simple-condition-format-control w)
758                                             "Duplicate keyform ~s in ~s statement."))))
759                                (muffle-warning c)))))
760      ;; This loads the infrastructure
761      (load "ccl:tests;ansi-tests;gclload1.lsp")
762      ;; This loads the actual tests
763      (let ((redef-var (find-symbol "*WARN-IF-REDEFINE-TEST*" :REGRESSION-TEST)))
764        (progv (list redef-var) (list (if force nil (symbol-value redef-var)))
765          (when ansi
766            (load "ccl:tests;ansi-tests;gclload2.lsp"))
767          ;; And our own tests
768          (when ccl
769            (load "ccl:tests;ansi-tests;ccl.lsp")))))))
770
771(defun test-ccl (&key force (update t) verbose (catch-errors t) (ansi t) (ccl t)
772                      optimization-settings)
773  (with-preserved-working-directory ()
774    (let* ((*package* (find-package "CL-USER")))
775      (ensure-tests-loaded :force force :update update :ansi ansi :ccl ccl)
776      (cwd "ccl:tests;ansi-tests;")
777      (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST"))
778            (*print-catch-errors* nil))
779        (prog1
780            (time (funcall do-tests :verbose verbose :compile t
781                           :catch-errors catch-errors
782                           :optimization-settings (or optimization-settings '((safety 2)))))
783          ;; Clean up a little
784          (map nil #'delete-file
785               (directory (merge-pathnames *.fasl-pathname* "ccl:tests;ansi-tests;temp*"))))))))
Note: See TracBrowser for help on using the repository browser.