guile18/scripts/lint

   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, 2006 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., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301 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       (format #t "Resolved module: ~S\n" module)
 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