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