Commit | Line | Data |
---|---|---|
b3f349b1 TTN |
1 | ;;; lint --- Preemptive checks for coding errors in Guile Scheme code |
2 | ||
6e7d5622 | 3 | ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. |
b3f349b1 TTN |
4 | ;; |
5 | ;; This program is free software; you can redistribute it and/or | |
83ba2d37 NJ |
6 | ;; modify it under the terms of the GNU Lesser General Public License |
7 | ;; as published by the Free Software Foundation; either version 3, or | |
b3f349b1 TTN |
8 | ;; (at your option) any later version. |
9 | ;; | |
10 | ;; This program is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
83ba2d37 | 13 | ;; Lesser General Public License for more details. |
b3f349b1 | 14 | ;; |
83ba2d37 NJ |
15 | ;; You should have received a copy of the GNU Lesser General Public |
16 | ;; License along with this software; see the file COPYING.LESSER. If | |
17 | ;; not, write to the Free Software Foundation, Inc., 51 Franklin | |
18 | ;; Street, Fifth Floor, Boston, MA 02110-1301 USA | |
b3f349b1 TTN |
19 | |
20 | ;;; Author: Neil Jerram | |
21 | ||
22 | ;;; Commentary: | |
23 | ||
24 | ;; Usage: lint FILE1 FILE2 ... | |
25 | ;; | |
26 | ;; Perform various preemptive checks for coding errors in Guile Scheme | |
27 | ;; code. | |
28 | ;; | |
29 | ;; Right now, there is only one check available, for unresolved free | |
30 | ;; variables. The intention is that future lint-like checks will be | |
31 | ;; implemented by adding to this script file. | |
32 | ;; | |
33 | ;; Unresolved free variables | |
34 | ;; ------------------------- | |
35 | ;; | |
36 | ;; Free variables are those whose definitions come from outside the | |
37 | ;; module under investigation. In Guile, these definitions are | |
38 | ;; imported from other modules using `#:use-module' forms. | |
39 | ;; | |
40 | ;; This tool scans the specified files for unresolved free variables - | |
41 | ;; i.e. variables for which you may have forgotten the appropriate | |
42 | ;; `#:use-module', or for which the module that is supposed to export | |
43 | ;; them forgot to. | |
44 | ;; | |
45 | ;; It isn't guaranteed that the scan will find absolutely all such | |
46 | ;; errors. Quoted (and quasiquoted) expressions are skipped, since | |
47 | ;; they are most commonly used to describe constant data, not code, so | |
48 | ;; code that is explicitly evaluated using `eval' will not be checked. | |
49 | ;; For example, the `unresolved-var' in `(eval 'unresolved-var | |
50 | ;; (current-module))' would be missed. | |
51 | ;; | |
52 | ;; False positives are also possible. Firstly, the tool doesn't | |
53 | ;; understand all possible forms of implicit quoting; in particular, | |
54 | ;; it doesn't detect and expand uses of macros. Secondly, it picks up | |
55 | ;; explicit compatibility code like `(if (defined? 'x) (define y x))'. | |
56 | ;; Thirdly, there are occasional oddities like `next-method'. | |
57 | ;; However, the number of false positives for realistic code is | |
58 | ;; hopefully small enough that they can be individually considered and | |
59 | ;; ignored. | |
60 | ;; | |
61 | ;; Example | |
62 | ;; ------- | |
63 | ;; | |
64 | ;; Note: most of the unresolved variables found in this example are | |
65 | ;; false positives, as you would hope. => scope for improvement. | |
66 | ;; | |
67 | ;; $ guile-tools lint `guile-tools` | |
68 | ;; No unresolved free variables in PROGRAM | |
69 | ;; No unresolved free variables in autofrisk | |
70 | ;; No unresolved free variables in display-commentary | |
71 | ;; Unresolved free variables in doc-snarf: | |
72 | ;; doc-snarf-version | |
73 | ;; No unresolved free variables in frisk | |
74 | ;; No unresolved free variables in generate-autoload | |
75 | ;; No unresolved free variables in lint | |
76 | ;; No unresolved free variables in punify | |
77 | ;; No unresolved free variables in read-scheme-source | |
78 | ;; Unresolved free variables in snarf-check-and-output-texi: | |
79 | ;; name | |
80 | ;; pos | |
81 | ;; line | |
82 | ;; x | |
83 | ;; rest | |
84 | ;; ... | |
85 | ;; do-argpos | |
86 | ;; do-command | |
87 | ;; do-args | |
88 | ;; type | |
89 | ;; num | |
90 | ;; file | |
91 | ;; do-arglist | |
92 | ;; req | |
93 | ;; opt | |
94 | ;; var | |
95 | ;; command | |
96 | ;; do-directive | |
97 | ;; s | |
98 | ;; ? | |
99 | ;; No unresolved free variables in use2dot | |
100 | ||
101 | ;;; Code: | |
102 | ||
103 | (define-module (scripts lint) | |
104 | #:use-module (ice-9 common-list) | |
105 | #:use-module (ice-9 format) | |
106 | #:export (lint)) | |
107 | ||
108 | (define (lint filename) | |
109 | (let ((module-name (scan-file-for-module-name filename)) | |
110 | (free-vars (uniq (scan-file-for-free-variables filename)))) | |
111 | (let ((module (resolve-module module-name)) | |
112 | (all-resolved? #t)) | |
daeea2a9 | 113 | (format #t "Resolved module: ~S\n" module) |
b3f349b1 TTN |
114 | (let loop ((free-vars free-vars)) |
115 | (or (null? free-vars) | |
116 | (begin | |
117 | (catch #t | |
118 | (lambda () | |
119 | (eval (car free-vars) module)) | |
120 | (lambda args | |
121 | (if all-resolved? | |
122 | (format #t | |
123 | "Unresolved free variables in ~A:\n" | |
124 | filename)) | |
125 | (write-char #\tab) | |
126 | (write (car free-vars)) | |
127 | (newline) | |
128 | (set! all-resolved? #f))) | |
129 | (loop (cdr free-vars))))) | |
130 | (if all-resolved? | |
131 | (format #t | |
132 | "No unresolved free variables in ~A\n" | |
133 | filename))))) | |
134 | ||
135 | (define (scan-file-for-module-name filename) | |
136 | (with-input-from-file filename | |
137 | (lambda () | |
138 | (let loop ((x (read))) | |
139 | (cond ((eof-object? x) #f) | |
140 | ((and (pair? x) | |
141 | (eq? (car x) 'define-module)) | |
142 | (cadr x)) | |
143 | (else (loop (read)))))))) | |
144 | ||
145 | (define (scan-file-for-free-variables filename) | |
146 | (with-input-from-file filename | |
147 | (lambda () | |
148 | (let loop ((x (read)) (fvlists '())) | |
149 | (if (eof-object? x) | |
150 | (apply append fvlists) | |
151 | (loop (read) (cons (detect-free-variables x '()) fvlists))))))) | |
152 | ||
153 | ; guile> (detect-free-variables '(let ((a 1)) a) '()) | |
154 | ; () | |
155 | ; guile> (detect-free-variables '(let ((a 1)) b) '()) | |
156 | ; (b) | |
157 | ; guile> (detect-free-variables '(let ((a 1) (b a)) b) '()) | |
158 | ; (a) | |
159 | ; guile> (detect-free-variables '(let* ((a 1) (b a)) b) '()) | |
160 | ; () | |
161 | ; guile> (detect-free-variables '(define a 1) '()) | |
162 | ; () | |
163 | ; guile> (detect-free-variables '(define a b) '()) | |
164 | ; (b) | |
165 | ; guile> (detect-free-variables '(define (a b c) b) '()) | |
166 | ; () | |
167 | ; guile> (detect-free-variables '(define (a b c) e) '()) | |
168 | ; (e) | |
169 | ||
170 | (define (detect-free-variables x locals) | |
171 | ;; Given an expression @var{x} and a list @var{locals} of local | |
172 | ;; variables (symbols) that are in scope for @var{x}, return a list | |
173 | ;; of free variable symbols. | |
174 | (cond ((symbol? x) | |
175 | (if (memq x locals) '() (list x))) | |
176 | ||
177 | ((pair? x) | |
178 | (case (car x) | |
179 | ((define-module define-generic quote quasiquote) | |
180 | ;; No code of interest in these expressions. | |
181 | '()) | |
182 | ||
183 | ((let letrec) | |
184 | ;; Check for named let. If there is a name, transform the | |
185 | ;; expression so that it looks like an unnamed let with | |
186 | ;; the name as one of the bindings. | |
187 | (if (symbol? (cadr x)) | |
188 | (set-cdr! x (cons (cons (list (cadr x) #f) (caddr x)) | |
189 | (cdddr x)))) | |
190 | ;; Unnamed let processing. | |
191 | (let ((letrec? (eq? (car x) 'letrec)) | |
192 | (locals-for-let-body (append locals (map car (cadr x))))) | |
193 | (append (apply append | |
194 | (map (lambda (binding) | |
195 | (detect-free-variables (cadr binding) | |
196 | (if letrec? | |
197 | locals-for-let-body | |
198 | locals))) | |
199 | (cadr x))) | |
200 | (apply append | |
201 | (map (lambda (bodyform) | |
202 | (detect-free-variables bodyform | |
203 | locals-for-let-body)) | |
204 | (cddr x)))))) | |
205 | ||
206 | ((let* and-let*) | |
207 | ;; Handle bindings recursively. | |
208 | (if (null? (cadr x)) | |
209 | (apply append | |
210 | (map (lambda (bodyform) | |
211 | (detect-free-variables bodyform locals)) | |
212 | (cddr x))) | |
213 | (append (detect-free-variables (cadr (caadr x)) locals) | |
214 | (detect-free-variables `(let* ,(cdadr x) ,@(cddr x)) | |
215 | (cons (caaadr x) locals))))) | |
216 | ||
217 | ((define define-public define-macro) | |
218 | (if (pair? (cadr x)) | |
219 | (begin | |
220 | (set! locals (cons (caadr x) locals)) | |
221 | (detect-free-variables `(lambda ,(cdadr x) ,@(cddr x)) | |
222 | locals)) | |
223 | (begin | |
224 | (set! locals (cons (cadr x) locals)) | |
225 | (detect-free-variables (caddr x) locals)))) | |
226 | ||
227 | ((lambda lambda*) | |
228 | (let ((locals-for-lambda-body (let loop ((locals locals) | |
229 | (args (cadr x))) | |
230 | (cond ((null? args) locals) | |
231 | ((pair? args) | |
232 | (loop (cons (car args) locals) | |
233 | (cdr args))) | |
234 | (else | |
235 | (cons args locals)))))) | |
236 | (apply append | |
237 | (map (lambda (bodyform) | |
238 | (detect-free-variables bodyform | |
239 | locals-for-lambda-body)) | |
240 | (cddr x))))) | |
241 | ||
242 | ((receive) | |
243 | (let ((locals-for-receive-body (append locals (cadr x)))) | |
244 | (apply append | |
245 | (detect-free-variables (caddr x) locals) | |
246 | (map (lambda (bodyform) | |
247 | (detect-free-variables bodyform | |
248 | locals-for-receive-body)) | |
249 | (cdddr x))))) | |
250 | ||
251 | ((define-method define*) | |
252 | (let ((locals-for-method-body (let loop ((locals locals) | |
253 | (args (cdadr x))) | |
254 | (cond ((null? args) locals) | |
255 | ((pair? args) | |
256 | (loop (cons (if (pair? (car args)) | |
257 | (caar args) | |
258 | (car args)) | |
259 | locals) | |
260 | (cdr args))) | |
261 | (else | |
262 | (cons args locals)))))) | |
263 | (apply append | |
264 | (map (lambda (bodyform) | |
265 | (detect-free-variables bodyform | |
266 | locals-for-method-body)) | |
267 | (cddr x))))) | |
268 | ||
269 | ((define-class) | |
270 | ;; Avoid picking up slot names at the start of slot | |
271 | ;; definitions. | |
272 | (apply append | |
273 | (map (lambda (slot/option) | |
274 | (detect-free-variables-noncar (if (pair? slot/option) | |
275 | (cdr slot/option) | |
276 | slot/option) | |
277 | locals)) | |
278 | (cdddr x)))) | |
279 | ||
280 | ((case) | |
281 | (apply append | |
282 | (detect-free-variables (cadr x) locals) | |
283 | (map (lambda (case) | |
284 | (detect-free-variables (cdr case) locals)) | |
285 | (cddr x)))) | |
286 | ||
287 | ((unquote unquote-splicing else =>) | |
288 | (detect-free-variables-noncar (cdr x) locals)) | |
289 | ||
290 | (else (append (detect-free-variables (car x) locals) | |
291 | (detect-free-variables-noncar (cdr x) locals))))) | |
292 | ||
293 | (else '()))) | |
294 | ||
295 | (define (detect-free-variables-noncar x locals) | |
296 | ;; Given an expression @var{x} and a list @var{locals} of local | |
297 | ;; variables (symbols) that are in scope for @var{x}, return a list | |
298 | ;; of free variable symbols. | |
299 | (cond ((symbol? x) | |
300 | (if (memq x locals) '() (list x))) | |
301 | ||
302 | ((pair? x) | |
303 | (case (car x) | |
304 | ((=>) | |
305 | (detect-free-variables-noncar (cdr x) locals)) | |
306 | ||
307 | (else (append (detect-free-variables (car x) locals) | |
308 | (detect-free-variables-noncar (cdr x) locals))))) | |
309 | ||
310 | (else '()))) | |
311 | ||
312 | (define (main . files) | |
313 | (for-each lint files)) | |
314 | ||
315 | ;;; lint ends here |