mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
* module/scripts/: Add %summary entries, and in many cases, %include-in-guild-list entries to inhibit a script from appearing in "guild list". Update list.scm to respect this new variable.
318 lines
9.6 KiB
Scheme
318 lines
9.6 KiB
Scheme
;;; lint --- Preemptive checks for coding errors in Guile Scheme code
|
|
|
|
;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
|
|
;;
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU Lesser General Public License
|
|
;; as published by the Free Software Foundation; either version 3, or
|
|
;; (at your option) any later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;; Lesser General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU Lesser General Public
|
|
;; License along with this software; see the file COPYING.LESSER. If
|
|
;; not, write to the Free Software Foundation, Inc., 51 Franklin
|
|
;; Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;;; Author: Neil Jerram
|
|
|
|
;;; Commentary:
|
|
|
|
;; Usage: lint FILE1 FILE2 ...
|
|
;;
|
|
;; Perform various preemptive checks for coding errors in Guile Scheme
|
|
;; code.
|
|
;;
|
|
;; Right now, there is only one check available, for unresolved free
|
|
;; variables. The intention is that future lint-like checks will be
|
|
;; implemented by adding to this script file.
|
|
;;
|
|
;; Unresolved free variables
|
|
;; -------------------------
|
|
;;
|
|
;; Free variables are those whose definitions come from outside the
|
|
;; module under investigation. In Guile, these definitions are
|
|
;; imported from other modules using `#:use-module' forms.
|
|
;;
|
|
;; This tool scans the specified files for unresolved free variables -
|
|
;; i.e. variables for which you may have forgotten the appropriate
|
|
;; `#:use-module', or for which the module that is supposed to export
|
|
;; them forgot to.
|
|
;;
|
|
;; It isn't guaranteed that the scan will find absolutely all such
|
|
;; errors. Quoted (and quasiquoted) expressions are skipped, since
|
|
;; they are most commonly used to describe constant data, not code, so
|
|
;; code that is explicitly evaluated using `eval' will not be checked.
|
|
;; For example, the `unresolved-var' in `(eval 'unresolved-var
|
|
;; (current-module))' would be missed.
|
|
;;
|
|
;; False positives are also possible. Firstly, the tool doesn't
|
|
;; understand all possible forms of implicit quoting; in particular,
|
|
;; it doesn't detect and expand uses of macros. Secondly, it picks up
|
|
;; explicit compatibility code like `(if (defined? 'x) (define y x))'.
|
|
;; Thirdly, there are occasional oddities like `next-method'.
|
|
;; However, the number of false positives for realistic code is
|
|
;; hopefully small enough that they can be individually considered and
|
|
;; ignored.
|
|
;;
|
|
;; Example
|
|
;; -------
|
|
;;
|
|
;; Note: most of the unresolved variables found in this example are
|
|
;; false positives, as you would hope. => scope for improvement.
|
|
;;
|
|
;; $ guild lint `guild`
|
|
;; No unresolved free variables in PROGRAM
|
|
;; No unresolved free variables in autofrisk
|
|
;; No unresolved free variables in display-commentary
|
|
;; Unresolved free variables in doc-snarf:
|
|
;; doc-snarf-version
|
|
;; No unresolved free variables in frisk
|
|
;; No unresolved free variables in generate-autoload
|
|
;; No unresolved free variables in lint
|
|
;; No unresolved free variables in punify
|
|
;; No unresolved free variables in read-scheme-source
|
|
;; Unresolved free variables in snarf-check-and-output-texi:
|
|
;; name
|
|
;; pos
|
|
;; line
|
|
;; x
|
|
;; rest
|
|
;; ...
|
|
;; do-argpos
|
|
;; do-command
|
|
;; do-args
|
|
;; type
|
|
;; num
|
|
;; file
|
|
;; do-arglist
|
|
;; req
|
|
;; opt
|
|
;; var
|
|
;; command
|
|
;; do-directive
|
|
;; s
|
|
;; ?
|
|
;; No unresolved free variables in use2dot
|
|
|
|
;;; Code:
|
|
|
|
(define-module (scripts lint)
|
|
#:use-module (ice-9 common-list)
|
|
#:use-module (ice-9 format)
|
|
#:export (lint))
|
|
|
|
(define %include-in-guild-list #f)
|
|
(define %summary "Check for bugs and style errors in a Scheme file.")
|
|
|
|
(define (lint filename)
|
|
(let ((module-name (scan-file-for-module-name filename))
|
|
(free-vars (uniq (scan-file-for-free-variables filename))))
|
|
(let ((module (resolve-module module-name))
|
|
(all-resolved? #t))
|
|
(format #t "Resolved module: ~S\n" module)
|
|
(let loop ((free-vars free-vars))
|
|
(or (null? free-vars)
|
|
(begin
|
|
(catch #t
|
|
(lambda ()
|
|
(eval (car free-vars) module))
|
|
(lambda args
|
|
(if all-resolved?
|
|
(format #t
|
|
"Unresolved free variables in ~A:\n"
|
|
filename))
|
|
(write-char #\tab)
|
|
(write (car free-vars))
|
|
(newline)
|
|
(set! all-resolved? #f)))
|
|
(loop (cdr free-vars)))))
|
|
(if all-resolved?
|
|
(format #t
|
|
"No unresolved free variables in ~A\n"
|
|
filename)))))
|
|
|
|
(define (scan-file-for-module-name filename)
|
|
(with-input-from-file filename
|
|
(lambda ()
|
|
(let loop ((x (read)))
|
|
(cond ((eof-object? x) #f)
|
|
((and (pair? x)
|
|
(eq? (car x) 'define-module))
|
|
(cadr x))
|
|
(else (loop (read))))))))
|
|
|
|
(define (scan-file-for-free-variables filename)
|
|
(with-input-from-file filename
|
|
(lambda ()
|
|
(let loop ((x (read)) (fvlists '()))
|
|
(if (eof-object? x)
|
|
(apply append fvlists)
|
|
(loop (read) (cons (detect-free-variables x '()) fvlists)))))))
|
|
|
|
; guile> (detect-free-variables '(let ((a 1)) a) '())
|
|
; ()
|
|
; guile> (detect-free-variables '(let ((a 1)) b) '())
|
|
; (b)
|
|
; guile> (detect-free-variables '(let ((a 1) (b a)) b) '())
|
|
; (a)
|
|
; guile> (detect-free-variables '(let* ((a 1) (b a)) b) '())
|
|
; ()
|
|
; guile> (detect-free-variables '(define a 1) '())
|
|
; ()
|
|
; guile> (detect-free-variables '(define a b) '())
|
|
; (b)
|
|
; guile> (detect-free-variables '(define (a b c) b) '())
|
|
; ()
|
|
; guile> (detect-free-variables '(define (a b c) e) '())
|
|
; (e)
|
|
|
|
(define (detect-free-variables x locals)
|
|
;; Given an expression @var{x} and a list @var{locals} of local
|
|
;; variables (symbols) that are in scope for @var{x}, return a list
|
|
;; of free variable symbols.
|
|
(cond ((symbol? x)
|
|
(if (memq x locals) '() (list x)))
|
|
|
|
((pair? x)
|
|
(case (car x)
|
|
((define-module define-generic quote quasiquote)
|
|
;; No code of interest in these expressions.
|
|
'())
|
|
|
|
((let letrec)
|
|
;; Check for named let. If there is a name, transform the
|
|
;; expression so that it looks like an unnamed let with
|
|
;; the name as one of the bindings.
|
|
(if (symbol? (cadr x))
|
|
(set-cdr! x (cons (cons (list (cadr x) #f) (caddr x))
|
|
(cdddr x))))
|
|
;; Unnamed let processing.
|
|
(let ((letrec? (eq? (car x) 'letrec))
|
|
(locals-for-let-body (append locals (map car (cadr x)))))
|
|
(append (apply append
|
|
(map (lambda (binding)
|
|
(detect-free-variables (cadr binding)
|
|
(if letrec?
|
|
locals-for-let-body
|
|
locals)))
|
|
(cadr x)))
|
|
(apply append
|
|
(map (lambda (bodyform)
|
|
(detect-free-variables bodyform
|
|
locals-for-let-body))
|
|
(cddr x))))))
|
|
|
|
((let* and-let*)
|
|
;; Handle bindings recursively.
|
|
(if (null? (cadr x))
|
|
(apply append
|
|
(map (lambda (bodyform)
|
|
(detect-free-variables bodyform locals))
|
|
(cddr x)))
|
|
(append (detect-free-variables (cadr (caadr x)) locals)
|
|
(detect-free-variables `(let* ,(cdadr x) ,@(cddr x))
|
|
(cons (caaadr x) locals)))))
|
|
|
|
((define define-public define-macro)
|
|
(if (pair? (cadr x))
|
|
(begin
|
|
(set! locals (cons (caadr x) locals))
|
|
(detect-free-variables `(lambda ,(cdadr x) ,@(cddr x))
|
|
locals))
|
|
(begin
|
|
(set! locals (cons (cadr x) locals))
|
|
(detect-free-variables (caddr x) locals))))
|
|
|
|
((lambda lambda*)
|
|
(let ((locals-for-lambda-body (let loop ((locals locals)
|
|
(args (cadr x)))
|
|
(cond ((null? args) locals)
|
|
((pair? args)
|
|
(loop (cons (car args) locals)
|
|
(cdr args)))
|
|
(else
|
|
(cons args locals))))))
|
|
(apply append
|
|
(map (lambda (bodyform)
|
|
(detect-free-variables bodyform
|
|
locals-for-lambda-body))
|
|
(cddr x)))))
|
|
|
|
((receive)
|
|
(let ((locals-for-receive-body (append locals (cadr x))))
|
|
(apply append
|
|
(detect-free-variables (caddr x) locals)
|
|
(map (lambda (bodyform)
|
|
(detect-free-variables bodyform
|
|
locals-for-receive-body))
|
|
(cdddr x)))))
|
|
|
|
((define-method define*)
|
|
(let ((locals-for-method-body (let loop ((locals locals)
|
|
(args (cdadr x)))
|
|
(cond ((null? args) locals)
|
|
((pair? args)
|
|
(loop (cons (if (pair? (car args))
|
|
(caar args)
|
|
(car args))
|
|
locals)
|
|
(cdr args)))
|
|
(else
|
|
(cons args locals))))))
|
|
(apply append
|
|
(map (lambda (bodyform)
|
|
(detect-free-variables bodyform
|
|
locals-for-method-body))
|
|
(cddr x)))))
|
|
|
|
((define-class)
|
|
;; Avoid picking up slot names at the start of slot
|
|
;; definitions.
|
|
(apply append
|
|
(map (lambda (slot/option)
|
|
(detect-free-variables-noncar (if (pair? slot/option)
|
|
(cdr slot/option)
|
|
slot/option)
|
|
locals))
|
|
(cdddr x))))
|
|
|
|
((case)
|
|
(apply append
|
|
(detect-free-variables (cadr x) locals)
|
|
(map (lambda (case)
|
|
(detect-free-variables (cdr case) locals))
|
|
(cddr x))))
|
|
|
|
((unquote unquote-splicing else =>)
|
|
(detect-free-variables-noncar (cdr x) locals))
|
|
|
|
(else (append (detect-free-variables (car x) locals)
|
|
(detect-free-variables-noncar (cdr x) locals)))))
|
|
|
|
(else '())))
|
|
|
|
(define (detect-free-variables-noncar x locals)
|
|
;; Given an expression @var{x} and a list @var{locals} of local
|
|
;; variables (symbols) that are in scope for @var{x}, return a list
|
|
;; of free variable symbols.
|
|
(cond ((symbol? x)
|
|
(if (memq x locals) '() (list x)))
|
|
|
|
((pair? x)
|
|
(case (car x)
|
|
((=>)
|
|
(detect-free-variables-noncar (cdr x) locals))
|
|
|
|
(else (append (detect-free-variables (car x) locals)
|
|
(detect-free-variables-noncar (cdr x) locals)))))
|
|
|
|
(else '())))
|
|
|
|
(define (main . files)
|
|
(for-each lint files))
|
|
|
|
;;; lint ends here
|