libguile/guile-func-name-check

   1 ;;; guile-func-name-check                               -*- scheme -*-
   2
   3 ;; Copyright (C) 2000, 2001, 2006, 2010 Free Software Foundation, Inc.
   4 ;;
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU Lesser General Public License as
   7 ;; published by the Free Software Foundation; either version 3, or (at
   8 ;; your option) any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful, but
  11 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this software; see the file COPYING.LESSER.  If
  17 ;; not, write to the Free Software Foundation, Inc., 51 Franklin
  18 ;; Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 ;;; Commentary:
  21
  22 ;; This is a Guile Scheme script based on the AWK script
  23 ;; originally by Greg J. Badros <gjb@cs.washington.edu>.
  24 ;; It has the following improvements:
  25 ;;  - handle inhibition directives
  26 ;;  - ignore a string literal ‘FUNC_NAME’
  27 ;;  - on error, exit failurefully (after file is scanned)
  28 ;;  - written in Scheme :-D
  29
  30 ;;; Code:
  31
  32 (use-modules
  33  ((ice-9 regex) #:select (match:substring
  34                           match:end))
  35  ((ice-9 rdelim) #:select (read-line)))
  36
  37 (define fse                             ; "format string to error-port"
  38   (let ((cep (current-error-port)))
  39     (lambda (s . args)
  40       (apply simple-format cep s args))))
  41
  42 ;; Global non-procedure variables have LOUD names.
  43 (define FILENAME (cadr (command-line)))
  44 (define FUNC-NAME "")
  45 (define IN-A-FUNC? #f)
  46 (define INHIBIT? #f)
  47 (define LAST-LINE #f)
  48 (define NEXT-LINE-BETTER-BE-UNDEF #f)
  49 (define EXIT-VALUE #t)
  50
  51 (define (fatal lno s . args)
  52   (fse "~A:~A:*** " FILENAME lno)
  53   (apply fse s args)
  54   (fse "~%")
  55   (set! EXIT-VALUE #f))
  56
  57 (define MOE "Missing or erroneous")     ; constant
  58
  59 ;; By default, processing is uninhibited.  In the scanned file, the comment:
  60 ;;   /* guile-func-name-check: TEXT */
  61 ;; inhibits processing if TEXT is anything but "ok", and displays TEXT to stderr.
  62 ;; This is used in pairs.c, for example.
  63 (define check-directive
  64   (let ((rx (make-regexp "^.. guile-func-name-check: (.+) ..$")))
  65     (lambda (line lno)
  66       (and=> (regexp-exec rx line)
  67              (lambda (m)
  68                (set! INHIBIT? (not (string=? "ok" (match:substring m 1))))
  69                (fse "~A:~A: ~A~%" FILENAME lno
  70                     (substring line 3 (match:end m 1))))))))
  71
  72 ;; Extract the function name from "SCM_DEFINE (foo, ...".
  73 ;; FIXME: This loses if the open paren is on the next line.
  74 (define check-SCM_DEFINE
  75   (let ((rx (make-regexp "^SCM_DEFINE *.([^,]+)")))
  76     (lambda (line)
  77       (and=> (regexp-exec rx line)
  78              (lambda (m)
  79                (set! FUNC-NAME (match:substring m 1))
  80                (or INHIBIT? (set! IN-A-FUNC? #t)))))))
  81
  82 ;; Check that for "SCM_DEFINE (foo, ...)", we see:
  83 ;;   #define FUNC_NAME s_foo
  84 ;;   {
  85 ;; FIXME: This loses if #define is inside the curly brace.
  86 (define check-curly-open
  87   (let ((rx-curly (make-regexp "^\\{"))
  88         (rx-string (make-regexp "\".+\""))
  89         (rx-hash-define (make-regexp "^#define[ \t]+FUNC_NAME[ \t]+s_([^ \t]+)")))
  90     (define (proper)
  91       (string-append "#define FUNC_NAME s_" FUNC-NAME))
  92     (lambda (line lno)
  93       (and=> (and IN-A-FUNC? (regexp-exec rx-curly line))
  94              (lambda (m)
  95                (cond
  96                 ((regexp-exec rx-string LAST-LINE)
  97                  ;; Do nothing for C string-literal:
  98                  ;;  #define FUNC_NAME "foo"
  99                  )
 100                 ((regexp-exec rx-hash-define LAST-LINE)
 101                  ;; Found a well-formed #define, but does its name match?
 102                  => (lambda (m)
 103                       (or (string=? (match:substring m 1) FUNC-NAME)
 104                           (fatal lno "Mismatching FUNC_NAME.  Should be: `~A'"
 105                                  (proper)))))
 106                 (else
 107                  (fatal lno "~A `~A'" MOE (proper)))))))))
 108
 109 ;; If previous line closed the function, check that we see "#undef FUNC_NAME".
 110 ;; FIXME: This loses if #undef is inside the curly brace.
 111 (define check-undef
 112   (let ((rx (make-regexp "^#undef FUNC_NAME[ \t]*$")))
 113     (lambda (line lno)
 114       (cond (NEXT-LINE-BETTER-BE-UNDEF
 115              (or (regexp-exec rx line)
 116                  (fatal lno "~A #undef for ~A: Got `~A' instead."
 117                         MOE FUNC-NAME line))
 118              (set! IN-A-FUNC? #f)
 119              (set! FUNC-NAME "")
 120              (set! NEXT-LINE-BETTER-BE-UNDEF #f))))))
 121
 122 ;; Note function closing.
 123 (define check-curly-close
 124   (let ((rx (make-regexp "^\\}")))
 125     (lambda (line)
 126       (and IN-A-FUNC? (regexp-exec rx line)
 127            (set! NEXT-LINE-BETTER-BE-UNDEF #t)))))
 128
 129 ;; The main loop.
 130 (let ((p (open-input-file FILENAME)))
 131   (let loop ((lno 1))
 132     (let ((line (read-line p)))
 133       (or (eof-object? line)
 134           (begin (check-directive line lno)
 135                  (check-SCM_DEFINE line)
 136                  (check-curly-open line lno)
 137                  (check-undef line lno)
 138                  (check-curly-close line)
 139                  ;; Remember this line for the next cycle.
 140                  (set! LAST-LINE line)
 141                  (loop (1+ lno))))))
 142   (close-port p))
 143
 144 (exit EXIT-VALUE)
 145
 146 ;;; guile-func-name-check ends here