~ chicken-core (chicken-5) 69eb29536f48bbeee6ba56bcfa7265e0cd7afe51

commit 69eb29536f48bbeee6ba56bcfa7265e0cd7afe51
Author:     Kooda <kooda@upyum.com>
AuthorDate: Sat May 5 12:51:37 2018 +0200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sun May 13 15:33:41 2018 +0200

    Add a types.db consistency check test
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/distribution/manifest b/distribution/manifest
index b3ec51a0..a7fccbbd 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -238,6 +238,7 @@ tests/user-pass-tests.scm
 tests/version-tests.scm
 tests/messages-test.scm
 tests/messages.expected
+tests/types-db-consistency.scm
 tweaks.scm
 Makefile
 Makefile.android
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*)