module/scripts/lint.scm

   1 ;;; lint --- Preemptive checks for coding errors in Guile Scheme code
   2
   3 ;;      Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
   4 ;;
   5 ;; This program is free software; you can redistribute it and/or
   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
   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
  13 ;; Lesser General Public License for more details.
  14 ;;
  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
  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 ;; $ guild lint `guild`
  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 %include-in-guild-list #f)
 109 (define %summary "Check for bugs and style errors in a Scheme file.")
 110
 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))
 116       (format #t "Resolved module: ~S\n" module)
 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