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

Last change on this file since 14030 was 14030, checked in by rme, 11 years ago

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