entry effect code work

library/bootstrap/boot-stage2.factor

@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -45,6 +45,7 @@ USE: namespaces
     "/library/generic/builtin.factor"
     "/library/generic/predicate.factor"
     "/library/generic/union.factor"
+    "/library/generic/complement.factor"
     "/library/generic/traits.factor"
 
     "/version.factor"

library/bootstrap/boot.factor

@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -86,6 +86,7 @@ USE: hashtables
     "/library/generic/builtin.factor" parse-resource append,
     "/library/generic/predicate.factor" parse-resource append,
     "/library/generic/union.factor" parse-resource append,
+    "/library/generic/complement.factor" parse-resource append,
     "/library/generic/traits.factor" parse-resource append,
 
     "/library/bootstrap/init.factor" parse-resource append,

library/generic/complement.factor

@@ -0,0 +1,76 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2005 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: generic
+USE: errors
+USE: hashtables
+USE: kernel
+USE: lists
+USE: namespaces
+USE: parser
+USE: strings
+USE: words
+USE: vectors
+USE: math
+
+! Complement metaclass, contains all objects not in a certain class.
+SYMBOL: complement
+
+complement [
+    "complement" word-property builtin-supertypes
+    num-types count
+    difference
+] "builtin-supertypes" set-word-property
+
+complement [
+    ( generic vtable definition class -- )
+    drop num-types [ >r 3dup r> add-method ] times* 3drop
+] "add-method" set-word-property
+
+complement 90 "priority" set-word-property
+
+complement [
+    swap "complement" word-property
+    swap "complement" word-property
+    class< not
+] "class<" set-word-property
+
+: complement-predicate ( complement -- list )
+    "predicate" word-property [ not ] append ;
+
+: define-complement ( class predicate complement -- )
+    [ complement-predicate define-compound ] keep
+    dupd "complement" set-word-property
+    complement define-class ;
+
+: COMPLEMENT: ( -- class predicate definition )
+    #! Followed by a class name, then a complemented class.
+    CREATE
+    dup intern-symbol
+    dup predicate-word
+    [ dupd unit "predicate" set-word-property ] keep
+    scan-word define-complement ; parsing

library/generic/generic.factor

@@ -80,6 +80,7 @@ USE: math-internals
 : class-ord ( class -- n ) metaclass "priority" word-property ;
 
 : class< ( cls1 cls2 -- ? )
+    #! Test if class1 is a subclass of class2.
     over metaclass over metaclass = [
         dup metaclass "class<" word-property call
     ] [

library/generic/union.factor

@@ -78,13 +78,13 @@ union [ 2drop t ] "class<" set-word-property
         ] keep ?
     ] map
     [ union-predicate define-compound ] keep
-    "members" set-word-property ;
+    dupd "members" set-word-property
+    union define-class ;
 
 : UNION: ( -- class predicate definition )
     #! Followed by a class name, then a list of union members.
     CREATE
     dup intern-symbol
-    dup union define-class
     dup predicate-word
     [ dupd unit "predicate" set-word-property ] keep
     [ define-union ] [ ] ; parsing

library/inference/branches.factor

@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -195,13 +195,25 @@ SYMBOL: cloned
     r> swap #label dataflow, [ node-label set ] bind
     meta-r set meta-d set d-in set ;
 
-: static-branch? ( value -- )
-    literal? branches-can-fail? not and ;
+: boolean-value? ( value -- ? )
+    #! Return if the value's boolean valuation is known.
+    value-class
+    dup \ f = swap
+    builtin-supertypes
+    \ f builtin-supertypes intersection not
+    or ;
+
+: boolean-value ( value -- ? )
+    #! Only valid if boolean? returns true.
+    value-class \ f = not ;
+
+: static-branch? ( value -- ? )
+    boolean-value? branches-can-fail? not and ;
 
 : static-ifte ( true false -- )
     #! If the branch taken is statically known, just infer
     #! along that branch.
-    dataflow-drop, pop-d literal-value [ drop ] [ nip ] ifte
+    dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte
     gensym [
         dup value-recursion recursive-state set
         literal-value infer-quot
@@ -212,7 +224,7 @@ SYMBOL: cloned
     #! unify.
     2list >r 1 meta-d get vector-tail* #ifte r>
     pop-d [
-        dup \ object cons ,
+        dup \ general-t cons ,
         \ f cons ,
     ] make-list zip ( condition )
     infer-branches ;

library/inference/words.factor

@@ -199,14 +199,16 @@ M: symbol (apply-word) ( word -- )
         >r 1 + r>
     ] each 2drop ;
 
-: apply-entry-effect ( word -- )
+: (recursive-word) ( word label effect -- )
+    >r [ #call-label ] [ #call ] ?ifte r> (consume/produce) ;
+
+: apply-entry-effect ( word label -- )
     #! Called at a recursive call point. We need this to compute
     #! the set of literals that is retained across a recursive
     #! call -- this is NOT the same as the literals present on
     #! entry. This word mutates the inferring-entry-effect
     #! vector.
-    base-case uncons raise
-    inferring-entry-effect get swap unify-entry-effect ;
+    over base-case uncons raise present-effect (recursive-word) ;
 
 : recursive-word ( word label -- )
     #! Handle a recursive call, by either applying a previously
@@ -216,10 +218,9 @@ M: symbol (apply-word) ( word -- )
         drop no-base-case
     ] [
         inferring-entry-effect get [
-            apply-entry-effect  "Bail out" throw
+            apply-entry-effect
         ] [
-            dup [ #call-label ] [ #call ] ?ifte
-            rot base-case present-effect (consume/produce)
+            over base-case present-effect (recursive-word)
         ] ifte
     ] ifte ;
 

library/kernel.factor

@@ -76,3 +76,4 @@ BUILTIN: t 7
 
 IN: kernel
 UNION: boolean f t ;
+COMPLEMENT: general-t f

library/lists.factor

@@ -209,3 +209,8 @@ M: cons hashcode ( cons -- hash ) 4 cons-hashcode ;
 : intersection ( list list -- list )
     #! Make a list of elements that occur in both lists.
     [ over contains? ] subset nip ;
+
+: difference ( list1 list2 -- list )
+    #! Make a list of elements that occur in list2 but not
+    #! list1.
+    [ over contains? not ] subset nip ;

library/primitives.factor

@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -74,7 +74,7 @@ USE: words
     [ sbuf-clone             [ [ sbuf ] [ sbuf ] ] ]
     [ sbuf=                  [ [ sbuf sbuf ] [ boolean ] ] ]
     [ sbuf-hashcode          [ [ sbuf ] [ fixnum ] ] ]
-    [ arithmetic-type        [ [ number number ] [ number number fixnum ] ] ]
+    [ arithmetic-type        [ [ object object ] [ object object fixnum ] ] ]
     [ >fixnum                [ [ number ] [ fixnum ] ] ]
     [ >bignum                [ [ number ] [ bignum ] ] ]
     [ >float                 [ [ number ] [ float ] ] ]

library/test/generic.factor

@@ -8,6 +8,7 @@ USE: math
 USE: words
 USE: lists
 USE: vectors
+USE: alien
 
 TRAITS: test-traits
 C: test-traits ;
@@ -145,3 +146,8 @@ M: very-funny gooey sq ;
 
 [ t ] [ \ generic \ compound class< ] unit-test
 [ f ] [ \ compound \ generic class< ] unit-test
+
+DEFER: bah
+FORGET: bah
+UNION: bah fixnum alien ;
+[ bah ] [ fixnum alien class-or ] unit-test

library/test/inference.factor

@@ -234,3 +234,9 @@ SYMBOL: sym-test
 ! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test
 ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
 [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test
+
+[ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test
+[ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test
+[ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
+
+[ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test

library/test/lists/lists.factor

@@ -60,3 +60,5 @@ USE: strings
 [ [ 1 ] ] [ [ 1 ] 1 head ] unit-test
 [ [ 1 ] 2 head ] unit-test-fails
 [ [ 1 2 3 ] ] [ [ 1 2 3 4 ] 3 head ] unit-test
+
+[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] difference ] unit-test