Fix interrupt-thread error detection.
[sbcl.git] / tools-for-build / canonicalize-whitespace.lisp
blob175b4270254267eaf2adfcb6663862f3e97ceb64
1 ;;;; Convert tabs to spaces and delete trailing whitespace in files.
2 ;;;;
3 ;;;; To be run in the root directory of the distribution as part of
4 ;;;; make.sh.
6 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; more information.
8 ;;;;
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
15 ;;; Stream and single-file functions
17 (progn
18 (defun whitespace-p (character)
19 (member character '(#\Space #\Tab) :test #'char=))
21 (defun canonicalize-whitespace (input output)
22 (let (change-p)
23 (flet ((remove-trailing-whitespace (line)
24 (let ((non-ws-position (position-if-not #'whitespace-p line
25 :from-end t)))
26 (cond
27 ((not non-ws-position)
28 (unless (zerop (length line))
29 (setq change-p t))
30 "")
31 ((< non-ws-position (1- (length line)))
32 (setq change-p t)
33 (subseq line 0 (1+ non-ws-position)))
35 line))))
36 (remove-tabs (line)
37 (unless (find #\Tab line :test #'char=)
38 (return-from remove-tabs line))
39 (setq change-p t)
40 (with-output-to-string (stream)
41 (loop :for char :across line :do
42 (if (char= char #\Tab)
43 (write-string " " stream)
44 (write-char char stream))))))
45 (loop :for line = (read-line input nil :eof)
46 :until (eq line :eof)
47 :do (let ((clean (remove-tabs (remove-trailing-whitespace line))))
48 (write-line clean output))))
49 change-p))
51 (defun canonicalize-whitespace/file (file)
52 (macrolet ((with-open-source-file ((stream pathname direction) &body body)
53 `(with-open-file (,stream ,pathname
54 :direction ,direction
55 :external-format #-clisp :utf-8 #+clisp charset:utf-8)
56 ,@body)))
57 (let* ((temporary (make-pathname :type "temp" :defaults file))
58 (change-p
59 (handler-case
60 (with-open-source-file (input file :input)
61 (with-open-source-file (output temporary :output)
62 (canonicalize-whitespace input output)))
63 (#+sbcl sb-int:stream-decoding-error #-sbcl error ()
64 (format t "// Ignoring non-UTF-8 source file ~S~%" file)
65 nil))))
66 (cond
67 (change-p
68 (delete-file file)
69 (rename-file temporary file))
70 ((probe-file temporary)
71 (delete-file temporary))))))
73 ;;; Timestamp functions
75 (defvar *stamp-file* "whitespace-stamp")
77 (defun read-stamp-file ()
78 (if (probe-file *stamp-file*)
79 (file-write-date *stamp-file*)
80 0))
82 (defun write-stamp-file ()
83 (with-open-file (stream *stamp-file*
84 :direction :output
85 :if-exists :supersede)
86 (declare (ignorable stream))
87 (values)))
89 ;;; Repository-level functions
91 (defvar *source-types* '("lisp" "lisp-expr" "c" "h" "asd" "texinfo"))
93 (defvar *exceptions* '("compile-file-pos-utf16be"))
95 (defun canonicalize-whitespace/directory
96 (&optional (directory *default-pathname-defaults*))
97 (let ((stamp-date (read-stamp-file)))
98 (labels ((older-than-stamp (file)
99 (< (file-write-date file) stamp-date))
100 (exception-p (file)
101 (member (pathname-name file) *exceptions*
102 :test #'string=))
103 (skip-p (file)
104 (or (older-than-stamp file) (exception-p file))))
105 (dolist (type *source-types*)
106 (let* ((pattern (merge-pathnames
107 (make-pathname :type type
108 :name :wild
109 :directory '(:relative :wild-inferiors))
110 directory))
111 (files (remove-if #'skip-p (directory pattern))))
112 (mapc #'canonicalize-whitespace/file files))))
113 (write-stamp-file)))
114 ) ; end PROGN
116 ;;; Entry point
118 (canonicalize-whitespace/directory)