>From aae6097fcb28f163f2c279953499961f81361ad3 Mon Sep 17 00:00:00 2001
From: Kooda <address@hidden>
Date: Sat, 5 May 2018 12:51:37 +0200
Subject: [PATCH 1/3] Add a types.db consistency check test

---
 tests/runtests.bat             |  4 ++
 tests/runtests.sh              |  3 ++
 tests/types-db-consistency.scm | 72 ++++++++++++++++++++++++++++++++++
 3 files changed, 79 insertions(+)
 create mode 100644 tests/types-db-consistency.scm

diff --git a/tests/runtests.bat b/tests/runtests.bat
index 67fd2e6f..100e2f48 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -27,6 +27,10 @@ rmdir /q /s %CHICKEN_INSTALL_REPOSITORY%
 mkdir %CHICKEN_INSTALL_REPOSITORY%
 copy %TYPESDB% %CHICKEN_INSTALL_REPOSITORY%
 
+echo "======================================== types.db consistency ..."
+%interpret% -s types-db-consistency.scm %TYPESDB%
+if errorlevel 1 exit /b 1
+
 echo ======================================== version tests ...
 %compile% version-tests.scm
 if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 04a8ade3..35cd9920 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -63,6 +63,9 @@ rm -fr *.exe *.so *.o *.import.* a.out ../foo.import.* test-repository
 mkdir -p test-repository
 cp $TYPESDB test-repository/types.db
 
+echo "======================================== types.db consistency ..."
+$interpret -s types-db-consistency.scm ${TYPESDB}
+
 echo "======================================== version tests ..."
 $compile version-tests.scm
 ./a.out
diff --git a/tests/types-db-consistency.scm b/tests/types-db-consistency.scm
new file mode 100644
index 00000000..5bfb89ba
--- /dev/null
+++ b/tests/types-db-consistency.scm
@@ -0,0 +1,72 @@
+;; This test walks the types.db file and checks that symbols are what they are supposed to be.
+
+(import
+  (chicken base)
+  (chicken bitwise)
+  (chicken continuation)
+  (chicken read-syntax)
+  (chicken irregex)
+  (chicken memory)
+  (chicken process-context posix)
+  (chicken tcp)
+  srfi-4)
+
+(define ignored-symbols
+  '(;; internal procedures
+    chicken.irregex#irregex-dfa
+    chicken.irregex#irregex-dfa/search
+    chicken.irregex#irregex-nfa
+    chicken.irregex#irregex-flags
+    chicken.irregex#irregex-lengths
+    chicken.irregex#irregex-reset-matches!
+    chicken.irregex#irregex-new-matches
+    chicken.irregex#irregex-apply-match
+    chicken.irregex#irregex-search/matches))
+
+(define *error-code* 0)
+
+(define (warn msg . args)
+  (apply fprintf (current-error-port)
+         msg args)
+  (set! *error-code* 1))
+
+(define (deep o)
+  (cond ((pair? o)
+         (deep (car o)))
+        ((vector? o)
+         (deep (vector-ref o 0)))
+        (else o)))
+
+(define ((unknown sym) obj)
+  (warn "Unknown type '~a' for object: ~a~%"
+        sym obj))
+
+(define (symbol->predicate sym)
+  (case sym
+    ((procedure forall) procedure?)
+    ((fixnum) fixnum?)
+    ((float) flonum?)
+    ((list-of) list?)
+    ((symbol) symbol?)
+    ((input-port) input-port?)
+    ((output-port) output-port?)
+    (else (unknown sym))))
+
+(define (run-checks file checker)
+  (with-input-from-file file
+    (lambda ()
+      (port-for-each checker read))))
+
+(define (simple-checker entry)
+  (let* ((symbol (car entry))
+         (value (##sys#slot symbol 0))
+         (type (deep (cadr entry)))
+         (pred (symbol->predicate type)))
+    (unless (or (member symbol ignored-symbols)
+                (pred value))
+      (warn "Mismatch for ~a '~a': ~a~%"
+            type symbol value))))
+
+(run-checks (car (command-line-arguments))
+            simple-checker)
+(exit *error-code*)
-- 
2.17.0