~ chicken-core (chicken-5) a8f97697496856c2675964b5c3658276b8f33466

commit a8f97697496856c2675964b5c3658276b8f33466
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Wed Nov 18 19:28:08 2015 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Mon Jan 11 08:56:49 2016 +1300

    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.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/core.scm b/core.scm
index f9ae772f..aeca37c4 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 2b1c3bde..0160f893 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 81c2f823..fed2a7ab 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 9511ca57..7458989e 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 5b614041..b02b716e 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 e24e5cbf..9b80922d 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 00000000..7ca640d9
--- /dev/null
+++ b/tests/specialization-test-2.types
@@ -0,0 +1,3 @@
+;; -*- Scheme -*-
+(specialize-me (procedure specialize-me (fixnum) fixnum)
+	       ((fixnum) #(1)))