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