From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Fri, 14 May 2010 23:59:39 +0000 (-0500)
Subject: Merge branch 'master' of git://factorcode.org/git/factor into propagation
X-Git-Tag: 0.97~4697
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=05290ee1b1bf26f6c6eb878d1658c542e0ac4284

Merge branch 'master' of git://factorcode.org/git/factor into propagation

Conflicts:

	basis/compiler/tree/propagation/propagation-tests.factor
---

05290ee1b1bf26f6c6eb878d1658c542e0ac4284
diff --cc basis/compiler/tree/propagation/propagation-tests.factor
index 07024f7e0d,e738a70fc3..d083b39b5b
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@@ -977,41 -977,21 +977,60 @@@ M: tuple-with-read-only-slot clon
      [ string-nth ] final-info first interval>> 0 23 2^ [a,b] =
  ] unit-test
  
 +! Optimization on instance?
 +[ f ] [ [ { number } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test
 +
 +UNION: ?fixnum fixnum POSTPONE: f ;
 +[ t ] [ [ { ?fixnum } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test
 +[ t ] [ [ { fixnum } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test
 +
 +! Actually check to make sure that the generated code works properly
 +: instance-test-1 ( x -- ? ) { ?fixnum } declare fixnum instance? ;
 +: instance-test-2 ( x -- ? ) { number } declare fixnum instance? ;
 +: instance-test-3 ( x -- ? ) { POSTPONE: f } declare \ f instance? ;
 +
 +[ t ] [ 1 instance-test-1 ] unit-test
 +[ f ] [ f instance-test-1 ] unit-test
 +[ t ] [ 1 instance-test-2 ] unit-test
 +[ f ] [ 1.1 instance-test-2 ] unit-test
 +[ t ] [ f instance-test-3 ] unit-test
 +
 +[ t ] [ [ { ?fixnum } declare >fixnum ] { >fixnum } inlined? ] unit-test
 +[ f ] [ [ { integer } declare >fixnum ] { >fixnum } inlined? ] unit-test
 +
 +[ f ] [ [ { word } declare parent-word ] { parent-word } inlined? ] unit-test
 +
 +! Make sure guarded method inlining installs the right dependencies
 +
 +[ ] [
 +    "IN: compiler.tree.propagation.tests
 +    USING: kernel.private accessors ;
 +    TUPLE: foo bar ;
 +    UNION: ?foo foo POSTPONE: f ;
 +    : baz ( ?foo -- bar ) { ?foo } declare bar>> ;" eval( -- )
 +] unit-test
 +
 +[ 3 ] [ "USE: kernel IN: compiler.tree.propagation.tests 3 foo boa baz" eval( -- x ) ] unit-test
 +
 +[ ] [ "IN: compiler.tree.propagation.tests TUPLE: foo baz bar ;" eval( -- ) ] unit-test
 +
 +[ 3 ] [ "USE: kernel IN: compiler.tree.propagation.tests 2 3 foo boa baz" eval( -- x ) ] unit-test
++
+ ! Non-zero displacement for <displaced-alien> restricts the output type
+ [ t ] [
+     [ { byte-array } declare <displaced-alien> ] final-classes
+     first byte-array alien class-or class=
+ ] unit-test
+ 
+ [ V{ alien } ] [
+     [ { alien } declare <displaced-alien> ] final-classes
+ ] unit-test
+ 
+ [ t ] [
+     [ { POSTPONE: f } declare <displaced-alien> ] final-classes
+     first \ f alien class-or class=
+ ] unit-test
+ 
+ [ V{ alien } ] [
+     [ { byte-array } declare [ 10 bitand 2 + ] dip <displaced-alien> ] final-classes
+ ] unit-test