#! /bin/sh
exec guile -s "$0" "$@"
!#

;; Syntax checking of guile scripts.

;; Copyright 2003 Kevin Ryde

;; guile-lint is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by the
;; Free Software Foundation; either version 2, or (at your option) any later
;; version.
;;
;; guile-lint 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 General Public License for
;; more details.
;;
;; You should have received a copy of the GNU General Public License along
;; with guile-lint; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.


;; Usage: guile-lint [--options] file...
;;
;; See the usage message in the code below for the available options, or run
;; "guile-lint --help".
;;
;;
;; The checks performed on each file are for
;;
;;     - unbound variables or functions
;;     - special form arguments (eg. `let' bindings)
;;
;; Unbound variables are identified by walking through the code, looking for
;; references to variables not bound by a "define", "let", module import,
;; etc.
;;
;; Modules imported with `use-modules' will be loaded.  Modules themselves
;; being checked are loaded too.  In both cases they must be available
;; through %load-path.  See the "-L" option for an easy way to add
;; directories to the path.
;;
;; Errors are printed in the usual "file:line:column:" format, which allows
;; Emacs `next-error' to recognise them.  Bad special forms are printed as
;; they're encountered, unbound variables are printed at the end.
;;
;; The location indicated for an unbound variable is the start of the
;; containing s-expression.  This is because that's all the guile reader
;; records, it doesn't note the exact location of every element.  Unless an
;; expression is very big this normally isn't a problem.
;;
;; When a bad special form is encountered, nothing within it is checked, so
;; guile-lint should be re-run once it's been corrected.
;;
;;
;; Compatibility:
;;
;; Designed for guile 1.6.3 or higher.
;;
;;
;; Bugs:
;;
;; Loading modules to find their bindings is unsafe, so guile-lint should be
;; run only on trusted code.  Perhaps in the future modules will be parsed
;; directly and their bindings extracted.  Modules which rely on C code
;; shared libraries will probably always have to be loaded though.
;;
;; Application macros are not recognised.  `syntax-case' macros could be
;; safely applied, and with luck syncase.scm will help expanding them, if it
;; doesn't mind us doing the tracking of what bindings are in scope.
;;
;; `procedure->macro' macros are unsafe in the sense that code under test is
;; executed, and they might need other application code too.  Perhaps as an
;; option they could be attempted, since straightforward tranformations
;; ought to be ok.
;;
;; No attempt is made to tell exactly when a reference is required, it's
;; assumed that checking can be left to the very end.  Expressions executed
;; immediately are easy enough to spot, but exactly what functions or
;; lambdas they reach is a lot harder, especially if obscured by callbacks
;; or whatever.  Hopefully such immediate-execute things are identified
;; easily enough when code is run.
;;
;; Slib `require' is not supported.
;;
;;
;; Extending:
;;
;; The "-l" or "-e" options allow extra code to be executed before the
;; checking commences.  For instance new special forms can be registered
;; with `lint-syntax!'.
;;
;; The current suggestion for handling application macros is to make a lint
;; function which runs the expression transform code the same as at
;; run-time, and invokes "lint-expr" on the result.  For example, create a
;; file my-syntax.scm containing
;;
;;     (define (my-transformer expr)
;;       ...)
;;     (define (lint-my-syntax expr env)
;;       (lint-expr (my-transformer expr) env))
;;     (lint-syntax! 'my-syntax lint-my-syntax)
;;
;; and run
;;
;;     guile-lint -l my-syntax.scm  files...
;;	      
;; When transforming, be sure to copy source-properties across from the
;; original expression so locations can be reported.  This is good when
;; running with --debug too, so it's worth doing whenever source properties
;; are present.
;;
;; Beware that arguments to the `lint-foo' functions might change in the
;; future.  Unless source-properties are always available after macro
;; expansion then it'll probably be necessary to introduce some sort of
;; source expression nesting scheme, in order to work upwards to some
;; position information if an exact location is unknown.  (The idea would be
;; to defer source position treatment until it's really needed, since often
;; it's not.)
;;
;;
;; Future:
;;
;; Checking function argument counts might be nice.  The standard functions
;; could be checked always.  Application functions would probably have to be
;; limited to those defined in straightforward ways.
;;
;; Checking argument types might be cute too.  Literal arguments would be
;; easy enough, but trying to decide what a variable can hold might be too
;; hard in general (perhaps easy usages could be covered).  In any case
;; would need to declare what the standard functions accept, and perhaps
;; have a means for application functions to give similar hints.



;;-----------------------------------------------------------------------------


;; hide ourselves in a module, so "guile-user" is kept clean for testing
;; application level bindings
;;
(define-module (guile-lint)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 syncase)
  #:use-module (ice-9 r5rs)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-13))

(define lint-version "1")


(define option-verbose #f)
(define option-r5rs    #f)


;;-----------------------------------------------------------------------------
;; misc

;; Like `for-each' but allowing an improper list.
;; PROC will be called for the last `cdr', if it's not '().
(define (for-each-improper proc lst)
  (cond ((pair? lst)
	 (proc (car lst))
	 (for-each-improper proc (cdr lst)))
	((not (null? lst))
	 (proc lst))))

;; Print the arguments, for diagnostic purposes.
(define (d . args)
  (for-each (lambda (elem)
	      (if (pair? elem)
		  (pretty-print-no-newline elem)
		  (display elem))
	      (display " "))
	    args)
  (display "\n"))

;; Usage: (dv expr ...)
;; Print names and values of expressions, for diagnostic purposes.
;; Strings are printed as prefixes.
(define-syntax dv
  (syntax-rules ()
    ((dv name)
     (if (string? 'name)
	 (begin
	   (display name " ")
	   (display " "))
	 (d 'name name)))
    ((dv name more ...)
     (begin
       (dv name)
       (dv more ...)))))

(define (pretty-print-no-newline obj)
  (display (string-trim-right (pretty-print-to-string obj))))

(define (pretty-print-to-string obj)
  (call-with-output-string
   (lambda (port)
     (pretty-print obj port))))

(define (set-source-properties-from-port! lst port)
  (set-source-property! lst 'filename (port-filename port))
  (set-source-property! lst 'line     (port-line     port))
  (set-source-property! lst 'column   (port-column   port)))

;; return "filename:line:column:" from the `source-properties' of EXPR
(define (source-position-string expr)
  (format #f "~a:~a:~a:"
	  (or (source-property expr 'filename)
	      "UNKNOWNFILE")
	  (1+ (or (source-property expr 'line)
		  0))
	  (1+ (or (source-property expr 'column)
		  0))))

;; return true if X is a list of symbols (a possibly improper list)
(define (list-of-symbols-improper? x)
  (or (null? x)
      (and (pair? x)
	   (symbol? (car x))
	   (or (symbol? (cdr x))
	       (list-of-symbols-improper? (cdr x))))))

;; Return true if LST length is >= N.
;; Unlike `length', this doesn't traverse the whole of LST, just as much as
;; needed to do the test.
(define (length>=? lst n)
  (if (= 0 n)
      #t
      (if (null? lst)
	  #f
	  (length>=? (cdr lst) (1- n)))))

;; return true if X is a proper list of at least N elements
(define (list>=? x n)
  (and (list? x)
       (length>=? x n)))

;; Like `and' but as a function so it can be used with `apply'
(define (and-func . args)
  (not (find not args)))

;; Apply `car' until reaching a non-pair
(define (car-to-object x)
  (if (pair? x)
      (car-to-object (car x))
      x))


;;-----------------------------------------------------------------------------
;; environments

;; modules-list is a list of modules, to which module-defined? can be applied
;; bound-list is a list of symbols
;; free-list is a list (symbol expr), where expr should have source-properties
;;
(define env-type  (make-record-type "env" '(module-list bound-list free-list
							prev)))
(define env-new          (record-constructor env-type))
(define env-module-list  (record-accessor env-type 'module-list))
(define env-bound-list   (record-accessor env-type 'bound-list))
(define env-free-list    (record-accessor env-type 'free-list))
(define env-prev         (record-accessor env-type 'prev))
(define env-module-list! (record-modifier env-type 'module-list))
(define env-bound-list!  (record-modifier env-type 'bound-list))
(define env-free-list!   (record-modifier env-type 'free-list))

;; return true if ENV is a top-level environment
(define (env-toplevel? env)
  (not (env-prev env)))

(define guile-user-module (resolve-module '(guile-user)))
(define r5rs-module       (scheme-report-environment 5))

;; Return a new environment, chaining back to ENV.
;; If ENV is #f, a top-level environment is created, it chains back to the
;; "guile-user" module, which is everything normal guile defines.
(define (env-chain env)
  (env-new (if env
	       '()
	       (list (if option-r5rs
			 r5rs-module
			 guile-user-module)))
	   '() '() env))

;; return #t if SYMBOL is bound in ENV
(define (env-bound? env symbol)
  (or (find (lambda (module)
	      (module-defined? module symbol))
	    (env-module-list env))
      (memq symbol (env-bound-list env))
      (let ((subenv (env-prev env)))
	(and subenv
	     (env-bound? subenv symbol)))))

;; bind SYMBOLS within ENV
;; SYMBOLS can be a symbol, or a list (proper or improper) of symbols or
;; further lists
(define (env-bind env obj)
  (if (symbol? obj)
      (begin
	(env-bound-list! env (cons obj (env-bound-list env)))
	(env-free-list! env (remove! (lambda (elem)
				       (eq? obj (car elem)))
				     (env-free-list env))))
      (for-each-improper (lambda (elem)
			   (env-bind env elem))
			 obj)))

;; bind in ENV the symbols implied by FORMAL-LIST from a lambda*
(define (env-bind-lambda* env formal-list source-expr)
  (if (not (null? formal-list))
      (let ((formal (first formal-list)))
	(cond ((symbol? formal)
	       (env-bind env formal))
	      ((keyword? formal)
	       )
	      ((pair? formal)
	       (env-bind env (first formal)))
	      (else
	       (lint-error source-expr
			   "unrecognised formal in `lambda*' arg list: ~a"
			   formal)))
	(env-bind-lambda* env (cdr formal-list) source-expr))))

(define (env-define-module env spec)
  (if (not (resolve-interface spec))
      (format (current-error-port)
	      "guile-lint: cannot resolve module: ~a\n" spec))
  (env-module-list! env (cons (resolve-module spec)
			      (env-module-list env)))
  (read-enable 'positions))

(define (env-use-module env spec)
  (let ((module (resolve-interface spec)))
    (if module
	(env-module-list! env (cons module
				    (env-module-list env)))
	(format (current-error-port)
		"guile-lint: cannot resolve module: ~a\n" spec)))
  (read-enable 'positions))

;; reference SYMBOL within ENV, recording the source location from EXPR if
;; SYMBOL is not bound yet
(define (env-ref env symbol expr)
  (if (not (env-bound? env symbol))
      (env-free-list! env
		      (cons (cons symbol expr)
			    (env-free-list env)))))

;; append the free-list from SUBENV onto ENV
(define (env-free-append env subenv)
  (env-free-list! env
		  (append! (env-free-list subenv) (env-free-list env))))


;;-----------------------------------------------------------------------------
;; support

(define lint-syntax-hash (make-hash-table 71))

;; set PROC as the handler for S-expressions starting with SYMBOL
;; calls to PROC are (PROC expr env)
;;
(define (lint-syntax! symbol proc)
  (hashq-set! lint-syntax-hash symbol proc))

;; print an error, indicating the PORT location
(define (lint-error-port port fmt . args)
  (format #t "~a:~a:~a: ~a\n"
	  (port-filename port)
	  (1+ (port-line port))
	  (1+ (port-column port))
	  (apply format #f fmt args)))

;; #f is returned, so lint-error can be the last in an `or' expression and
;; make that come out false
(define (lint-error source-expr fmt . args)
  (format #t "~a ~a\n"
	  (source-position-string source-expr)
	  (apply format #f fmt args))
  #f)

;; call (PROC subenv) for a new sub-environment chained back to ENV, and
;; when PROC returns join any free variables from subenv onto ENV
;;
(define (lint-subenv env proc)
  (let ((subenv (env-chain env)))
    (proc subenv)
    (if env
	(env-free-append env subenv)
	(lint-error-free-list (env-free-list subenv)))))

;; print all elements of the free list LST as errors
;;
;; a quad is (filename line column symbol)
;; used mainly to avoid repeated calls to source-property when sorting
;;
(define (lint-error-free-list lst)
  (define (quad<? x y)
    (lambda (x y)
      (if (not (string=? (first x) (first y)))
	  (string<? (first x) (first y))
	  (if (not (= (second x) (second y)))
	      (< (second x) (second y))
	      (if (not (= (third x) (third y)))
		  (< (third x) (third y))
		  (string<? (symbol->string (fourth x))
			    (symbol->string (fourth y))))))))
  (define (free->quad elem)
    (list (or (source-property (cdr elem) 'filename)
	      "!unknown-file")
	  (1+ (or (source-property (cdr elem) 'line)
		  0))
	  (1+ (or (source-property (cdr elem) 'column)
		  0))
	  (car elem)))
  
  (for-each (lambda (elem)
	      (format #t "~a:~a:~a: unbound variable ~a\n"
		      (first  elem)
		      (second elem)
		      (third  elem)
		      (fourth elem)))
	    (sort! (map free->quad lst) quad<?)))

;; Return EXPR if it's a list with source properties, otherwise SOURCE-EXPR.
;; source-property is used for the test, since in guile 1.6.3
;; source-properties doesn't cooperate with set-source-properties! (it
;; doesn't return anything set that way).
(define (lint-source source-expr expr)
  (if (and (pair? expr)
	   (source-property expr 'filename))
      expr
      source-expr))


;;-----------------------------------------------------------------------------
;; special forms
;;
;; The lint-foo functions are called with a list expression (a proper list),
;; the first element being the symbol as registered with lint-syntax!.
;;
;; The form-foo functions check the form of the given expression and return
;; true if it's good.


(define (lint-and-let* expr env)
  (lint-let* expr env))
(lint-syntax! 'and-let* lint-and-let*)


(define (form-begin expr)
  (or (list>=? expr 2)
      (lint-error expr "`begin' must have at least one expression: ~a" expr)))

(define (lint-begin expr env)
  (if (form-begin expr)
      (lint-list-source expr (cdr expr) env)))
(lint-syntax! 'begin lint-begin)


(define (form-case-datum clause datum last?)
  (and (or (not (eq? 'else datum))
	   last?
	   (lint-error clause "case `else' must be last: ~a" clause))
       (or (eq? 'else datum)
	   (list? datum)
	   (lint-error clause "case datum must be a (proper) list, or `else': ~a" datum))))

(define (form-case-clauses clause-list)
  (let ((lst    clause-list)
	(result #t))
    (while (not (null? lst))
	   (let ((clause (first lst)))
	     (set! result
		   (and (or (list>=? clause 1)
			    (lint-error (lint-source clause-list clause)
					"case clause should be a (proper) list of at least one element: ~a" clause))
			(form-case-datum clause (first clause) (null? (cdr lst)))
			result)))
	   (set! lst (cdr lst)))
    result))

(define (form-case expr)
  (and (or (length>=? expr 2)
	   (lint-error expr "case needs key and at least one clause: ~a" expr))
       (form-case-clauses (cddr expr))))

(define (lint-case expr env)
  (if (form-case expr)
      (begin
	;; key
	(lint-list-source expr (list (second expr)) env)
	;; consequents
	(for-each (lambda (elem)
		    (lint-list-source elem (cdr elem) env))
		  (cddr expr)))))
(lint-syntax! 'case lint-case)


(define (form-cond expr)
  (and (or (length>=? expr 2)
	   (lint-error expr "cond needs at least one clause: ~a" expr))
       (apply and-func
	      (map (lambda (clause)
		     (or (list>=? clause 1)
			 (lint-error (lint-source expr clause)
				     "cond clause must be a list containing at least a test: ~a"
				     clause)))
		   (cddr expr)))))

(define (lint-cond expr env)
  (if (form-cond expr)
      (let* ((clause (second expr))
	     (test   (first clause))
	     (body   (cdr clause)))
	;; don't check for a test `else' in the last clause
	(if (or (not (null? (cddr expr)))
		(not (eq? 'else test)))
	    (lint-object-source clause test env))
	;; ignore `=>'
	(if (and (pair? body)
		 (eq? '=> (first body)))
	    (set! body (cdr body)))
	(lint-list-source clause body env))))
(lint-syntax! 'cond lint-cond)


(define (form-do expr)
  (and (or (length>=? expr 3)
	   (lint-error expr "`do' needs at least bindings and tests: ~a" expr))
       (apply and-func
	      (or (list? (second expr))
		  (lint-error (lint-source expr (second expr))
			      "`do' bindings must be a (proper) list: ~a" (second expr)))
	      (or (list? (third expr))
		  (not (null? (third expr)))
		  (lint-error (lint-source expr (third expr))
			      "`do' test/results must be a non-empty (proper) list: ~a" (third expr)))
	      (map (lambda (binding)
		     (or (and (or (= 2 (length binding))
				  (= 3 (length binding)))
			      (symbol? (first binding)))
			 (lint-error (lint-source expr (third expr))
				     "`do' binding must symbol, initializer and optional step: ~a" (third expr))))		     
		   (second expr)))))

(define (lint-do expr env)
  (if (form-do expr)
      (begin
	;; initializers
	(for-each (lambda (elem)
		    (lint-list-source elem (list (second elem)) env))
		  (second expr))
	(lint-subenv env
		     (lambda (subenv)
		       ;; variables
		       (for-each (lambda (elem)
				   (env-bind subenv (first elem)))
				 (second expr))
		       ;; steps
		       (for-each (lambda (elem)
				   (lint-list-source elem (cddr elem) subenv))
				 (second expr))
		       ;; tests and body
		       (lint-list-source expr (cddr expr) subenv))))))
(lint-syntax! 'do lint-do)


(define (form-define-arglist expr)
  (and (or (not (null? expr))
	   (lint-error expr "define name-spec cannot be empty: ~a" expr))
       (if option-r5rs
	   (or (symbol? (first expr))
	       (lint-error expr "define name-spec must start with symbol: ~a" expr))
	   (or (symbol? (first expr))
	       (pair? (first expr))
	       (lint-error expr "define name-spec must start with symbol or currying list: ~a" expr)))
       (or (symbol? (first expr))
	   (form-define-arglist (first expr)))
       (or (symbol? (cdr expr))
	   (list-of-symbols-improper? (cdr expr))
	   (lint-error expr "define formal parameters must be symbols: ~a" (cdr expr)))))

(define (form-define expr)
  (and (or (length>=? expr 3)
	   (lint-error expr "define needs at least two arguments: ~a" expr))
       (or (symbol? (second expr))
	   (form-define-arglist (second expr)))
       (or (not (symbol? (second expr)))
	   (= 3 (length expr))
	   (lint-error expr "define of symbol needs exactly two arguments: ~a" (second expr)))))

(define (lint-define expr env)
  (if (form-define expr)
      (if (symbol? (second expr))
	  (begin
	    (lint-list-source expr (cddr expr) env)
	    (env-bind env (second expr)))
	  (begin
	    (let ((params (second expr)))
	      (env-bind env (car-to-object params))
	      (lint-subenv env
			   (lambda (subenv)
			     ;; this gets the define name too, but that's
			     ;; ok, and we need to get curried parts
			     (env-bind subenv params)
			     (lint-list-source expr (cddr expr) subenv))))))))
(lint-syntax! 'define lint-define)


(define (form-define*-arglist expr)
  (and (or (not (null? expr))
	   (lint-error expr "`define*' formals cannot be empty: ~a" expr))
       (or (pair? (first expr))
	   (symbol? (first expr))
	   (lint-error expr "`define*' arglist must start with symbol or currying list: ~a" expr))
       (and-func (if (pair? (first expr))
		     (form-define*-arglist (car expr))
		     #t)
		 (form-lambda*-formals 'define* expr (cdr expr)))))

(define (form-define* expr)
  (and (or (length>=? expr 3)
	   (lint-error expr "`define*' needs at least two arguments: ~a" expr))
       (or (symbol? (second expr))
	   (pair? (second expr))
	   (lint-error expr "`define*' name must be symbol or list: ~a"
		       (second expr)))
       (if (symbol? (second expr))
	   (or (= 3 (length expr))
	       (lint-error expr "`define*' of symbol needs exactly two arguments: ~a" (second expr)))
	   (form-define*-arglist (second expr)))))

(define (lint-define* expr env)
  (if (form-define* expr)
      (let ((params (second expr)))
	(env-bind env (first params))
	(lint-subenv env
		     (lambda (subenv)
		       (env-bind-lambda* env (cdr params) params)
		       (lint-list-source expr (cddr expr) subenv))))))
(lint-syntax! 'define* lint-define*)


(define (form-define-macro expr)
  (and (or (length>=? expr 3)
	   (lint-error expr "`define-macro' needs at least two arguments: ~a" expr))
       (or (list-of-symbols-improper? (second expr))
	   (lint-error expr "`define-macro' arglist must be a list of symbols: ~a" (second expr)))))

;; only the macro code itself is checked, not what it might expand to
(define (lint-define-macro expr env)
  (if (form-define-macro expr)
      (let ((params (second expr)))
	(env-bind env (first params))
	(lint-subenv env
		     (lambda (subenv)
		       (env-bind env (cdr params))
		       (lint-list-source expr (cddr expr) subenv))))))
(lint-syntax! 'define-macro lint-define-macro)


;; FIXME: check the form
(define (lint-define-method expr env)
  (let ((params (second expr)))
    (env-bind env (first params))
    (lint-subenv env
		 (lambda (subenv)
		   (env-bind subenv 'next-method)
		   (for-each (lambda (formal)
			       (if (symbol? formal)
				   (env-bind subenv formal)
				   (env-bind subenv (first formal))))
			     params)
		   (lint-list-source expr (cddr expr) subenv)))))
(lint-syntax! 'define-method lint-define-method)


(define (lint-define-module expr env)
  (env-define-module env (second expr)))
(lint-syntax! 'define-module lint-define-module)


(define (lint-define-public expr env)
  (if (not (env-toplevel? env))
      (lint-error expr "~a only valid at top-level" (first expr)))
  (lint-define expr env))
(lint-syntax! 'define-public lint-define-public)


(lint-syntax! 'define-syntax noop)


(define (form-defmacro expr)
  (and (or (length>=? expr 4)
	   (lint-error expr "`defmacro' needs at least three arguments: ~a" expr))
       (or (symbol? (second expr))
	   (lint-error expr "`defmacro' name must be a symbol: ~a" (second expr)))
       (or (symbol? (third expr))
	   (list-of-symbols-improper? (third expr))
	   (lint-error expr "`defmacro' arglist must be a symbol or list of symbols: ~a" (third expr)))))

;; only the macro code itself is checked, not what it might expand to
(define (lint-defmacro expr env)
  (if (form-defmacro expr)
      (begin
	(env-bind env (second expr))
	(lint-subenv env
		     (lambda (subenv)
		       (env-bind env (third expr))
		       (lint-list-source expr (cdddr expr) subenv))))))
(lint-syntax! 'defmacro lint-defmacro)


(define (form-export expr)
  (and (or (list>=? expr 2)
	   (lint-error expr "`export' must have at least one argument: ~a" expr))
       (or (and (list? expr)
		(every symbol? expr))
	   (lint-error expr "`export' arguments must be symbols: ~a" expr))))

(define (lint-export expr env)
  (if (form-export expr)
      (lint-list-source expr (cdr expr) env)))
(lint-syntax! 'export lint-export)


(define (form-if expr)
  (or (and (list? expr)
	   (or (= 3 (length expr))
	       (= 4 (length expr))))
      (lint-error expr "`if' takes three or four arguments: ~a" expr)))

(define (lint-if expr env)
  (if (form-if expr)
      (lint-list-source expr (cdr expr) env)))
(lint-syntax! 'if lint-if)


(define (form-lambda expr)
  (and (or (length>=? expr 3)
	   (lint-error expr "lambda must have bindings and at least one expression: ~a" expr))
       (or (symbol? (second expr))
	   (list-of-symbols-improper? (second expr))
	   (lint-error (lint-source expr (second expr))
		       "lambda formal parameters must be a symbol or a list of symbols: ~a" (second expr)))))

(define (lint-lambda expr env)
  (if (form-lambda expr)
      (lint-subenv env
		   (lambda (subenv)
		     (if (symbol? (second expr))
			 (env-bind subenv (second expr))
			 (env-bind subenv (second expr)))
		     (lint-list-source expr (cddr expr) subenv)))))
(lint-syntax! 'lambda lint-lambda)


(define (form-lambda*-formals name source-expr formals)
  (define (ext-var-decl? elem)
    (or (symbol? elem)
	(and (list? elem)
	     (= 2 (length elem))
	     (symbol? (car elem)))))
  
  ;; leading symbols
  (let symbols ()
    (if (pair? formals)
	(if (symbol? (car formals))
	    (begin
	      (set! formals (cdr formals))
	      (symbols)))))
  
  ;; #:optional symbols or (symbol expr)
  (if (and (pair? formals)
	   (eq? #:optional (car formals)))
      (begin
	(set! formals (cdr formals))
	(let optionals ()
	  (if (pair? formals)
	      (if (ext-var-decl? (car formals))
		  (begin
		    (set! formals (cdr formals))
		    (optionals)))))))
  
  ;; #:key symbols or (symbol expr), and optional #:allow-other-keys
  (if (and (pair? formals)
	   (eq? #:key (car formals)))
      (begin
	(set! formals (cdr formals))
	(let keys ()
	  (if (pair? formals)
	      (cond ((ext-var-decl? (first formals))
		     (set! formals (cdr formals))
		     (keys))
		    ((eq? #:allow-other-keys)
		     (set! formals (cdr formals))))))))
  
  ;; #:rest symbol or . symbol
  (cond ((and (pair? formals)
	      (eq? #:rest (car formals))
	      (pair? (cdr formals))
	      (symbol? (cadr formals)))
	 (set! formals (cddr formals)))
	((symbol? formals)
	 (set! formals '())))
  
  (if (not (null? formals))
      (lint-error source-expr "~a invalid formals: ~a" name formals)))

(define (form-lambda* expr)
  (and (or (length>=? expr 3)
	   (lint-error expr "`lambda*' must have bindings and at least one expression: ~a" expr))
       (form-lambda*-formals 'lambda* (second expr) (second expr))))

(define (lint-lambda* expr env)
  (if (form-lambda* expr)
      (lint-subenv env
		   (lambda (subenv)
		     (env-bind-lambda* env (second expr) (second expr))
		     (lint-list-source expr (cddr expr) subenv)))))
(lint-syntax! 'define* lint-define*)


(define (form-let-bindings name binding-list)
  (apply and-func
	 (map (lambda (binding)
		(or (and (list? binding)
			 (= 2 (length binding))
			 (symbol? (first binding)))
		    (lint-error (lint-source binding-list binding)
				"~a binding must be list of symbol and value: ~a"
				binding)))
	      binding-list)))

(define (form-let expr)
  (let ((name        (first expr))
	(source-expr expr))
    ;; skip named let
    (if (and (length>=? expr 2)
	     (symbol? (second expr)))
	(set! expr (cdr expr)))
    
    (and (or (length>=? expr 3)
	     (lint-error expr "let must have bindings and at least one expression: ~a" expr))
	 (or (list? (second expr))
	     (lint-error (lint-source source-expr (second expr))
			 "~a bindings must be a (proper) list: ~a" name (second expr)))
	 (form-let-bindings name (second expr)))))

(define (lint-let expr env)
  (if (form-let expr)
      (let ((name #f))
	(if (symbol? (second expr))
	    (begin
	      (set! name (second expr))
	      (set! expr (cdr expr))))
	(for-each (lambda (binding)
		    (lint-list-source binding (cdr binding) env))
		  (second expr))
	(lint-subenv env
		     (lambda (subenv)
		       (if name
			   (env-bind subenv name))
		       (for-each (lambda (binding)
				   (env-bind subenv (first binding)))
				 (second expr))
		       (lint-list-source expr (cddr expr) subenv))))))
(lint-syntax! 'let lint-let)


;; check a "let" form, without allowing a named let
(define (form-let-noname expr)
  (and (or (length>=? expr 3)
	   (lint-error expr "`~a' must have bindings and at least one expression: ~a" (first expr) expr))
       (or (list? (second expr))
	   (lint-error (lint-source expr (second expr))
		       "`~a' bindings must be a (proper) list: ~a"
		       (first expr) (second expr)))
       (form-let-bindings 'let* (second expr))))
       
(define (lint-let* expr env)
  (if (form-let-noname expr)
      (let ((bindings (second expr)))
	(if (null? bindings)
	    (lint-list-source expr (cddr expr) env)
	    (let ((binding (first bindings)))
	      (lint-list-source binding (cdr binding) env)
	      (lint-subenv env
			   (lambda (subenv)
			     (env-bind subenv (first binding))
			     (lint-let* (cons* 'let* (cdr bindings) (cddr expr))
					subenv))))))))
(lint-syntax! 'let* lint-let*)


(define (lint-letrec expr env)
  (if (form-let-noname expr)
      (lint-subenv env
		   (lambda (subenv)
		     ;; variables
		     (for-each (lambda (binding)
				 (env-bind subenv (first binding)))
			       (second expr))
		     ;; initial values
		     (for-each (lambda (binding)
				 (lint-list-source binding (cdr binding) subenv))
			       (second expr))
		     ;; body
		     (lint-list-source expr (cddr expr) subenv)))))
(lint-syntax! 'letrec lint-letrec)


(define (lint-quasiquote expr env)
  (if (pair? expr)
      (for-each-improper (lambda (elem)
			   (if (pair? elem)
			       (if (memq (first elem)
					 '(unquote unquote-splicing))
				   (lint-list-source elem (cdr elem) env))
			       (lint-quasiquote elem env)))
			 expr)))
(lint-syntax! 'quasiquote lint-quasiquote)


(lint-syntax! 'quote noop)


(define (lint-read-set! expr env)
  (if (not (null? (cdr expr)))
      (lint-list-source expr (cddr expr) env)))
(lint-syntax! 'read-set! lint-read-set!)


;; even an empty (trap-set!) is allowed, apparently, so no form checking
(define (lint-trap-set! expr env)
  (if (not (null? (cdr expr)))
      (lint-list-source expr (cddr expr) env)))
(lint-syntax! 'trap-set! lint-trap-set!)


(define (lint-use-modules expr env)
  (for-each (lambda (spec)
	      (env-use-module env spec))
	    (cdr expr)))
(lint-syntax! 'use-modules lint-use-modules)

(lint-syntax! 'use-syntax lint-use-modules)


;; actually, it seems (while #f) is valid, the body only needs to be present
;; if it's going to be executed, but let's assume that's degenerate and we
;; should insist on a body
(define (form-while expr)
  (or (list>=? expr 3)
      (lint-error expr "`while' must have at least one body expression: ~a" expr)))

(define (lint-while expr env)
  (if (form-while expr)
      (lint-list-source expr (cdr expr) env)))
(lint-syntax! 'while lint-while)


(define (form-expr expr)
  (or (list? expr)
      (lint-error expr "expression must be a proper list: ~a" expr)))

;; Check S-expression EXPR.
;; Launch syntax handler if available, or just check each element otherwise.
;;
;; Syntax handlers are only recognised when their symbol is bound, so for
;; instance and-let* is only available when the application has loaded
;; (ice-9 and-let-star).
;;
(define (lint-expr expr env)
  (if (form-expr expr)
      ((or (and (env-bound? env (first expr))
		(hashq-ref lint-syntax-hash (first expr)))
	   lint-list)
       expr env)))


;; Check each element of the list EXPR.
(define (lint-list expr env)
  (lint-list-source expr expr env))

;; Check each element of the list EXPR, but with source properties taken
;; from SOURCE-EXPR.
;;
(define (lint-list-source source-expr expr env)
  (if (not (list? expr))
      (lint-error expr "not a proper list: ~a" expr)
      (for-each (lambda (obj)
		  (lint-object-source source-expr obj env))
		expr)))

(define (lint-object-source source-expr expr env)
  (cond ((symbol? expr)
	 (env-ref env expr source-expr))
	((pair? expr)
	 (lint-expr expr env))))


;;-----------------------------------------------------------------------------
;; files

;; return true if KEY and ARGS is a bad # object
(define (read-bad-hash-error? key args)
  (and (>= (length args) 2)
       (string-contains (second args) "Unknown # object:")))

;; Any error occurring under read is thrown as read-error.  This is what
;; happens already in guile 1.7, but guile 1.6.3 only throws misc-error.
;;
(define (lint-read port)
  (lazy-catch #t
	      (lambda () (read port))
	      (lambda (key . args)
		(apply throw 'read-error args))))

(define (lint-port port env)
  (read-enable 'positions)
  (let more ()
    (let ((expr (lint-read port)))
      (if (not (eof-object? expr))
	  (begin
	    (cond ((pair? expr)
		   (lint-expr expr env))
		  ((symbol? expr)
		   (let ((source-expr (list #f)))
		     (set-source-properties-from-port! source-expr port)
		     (lint-object-source source-expr expr env))))
	    (more))))))

;; Reader errors like unexpected ")" print an error and abort the processing
;; of FILENAME, but the program continues.
(define (lint filename)
  (if option-verbose
      (format #t "~a:\n" filename))
  (if (not (access? filename R_OK))
      (format (current-error-port)
	      "guile-lint: cannot read file ~a\n" filename)
      (call-with-input-file filename
	(lambda (port)
	  (catch 'read-error
		 (lambda ()
		   (lint-subenv #f
				(lambda (env)
				  (lint-port port env))))
		 (lambda (key . args)
		   ;; guile 1.6.3 doesn't include the offending location in
		   ;; the error string, so use lint-error-port rather than a
		   ;; plain format print
		   (apply lint-error-port port (second args) (third args))
		   (newline)))))))


;;-----------------------------------------------------------------------------
;; command line

(define file-list '())

(let ((args            (cdr (program-arguments)))
      (orig-load-path  %load-path)
      (extra-load-path '()))
  (while
   (not (null? args))
   (let ((arg (first args)))
     
     (cond ((or (string=? arg "-e")
		(string=? arg "--eval"))
	    (eval-string (second args))
	    (set! args (cdr args)))
	   
	   ((or (string=? arg "-h")
		(string=? arg "--help"))
	    (display (string-append
		      "lint [options] file...
    -e, --eval <expr>   Eval some extra code
    -h, --help          Display this help
    -i, --ignore-case   Read case-insensitively
    -k, --keywords      Enable :foo keywords (as well as #:foo)
    -l, --load <file>   Load a file with extra code
    -L, --path <dir>    Prepend to %load-path
    --r5rs              Test with R5RS bindings, not guile extensions
    -v, --version       Display version
"))
	    (exit 0))
	   
	   ((or (string=? arg "-i")
		(string=? arg "--ignore-case"))
	    (read-disable 'case-sensitive))
	   
	   ((or (string=? arg "-k")
		(string=? arg "--keywords"))
	    (read-set! keywords 'prefix))
	   
	   ((or (string=? arg "-l")
		(string=? arg "--load"))
	    (load (second args))
	    (set! args (cdr args)))
	   
	   ((string=? arg "-L")
	    (set! extra-load-path (append extra-load-path
					  (list (second args))))
	    (set! %load-path (append extra-load-path orig-load-path))
	    (set! args (cdr args)))
	   
	   ((string=? arg "--r5rs")
	    (set! option-r5rs #t))
	   
	   ((or (string=? arg "-v")
		(string=? arg "--verbose"))
	    (set! option-verbose #t))
	   
	   ((string=? arg "--version")
	    (display (string-append "lint version " lint-version "\n"))
	    (exit 0))
	   
	   ((string-prefix? "-" arg)
	    (format (current-error-port) "guile-lint: unrecognised option: ~a" arg)
	    (exit 1))
	   
	   (else
	    (lint arg)))
     
     (set! args (cdr args)))))


;; Local variables:
;; mode: scheme
;; End: