From b6abd4a90cc0dfde3e204013626df4bed4523fe3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 25 Jun 2009 09:15:04 -0500 Subject: [PATCH 1/3] windows.offscreen:make-bitmap-image wasn't filling in the component-type of the image object it makes --- basis/windows/offscreen/offscreen.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/windows/offscreen/offscreen.factor b/basis/windows/offscreen/offscreen.factor index 6e65958220..fea7240bf6 100755 --- a/basis/windows/offscreen/offscreen.factor +++ b/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 \ No newline at end of file + dim bitmap>image ; inline From 7a88c5ae8a884df266e335fd699db82701e97b56 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 26 Jun 2009 16:31:20 -0500 Subject: [PATCH 2/3] variants vocab for ADTs --- core/classes/tuple/parser/parser.factor | 14 ++++-- extra/variants/authors.txt | 1 + extra/variants/summary.txt | 1 + extra/variants/variants-tests.factor | 21 +++++++++ extra/variants/variants.factor | 59 +++++++++++++++++++++++++ 5 files changed, 92 insertions(+), 4 deletions(-) create mode 100644 extra/variants/authors.txt create mode 100644 extra/variants/summary.txt create mode 100644 extra/variants/variants-tests.factor create mode 100644 extra/variants/variants.factor diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index efb77e3274..6b106e48d9 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/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 diff --git a/extra/variants/authors.txt b/extra/variants/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/variants/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/variants/summary.txt b/extra/variants/summary.txt new file mode 100644 index 0000000000..142366be00 --- /dev/null +++ b/extra/variants/summary.txt @@ -0,0 +1 @@ +Syntax and combinators for manipulating algebraic data types diff --git a/extra/variants/variants-tests.factor b/extra/variants/variants-tests.factor new file mode 100644 index 0000000000..ef48b36b9c --- /dev/null +++ b/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 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 list-length ] unit-test diff --git a/extra/variants/variants.factor b/extra/variants/variants.factor new file mode 100644 index 0000000000..5cb786afde --- /dev/null +++ b/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 -- ) + \ 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 ; + From 911acd6a4a228fe09c7801c02a8b29966449be9e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 26 Jun 2009 17:12:08 -0500 Subject: [PATCH 3/3] docs for variants --- extra/variants/variants-docs.factor | 63 +++++++++++++++++++++++++++++ 1 file changed, 63 insertions(+) create mode 100644 extra/variants/variants-docs.factor diff --git a/extra/variants/variants-docs.factor b/extra/variants/variants-docs.factor new file mode 100644 index 0000000000..8ba1623f2e --- /dev/null +++ b/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 "" } " 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 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"