From bcaa72f3db8dae4f416dae0b7989c701652ba9b0 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Thu, 12 Jul 2012 19:23:53 -0700
Subject: [PATCH] doc/gtk/check.scm: Compare @deffns against package exports.

---
 doc/gtk/check.scm | 113 ++++++++++++++++++++++++++++++++++++++++++++++
 src/Makefile.in   |   9 +++-
 2 files changed, 121 insertions(+), 1 deletion(-)
 create mode 100644 doc/gtk/check.scm

diff --git a/doc/gtk/check.scm b/doc/gtk/check.scm
new file mode 100644
index 000000000..e1d513ed2
--- /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 976ab85e7..ab8cce9b2 100644
--- 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
-- 
2.25.1