From 8615910885a080a0a5e8dd2af40677c18afc2453 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Jan 2005 19:41:08 +0000 Subject: [PATCH] entry effect code work --- library/bootstrap/boot-stage2.factor | 3 +- library/bootstrap/boot.factor | 3 +- library/generic/complement.factor | 76 ++++++++++++++++++++++++++++ library/generic/generic.factor | 1 + library/generic/union.factor | 4 +- library/inference/branches.factor | 22 ++++++-- library/inference/words.factor | 13 ++--- library/kernel.factor | 3 +- library/lists.factor | 5 ++ library/primitives.factor | 4 +- library/test/generic.factor | 6 +++ library/test/inference.factor | 6 +++ library/test/lists/lists.factor | 2 + 13 files changed, 130 insertions(+), 18 deletions(-) create mode 100644 library/generic/complement.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index ed3d52e83e..444780df70 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/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" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 2070c16fde..71cafa7b49 100644 --- a/library/bootstrap/boot.factor +++ b/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, diff --git a/library/generic/complement.factor b/library/generic/complement.factor new file mode 100644 index 0000000000..e0014b1666 --- /dev/null +++ b/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 diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 5914b660ff..fa3062bf72 100644 --- a/library/generic/generic.factor +++ b/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 ] [ diff --git a/library/generic/union.factor b/library/generic/union.factor index a90ce324ef..1bcf11cfa8 100644 --- a/library/generic/union.factor +++ b/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 diff --git a/library/inference/branches.factor b/library/inference/branches.factor index bf66244b2d..60e107047a 100644 --- a/library/inference/branches.factor +++ b/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 ; diff --git a/library/inference/words.factor b/library/inference/words.factor index 9d870bf80d..d68ee4fee6 100644 --- a/library/inference/words.factor +++ b/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 ; diff --git a/library/kernel.factor b/library/kernel.factor index 516a671cfd..1b305dbb78 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -67,7 +67,7 @@ M: object = eq? ; : and ( a b -- a&b ) f ? ; inline : not ( a -- ~a ) f t ? ; inline -: or ( a b -- a|b) t swap ? ; inline +: or ( a b -- a|b ) t swap ? ; inline : xor ( a b -- a^b ) dup not swap ? ; inline IN: syntax @@ -76,3 +76,4 @@ BUILTIN: t 7 IN: kernel UNION: boolean f t ; +COMPLEMENT: general-t f diff --git a/library/lists.factor b/library/lists.factor index 0fc947aa64..7cab567d56 100644 --- a/library/lists.factor +++ b/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 ; diff --git a/library/primitives.factor b/library/primitives.factor index be4dc0914e..92b827dd0b 100644 --- a/library/primitives.factor +++ b/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 ] ] ] diff --git a/library/test/generic.factor b/library/test/generic.factor index d55899ffa1..404f513466 100644 --- a/library/test/generic.factor +++ b/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 diff --git a/library/test/inference.factor b/library/test/inference.factor index af754a2219..b20194370a 100644 --- a/library/test/inference.factor +++ b/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 diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index d0ce247a65..232893f90c 100644 --- a/library/test/lists/lists.factor +++ b/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