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

basis/windows/offscreen/offscreen.factor

@@ -42,6 +42,7 @@ IN: windows.offscreen
         swap >>dim
         swap >>bitmap
         BGRX >>component-order
+        ubyte-components >>component-type
         t >>upside-down? ;
 
 : with-memory-dc ( quot: ( hDC -- ) -- )
@@ -50,4 +51,4 @@ IN: windows.offscreen
 :: make-bitmap-image ( dim dc quot -- image )
     dim dc make-bitmap [ &DeleteObject drop ] dip
     quot dip
-    dim bitmap>image ; inline
+    dim bitmap>image ; inline

core/classes/tuple/parser/parser.factor

@@ -33,7 +33,7 @@ ERROR: invalid-slot-name name ;
 : parse-long-slot-name ( -- spec )
     [ scan , \ } parse-until % ] { } make ;
 
-: parse-slot-name ( string/f -- ? )
+: parse-slot-name-delim ( end-delim string/f -- ? )
     #! This isn't meant to enforce any kind of policy, just
     #! to check for mistakes of this form:
     #!
@@ -43,12 +43,18 @@ ERROR: invalid-slot-name name ;
     {
         { [ dup not ] [ unexpected-eof ] }
         { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
-        { [ dup ";" = ] [ drop f ] }
+        { [ 2dup = ] [ drop f ] }
         [ dup "{" = [ drop parse-long-slot-name ] when , t ]
-    } cond ;
+    } cond nip ;
+
+: parse-tuple-slots-delim ( end-delim -- )
+    dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+
+: parse-slot-name ( string/f -- ? )
+    ";" swap parse-slot-name-delim ;
 
 : parse-tuple-slots ( -- )
-    scan parse-slot-name [ parse-tuple-slots ] when ;
+    ";" parse-tuple-slots-delim ;
 
 : parse-tuple-definition ( -- class superclass slots )
     CREATE-CLASS

extra/variants/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/variants/summary.txt

@@ -0,0 +1 @@
+Syntax and combinators for manipulating algebraic data types

extra/variants/variants-docs.factor

@@ -0,0 +1,63 @@
+! (c)2009 Joe Groff bsd license
+USING: arrays classes classes.singleton classes.tuple help.markup
+help.syntax kernel multiline slots quotations ;
+IN: variants
+
+HELP: VARIANT:
+{ $syntax <"
+VARIANT: class-name
+    singleton
+    singleton
+    tuple: { slot slot slot ... }
+    .
+    .
+    .
+    ; "> }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots are able to recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $examples { $code <"
+USING: kernel variants ;
+IN: scratchpad
+
+VARIANT: list
+    nil
+    cons: { { first object } { rest list } }
+    ;
+"> } } ;
+
+HELP: match
+{ $values { "branches" array } }
+{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with an empty stack. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
+{ $examples { $example <"
+USING: kernel math prettyprint variants ;
+IN: scratchpad
+
+VARIANT: list
+    nil
+    cons: { { first object } { rest list } }
+    ;
+
+: list-length ( list -- length )
+    {
+        { nil [ 0 ] }
+        { cons [ nip list-length 1 + ] }
+    } match ;
+
+1 2 3 4 nil <cons> <cons> <cons> <cons> list-length .
+"> "4" } } ;
+
+HELP: unboa
+{ $values { "class" class } }
+{ $description "Decomposes a tuple of type " { $snippet "class" } " into its component slot values by order of arguments. The inverse of " { $link boa } "." } ;
+
+HELP: variant-class
+{ $class-description "This class comprises class names that have been defined with " { $link POSTPONE: VARIANT: } ". When a " { $snippet "variant-class" } " is used as the type of a specialized " { $link tuple } " slot, the variant's first member type is used as the default " { $link initial-value } "." } ;
+
+{ POSTPONE: VARIANT: variant-class match } related-words
+
+ARTICLE: "variants" "Algebraic data types"
+"The " { $vocab-link "variants" } " vocabulary provides syntax and combinators for defining and manipulating algebraic data types."
+{ $subsection POSTPONE: VARIANT: }
+{ $subsection variant-class }
+{ $subsection match } ;
+
+ABOUT: "variants"

extra/variants/variants-tests.factor

@@ -0,0 +1,21 @@
+! (c)2009 Joe Groff bsd license
+USING: kernel math tools.test variants ;
+IN: variants.tests
+
+VARIANT: list
+    nil
+    cons: { { first object } { rest list } }
+    ;
+
+[ t ] [ nil list? ] unit-test
+[ t ] [ 1 nil <cons> list? ] unit-test
+[ f ] [ 1 list? ] unit-test
+
+: list-length ( list -- length )
+    {
+        { nil  [ 0 ] }
+        { cons [ nip list-length 1 + ] }
+    } match ;
+
+[ 4 ]
+[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test

extra/variants/variants.factor

@@ -0,0 +1,59 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays classes classes.mixin classes.parser
+classes.singleton classes.tuple classes.tuple.parser
+classes.union combinators inverse kernel lexer macros make
+parser quotations sequences slots splitting words ;
+IN: variants
+
+PREDICATE: variant-class < mixin-class "variant" word-prop ;
+
+M: variant-class initial-value*
+    dup members [ no-initial-value ]
+    [ nip first dup word? [ initial-value* ] unless ] if-empty ;
+
+: define-tuple-class-and-boa-word ( class superclass slots -- )
+    pick [ define-tuple-class ] dip
+    dup name>> "<" ">" surround create-in swap define-boa-word ;
+
+: define-variant-member ( member -- class )
+    dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
+
+: define-variant-class ( class members -- )
+    [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
+    [ define-variant-member swap add-mixin-instance ] with each ;
+
+: parse-variant-tuple-member ( name -- member )
+    create-class-in tuple
+    "{" expect
+    [ "}" parse-tuple-slots-delim ] { } make
+    3array ;
+
+: parse-variant-member ( name -- member )
+    ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
+
+: parse-variant-members ( -- members )
+    [ scan dup ";" = not ]
+    [ parse-variant-member ] produce nip ;
+
+SYNTAX: VARIANT:
+    CREATE-CLASS
+    parse-variant-members
+    define-variant-class ;
+
+MACRO: unboa ( class -- )
+    <wrapper> \ boa [ ] 2sequence [undo] ;
+
+GENERIC# (match-branch) 1 ( class quot -- class quot' )
+
+M: singleton-class (match-branch)
+    \ drop prefix ;
+M: object (match-branch)
+    over \ unboa [ ] 2sequence prepend ;
+
+: ?class ( object -- class )
+    dup word? [ class ] unless ;
+
+MACRO: match ( branches -- )
+    [ dup callable? [ first2 (match-branch) 2array ] unless ] map
+    [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
+