;;; 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