#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do check-topodefs)' -s $0 "$@" # -*- scheme -*-
!#
;;; check-topodefs --- flag callsites appearing before defining form
;; Copyright (C) 2007, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version. There is NO WARRANTY. See file COPYING for details.
;;; Commentary:
;; Usage: check-topodefs [options] FILE...
;;
;; Scan each FILE for definitions and check that "usages" of those
;; definitions (i.e., simple references to the name of the definition)
;; do not occur in forms prior the definition. When this is not the
;; case, display to stderr:
;;
;; FILENAME:LINE:: (USAGE-TOP-LEVEL) LATER
;;
;; where USAGE-TOP-LEVEL is the name of the form (if deducible) where
;; the definition of LATER is used, and FILENAME:LINE is its location.
;; Options are:
;;
;; -I, --ignore NAME -- In addition to ‘define-module’ and
;; ‘use-modules’, ignore NAME, as well.
;;
;; -D, --defkey NAME -- Consider NAME a definition form, as well.
;; The list of standard definition forms are:
;; define define-public,
;; define* define*-public,
;; defmacro defmacro-public,
;; defmacro* defmacro*-public
;; define-macro
;;
;; -v, --verbose -- Display progress and scan information.
;; This includes filename, definition names,
;; and "distance" information.
;;
;; Note that both ‘-I’ and ‘-D’ add to their respective lists; there is
;; presently no way to specify that an item be removed. Also, both ‘-I’
;; and ‘-D’ can be given multiply; their args accumulate.
;;; Code:
(define-module (ttn-do check-topodefs)
#:export (main)
#:use-module ((ice-9 format) #:select (format))
#:use-module ((ttn-do zzz banalities) #:select (check-hv
qop<-args))
#:use-module ((ttn-do zzz personally) #:select (accumulator
FE HFE fso))
#:use-module ((scripts read-scheme-source)
#:select (read-scheme-source-silently
quoted?)))
(define *standard-ignored* '(define-module use-modules))
(define *standard-def-head* '(define define-public
define* define*-public
defmacro defmacro-public
defmacro* defmacro*-public
define-macro))
(define (check-proc verbose? ignore defkeys)
(define (def? x)
(memq x defkeys))
(lambda (filename)
(let ((serial (make-object-property))
(counter 0)
(results (read-scheme-source-silently filename))
(orig #f)
(new-names (accumulator)))
(FE results (lambda (ent)
(and (pair? ent)
(def? (car ent))
(let ((nn (let loop ((first (cadr ent)))
(if (symbol? first)
first
(loop (car first))))))
(set! (serial nn) counter)
(set! counter (1+ counter))
(new-names nn)))))
(set! new-names (new-names))
(set! orig new-names)
(and verbose? (format #t "checking: ~A -- ~A defs:~{ ~A~}~%"
filename (length new-names) new-names))
(let loop ((last #f) (ls results))
(define (next!) (loop (car ls) (cdr ls)))
(cond ((null? ls))
((or (not last)
(not (pair? (car ls)))
(eq? 'quote (caar ls))
(memq (caar ls) ignore))
(next!))
(else
(let* ((u (car ls))
(alist (quoted? 'following-form-properties last))
(name (or (and=> (assq-ref alist 'signature) car)
(cadr u)))
(seen (make-hash-table 97)))
(and (def? (car u))
(set! new-names (delq! name new-names)))
(letrec ((walk (lambda (form)
(cond ((not (pair? form))
(hashq-set! seen form #t))
((eq? 'quote (car form)))
((eq? 'case (car form))
(walk (cadr form))
(FE (cddr form)
(lambda (claws)
(walk (cdr claws)))))
(else (walk (car form))
(walk (cdr form)))))))
(walk u))
(let ((hit (accumulator))
(bef (accumulator))
(serial-name (serial name)))
(HFE (k v seen)
(and (not (eq? k name))
(def? (car u))
(memq k orig)
(let ((diff (- serial-name (serial k))))
(bef (list diff k))))
(and (memq k new-names)
(hit k)))
(set! bef (sort (bef) (lambda (a b)
(< (car a) (car b)))))
(and verbose?
(not (null? bef))
(fso "~A\t~A\t~A\t~A ~S ~S~%"
serial-name (length bef) (caar bef)
name (map car bef) (map cadr bef)))
(or (null? (hit))
(memq name ignore)
(let ((line (or (assq-ref alist 'line) 0)))
(format (current-error-port)
"~A:~A:: (~A)~{ ~S~}~%"
filename line name (hit))))))
(loop #f (cdr ls))))))))
(define (main/qop qop)
(define (symbolic opt base)
(append (cond ((qop opt) => (lambda (ls)
(map string->symbol ls)))
(else '()))
base))
(FE (qop '()) (check-proc (qop 'verbose)
(symbolic 'ignore *standard-ignored*)
(symbolic 'defkeys *standard-def-head*))))
(define (main args)
(check-hv args '((package . "ttn-do")
(version . "1.1")
(help . commentary)))
(main/qop
(qop<-args
args
'((ignore (single-char #\I) (value #t) (merge-multiple? #t))
(defkey (single-char #\D) (value #t) (merge-multiple? #t))
(verbose (single-char #\v))))))
;;; check-topodefs ends here