Ignore:
Timestamp:
Oct 15, 2008, 8:48:03 PM (13 years ago)
Author:
gz
Message:

Another round of changes from the trunk, mostly just mods in internal mechanisms in support of various recent ports.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/compile-ccl.lisp

    r11041 r11101  
    437437    (:solarisx8664 "sx86-boot64")
    438438    (:win64 "wx86-boot64.image")
    439     (:linuxx8632 "x86-boot32")))
     439    (:linuxx8632 "x86-boot32")
     440    (:win32 "wx86-boot32.image")))
    440441
    441442(defun standard-kernel-name (&optional (target (backend-name *host-backend*)))
     
    451452    (:solarisx8664 "sx86cl64")
    452453    (:win64 "wx86cl64.exe")
    453     (:linuxx8632 "lx86cl")))
     454    (:linuxx8632 "lx86cl")
     455    (:win32 "wx86cl.exe")))
    454456
    455457(defun standard-image-name (&optional (target (backend-name *host-backend*)))
     
    479481    (:solarisx8664 "solarisx64")
    480482    (:win64 "win64")
    481     (:linuxx8632 "linuxx8632")))
     483    (:linuxx8632 "linuxx8632")
     484    (:win32 "win32")))
    482485
    483486;;; If we distribute (e.g.) 32- and 64-bit versions for the same
     
    489492  (let* ((pairs '((:darwinppc32 . :darwinppc64)
    490493                  (:linuxppc32 . :linuxppc64)
    491                   (:darwinx8632 . :darwinx8664))))
     494                  (:darwinx8632 . :darwinx8664)
     495                  (:linuxx8632 . :linuxx8664))))
    492496    (or (cdr (assoc target pairs))
    493497        (car (rassoc target pairs)))))
     
    511515    (when full
    512516      (setq clean t kernel t reload t))
    513     (when update (update-ccl))
     517    (when update (update-ccl :verbose (not (eq update :quiet))))
    514518    (when (or clean force)
    515519      ;; for better bug reports...
     
    542546                                          (status exit-code)
    543547                                          (external-process-status
    544                                            (run-program "make"
     548                                           (run-program (make-program)
    545549                                                        (list "-k" "-C"
    546550                                                              (format nil "lisp-kernel/~a"
     
    622626          (funcall f dirname target))))))
    623627
    624 (defun update-ccl ()
    625   (let* ((cvs-update "cvs -q update -d -P")
    626          (svn-update "svn update")
    627          (use-cvs (probe-file "ccl:\.svnrev"))
    628          (s (make-string-output-stream)))
    629     (multiple-value-bind (status exit-code)
    630         (external-process-status
    631          (run-program "/bin/sh"
    632                       (list "-c"
    633                             (format nil "cd ~a && ~a"
    634                                     (native-translated-namestring "ccl:")
    635                                     (if use-cvs cvs-update svn-update)))
    636                       :output s))
    637       (when (and (eq status :exited)
    638                  (eql exit-code 0))
    639         (format t "~&~a" (get-output-stream-string s))
    640         t))))
     628(defun update-ccl (&key (verbose t))
     629  (let* ((changed ())
     630         (conflicts ()))
     631    (with-output-to-string (out)
     632      (with-preserved-working-directory ("ccl:")                     
     633        (when verbose (format t "~&;Running 'svn update'."))
     634        (multiple-value-bind (status exit-code)
     635            (external-process-status
     636             (run-program "svn" '("update" "--non-interactive") :output out :error t))
     637          (when verbose (format t "~&;'svn update' complete."))
     638          (if (not (and (eq status :exited)
     639                        (eql exit-code 0)))
     640            (error "Running \"svn update\" produced exit status ~s, code ~s." status exit-code)
     641            (let* ((sout (get-output-stream-string out))
     642                   (added ())
     643                   (deleted ())
     644                   (updated ())
     645                   (merged ())
     646                   (binaries (list (standard-kernel-name) (standard-image-name )))
     647                   (peer (peer-platform)))
     648              (when peer
     649                (push (standard-kernel-name peer) binaries)
     650                (push (standard-image-name peer) binaries))
     651              (flet ((svn-revert (string)
     652                       (multiple-value-bind (status exit-code)
     653                           (external-process-status (run-program "svn" `("revert" ,string)))
     654                         (when (and (eq status :exited) (eql exit-code 0))
     655                           (setq conflicts (delete string conflicts :test #'string=))
     656                           (push string updated)))))
     657                (with-input-from-string (in sout)
     658                  (do* ((line (read-line in nil nil) (read-line in nil nil)))
     659                       ((null line))
     660                    (when (and (> (length line) 2)
     661                               (eql #\space (schar line 1)))
     662                      (let* ((path (string-trim " " (subseq line 2))))
     663                        (case (schar line 0)
     664                          (#\A (push path added))
     665                          (#\D (push path deleted))
     666                          (#\U (push path updated))
     667                          (#\G (push path merged))
     668                          (#\C (push path conflicts)))))))
     669                ;; If the kernel and/or image conflict, use "svn revert"
     670                ;; to replace the working copies with the (just updated)
     671                ;; repository versions.
     672                (setq changed (if (or added deleted updated merged conflicts) t))
     673             
     674                (dolist (f binaries)
     675                  (when (member f conflicts :test #'string=)
     676                    (svn-revert f)))
     677                ;; If there are any remaining conflicts, offer
     678                ;; to revert them.
     679                (when conflicts
     680                  (with-preserved-working-directory ()
     681                    (cerror "Discard local changes to these files (using 'svn revert'."
     682                            "'svn update' was unable to merge local changes to the following file~p with the updated versions:~{~&~s~~}" (length conflicts) conflicts)
     683                    (dolist (c (copy-list conflicts))
     684                      (svn-revert c))))
     685                ;; Report other changes, if verbose.
     686                (when (and verbose
     687                           (or added deleted updated merged conflicts))
     688                  (format t "~&;Changes from svn update:")
     689                  (flet ((show-changes (herald files)
     690                           (when files
     691                             (format t "~&; ~a:~{~&;  ~a~}"
     692                                     herald files))))
     693                    (show-changes "Conflicting files" conflicts)
     694                    (show-changes "New files/directories" added)
     695                    (show-changes "Deleted files/directories" deleted)
     696                    (show-changes "Updated files" updated)
     697                    (show-changes "Files with local changes, successfully merged" merged)))))))))
     698    (values changed conflicts)))
    641699
    642700(defmacro with-preserved-working-directory ((&optional dir) &body body)
     
    691749      ;; This loads the infrastructure
    692750      (load "ccl:tests;ansi-tests;gclload1.lsp")
    693       ;; Can't put this in the source, because currently tests are not branched
    694       (eval `(define-definition-type ,(find-symbol "DEFTEST" "CL-TEST")
    695                  (function-definition-type)))
    696751      ;; This loads the actual tests
    697752      (let ((redef-var (find-symbol "*WARN-IF-REDEFINE-TEST*" :REGRESSION-TEST)))
Note: See TracChangeset for help on using the changeset viewer.