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

core/alien/strings/strings.factor

@@ -85,10 +85,10 @@ M: string-type c-type-getter
 M: string-type c-type-setter
     drop [ set-alien-cell ] ;
 
-TUPLE: utf16n ;
-
 ! Native-order UTF-16
 
+SINGLETON: utf16n
+
 : utf16n ( -- descriptor )
     little-endian? utf16le utf16be ? ; foldable
 

core/bootstrap/primitives.factor

@@ -5,8 +5,9 @@ hashtables.private io kernel math namespaces parser sequences
 strings vectors words quotations assocs layouts classes
 classes.builtin classes.tuple classes.tuple.private
 kernel.private vocabs vocabs.loader source-files definitions
-slots.deprecated classes.union compiler.units
+slots.deprecated classes.union classes.intersection
-bootstrap.image.private io.files accessors combinators ;
+compiler.units bootstrap.image.private io.files accessors
+combinators ;
 IN: bootstrap.primitives
 
 "Creating primitives and basic runtime structures..." print flush
@@ -127,7 +128,7 @@ bootstrapping? on
 : register-builtin ( class -- )
     [ dup lookup-type-number "type" set-word-prop ]
     [ dup "type" word-prop builtins get set-nth ]
-    [ f f builtin-class define-class ]
+    [ f f f builtin-class define-class ]
     tri ;
 
 : define-builtin-slots ( symbol slotspec -- )
@@ -159,8 +160,13 @@ bootstrapping? on
 "tuple-layout" "classes.tuple.private" create register-builtin
 
 ! Catch-all class for providing a default method.
+! "object" "kernel" create
+! [ f builtins get [ ] filter f union-class define-class ]
+! [ [ drop t ] "predicate" set-word-prop ]
+! bi
+
 "object" "kernel" create
-[ f builtins get [ ] filter union-class define-class ]
+[ f f { } intersection-class define-class ]
 [ [ drop t ] "predicate" set-word-prop ]
 bi
 
@@ -172,7 +178,7 @@ builtins get num-tags get tail define-union-class
 
 ! Empty class with no instances
 "null" "kernel" create
-[ f { } union-class define-class ]
+[ f { } f union-class define-class ]
 [ [ drop f ] "predicate" set-word-prop ]
 bi
 

core/bootstrap/syntax.factor

@@ -46,6 +46,7 @@ IN: bootstrap.syntax
     "TUPLE:"
     "T{"
     "UNION:"
+    "INTERSECTION:"
     "USE:"
     "USING:"
     "V{"

core/classes/algebra/algebra-tests.factor

@@ -1,10 +1,16 @@
-IN: classes.algebra.tests
 USING: alien arrays definitions generic assocs hashtables io
 kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
 random inference effects kernel.private sbufs math.order ;
+IN: classes.algebra.tests
+
+\ class< must-infer
+\ class-and must-infer
+\ class-or must-infer
+\ flatten-class must-infer
+\ flatten-builtin-class must-infer
 
 : class= [ class<= ] [ swap class<= ] 2bi and ;
 
@@ -261,3 +267,38 @@ TUPLE: xg < xb ;
 TUPLE: xh < xb ;
 
 [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
+
+INTERSECTION: generic-class generic class ;
+
+[ t ] [ generic-class generic class<= ] unit-test
+[ t ] [ generic-class \ class class<= ] unit-test
+
+! Later
+[
+    [ t ] [ \ class generic class-and generic-class class<= ] unit-test
+    [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test
+] drop
+
+[ t ] [ \ word generic-class classes-intersect? ] unit-test
+[ f ] [ number generic-class classes-intersect? ] unit-test
+
+[ H{ { word word } } ] [ 
+    generic-class flatten-class
+] unit-test
+
+INTERSECTION: empty-intersection ;
+
+[ t ] [ object empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection object class<= ] unit-test
+[ t ] [ \ f class-not empty-intersection class<= ] unit-test
+[ f ] [ empty-intersection \ f class-not class<= ] unit-test
+[ t ] [ \ number empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection class-not null class<= ] unit-test
+[ t ] [ null empty-intersection class-not class<= ] unit-test
+
+[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
+
+[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
+
+[ ] [ object flatten-builtin-class drop ] unit-test

core/classes/algebra/algebra.factor

@@ -37,7 +37,7 @@ TUPLE: anonymous-union members ;
 
 C: <anonymous-union> anonymous-union
 
-TUPLE: anonymous-intersection members ;
+TUPLE: anonymous-intersection participants ;
 
 C: <anonymous-intersection> anonymous-intersection
 
@@ -48,57 +48,83 @@ C: <anonymous-complement> anonymous-complement
 : superclass<= ( first second -- ? )
     >r superclass r> class<= ;
 
-: left-union-class<= ( first second -- ? )
+: left-anonymous-union<= ( first second -- ? )
-    >r members r> [ class<= ] curry all? ;
-
-: right-union-class<= ( first second -- ? )
-    members [ class<= ] with contains? ;
-
-: left-anonymous-union< ( first second -- ? )
     >r members>> r> [ class<= ] curry all? ;
 
-: right-anonymous-union< ( first second -- ? )
+: right-anonymous-union<= ( first second -- ? )
     members>> [ class<= ] with contains? ;
 
-: left-anonymous-intersection< ( first second -- ? )
+: left-anonymous-intersection<= ( first second -- ? )
-    >r members>> r> [ class<= ] curry contains? ;
+    >r participants>> r> [ class<= ] curry contains? ;
 
-: right-anonymous-intersection< ( first second -- ? )
+: right-anonymous-intersection<= ( first second -- ? )
-    members>> [ class<= ] with all? ;
+    participants>> [ class<= ] with all? ;
 
-: anonymous-complement< ( first second -- ? )
+: anonymous-complement<= ( first second -- ? )
     [ class>> ] bi@ swap class<= ;
 
-: (class<=) ( first second -- -1/0/1 )  
+: normalize-class ( class -- class' )
     {
-        { [ 2dup eq? ] [ 2drop t ] }
+        { [ dup members ] [ members <anonymous-union> ] }
-        { [ dup object eq? ] [ 2drop t ] }
+        { [ dup participants ] [ participants <anonymous-intersection> ] }
-        { [ over null eq? ] [ 2drop t ] }
+        [ ]
-        { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
-        { [ over anonymous-union? ] [ left-anonymous-union< ] }
-        { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
-        { [ over members ] [ left-union-class<= ] }
-        { [ dup anonymous-union? ] [ right-anonymous-union< ] }
-        { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
-        { [ over anonymous-complement? ] [ 2drop f ] }
-        { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
-        { [ dup members ] [ right-union-class<= ] }
-        { [ over superclass ] [ superclass<= ] }
-        [ 2drop f ]
     } cond ;
 
+: normalize-complement ( class -- class' )
+    class>> normalize-class {
+        { [ dup anonymous-union? ] [
+            members>>
+            [ class-not normalize-class ] map
+            <anonymous-intersection> 
+        ] }
+        { [ dup anonymous-intersection? ] [
+            participants>>
+            [ class-not normalize-class ] map
+            <anonymous-union>
+        ] }
+    } cond ;
+
+: left-anonymous-complement<= ( first second -- ? )
+    >r normalize-complement r> class<= ;
+
+PREDICATE: nontrivial-anonymous-complement < anonymous-complement
+    class>> {
+        [ anonymous-union? ]
+        [ anonymous-intersection? ]
+        [ members ]
+        [ participants ]
+    } cleave or or or ;
+
+PREDICATE: empty-union < anonymous-union members>> empty? ;
+
+PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
+
+: (class<=) ( first second -- -1/0/1 )
+    2dup eq? [ 2drop t ] [
+        [ normalize-class ] bi@ {
+            { [ dup empty-intersection? ] [ 2drop t ] }
+            { [ over empty-union? ] [ 2drop t ] }
+            { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
+            { [ over anonymous-union? ] [ left-anonymous-union<= ] }
+            { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
+            { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
+            { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
+            { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
+            { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
+            { [ over superclass ] [ superclass<= ] }
+            [ 2drop f ]
+        } cond
+    ] if ;
+
 : anonymous-union-intersect? ( first second -- ? )
     members>> [ classes-intersect? ] with contains? ;
 
 : anonymous-intersection-intersect? ( first second -- ? )
-    members>> [ classes-intersect? ] with all? ;
+    participants>> [ classes-intersect? ] with all? ;
 
 : anonymous-complement-intersect? ( first second -- ? )
     class>> class<= not ;
 
-: union-class-intersect? ( first second -- ? )
-    members [ classes-intersect? ] with contains? ;
-
 : tuple-class-intersect? ( first second -- ? )
     {
         { [ over tuple eq? ] [ 2drop t ] }
@@ -115,61 +141,57 @@ C: <anonymous-complement> anonymous-complement
     } cond ;
 
 : (classes-intersect?) ( first second -- ? )
-    {
+    normalize-class {
         { [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
         { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
         { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
         { [ dup tuple-class? ] [ tuple-class-intersect? ] }
         { [ dup builtin-class? ] [ builtin-class-intersect? ] }
         { [ dup superclass ] [ superclass classes-intersect? ] }
-        { [ dup members ] [ union-class-intersect? ] }
     } cond ;
 
-: left-union-and ( first second -- class )
+: anonymous-union-and ( first second -- class )
-    >r members r> [ class-and ] curry map <anonymous-union> ;
-
-: right-union-and ( first second -- class )
-    members [ class-and ] with map <anonymous-union> ;
-
-: left-anonymous-union-and ( first second -- class )
-    >r members>> r> [ class-and ] curry map <anonymous-union> ;
-
-: right-anonymous-union-and ( first second -- class )
     members>> [ class-and ] with map <anonymous-union> ;
 
-: left-anonymous-intersection-and ( first second -- class )
+: anonymous-intersection-and ( first second -- class )
-    >r members>> r> suffix <anonymous-intersection> ;
+    participants>> swap suffix <anonymous-intersection> ;
-
-: right-anonymous-intersection-and ( first second -- class )
-    members>> swap suffix <anonymous-intersection> ;
 
 : (class-and) ( first second -- class )
     {
         { [ 2dup class<= ] [ drop ] }
         { [ 2dup swap class<= ] [ nip ] }
         { [ 2dup classes-intersect? not ] [ 2drop null ] }
-        { [ dup members ] [ right-union-and ] }
+        [
-        { [ dup anonymous-union? ] [ right-anonymous-union-and ] }
+            [ normalize-class ] bi@ {
-        { [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] }
+                { [ dup anonymous-union? ] [ anonymous-union-and ] }
-        { [ over members ] [ left-union-and ] }
+                { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
-        { [ over anonymous-union? ] [ left-anonymous-union-and ] }
+                { [ over anonymous-union? ] [ swap anonymous-union-and ] }
-        { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
+                { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
-        [ 2array <anonymous-intersection> ]
+                [ 2array <anonymous-intersection> ]
+            } cond
+        ]
     } cond ;
 
-: left-anonymous-union-or ( first second -- class )
+: anonymous-union-or ( first second -- class )
-    >r members>> r> suffix <anonymous-union> ;
-
-: right-anonymous-union-or ( first second -- class )
     members>> swap suffix <anonymous-union> ;
 
+: ((class-or)) ( first second -- class )
+    [ normalize-class ] bi@ {
+        { [ dup anonymous-union? ] [ anonymous-union-or ] }
+        { [ over anonymous-union? ] [ swap anonymous-union-or ] }
+        [ 2array <anonymous-union> ]
+    } cond ;
+
+: anonymous-complement-or ( first second -- class )
+    2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;
+
 : (class-or) ( first second -- class )
     {
         { [ 2dup class<= ] [ nip ] }
         { [ 2dup swap class<= ] [ drop ] }
-        { [ dup anonymous-union? ] [ right-anonymous-union-or ] }
+        { [ dup anonymous-complement? ] [ anonymous-complement-or ] }
-        { [ over anonymous-union? ] [ left-anonymous-union-or ] }
+        { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
-        [ 2array <anonymous-union> ]
+        [ ((class-or)) ]
     } cond ;
 
 : (class-not) ( class -- complement )
@@ -203,11 +225,23 @@ C: <anonymous-complement> anonymous-complement
         tuck [ class<= ] with all? [ peek ] [ drop f ] if
     ] if ;
 
+DEFER: (flatten-class)
+DEFER: flatten-builtin-class
+
+: flatten-intersection-class ( class -- )
+    participants [ flatten-builtin-class ] map
+    dup empty? [
+        drop builtins get [ (flatten-class) ] each
+    ] [
+        unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
+    ] if ;
+
 : (flatten-class) ( class -- )
     {
         { [ dup tuple-class? ] [ dup set ] }
         { [ dup builtin-class? ] [ dup set ] }
         { [ dup members ] [ members [ (flatten-class) ] each ] }
+        { [ dup participants ] [ flatten-intersection-class ] }
         { [ dup superclass ] [ superclass (flatten-class) ] }
         [ drop ]
     } cond ;

core/classes/classes-docs.factor

@@ -40,6 +40,7 @@ $nl
 "There are several sorts of classes:"
 { $subsection "builtin-classes" }
 { $subsection "unions" }
+{ $subsection "intersections" }
 { $subsection "mixins" }
 { $subsection "predicates" }
 { $subsection "singletons" }
@@ -86,7 +87,11 @@ HELP: members
 { $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
 { $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
 
+HELP: participants
+{ $values { "class" class } { "seq" "a sequence of intersection participants, or " { $link f } } }
+{ $description "If " { $snippet "class" } " is an intersection class, outputs a sequence of its participant classes, otherwise outputs " { $link f } "." } ;
+
 HELP: define-class
-{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
+{ $values { "word" word } { "superclass" class } { "members" "a sequence of class words" } { "participants" "a sequence of class words" } { "metaclass" class } }
 { $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." }
 $low-level-note ;

core/classes/classes.factor

@@ -57,6 +57,10 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     #! Output f for non-classes to work with algebra code
     dup class? [ "members" word-prop ] [ drop f ] if ;
 
+: participants ( class -- seq )
+    #! Output f for non-classes to work with algebra code
+    dup class? [ "participants" word-prop ] [ drop f ] if ;
+
 GENERIC: rank-class ( class -- n )
 
 GENERIC: reset-class ( class -- )
@@ -67,7 +71,12 @@ M: word reset-class drop ;
 
 ! update-map
 : class-uses ( class -- seq )
-    [ members ] [ superclass ] bi [ suffix ] when* ;
+    [
+        [ members % ]
+        [ participants % ]
+        [ superclass [ , ] when* ]
+        tri
+    ] { } make ;
 
 : class-usages ( class -- assoc )
     [ update-map get at ] closure ;
@@ -78,12 +87,14 @@ M: word reset-class drop ;
 : update-map- ( class -- )
     dup class-uses update-map get remove-vertex ;
 
-: make-class-props ( superclass members metaclass -- assoc )
+: make-class-props ( superclass members participants metaclass -- assoc )
     [
-        [ dup [ bootstrap-word ] when "superclass" set ]
+        {
-        [ [ bootstrap-word ] map "members" set ]
+            [ dup [ bootstrap-word ] when "superclass" set ]
-        [ "metaclass" set ]
+            [ [ bootstrap-word ] map "members" set ]
-        tri*
+            [ [ bootstrap-word ] map "participants" set ]
+            [ "metaclass" set ]
+        } spread
     ] H{ } make-assoc ;
 
 : (define-class) ( word props -- )
@@ -112,7 +123,7 @@ GENERIC: update-methods ( assoc -- )
     [ update-methods ]
     bi ;
 
-: define-class ( word superclass members metaclass -- )
+: define-class ( word superclass members participants metaclass -- )
     #! If it was already a class, update methods after.
     reset-caches
     make-class-props

core/classes/intersection/intersection-docs.factor

@@ -0,0 +1,28 @@
+USING: generic help.markup help.syntax kernel kernel.private
+namespaces sequences words arrays layouts help effects math
+layouts classes.private classes compiler.units ;
+IN: classes.intersection
+
+ARTICLE: "intersections" "Intersection classes"
+"An object is an instance of a intersection class if it is an instance of all of its participants."
+{ $subsection POSTPONE: INTERSECTION: }
+{ $subsection define-intersection-class }
+"Intersection classes can be introspected:"
+{ $subsection participants }
+"The set of intersection classes is a class:"
+{ $subsection intersection-class }
+{ $subsection intersection-class? }
+"Intersection classes are used to associate a method with objects which are simultaneously instances of multiple different classes, as well as to conveniently define predicates." ;
+
+ABOUT: "intersections"
+
+HELP: define-intersection-class
+{ $values { "class" class } { "participants" "a sequence of classes" } }
+{ $description "Defines a intersection class with specified participants. This is the run time equivalent of " { $link POSTPONE: INTERSECTION: } "." }
+{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
+{ $side-effects "class" } ;
+
+{ intersection-class define-intersection-class POSTPONE: INTERSECTION: } related-words
+
+HELP: intersection-class
+{ $class-description "The class of intersection classes." } ;

core/classes/intersection/intersection.factor

@@ -0,0 +1,33 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words sequences kernel assocs combinators classes
+namespaces arrays math quotations ;
+IN: classes.intersection
+
+PREDICATE: intersection-class < class
+    "metaclass" word-prop intersection-class eq? ;
+
+: intersection-predicate-quot ( members -- quot )
+    dup empty? [
+        drop [ drop t ]
+    ] [
+        unclip "predicate" word-prop swap [
+            "predicate" word-prop [ dup ] swap [ not ] 3append
+            [ drop f ]
+        ] { } map>assoc alist>quot
+    ] if ;
+
+: define-intersection-predicate ( class -- )
+    dup participants intersection-predicate-quot define-predicate ;
+
+M: intersection-class update-class define-intersection-predicate ;
+
+: define-intersection-class ( class participants -- )
+    [ f f rot intersection-class define-class ]
+    [ drop update-classes ]
+    2bi ;
+
+M: intersection-class reset-class
+    { "class" "metaclass" "participants" } reset-props ;
+
+M: intersection-class rank-class drop 2 ;

core/classes/predicate/predicate.factor

@@ -14,7 +14,7 @@ PREDICATE: predicate-class < class
     ] [ ] make ;
 
 : define-predicate-class ( class superclass definition -- )
-    [ drop f predicate-class define-class ]
+    [ drop f f predicate-class define-class ]
     [ nip "predicate-definition" set-word-prop ]
     [
         2drop

core/classes/singleton/singleton-tests.factor

@@ -10,3 +10,10 @@ GENERIC: zammo ( obj -- str )
 [ ] [ SINGLETON: omg ] unit-test
 [ t ] [ omg singleton-class? ] unit-test
 [ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
+
+SINGLETON: word-and-singleton
+
+: word-and-singleton 3 ;
+
+[ t ] [ \ word-and-singleton word-and-singleton? ] unit-test
+[ 3 ] [ word-and-singleton ] unit-test

core/classes/tuple/tuple-tests.factor

@@ -541,7 +541,7 @@ TUPLE: another-forget-accessors-test ;
 ] unit-test
 
 ! Missing error check
-[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
 
 TUPLE: subclass-forget-test ;
 
@@ -554,3 +554,5 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
 [ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
 [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
 [ subclass-forget-test-3 new ] must-fail
+
+[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail

core/classes/tuple/tuple.factor

@@ -160,7 +160,7 @@ M: tuple-class update-class
     tri ;
 
 : define-new-tuple-class ( class superclass slots -- )
-    [ drop f tuple-class define-class ]
+    [ drop f f tuple-class define-class ]
     [ nip "slot-names" set-word-prop ]
     [ 2drop update-classes ]
     3tri ;
@@ -226,6 +226,12 @@ M: tuple-class reset-class
         } reset-props
     ] bi ;
 
+: reset-tuple-class ( class -- )
+    [ [ reset-class ] [ update-map- ] bi ] each-subclass ;
+
+M: tuple-class forget*
+    [ reset-tuple-class ] [ call-next-method ] bi ;
+
 M: tuple-class rank-class drop 0 ;
 
 M: tuple clone

core/classes/union/union-docs.factor

@@ -4,7 +4,7 @@ layouts classes.private classes compiler.units ;
 IN: classes.union
 
 ARTICLE: "unions" "Union classes"
-"An object is an instance of a union class if it is an instance of one of its members. Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates."
+"An object is an instance of a union class if it is an instance of one of its members."
 { $subsection POSTPONE: UNION: }
 { $subsection define-union-class }
 "Union classes can be introspected:"
@@ -12,7 +12,7 @@ ARTICLE: "unions" "Union classes"
 "The set of union classes is a class:"
 { $subsection union-class }
 { $subsection union-class? } 
-"Unions are used to define behavior shared between a fixed set of classes."
+"Unions are used to define behavior shared between a fixed set of classes, as well as to conveniently define predicates."
 { $see-also "mixins" "tuple-subclassing" } ;
 
 ABOUT: "unions"

core/classes/union/union.factor

@@ -7,7 +7,6 @@ IN: classes.union
 PREDICATE: union-class < class
     "metaclass" word-prop union-class eq? ;
 
-! Union classes for dispatch on multiple classes.
 : union-predicate-quot ( members -- quot )
     dup empty? [
         drop [ drop f ]
@@ -24,7 +23,7 @@ PREDICATE: union-class < class
 M: union-class update-class define-union-predicate ;
 
 : define-union-class ( class members -- )
-    [ f swap union-class define-class ]
+    [ f swap f union-class define-class ]
     [ drop update-classes ]
     2bi ;
 

core/generic/generic.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words kernel sequences namespaces assocs hashtables
 definitions kernel.private classes classes.private
-classes.algebra quotations arrays vocabs effects ;
+classes.algebra quotations arrays vocabs effects combinators ;
 IN: generic
 
 ! Method combination protocol
@@ -123,12 +123,13 @@ M: method-body definer
 M: method-body forget*
     dup "forgotten" word-prop [ drop ] [
         [
-            [   "method-class" word-prop ]
+            [ ]
-            [ "method-generic" word-prop ] bi
+            [ "method-class" word-prop ]
-            dup generic? [
+            [ "method-generic" word-prop ] tri
-                [ delete-at* ] with-methods
+            3dup method eq? [
-                [ call-next-method ] [ drop ] if
+                [ delete-at ] with-methods
-            ] [ 2drop ] if
+                call-next-method
+            ] [ 3drop ] if
         ]
         [ t "forgotten" set-word-prop ] bi
     ] if ;
@@ -146,10 +147,12 @@ M: method-body forget*
     [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
 
 M: class forget* ( class -- )
-    [ forget-methods ]
+    {
-    [ update-map- ]
+        [ forget-methods ]
-    [ call-next-method ]
+        [ update-map- ]
-    tri ;
+        [ reset-class ]
+        [ call-next-method ]
+    } cleave ;
 
 M: assoc update-methods ( assoc -- )
     implementors* [ make-generic ] each ;

core/io/encodings/binary/binary.factor

@@ -3,6 +3,6 @@
 USING: io.encodings kernel ;
 IN: io.encodings.binary
 
-TUPLE: binary ;
+SINGLETON: binary
 M: binary <encoder> drop ;
 M: binary <decoder> drop ;

core/io/encodings/encodings-tests.factor

@@ -1,5 +1,6 @@
-USING: io.files io.streams.string io
+USING: io.files io.streams.string io io.streams.byte-array
-tools.test kernel io.encodings.ascii ;
+tools.test kernel io.encodings.ascii io.encodings.utf8
+namespaces accessors io.encodings ;
 IN: io.streams.encodings.tests
 
 [ { } ]
@@ -56,3 +57,19 @@ unit-test
      dup stream-readln drop
      stream-read1
 ] unit-test
+
+[ utf8 ascii ] [
+    "foo" utf8 [
+        input-stream get code>>
+        ascii decode-input
+        input-stream get code>>
+    ] with-byte-reader
+] unit-test
+
+[ utf8 ascii ] [
+    utf8 [
+        output-stream get code>>
+        ascii encode-output
+        output-stream get code>>
+    ] with-byte-writer drop
+] unit-test

core/io/encodings/encodings.factor

@@ -30,8 +30,7 @@ ERROR: encode-error ;
 
 <PRIVATE
 
-M: tuple-class <decoder> new <decoder> ;
+M: object <decoder> f decoder boa ;
-M: tuple <decoder> f decoder boa ;
 
 : >decoder< ( decoder -- stream encoding )
     [ stream>> ] [ code>> ] bi ;
@@ -104,8 +103,7 @@ M: decoder stream-readln ( stream -- str )
 M: decoder dispose decoder-stream dispose ;
 
 ! Encoding
-M: tuple-class <encoder> new <encoder> ;
+M: object <encoder> encoder boa ;
-M: tuple <encoder> encoder boa ;
 
 : >encoder< ( encoder -- stream encoding )
     [ stream>> ] [ code>> ] bi ;
@@ -121,13 +119,16 @@ M: encoder dispose encoder-stream dispose ;
 M: encoder stream-flush encoder-stream stream-flush ;
 
 INSTANCE: encoder plain-writer
+PRIVATE>
 
-! Rebinding duplex streams which have not read anything yet
+: re-encode ( stream encoding -- newstream )
-
-: reencode ( stream encoding -- newstream )
     over encoder? [ >r encoder-stream r> ] when <encoder> ;
 
-: redecode ( stream encoding -- newstream )
+: encode-output ( encoding -- )
+    output-stream [ swap re-encode ] change ;
+
+: re-decode ( stream encoding -- newstream )
     over decoder? [ >r decoder-stream r> ] when <decoder> ;
 
-PRIVATE>
+: decode-input ( encoding -- )
+    input-stream [ swap re-decode ] change ;

core/io/encodings/utf16/utf16-tests.factor

@@ -24,7 +24,7 @@ IN: io.encodings.utf16.tests
 [ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
 
 : correct-endian
-    code>> class little-endian? [ utf16le = ] [ utf16be = ] if ;
+    code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
 
 [ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
 [ t ] [ utf16n <byte-writer> correct-endian ] unit-test

core/io/encodings/utf16/utf16.factor

@@ -4,11 +4,11 @@ USING: math kernel sequences sbufs vectors namespaces io.binary
 io.encodings combinators splitting io byte-arrays inspector ;
 IN: io.encodings.utf16
 
-TUPLE: utf16be ;
+SINGLETON: utf16be
 
-TUPLE: utf16le ;
+SINGLETON: utf16le
 
-TUPLE: utf16 ;
+SINGLETON: utf16
 
 <PRIVATE
 

core/io/encodings/utf8/utf8.factor

@@ -6,7 +6,7 @@ IN: io.encodings.utf8
 
 ! Decoding UTF-8
 
-TUPLE: utf8 ;
+SINGLETON: utf8
 
 <PRIVATE 
 

core/io/files/files-tests.factor

@@ -66,6 +66,9 @@ strings accessors io.encodings.utf8 math ;
 [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
 [ "" ] [ "" file-name ] unit-test
 
+[ "freetype6.dll" ] [ "resource:freetype6.dll" file-name ] unit-test
+[ "freetype6.dll" ] [ "resource:/freetype6.dll" file-name ] unit-test
+
 [ ] [
     { "Hello world." }
     "test-foo.txt" temp-file ascii set-file-lines

core/io/files/files.factor

@@ -142,7 +142,9 @@ PRIVATE>
 : file-name ( path -- string )
     dup root-directory? [
         right-trim-separators
-        dup last-path-separator [ 1+ tail ] [ drop ] if
+        dup last-path-separator [ 1+ tail ] [
+            drop "resource:" ?head [ file-name ] when
+        ] if
     ] unless ;
 
 ! File info

core/io/streams/string/string.factor

@@ -49,7 +49,7 @@ M: growable stream-read
 M: growable stream-read-partial
     stream-read ;
 
-TUPLE: null ;
+SINGLETON: null
 M: null decode-char drop stream-read1 ;
 
 : <string-reader> ( str -- stream )

core/parser/parser-tests.factor

@@ -435,3 +435,28 @@ must-fail-with
 
 [ 92 ] [ "CHAR: \\" eval ] unit-test
 [ 92 ] [ "CHAR: \\\\" eval ] unit-test
+
+[ ] [
+    {
+        "IN: parser.tests"
+        "USING: math arrays ;"
+        "GENERIC: change-combination"
+        "M: integer change-combination 1 ;"
+        "M: array change-combination 2 ;"
+    } "\n" join <string-reader> "change-combination-test" parse-stream drop
+] unit-test
+
+[ ] [
+    {
+        "IN: parser.tests"
+        "USING: math arrays ;"
+        "GENERIC# change-combination 1"
+        "M: integer change-combination 1 ;"
+        "M: array change-combination 2 ;"
+    } "\n" join <string-reader> "change-combination-test" parse-stream drop
+] unit-test
+
+[ 2 ] [
+    "change-combination" "parser.tests" lookup
+    "methods" word-prop assoc-size
+] unit-test

core/prettyprint/prettyprint-tests.factor

@@ -334,5 +334,11 @@ PREDICATE: predicate-see-test < integer even? ;
     [ \ predicate-see-test see ] with-string-writer
 ] unit-test
 
+INTERSECTION: intersection-see-test sequence number ;
+
+[ "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" ] [
+    [ \ intersection-see-test see ] with-string-writer
+] unit-test
+
 [ ] [ \ compose see ] unit-test
 [ ] [ \ curry see ] unit-test

core/prettyprint/prettyprint.factor

@@ -7,8 +7,8 @@ vectors words prettyprint.backend prettyprint.sections
 prettyprint.config sorting splitting math.parser vocabs
 definitions effects classes.builtin classes.tuple io.files
 classes continuations hashtables classes.mixin classes.union
-classes.predicate classes.singleton combinators quotations
+classes.intersection classes.predicate classes.singleton
-sets ;
+combinators quotations sets ;
 
 : make-pprint ( obj quot -- block in use )
     [
@@ -238,6 +238,11 @@ M: union-class see-class*
     dup pprint-word
     members pprint-elements pprint-; block> ;
 
+M: intersection-class see-class*
+    <colon \ INTERSECTION: pprint-word
+    dup pprint-word
+    participants pprint-elements pprint-; block> ;
+
 M: mixin-class see-class*
     <block \ MIXIN: pprint-word
     dup pprint-word <block

core/syntax/syntax-docs.factor

@@ -496,14 +496,17 @@ HELP: M:
 HELP: UNION:
 { $syntax "UNION: class members... ;" }
 { $values { "class" "a new class word to define" } { "members" "a list of class words separated by whitespace" } }
-{ $description "Defines a union class. An object is an instance of a union class if it is an instance of one of its members." }
+{ $description "Defines a union class. An object is an instance of a union class if it is an instance of one of its members." } ;
-{ $notes "Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates." } ;
+
+HELP: INTERSECTION:
+{ $syntax "INTERSECTION: class participants... ;" }
+{ $values { "class" "a new class word to define" } { "participants" "a list of class words separated by whitespace" } }
+{ $description "Defines an intersection class. An object is an instance of a union class if it is an instance of all of its participants." } ;
 
 HELP: MIXIN:
 { $syntax "MIXIN: class" }
 { $values { "class" "a new class word to define" } }
 { $description "Defines a mixin class. A mixin is similar to a union class, except it has no members initially, and new members can be added with the " { $link POSTPONE: INSTANCE: } " word." }
-{ $notes "Mixins classes are used to mark implementations of a protocol and define default methods." }
 { $examples "The " { $link sequence } " and " { $link assoc } " mixin classes." } ;
 
 HELP: INSTANCE:

core/syntax/syntax.factor

@@ -5,8 +5,9 @@ definitions generic hashtables kernel math
 namespaces parser sequences strings sbufs vectors words
 quotations io assocs splitting classes.tuple generic.standard
 generic.math classes io.files vocabs float-arrays
-classes.union classes.mixin classes.predicate classes.singleton
+classes.union classes.intersection classes.mixin
-compiler.units combinators debugger ;
+classes.predicate classes.singleton compiler.units
+combinators debugger ;
 IN: bootstrap.syntax
 
 ! These words are defined as a top-level form, instead of with
@@ -135,6 +136,10 @@ IN: bootstrap.syntax
         CREATE-CLASS parse-definition define-union-class
     ] define-syntax
 
+    "INTERSECTION:" [
+        CREATE-CLASS parse-definition define-intersection-class
+    ] define-syntax
+
     "MIXIN:" [
         CREATE-CLASS define-mixin-class
     ] define-syntax
@@ -153,8 +158,7 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "SINGLETON:" [
-        scan create-class-in
+        CREATE-CLASS define-singleton-class
-        dup save-location define-singleton-class
     ] define-syntax
 
     "TUPLE:" [

core/words/words.factor

@@ -3,7 +3,7 @@
 USING: arrays definitions graphs assocs kernel kernel.private
 slots.private math namespaces sequences strings vectors sbufs
 quotations assocs hashtables sorting words.private vocabs
-math.order ;
+math.order sets ;
 IN: words
 
 : word ( -- word ) \ word get-global ;
@@ -121,7 +121,7 @@ SYMBOL: +called+
     compiled-crossref get at ;
 
 : compiled-usages ( words -- seq )
-    [ [ dup ] H{ } map>assoc dup ] keep [
+    [ unique dup ] keep [
         compiled-usage [ nip +inlined+ eq? ] assoc-filter update
     ] with each keys ;
 

extra/assocs/lib/lib.factor

@@ -2,9 +2,6 @@ USING: arrays assocs kernel vectors sequences namespaces
 random math.parser ;
 IN: assocs.lib
 
-: >set ( seq -- hash )
-    [ dup ] H{ } map>assoc ;
-
 : ref-at ( table key -- value ) swap at ;
 
 : put-at* ( table key value -- ) swap rot set-at ;

extra/cairo/cairo-tests.factor

@@ -0,0 +1,7 @@
+USING: cairo math.parser kernel sequences tools.test ;
+IN: cairo.tests
+
+[ t ] [ ! apply a little pressure to cairo_version
+    cairo_version number>string CHAR: 0 swap remove
+    CHAR: . cairo_version_string remove =
+] unit-test

extra/cairo/cairo.factor

@@ -0,0 +1,968 @@
+! Copyright (c) 2007 Sampo Vuori
+! Copyright (c) 2008 Matthew Willis
+!
+! Adapted from cairo.h, version 1.5.14
+! License: http://factorcode.org/license.txt
+
+USING: system combinators alien alien.syntax kernel 
+alien.c-types accessors sequences arrays ui.gadgets ;
+
+IN: cairo
+<< "cairo" {
+    { [ os winnt? ] [ "libcairo-2.dll" ] }
+    { [ os macosx? ] [ "libcairo.dylib" ] }
+    { [ os unix? ] [ "libcairo.so.2" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: cairo
+
+FUNCTION: int cairo_version ( ) ;
+FUNCTION: char* cairo_version_string ( ) ;
+
+TYPEDEF: int cairo_bool_t
+
+! I am leaving these and other void* types as opaque structures
+TYPEDEF: void* cairo_t
+TYPEDEF: void* cairo_surface_t
+
+C-STRUCT: cairo_matrix_t
+    { "double" "xx" }
+    { "double" "yx" }
+    { "double" "xy" }
+    { "double" "yy" }
+    { "double" "x0" }
+    { "double" "y0" } ;
+
+TYPEDEF: void* cairo_pattern_t
+
+TYPEDEF: void* cairo_destroy_func_t
+: cairo-destroy-func ( quot -- callback )
+    >r "void" { "void*" } "cdecl" r> alien-callback ; inline
+
+! See cairo.h for details
+C-STRUCT: cairo_user_data_key_t
+    { "int" "unused" } ;
+
+TYPEDEF: int cairo_status_t
+C-ENUM:
+    CAIRO_STATUS_SUCCESS
+    CAIRO_STATUS_NO_MEMORY
+    CAIRO_STATUS_INVALID_RESTORE
+    CAIRO_STATUS_INVALID_POP_GROUP
+    CAIRO_STATUS_NO_CURRENT_POINT
+    CAIRO_STATUS_INVALID_MATRIX
+    CAIRO_STATUS_INVALID_STATUS
+    CAIRO_STATUS_NULL_POINTER
+    CAIRO_STATUS_INVALID_STRING
+    CAIRO_STATUS_INVALID_PATH_DATA
+    CAIRO_STATUS_READ_ERROR
+    CAIRO_STATUS_WRITE_ERROR
+    CAIRO_STATUS_SURFACE_FINISHED
+    CAIRO_STATUS_SURFACE_TYPE_MISMATCH
+    CAIRO_STATUS_PATTERN_TYPE_MISMATCH
+    CAIRO_STATUS_INVALID_CONTENT
+    CAIRO_STATUS_INVALID_FORMAT
+    CAIRO_STATUS_INVALID_VISUAL
+    CAIRO_STATUS_FILE_NOT_FOUND
+    CAIRO_STATUS_INVALID_DASH
+    CAIRO_STATUS_INVALID_DSC_COMMENT
+    CAIRO_STATUS_INVALID_INDEX
+    CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
+    CAIRO_STATUS_TEMP_FILE_ERROR
+    CAIRO_STATUS_INVALID_STRIDE ;
+
+TYPEDEF: int cairo_content_t
+: CAIRO_CONTENT_COLOR		HEX: 1000 ;
+: CAIRO_CONTENT_ALPHA		HEX: 2000 ;
+: CAIRO_CONTENT_COLOR_ALPHA	HEX: 3000 ;
+
+TYPEDEF: void* cairo_write_func_t
+: cairo-write-func ( quot -- callback )
+    >r "cairo_status_t" { "void*" "uchar*" "int" }
+    "cdecl" r> alien-callback ; inline
+                          
+TYPEDEF: void* cairo_read_func_t
+: cairo-read-func ( quot -- callback )
+    >r "cairo_status_t" { "void*" "uchar*" "int" }
+    "cdecl" r> alien-callback ; inline
+
+! Functions for manipulating state objects
+FUNCTION: cairo_t*
+cairo_create ( cairo_surface_t* target ) ;
+
+FUNCTION: cairo_t*
+cairo_reference ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_destroy ( cairo_t* cr ) ;
+
+FUNCTION: uint
+cairo_get_reference_count ( cairo_t* cr ) ;
+
+FUNCTION: void*
+cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_save ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_restore ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_push_group ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_push_group_with_content  ( cairo_t* cr, cairo_content_t content ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pop_group ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_pop_group_to_source ( cairo_t* cr ) ;
+
+! Modify state
+TYPEDEF: int cairo_operator_t
+C-ENUM:
+    CAIRO_OPERATOR_CLEAR
+
+    CAIRO_OPERATOR_SOURCE
+    CAIRO_OPERATOR_OVER
+    CAIRO_OPERATOR_IN
+    CAIRO_OPERATOR_OUT
+    CAIRO_OPERATOR_ATOP
+
+    CAIRO_OPERATOR_DEST
+    CAIRO_OPERATOR_DEST_OVER
+    CAIRO_OPERATOR_DEST_IN
+    CAIRO_OPERATOR_DEST_OUT
+    CAIRO_OPERATOR_DEST_ATOP
+
+    CAIRO_OPERATOR_XOR
+    CAIRO_OPERATOR_ADD
+    CAIRO_OPERATOR_SATURATE ;
+
+FUNCTION: void
+cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ;
+
+FUNCTION: void
+cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ;
+
+FUNCTION: void
+cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ;
+
+FUNCTION: void
+cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ;
+
+FUNCTION: void
+cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ;
+
+FUNCTION: void
+cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
+
+TYPEDEF: int cairo_antialias_t
+C-ENUM:
+    CAIRO_ANTIALIAS_DEFAULT
+    CAIRO_ANTIALIAS_NONE
+    CAIRO_ANTIALIAS_GRAY
+    CAIRO_ANTIALIAS_SUBPIXEL ;
+
+FUNCTION: void
+cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
+
+TYPEDEF: int cairo_fill_rule_t
+C-ENUM:
+    CAIRO_FILL_RULE_WINDING
+    CAIRO_FILL_RULE_EVEN_ODD ;
+
+FUNCTION: void
+cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
+
+FUNCTION: void
+cairo_set_line_width ( cairo_t* cr, double width ) ;
+
+TYPEDEF: int cairo_line_cap_t
+C-ENUM:
+    CAIRO_LINE_CAP_BUTT
+    CAIRO_LINE_CAP_ROUND
+    CAIRO_LINE_CAP_SQUARE ;
+
+FUNCTION: void
+cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
+
+TYPEDEF: int cairo_line_join_t
+C-ENUM:
+    CAIRO_LINE_JOIN_MITER
+    CAIRO_LINE_JOIN_ROUND
+    CAIRO_LINE_JOIN_BEVEL ;
+
+FUNCTION: void
+cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ;
+
+FUNCTION: void
+cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ;
+
+FUNCTION: void
+cairo_set_miter_limit ( cairo_t* cr, double limit ) ;
+
+FUNCTION: void
+cairo_translate ( cairo_t* cr, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_scale ( cairo_t* cr, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_rotate ( cairo_t* cr, double angle ) ;
+
+FUNCTION: void
+cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_identity_matrix ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: void
+cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ;
+
+FUNCTION: void
+cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: void
+cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
+
+! Path creation functions
+FUNCTION: void
+cairo_new_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_move_to ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: void
+cairo_new_sub_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_line_to ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: void
+cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ;
+
+FUNCTION: void
+cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
+
+FUNCTION: void
+cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
+
+FUNCTION: void
+cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ;
+
+FUNCTION: void
+cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ;
+
+FUNCTION: void
+cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ;
+
+FUNCTION: void
+cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+FUNCTION: void
+cairo_close_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+! Painting functions
+FUNCTION: void
+cairo_paint ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ;
+
+FUNCTION: void
+cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ;
+
+FUNCTION: void
+cairo_stroke ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_stroke_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_fill ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_fill_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_copy_page ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_show_page ( cairo_t* cr ) ;
+
+! Insideness testing
+FUNCTION: cairo_bool_t
+cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: cairo_bool_t
+cairo_in_fill ( cairo_t* cr, double x, double y ) ;
+
+! Rectangular extents
+FUNCTION: void
+cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+FUNCTION: void
+cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+! Clipping
+FUNCTION: void
+cairo_reset_clip ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+C-STRUCT: cairo_rectangle_t
+    { "double" "x" }
+    { "double" "y" }
+    { "double" "width" }
+    { "double" "height" } ;
+
+: <cairo-rect> ( x y width height -- cairo_rectangle_t )
+    "cairo_rectangle_t" <c-object> dup
+    { 
+        [ set-cairo_rectangle_t-height ] [ set-cairo_rectangle_t-width ]
+        [ set-cairo_rectangle_t-y ] [ set-cairo_rectangle_t-x ]
+    } cleave ;
+    
+: rect>cairo ( rect -- cairo_rectangle_t )
+    [ loc>> ] [ dim>> ] bi [ [ first ] [ second ] bi ] bi@
+    <cairo-rect> ;
+
+: cairo>rect ( cairo_rectangle_t -- rect )
+    {
+        [ cairo_rectangle_t-x ] [ cairo_rectangle_t-y ]
+        [ cairo_rectangle_t-width ] [ cairo_rectangle_t-height ]
+    } cleave
+    [ 2array ] 2bi@ <rect> ;
+    
+C-STRUCT: cairo_rectangle_list_t
+    { "cairo_status_t"     "status" }
+    { "cairo_rectangle_t*" "rectangles" }
+    { "int"                "num_rectangles" } ;
+
+FUNCTION: cairo_rectangle_list_t*
+cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ;
+
+! Font/Text functions
+
+TYPEDEF: void* cairo_scaled_font_t
+
+TYPEDEF: void* cairo_font_face_t
+
+C-STRUCT: cairo_glyph_t
+  { "ulong"     "index" }
+  { "double"    "x" }
+  { "double"    "y" } ;
+
+C-STRUCT: cairo_text_extents_t
+    { "double" "x_bearing" }
+    { "double" "y_bearing" }
+    { "double" "width" }
+    { "double" "height" }
+    { "double" "x_advance" }
+    { "double" "y_advance" } ;
+
+C-STRUCT: cairo_font_extents_t
+    { "double" "ascent" }
+    { "double" "descent" }
+    { "double" "height" }
+    { "double" "max_x_advance" }
+    { "double" "max_y_advance" } ;
+
+TYPEDEF: int cairo_font_slant_t
+C-ENUM:
+    CAIRO_FONT_SLANT_NORMAL
+    CAIRO_FONT_SLANT_ITALIC
+    CAIRO_FONT_SLANT_OBLIQUE ;
+
+TYPEDEF: int cairo_font_weight_t
+C-ENUM:
+    CAIRO_FONT_WEIGHT_NORMAL
+    CAIRO_FONT_WEIGHT_BOLD ;
+
+TYPEDEF: int cairo_subpixel_order_t
+C-ENUM:
+    CAIRO_SUBPIXEL_ORDER_DEFAULT
+    CAIRO_SUBPIXEL_ORDER_RGB
+    CAIRO_SUBPIXEL_ORDER_BGR
+    CAIRO_SUBPIXEL_ORDER_VRGB
+    CAIRO_SUBPIXEL_ORDER_VBGR ;
+
+TYPEDEF: int cairo_hint_style_t
+C-ENUM:
+    CAIRO_HINT_STYLE_DEFAULT
+    CAIRO_HINT_STYLE_NONE
+    CAIRO_HINT_STYLE_SLIGHT
+    CAIRO_HINT_STYLE_MEDIUM
+    CAIRO_HINT_STYLE_FULL ;
+
+TYPEDEF: int cairo_hint_metrics_t
+C-ENUM:
+    CAIRO_HINT_METRICS_DEFAULT
+    CAIRO_HINT_METRICS_OFF
+    CAIRO_HINT_METRICS_ON ;
+
+TYPEDEF: void* cairo_font_options_t
+
+FUNCTION: cairo_font_options_t*
+cairo_font_options_create ( ) ;
+
+FUNCTION: cairo_font_options_t*
+cairo_font_options_copy ( cairo_font_options_t* original ) ;
+
+FUNCTION: void
+cairo_font_options_destroy ( cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_options_status ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
+
+FUNCTION: cairo_bool_t
+cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
+
+FUNCTION: ulong
+cairo_font_options_hash ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ;
+
+FUNCTION: cairo_antialias_t
+cairo_font_options_get_antialias ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ;
+
+FUNCTION: cairo_subpixel_order_t
+cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ;
+
+FUNCTION: cairo_hint_style_t
+cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ;
+
+FUNCTION: cairo_hint_metrics_t
+cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
+
+! This interface is for dealing with text as text, not caring about the
+!  font object inside the the cairo_t.
+
+FUNCTION: void
+cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
+
+FUNCTION: void
+cairo_set_font_size ( cairo_t* cr, double size ) ;
+
+FUNCTION: void
+cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ;
+
+FUNCTION: cairo_font_face_t*
+cairo_get_font_face ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_scaled_font_t*
+cairo_get_scaled_font ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_show_text ( cairo_t* cr, char* utf8 ) ;
+
+FUNCTION: void
+cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
+
+FUNCTION: void
+cairo_text_path  ( cairo_t* cr, char* utf8 ) ;
+
+FUNCTION: void
+cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
+
+FUNCTION: void
+cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ;
+
+! Generic identifier for a font style
+
+FUNCTION: cairo_font_face_t*
+cairo_font_face_reference ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: void
+cairo_font_face_destroy ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: uint
+cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_face_status ( cairo_font_face_t* font_face ) ;
+
+TYPEDEF: int cairo_font_type_t
+C-ENUM:
+    CAIRO_FONT_TYPE_TOY
+    CAIRO_FONT_TYPE_FT
+    CAIRO_FONT_TYPE_WIN32
+    CAIRO_FONT_TYPE_QUARTZ ;
+
+FUNCTION: cairo_font_type_t
+cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: void* 
+cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+! Portable interface to general font features.
+
+FUNCTION: cairo_scaled_font_t*
+cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_scaled_font_t*
+cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void
+cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: uint
+cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_status_t
+cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_font_type_t
+cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void* 
+cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
+
+FUNCTION: cairo_font_face_t*
+cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
+
+! Query functions
+
+FUNCTION: cairo_operator_t
+cairo_get_operator ( cairo_t* cr ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_get_source ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_tolerance ( cairo_t* cr ) ;
+
+FUNCTION: cairo_antialias_t
+cairo_get_antialias ( cairo_t* cr ) ;
+
+FUNCTION: cairo_bool_t
+cairo_has_current_point ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: cairo_fill_rule_t
+cairo_get_fill_rule ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_line_width ( cairo_t* cr ) ;
+
+FUNCTION: cairo_line_cap_t
+cairo_get_line_cap ( cairo_t* cr ) ;
+
+FUNCTION: cairo_line_join_t
+cairo_get_line_join ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_miter_limit ( cairo_t* cr ) ;
+
+FUNCTION: int
+cairo_get_dash_count ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ;
+
+FUNCTION: void
+cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_get_target ( cairo_t* cr ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_get_group_target ( cairo_t* cr ) ;
+
+TYPEDEF: int cairo_path_data_type_t
+C-ENUM:
+    CAIRO_PATH_MOVE_TO
+    CAIRO_PATH_LINE_TO
+    CAIRO_PATH_CURVE_TO
+    CAIRO_PATH_CLOSE_PATH ;
+
+! NEED TO DO UNION HERE
+C-STRUCT: cairo_path_data_t-point
+    { "double" "x" }
+    { "double" "y" } ;
+
+C-STRUCT: cairo_path_data_t-header
+    { "cairo_path_data_type_t" "type" }
+    { "int" "length" } ;
+
+C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
+
+C-STRUCT: cairo_path_t
+    { "cairo_status_t"      "status" }
+    { "cairo_path_data_t*"  "data" }
+    { "int"                 "num_data" } ;
+
+FUNCTION: cairo_path_t*
+cairo_copy_path ( cairo_t* cr ) ;
+
+FUNCTION: cairo_path_t*
+cairo_copy_path_flat ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ;
+
+FUNCTION: void
+cairo_path_destroy ( cairo_path_t* path ) ;
+
+! Error status queries
+
+FUNCTION: cairo_status_t
+cairo_status ( cairo_t* cr ) ;
+
+FUNCTION: char* 
+cairo_status_to_string ( cairo_status_t status ) ;
+
+! Surface manipulation
+
+FUNCTION: cairo_surface_t*
+cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_surface_reference ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_finish ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_destroy ( cairo_surface_t* surface ) ;
+
+FUNCTION: uint
+cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_status ( cairo_surface_t* surface ) ;
+
+TYPEDEF: int cairo_surface_type_t
+C-ENUM:
+    CAIRO_SURFACE_TYPE_IMAGE
+    CAIRO_SURFACE_TYPE_PDF
+    CAIRO_SURFACE_TYPE_PS
+    CAIRO_SURFACE_TYPE_XLIB
+    CAIRO_SURFACE_TYPE_XCB
+    CAIRO_SURFACE_TYPE_GLITZ
+    CAIRO_SURFACE_TYPE_QUARTZ
+    CAIRO_SURFACE_TYPE_WIN32
+    CAIRO_SURFACE_TYPE_BEOS
+    CAIRO_SURFACE_TYPE_DIRECTFB
+    CAIRO_SURFACE_TYPE_SVG
+    CAIRO_SURFACE_TYPE_OS2
+    CAIRO_SURFACE_TYPE_WIN32_PRINTING
+    CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ;
+
+FUNCTION: cairo_surface_type_t
+cairo_surface_get_type ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_content_t
+cairo_surface_get_content ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
+
+FUNCTION: void* 
+cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_surface_flush ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_mark_dirty ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ;
+
+FUNCTION: void
+cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ;
+
+FUNCTION: void
+cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ;
+
+FUNCTION: void
+cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
+
+FUNCTION: void
+cairo_surface_copy_page ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_show_page ( cairo_surface_t* surface ) ;
+
+! Image-surface functions
+
+TYPEDEF: int cairo_format_t
+C-ENUM:
+    CAIRO_FORMAT_ARGB32
+    CAIRO_FORMAT_RGB24
+    CAIRO_FORMAT_A8
+    CAIRO_FORMAT_A1
+    CAIRO_FORMAT_RGB16_565 ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
+
+FUNCTION: int
+cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
+
+FUNCTION: uchar*
+cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_format_t
+cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_from_png ( char* filename ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
+
+! Pattern creation functions
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_rgb ( double red, double green, double blue ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_reference ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_pattern_destroy ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: uint
+cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_status ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void*
+cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+TYPEDEF: int cairo_pattern_type_t
+C-ENUM:
+    CAIRO_PATTERN_TYPE_SOLID
+    CAIRO_PATTERN_TYPE_SURFACE
+    CAIRO_PATTERN_TYPE_LINEAR
+    CAIRO_PATTERN_TYPE_RADIA ;
+
+FUNCTION: cairo_pattern_type_t
+cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ;
+
+FUNCTION: void
+cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ;
+
+FUNCTION: void
+cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
+
+TYPEDEF: int cairo_extend_t
+C-ENUM:
+    CAIRO_EXTEND_NONE
+    CAIRO_EXTEND_REPEAT
+    CAIRO_EXTEND_REFLECT
+    CAIRO_EXTEND_PAD ;
+
+FUNCTION: void
+cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
+
+FUNCTION: cairo_extend_t
+cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
+
+TYPEDEF: int cairo_filter_t
+C-ENUM:
+    CAIRO_FILTER_FAST
+    CAIRO_FILTER_GOOD
+    CAIRO_FILTER_BEST
+    CAIRO_FILTER_NEAREST
+    CAIRO_FILTER_BILINEAR
+    CAIRO_FILTER_GAUSSIAN ;
+
+FUNCTION: void
+cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ;
+
+FUNCTION: cairo_filter_t
+cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ;
+
+! Matrix functions
+
+FUNCTION: void
+cairo_matrix_init ( cairo_matrix_t* matrix, double  xx, double  yx, double  xy, double  yy, double  x0, double  y0 ) ;
+
+FUNCTION: void
+cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ;
+
+FUNCTION: void
+cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ;
+
+FUNCTION: cairo_status_t
+cairo_matrix_invert ( cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ;
+
+FUNCTION: void
+cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ;
+
+FUNCTION: void
+cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ;
+
+! Functions to be used while debugging (not intended for use in production code)
+FUNCTION: void
+cairo_debug_reset_static_data ( ) ;

extra/cairo/gadgets/gadgets.factor

@@ -0,0 +1,73 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cairo cairo.lib ui.render kernel opengl.gl opengl
+math byte-arrays ui.gadgets accessors arrays 
+namespaces io.backend ;
+
+IN: cairo.gadgets
+
+! We need two kinds of gadgets:
+! one performs the cairo ops once and caches the bytes, the other
+! performs cairo ops every refresh
+
+TUPLE: cairo-gadget width height quot cache? bytes ;
+PREDICATE: cached-cairo < cairo-gadget cache?>> ;
+: <cairo-gadget> ( width height quot -- cairo-gadget )
+    cairo-gadget construct-gadget 
+    swap >>quot
+    swap >>height
+    swap >>width ;
+
+: <cached-cairo> ( width height quot -- cairo-gadget )
+    <cairo-gadget> t >>cache? ;
+
+: width>stride ( width -- stride ) 4 * ;
+    
+: copy-cairo ( width height quot -- byte-array )
+    >r over width>stride
+    [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
+    [ cairo_image_surface_create_for_data ] 3bi
+    r> with-cairo-from-surface ;
+
+: (cairo>bytes) ( gadget -- byte-array )
+    [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
+
+GENERIC: cairo>bytes
+M: cairo-gadget cairo>bytes ( gadget -- byte-array )
+    (cairo>bytes) ;
+
+M: cached-cairo cairo>bytes ( gadget -- byte-array )
+    dup bytes>> [ ] [
+        dup (cairo>bytes) [ >>bytes drop ] keep
+    ] ?if ;
+
+: cairo>png ( gadget path -- )
+    >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
+    [ height>> ] tri over width>stride
+    cairo_image_surface_create_for_data
+    r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
+
+M: cairo-gadget draw-gadget* ( gadget -- )
+    origin get [
+        0 0 glRasterPos2i
+        1.0 -1.0 glPixelZoom
+        [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
+        [ cairo>bytes ] tri glDrawPixels
+    ] with-translation ;
+    
+M: cairo-gadget pref-dim* ( gadget -- rect )
+    [ width>> ] [ height>> ] bi 2array ;
+
+: copy-surface ( surface -- )
+    cr swap 0 0 cairo_set_source_surface
+    cr cairo_paint ;
+
+: <bytes-gadget> ( width height bytes -- cairo-gadget )
+    >r [ ] <cached-cairo> r> >>bytes ;
+
+: <png-gadget> ( path -- gadget )
+    normalize-path cairo_image_surface_create_from_png
+    [ cairo_image_surface_get_width ]
+    [ cairo_image_surface_get_height 2dup ]
+    [ [ copy-surface ] curry copy-cairo ] tri
+    <bytes-gadget> ;

extra/cairo/lib/lib.factor

@@ -1,39 +1,36 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types cairo.ffi continuations destructors
+USING: cairo kernel accessors sequences
-kernel libc locals math shuffle accessors ;
+namespaces fry continuations ;
 IN: cairo.lib
 
 TUPLE: cairo-t alien ;
 C: <cairo-t> cairo-t
 M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
-: cairo-t-destroy-always ( alien -- ) <cairo-t> add-always-destructor ;
+
-: cairo-t-destroy-later ( alien -- ) <cairo-t> add-error-destructor ;
-    
 TUPLE: cairo-surface-t alien ;
 C: <cairo-surface-t> cairo-surface-t
 M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
 
-: cairo-surface-t-destroy-always ( alien -- )
+: check-cairo ( cairo_status_t -- )
-    <cairo-surface-t> add-always-destructor ;
+    dup CAIRO_STATUS_SUCCESS = [ drop ]
+    [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
 
-: cairo-surface-t-destroy-later ( alien -- )
+SYMBOL: cairo
-    <cairo-surface-t> add-error-destructor ;
+: cr ( -- cairo ) cairo get ;
 
-: cairo-surface>array ( surface -- cairo-t byte-array )
+: (with-cairo) ( cairo-t quot -- )
-    [
+    >r alien>> cairo r> [ cr cairo_status check-cairo ]
-        dup
+    compose with-variable ; inline
-        [ drop CAIRO_FORMAT_ARGB32 ]
+    
-        [ cairo_image_surface_get_width ]
+: with-cairo ( cairo quot -- )
-        [ cairo_image_surface_get_height ] tri
+    >r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
-        over 4 *
+
-        2dup * [
+: (with-surface) ( cairo-surface-t quot -- )
-            malloc dup free-always [
+    >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
-                5 -nrot cairo_image_surface_create_for_data
+
-                dup cairo-surface-t-destroy-always
+: with-surface ( cairo_surface quot -- )
-                cairo_create dup cairo-t-destroy-later
+    >r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
-                [ swap 0 0 cairo_set_source_surface ] keep
+
-                dup cairo_paint
+: with-cairo-from-surface ( cairo_surface quot -- )
-            ] keep
+    '[ cairo_create , with-cairo ] with-surface ; inline
-        ] keep memory>byte-array
-    ] with-destructors ;

extra/cairo/png/png.factor

@@ -1,65 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel accessors math ui.gadgets ui.render
-opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib
-inspector sequences combinators io.backend ;
-IN: cairo.png
-
-TUPLE: png surface width height cairo-t array ;
-TUPLE: png-gadget png ;
-
-ERROR: cairo-error string ;
-
-: check-zero ( n -- n )
-    dup zero? [
-        "PNG dimension is 0" cairo-error
-    ] when ;
-
-: cairo-png-error ( n -- )
-    {
-        { CAIRO_STATUS_NO_MEMORY [ "Cairo: no memory" cairo-error ] }
-        { CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
-        { CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
-        [ drop ]
-    } case ;
-
-: <png> ( path -- png )
-    normalize-path
-    cairo_image_surface_create_from_png
-    dup cairo_surface_status cairo-png-error
-    dup [ cairo_image_surface_get_width check-zero ]
-    [ cairo_image_surface_get_height check-zero ] [ ] tri
-    cairo-surface>array png boa ;
-
-: write-png ( png path -- )
-    >r png-surface r>
-    cairo_surface_write_to_png
-    zero? [ "write png failed" throw ] unless ;
-
-: <png-gadget> ( path -- gadget )
-    png-gadget construct-gadget swap
-    <png> >>png ;
-
-M: png-gadget pref-dim* ( gadget -- )
-    png>>
-    [ width>> ] [ height>> ] bi 2array ;
-
-M: png-gadget draw-gadget* ( gadget -- )
-    origin get [
-        0 0 glRasterPos2i
-        1.0 -1.0 glPixelZoom
-        png>>
-        [ width>> ]
-        [ height>> GL_RGBA GL_UNSIGNED_BYTE ]
-        ! [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
-        [ array>> ] tri
-        glDrawPixels
-    ] with-translation ;
-
-M: png-gadget graft* ( gadget -- )
-    drop ;
-
-M: png-gadget ungraft* ( gadget -- )
-    png>> surface>> cairo_destroy ;
-
-! "resource:misc/icons/Factor_1x16.png" USE: cairo.png <png-gadget> gadget.

extra/cairo/samples/samples.factor

@@ -0,0 +1,140 @@
+! Copyright (C) 2008 Matthew Willis
+! See http://factorcode.org/license.txt for BSD license.
+!
+! these samples are a subset of the samples on
+! http://cairographics.org/samples/
+USING: cairo cairo.lib locals math.constants math
+io.backend kernel alien.c-types libc namespaces ;
+
+IN: cairo.samples
+
+:: arc ( -- )
+    [let | xc [ 128.0 ]
+           yc [ 128.0 ]
+           radius [ 100.0 ]
+           angle1 [ pi 1/4 * ]
+           angle2 [ pi ] |
+        cr 10.0 cairo_set_line_width
+        cr xc yc radius angle1 angle2 cairo_arc
+        cr cairo_stroke
+        
+        ! draw helping lines
+        cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+        cr 6.0 cairo_set_line_width
+        
+        cr xc yc 10.0 0 2 pi * cairo_arc
+        cr cairo_fill
+        
+        cr xc yc radius angle1 angle1 cairo_arc
+        cr xc yc cairo_line_to
+        cr xc yc radius angle2 angle2 cairo_arc
+        cr xc yc cairo_line_to
+        cr cairo_stroke
+    ] ;
+
+: clip ( -- )
+    cr 128 128 76.8 0 2 pi * cairo_arc
+    cr cairo_clip
+    cr cairo_new_path
+    
+    cr 0 0 256 256 cairo_rectangle
+    cr cairo_fill
+    cr 0 1 0 cairo_set_source_rgb
+    cr 0 0 cairo_move_to
+    cr 256 256 cairo_line_to
+    cr 256 0 cairo_move_to
+    cr 0 256 cairo_line_to
+    cr 10 cairo_set_line_width
+    cr cairo_stroke ;
+
+:: clip-image ( -- )
+    [let* | png [ "resource:misc/icons/Factor_128x128.png"
+                  normalize-path cairo_image_surface_create_from_png ]
+            w [ png cairo_image_surface_get_width ]
+            h [ png cairo_image_surface_get_height ] |
+        cr 128 128 76.8 0 2 pi * cairo_arc
+        cr cairo_clip
+        cr cairo_new_path
+
+        cr 192.0 w / 192.0 h / cairo_scale
+        cr png 32 32 cairo_set_source_surface
+        cr cairo_paint
+        png cairo_surface_destroy
+    ] ;
+
+:: dash ( -- )
+    [let | dashes [ { 50 10 10 10 } >c-double-array ]
+           ndash [ 4 ] |
+        cr dashes ndash -50 cairo_set_dash
+        cr 10 cairo_set_line_width
+        cr 128.0 25.6 cairo_move_to
+        cr 230.4 230.4 cairo_line_to
+        cr -102.4 0 cairo_rel_line_to
+        cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
+        cr cairo_stroke
+    ] ;
+
+:: gradient ( -- )
+    [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
+           radial [ 115.2 102.4 25.6 102.4 102.4 128.0
+                    cairo_pattern_create_radial ] |
+        pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+        pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+        cr 0 0 256 256 cairo_rectangle
+        cr pat cairo_set_source
+        cr cairo_fill
+        pat cairo_pattern_destroy
+        
+        radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+        radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+        cr radial cairo_set_source
+        cr 128.0 128.0 76.8 0 2 pi * cairo_arc
+        cr cairo_fill
+        radial cairo_pattern_destroy
+    ] ;
+
+: text ( -- )
+    cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
+    cairo_select_font_face
+    cr 50 cairo_set_font_size
+    cr 10 135 cairo_move_to
+    cr "Hello" cairo_show_text
+    
+    cr 70 165 cairo_move_to
+    cr "factor" cairo_text_path
+    cr 0.5 0.5 1 cairo_set_source_rgb
+    cr cairo_fill_preserve
+    cr 0 0 0 cairo_set_source_rgb
+    cr 2.56 cairo_set_line_width
+    cr cairo_stroke
+    
+    ! draw helping lines
+    cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+    cr 10 135 5.12 0 2 pi * cairo_arc
+    cr cairo_close_path
+    cr 70 165 5.12 0 2 pi * cairo_arc
+    cr cairo_fill ;
+
+: utf8 ( -- )
+    cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
+    cairo_select_font_face
+    cr 50 cairo_set_font_size
+    "cairo_text_extents_t" malloc-object
+    cr B{ 230 151 165 230 156 172 232 170 158 } pick cairo_text_extents
+    cr over
+    [ cairo_text_extents_t-width 2 / ]
+    [ cairo_text_extents_t-x_bearing ] bi +
+    128 swap - pick
+    [ cairo_text_extents_t-height 2 / ]
+    [ cairo_text_extents_t-y_bearing ] bi +
+    128 swap - cairo_move_to
+    free
+    cr B{ 230 151 165 230 156 172 232 170 158 } cairo_show_text
+    
+    cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+    cr 6 cairo_set_line_width
+    cr 128 0 cairo_move_to
+    cr 0 256 cairo_rel_line_to
+    cr 0 128 cairo_move_to
+    cr 256 0 cairo_rel_line_to
+    cr cairo_stroke ;

extra/delegate/delegate-tests.factor

@@ -1,5 +1,6 @@
 USING: delegate kernel arrays tools.test words math definitions
-compiler.units parser generic prettyprint io.streams.string ;
+compiler.units parser generic prettyprint io.streams.string
+accessors ;
 IN: delegate.tests
 
 TUPLE: hello this that ;
@@ -16,14 +17,14 @@ PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
 : hello-test ( hello/goodbye -- array )
     [ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
 
-CONSULT: baz goodbye goodbye-these ;
+CONSULT: baz goodbye these>> ;
-M: hello foo hello-this ;
+M: hello foo this>> ;
 M: hello bar hello-test ;
-M: hello whoa >r hello-this r> + ;
+M: hello whoa >r this>> r> + ;
 
 GENERIC: bing ( c -- d )
 PROTOCOL: bee bing ;
-CONSULT: hello goodbye goodbye-those ;
+CONSULT: hello goodbye those>> ;
 M: hello bing hello-test ;
 
 [ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
@@ -33,11 +34,48 @@ M: hello bing hello-test ;
 [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
 [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
 
-[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
+[ ] [ 3 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
 [ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
 [ H{ } ] [ bee protocol-consult ] unit-test
 
 [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
 
-! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
+GENERIC: one
-! [ f ] [ goodbye baz method ] unit-test
+M: integer one ;
+GENERIC: two
+M: integer two ;
+GENERIC: three
+M: integer three ;
+GENERIC: four
+M: integer four ;
+
+PROTOCOL: alpha one two ;
+PROTOCOL: beta three ;
+
+TUPLE: hey value ;
+C: <hey> hey
+CONSULT: alpha hey value>> 1+ ;
+CONSULT: beta hey value>> 1- ;
+
+[ 2 ] [ 1 <hey> one ] unit-test
+[ 2 ] [ 1 <hey> two ] unit-test
+[ 0 ] [ 1 <hey> three ] unit-test
+[ { hey } ] [ alpha protocol-users ] unit-test
+[ { hey } ] [ beta protocol-users ] unit-test
+[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test
+[ f ] [ hey \ two method ] unit-test
+[ f ] [ hey \ four method ] unit-test
+[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test
+[ { hey } ] [ alpha protocol-users ] unit-test
+[ { hey } ] [ beta protocol-users ] unit-test
+[ 2 ] [ 1 <hey> one ] unit-test
+[ 0 ] [ 1 <hey> two ] unit-test
+[ 0 ] [ 1 <hey> three ] unit-test
+[ 0 ] [ 1 <hey> four ] unit-test
+[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test
+[ 2 ] [ 1 <hey> one ] unit-test
+[ -1 ] [ 1 <hey> two ] unit-test
+[ -1 ] [ 1 <hey> three ] unit-test
+[ -1 ] [ 1 <hey> four ] unit-test
+[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
+[ f ] [ hey \ one method ] unit-test

extra/delegate/delegate.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser generic kernel classes words slots assocs sequences arrays
+USING: parser generic kernel classes words slots assocs
-vectors definitions prettyprint combinators.lib math hashtables sets ;
+sequences arrays vectors definitions prettyprint combinators.lib
+math hashtables sets ;
 IN: delegate
 
 : protocol-words ( protocol -- words )
@@ -22,7 +23,8 @@ M: tuple-class group-words
 
 : consult-method ( word class quot -- )
     [ drop swap first create-method ]
-    [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
+    [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi
+    define ;
 
 : change-word-prop ( word prop quot -- )
     rot word-props swap change-at ; inline
@@ -31,10 +33,9 @@ M: tuple-class group-words
     rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
 
 : define-consult ( group class quot -- )
-    [ register-protocol ] [
+    [ register-protocol ]
-        rot group-words -rot
+    [ rot group-words -rot [ consult-method ] 2curry each ]
-        [ consult-method ] 2curry each
+    3bi ;
-    ] 3bi ;
 
 : CONSULT:
     scan-word scan-word parse-definition define-consult ; parsing
@@ -45,7 +46,7 @@ M: tuple-class group-words
     [ with each ] 2curry each ; inline
 
 : forget-all-methods ( classes words -- )
-    [ 2array forget ] cross-2each ;
+    [ first method forget ] cross-2each ;
 
 : protocol-users ( protocol -- users )
     protocol-consult keys ;
@@ -54,19 +55,21 @@ M: tuple-class group-words
     >r protocol-words r> diff ;
 
 : forget-old-definitions ( protocol new-wordlist -- )
-    >r [ protocol-users ] [ protocol-words ] bi r>
+    [ drop protocol-users ] [ lost-words ] 2bi
-    swap diff forget-all-methods ;
+    forget-all-methods ;
 
 : added-words ( protocol wordlist -- added-words )
-    swap protocol-words swap diff ;
+    swap protocol-words diff ;
 
 : add-new-definitions ( protocol wordlist -- )
-     dupd added-words >r protocol-consult >alist r>
+    [ drop protocol-consult >alist ] [ added-words ] 2bi
-     [ first2 consult-method ] cross-2each ;
+    [ swap first2 consult-method ] cross-2each ;
 
 : initialize-protocol-props ( protocol wordlist -- )
-    [ drop H{ } clone \ protocol-consult set-word-prop ]
+    [
-    [ { } like \ protocol-words set-word-prop ] 2bi ;
+        drop \ protocol-consult
+        [ H{ } assoc-like ] change-word-prop
+    ] [ { } like \ protocol-words set-word-prop ] 2bi ;
 
 : fill-in-depth ( wordlist -- wordlist' )
     [ dup word? [ 0 2array ] when ] map ;

extra/delegate/protocols/protocols.factor

@@ -1,16 +1,19 @@
 ! Copyright (C) 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: delegate sequences.private sequences assocs prettyprint.sections 
+USING: delegate sequences.private sequences assocs
-io definitions kernel continuations listener ;
+prettyprint.sections io definitions kernel continuations
+listener ;
 IN: delegate.protocols
 
 PROTOCOL: sequence-protocol
-    clone clone-like like new-sequence new-resizable nth nth-unsafe
+    clone clone-like like new-sequence new-resizable nth
-    set-nth set-nth-unsafe length set-length lengthen ;
+    nth-unsafe set-nth set-nth-unsafe length set-length
+    lengthen ;
 
 PROTOCOL: assoc-protocol
-    at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 }
+    at* assoc-size >alist set-at assoc-clone-like
-    delete-at clear-assoc new-assoc assoc-like ;
+    { assoc-find 1 } delete-at clear-assoc new-assoc
+    assoc-like ;
 
 PROTOCOL: input-stream-protocol
     stream-read1 stream-read stream-read-partial stream-readln

extra/descriptive/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

extra/descriptive/descriptive-docs.factor

@@ -0,0 +1,22 @@
+USING: help.syntax help.markup ;
+IN: descriptive
+
+HELP: DESCRIPTIVE:
+{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }
+{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
+
+HELP: DESCRIPTIVE::
+{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }
+{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
+
+HELP: descriptive
+{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
+
+ARTICLE: "descriptive" "Descriptive errors"
+"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:"
+{ $subsection descriptive }
+"To define words which throw descriptive errors, use the following words:"
+{ $subsection POSTPONE: DESCRIPTIVE: }
+{ $subsection POSTPONE: DESCRIPTIVE:: } ;
+
+ABOUT: "descriptive"

extra/descriptive/descriptive-tests.factor

@@ -0,0 +1,16 @@
+USING: descriptive kernel math tools.test continuations prettyprint io.streams.string ;
+IN: descriptive.tests
+
+DESCRIPTIVE: divide ( num denom -- fraction ) / ;
+
+[ 3 ] [ 9 3 divide ] unit-test
+[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test
+
+[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test
+
+DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;
+
+[ 3 ] [ 9 3 divide* ] unit-test
+[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test
+
+[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test

extra/descriptive/descriptive.factor

@@ -0,0 +1,45 @@
+USING: words kernel sequences combinators.lib locals
+locals.private accessors parser namespaces continuations
+inspector definitions arrays.lib arrays ;
+IN: descriptive
+
+ERROR: descriptive-error args underlying word ;
+
+M: descriptive-error summary
+    word>> "The " swap word-name " word encountered an error."
+    3append ;
+
+<PRIVATE
+: rethrower ( word inputs -- quot )
+    [ length ] keep [ >r narray r> swap 2array flip ] 2curry
+    [ 2 ndip descriptive-error ] 2curry ;
+
+: [descriptive] ( word def -- newdef )
+    swap dup "declared-effect" word-prop in>> rethrower
+    [ recover ] 2curry ;
+PRIVATE>
+
+: define-descriptive ( word def -- )
+    [ "descriptive-definition" set-word-prop ]
+    [ dupd [descriptive] define ] 2bi ;
+
+: DESCRIPTIVE:
+    (:) define-descriptive ; parsing
+
+PREDICATE: descriptive < word
+    "descriptive-definition" word-prop ;
+
+M: descriptive definer drop \ DESCRIPTIVE: \ ; ;
+
+M: descriptive definition
+    "descriptive-definition" word-prop ;
+
+: DESCRIPTIVE::
+    (::) define-descriptive ; parsing
+
+INTERSECTION: descriptive-lambda descriptive lambda-word ;
+
+M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;
+
+M: descriptive-lambda definition
+    "lambda" word-prop body>> ;

extra/descriptive/summary.txt

@@ -0,0 +1 @@
+Descriptive errors generated automatically for specially defined words

extra/ftp/client/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/ftp/client/client.factor

@@ -0,0 +1,138 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes.singleton combinators continuations
+io io.encodings.binary io.encodings.ascii io.files io.sockets
+kernel math math.parser sequences splitting namespaces strings ;
+IN: ftp.client
+
+TUPLE: ftp-client host port stream user password mode ;
+TUPLE: ftp-response n strings ;
+
+SINGLETON: active
+SINGLETON: passive
+
+: <ftp-response> ( -- ftp-response )
+    ftp-response new
+        V{ } clone >>strings ;
+
+: <ftp-client> ( host -- ftp-client )
+    ftp-client new
+        swap >>host
+        21 >>port
+        "anonymous" >>user
+        "factor-ftp@factorcode.org" >>password ;
+
+: add-response-line ( ftp-response string -- ftp-response )
+    over strings>> push ;
+
+: (ftp-response-code) ( str -- n )
+    3 head string>number ;
+
+: ftp-response-code ( string -- n/f )
+    dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
+
+: last-code ( ftp-response -- n )
+    strings>> peek (ftp-response-code) ;
+
+: read-response-until ( stream ftp-response n -- ftp-response )
+    >r over stream-readln
+    [ add-response-line ] [ ftp-response-code ] bi
+    r> tuck = [ drop nip ] [ read-response-until ] if ;
+
+: read-response ( stream -- ftp-response )
+    <ftp-response>
+    over stream-readln
+    [ add-response-line ] [ fourth CHAR: - = ] bi
+    [ dup last-code read-response-until ]
+    [ nip ] if dup last-code >>n ;
+
+: ftp-read ( ftp-client -- ftp-response )
+    stream>> read-response ;
+
+: ftp-send ( str ftp-client -- )
+    stream>>
+    [ stream-write ]
+    [ "\r\n" swap stream-write ]
+    [ stream-flush ] tri ;
+
+: ftp-command ( string ftp-client -- ftp-response )
+    [ ftp-send ] [ ftp-read ] bi ;
+
+: ftp-user ( ftp-client -- ftp-response )
+    [ user>> "USER " prepend ] [ ftp-command ] bi ;
+
+: ftp-password ( ftp-client -- ftp-response )
+    [ password>> "PASS " prepend ] [ ftp-command ] bi ;
+
+: ftp-set-binary ( ftp-client -- ftp-response )
+    >r "TYPE I" r> ftp-command ;
+
+: ftp-pwd ( ftp-client -- ftp-response )
+    >r "PWD" r> ftp-command ;
+
+: ftp-list ( ftp-client -- ftp-response )
+    >r "LIST" r> ftp-command ;
+
+: ftp-quit ( ftp-client -- ftp-response )
+    >r "QUIT" r> ftp-command ;
+
+: ftp-cwd ( directory ftp-client -- ftp-response )
+    >r "CWD " prepend r> ftp-command ;
+
+: ftp-retr ( filename ftp-client -- ftp-response )
+    >r "RETR " prepend r> ftp-command ;
+
+: parse-epsv ( ftp-response -- port )
+    strings>> first
+    "|" split 2 tail* first string>number ;
+
+: ftp-epsv ( ftp-client -- ftp-response )
+    >r "EPSV" r> ftp-command ;
+
+M: ftp-client dispose ( ftp-client -- )
+    [ ftp-quit drop ] [ stream>> dispose ] bi ;
+
+ERROR: ftp-error got expected ;
+: ftp-assert ( ftp-response n -- )
+    2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
+
+: ftp-connect ( ftp-client -- )
+    dup
+    [ host>> ] [ port>> ] bi <inet> ascii <client>
+    >>stream drop ;
+
+: ftp-login ( ftp-client -- )
+    {
+        [ ftp-connect ]
+        [ ftp-read 220 ftp-assert ]
+        [ ftp-user 331 ftp-assert ]
+        [ ftp-password 230 ftp-assert ]
+        [ ftp-set-binary 200 ftp-assert ]
+    } cleave ;
+
+: start-2nd ( ftp-client -- port )
+    ftp-epsv [ 229 ftp-assert ] [ parse-epsv ] bi ;
+
+: list ( ftp-client -- ftp-response )
+    dup [ host>> ] [ start-2nd ] bi <inet> ascii <client>
+    over ftp-list 150 ftp-assert
+    lines <ftp-response> swap >>strings
+    >r ftp-read 226 ftp-assert r> ;
+
+: ftp-get ( filename ftp-client -- ftp-response )
+    dup [ host>> ] [ start-2nd ] bi <inet> binary <client>
+    rot tuck
+    [ over ftp-retr 150 ftp-assert ]
+    [ binary <file-writer> stream-copy ] 2bi*
+    ftp-read dup 226 ftp-assert ;
+
+GENERIC: ftp-download ( path obj -- )
+
+M: ftp-client ftp-download ( path ftp-client -- )
+    dup ftp-login
+    [ >r parent-directory r> ftp-cwd drop ]
+    [ >r file-name r> ftp-get drop ]
+    [ dispose drop ] 2tri ;
+
+M: string ftp-download ( path string -- )
+    <ftp-client> ftp-download ;

extra/io/encodings/ascii/ascii.factor

@@ -13,7 +13,7 @@ IN: io.encodings.ascii
     [ drop f ] if* ;
 PRIVATE>
 
-TUPLE: ascii ;
+SINGLETON: ascii
 
 M: ascii encode-char
     128 encode-if< ;

extra/io/streams/duplex/duplex.factor

@@ -47,7 +47,7 @@ M: duplex-stream dispose
     ] unless drop ;
 
 : <encoder-duplex> ( stream-in stream-out encoding -- duplex )
-    tuck reencode >r redecode r> <duplex-stream> ;
+    tuck re-encode >r re-decode r> <duplex-stream> ;
 
 : with-stream* ( stream quot -- )
     >r [ in>> ] [ out>> ] bi r> with-streams* ; inline

extra/locals/locals-tests.factor

@@ -246,3 +246,11 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
 : no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
 
 [ { 4 5 6 } ] [ no-with-locals-test ] unit-test
+
+{ 3 0 } [| a b c | ] must-infer-as
+
+[ ] [ 1 [let | a [ ] | ] ] unit-test
+
+[ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
+
+[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test

extra/locals/locals.factor

@@ -116,7 +116,9 @@ UNION: special local quote local-word local-reader local-writer ;
     2tri 3append >quotation ;
 
 : point-free ( quot args -- newquot )
-    over empty? [ drop ] [ (point-free) ] if ;
+    over empty?
+    [ nip length \ drop <repetition> >quotation ]
+    [ (point-free) ] if ;
 
 UNION: lexical local local-reader local-writer local-word ;
 
@@ -355,40 +357,34 @@ M: wlet pprint* \ [wlet pprint-let ;
 
 M: let* pprint* \ [let* pprint-let ;
 
-PREDICATE: lambda-word < word
+PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
-    "lambda" word-prop >boolean ;
 
 M: lambda-word definer drop \ :: \ ; ;
 
 M: lambda-word definition
     "lambda" word-prop body>> ;
 
-: lambda-word-synopsis ( word -- )
+INTERSECTION: lambda-macro macro lambda-word ;
-    dup definer.
-    dup seeing-word
-    dup pprint-word
-    stack-effect. ;
-
-M: lambda-word synopsis* lambda-word-synopsis ;
-
-PREDICATE: lambda-macro < macro
-    "lambda" word-prop >boolean ;
 
 M: lambda-macro definer drop \ MACRO:: \ ; ;
 
 M: lambda-macro definition
     "lambda" word-prop body>> ;
 
-M: lambda-macro synopsis* lambda-word-synopsis ;
+INTERSECTION: lambda-method method-body lambda-word ;
-
-PREDICATE: lambda-method < method-body
-    "lambda" word-prop >boolean ;
 
 M: lambda-method definer drop \ M:: \ ; ;
 
 M: lambda-method definition
     "lambda" word-prop body>> ;
 
+INTERSECTION: lambda-memoized memoized lambda-word ;
+
+M: lambda-memoized definer drop \ MEMO:: \ ; ;
+
+M: lambda-memoized definition
+    "lambda" word-prop body>> ;
+
 : method-stack-effect ( method -- effect )
     dup "lambda" word-prop vars>>
     swap "method-generic" word-prop stack-effect

extra/tools/deploy/backend/backend.factor

@@ -8,14 +8,14 @@ debugger io.streams.c io.files io.backend
 quotations io.launcher words.private tools.deploy.config
 bootstrap.image io.encodings.utf8 accessors ;
 IN: tools.deploy.backend
-    
+
 : copy-vm ( executable bundle-name extension -- vm )
   [ prepend-path ] dip append vm over copy-file ;
-  
+
-: copy-fonts ( name dir -- )  
+: copy-fonts ( name dir -- )
-  append-path "fonts/" resource-path swap copy-tree-into ;
+  append-path "resource:fonts/" swap copy-tree-into ;
-  
+
-: image-name ( vocab bundle-name -- str )  
+: image-name ( vocab bundle-name -- str )
   prepend-path ".image" append ;
 
 : (copy-lines) ( stream -- )

extra/tools/deploy/windows/windows-tests.factor

@@ -0,0 +1,7 @@
+IN: tools.deploy.windows.tests
+USING: tools.deploy.windows tools.test sequences ;
+
+[ t ] [
+    "foo" "resource:temp/test-copy-files" create-exe-dir
+    ".exe" tail?
+] unit-test

extra/tools/deploy/windows/windows.factor

@@ -2,12 +2,15 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io io.files kernel namespaces sequences system
 tools.deploy.backend tools.deploy.config assocs hashtables
-prettyprint windows.shell32 windows.user32 ;
+prettyprint combinators windows.shell32 windows.user32 ;
 IN: tools.deploy.windows
 
 : copy-dlls ( bundle-name -- )
-    { "resource:freetype6.dll" "resource:zlib1.dll" "resource:factor.dll" }
+    {
-    swap copy-files-into ;
+        "resource:freetype6.dll"
+        "resource:zlib1.dll"
+        "resource:factor.dll"
+    } swap copy-files-into ;
 
 : create-exe-dir ( vocab bundle-name -- vm )
     dup copy-dlls
@@ -15,11 +18,15 @@ IN: tools.deploy.windows
     ".exe" copy-vm ;
 
 M: winnt deploy*
-    "." resource-path [
+    "resource:" [
-        dup deploy-config [
+        deploy-name over deploy-config at
-            [ deploy-name get create-exe-dir ] keep
+        [
-            [ deploy-name get image-name ] keep
+            {
-            [ namespace make-deploy-image ] keep
+                [ create-exe-dir ]
-            open-in-explorer
+                [ image-name ]
-        ] bind
+                [ drop ]
+                [ drop deploy-config ]
+            } 2cleave make-deploy-image
+        ]
+        [ nip open-in-explorer ] 2bi
     ] with-directory ;

extra/tools/time/time-docs.factor

@@ -16,7 +16,7 @@ ABOUT: "timing"
 HELP: benchmark
 { $values { "quot" "a quotation" }
           { "runtime" "an integer denoting milliseconds" } }
-{ $description "Runs a quotation, measuring the total wall clock time and the total time spent in the garbage collector." }
+      { $description "Runs a quotation, measuring the total wall clock time." }
 { $notes "A nicer word for interactive use is " { $link time } "." } ;
 
 HELP: time

extra/unicode/breaks/breaks.factor

@@ -1,7 +1,7 @@
 USING: unicode.categories kernel math combinators splitting
 sequences math.parser io.files io assocs arrays namespaces
 math.ranges unicode.normalize values io.encodings.ascii
-unicode.syntax unicode.data compiler.units alien.syntax  ;
+unicode.syntax unicode.data compiler.units alien.syntax sets ;
 IN: unicode.breaks
 
 C-ENUM: Any L V T Extend Control CR LF graphemes ;
@@ -27,7 +27,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
     [ "#" split1 drop ";" split1 drop trim-blank ] map
     [ empty? not ] filter
     [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
-    concat [ dup ] H{ } map>assoc ;
+    concat unique ;
 
 : other-extend-lines ( -- lines )
     "resource:extra/unicode/PropList.txt" ascii file-lines ;

vm/data_gc.c

@@ -648,12 +648,63 @@ void do_code_slots(CELL scan)
 	}
 }
 
+/* This function is performance-critical */
 CELL collect_next(CELL scan)
 {
-	do_slots(scan,copy_handle);
+	CELL *obj = (CELL *)scan;
+	CELL *end = (CELL *)(scan + binary_payload_start(scan));
+
+	obj++;
+
+	CELL newspace_start = newspace->start;
+	CELL newspace_end = newspace->end;
+
+	if(HAVE_NURSERY_P && collecting_gen == NURSERY)
+	{
+		CELL nursery_start = nursery.start;
+		CELL nursery_end = nursery.end;
+
+		for(; obj < end; obj++)
+		{
+			CELL pointer = *obj;
+
+			if(!immediate_p(pointer)
+				&& (pointer >= nursery_start && pointer < nursery_end))
+				*obj = copy_object(pointer);
+		}
+	}
+	else if(HAVE_AGING_P && collecting_gen == AGING)
+	{
+		F_ZONE *tenured = &data_heap->generations[TENURED];
+
+		CELL tenured_start = tenured->start;
+		CELL tenured_end = tenured->end;
+
+		for(; obj < end; obj++)
+		{
+			CELL pointer = *obj;
+
+			if(!immediate_p(pointer)
+				&& !(pointer >= newspace_start && pointer < newspace_end)
+				&& !(pointer >= tenured_start && pointer < tenured_end))
+				*obj = copy_object(pointer);
+		}
+	}
+	else if(collecting_gen == TENURED)
+	{
+		for(; obj < end; obj++)
+		{
+			CELL pointer = *obj;
+
+			if(!immediate_p(pointer)
+				&& !(pointer >= newspace_start && pointer < newspace_end))
+				*obj = copy_object(pointer);
+		}
 
-	if(collecting_gen == TENURED)
 		do_code_slots(scan);
+	}
+	else
+		critical_error("Bug in collect_next",0);
 
 	return scan + untagged_object_size(scan);
 }

vm/layouts.h

@@ -64,7 +64,7 @@ typedef signed long long s64;
 
 INLINE bool immediate_p(CELL obj)
 {
-	return (TAG(obj) == FIXNUM_TYPE || obj == F);
+	return (obj == F || TAG(obj) == FIXNUM_TYPE);
 }
 
 INLINE F_FIXNUM untag_fixnum_fast(CELL tagged)