From 0812009d1b90ed75cd9ab7f4d5b8c0454ea89685 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Wed, 18 Nov 2015 17:04:57 +0100
Subject: [PATCH 1/3] Mark external type declarations as declared.

By not being marked as "declared", types loaded from a types database
would be considered to be inferred via flow analysis.  When scrutinizing
procedure definitions, "initial-argument-types" and "variable-result"
would simply return '* or '(*) as the type, which doesn't match the
loaded declaration.  This had the effect of blocking specialization.

This fixes the most important part of #1219.
---
 distribution/manifest             | 1 +
 scrutinizer.scm                   | 1 +
 tests/runtests.bat                | 2 +-
 tests/runtests.sh                 | 2 +-
 tests/specialization-test-2.scm   | 6 ++++++
 tests/specialization-test-2.types | 4 ++++
 6 files changed, 14 insertions(+), 2 deletions(-)
 create mode 100644 tests/specialization-test-2.types

diff --git a/distribution/manifest b/distribution/manifest
index 34c6ae3..c40671e 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -174,6 +174,7 @@ tests/loopy-loop.scm
 tests/r5rs_pitfalls.scm
 tests/specialization-test-1.scm
 tests/specialization-test-2.scm
+tests/specialization-test-2.types
 tests/test-irregex.scm
 tests/re-tests.txt
 tests/lolevel-tests.scm
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 99da823..8cf2d14 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1778,6 +1778,7 @@
 		    "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
 		  name new old)))
 	     (mark-variable name '##compiler#type t)
+	     (mark-variable name '##compiler#declared-type)
 	     (when specs
 	       (install-specializations name specs)))))
        (read-file dbfile))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 9539bd4..e32aace 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -73,7 +73,7 @@ del /f /q foo.types foo.import.*
 if errorlevel 1 exit /b 1
 a.out
 if errorlevel 1 exit /b 1
-%compile% specialization-test-2.scm -types foo.types -specialize -debug ox
+%compile% specialization-test-2.scm -types foo.types -types specialization-test-2.types -specialize -debug ox
 if errorlevel 1 exit /b 1
 a.out
 if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 4bbd171..612e562 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -113,7 +113,7 @@ rm -f foo.types foo.import.*
 $compile specialization-test-1.scm -emit-type-file foo.types -specialize \
   -debug ox -emit-import-library foo
 ./a.out
-$compile specialization-test-2.scm -types foo.types -specialize -debug ox
+$compile specialization-test-2.scm -types foo.types -types specialization-test-2.types -specialize -debug ox
 ./a.out
 rm -f foo.types foo.import.*
 
diff --git a/tests/specialization-test-2.scm b/tests/specialization-test-2.scm
index e24e5cb..9b80922 100644
--- a/tests/specialization-test-2.scm
+++ b/tests/specialization-test-2.scm
@@ -26,3 +26,9 @@ return n;}
 
 (assert (handle-exceptions ex #t (bug855 '(#f)) #f))
 
+;; #1219: Specializations from databases loaded with "-types" should
+;; be applied.
+(define (specialize-me x)
+  (error "Not specialized!"))
+
+(assert (= (specialize-me 123) 123))
diff --git a/tests/specialization-test-2.types b/tests/specialization-test-2.types
new file mode 100644
index 0000000..8686522
--- /dev/null
+++ b/tests/specialization-test-2.types
@@ -0,0 +1,4 @@
+;; -*- Scheme -*-
+(specialize-me (procedure specialize-me (fixnum) fixnum)
+	       ((fixnum) #(1)))
+
-- 
2.1.4