Commit | Line | Data |
---|---|---|
b3f349b1 TTN |
1 | ;;; lint --- Preemptive checks for coding errors in Guile Scheme code |
2 | ||
b8b06598 | 3 | ;; Copyright (C) 2002, 2006, 2011 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 | ;; | |
b8b06598 | 67 | ;; $ guild lint `guild` |
b3f349b1 TTN |
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 | ||
a1a2ed53 AW |
108 | (define %include-in-guild-list #f) |
109 | (define %summary "Check for bugs and style errors in a Scheme file.") | |
110 | ||
b3f349b1 TTN |
111 | (define (lint filename) |
112 | (let ((module-name (scan-file-for-module-name filename)) | |
113 | (free-vars (uniq (scan-file-for-free-variables filename)))) | |
114 | (let ((module (resolve-module module-name)) | |
115 | (all-resolved? #t)) | |
daeea2a9 | 116 | (format #t "Resolved module: ~S\n" module) |
b3f349b1 TTN |
117 | (let loop ((free-vars free-vars)) |
118 | (or (null? free-vars) | |
119 | (begin | |
120 | (catch #t | |
121 | (lambda () | |
122 | (eval (car free-vars) module)) | |
123 | (lambda args | |
124 | (if all-resolved? | |
125 | (format #t | |
126 | "Unresolved free variables in ~A:\n" | |
127 | filename)) | |
128 | (write-char #\tab) | |
129 | (write (car free-vars)) | |
130 | (newline) | |
131 | (set! all-resolved? #f))) | |
132 | (loop (cdr free-vars))))) | |
133 | (if all-resolved? | |
134 | (format #t | |
135 | "No unresolved free variables in ~A\n" | |
136 | filename))))) | |
137 | ||
138 | (define (scan-file-for-module-name filename) | |
139 | (with-input-from-file filename | |
140 | (lambda () | |
141 | (let loop ((x (read))) | |
142 | (cond ((eof-object? x) #f) | |
143 | ((and (pair? x) | |
144 | (eq? (car x) 'define-module)) | |
145 | (cadr x)) | |
146 | (else (loop (read)))))))) | |
147 | ||
148 | (define (scan-file-for-free-variables filename) | |
149 | (with-input-from-file filename | |
150 | (lambda () | |
151 | (let loop ((x (read)) (fvlists '())) | |
152 | (if (eof-object? x) | |
153 | (apply append fvlists) | |
154 | (loop (read) (cons (detect-free-variables x '()) fvlists))))))) | |
155 | ||
156 | ; guile> (detect-free-variables '(let ((a 1)) a) '()) | |
157 | ; () | |
158 | ; guile> (detect-free-variables '(let ((a 1)) b) '()) | |
159 | ; (b) | |
160 | ; guile> (detect-free-variables '(let ((a 1) (b a)) b) '()) | |
161 | ; (a) | |
162 | ; guile> (detect-free-variables '(let* ((a 1) (b a)) b) '()) | |
163 | ; () | |
164 | ; guile> (detect-free-variables '(define a 1) '()) | |
165 | ; () | |
166 | ; guile> (detect-free-variables '(define a b) '()) | |
167 | ; (b) | |
168 | ; guile> (detect-free-variables '(define (a b c) b) '()) | |
169 | ; () | |
170 | ; guile> (detect-free-variables '(define (a b c) e) '()) | |
171 | ; (e) | |
172 | ||
173 | (define (detect-free-variables x locals) | |
174 | ;; Given an expression @var{x} and a list @var{locals} of local | |
175 | ;; variables (symbols) that are in scope for @var{x}, return a list | |
176 | ;; of free variable symbols. | |
177 | (cond ((symbol? x) | |
178 | (if (memq x locals) '() (list x))) | |
179 | ||
180 | ((pair? x) | |
181 | (case (car x) | |
182 | ((define-module define-generic quote quasiquote) | |
183 | ;; No code of interest in these expressions. | |
184 | '()) | |
185 | ||
186 | ((let letrec) | |
187 | ;; Check for named let. If there is a name, transform the | |
188 | ;; expression so that it looks like an unnamed let with | |
189 | ;; the name as one of the bindings. | |
190 | (if (symbol? (cadr x)) | |
191 | (set-cdr! x (cons (cons (list (cadr x) #f) (caddr x)) | |
192 | (cdddr x)))) | |
193 | ;; Unnamed let processing. | |
194 | (let ((letrec? (eq? (car x) 'letrec)) | |
195 | (locals-for-let-body (append locals (map car (cadr x))))) | |
196 | (append (apply append | |
197 | (map (lambda (binding) | |
198 | (detect-free-variables (cadr binding) | |
199 | (if letrec? | |
200 | locals-for-let-body | |
201 | locals))) | |
202 | (cadr x))) | |
203 | (apply append | |
204 | (map (lambda (bodyform) | |
205 | (detect-free-variables bodyform | |
206 | locals-for-let-body)) | |
207 | (cddr x)))))) | |
208 | ||
209 | ((let* and-let*) | |
210 | ;; Handle bindings recursively. | |
211 | (if (null? (cadr x)) | |
212 | (apply append | |
213 | (map (lambda (bodyform) | |
214 | (detect-free-variables bodyform locals)) | |
215 | (cddr x))) | |
216 | (append (detect-free-variables (cadr (caadr x)) locals) | |
217 | (detect-free-variables `(let* ,(cdadr x) ,@(cddr x)) | |
218 | (cons (caaadr x) locals))))) | |
219 | ||
220 | ((define define-public define-macro) | |
221 | (if (pair? (cadr x)) | |
222 | (begin | |
223 | (set! locals (cons (caadr x) locals)) | |
224 | (detect-free-variables `(lambda ,(cdadr x) ,@(cddr x)) | |
225 | locals)) | |
226 | (begin | |
227 | (set! locals (cons (cadr x) locals)) | |
228 | (detect-free-variables (caddr x) locals)))) | |
229 | ||
230 | ((lambda lambda*) | |
231 | (let ((locals-for-lambda-body (let loop ((locals locals) | |
232 | (args (cadr x))) | |
233 | (cond ((null? args) locals) | |
234 | ((pair? args) | |
235 | (loop (cons (car args) locals) | |
236 | (cdr args))) | |
237 | (else | |
238 | (cons args locals)))))) | |
239 | (apply append | |
240 | (map (lambda (bodyform) | |
241 | (detect-free-variables bodyform | |
242 | locals-for-lambda-body)) | |
243 | (cddr x))))) | |
244 | ||
245 | ((receive) | |
246 | (let ((locals-for-receive-body (append locals (cadr x)))) | |
247 | (apply append | |
248 | (detect-free-variables (caddr x) locals) | |
249 | (map (lambda (bodyform) | |
250 | (detect-free-variables bodyform | |
251 | locals-for-receive-body)) | |
252 | (cdddr x))))) | |
253 | ||
254 | ((define-method define*) | |
255 | (let ((locals-for-method-body (let loop ((locals locals) | |
256 | (args (cdadr x))) | |
257 | (cond ((null? args) locals) | |
258 | ((pair? args) | |
259 | (loop (cons (if (pair? (car args)) | |
260 | (caar args) | |
261 | (car args)) | |
262 | locals) | |
263 | (cdr args))) | |
264 | (else | |
265 | (cons args locals)))))) | |
266 | (apply append | |
267 | (map (lambda (bodyform) | |
268 | (detect-free-variables bodyform | |
269 | locals-for-method-body)) | |
270 | (cddr x))))) | |
271 | ||
272 | ((define-class) | |
273 | ;; Avoid picking up slot names at the start of slot | |
274 | ;; definitions. | |
275 | (apply append | |
276 | (map (lambda (slot/option) | |
277 | (detect-free-variables-noncar (if (pair? slot/option) | |
278 | (cdr slot/option) | |
279 | slot/option) | |
280 | locals)) | |
281 | (cdddr x)))) | |
282 | ||
283 | ((case) | |
284 | (apply append | |
285 | (detect-free-variables (cadr x) locals) | |
286 | (map (lambda (case) | |
287 | (detect-free-variables (cdr case) locals)) | |
288 | (cddr x)))) | |
289 | ||
290 | ((unquote unquote-splicing else =>) | |
291 | (detect-free-variables-noncar (cdr x) locals)) | |
292 | ||
293 | (else (append (detect-free-variables (car x) locals) | |
294 | (detect-free-variables-noncar (cdr x) locals))))) | |
295 | ||
296 | (else '()))) | |
297 | ||
298 | (define (detect-free-variables-noncar x locals) | |
299 | ;; Given an expression @var{x} and a list @var{locals} of local | |
300 | ;; variables (symbols) that are in scope for @var{x}, return a list | |
301 | ;; of free variable symbols. | |
302 | (cond ((symbol? x) | |
303 | (if (memq x locals) '() (list x))) | |
304 | ||
305 | ((pair? x) | |
306 | (case (car x) | |
307 | ((=>) | |
308 | (detect-free-variables-noncar (cdr x) locals)) | |
309 | ||
310 | (else (append (detect-free-variables (car x) locals) | |
311 | (detect-free-variables-noncar (cdr x) locals))))) | |
312 | ||
313 | (else '()))) | |
314 | ||
315 | (define (main . files) | |
316 | (for-each lint files)) | |
317 | ||
318 | ;;; lint ends here |