From 0dd811557b160666b352f6bf2b5264cae1586919 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Feb 2009 20:28:36 -0600 Subject: [PATCH 01/13] Removing sequences.next --- basis/sequences/next/authors.txt | 1 - basis/sequences/next/next-tests.factor | 5 ----- basis/sequences/next/next.factor | 21 --------------------- basis/sequences/next/summary.txt | 1 - basis/sequences/next/tags.txt | 1 - basis/unicode/case/case.factor | 2 +- 6 files changed, 1 insertion(+), 30 deletions(-) delete mode 100644 basis/sequences/next/authors.txt delete mode 100644 basis/sequences/next/next-tests.factor delete mode 100644 basis/sequences/next/next.factor delete mode 100644 basis/sequences/next/summary.txt delete mode 100644 basis/sequences/next/tags.txt diff --git a/basis/sequences/next/authors.txt b/basis/sequences/next/authors.txt deleted file mode 100644 index f990dd0ed2..0000000000 --- a/basis/sequences/next/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/basis/sequences/next/next-tests.factor b/basis/sequences/next/next-tests.factor deleted file mode 100644 index be728b2d8e..0000000000 --- a/basis/sequences/next/next-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: sequences.next tools.test arrays kernel math sequences ; - -[ { { 1 0 } { 2 1 } { f 2 } } ] [ 3 [ 2array ] map-next ] unit-test - -[ 8 ] [ 3 [ 1+ ] map 0 swap [ swap [ + + ] [ drop ] if* ] each-next ] unit-test diff --git a/basis/sequences/next/next.factor b/basis/sequences/next/next.factor deleted file mode 100644 index 19b406cc58..0000000000 --- a/basis/sequences/next/next.factor +++ /dev/null @@ -1,21 +0,0 @@ -USING: kernel sequences sequences.private math ; -IN: sequences.next - - - -: each-next ( seq quot: ( next-elt elt -- ) -- ) - iterate-seq [ (map-next) ] 2curry each-integer ; inline - -: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq ) - over dup length swap new-sequence [ - iterate-seq [ (map-next) ] 2curry - ] dip [ collect ] keep ; inline diff --git a/basis/sequences/next/summary.txt b/basis/sequences/next/summary.txt deleted file mode 100644 index fe5bd315de..0000000000 --- a/basis/sequences/next/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Iteration with access to next element diff --git a/basis/sequences/next/tags.txt b/basis/sequences/next/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/basis/sequences/next/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 7566138e11..65fab0ac38 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: unicode.data sequences sequences.next namespaces +USING: unicode.data sequences namespaces sbufs make unicode.syntax unicode.normalize math hints unicode.categories combinators unicode.syntax assocs strings splitting kernel accessors unicode.breaks fry locals ; From 86c3481f12ddd58a162c1d5994bd914a7e500443 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Feb 2009 21:17:03 -0600 Subject: [PATCH 02/13] Moving XML vocabularies around --- basis/farkup/farkup-tests.factor | 2 +- basis/farkup/farkup.factor | 2 +- basis/furnace/chloe-tags/chloe-tags.factor | 4 +- basis/help/html/html.factor | 2 +- basis/html/components/components-docs.factor | 2 +- basis/html/components/components.factor | 2 +- basis/html/elements/elements.factor | 2 +- basis/html/forms/forms.factor | 2 +- basis/html/html.factor | 4 +- basis/html/streams/streams.factor | 2 +- basis/html/templates/chloe/chloe.factor | 2 +- .../html/templates/chloe/syntax/syntax.factor | 2 +- basis/html/templates/templates.factor | 2 +- basis/http/http-tests.factor | 2 +- basis/http/server/responses/responses.factor | 2 +- basis/http/server/static/static.factor | 2 +- basis/lcs/diff2html/diff2html.factor | 2 +- basis/syndication/syndication.factor | 4 +- basis/xml-rpc/xml-rpc.factor | 4 +- basis/xml/data/data-docs.factor | 2 +- basis/xml/dispatch/dispatch-docs.factor | 25 --------- basis/xml/dispatch/dispatch-tests.factor | 33 ------------ basis/xml/dispatch/dispatch.factor | 32 ----------- basis/xml/literals/authors.txt | 1 - basis/xml/literals/summary.txt | 1 - basis/xml/literals/tags.txt | 2 - basis/xml/{dispatch => syntax}/authors.txt | 0 basis/xml/{dispatch => syntax}/summary.txt | 0 .../syntax-docs.factor} | 53 +++++++++++++++---- .../syntax-tests.factor} | 48 ++++++++++++++--- .../literals.factor => syntax/syntax.factor} | 47 ++++++++++++---- basis/xml/{dispatch => syntax}/tags.txt | 0 basis/xml/tests/encodings.factor | 2 +- basis/xml/tests/soap.factor | 2 +- basis/xml/tests/templating.factor | 2 +- basis/xml/tests/test.factor | 2 +- basis/xml/tests/xmltest.factor | 2 +- .../xml/{utilities => traversal}/authors.txt | 0 basis/xml/traversal/summary.txt | 1 + basis/xml/{utilities => traversal}/tags.txt | 0 .../traversal-docs.factor} | 8 +-- .../traversal-tests.factor} | 10 ++-- .../traversal.factor} | 13 +---- basis/xml/utilities/summary.txt | 1 - basis/xml/writer/writer-docs.factor | 4 +- basis/xml/writer/writer-tests.factor | 2 +- basis/xml/xml-docs.factor | 4 +- basis/xmode/code2html/code2html.factor | 2 +- basis/xmode/loader/loader.factor | 2 +- basis/xmode/loader/syntax/syntax.factor | 2 +- basis/xmode/utilities/utilities.factor | 2 +- .../space-file-decoder.factor | 2 +- extra/msxml-to-csv/msxml-to-csv.factor | 2 +- extra/svg/svg-tests.factor | 2 +- extra/svg/svg.factor | 2 +- extra/yahoo/yahoo.factor | 2 +- 56 files changed, 174 insertions(+), 187 deletions(-) delete mode 100644 basis/xml/dispatch/dispatch-docs.factor delete mode 100644 basis/xml/dispatch/dispatch-tests.factor delete mode 100644 basis/xml/dispatch/dispatch.factor delete mode 100644 basis/xml/literals/authors.txt delete mode 100644 basis/xml/literals/summary.txt delete mode 100644 basis/xml/literals/tags.txt rename basis/xml/{dispatch => syntax}/authors.txt (100%) rename basis/xml/{dispatch => syntax}/summary.txt (100%) rename basis/xml/{literals/literals-docs.factor => syntax/syntax-docs.factor} (53%) rename basis/xml/{literals/literals-tests.factor => syntax/syntax-tests.factor} (73%) rename basis/xml/{literals/literals.factor => syntax/syntax.factor} (83%) rename basis/xml/{dispatch => syntax}/tags.txt (100%) rename basis/xml/{utilities => traversal}/authors.txt (100%) create mode 100644 basis/xml/traversal/summary.txt rename basis/xml/{utilities => traversal}/tags.txt (100%) rename basis/xml/{utilities/utilities-docs.factor => traversal/traversal-docs.factor} (91%) rename basis/xml/{utilities/utilities-tests.factor => traversal/traversal-tests.factor} (73%) rename basis/xml/{utilities/utilities.factor => traversal/traversal.factor} (86%) delete mode 100644 basis/xml/utilities/summary.txt diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 49c4dab0db..60a9f785e6 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: farkup kernel peg peg.ebnf tools.test namespaces xml -urls.encoding assocs xml.utilities xml.data ; +urls.encoding assocs xml.traversal xml.data ; IN: farkup.tests relative-link-prefix off diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index bad41296ee..a5951a5080 100755 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators io io.streams.string kernel math namespaces peg peg.ebnf -sequences sequences.deep strings xml.entities xml.literals +sequences sequences.deep strings xml.entities xml.syntax vectors splitting xmode.code2html urls.encoding xml.data xml.writer ; IN: farkup diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index dd24d8dcde..6024607d37 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -7,8 +7,8 @@ xml xml.data xml.entities xml.writer -xml.utilities -xml.literals +xml.traversal +xml.syntax html.components html.elements html.forms diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 26fc4e2637..cccf320e44 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -5,7 +5,7 @@ io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs tools.vocabs tools.vocabs.browser namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order -sorting debugger html xml.literals xml.writer ; +sorting debugger html xml.syntax xml.writer ; IN: help.html : escape-char ( ch -- ) diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor index ce4bddde6a..b432cc0cc6 100644 --- a/basis/html/components/components-docs.factor +++ b/basis/html/components/components-docs.factor @@ -100,6 +100,6 @@ $nl { $subsection farkup } "Creating custom components:" { $subsection render* } -"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ; +"Custom components can emit HTML using the " { $vocab-link "xml.syntax" } " vocabulary." ; ABOUT: "html.components" diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index f811343df2..82bb75015e 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -4,7 +4,7 @@ USING: accessors kernel namespaces io math.parser assocs classes classes.tuple words arrays sequences splitting mirrors hashtables combinators continuations math strings inspector fry locals calendar calendar.format xml.entities xml.data -validators urls present xml.writer xml.literals xml +validators urls present xml.writer xml.syntax xml xmode.code2html lcs.diff2html farkup io.streams.string html html.streams html.forms ; IN: html.components diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index e23d929d6d..85df4f7b27 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.styles kernel namespaces prettyprint quotations sequences strings words xml.entities compiler.units effects -xml.data xml.literals urls math math.parser combinators +xml.data urls math math.parser combinators present fry io.streams.string xml.writer html ; IN: html.elements diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index 0a69e2ed70..d5c744beab 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors strings namespaces assocs hashtables io mirrors math fry sequences words continuations -xml.entities xml.writer xml.literals ; +xml.entities xml.writer xml.syntax ; IN: html.forms TUPLE: form errors values validation-failed ; diff --git a/basis/html/html.factor b/basis/html/html.factor index 5e86add10e..e86b4917d7 100644 --- a/basis/html/html.factor +++ b/basis/html/html.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel xml.data xml.writer xml.literals urls.encoding ; +USING: kernel xml.data xml.writer xml.syntax urls.encoding ; IN: html : simple-page ( title head body -- xml ) @@ -21,4 +21,4 @@ IN: html [XML <-> XML] ; : simple-link ( xml url -- xml' ) - url-encode swap [XML ><-> XML] ; \ No newline at end of file + url-encode swap [XML ><-> XML] ; diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 0a4b8eddd4..28d6e6d5de 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel assocs io io.styles math math.order math.parser -sequences strings make words combinators macros xml.literals html fry +sequences strings make words combinators macros xml.syntax html fry destructors ; IN: html.streams diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index e5b40fcfaa..6ab6722afe 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -5,7 +5,7 @@ namespaces make classes.tuple assocs splitting words arrays io io.files io.files.info io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml logging continuations -xml.data xml.writer xml.literals strings +xml.data xml.writer xml.syntax strings html.forms html html.elements diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index c2ecd4506b..f149c3fe47 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -5,7 +5,7 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize parser lexer io io.files io.encodings.utf8 io.streams.string unicode.case mirrors fry math urls -multiline xml xml.data xml.writer xml.utilities +multiline xml xml.data xml.writer xml.syntax html.components html.templates ; diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index efaf8d6a62..4aca73cc57 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -3,7 +3,7 @@ USING: accessors kernel fry io io.encodings.utf8 io.files debugger prettyprint continuations namespaces boxes sequences arrays strings html io.streams.string -quotations xml.data xml.writer xml.literals ; +quotations xml.data xml.writer xml.syntax ; IN: html.templates MIXIN: template diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index f593980467..49acdb639c 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -299,7 +299,7 @@ test-db [ [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test USING: html.components html.forms -xml xml.utilities validators +xml xml.traversal validators furnace furnace.conversations ; SYMBOL: a diff --git a/basis/http/server/responses/responses.factor b/basis/http/server/responses/responses.factor index c9b4600ac8..3902b7f5e2 100644 --- a/basis/http/server/responses/responses.factor +++ b/basis/http/server/responses/responses.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math.parser http accessors kernel xml.literals xml.writer +USING: math.parser http accessors kernel xml.syntax xml.writer io io.streams.string io.encodings.utf8 ; IN: http.server.responses diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 2df8838061..53d3d4f917 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -4,7 +4,7 @@ USING: calendar kernel math math.order math.parser namespaces parser sequences strings assocs hashtables debugger mime.types sorting logging calendar.format accessors splitting io io.files io.files.info io.directories io.pathnames io.encodings.binary -fry xml.entities destructors urls html xml.literals +fry xml.entities destructors urls html xml.syntax html.templates.fhtml http http.server http.server.responses http.server.redirection xml.writer ; IN: http.server.static diff --git a/basis/lcs/diff2html/diff2html.factor b/basis/lcs/diff2html/diff2html.factor index 16e6cc8d97..ca9e48eb05 100644 --- a/basis/lcs/diff2html/diff2html.factor +++ b/basis/lcs/diff2html/diff2html.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: lcs xml.literals xml.writer kernel strings ; +USING: lcs xml.syntax xml.writer kernel strings ; FROM: accessors => item>> ; FROM: io => write ; FROM: sequences => each if-empty when-empty map ; diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index 4cd5ef17b3..9901fd4ce4 100755 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg. ! Portions copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: xml.utilities kernel assocs math.order +USING: xml.traversal kernel assocs math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities.html io.files io - http.client namespaces make xml.literals hashtables + http.client namespaces make xml.syntax hashtables calendar.format accessors continuations urls present ; IN: syndication diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 24dfabc8ff..9632cbb1ac 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel xml arrays math generic http.client combinators hashtables namespaces io base64 sequences strings -calendar xml.data xml.writer xml.utilities assocs math.parser -debugger calendar.format math.order xml.literals xml.dispatch ; +calendar xml.data xml.writer xml.traversal assocs math.parser +debugger calendar.format math.order xml.syntax ; IN: xml-rpc ! * Sending RPC requests diff --git a/basis/xml/data/data-docs.factor b/basis/xml/data/data-docs.factor index 639ef5591c..8c837fdf19 100644 --- a/basis/xml/data/data-docs.factor +++ b/basis/xml/data/data-docs.factor @@ -10,7 +10,7 @@ ARTICLE: "xml.data" "XML data types" "Simple words for manipulating names:" { $subsection names-match? } { $subsection assure-name } -"For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ; +"For high-level tools for manipulating XML, see " { $vocab-link "xml.traversal" } ; ARTICLE: { "xml.data" "classes" } "XML data classes" "XML documents and chunks are made of the following classes:" diff --git a/basis/xml/dispatch/dispatch-docs.factor b/basis/xml/dispatch/dispatch-docs.factor deleted file mode 100644 index d3d24d736c..0000000000 --- a/basis/xml/dispatch/dispatch-docs.factor +++ /dev/null @@ -1,25 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax ; -IN: xml.dispatch - -ABOUT: "xml.dispatch" - -ARTICLE: "xml.dispatch" "Dispatch on XML tag names" -"The " { $link "xml.dispatch" } " vocabulary defines a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use" -{ $subsection POSTPONE: TAGS: } -"and to define a new 'method' for this word, use" -{ $subsection POSTPONE: TAG: } ; - -HELP: TAGS: -{ $syntax "TAGS: word" } -{ $values { "word" "a new word to define" } } -{ $description "Creates a new word to which dispatches on XML tag names." } -{ $see-also POSTPONE: TAG: } ; - -HELP: TAG: -{ $syntax "TAG: tag word definition... ;" } -{ $values { "tag" "an XML tag name" } { "word" "an XML process" } } -{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." } -{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } -{ $see-also POSTPONE: TAGS: } ; diff --git a/basis/xml/dispatch/dispatch-tests.factor b/basis/xml/dispatch/dispatch-tests.factor deleted file mode 100644 index e76a759291..0000000000 --- a/basis/xml/dispatch/dispatch-tests.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: xml io kernel math sequences strings xml.utilities -tools.test math.parser xml.dispatch ; -IN: xml.dispatch.tests - -TAGS: calculate ( tag -- n ) - -: calc-2children ( tag -- n n ) - children-tags first2 [ calculate ] dip calculate ; - -TAG: number calculate - children>string string>number ; -TAG: add calculate - calc-2children + ; -TAG: minus calculate - calc-2children - ; -TAG: times calculate - calc-2children * ; -TAG: divide calculate - calc-2children / ; -TAG: neg calculate - children-tags first calculate neg ; - -: calc-arith ( string -- n ) - string>xml first-child-tag calculate ; - -[ 32 ] [ - "13-8" - calc-arith -] unit-test - -\ calc-arith must-infer diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor deleted file mode 100644 index af47f7c14c..0000000000 --- a/basis/xml/dispatch/dispatch.factor +++ /dev/null @@ -1,32 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: words assocs kernel accessors parser sequences summary -lexer splitting fry combinators locals ; -IN: xml.dispatch - -TUPLE: no-tag name word ; -M: no-tag summary - drop "The tag-dispatching word has no method for the given tag name" ; - -alist swap '[ _ no-tag boa throw ] suffix - '[ dup main>> _ case ] ; - -PRIVATE> - -: define-tags ( word -- ) - dup dup "xtable" word-prop compile-tags define ; - -:: define-tag ( string word quot -- ) - quot string word "xtable" word-prop set-at - word define-tags ; - -: TAGS: - CREATE - [ H{ } clone "xtable" set-word-prop ] - [ define-tags ] bi ; parsing - -: TAG: - scan scan-word parse-definition define-tag ; parsing diff --git a/basis/xml/literals/authors.txt b/basis/xml/literals/authors.txt deleted file mode 100644 index 29e79639ae..0000000000 --- a/basis/xml/literals/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg \ No newline at end of file diff --git a/basis/xml/literals/summary.txt b/basis/xml/literals/summary.txt deleted file mode 100644 index 7c18fc8c76..0000000000 --- a/basis/xml/literals/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Syntax for XML interpolation diff --git a/basis/xml/literals/tags.txt b/basis/xml/literals/tags.txt deleted file mode 100644 index d236e9679f..0000000000 --- a/basis/xml/literals/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -syntax -enterprise diff --git a/basis/xml/dispatch/authors.txt b/basis/xml/syntax/authors.txt similarity index 100% rename from basis/xml/dispatch/authors.txt rename to basis/xml/syntax/authors.txt diff --git a/basis/xml/dispatch/summary.txt b/basis/xml/syntax/summary.txt similarity index 100% rename from basis/xml/dispatch/summary.txt rename to basis/xml/syntax/summary.txt diff --git a/basis/xml/literals/literals-docs.factor b/basis/xml/syntax/syntax-docs.factor similarity index 53% rename from basis/xml/literals/literals-docs.factor rename to basis/xml/syntax/syntax-docs.factor index a37fcbd711..19f059078b 100644 --- a/basis/xml/literals/literals-docs.factor +++ b/basis/xml/syntax/syntax-docs.factor @@ -1,29 +1,56 @@ -USING: help.markup help.syntax present multiline xml.data ; -IN: xml.literals +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax xml.data present multiline ; +IN: xml.syntax -ABOUT: "xml.literals" +ABOUT: "xml.syntax" -ARTICLE: "xml.literals" "XML literals" -"The " { $vocab-link "xml.literals" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:" +ARTICLE: "xml.syntax" "Syntax extensions for XML" +"The " { $link "xml.syntax" } " vocabulary defines a number of new parsing words forXML processing." +{ $subsection { "xml.syntax" "tags" } } +{ $subsection { "xml.syntax" "literals" } } +{ $subsection POSTPONE: XML-NS: } ; + +ARTICLE: { "xml.syntax" "tags" } "Dispatch on XML tag names" +"There is a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use" +{ $subsection POSTPONE: TAGS: } +"and to define a new 'method' for this word, use" +{ $subsection POSTPONE: TAG: } ; + +HELP: TAGS: +{ $syntax "TAGS: word" } +{ $values { "word" "a new word to define" } } +{ $description "Creates a new word to which dispatches on XML tag names." } +{ $see-also POSTPONE: TAG: } ; + +HELP: TAG: +{ $syntax "TAG: tag word definition... ;" } +{ $values { "tag" "an XML tag name" } { "word" "an XML process" } } +{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." } +{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } +{ $see-also POSTPONE: TAGS: } ; + +ARTICLE: { "xml.syntax" "literals" } "XML literals" +"The following words provide syntax for XML literals:" { $subsection POSTPONE: ... XML>" } -{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ; +{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ; HELP: [XML { $syntax "[XML foo ... bar ... baz XML]" } -{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ; +{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ; -ARTICLE: { "xml.literals" "interpolation" } "XML interpolation syntax" +ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax" "XML interpolation has two forms for each of the words " { $link POSTPONE: " } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles." $nl "These forms can be used where a tag might go, as in " { $snippet "[XML <-> XML]" } " or where an attribute might go, as in " { $snippet "[XML /> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:" { $example -{" USING: splitting sequences xml.writer xml.literals ; +{" USING: splitting sequences xml.writer xml.syntax ; "one two three" " " split [ [XML <-> XML] ] map <-> XML> pprint-xml"} @@ -41,7 +68,7 @@ $nl "} } "Here is an example of the locals version:" { $example -{" USING: locals urls xml.literals xml.writer ; +{" USING: locals urls xml.syntax xml.writer ; [let | number [ 3 ] false [ f ] @@ -58,3 +85,7 @@ $nl XML> pprint-xml ] "} {" "} } ; + +HELP: XML-NS: +{ $syntax "XML-NS: name http://url" } +{ $description "Defines a new word of the given name which constructs XML names in the namespace of the given URL. The names constructed are memoized." } ; diff --git a/basis/xml/literals/literals-tests.factor b/basis/xml/syntax/syntax-tests.factor similarity index 73% rename from basis/xml/literals/literals-tests.factor rename to basis/xml/syntax/syntax-tests.factor index 0d8367c144..10ab961ec0 100644 --- a/basis/xml/literals/literals-tests.factor +++ b/basis/xml/syntax/syntax-tests.factor @@ -1,9 +1,45 @@ -! Copyright (C) 2009 Daniel Ehrenberg. +! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test xml.literals multiline kernel assocs -sequences accessors xml.writer xml.literals.private -locals splitting urls xml.data classes ; -IN: xml.literals.tests +USING: xml io kernel math sequences strings xml.traversal +tools.test math.parser xml.syntax xml.data xml.syntax.private +accessors multiline locals inverse xml.writer splitting classes ; +IN: xml.syntax.tests + +! TAGS test + +TAGS: calculate ( tag -- n ) + +: calc-2children ( tag -- n n ) + children-tags first2 [ calculate ] dip calculate ; + +TAG: number calculate + children>string string>number ; +TAG: add calculate + calc-2children + ; +TAG: minus calculate + calc-2children - ; +TAG: times calculate + calc-2children * ; +TAG: divide calculate + calc-2children / ; +TAG: neg calculate + children-tags first calculate neg ; + +: calc-arith ( string -- n ) + string>xml first-child-tag calculate ; + +[ 32 ] [ + "13-8" + calc-arith +] unit-test + +\ calc-arith must-infer + +XML-NS: foo http://blah.com + +[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test + +! XML literals [ "a" "c" { "a" "c" f } ] [ "<-a->/><->" @@ -47,7 +83,7 @@ IN: xml.literals.tests [ {" "} ] -[ 3 f URL" http://factorcode.org/" "hello" \ drop +[ 3 f "http://factorcode.org/" "hello" \ drop false=<-> url=<-> string=<-> word=<->/> XML> pprint-xml>string ] unit-test diff --git a/basis/xml/literals/literals.factor b/basis/xml/syntax/syntax.factor similarity index 83% rename from basis/xml/literals/literals.factor rename to basis/xml/syntax/syntax.factor index 4648f7b0e7..8e6bebfe6b 100644 --- a/basis/xml/literals/literals.factor +++ b/basis/xml/syntax/syntax.factor @@ -1,11 +1,42 @@ -! Copyright (C) 2009 Daniel Ehrenberg. +! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: xml xml.state kernel sequences fry assocs xml.data -accessors strings make multiline parser namespaces macros -sequences.deep generalizations words combinators -math present arrays unicode.categories locals.backend -quotations ; -IN: xml.literals +USING: words assocs kernel accessors parser sequences summary +lexer splitting combinators locals xml.data memoize sequences.deep +xml.data xml.state xml namespaces present arrays generalizations strings +make math macros multiline inverse combinators.short-circuit +sorting fry unicode.categories ; +IN: xml.syntax + +alist swap '[ _ no-tag boa throw ] suffix + '[ dup main>> _ case ] ; + +: define-tags ( word -- ) + dup dup "xtable" word-prop compile-tags define ; + +:: define-tag ( string word quot -- ) + quot string word "xtable" word-prop set-at + word define-tags ; + +PRIVATE> + +: TAGS: + CREATE + [ H{ } clone "xtable" set-word-prop ] + [ define-tags ] bi ; parsing + +: TAG: + scan scan-word parse-definition define-tag ; parsing + +: XML-NS: + CREATE-WORD (( string -- name )) over set-stack-effect + scan '[ f swap _ ] define-memoized ; parsing : [XML "XML]" [ string>chunk ] parse-def ; parsing -USING: inverse sorting fry combinators.short-circuit ; - : remove-blanks ( seq -- newseq ) [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ; diff --git a/basis/xml/dispatch/tags.txt b/basis/xml/syntax/tags.txt similarity index 100% rename from basis/xml/dispatch/tags.txt rename to basis/xml/syntax/tags.txt diff --git a/basis/xml/tests/encodings.factor b/basis/xml/tests/encodings.factor index 35076d2930..aec3e40a52 100644 --- a/basis/xml/tests/encodings.factor +++ b/basis/xml/tests/encodings.factor @@ -1,4 +1,4 @@ -USING: xml xml.data xml.utilities tools.test accessors kernel +USING: xml xml.data xml.traversal tools.test accessors kernel io.encodings.8-bit ; [ "\u000131" ] [ "resource:basis/xml/tests/latin5.xml" file>xml children>string ] unit-test diff --git a/basis/xml/tests/soap.factor b/basis/xml/tests/soap.factor index d2568a24e1..3d1ac2379e 100644 --- a/basis/xml/tests/soap.factor +++ b/basis/xml/tests/soap.factor @@ -1,4 +1,4 @@ -USING: sequences xml kernel arrays xml.utilities io.files tools.test ; +USING: sequences xml kernel arrays xml.traversal io.files tools.test ; IN: xml.tests : assemble-data ( tag -- 3array ) diff --git a/basis/xml/tests/templating.factor b/basis/xml/tests/templating.factor index 618e785d05..4861f86d7b 100644 --- a/basis/xml/tests/templating.factor +++ b/basis/xml/tests/templating.factor @@ -1,5 +1,5 @@ USING: kernel xml sequences assocs tools.test io arrays namespaces fry -accessors xml.data xml.utilities xml.writer generic sequences.deep multiline ; +accessors xml.data xml.traversal xml.writer generic sequences.deep multiline ; IN: xml.tests : sub-tag diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index dcd428d9e6..b1f6cf002f 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -3,7 +3,7 @@ IN: xml.tests USING: kernel xml tools.test io namespaces make sequences xml.errors xml.entities.html parser strings xml.data io.files -xml.utilities continuations assocs +xml.traversal continuations assocs sequences.deep accessors io.streams.string ; ! This is insufficient diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor index a8024ce151..80472fc788 100644 --- a/basis/xml/tests/xmltest.factor +++ b/basis/xml/tests/xmltest.factor @@ -1,6 +1,6 @@ USING: accessors assocs combinators continuations fry generalizations io.pathnames kernel macros sequences stack-checker tools.test xml -xml.utilities xml.writer arrays xml.data ; +xml.traversal xml.writer arrays xml.data ; IN: xml.tests.suite TUPLE: xml-test id uri sections description type ; diff --git a/basis/xml/utilities/authors.txt b/basis/xml/traversal/authors.txt similarity index 100% rename from basis/xml/utilities/authors.txt rename to basis/xml/traversal/authors.txt diff --git a/basis/xml/traversal/summary.txt b/basis/xml/traversal/summary.txt new file mode 100644 index 0000000000..365ec87864 --- /dev/null +++ b/basis/xml/traversal/summary.txt @@ -0,0 +1 @@ +Utilities for traversing an XML DOM tree diff --git a/basis/xml/utilities/tags.txt b/basis/xml/traversal/tags.txt similarity index 100% rename from basis/xml/utilities/tags.txt rename to basis/xml/traversal/tags.txt diff --git a/basis/xml/utilities/utilities-docs.factor b/basis/xml/traversal/traversal-docs.factor similarity index 91% rename from basis/xml/utilities/utilities-docs.factor rename to basis/xml/traversal/traversal-docs.factor index 161ca824c3..1329c4975e 100644 --- a/basis/xml/utilities/utilities-docs.factor +++ b/basis/xml/traversal/traversal-docs.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax xml.data sequences strings ; -IN: xml.utilities +IN: xml.traversal -ABOUT: "xml.utilities" +ABOUT: "xml.traversal" -ARTICLE: "xml.utilities" "Utilities for processing XML" - "Getting parts of an XML document or tag:" +ARTICLE: "xml.traversal" "Utilities for traversing XML" + "The " { $vocab-link "xml.traversal" } " vocabulary provides utilities for traversing an XML DOM tree and viewing the contents of a single tag. The following words are defined:" $nl "Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient." { $subsection tag-named } diff --git a/basis/xml/utilities/utilities-tests.factor b/basis/xml/traversal/traversal-tests.factor similarity index 73% rename from basis/xml/utilities/utilities-tests.factor rename to basis/xml/traversal/traversal-tests.factor index 673bf47f6e..165ca34adf 100644 --- a/basis/xml/utilities/utilities-tests.factor +++ b/basis/xml/traversal/traversal-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: xml xml.utilities tools.test xml.data sequences ; -IN: xml.utilities.tests +USING: xml xml.traversal tools.test xml.data sequences ; +IN: xml.traversal.tests [ "bar" ] [ "bar" string>xml children>string ] unit-test @@ -9,14 +9,10 @@ IN: xml.utilities.tests [ "" ] [ "" string>xml children>string ] unit-test -XML-NS: foo http://blah.com - -[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test - [ "blah" ] [ "" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test [ { "blah" } ] [ "" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test [ "blah" ] [ "" string>xml "foo" deep-tag-named "attr" attr ] unit-test -[ { "blah" } ] [ "" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test \ No newline at end of file +[ { "blah" } ] [ "" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/traversal/traversal.factor similarity index 86% rename from basis/xml/utilities/utilities.factor rename to basis/xml/traversal/traversal.factor index 1249da8c36..b337ea1472 100755 --- a/basis/xml/utilities/utilities.factor +++ b/basis/xml/traversal/traversal.factor @@ -3,7 +3,7 @@ USING: accessors kernel namespaces sequences words io assocs quotations strings parser lexer arrays xml.data xml.writer debugger splitting vectors sequences.deep combinators fry memoize ; -IN: xml.utilities +IN: xml.traversal : children>string ( tag -- string ) children>> { @@ -66,14 +66,3 @@ PRIVATE> : assert-tag ( name name -- ) names-match? [ "Unexpected XML tag found" throw ] unless ; - -: insert-children ( children tag -- ) - dup children>> [ push-all ] - [ swap V{ } like >>children drop ] if ; - -: insert-child ( child tag -- ) - [ 1vector ] dip insert-children ; - -: XML-NS: - CREATE-WORD (( string -- name )) over set-stack-effect - scan '[ f swap _ ] define-memoized ; parsing diff --git a/basis/xml/utilities/summary.txt b/basis/xml/utilities/summary.txt deleted file mode 100644 index a671132945..0000000000 --- a/basis/xml/utilities/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Utilities for manipulating an XML DOM tree diff --git a/basis/xml/writer/writer-docs.factor b/basis/xml/writer/writer-docs.factor index cc45528cec..9971abcdf1 100644 --- a/basis/xml/writer/writer-docs.factor +++ b/basis/xml/writer/writer-docs.factor @@ -41,7 +41,7 @@ HELP: pprint-xml HELP: indenter { $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" } -{ $example {" USING: xml.literals xml.writer namespaces ; +{ $example {" USING: xml.syntax xml.writer namespaces ; [XML bar XML] "%%%%" indenter [ pprint-xml ] with-variable "} {" %%%%bar @@ -49,7 +49,7 @@ HELP: indenter HELP: sensitive-tags { $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" } -{ $example {" USING: xml.literals xml.writer namespaces ; +{ $example {" USING: xml.syntax xml.writer namespaces ; [XML something
bing
 bang
    bong
XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {" diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index f414264e11..23fb7a5074 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: xml.data xml.writer tools.test fry xml kernel multiline -xml.writer.private io.streams.string xml.utilities sequences +xml.writer.private io.streams.string xml.traversal sequences io.encodings.utf8 io.files accessors io.directories ; IN: xml.writer.tests diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor index 901fce2dd4..024b086ef9 100644 --- a/basis/xml/xml-docs.factor +++ b/basis/xml/xml-docs.factor @@ -93,7 +93,7 @@ ARTICLE: "xml" "XML parser" { $vocab-subsection "XML parsing errors" "xml.errors" } { $vocab-subsection "XML entities" "xml.entities" } { $vocab-subsection "XML data types" "xml.data" } - { $vocab-subsection "Utilities for processing XML" "xml.utilities" } - { $vocab-subsection "Dispatch on XML tag names" "xml.dispatch" } ; + { $vocab-subsection "Utilities for traversing XML" "xml.traversal" } + { $vocab-subsection "Syntax extensions for XML" "xml.syntax" } ; ABOUT: "xml" diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor index 2f35cd6d76..3fb5a532c9 100644 --- a/basis/xmode/code2html/code2html.factor +++ b/basis/xmode/code2html/code2html.factor @@ -1,6 +1,6 @@ USING: xmode.tokens xmode.marker xmode.catalog kernel locals io io.files sequences words io.encodings.utf8 -namespaces xml.entities accessors xml.literals locals xml.writer ; +namespaces xml.entities accessors xml.syntax locals xml.writer ; IN: xmode.code2html : htmlize-tokens ( tokens -- xml ) diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor index b661f4eb3f..70466913a0 100644 --- a/basis/xmode/loader/loader.factor +++ b/basis/xmode/loader/loader.factor @@ -1,5 +1,5 @@ USING: xmode.loader.syntax xmode.tokens xmode.rules -xmode.keyword-map xml.data xml.utilities xml assocs kernel +xmode.keyword-map xml.data xml.traversal xml assocs kernel combinators sequences math.parser namespaces parser xmode.utilities parser-combinators.regexp io.files accessors ; IN: xmode.loader diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor index b546969a37..0e7293da97 100644 --- a/basis/xmode/loader/syntax/syntax.factor +++ b/basis/xmode/loader/syntax/syntax.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors xmode.tokens xmode.rules xmode.keyword-map -xml.data xml.utilities xml assocs kernel combinators sequences +xml.data xml.traversal xml assocs kernel combinators sequences math.parser namespaces make parser lexer xmode.utilities parser-combinators.regexp io.files splitting arrays ; IN: xmode.loader.syntax diff --git a/basis/xmode/utilities/utilities.factor b/basis/xmode/utilities/utilities.factor index d6407d8180..2423fb0d86 100644 --- a/basis/xmode/utilities/utilities.factor +++ b/basis/xmode/utilities/utilities.factor @@ -1,5 +1,5 @@ USING: accessors sequences assocs kernel quotations namespaces -xml.data xml.utilities combinators macros parser lexer words fry ; +xml.data xml.traversal combinators macros parser lexer words fry ; IN: xmode.utilities : implies ( x y -- z ) [ not ] dip or ; inline diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/extra/4DNav/space-file-decoder/space-file-decoder.factor index ecc8f778fa..e85830de52 100755 --- a/extra/4DNav/space-file-decoder/space-file-decoder.factor +++ b/extra/4DNav/space-file-decoder/space-file-decoder.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Jeff Bigot ! See http://factorcode.org/license.txt for BSD license. -USING: adsoda xml xml.utilities xml.dispatch accessors +USING: adsoda xml xml.traversal xml.syntax accessors combinators sequences math.parser kernel splitting values continuations ; IN: 4DNav.space-file-decoder diff --git a/extra/msxml-to-csv/msxml-to-csv.factor b/extra/msxml-to-csv/msxml-to-csv.factor index 855275efcc..cab28c14ca 100644 --- a/extra/msxml-to-csv/msxml-to-csv.factor +++ b/extra/msxml-to-csv/msxml-to-csv.factor @@ -1,4 +1,4 @@ -USING: io io.files sequences xml xml.utilities +USING: io io.files sequences xml xml.traversal io.encodings.ascii kernel ; IN: msxml-to-csv diff --git a/extra/svg/svg-tests.factor b/extra/svg/svg-tests.factor index 3a28310d71..0f0c349b8e 100644 --- a/extra/svg/svg-tests.factor +++ b/extra/svg/svg-tests.factor @@ -1,6 +1,6 @@ ! (c)2009 Joe Groff, see BSD license USING: accessors arrays literals math math.affine-transforms -math.functions multiline sequences svg tools.test xml xml.utilities ; +math.functions multiline sequences svg tools.test xml xml.traversal ; IN: svg.tests { 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } 1array [ diff --git a/extra/svg/svg.factor b/extra/svg/svg.factor index 4d8a6e6a17..2ed5d21707 100644 --- a/extra/svg/svg.factor +++ b/extra/svg/svg.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff, see BSD license USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish -splitting strings xml.data xml.utilities ; +splitting strings xml.data xml.syntax ; IN: svg XML-NS: svg-name http://www.w3.org/2000/svg diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index d163c8f1ac..b58a11747f 100755 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan ! See http://factorcode.org/license.txt for BSD license. -USING: http.client xml xml.utilities kernel sequences +USING: http.client xml xml.traversal kernel sequences math.parser urls accessors locals ; IN: yahoo From 51b5973b0e356392462aa1385a36e8925dafb863 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Feb 2009 21:26:40 -0600 Subject: [PATCH 03/13] Documenting XML interpolation inverse --- basis/xml/syntax/syntax-docs.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/basis/xml/syntax/syntax-docs.factor b/basis/xml/syntax/syntax-docs.factor index 19f059078b..34473fecfc 100644 --- a/basis/xml/syntax/syntax-docs.factor +++ b/basis/xml/syntax/syntax-docs.factor @@ -84,7 +84,17 @@ $nl word=<-word-> /> XML> pprint-xml ] "} {" -"} } ; +"} } +"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:" +{ $example {" USING: sequences xml.syntax inverse ; +: dispatch ( xml -- string ) + { + { [ [XML <-> XML] ] [ "a" prepend ] } + { [ [XML <-> XML] ] [ "b" prepend ] } + { [ [XML XML] ] [ "yes" ] } + { [ [XML /> XML] ] [ "no" prepend ] } + } switch ; +[XML pple XML] dispatch write "} "apple" } ; HELP: XML-NS: { $syntax "XML-NS: name http://url" } From a1f4f7772f988f7fd0cf84598a378747807acb01 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 5 Feb 2009 23:59:36 -0600 Subject: [PATCH 04/13] make multipart work with sessions --- basis/mime/multipart/multipart.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index fc3024bd01..eda7849a73 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -99,7 +99,7 @@ ERROR: end-of-stream multipart ; dup name>> empty-name? [ drop ] [ - [ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ] + [ name-content>> ] [ name>> unquote ] [ mime-parts>> set-at ] tri ] if ; From f31e19a66669c1c280858755a3a483eededd7490 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 6 Feb 2009 00:01:28 -0600 Subject: [PATCH 05/13] refactoring graphics.bitmap --- extra/graphics/bitmap/bitmap-tests.factor | 15 +++ extra/graphics/bitmap/bitmap.factor | 155 +++++++++------------- extra/graphics/viewer/viewer.factor | 33 ++++- 3 files changed, 108 insertions(+), 95 deletions(-) create mode 100644 extra/graphics/bitmap/bitmap-tests.factor diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor new file mode 100644 index 0000000000..4998427b22 --- /dev/null +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -0,0 +1,15 @@ +USING: graphics.bitmap ; +IN: graphics.bitmap.tests + +: test-bitmap24 ( -- ) + "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; + +: test-bitmap8 ( -- ) + "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; + +: test-bitmap4 ( -- ) + "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; + +: test-bitmap1 ( -- ) + "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; + diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index a0212e47de..bd34a9ee41 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays combinators summary -graphics.viewer io io.binary io.files kernel libc math +io io.binary io.files kernel libc math math.functions math.bitwise namespaces opengl opengl.gl prettyprint sequences strings ui ui.gadgets.panes fry io.encodings.binary accessors grouping macros alien.c-types ; @@ -12,10 +12,11 @@ IN: graphics.bitmap ! Handles row-reversed bitmaps (their height is negative) TUPLE: bitmap magic size reserved offset header-length width - height planes bit-count compression size-image - x-pels y-pels color-used color-important rgb-quads color-index array ; +height planes bit-count compression size-image +x-pels y-pels color-used color-important rgb-quads color-index +array ; -: (array-copy) ( bitmap array -- bitmap array' ) +: array-copy ( bitmap array -- bitmap array' ) over size-image>> abs memory>byte-array ; MACRO: (nbits>bitmap) ( bits -- ) @@ -24,7 +25,7 @@ MACRO: (nbits>bitmap) ( bits -- ) 2over * _ * >>size-image swap >>height swap >>width - swap (array-copy) [ >>array ] [ >>color-index ] bi + swap array-copy [ >>array ] [ >>color-index ] bi _ >>bit-count ] ; @@ -45,7 +46,7 @@ MACRO: (nbits>bitmap) ( bits -- ) : raw-bitmap>array ( bitmap -- array ) dup bit-count>> { - { 32 [ "32bit" throw ] } + { 32 [ color-index>> ] } { 24 [ color-index>> ] } { 16 [ "16bit" throw ] } { 8 [ 8bit>array ] } @@ -59,107 +60,75 @@ ERROR: bitmap-magic ; M: bitmap-magic summary drop "First two bytes of bitmap stream must be 'BM'" ; -: parse-file-header ( bitmap -- ) - 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic - 4 read le> >>size - 4 read le> >>reserved - 4 read le> >>offset drop ; +: read2 ( -- n ) 2 read le> ; +: read4 ( -- n ) 4 read le> ; -: parse-bitmap-header ( bitmap -- ) - 4 read le> >>header-length - 4 read signed-le> >>width - 4 read signed-le> >>height - 2 read le> >>planes - 2 read le> >>bit-count - 4 read le> >>compression - 4 read le> >>size-image - 4 read le> >>x-pels - 4 read le> >>y-pels - 4 read le> >>color-used - 4 read le> >>color-important drop ; +: parse-file-header ( bitmap -- bitmap ) + 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic + read4 >>size + read4 >>reserved + read4 >>offset ; + +: parse-bitmap-header ( bitmap -- bitmap ) + read4 >>header-length + read4 >>width + read4 >>height + read2 >>planes + read2 >>bit-count + read4 >>compression + read4 >>size-image + read4 >>x-pels + read4 >>y-pels + read4 >>color-used + read4 >>color-important ; : rgb-quads-length ( bitmap -- n ) - [ offset>> 14 - ] keep header-length>> - ; + [ offset>> 14 - ] [ header-length>> ] bi - ; : color-index-length ( bitmap -- n ) - [ width>> ] keep [ planes>> * ] keep - [ bit-count>> * 31 + 32 /i 4 * ] keep - height>> abs * ; + { + [ width>> ] + [ planes>> * ] + [ bit-count>> * 31 + 32 /i 4 * ] + [ height>> abs * ] + } cleave ; -: parse-bitmap ( bitmap -- ) +: parse-bitmap ( bitmap -- bitmap ) dup rgb-quads-length read >>rgb-quads - dup color-index-length read >>color-index drop ; + dup color-index-length read >>color-index ; : load-bitmap ( path -- bitmap ) binary [ bitmap new - dup parse-file-header - dup parse-bitmap-header - dup parse-bitmap + parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader dup raw-bitmap>array >>array ; +: write2 ( n -- ) 2 >le write ; +: write4 ( n -- ) 4 >le write ; + : save-bitmap ( bitmap path -- ) binary [ - "BM" >byte-array write - dup array>> length 14 + 40 + 4 >le write - 0 4 >le write - 54 4 >le write - - 40 4 >le write - { - [ width>> 4 >le write ] - [ height>> 4 >le write ] - [ planes>> 1 or 2 >le write ] - [ bit-count>> 24 or 2 >le write ] - [ compression>> 0 or 4 >le write ] - [ size-image>> 4 >le write ] - [ x-pels>> 0 or 4 >le write ] - [ y-pels>> 0 or 4 >le write ] - [ color-used>> 0 or 4 >le write ] - [ color-important>> 0 or 4 >le write ] - [ rgb-quads>> write ] - [ color-index>> write ] - } cleave + B{ CHAR: B CHAR: M } write + [ + array>> length 14 + 40 + write4 + 0 write4 + 54 write4 + 40 write4 + ] [ + { + [ width>> write4 ] + [ height>> write4 ] + [ planes>> 1 or write2 ] + [ bit-count>> 24 or write2 ] + [ compression>> 0 or write4 ] + [ size-image>> write4 ] + [ x-pels>> 0 or write4 ] + [ y-pels>> 0 or write4 ] + [ color-used>> 0 or write4 ] + [ color-important>> 0 or write4 ] + [ rgb-quads>> write ] + [ color-index>> write ] + } cleave + ] bi ] with-file-writer ; - -M: bitmap draw-image ( bitmap -- ) - dup height>> 0 < [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] [ - 0 over height>> abs glRasterPos2i - 1.0 1.0 glPixelZoom - ] if - [ width>> ] keep - [ - [ height>> abs ] keep - bit-count>> { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case - ] keep array>> glDrawPixels ; - -M: bitmap width ( bitmap -- ) width>> ; -M: bitmap height ( bitmap -- ) height>> ; - -: bitmap. ( path -- ) - load-bitmap gadget. ; - -: bitmap-window ( path -- gadget ) - load-bitmap [ "bitmap" open-window ] keep ; - -: test-bitmap24 ( -- ) - "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; - -: test-bitmap8 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; - -: test-bitmap4 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; - -: test-bitmap1 ( -- ) - "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; - diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 0533ffaf5d..8e0b1ec43c 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.functions namespaces opengl -ui.gadgets ui.render accessors ; +USING: accessors arrays combinators graphics.bitmap kernel math +math.functions namespaces opengl opengl.gl ui ui.gadgets +ui.gadgets.panes ui.render ; IN: graphics.viewer TUPLE: graphics-gadget < gadget image ; @@ -19,3 +20,31 @@ M: graphics-gadget draw-gadget* ( gadget -- ) : ( bitmap -- gadget ) \ graphics-gadget new-gadget swap >>image ; + +M: bitmap draw-image ( bitmap -- ) + dup height>> 0 < [ + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + ] [ + 0 over height>> abs glRasterPos2i + 1.0 1.0 glPixelZoom + ] if + [ width>> ] keep + [ + [ height>> abs ] keep + bit-count>> { + { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } + { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + } case + ] keep array>> glDrawPixels ; + +M: bitmap width ( bitmap -- ) width>> ; +M: bitmap height ( bitmap -- ) height>> ; + +: bitmap. ( path -- ) + load-bitmap gadget. ; + +: bitmap-window ( path -- gadget ) + load-bitmap [ "bitmap" open-window ] keep ; From 4adef7db09688f341283c2081b87faa0cd4b40da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 02:45:21 -0600 Subject: [PATCH 06/13] Fix functors bug where changing a hand-written method into one generated by a functor would forget the method; also associate functor-generated methods with the source file they're in. Add DEFINES-CLASS, to parallel DEFINES. Update math.blas and specialized-arrays/vectors to use DEFINES-CLASS where appropriate --- basis/functors/functors-tests.factor | 51 +++++++++++++++++-- basis/functors/functors.factor | 11 ++-- basis/math/blas/matrices/matrices.factor | 2 +- basis/math/blas/vectors/vectors.factor | 2 +- .../direct/functor/functor.factor | 2 +- .../specialized-arrays/functor/functor.factor | 2 +- .../functor/functor.factor | 2 +- 7 files changed, 60 insertions(+), 12 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a5f3042b38..df008d52bd 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,11 +1,12 @@ IN: functors.tests -USING: functors tools.test math words kernel ; +USING: functors tools.test math words kernel multiline parser +io.streams.string generic ; << FUNCTOR: define-box ( T -- ) -B DEFINES ${T}-box +B DEFINES-CLASS ${T}-box DEFINES <${B}> WHERE @@ -62,4 +63,48 @@ WHERE >> -[ 4 ] [ 1 3 blah ] unit-test \ No newline at end of file +[ 4 ] [ 1 3 blah ] unit-test + +GENERIC: some-generic ( a -- b ) + +! Does replacing an ordinary word with a functor-generated one work? +[ [ ] ] [ + <" IN: functors.tests + + TUPLE: some-tuple ; + : some-word ( -- ) ; + M: some-tuple some-generic ; + "> "functors-test" parse-stream +] unit-test + +: test-redefinition ( -- ) + [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test + [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test + [ t ] [ + "some-tuple" "functors.tests" lookup + "some-generic" "functors.tests" lookup method >boolean + ] unit-test ; + +test-redefinition + +FUNCTOR: redefine-test ( W -- ) + +W-word DEFINES ${W}-word +W-tuple DEFINES-CLASS ${W}-tuple +W-generic IS ${W}-generic + +WHERE + +TUPLE: W-tuple ; +: W-word ( -- ) ; +M: W-tuple W-generic ; + +;FUNCTOR + +[ [ ] ] [ + <" IN: functors.tests + << "some" redefine-test >> + "> "functors-test" parse-stream +] unit-test + +test-redefinition \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index f4d35b6932..14151692f0 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -3,8 +3,9 @@ USING: kernel quotations classes.tuple make combinators generic words interpolate namespaces sequences io.streams.string fry classes.mixin effects lexer parser classes.tuple.parser -effects.parser locals.types locals.parser -locals.rewrite.closures vocabs.parser arrays accessors ; +effects.parser locals.types locals.parser generic.parser +locals.rewrite.closures vocabs.parser classes.parser +arrays accessors ; IN: functors ! This is a hack @@ -29,7 +30,7 @@ M: object >fake-quotations ; GENERIC: fake-quotations> ( fake -- quot ) M: fake-quotation fake-quotations> - seq>> [ fake-quotations> ] map >quotation ; + seq>> [ fake-quotations> ] [ ] map-as ; M: array fake-quotations> [ fake-quotations> ] map ; @@ -57,7 +58,7 @@ M: object fake-quotations> ; effect off scan-param parsed scan-param parsed - \ create-method parsed + \ create-method-in parsed parse-definition* DEFINE* ; parsing @@ -96,6 +97,8 @@ PRIVATE> : DEFINES [ create-in ] (INTERPOLATE) ; parsing +: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing + DEFER: ;FUNCTOR delimiter DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix XMATRIX{ DEFINES ${T}matrix{ diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 3b7f89f730..4e61f4478e 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -134,7 +134,7 @@ XCOPY IS cblas_${T}copy XSWAP IS cblas_${T}swap IXAMAX IS cblas_i${T}amax -VECTOR DEFINES ${TYPE}-blas-vector +VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> >VECTOR DEFINES >${TYPE}-blas-vector diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index ce23186fc6..0c3999db44 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -11,7 +11,7 @@ A' IS ${T}-array >A' IS >${T}-array IS <${A'}> -A DEFINES direct-${T}-array +A DEFINES-CLASS direct-${T}-array DEFINES <${A}> NTH [ T dup c-getter array-accessor ] diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 9a56346be4..3c2c53db31 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -15,7 +15,7 @@ M: bad-byte-array-length summary FUNCTOR: define-array ( T -- ) -A DEFINES ${T}-array +A DEFINES-CLASS ${T}-array DEFINES <${A}> (A) DEFINES (${A}) >A DEFINES >${A} diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 2410cc284e..9d48a9e79e 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -9,7 +9,7 @@ FUNCTOR: define-vector ( T -- ) A IS ${T}-array IS <${A}> -V DEFINES ${T}-vector +V DEFINES-CLASS ${T}-vector DEFINES <${V}> >V DEFINES >${V} V{ DEFINES ${V}{ From 7bb0e78314e21b1094cbbc3aaa1cd766f5100e0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:02:00 -0600 Subject: [PATCH 07/13] Add support for C99 complex float and complex double types to FFI They are named complex-float and complex-double in the Factor world --- basis/alien/arrays/arrays.factor | 17 ++++++++--------- basis/alien/c-types/c-types-docs.factor | 2 ++ basis/alien/structs/structs.factor | 11 +++++++++-- basis/compiler/codegen/codegen.factor | 4 ++-- basis/compiler/tests/alien.factor | 7 +++++++ vm/ffi_test.c | 6 +++++- vm/ffi_test.h | 2 ++ vm/master.h | 1 + 8 files changed, 36 insertions(+), 14 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 727492edb1..c823b614d9 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays alien.c-types alien.structs -sequences math kernel namespaces make libc cpu.architecture ; +sequences math kernel namespaces fry libc cpu.architecture ; IN: alien.arrays UNION: value-type array struct-type ; @@ -10,7 +10,7 @@ M: array c-type ; M: array c-type-class drop object ; -M: array heap-size unclip heap-size [ * ] reduce ; +M: array heap-size unclip [ product ] [ heap-size ] bi* * ; M: array c-type-align first c-type-align ; @@ -26,16 +26,15 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; +M: array c-type-boxer-quot drop f ; + +M: array c-type-unboxer-quot drop f ; + M: value-type c-type-reg-class drop int-regs ; -M: value-type c-type-boxer-quot drop f ; - -M: value-type c-type-unboxer-quot drop f ; - M: value-type c-type-getter drop [ swap ] ; M: value-type c-type-setter ( type -- quot ) - [ - dup c-type-getter % \ swap , heap-size , \ memcpy , - ] [ ] make ; + [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri + '[ @ swap @ _ memcpy ] ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index a2b555b057..dc29ea9bb3 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -178,6 +178,8 @@ $nl { { $snippet "ulonglong" } { } } { { $snippet "float" } { } } { { $snippet "double" } { "same format as " { $link float } " objects" } } + { { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } } + { { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } } } "When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." $nl diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 42923fb28b..d9ed53d0c6 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -5,7 +5,7 @@ math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture math.order ; IN: alien.structs -TUPLE: struct-type size align fields ; +TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ; M: struct-type heap-size size>> ; @@ -15,6 +15,10 @@ M: struct-type c-type-align align>> ; M: struct-type c-type-stack-align? drop f ; +M: struct-type c-type-boxer-quot boxer-quot>> ; + +M: struct-type c-type-unboxer-quot unboxer-quot>> ; + : if-value-struct ( ctype true false -- ) [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline @@ -40,7 +44,10 @@ M: struct-type stack-size : (define-struct) ( name size align fields -- ) [ [ align ] keep ] dip - struct-type boa + struct-type new + swap >>fields + swap >>align + swap >>size swap typedef ; : make-fields ( name vocab fields -- fields ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 71d9c36412..d915b29ae5 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -3,8 +3,8 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs -alien.strings alien.arrays sets libc continuations.private -fry cpu.architecture +alien.strings alien.arrays alien.complex sets libc +continuations.private fry cpu.architecture compiler.errors compiler.alien compiler.cfg diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 1b21e40bac..b1a9853d55 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -558,3 +558,10 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ; [ ] [ stack-frame-bustage 2drop ] unit-test + +FUNCTION: complex-float ffi_test_45 ( complex-float x, complex-double y ) ; + +[ C{ 4.0 4.0 } ] [ + C{ 1.0 2.0 } + C{ 1.5 1.0 } ffi_test_45 +] unit-test \ No newline at end of file diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 1ec41ac2b9..36147795d1 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -1,6 +1,5 @@ /* This file is linked into the runtime for the sole purpose * of testing FFI code. */ -#include #include "master.h" #include "ffi_test.h" @@ -303,3 +302,8 @@ struct test_struct_14 ffi_test_44(void) retval.x2 = 2.0; return retval; } + +complex float ffi_test_45(complex float x, complex double y) +{ + return x + 2 * y; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 7c51261157..de48d6dc5b 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -88,3 +88,5 @@ struct test_struct_16 { float x; int a; }; DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); DLLEXPORT struct test_struct_14 ffi_test_44(); + +complex float ffi_test_45(complex float x, complex double y); diff --git a/vm/master.h b/vm/master.h index 86b5223eaa..01b2335841 100644 --- a/vm/master.h +++ b/vm/master.h @@ -8,6 +8,7 @@ #include #include #include +#include #include #include From 7ffbbb13e0ffc533ab7086966cbca975f4f2866d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:36:17 -0600 Subject: [PATCH 08/13] Specialized arrays can now be passed to alien functions directly, without calling underlying>> first --- basis/alien/arrays/arrays.factor | 2 +- basis/alien/c-types/c-types.factor | 9 +++++---- core/alien/alien.factor | 10 +++++++++- 3 files changed, 15 insertions(+), 6 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index c823b614d9..8253d9458c 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -28,7 +28,7 @@ M: array stack-size drop "void*" stack-size ; M: array c-type-boxer-quot drop f ; -M: array c-type-unboxer-quot drop f ; +M: array c-type-unboxer-quot drop [ >c-ptr ] ; M: value-type c-type-reg-class drop int-regs ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index d1354cb04e..ff9d4cefc4 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -201,13 +201,13 @@ M: byte-array byte-length length ; 1 swap malloc-array ; inline : malloc-byte-array ( byte-array -- alien ) - dup length [ nip malloc dup ] 2keep memcpy ; + dup byte-length [ nip malloc dup ] 2keep memcpy ; : memory>byte-array ( alien len -- byte-array ) [ nip (byte-array) dup ] 2keep memcpy ; : byte-array>memory ( byte-array base -- ) - swap dup length memcpy ; + swap dup byte-length memcpy ; : array-accessor ( type quot -- def ) [ @@ -263,7 +263,7 @@ M: long-long-type box-return ( type -- ) ] when ; : malloc-file-contents ( path -- alien len ) - binary file-contents dup malloc-byte-array swap length ; + binary file-contents [ malloc-byte-array ] [ length ] bi ; : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline @@ -283,9 +283,10 @@ M: long-long-type box-return ( type -- ) c-ptr >>class [ alien-cell ] >>getter - [ set-alien-cell ] >>setter + [ [ >c-ptr ] 2dip set-alien-cell ] >>setter bootstrap-cell >>size bootstrap-cell >>align + [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer "void*" define-primitive-type diff --git a/core/alien/alien.factor b/core/alien/alien.factor index c97e36e889..93d1a8e306 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math namespaces sequences system kernel.private byte-arrays arrays init ; @@ -18,6 +18,14 @@ PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ; UNION: pinned-c-ptr pinned-alien POSTPONE: f ; +GENERIC: >c-ptr ( obj -- c-ptr ) + +M: c-ptr >c-ptr ; + +SLOT: underlying + +M: object >c-ptr underlying>> ; + GENERIC: expired? ( c-ptr -- ? ) flushable M: alien expired? expired>> ; From d6aa376ed089ce44364ba47693ab32c7f60c9e28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:37:28 -0600 Subject: [PATCH 09/13] Removing now-redundant underlying>> calls --- basis/cocoa/messages/messages.factor | 2 +- basis/cocoa/views/views.factor | 2 +- basis/compiler/tests/alien.factor | 4 ++-- basis/db/postgresql/lib/lib.factor | 6 +++--- basis/io/backend/unix/multiplexers/epoll/epoll.factor | 2 +- .../io/backend/unix/multiplexers/kqueue/kqueue.factor | 2 +- .../io/backend/unix/multiplexers/select/select.factor | 4 ++-- basis/io/launcher/windows/windows.factor | 4 ++-- basis/io/pipes/unix/unix.factor | 2 +- basis/libc/libc.factor | 4 ++-- basis/opengl/opengl.factor | 10 +++++----- basis/opengl/shaders/shaders.factor | 2 +- .../specialized-arrays/specialized-arrays-tests.factor | 7 ++++++- basis/struct-arrays/struct-arrays-tests.factor | 4 ++-- basis/unix/utilities/utilities.factor | 4 ++-- basis/windows/com/wrapper/wrapper.factor | 2 +- basis/windows/dinput/constants/constants.factor | 2 +- basis/x11/clipboard/clipboard.factor | 2 +- basis/x11/glx/glx.factor | 2 +- basis/x11/xim/xim.factor | 2 +- 20 files changed, 37 insertions(+), 32 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index ebe98a2df1..a0b0e89a0d 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -202,7 +202,7 @@ assoc-union alien>objc-types set-global [ 0 [ class_copyMethodList ] keep *uint ] dip over 0 = [ 3drop ] [ [ ] dip - [ each ] [ drop underlying>> (free) ] 2bi + [ each ] [ drop (free) ] 2bi ] if ; inline : register-objc-methods ( class -- ) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index 03cafd0a0a..e74e912202 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -68,7 +68,7 @@ PRIVATE> NSOpenGLPFASamples , 8 , ] when 0 , - ] int-array{ } make underlying>> + ] int-array{ } make -> initWithAttributes: -> autorelease ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index b1a9853d55..b9c62f1429 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -198,8 +198,8 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; [ 32.0 ] [ - { 1.0 2.0 3.0 } >float-array underlying>> - { 4.0 5.0 6.0 } >float-array underlying>> + { 1.0 2.0 3.0 } >float-array + { 4.0 5.0 6.0 } >float-array ffi_test_23 ] unit-test diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 19cf5c5002..05114a4deb 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -65,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str ) } case ; : param-types ( statement -- seq ) - in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ; + in-params>> [ type>> type>oid ] uint-array{ } map-as ; : malloc-byte-array/length ( byte-array -- alien length ) [ malloc-byte-array &free ] [ length ] bi ; @@ -91,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str ) ] 2map flip [ f f ] [ - first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi* + first2 [ >void*-array ] [ >uint-array ] bi* ] if-empty ; : param-formats ( statement -- seq ) - in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ; + in-params>> [ type>> type>param-format ] uint-array{ } map-as ; : do-postgresql-bound-statement ( statement -- res ) [ diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor index a91f62f1df..e1428fee4d 100644 --- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor +++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor @@ -51,7 +51,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq ) ] [ 2drop f ] if ; : wait-event ( mx us -- n ) - [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi* + [ [ fd>> ] [ events>> ] bi dup length ] [ 1000 /i ] bi* epoll_wait multiplexer-error ; : handle-event ( event mx -- ) diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor index 2a6648981b..7bd157136a 100644 --- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -59,7 +59,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) : wait-kevent ( mx timespec -- n ) [ [ fd>> f 0 ] - [ events>> [ underlying>> ] [ length ] bi ] bi + [ events>> dup length ] bi ] dip kevent multiplexer-error ; : handle-kevent ( mx kevent -- ) diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor index c62101e478..7d0acb4140 100644 --- a/basis/io/backend/unix/multiplexers/select/select.factor +++ b/basis/io/backend/unix/multiplexers/select/select.factor @@ -44,8 +44,8 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : init-fdsets ( mx -- nfds read write except ) [ num-fds ] - [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] - [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri + [ read-fdset/tasks [ init-fdset ] keep ] + [ write-fdset/tasks [ init-fdset ] keep ] tri f ; M:: select-mx wait-for-events ( us mx -- ) diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 0497754aa2..7de6c25a13 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -103,7 +103,7 @@ TUPLE: CreateProcess-args over get-environment [ swap % "=" % % "\0" % ] assoc-each "\0" % - ] ushort-array{ } make underlying>> + ] ushort-array{ } make >>lpEnvironment ] when ; @@ -158,7 +158,7 @@ M: windows kill-process* ( handle -- ) M: windows wait-for-processes ( -- ? ) processes get keys dup [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as - [ length ] [ underlying>> ] bi 0 0 + [ length ] keep 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor index 6a0015084b..f94733ca56 100644 --- a/basis/io/pipes/unix/unix.factor +++ b/basis/io/pipes/unix/unix.factor @@ -7,5 +7,5 @@ QUALIFIED: io.pipes M: unix io.pipes:(pipe) ( -- pair ) 2 - [ underlying>> pipe io-error ] + [ pipe io-error ] [ first2 [ init-fd ] bi@ io.pipes:pipe boa ] bi ; diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index c4d351e6a0..1e751833a2 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -75,14 +75,14 @@ PRIVATE> dup add-malloc ; : realloc ( alien size -- newalien ) + [ >c-ptr ] dip over malloc-exists? [ realloc-error ] unless dupd (realloc) check-ptr swap delete-malloc dup add-malloc ; : free ( alien -- ) - dup delete-malloc - (free) ; + >c-ptr [ delete-malloc ] [ (free) ] bi ; : memcpy ( dst src size -- ) "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ; diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index f5868ee7a1..6d9ac95965 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -53,16 +53,16 @@ MACRO: all-enabled-client-state ( seq quot -- ) glMatrixMode glPopMatrix ; inline : gl-material ( face pname params -- ) - float-array{ } like underlying>> glMaterialfv ; + float-array{ } like glMaterialfv ; : gl-vertex-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline + [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline : gl-color-pointer ( seq -- ) - [ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline + [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline : gl-texture-coord-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline + [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline : line-vertices ( a b -- ) [ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence @@ -177,7 +177,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) glActiveTexture swap glBindTexture gl-error ; : (set-draw-buffers) ( buffers -- ) - [ length ] [ >uint-array underlying>> ] bi glDrawBuffers ; + [ length ] [ >uint-array ] bi glDrawBuffers ; MACRO: set-draw-buffers ( buffers -- ) words>values [ (set-draw-buffers) ] curry ; diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index eb5bbb0ee8..a77d29da2f 100755 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -96,7 +96,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; dup gl-program-shaders-length 0 over - [ underlying>> glGetAttachedShaders ] keep ; + [ glGetAttachedShaders ] keep ; : delete-gl-program-only ( program -- ) glDeleteProgram ; inline diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 1ca041191e..73e719b806 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -1,7 +1,8 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences specialized-arrays.int specialized-arrays.bool -specialized-arrays.ushort alien.c-types accessors kernel ; +specialized-arrays.ushort alien.c-types accessors kernel +specialized-arrays.direct.int arrays ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -16,3 +17,7 @@ specialized-arrays.ushort alien.c-types accessors kernel ; ] unit-test [ B{ 210 4 1 } byte-array>ushort-array ] must-fail + +[ { 3 1 3 3 7 } ] [ + int-array{ 3 1 3 3 7 } malloc-byte-array 5 >array +] unit-test \ No newline at end of file diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 6f77e66cd2..a8ce98888c 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -22,7 +22,7 @@ C-STRUCT: test-struct [ 5/4 ] [ [ 2 "test-struct" malloc-struct-array - dup underlying>> &free drop + dup &free drop 1 2 make-point over set-first 3 4 make-point over set-second 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce @@ -34,6 +34,6 @@ C-STRUCT: test-struct [ ] [ [ 10 "test-struct" malloc-struct-array - underlying>> &free drop + &free drop ] with-destructors ] unit-test \ No newline at end of file diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor index e2f780cd13..29b137e3de 100644 --- a/basis/unix/utilities/utilities.factor +++ b/basis/unix/utilities/utilities.factor @@ -16,5 +16,5 @@ IN: unix.utilities '[ [ advance ] [ *void* _ alien>string ] bi ] [ ] produce nip ; -: strings>alien ( strings encoding -- alien ) - '[ _ malloc-string ] void*-array{ } map-as f suffix underlying>> ; +: strings>alien ( strings encoding -- array ) + '[ _ malloc-string ] void*-array{ } map-as f suffix ; diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 813d8315ac..c86cde23d9 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -132,7 +132,7 @@ unless [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ; + [ execute ] void*-array{ } map-as malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index 0e9a03f075..314fb167e3 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -59,7 +59,7 @@ SYMBOLS: struct args i alien set-nth ] each-index - alien underlying>> + alien ] ; : (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien ) diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index d3fe0a8447..8375636a72 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -51,7 +51,7 @@ TUPLE: x-clipboard atom contents ; "TARGETS" x-atom 32 PropModeReplace { "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP" - } [ x-atom ] int-array{ } map-as underlying>> + } [ x-atom ] int-array{ } map-as 4 XChangeProperty drop ; : set-timestamp-prop ( evt -- ) diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index e0b786ce7d..11473d6e83 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -93,7 +93,7 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; GLX_RGBA , GLX_DEPTH_SIZE , 16 , 0 , - ] int-array{ } make underlying>> + ] int-array{ } make glXChooseVisual [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ; diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index 856420af0f..534e47ac37 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -50,7 +50,7 @@ SYMBOL: keysym : lookup-string ( event xic -- string keysym ) [ prepare-lookup - swap keybuf get underlying>> buf-size keysym get 0 + swap keybuf get buf-size keysym get 0 XwcLookupString finish-lookup ] with-scope ; From 242638fc5c20a70cd96a3dd770ed097fb3327824 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:38:31 -0600 Subject: [PATCH 10/13] alien.complex vocabulary implementing support for C99 complex numbers --- basis/alien/complex/authors.txt | 1 + basis/alien/complex/complex-tests.factor | 18 ++++++++++ basis/alien/complex/complex.factor | 6 ++++ basis/alien/complex/functor/authors.txt | 1 + .../complex/functor/functor-tests.factor | 4 +++ basis/alien/complex/functor/functor.factor | 35 +++++++++++++++++++ basis/alien/complex/summary.txt | 1 + 7 files changed, 66 insertions(+) create mode 100644 basis/alien/complex/authors.txt create mode 100644 basis/alien/complex/complex-tests.factor create mode 100644 basis/alien/complex/complex.factor create mode 100644 basis/alien/complex/functor/authors.txt create mode 100644 basis/alien/complex/functor/functor-tests.factor create mode 100644 basis/alien/complex/functor/functor.factor create mode 100644 basis/alien/complex/summary.txt diff --git a/basis/alien/complex/authors.txt b/basis/alien/complex/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/alien/complex/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor new file mode 100644 index 0000000000..bfb2c1137c --- /dev/null +++ b/basis/alien/complex/complex-tests.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.complex kernel alien.c-types alien.syntax +namespaces ; +IN: alien.complex.tests + +C-STRUCT: complex-holder + { "complex-float" "z" } ; + +: ( z -- alien ) + "complex-holder" + [ set-complex-holder-z ] keep ; + +[ ] [ + C{ 1.0 2.0 } "h" set +] unit-test + +[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test \ No newline at end of file diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor new file mode 100644 index 0000000000..60a84b9394 --- /dev/null +++ b/basis/alien/complex/complex.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.complex.functor sequences kernel ; +IN: alien.complex + +<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >> \ No newline at end of file diff --git a/basis/alien/complex/functor/authors.txt b/basis/alien/complex/functor/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/alien/complex/functor/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/alien/complex/functor/functor-tests.factor b/basis/alien/complex/functor/functor-tests.factor new file mode 100644 index 0000000000..c2df22be1d --- /dev/null +++ b/basis/alien/complex/functor/functor-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.complex.functor ; +IN: alien.complex.functor.tests diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor new file mode 100644 index 0000000000..1d12bb0ff4 --- /dev/null +++ b/basis/alien/complex/functor/functor.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.structs alien.c-types math math.functions sequences +arrays kernel functors vocabs.parser namespaces accessors +quotations ; +IN: alien.complex.functor + +FUNCTOR: define-complex-type ( N T -- ) + +T-real DEFINES ${T}-real +T-imaginary DEFINES ${T}-imaginary +set-T-real DEFINES set-${T}-real +set-T-imaginary DEFINES set-${T}-imaginary + +>T DEFINES >${T} +T> DEFINES ${T}> + +WHERE + +: >T ( z -- alien ) + >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline + +: T> ( alien -- z ) + [ T-real ] [ T-imaginary ] bi rect> ; inline + +T in get +{ { N "real" } { N "imaginary" } } +define-struct + +T c-type +T> 1quotation >>boxer-quot +>T 1quotation >>unboxer-quot +drop + +;FUNCTOR \ No newline at end of file diff --git a/basis/alien/complex/summary.txt b/basis/alien/complex/summary.txt new file mode 100644 index 0000000000..76c00c1d65 --- /dev/null +++ b/basis/alien/complex/summary.txt @@ -0,0 +1 @@ +Implementation details for C99 complex float and complex double types From 3166828f755bb8e2a0a1c0d4e34e880210cda393 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:38:54 -0600 Subject: [PATCH 11/13] Fix bug reported by Doug: smart combinators and inline words didn't mix very well in some cases --- basis/combinators/smart/smart-tests.factor | 8 ++++ .../transforms/transforms-tests.factor | 15 ++++++ .../transforms/transforms.factor | 46 ++++++------------- 3 files changed, 38 insertions(+), 31 deletions(-) diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 370dc26960..69a3a821e5 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -37,3 +37,11 @@ IN: combinators.smart.tests [ [ { 1 } { 2 } { 3 } ] B{ } append-outputs-as ] unit-test + +! Test nesting +: nested-smart-combo-test ( -- array ) + [ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ; + +\ nested-smart-combo-test must-infer + +[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 8ae30dcd97..2e2dccd6c4 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -42,3 +42,18 @@ C: color [ bad-new-test ] must-infer [ bad-new-test ] must-fail + +! Corner case if macro expansion calls 'infer', found by Doug +DEFER: smart-combo ( quot -- ) + +\ smart-combo [ infer [ ] curry ] 1 define-transform + +[ [ "a" "b" "c" ] smart-combo ] must-infer + +[ [ [ "a" "b" ] smart-combo "c" ] smart-combo ] must-infer + +: very-smart-combo ( quot -- ) smart-combo ; inline + +[ [ "a" "b" "c" ] very-smart-combo ] must-infer + +[ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 808ea6a141..e5c2f05d72 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel words sequences generic math namespaces make quotations assocs combinators classes.tuple classes.tuple.private effects summary hashtables classes generic -sets definitions generic.standard slots.private continuations +sets definitions generic.standard slots.private continuations locals stack-checker.backend stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; @@ -15,48 +15,32 @@ IN: stack-checker.transforms [ dup infer-word apply-word/effect ] if ; -: ((apply-transform)) ( word quot values stack -- ) - rot with-datastack first2 - dup [ - [ - [ drop ] - [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi* - ] 2dip - swap infer-quot - ] [ - 3drop give-up-transform - ] if ; inline +:: ((apply-transform)) ( word quot values stack rstate -- ) + rstate recursive-state + [ stack quot with-datastack first ] with-variable + [ + word inlined-dependency depends-on + values [ length meta-d shorten-by ] [ #drop, ] bi + rstate infer-quot + ] [ word give-up-transform ] if* ; : (apply-transform) ( word quot n -- ) ensure-d dup [ known literal? ] all? [ - dup empty? [ - recursive-state get 1array - ] [ + dup empty? [ dup recursive-state get ] [ [ ] [ [ literal value>> ] map ] [ first literal recursion>> ] tri - prefix ] if ((apply-transform)) ] [ 2drop give-up-transform ] if ; : apply-transform ( word -- ) - [ inlined-dependency depends-on ] [ - [ ] - [ "transform-quot" word-prop ] - [ "transform-n" word-prop ] - tri - (apply-transform) - ] bi ; + [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri + (apply-transform) ; : apply-macro ( word -- ) - [ inlined-dependency depends-on ] [ - [ ] - [ "macro" word-prop ] - [ "declared-effect" word-prop in>> length ] - tri - (apply-transform) - ] bi ; + [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri + (apply-transform) ; : define-transform ( word quot n -- ) [ drop "transform-quot" set-word-prop ] From f9bc9a31981a415c5d26cdf01b529fa1fa5ef4c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 04:53:08 -0600 Subject: [PATCH 12/13] Fix VM compile error --- vm/math.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/vm/math.c b/vm/math.c index f0aa874886..7bff0de387 100644 --- a/vm/math.c +++ b/vm/math.c @@ -530,8 +530,8 @@ void box_double(double flo) void primitive_from_rect(void) { - F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); - complex->imaginary = dpop(); - complex->real = dpop(); - dpush(RETAG(complex,COMPLEX_TYPE)); + F_COMPLEX* z = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); + z->imaginary = dpop(); + z->real = dpop(); + dpush(RETAG(z,COMPLEX_TYPE)); } From 5579de1722a1490a45a6e069069aafd5420fdac0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Feb 2009 05:09:10 -0600 Subject: [PATCH 13/13] Fix load error in graphics.bitmap tests --- extra/graphics/bitmap/bitmap-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor index 4998427b22..15e960084a 100644 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -1,4 +1,4 @@ -USING: graphics.bitmap ; +USING: graphics.bitmap graphics.viewer ; IN: graphics.bitmap.tests : test-bitmap24 ( -- )