Changeset 12247


Ignore:
Timestamp:
Jun 10, 2009, 9:32:26 PM (10 years ago)
Author:
gz
Message:

r11868 r12100 r12102 r12112 from trunk

Location:
branches/working-0711/ccl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

    r11267 r12247  
    27232723      usual)))
    27242724
    2725 (defun string-sans-most-whitespace (string &optional (max-length (length string)))
    2726   (with-output-to-string (sans-whitespace)
    2727     (loop
    2728       for count below max-length
    2729       for char across string
    2730       with just-saw-space = nil
    2731       if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed))
    2732         do (if just-saw-space
    2733                (decf count)
    2734                (write-char #\Space sans-whitespace))
    2735         and do (setf just-saw-space t)
    2736       else
    2737         do (setf just-saw-space nil)
    2738         and do (write-char char sans-whitespace))))
    2739 
    2740 
    27412725(defun x86-print-disassembled-instruction (ds instruction seq function)
    27422726  (declare (special *previous-instruction* *previous-block*))
  • branches/working-0711/ccl/lib/misc.lisp

    r12198 r12247  
    724724                       (return-from get-answer (list (nth value list))))))))))))
    725725
     726(defvar *choose-file-dialog-hook* nil "for GUIs")
     727
    726728;;; There should ideally be some way to override the UI (such as
    727729;;; it is ...) here.
     
    730732;;;   b) should do more sanity-checking
    731733(defun choose-file-dialog (&key file-types (prompt "File name:"))
    732   (%choose-file-dialog t prompt file-types))
     734  (let* ((hook *choose-file-dialog-hook*))
     735    (if hook
     736      (funcall hook t prompt file-types)
     737      (%choose-file-dialog t prompt file-types))))
    733738
    734739(defun choose-new-file-dialog (&key prompt)
    735   (%choose-file-dialog nil prompt nil))
     740  (let* ((hook *choose-file-dialog-hook*))
     741    (if hook
     742      (funcall hook nil prompt nil)
     743      (%choose-file-dialog nil prompt nil))))
    736744
    737745(defun %choose-file-dialog (must-exist prompt file-types)
     
    789797(%fhave 'df #'disassemble)
    790798
     799(defun string-sans-most-whitespace (string &optional (max-length (length string)))
     800  (with-output-to-string (sans-whitespace)
     801    (loop
     802      for count below max-length
     803      for char across string
     804      with just-saw-space = nil
     805      if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed))
     806        do (if just-saw-space
     807               (decf count)
     808               (write-char #\Space sans-whitespace))
     809        and do (setf just-saw-space t)
     810      else
     811        do (setf just-saw-space nil)
     812        and do (write-char char sans-whitespace))))
     813
     814
     815(defparameter *svn-program* "svn")
     816
    791817(defloadvar *use-cygwin-svn*
    792818    #+windows-target (not (null (getenv "CYGWIN")))
     
    795821(defun svn-info-component (component)
    796822  (let* ((component-length (length component)))
    797   (with-output-to-string (s)
    798     (multiple-value-bind (status exit-code)
    799         (external-process-status
    800          (run-program "svn"  (list "info" (native-translated-namestring "ccl:")):output s))
    801       (when (and (eq :exited status) (zerop exit-code))
    802         (with-input-from-string (output (get-output-stream-string s))
     823    (let* ((s (make-string-output-stream)))
     824      (multiple-value-bind (status exit-code)
     825          (external-process-status
     826           (run-program *svn-program*  (list "info" (native-translated-namestring "ccl:")) :output s :error :output))
     827        (when (and (eq :exited status) (zerop exit-code))
     828          (with-input-from-string (output (get-output-stream-string s))
    803829            (do* ((line (read-line output nil nil) (read-line output nil nil)))
    804830                 ((null line))
     
    806832                         (string= component line :end2 component-length))
    807833                (return-from svn-info-component
    808                   (string-trim " " (subseq line component-length)))))))))))
     834                  (string-trim " " (subseq line component-length)))))))))
     835    nil))
    809836
    810837(defun svn-url () (svn-info-component "URL:"))
     
    835862
    836863
    837 
     864(defun svnversion-program ()
     865  (or (ignore-errors
     866        (native-translated-namestring
     867         (merge-pathnames "svnversion" *svn-program*)))
     868      "svnversion"))
     869       
     870                     
    838871       
    839872                         
    840873(defun local-svn-revision ()
    841   (or
    842    ;; svn2cvs uses a .svnrev file to sync CVS and SVN; if present,
    843    ;; it contains the svn revision in decimal.
    844    (with-open-file (f "ccl:\\.svnrev" :direction :input :if-does-not-exist nil)
    845      (when f (read f)))
    846    (with-output-to-string (s)
    847      (let* ((root (native-translated-namestring "ccl:")))
    848        (when *use-cygwin-svn*
    849          (setq root (cygpath root)))
    850        (multiple-value-bind (status exit-code)
    851            (external-process-status
    852             (run-program "svnversion"  (list  (native-translated-namestring "ccl:") (or (svn-url) "")):output s))
    853          (when (and (eq :exited status) (zerop exit-code))
    854            (with-input-from-string (output (get-output-stream-string s))
    855              (let* ((line (read-line output nil nil)))
    856                (when (and line (parse-integer line :junk-allowed t) )
    857                  (return-from local-svn-revision line))))))))))
     874  (let* ((s (make-string-output-stream))
     875         (root (native-translated-namestring "ccl:")))
     876    (when *use-cygwin-svn*
     877      (setq root (cygpath root)))
     878    (multiple-value-bind (status exit-code)
     879        (external-process-status
     880         (run-program (svnversion-program)  (list  (native-translated-namestring "ccl:") (or (svn-url) "")) :output s :error :output))
     881      (when (and (eq :exited status) (zerop exit-code))
     882        (with-input-from-string (output (get-output-stream-string s))
     883          (let* ((line (read-line output nil nil)))
     884            (when (and line (parse-integer line :junk-allowed t) )
     885              (return-from local-svn-revision line))))))
     886    nil))
    858887
    859888
Note: See TracChangeset for help on using the changeset viewer.