;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   Copyright (C) 2009 Clozure Associates
;;;   Copyright (C) 1994-2001 Digitool, Inc
;;;   This file is part of Clozure CL.  
;;;
;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with Clozure CL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html

(in-package "CCL")

(require 'systems)

(defparameter *sysdef-modules*
  '(systems compile-ccl))

(defparameter *level-1-modules*
  '(level-1
    l1-cl-package
    l1-boot-1 l1-boot-2 l1-boot-3
    l1-utils l1-init l1-symhash l1-numbers l1-aprims 
    l1-sort l1-dcode l1-clos-boot l1-clos
    l1-unicode l1-streams l1-files l1-io 
    l1-format l1-readloop l1-reader
    l1-sysio l1-pathnames l1-events
    l1-boot-lds  l1-readloop-lds 
    l1-lisp-threads  l1-application l1-processes
    l1-typesys sysutils l1-error-system
    l1-error-signal version l1-callbacks
    l1-sockets linux-files
    ))

(defparameter *compiler-modules*
  '(nx optimizers dll-node arch vreg vinsn 
    reg subprims  backend nx2 acode-rewrite))


(defparameter *ppc-compiler-modules*
  '(ppc32-arch
    ppc64-arch
    ppc-arch
    ppcenv
    ppc-asm
    risc-lap
    ppc-lap
    ppc-backend
))

(defparameter *x86-compiler-modules*
  '(x8632-arch
    x8664-arch
    x86-arch
    x8632env
    x8664env
    x86-asm
    x86-lap
    x86-backend
))

(defparameter *arm-compiler-modules*
  '(arm-arch
    armenv
    arm-asm
    arm-lap
))

(defparameter *ppc32-compiler-backend-modules*
  '(ppc32-backend ppc32-vinsns))

(defparameter *ppc64-compiler-backend-modules*
  '(ppc64-backend ppc64-vinsns))


(defparameter *ppc-compiler-backend-modules*
  '(ppc2))


(defparameter *x8632-compiler-backend-modules*
  '(x8632-backend x8632-vinsns))

(defparameter *x8664-compiler-backend-modules*
  '(x8664-backend x8664-vinsns))

(defparameter *x86-compiler-backend-modules*
  '(x862))

(defparameter *arm-compiler-backend-modules*
  '(arm-backend arm-vinsns arm2))




(defparameter *ppc-xload-modules* '(xppcfasload xfasload heap-image ))
(defparameter *x8632-xload-modules* '(xx8632fasload xfasload heap-image ))
(defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image ))
(defparameter *arm-xload-modules* '(xarmfasload xfasload heap-image ))


;;; Not too OS-specific.
(defparameter *ppc-xdev-modules* '(ppc-lapmacros ))
(defparameter *x86-xdev-modules* '(x86-lapmacros ))
(defparameter *arm-xdev-modules* '(arm-lapmacros ))

(defmacro with-global-optimization-settings ((&key speed
                                                   space
                                                   safety
                                                   debug
                                                   compilation-speed)
                                             &body body
                                             &environment env)
  (flet ((check-quantity (val default)
           (if val
             (require-type val '(mod 4))
             default)))
    (multiple-value-bind (body decls) (parse-body body env)
      `(let* ((*nx-speed* ,(check-quantity speed '*nx-speed*))
              (*nx-space* ,(check-quantity space '*nx-space*))
              (*nx-safety* ,(check-quantity safety '*nx-safety*))
              (*nx-debug* ,(check-quantity debug '*nx-debug*))
              (*nx-cspeed* ,(check-quantity compilation-speed '*nx-cspeed*)))
        ,@decls
        ,@body))))
  
(defun target-xdev-modules (&optional (target
				       (backend-target-arch-name
					*host-backend*)))
  (case target
    ((:ppc32 :ppc64) *ppc-xdev-modules*)
    ((:x8632 :x8664) *x86-xdev-modules*)
    (:arm *arm-xdev-modules*)))

(defun target-xload-modules (&optional (target
					(backend-target-arch-name *host-backend*)))
  (case target
    ((:ppc32 :ppc64) *ppc-xload-modules*)
    (:x8632 *x8632-xload-modules*)
    (:x8664 *x8664-xload-modules*)
    (:arm *arm-xload-modules*)))






(defparameter *env-modules*
  '(hash backquote lispequ  level-2 macros
    defstruct-macros lists chars setf setf-runtime
    defstruct defstruct-lds 
    foreign-types
    db-io
    nfcomp
    ))

(defun target-env-modules (&optional (target
				      (backend-name *host-backend*)))
  (append *env-modules*
          (list
           (ecase target
             (:linuxppc32 'ffi-linuxppc32)
             (:darwinppc32 'ffi-darwinppc32)
             (:darwinppc64 'ffi-darwinppc64)
             (:linuxppc64 'ffi-linuxppc64)
	     (:darwinx8632 'ffi-darwinx8632)
             (:linuxx8664 'ffi-linuxx8664)
             (:darwinx8664 'ffi-darwinx8664)
             (:freebsdx8664 'ffi-freebsdx8664)
             (:solarisx8664 'ffi-solarisx8664)
             (:win64 'ffi-win64)
             (:linuxx8632 'ffi-linuxx8632)
             (:win32 'ffi-win32)
             (:solarisx8632 'ffi-solarisx8632)
             (:freebsdx8632 'ffi-freebsdx8632)
             (:linuxarm 'ffi-linuxarm)
             (:androidarm 'ffi-androidarm)
             (:darwinarm 'ffi-darwinarm)))))


(defun target-compiler-modules (&optional (target
					   (backend-target-arch-name
					    *host-backend*)))
  (case target
    (:ppc32 (append *ppc-compiler-modules*
                    *ppc32-compiler-backend-modules*
                    *ppc-compiler-backend-modules*))
    (:ppc64 (append *ppc-compiler-modules*
                    *ppc64-compiler-backend-modules*
                    *ppc-compiler-backend-modules*))
    (:x8632 (append *x86-compiler-modules*
                    *x8632-compiler-backend-modules*
                    *x86-compiler-backend-modules*))
    (:x8664 (append *x86-compiler-modules*
                    *x8664-compiler-backend-modules*
                    *x86-compiler-backend-modules*))
    (:arm (append *arm-compiler-modules*
                  *arm-compiler-backend-modules*))))

(defparameter *other-lib-modules*
  '(streams pathnames backtrace
    apropos
    numbers 
    dumplisp
    source-files
    swink))

(defun target-other-lib-modules (&optional (target
					    (backend-target-arch-name
					     *host-backend*)))
  (append *other-lib-modules*
	  (case target
	    ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble))
            ((:x8632 :x8664) '(x86-backtrace x86-disassemble x86-watch))
            (:arm '(arm-backtrace arm-disassemble)))))
	  

(defun target-lib-modules (&optional (backend-name
                                      (backend-name *host-backend*)))
  (let* ((backend (or (find-backend backend-name) *host-backend*))
         (arch-name (backend-target-arch-name backend)))
    (append (target-env-modules backend-name) (target-other-lib-modules arch-name))))


(defparameter *code-modules*
  '(encapsulate
    read misc  arrays-fry
    sequences sort 
    method-combination
    case-error pprint 
    format time 
;        eval step
    backtrace-lds  ccl-export-syms prepare-mcl-environment))



(defparameter *aux-modules*
  '(number-macros number-case-macro
    loop
    runtime
    mcl-compat
    arglist
    edit-callers
    describe
    cover
    leaks
    core-files
    dominance
    swank-loader
    remote-lisp
    ;; asdf has peculiar compile-time side-effects
    ;;asdf
    defsystem
    jp-encode
    cn-encode
    ))







(defun target-level-1-modules (&optional (target (backend-name *host-backend*)))
  (append *level-1-modules*
	  (case target
	    ((:linuxppc32 :darwinppc32 :linuxppc64 :darwinppc64)
	     '(ppc-error-signal ppc-trap-support
	       ppc-threads-utils ppc-callback-support))            
            ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664
                          :darwinx8632 :win64  :linuxx8632 :win32 :solarisx8632
                          :freebsdx8632)
             '(x86-error-signal x86-trap-support
               x86-threads-utils x86-callback-support))
            ((:linuxarm :darwinarm :androidarm)
             '(arm-error-signal arm-trap-support
               arm-threads-utils arm-callback-support)))))


;;; Needed to cross-dump an image


(unless (fboundp 'xload-level-0)
  (%fhave 'xload-level-0
          #'(lambda (&rest rest)
	      (in-development-mode
	       (require-modules (target-xload-modules)))
              (apply 'xload-level-0 rest))))

(defun find-module (module &optional (target (backend-name *host-backend*))  &aux data fasl sources)
  (if (setq data (assoc module *ccl-system*))
    (let* ((backend (or (find-backend target) *host-backend*)))
      (setq fasl (cadr data) sources (caddr data))      
      (setq fasl (merge-pathnames (backend-target-fasl-pathname
				   backend) fasl))
      (values fasl (if (listp sources) sources (list sources))))
    (error "Module ~S not defined" module)))

;compile if needed.
(defun target-compile-modules (modules target force-compile)
  (if (not (listp modules)) (setq modules (list modules)))
  (in-development-mode
   (dolist (module modules t)
     (multiple-value-bind (fasl sources) (find-module module target)
      (if (needs-compile-p fasl sources force-compile)
        (progn
          (require'nfcomp)
          (compile-file (car sources)
			:output-file fasl
			:verbose t
			:target target)))))))


(defun needs-compile-p (fasl sources force-compile)
  (if fasl
    (if (eq force-compile t)
      t
      (if (not (probe-file fasl))
        t
        (let ((fasldate (file-write-date fasl)))
          (if (if (integerp force-compile) (> force-compile fasldate))
            t
            (dolist (source sources nil)
              (if (> (file-write-date source) fasldate)
                (return t)))))))))



;;;compile if needed, load if recompiled.

(defun update-modules (modules &optional force-compile)
  (if (not (listp modules)) (setq modules (list modules)))
  (in-development-mode
   (dolist (module modules t)
     (multiple-value-bind (fasl sources) (find-module module)
       (if (needs-compile-p fasl sources force-compile)
	 (progn
	   (require'nfcomp)
	   (let* ((*warn-if-redefine* nil))
	     (compile-file (car sources) :output-file fasl :verbose t :load t))
	   (provide module)))))))

(defun compile-modules (modules &optional force-compile)
  (target-compile-modules modules (backend-name *host-backend*) force-compile)
)



(defun compile-ccl (&optional force-compile)
  (with-compilation-unit ()
    (update-modules *sysdef-modules* force-compile)
    (update-modules 'nxenv force-compile)
    (update-modules *compiler-modules* force-compile)
    (update-modules (target-compiler-modules) force-compile)
    (update-modules (target-xdev-modules) force-compile)
    (update-modules (target-xload-modules)  force-compile)
    (let* ((env-modules (target-env-modules))
           (other-lib (target-other-lib-modules)))
      (require-modules env-modules)
      (update-modules env-modules force-compile)
      (compile-modules (target-level-1-modules)  force-compile)
      (update-modules other-lib force-compile)
      (require-modules other-lib)
      (require-update-modules *code-modules* force-compile))
    (compile-modules *aux-modules* force-compile)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun require-env (&optional force-load)
  (require-modules  (target-env-modules)
                   force-load))

(defun compile-level-1 (&optional force-compile)
  (require-env)
  (compile-modules (target-level-1-modules (backend-name *host-backend*))
                   force-compile))





(defun compile-lib (&optional force-compile)
  (compile-modules (target-lib-modules)
                   force-compile))

(defun compile-code (&optional force-compile)
  (compile-modules *code-modules* force-compile))


;Compile but don't load

(defun xcompile-ccl (&optional force)
  (with-compilation-unit ()
    (compile-modules *sysdef-modules* force)
    (compile-modules 'nxenv force)
    (compile-modules *compiler-modules* force)
    (compile-modules (target-compiler-modules) force)
    (compile-modules (target-xdev-modules) force)
    (compile-modules (target-xload-modules)  force)
    (compile-modules (target-env-modules) force)
    (compile-modules (target-level-1-modules) force)
    (compile-modules (target-other-lib-modules) force)
    (compile-modules *code-modules* force)
    (compile-modules *aux-modules* force)))

(defun require-update-modules (modules &optional force-compile)
  (if (not (listp modules)) (setq modules (list modules)))
  (in-development-mode
    (dolist (module modules)
    (require-modules module)
    (update-modules module force-compile))))


(defun target-xcompile-ccl (target &optional force)
  (let* ((*target-backend* *host-backend*))
    (require-update-modules *sysdef-modules* force)) ;in the host
  (let* ((backend (or (find-backend target) *target-backend*))
	 (arch (backend-target-arch-name backend)))
    (target-compile-modules 'nxenv target force)
    (target-compile-modules *compiler-modules* target force)
    (target-compile-modules (target-compiler-modules arch) target force)
    (target-compile-modules (target-level-1-modules target) target force)
    (target-compile-modules (target-lib-modules target) target force)
    (target-compile-modules *sysdef-modules* target force)
    (target-compile-modules *aux-modules* target force)
    (target-compile-modules *code-modules* target force)
    (target-compile-modules (target-xdev-modules arch) target force)))

(defun cross-compile-ccl (target &optional force)
  (with-cross-compilation-target (target)
    (let* ((*target-backend* (find-backend target)))
      (target-xcompile-ccl target force))))


(defun require-module (module force-load)
  (multiple-value-bind (fasl source) (find-module module)
      (setq source (car source))
      (if (if fasl (probe-file fasl))
        (if force-load
          (progn
            (load fasl)
            (provide module))
          (require module fasl))
        (if (probe-file source)
          (progn
            (if fasl (format t "~&Can't find ~S so requiring ~S instead"
                             fasl source))
            (if force-load
              (progn
                (load source)
                (provide module))
              (require module source)))
          (error "Can't find ~S or ~S" fasl source)))))

(defun require-modules (modules &optional force-load)
  (if (not (listp modules)) (setq modules (list modules)))
  (let ((*package* (find-package :ccl)))
    (dolist (m modules t)
      (require-module m force-load))))


(defun target-xcompile-level-1 (target &optional force)
  (target-compile-modules (target-level-1-modules target) target force))

(defun standard-boot-image-name (&optional (target (backend-name *host-backend*)))
  (ecase target
    (:darwinppc32 "ppc-boot.image")
    (:linuxppc32 "ppc-boot")
    (:darwinppc64 "ppc-boot64.image")
    (:linuxppc64 "ppc-boot64")
    (:darwinx8632 "x86-boot32.image")
    (:linuxx8664 "x86-boot64")
    (:freebsdx8664 "fx86-boot64")
    (:darwinx8664 "x86-boot64.image")
    (:solarisx8664 "sx86-boot64")
    (:win64 "wx86-boot64.image")
    (:linuxx8632 "x86-boot32")
    (:win32 "wx86-boot32.image")
    (:solarisx8632 "sx86-boot32")
    (:freebsdx8632 "fx86-boot32")
    (:linuxarm "arm-boot")
    (:androidarm "aarm-boot")))

(defun standard-kernel-name (&optional (target (backend-name *host-backend*)))
  (ecase target
    (:darwinppc32 "dppccl")
    (:linuxppc32 "ppccl")
    (:darwinppc64 "dppccl64")
    (:darwinx8632 "dx86cl")
    (:linuxppc64 "ppccl64")
    (:linuxx8664 "lx86cl64")
    (:freebsdx8664 "fx86cl64")
    (:darwinx8664 "dx86cl64")
    (:solarisx8664 "sx86cl64")
    (:win64 "wx86cl64.exe")
    (:linuxx8632 "lx86cl")
    (:win32 "wx86cl.exe")
    (:solarisx8632 "sx86cl")
    (:freebsdx8632 "fx86cl")
    (:linuxarm "armcl")
    (:darwinarm "darmcl")
    (:androidarm "aarmcl")))

(defun standard-image-name (&optional (target (backend-name *host-backend*)))
  (concatenate 'string (pathname-name (standard-kernel-name target)) ".image"))

(defun kernel-build-directory (&optional (target (backend-name *host-backend*)))
  (ecase target
    (:darwinppc32 "darwinppc")
    (:linuxppc32 "linuxppc")
    (:darwinppc64 "darwinppc64")
    (:linuxppc64 "linuxppc64")
    (:darwinx8632 "darwinx8632")
    (:linuxx8664 "linuxx8664")
    (:freebsdx8664 "freebsdx8664")
    (:darwinx8664 "darwinx8664")
    (:solarisx8664 "solarisx64")
    (:win64 "win64")
    (:linuxx8632 "linuxx8632")
    (:win32 "win32")
    (:solarisx8632 "solarisx86")
    (:freebsdx8632 "freebsdx8632")
    (:linuxarm "linuxarm")
    (:darwinarm "darwinarm")
    (:androidarm "androidarm")))

;;; If we distribute (e.g.) 32- and 64-bit versions for the same
;;; machine and OS in the same svn directory, return the name of the
;;; peer backend, or NIL. For example., the peer of :linuxppc64 is
;;; :linuxppc32.  Note that this may change over time.
;;; Return NIL if the concept doesn't apply.
(defun peer-platform (&optional (target (backend-name *host-backend*)))
  (let* ((pairs '((:darwinppc32 . :darwinppc64)
                  (:linuxppc32 . :linuxppc64)
                  (:darwinx8632 . :darwinx8664)
                  (:linuxx8632 . :linuxx8664)
                  (:win32 . :win64)
                  (:solarisx8632 . :solarisx8664)
                  (:freebsdx8632 . :freebsdx8664))))
    (or (cdr (assoc target pairs))
        (car (rassoc target pairs)))))

(defun make-program (&optional (target (backend-name *host-backend*)))
  ;; The Solaris "make" program is too clever to understand -C, so
  ;; use GNU make (installed as "gmake").
  (case target
    ((:solarisx8664 :solarisx8632) "gmake")
    (t "make")))


(defun describe-external-process-failure (proc reminder)
  "If it appears that the external-process PROC failed in some way,
try to return a string that describes that failure.  If it seems
to have succeeded or if we can't tell why it failed, return NIL.
This is mostly intended to describe process-creation/fork/exec failures,
not runtime errors reported by a successfully created process."
  (multiple-value-bind (status exit-code)
      (external-process-status proc)
    (let* ((procname (car (external-process-args proc)))
           (string
            (case status
              (:error
               (%strerror exit-code))
              #-windows-target
              (:exited
               (when(= exit-code #-android-target #$EX_OSERR #+android-target 71)
                 "generic OS error in fork/exec")))))
      (when string
        (format nil "Error executing ~a: ~a~&~a" procname string reminder)))))

(defparameter *known-optional-features* '(:count-gf-calls :monitor-futex-wait :unique-dcode :qres-ccl :eq-hash-monitor))
(defvar *build-time-optional-features* nil)
(defvar *ccl-save-source-locations* :no-text)

(defun rebuild-ccl (&key update full clean kernel force (reload t) exit
                         reload-arguments verbose optional-features
                         (save-source-locations *ccl-save-source-locations*)
                         (allow-constant-redefinition nil allow-constant-redefinition-p))
  (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features))
         (*features* (append *build-time-optional-features* *features*))
	 (*save-source-locations* save-source-locations))
    (when *build-time-optional-features*
      (setq full t))
    (when full
      (setq clean t kernel t reload t))
    (when update
      (multiple-value-bind (changed conflicts new-binaries)
	  (update-ccl :verbose (not (eq update :quiet)))
	(declare (ignore changed conflicts))
	(when new-binaries
	  (format t "~&There are new bootstrapping binaries.  Please restart
the lisp and run REBUILD-CCL again.")
	  (return-from rebuild-ccl nil))))
    (when (or clean force)
      ;; for better bug reports...
      (format t "~&Rebuilding ~a using ~a"
              (lisp-implementation-type)
              (lisp-implementation-version))
      (unless allow-constant-redefinition-p
        (when (or force clean update)
          (setq allow-constant-redefinition t))))
    (let* ((cd (current-directory))
           (*cerror-on-constant-redefinition* (not allow-constant-redefinition ))
	   (*warn-if-redefine-kernel* nil))
      (unwind-protect
           (progn
             (setf (current-directory) "ccl:")
             (when clean
               (dolist (f (directory
                           (merge-pathnames
                            (make-pathname :name :wild
                                           :type (pathname-type *.fasl-pathname*))
                            "ccl:**;")))
                 (delete-file f)))
             (with-global-optimization-settings ()
               (compile-ccl (not (null force)))
               (if force (xload-level-0 :force) (xload-level-0)))
             (when kernel
               (when (or clean force)
                 ;; Do a "make -k clean".
                 (run-program "make"
                              (list "-k"
                                    "-C"
                                    (format nil "lisp-kernel/~a"
                                            (kernel-build-directory))
                                    "clean")))
               (format t "~&;Building lisp-kernel ...")
               (with-output-to-string (s)
                 (let* ((proc (run-program (make-program)
                                           (list "-k" "-C" 
                                                 (format nil "lisp-kernel/~a"
                                                         (kernel-build-directory))
                                                 "-j"
                                                            
                                                 (format nil "~d" (1+ (cpu-count))))
                                           :output s
                                           :error :output)))
                   (multiple-value-bind (status exit-code)
                       (external-process-status proc)
                     (if (and (eq :exited status) (zerop exit-code))
                       (progn
                         (format t "~&;Kernel built successfully.")
                         (when verbose
                           (format t "~&;kernel build output:~%~a"
                                   (get-output-stream-string s)))
                         (sleep 1))
                       (error "Error(s) during kernel compilation.~%~a"
                              (or
                               (describe-external-process-failure
                                proc
                                "Developer tools may not be installed correctly.")
                               (get-output-stream-string s))))))))
             (when reload
               (with-input-from-string (cmd (format nil
                                              "(save-application ~s)"
                                              (standard-image-name)))
                 (with-output-to-string (output)
                   (multiple-value-bind (status exit-code)
                       (external-process-status
                        (run-program
                         (format nil "./~a" (standard-kernel-name))
                         (list* "--image-name" (standard-boot-image-name)
                                "--batch"
                                reload-arguments)
                         :input cmd
                         :output output
                         :error output))
                     (if (and (eq status :exited)
                              (eql exit-code 0))
                       (progn
                         (format t "~&;Wrote heap image: ~s"
                                 (truename (format nil "ccl:~a"
                                                   (standard-image-name))))
                         (when verbose
                           (format t "~&;Reload heap image output:~%~a"
                                   (get-output-stream-string output))))
                       (error "Errors (~s ~s) reloading boot image:~&~a"
                              status exit-code
                              (get-output-stream-string output)))))))
             (when exit
               (quit)))
        (setf (current-directory) cd)))))
                                                  
               
(defun create-interfaces (dirname &key target populate-arg)
  (let* ((backend (if target (find-backend target) *target-backend*))
         (*default-pathname-defaults* nil)
         (ftd (backend-target-foreign-type-data backend))
         (d (use-interface-dir dirname ftd))
         (populate (merge-pathnames "C/populate.sh"
                                    (merge-pathnames
                                     (interface-dir-subdir d)
                                     (ftd-interface-db-directory ftd))))
         (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate))))
         (args (list "-c"
                     (format nil "cd ~a && /bin/sh ~a ~@[~a~]"
                             (native-translated-namestring cdir)
                             (native-translated-namestring populate)
                             populate-arg))))
    (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate)
    (force-output t)
    (multiple-value-bind (status exit-code)
        (external-process-status
         (run-program "/bin/sh" args :output t))
      (if (and (eq status :exited)
               (eql exit-code 0))
        (let* ((f 'parse-standard-ffi-files))
          (require "PARSE-FFI")
          (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname)
          (funcall f dirname target)
          (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]")
          (funcall f dirname target))))))

(defun update-ccl (&key (verbose t))
  (let* ((changed ())
	 (new-binaries ())
         (conflicts ()))
    (with-output-to-string (out)
      (with-preserved-working-directory ("ccl:")                     
        (when verbose (format t "~&;Running 'svn update'."))
        (multiple-value-bind (status exit-code)
            (external-process-status
             (run-program *svn-program* '("update" "--non-interactive") :output out :error t))
          (when verbose (format t "~&;'svn update' complete."))
          (if (not (and (eq status :exited)
                        (eql exit-code 0)))
            (error "Running \"svn update\" produced exit status ~s, code ~s." status exit-code)
            (let* ((sout (get-output-stream-string out))
                   (added ())
                   (deleted ())
                   (updated ())
                   (merged ())
                   (binaries (list (standard-kernel-name) (standard-image-name )))
                   (peer (peer-platform)))
              (when peer
                (push (standard-kernel-name peer) binaries)
                (push (standard-image-name peer) binaries))
              (flet ((svn-revert (string)
                       (multiple-value-bind (status exit-code)
                           (external-process-status (run-program *svn-program* `("revert" ,string)))
                         (when (and (eq status :exited) (eql exit-code 0))
                           (setq conflicts (delete string conflicts :test #'string=))
                           (push string updated)))))
                (with-input-from-string (in sout)
                  (do* ((line (read-line in nil nil) (read-line in nil nil)))
                       ((null line))
                    (when (and (> (length line) 2)
                               (eql #\space (schar line 1)))
                      (let* ((path (string-trim " " (subseq line 2))))
                        (case (schar line 0)
                          (#\A (push path added))
                          (#\D (push path deleted))
                          (#\U (push path updated))
                          (#\G (push path merged))
                          (#\C (push path conflicts)))))))
                ;; If the kernel and/or image conflict, use "svn revert"
                ;; to replace the working copies with the (just updated)
                ;; repository versions.
                (setq changed (if (or added deleted updated merged conflicts) t))
                (dolist (f binaries)
		  (cond ((member f conflicts :test #'string=)
			 (svn-revert f)
			 (setq new-binaries t))
			((or (member f updated :test #'string=)
			     (member f merged :test #'string=))
			 (setq new-binaries t))))

                ;; If there are any remaining conflicts, offer
                ;; to revert them.
                (when conflicts
                  (with-preserved-working-directory ()
                    (cerror "Discard local changes to these files (using 'svn revert')."
                            "'svn update' was unable to merge local changes to the following file~p with the updated versions:~{~&~s~}" (length conflicts) conflicts)
                    (dolist (c (copy-list conflicts))
                      (svn-revert c))))
                ;; Report other changes, if verbose.
                (when (and verbose
                           (or added deleted updated merged conflicts))
                  (format t "~&;Changes from svn update:")
                  (flet ((show-changes (herald files)
                           (when files
                             (format t "~&; ~a:~{~&;  ~a~}"
                                     herald files))))
                    (show-changes "Conflicting files" conflicts)
                    (show-changes "New files/directories" added)
                    (show-changes "Deleted files/directories" deleted)
                    (show-changes "Updated files" updated)
                    (show-changes "Files with local changes, successfully merged" merged)))))))))
    (values changed conflicts new-binaries)))

(defmacro with-preserved-working-directory ((&optional dir) &body body)
  (let ((wd (gensym)))
    `(let ((,wd (mac-default-directory)))
       (unwind-protect
	    (progn 
	      ,@(when dir `((cwd ,dir)))
	      ,@body)
	 (cwd ,wd)))))

(defun ensure-tests-loaded (&key force update ansi ccl (load t))
  (unless (and (find-package "REGRESSION-TEST") (not force))
    (if (probe-file "ccl:tests;ansi-tests;")
      (when update
	(cwd "ccl:tests;")
	(run-program *svn-program* '("update") :output t))
      (let* ((repo (svn-repository))
	     (url (format nil "~a/trunk/tests" repo))
	     (s (make-string-output-stream)))
	(if (null repo)
	  (error "Can't determine svn repository.  ccl directory is ~s"
		 (ccl-directory))
	  (progn
	    (format t "~&Using ~a to check out test suite from ~a ~
                       into ccl:tests;~%" *svn-program* url)
	    (cwd "ccl:")
	    (multiple-value-bind (status exit-code)
                (external-process-status
                 (run-program *svn-program* (list "checkout" url "tests")
                              :output s :error s))
	      (unless (and (eq status :exited)
			   (eql exit-code 0))
		(error "Failed to check out test suite: ~%~a"
		       (get-output-stream-string s))))))))
    (cwd "ccl:tests;ansi-tests;")
    (run-program "make" '("-k" "clean") :output t)
    (map nil 'delete-file (directory "*.*fsl"))
    (when load
      ;; Muffle the typecase "clause ignored" warnings, since there is really nothing we can do about
      ;; it without making the test suite non-portable across platforms...
      (handler-bind ((warning (lambda (c)
                                (if (typep c 'shadowed-typecase-clause)
                                  (muffle-warning c)
                                  (when (let ((w (or (and (typep c 'compiler-warning)
                                                          (eq (compiler-warning-warning-type c) :program-error)
                                                          (car (compiler-warning-args c)))
                                                     c)))
                                          (or (typep (car (compiler-warning-args c))
                                                     'shadowed-typecase-clause)
                                              (and (typep w 'simple-warning)
                                                   (or 
                                                    (string-equal
                                                     (simple-condition-format-control w)
                                                     "Clause ~S ignored in ~S form - shadowed by ~S .")
                                                    ;; Might as well ignore these as well, they're intentional.
                                                    (string-equal
                                                     (simple-condition-format-control w)
                                                     "Duplicate keyform ~s in ~s statement.")))))
                                    (muffle-warning c))))))
        ;; This loads the infrastructure
        (load "ccl:tests;ansi-tests;gclload1.lsp")
        ;; This loads the actual tests
        (let ((redef-var (find-symbol "*WARN-IF-REDEFINE-TEST*" :REGRESSION-TEST)))
          (progv (list redef-var) (list (if force nil (symbol-value redef-var)))
            (when ansi
              (load "ccl:tests;ansi-tests;gclload2.lsp"))
            ;; And our own tests
            (when ccl
              (load "ccl:tests;ansi-tests;ccl.lsp"))))))))


(defun test-ccl (&key force (update t) verbose (catch-errors t) (ansi t) (ccl t)
                      optimization-settings exit exhaustive)
  (if exhaustive
    (let* ((total-failures ()))
      (ensure-tests-loaded :update update :force nil :load nil)
      (dotimes (speed 4)
        (dotimes (space 4)
          (dotimes (safety 4)
            (dotimes (debug 4)
              (dotimes (compilation-speed 4)
                (let* ((optimization-settings `((speed ,speed)
                                                (space ,space)
                                                (safety ,safety)
                                                (debug ,debug)
                                                (compilation-speed ,compilation-speed))))
                  (format t "~&;Testing ~a at optimization settings~&;~s~&"
                          (lisp-implementation-version) optimization-settings)
                  (let* ((failures (test-ccl :force t
                                             :update nil
                                             :verbose verbose
                                             :catch-errors catch-errors
                                             :ansi ansi
                                             :ccl ccl
                                             :optimization-settings optimization-settings
                                             :exit nil)))
                    (when failures
                      (push (cons optimization-settings failures) total-failures)))))))))
      (if exit
        (quit (if total-failures 1 0))
        total-failures))
    (with-preserved-working-directory ()
      (let* ((*package* (find-package "CL-USER"))
             (*load-preserves-optimization-settings* t))
        (with-global-optimization-settings ()
          (proclaim `(optimize ,@optimization-settings))
          (ensure-tests-loaded :force force :update update :ansi ansi :ccl ccl)
          (cwd "ccl:tests;ansi-tests;")
          (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST"))
                (failed (find-symbol "*FAILED-TESTS*" "REGRESSION-TEST"))
                (*print-catch-errors* nil))
            (prog1
                (time (funcall do-tests :verbose verbose :compile t
                               :catch-errors catch-errors
                               :optimization-settings (or optimization-settings '((speed 1) (space 1) (safety 1) (debug 1) (compilation-speed 1)))))
              ;; Clean up a little
              (map nil #'delete-file
                   (directory (merge-pathnames *.fasl-pathname* "ccl:tests;ansi-tests;temp*"))))
            (let ((failed-tests (symbol-value failed)))
              (when exit
                (quit (if failed-tests 1 0)))
              failed-tests)))))))

