~ chicken-core (chicken-5) 90c0d08e032d71f2633dfa9271e93ecad0adf95e

commit 90c0d08e032d71f2633dfa9271e93ecad0adf95e
Author:     felix <felix@z.(none)>
AuthorDate: Sat Mar 12 14:03:17 2011 +0100
Commit:     felix <felix@z.(none)>
CommitDate: Sat Mar 12 14:03:17 2011 +0100

    : allows rewrite rules; specialization tests

diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index b889f7d3..2b2659e5 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1116,7 +1116,7 @@
  ': '()
  (##sys#er-transformer
   (lambda (x r c)
-    (##sys#check-syntax ': x '(_ symbol _))
+    (##sys#check-syntax ': x '(_ symbol _ . _))
     (let* ((name (##sys#globalize (cadr x)))
 	   (type1 (##sys#strip-syntax (caddr x)))
 	   (name1 (##sys#strip-syntax (cadr x)))
@@ -1125,7 +1125,8 @@
 	     (syntax-error ': "invalid type syntax" name1 type1))
 	    ((memq #:csi ##sys#features) '(##core#undefined))
 	    (else
-	     `(##core#declare (type (,name ,type)))))))))
+	     `(##core#declare 
+	       (type (,name ,type ,@(cdddr x)))))))))
 
 
 (##sys#macro-subset me0 ##sys#default-macro-environment)))
diff --git a/chicken.scm b/chicken.scm
index efe52fb1..b84cf647 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -89,18 +89,24 @@
 			     options)) ) 
 		   ((3)
 		    (set! options
-		      (cons* 'optimize-leaf-routines 'inline 'inline-global 'unboxing 'local
+		      (cons* 'optimize-leaf-routines 'inline 'inline-global
+			     'unboxing 'local
+			     ;;XXX 'specialize
 			     options) ) )
 		   ((4)
 		    (set! options
-		      (cons* 'optimize-leaf-routines 'inline 'inline-global 'unboxing 
+		      (cons* 'optimize-leaf-routines 'inline 'inline-global
+			     'unboxing 
+			     ;;XXX 'specialize
 			     'local 'unsafe
 			     options) ) )
 		   (else
 		    (when (>= level 5)
 		      (set! options 
 			(cons* 'disable-interrupts 'no-trace 'unsafe 'block
-			       'optimize-leaf-routines 'lambda-lift 'no-lambda-info
+			       'optimize-leaf-routines 'lambda-lift 
+			       'no-lambda-info
+			       ;;XXX 'specialize
 			       'inline 'inline-global 'unboxing
 			       options) ) ) ) )
 		 (loop (cdr rest)) ) )
diff --git a/compiler.scm b/compiler.scm
index 277b5f92..6cb63f89 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1466,7 +1466,9 @@
        ((type)
 	(for-each
 	 (lambda (spec)
-	   (if (not (and (list? spec) (>= 2 (length spec)) (symbol? (car spec))))
+	   (if (not (and (list? spec)
+			 (>= 2 (length spec))
+			 (symbol? (car spec))))
 	       (warning "illegal type declaration" (##sys#strip-syntax spec))
 	       (let ((name (globalize (car spec)))
 		     (type (##sys#strip-syntax (cadr spec))))
diff --git a/distribution/manifest b/distribution/manifest
index abdc28fe..709d9d9d 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -156,6 +156,8 @@ tests/test.scm
 tests/loopy-test.scm
 tests/loopy-loop.scm
 tests/r5rs_pitfalls.scm
+tests/specialization-test-1.scm
+tests/specialization-test-2.scm
 tests/test-irregex.scm
 tests/re-tests.txt
 tests/lolevel-tests.scm
diff --git a/support.scm b/support.scm
index e79395a8..6753e746 100644
--- a/support.scm
+++ b/support.scm
@@ -747,7 +747,8 @@
        (lambda (sym plist)
 	 (when (variable-visible? sym)
 	   (and-let* ((type (variable-mark sym '##core#declared-type)))
-	     (let ((specs (or (variable-mark sym '##core#specializations) '())))
+	     (let ((specs
+		    (or (variable-mark sym '##core#specializations) '())))
 	       (pp (cons* sym type specs))))))
        db)
       (print "; END OF FILE"))))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index e544c7d9..2e4bcfc9 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -73,6 +73,14 @@ fi
 
 diff -bu scrutiny.out scrutiny.expected
 
+echo "======================================== specialization tests ..."
+rm foo.types
+$compile specialization-test-1.scm -emit-type-file foo.types -specialize \
+  -debug ox
+./a.out
+$compile specialization-test-2.scm -types foo.types -specialize -debug ox
+./a.out
+
 echo "======================================== callback tests ..."
 $compile callback-tests.scm
 ./a.out
diff --git a/tests/specialization-test-1.scm b/tests/specialization-test-1.scm
new file mode 100644
index 00000000..41e7ea37
--- /dev/null
+++ b/tests/specialization-test-1.scm
@@ -0,0 +1,23 @@
+;;;; specialization-test-1.scm
+
+
+(module main ()
+(import scheme chicken foreign)
+
+#>
+static int inlined(int i) {
+static int n = 0;
+n += i;
+return n;}
+<#
+
+(: foo (fixnum -> fixnum)
+   ((fixnum) (##core#inline "inlined" #(1))))
+(define (foo i)
+  (print "foo: " i)
+  0)
+
+(assert (zero? (foo 1.0)))
+(assert (= 1 (foo 1)))
+
+)
diff --git a/tests/specialization-test-2.scm b/tests/specialization-test-2.scm
new file mode 100644
index 00000000..82763f40
--- /dev/null
+++ b/tests/specialization-test-2.scm
@@ -0,0 +1,21 @@
+;;;; specialization-test-2.scm
+
+
+(module main ()
+(import scheme chicken foreign)
+
+#>
+static int inlined(int i) {
+static int n = 0;
+n += i;
+return n;}
+<#
+
+(define (foo i)
+  (print "foo: " i)
+  0)
+
+(assert (zero? (foo 1.0)))
+(assert (= 1 (foo 1)))
+
+)