Re: Removing breakpoints/debugging stuff from CVS head

[Thien-Thi Nguyen]

   From: Neil Jerram <address@hidden>
   Date: Sun, 12 Jun 2005 08:59:46 +0100

   Would anyone object if I deleted my work on breakpoints and
   debugging-in-Emacs from CVS head?

that would be very cool (not that it is being deleted, but that it is
being positioned independently); i imagine it will be easier to
integrate into Guile 1.4.x as a result.  go for it!

btw, below is a lint modified to handle internal defines when checking
for free variables.  it will probably undergo further changes before
release, but in areas largely unrelated to internal defines.

thi


_____________________________________________
#!/bin/sh
exec ${GUILE-guile} -e '(scripts lint)' -s $0 "$@" # -*- scheme -*-
!#
;;; lint --- Preemptive checks for coding errors in Guile Scheme code

;;      Copyright (C) 2002,2003,2004,2005 Free Software Foundation, Inc.
;;
;; This program 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.
;;
;; 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
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Neil Jerram

;;; Commentary:

;; Usage: lint [options] FILE1 FILE2 ...
;;
;; Perform various preemptive checks for coding errors in Guile Scheme
;; code.  Options are:
;;
;;  -m, --module NAME  -- use NAME as the module name, for files
;;                        that do not have a `define-module' form;
;;                        default: `(guile-user)'
;;
;; Here are the available checks (in order of application):
;;
;;  *readable
;;   freevars
;;
;; The * means that if the check fails, lint exits with error status.
;; The rest of this help message explains the checks in more detail.
;;
;;
;; Readability
;; -----------
;;
;; This checks for file readability as well as the absense of `#.'
;; (hash-dot) reader macros, which is a risky practice.
;;
;;
;; 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.
;;
;;
;; Usage from a Scheme program:
;;   (lint filename [tests...]) => alist
;;
;; TESTS, a list of symbols, specifies tests to run.  If omitted,
;; run all tests.  ALIST maps each test name to its result.

;;; Code:

(define-module (scripts lint)
  #:use-module ((ice-9 gumm) #:select (module-name->fob eval-in-module))
  #:autoload (ice-9 editing-buffer) (editing-buffer)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:autoload (ice-9 common-list) (uniq remove-if)
  #:use-module (ice-9 format)
  #:export (lint))

(define (check-readability filename)
  ;; For safety, do textual checks before actually applying `read'.
  (and (access? filename R_OK)
       (editing-buffer (open-input-file filename)
         (goto-char (point-min))
         (and
          ;; shell script header
          (or (not (looking-at "#!"))
              (and (re-search-forward "^!#\n" (point-max) #t)
                   (begin (delete-region (point-min) (point))
                          #t)))
          ;; full-line comments
          (let loop ()
            (cond ((re-search-forward "^[ \t]*;.*\n*" (point-max) #t)
                   (replace-match "")
                   (loop))
                  (else #t)))
          ;; strings
          (goto-char (point-min))
          (let ((p (buffer-port)))
            (let loop ()
              (or (not (re-search-forward "[^\\][\"]" (point-max) #t))
                  (let ((beg (1- (point))))
                    (forward-char -1)
                    (and (string? (read p))
                         (begin (delete-region (1+ beg) (1- (point)))
                                (loop)))))))
          ;; trailing-line comments
          (goto-char (point-min))       ; like this one
          (let loop ()
            (or (not (re-search-forward ";.*$" (point-max) #t))
                (begin (replace-match "")
                       (loop))))
          ;; hash-dot
          (goto-char (point-min))
          (not (search-forward "#." (point-max) #t))))))

(define *default-module-name* '(guile-user))

(define (scan-file-for-module-name filename)
  (with-input-from-file filename
    (lambda ()
      (let loop ((x (read)))
        (cond ((eof-object? x)
               *default-module-name*)
              ((and (pair? x)
                    (eq? (car x) 'define-module))
               (cadr x))
              (else (loop (read))))))))

(define (oe:new!)                       ; one environment (scope)
  (make-hash-table 31))

(define (oe:add! oe symbol)
  (hashq-set! oe symbol #t))

(define (oe:in? oe symbol)
  (hashq-ref oe symbol))

(define (newenv inits env)
  (let ((oe (oe:new!)))
    (for-each (lambda (symbol)
                (oe:add! oe symbol))
              inits)
    (cons oe env)))

(define (memenv? symbol env)
  (or-map (lambda (oe)
            (oe:in? oe symbol))
          env))

(define (collect ls mogrify)
  ;; This proc is similar to `pick-mappings' in (ice-9 common-list),
  ;; except that args are inverted, order is maintained, and improper
  ;; lists are handled.
  (let ((box (list #f)))
    (let loop ((ls ls) (tp box))
      (if (null? ls)
          (cdr box)                     ; rv
          (let* ((p? (pair? ls))
                 (next (if p? (cdr ls) '()))
                 (item (mogrify (if p? (car ls) ls))))
            (loop next (cond ((not item) tp)
                             (else (set-cdr! tp (list item))
                                   (cdr tp)))))))))

(define (scan-file-for-free-variables filename)

  (define (app! ls)
    (apply append! ls))

  (define (a1p! one ls)
    (app! (cons one ls)))

  (define (procedure?/name x)
    (and (pair? x)
         (eq? 'define (car x))          ; todo: generalize
         (pair? (cdr x))
         (let* ((rest (cdr x))
                (name (car rest)))
           (if (symbol? name)
               (letrec ((ltu?           ;-D lambda the ultimate
                         (lambda (form)
                           (and (pair? form)
                                (< 2 (length form))
                                (case (car form)
                                  ((let let* letrec)
                                   (ltu? (car (last-pair form))))
                                  ((lambda lambda*) #t)
                                  (else #f))))))
                 (and (ltu? (cadr rest))
                      name))
               (let loop ((name (car name)))
                 (if (symbol? name)
                     name
                     (loop (car name))))))))

  (define (dfv x locals)                ; detect free variables

    (define (ext new)
      (newenv (if (pair? new) new (list new)) locals))

    (define (iseq forms new)            ; internal (non top-level)
      (seq forms (ext new)
           (let ((acceptable? #t))
             ;; Ignore internal `define' forms not at scope beginning.
             (lambda (form)
               (and acceptable?
                    (let ((name (procedure?/name form)))
                      (or name (set! acceptable? #f))
                      name))))))

    (define (dfv/recurse)
      (app! (collect x (lambda (form)
                         (let ((fv (dfv form locals)))
                           (and (not (null? fv))
                                fv))))))

    (define (formal-names from)
      (collect (from x) (lambda (formal)
                          (and (not (keyword? formal))
                               (if (pair? formal)
                                   (car formal)
                                   formal)))))

    (cond ((symbol? x)
           (if (memenv? x locals) '() (list x)))

          ((and (pair? x) (symbol? (car x)))
           (case (car x)
             ((define-module use-modules 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))
                    (letvars (map car (cadr x))))
                (append (app! (map (lambda (binding)
                                     (dfv (cadr binding)
                                          (if letrec? (ext letvars) locals)))
                                   (cadr x)))
                        (iseq (cddr x) letvars))))

             ((let* and-let*)
              ;; Handle bindings recursively.
              (let ((bindings (cadr x)))
                (if (pair? bindings)
                    (append (dfv (cadr (car bindings)) locals)
                            (dfv `(let* ,(cdr bindings) ,@(cddr x))
                                 (ext (caar bindings))))
                    (iseq (cddr x) '()))))

             ((define define-public define-macro)
              (dfv (if (pair? (cadr x))
                       `(lambda ,(cdadr x) ,@(cddr x))
                       (caddr x))
                   locals))

             ((lambda lambda*)
              (iseq (cddr x) (formal-names cadr)))

             ((receive)
              (append (dfv (caddr x) locals)
                      (iseq (cdddr x) (formal-names cadr))))

             ((define-method define* define*-public)
              (iseq (cddr x) (formal-names cdadr)))

             ((define-class)
              ;; Avoid picking up slot names at the start of slot
              ;; definitions.
              (app! (map (lambda (slot/option)
                           (dfv (if (pair? slot/option)
                                    (cdr slot/option)
                                    slot/option)
                                locals))
                         (cdddr x))))

             ((case)
              (a1p! (dfv (cadr x) locals)
                    (map (lambda (case)
                           (dfv (cdr case) locals))
                         (cddr x))))

             ((cond)
              (app! (map (lambda (sub)
                           (append (let ((condition (car sub)))
                                     (if (eq? 'else condition)
                                         '()
                                         (dfv condition locals)))
                                   (let ((actions (cdr sub)))
                                     (cond ((not (pair? actions))
                                            (dfv actions locals))
                                           ((eq? '=> (car actions))
                                            (dfv (cadr actions) locals))
                                           (else
                                            (dfv actions locals))))))
                         (cdr x))))

             ((do)
              (let* ((bindings (cadr x))
                     (do/locals (ext (map car bindings)))
                     (do/dfv (lambda (forms)
                               (app! (map (lambda (form)
                                            (dfv form do/locals))
                                          forms)))))
                (append (app! (map (lambda (binding)
                                     (do/dfv (cdr binding)))
                                   bindings))
                        (do/dfv (caddr x))
                        (do/dfv (cdddr x)))))

             ((unquote unquote-splicing)
              (dfv (cadr x) locals))

             (else (dfv/recurse))))

          ((pair? x)
           (dfv/recurse))

          (else '())))

  (define (seq forms env relevant)
    (for-each (lambda (name)
                (oe:add! (car env) name))
              (collect forms relevant))
    (app! (map (lambda (x)
                 (dfv x env))
               forms)))

  ;; do it!
  (seq (let ((p (open-input-file filename))
             (box (list #f)))
         (let loop ((form (read p)) (tp box))
           (cond ((eof-object? form)
                  (close-port p)
                  (cdr box))            ; file forms
                 (else
                  (set-cdr! tp (list form))
                  (loop (read p) (cdr tp))))))
       (newenv '() '())
       (lambda (form)
         (or (procedure?/name form)
             (and (pair? form)
                  (case (car form)      ; todo: generalize
                    ((define defmacro)
                     (and (symbol? (cadr form))
                          (cadr form)))
                    ((define-macro)
                     (and (symbol? (caadr form))
                          (caadr form)))
                    (else #f)))))))

(define (check-free-variables filename)
  (let* ((module (module-name->fob (scan-file-for-module-name filename)))
         (check (lambda (sym)
                  (catch #t
                         (lambda () (eval-in-module sym module) #t)
                         (lambda args #f)))))
    (remove-if check (uniq (scan-file-for-free-variables filename)))))

(define (>>freevars filename vars)
  (let ((none? (null? vars)))
    (format #t "~:[U~;No u~]nresolved free variables in address@hidden:~]\n"
            none? filename (not none?)))
  (format #t "~{\t~A\n~}" vars))

;; selection

(define *tests*
  `((exists   #t #:filename ,file-exists? #f)
    (readable #t #:filename ,check-readability #f)
    (freevars #f #:filename ,check-free-variables ,>>freevars)))

(define t:fatal?  car)
(define t:argtype cadr)
(define t:proc    caddr)
(define t:report  cadddr)

(define (lint filename . tests)
  (and (null? tests) (set! tests (map car *tests*)))
  (map (lambda (name)
         (cons name
               (cond ((assq-ref *tests* name)
                      => (lambda (ent)
                           (let ((res ((t:proc ent)
                                       (case (t:argtype ent)
                                         ((#:filename) filename)
                                         (else (error "bad t:argtype"))))))
                             (and (t:fatal? ent)
                                  (not res)
                                  (error
                                   (format #f "fatal result for test `~A': ~A"
                                           name filename)))
                             res)))
                     (else
                      "no such test"))))
       tests))

;; output driver

(define (lint-main . files)
  (for-each (lambda (filename)
              (for-each
               (lambda (res)
                 (let* ((entry (assq-ref *tests* (car res)))
                        (report (t:report entry)))
                   (and report (report (case (t:argtype entry)
                                         ((#:filename) filename)
                                         (else (error "bad t:argtype")))
                                       (cdr res)))))
               (lint filename)))
            files))

(define (main args)
  (HVQC-MAIN args (lambda (qop)
                    (qop 'module (lambda (s)
                                   (set! *default-module-name*
                                         (with-input-from-string s read))))
                    (apply lint-main (qop '())))
             '(usage . commentary)
             '(package . "Guile")
             '(option-spec (module (single-char #\m) (value #t)))))

;;; lint ends here