From fe88996d070b790633de2e36bd212f935150580d Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Wed, 18 Nov 2015 19:28:08 +0100
Subject: [PATCH] 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.
---
 core.scm                          | 4 ++--
 distribution/manifest             | 1 +
 scrutinizer.scm                   | 8 +++++---
 tests/runtests.bat                | 2 +-
 tests/runtests.sh                 | 2 +-
 tests/specialization-test-2.scm   | 6 ++++++
 tests/specialization-test-2.types | 3 +++
 7 files changed, 19 insertions(+), 7 deletions(-)
 create mode 100644 tests/specialization-test-2.types

diff --git a/core.scm b/core.scm
index f9ae772..aeca37c 100644
--- a/core.scm
+++ b/core.scm
@@ -91,7 +91,7 @@
 ;   ##compiler#pure -> BOOL                                 referentially transparent
 ;   ##compiler#clean -> BOOL                                does not modify local state
 ;   ##compiler#type -> TYPE
-;   ##compiler#declared-type -> BOOL
+;   ##compiler#declared-type -> 'from-db | 'local | 'implicit
 
 ; - Source language:
 ;
@@ -1659,7 +1659,7 @@
 					 (symbol? (cadr type)))
 				(set-car! (cdr type) name))
 			      (mark-variable name '##compiler#type type)
-			      (mark-variable name '##compiler#declared-type)
+			      (mark-variable name '##compiler#declared-type 'local)
 			      (when pure
 				(mark-variable name '##compiler#pure #t))
 			      (when pred
diff --git a/distribution/manifest b/distribution/manifest
index 2b1c3bd..0160f89 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -176,6 +176,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 81c2f82..fed2a7a 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -88,7 +88,7 @@
 ; global symbol properties:
 ;
 ;   ##compiler#type            ->  TYPESPEC
-;   ##compiler#declared-type   ->  BOOL
+;   ##compiler#declared-type   ->  'from-db | 'local | 'implicit
 ;   ##compiler#predicate       ->  TYPESPEC
 ;   ##compiler#specializations ->  (SPECIALIZATION ...)
 ;   ##compiler#local-specializations ->  (SPECIALIZATION ...)
@@ -649,7 +649,7 @@
 			      ;; [2] sets property, but lambda has already been walked,
 			      ;; so no type-checks are generated (see also [1], above)
 			      ;; note that implicit declarations are not enforcing
-			      (mark-variable var '##compiler#declared-type)
+			      (mark-variable var '##compiler#declared-type 'implicit)
 			      (mark-variable var '##compiler#type rt))))))
 		    (when b
 		      (cond ((eq? 'undefined (cdr b)) (set-cdr! b rt))
@@ -1803,6 +1803,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 'from-db)
 	     (when specs
 	       (install-specializations name specs)))))
        (read-file dbfile))
@@ -1816,7 +1817,8 @@
       (##sys#hash-table-for-each
        (lambda (sym plist)
 	 (when (and (variable-visible? sym block-compilation)
-		    (variable-mark sym '##compiler#declared-type))
+		    (memq (variable-mark sym '##compiler#declared-type)
+			  '(local implicit)))
 	   (let ((specs (or (variable-mark sym '##compiler#specializations) '()))
 		 (type (variable-mark sym '##compiler#type))
 		 (pred (variable-mark sym '##compiler#predicate))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 9511ca5..7458989 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -86,7 +86,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 5b61404..b02b716 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -126,7 +126,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..7ca640d
--- /dev/null
+++ b/tests/specialization-test-2.types
@@ -0,0 +1,3 @@
+;; -*- Scheme -*-
+(specialize-me (procedure specialize-me (fixnum) fixnum)
+	       ((fixnum) #(1)))
-- 
2.1.4