doc/gtk/check.scm: Compare @deffns against package exports.

diff --git a/doc/gtk/check.scm b/doc/gtk/check.scm
new file mode 100644 (file)
index 0000000..e1d513e
--- /dev/null
+++ b/doc/gtk/check.scm
@@ -0,0 +1,113 @@
+#| -*-Scheme-*-
+
+   Check that every binding in (gtk) or exported to () has a
+   corresponding @deffn in gtk.texinfo. |#
+
+(load-option 'cref)
+(define read-package-model)
+(define pmodel/packages)
+(define package/name)
+(define package/bindings)
+(define package/links)
+(define link/source)
+(define link/destination)
+(define binding/package)
+(define binding/name)
+(let ((cref (->environment '(cross-reference))))
+  (set! read-package-model (access read-package-model cref))
+  (set! pmodel/packages (access pmodel/packages cref))
+  (set! package/name (access package/name cref))
+  (set! package/bindings (access package/bindings cref))
+  (set! package/links (access package/links cref))
+  (set! link/source (access link/source cref))
+  (set! link/destination (access link/destination cref))
+  (set! binding/package (access binding/package cref))
+  (set! binding/name (access binding/name cref)))
+
+(define (deffn-name line)
+  (let ((regs (re-string-match
+              "@deffn \\(Class\\|Procedure\\|{Generic Procedure}\\) \\([-A-Za-z0-9<>?!+.]+\\)"
+              line)))
+    (if regs
+       (intern (re-match-extract line regs 2))
+       (error "Could not find binding name:" line))))
+
+(define (texinfo-deffns lines)
+  (let ((len (vector-length lines)))
+    (let loop ((i 0) (deffns '()))
+      (if (fix:< i len)
+         (let ((line (vector-ref lines i)))
+           (loop (fix:1+ i)
+                 (if (string-prefix? "@deffn " line)
+                     (cons (deffn-name line) deffns)
+                     deffns)))
+         deffns))))
+
+(define (read-lines port)
+  (let loop ()
+    (let ((line (read-line port)))
+      (if (eof-object? line)
+         '()
+         (cons line (loop))))))
+
+(define (pmodel/find-package pmodel package-name)
+  (find-matching-item (pmodel/packages pmodel)
+                     (lambda (p) (equal? package-name (package/name p)))))
+
+(define (pmodel/global-exports pmodel)
+  (define (global-exports package)
+    (append-map! (lambda (link)
+                  (if (eq? '() (package/name
+                                (binding/package
+                                 (link/destination link))))
+                      (list (binding/name (link/destination link)))
+                      '()))
+                (package/links package)))
+  (append-map! global-exports (pmodel/packages pmodel)))
+
+(define (pmodel/package-bindings pmodel package-name)
+  (let ((package (pmodel/find-package pmodel package-name)))
+    (if package
+       (map binding/name (package/bindings package))
+       (error "No such package:" package-name))))
+
+(define (duplicates listset)
+  (let loop ((items listset) (duplicates '()))
+    (cond ((null? items)
+          (reverse! duplicates))
+         ((memq (car items) (cdr items))
+          (if (memq (car items) duplicates)
+              (loop (cdr items) duplicates)
+              (loop (cdr items) (cons (car items) duplicates))))
+         (else
+          (loop (cdr items) duplicates)))))
+
+(define (minus set1 set2)
+  (let loop ((items set1) (difference '()))
+    (cond ((null? items)
+          difference)
+         ((memq (car items) set2)
+          (loop (cdr items) difference))
+         (else
+          (loop (cdr items) (cons (car items) difference))))))
+
+(define (check)
+  (let* ((texinfo (list->vector (call-with-input-file "../doc/gtk/gtk.texinfo"
+                                 read-lines)))
+        (deffns (texinfo-deffns texinfo))
+        (dups (duplicates deffns))
+        (pmodel (with-working-directory-pathname "gtk/"
+                  (lambda ()
+                    (read-package-model "gtk" microcode-id/operating-system))))
+        (bindings (append (pmodel/global-exports pmodel)
+                          (pmodel/package-bindings pmodel '(gtk))))
+        (missing (minus bindings deffns))
+        (extras (minus deffns bindings)))
+    (if (not (null? dups))
+       (for-each (lambda (name) (warn "multiple-descriptions:" name)) dups))
+    (if (not (null? extras))
+       (for-each (lambda (name) (warn "not bound:" name)) extras))
+    (if (not (null? missing))
+       (for-each (lambda (name) (warn "not documented:" name)) missing))))
+
+(check)
\ No newline at end of file

diff --git a/src/Makefile.in b/src/Makefile.in
index 976ab85e720cc40e23e8096faa304b37308c2d73..ab8cce9b293befaae511b48e26bd85f8876cb6ad 100644 (file)
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -78,7 +78,14 @@ all: @ALL_TARGET@
 
 check:
        ./microcode/scheme --library lib --batch-mode \
-         --load ../tests/check.scm </dev/null
+         --load ../tests/check </dev/null
+       @if [ -d ../doc/gtk ]; then \
+         echo ./microcode/scheme --load ../doc/gtk/check; \
+         ./microcode/scheme --library lib --batch-mode \
+           --load ../doc/gtk/check </dev/null; \
+       else \
+         echo "; Warning: Gtk documentation not checked."; \
+       fi
 
 all-native: compile-microcode
        @$(top_srcdir)/etc/compile.sh "$(MIT_SCHEME_EXE)" --batch-mode