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

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

New Japanese character encodings cp 932, eucjp from Yoshinori Tahara.
New x8632 large function support (from rme, mostly.)
The latter's a bit hard to bootstrap; new binaries, fasl/image versions
soon.

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