From 33822922d4ee4a48c4af7d7d83f84737772bc6cd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 11 Mar 2009 00:10:11 -0500 Subject: [PATCH 01/27] Removing regexp.matchers vocab, merged into regexp --- basis/regexp/matchers/matchers.factor | 59 --------------------------- 1 file changed, 59 deletions(-) delete mode 100644 basis/regexp/matchers/matchers.factor diff --git a/basis/regexp/matchers/matchers.factor b/basis/regexp/matchers/matchers.factor deleted file mode 100644 index 87df845958..0000000000 --- a/basis/regexp/matchers/matchers.factor +++ /dev/null @@ -1,59 +0,0 @@ -! Copyright (C) 2008, 2009 Daniel Ehrenberg, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences math splitting make fry locals math.ranges -accessors arrays ; -IN: regexp.matchers - -! For now, a matcher is just something with a method to do the -! equivalent of match. - -GENERIC: match-index-from ( i string matcher -- index/f ) - -: match-index-head ( string matcher -- index/f ) - [ 0 ] 2dip match-index-from ; - -: match-slice ( i string matcher -- slice/f ) - [ 2dup ] dip match-index-from - [ swap ] [ 2drop f ] if* ; - -: matches? ( string matcher -- ? ) - dupd match-index-head - [ swap length = ] [ drop f ] if* ; - -: match-from ( i string matcher -- slice/f ) - [ [ length [a,b) ] keep ] dip - '[ _ _ match-slice ] map-find drop ; - -: match-head ( str matcher -- slice/f ) - [ 0 ] 2dip match-from ; - -> ] when ] keep ; - -PRIVATE> - -:: all-matches ( string matcher -- seq ) - 0 [ dup ] [ string matcher next-match ] produce nip but-last ; - -: count-matches ( string matcher -- n ) - all-matches length ; - -> ] map 0 prefix - slices [ from>> ] map string length suffix - [ string ] 2map ; - -PRIVATE> - -: re-split1 ( string matcher -- before after/f ) - dupd match-head [ 1array split-slices first2 ] [ f ] if* ; - -: re-split ( string matcher -- seq ) - dupd all-matches split-slices ; - -: re-replace ( string matcher replacement -- result ) - [ re-split ] dip join ; From 5027d02b12cd0503e24f939f92ac7920bb791394 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 11 Mar 2009 00:10:27 -0500 Subject: [PATCH 02/27] Stack shuffling cleanup in sequences --- core/sequences/sequences.factor | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index fb05d331e1..c5ff787768 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -213,12 +213,16 @@ TUPLE: slice : collapse-slice ( m n slice -- m' n' seq ) [ from>> ] [ seq>> ] bi [ [ + ] curry bi@ ] dip ; inline -ERROR: slice-error from to seq reason ; +TUPLE: slice-error from to seq reason ; + +: slice-error ( from to seq ? string -- from to seq ) + [ \ slice-error boa throw ] curry when ; inline : check-slice ( from to seq -- from to seq ) - pick 0 < [ "start < 0" slice-error ] when - dup length pick < [ "end > sequence" slice-error ] when - 2over > [ "start > end" slice-error ] when ; inline + 3dup + [ 2drop 0 < "start < 0" slice-error ] + [ nip length > "end > sequence" slice-error ] + [ drop > "start > end" slice-error ] 3tri ; inline : ( from to seq -- slice ) dup slice? [ collapse-slice ] when @@ -326,8 +330,8 @@ PRIVATE> [ (append) ] new-like ; inline : 3append-as ( seq1 seq2 seq3 exemplar -- newseq ) - [ pick length pick length pick length + + ] dip [ - [ [ pick length pick length + ] dip copy ] + [ 3dup [ length ] tri@ + + ] dip [ + [ [ 2over [ length ] bi@ + ] dip copy ] [ (append) ] bi ] new-like ; inline From 5f196ba2eff783a57f20996421432039d868b7c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 07:17:57 -0500 Subject: [PATCH 03/27] Fix bootstrap --- basis/ui/gadgets/panes/panes-docs.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/basis/ui/gadgets/panes/panes-docs.factor b/basis/ui/gadgets/panes/panes-docs.factor index afb2307b1e..cb747bf84d 100644 --- a/basis/ui/gadgets/panes/panes-docs.factor +++ b/basis/ui/gadgets/panes/panes-docs.factor @@ -26,10 +26,6 @@ HELP: gadget. { $description "Writes a gadget followed by a newline to " { $link output-stream } "." } { $notes "Not all streams support this operation." } ; -HELP: ?nl -{ $values { "stream" pane-stream } } -{ $description "Inserts a line break in the pane unless the current line is empty." } ; - HELP: with-pane { $values { "pane" pane } { "quot" quotation } } { $description "Clears the pane and calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to the pane." } ; From abab72f80cd298bfabca860251860c77a50d2482 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 07:18:24 -0500 Subject: [PATCH 04/27] Move 'see' to its own vocabulary, and fix excess newlines after panes change --- basis/help/cookbook/cookbook.factor | 2 +- basis/help/definitions/definitions.factor | 4 +- basis/help/handbook/handbook.factor | 1 + basis/help/help-docs.factor | 2 +- basis/help/markup/markup.factor | 6 +- basis/locals/definitions/definitions.factor | 2 +- basis/locals/locals-docs.factor | 2 +- basis/prettyprint/prettyprint-docs.factor | 58 +---- basis/prettyprint/prettyprint-tests.factor | 2 +- basis/prettyprint/prettyprint.factor | 232 +----------------- .../prettyprint/sections/sections-docs.factor | 2 +- basis/see/authors.txt | 1 + basis/see/see-docs.factor | 53 ++++ basis/see/see.factor | 227 +++++++++++++++++ basis/tools/crossref/crossref-docs.factor | 2 +- basis/tools/crossref/crossref.factor | 6 +- basis/ui/tools/profiler/profiler.factor | 2 +- basis/ui/tools/tools-docs.factor | 2 +- core/definitions/definitions-docs.factor | 2 +- core/generic/generic-docs.factor | 2 +- core/words/words-docs.factor | 2 +- 21 files changed, 318 insertions(+), 294 deletions(-) create mode 100644 basis/see/authors.txt create mode 100644 basis/see/see-docs.factor create mode 100644 basis/see/see.factor diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index b2b65c3913..d6693cd94f 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax io kernel math namespaces parser prettyprint sequences vocabs.loader namespaces stack-checker -help command-line multiline ; +help command-line multiline see ; IN: help.cookbook ARTICLE: "cookbook-syntax" "Basic syntax cookbook" diff --git a/basis/help/definitions/definitions.factor b/basis/help/definitions/definitions.factor index 3e4066d8b7..91ee1c9c79 100644 --- a/basis/help/definitions/definitions.factor +++ b/basis/help/definitions/definitions.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors definitions help help.topics help.syntax prettyprint.backend prettyprint.custom prettyprint words kernel -effects ; +effects see ; IN: help.definitions ! Definition protocol implementation diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 331fafbbd1..f20732c7ee 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -194,6 +194,7 @@ ARTICLE: "io" "Input and output" ARTICLE: "tools" "Developer tools" { $subsection "tools.vocabs" } "Exploratory tools:" +{ $subsection "see" } { $subsection "editor" } { $subsection "listener" } { $subsection "tools.crossref" } diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index 8384799dbd..733199fc60 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.crossref help.stylesheet help.topics help.syntax definitions io prettyprint summary arrays math -sequences vocabs strings ; +sequences vocabs strings see ; IN: help ARTICLE: "printing-elements" "Printing markup elements" diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 188cdd1cf8..ea64def751 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs hashtables namespaces make parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots fry sets vocabs help.stylesheet help.topics vocabs.loader quotations -combinators call ; +combinators call see ; IN: help.markup PREDICATE: simple-element < array @@ -300,7 +300,7 @@ M: f ($instance) ] with-style ] ($block) ; inline -: $see ( element -- ) first [ see ] ($see) ; +: $see ( element -- ) first [ see* ] ($see) ; : $synopsis ( element -- ) first [ synopsis write ] ($see) ; @@ -345,6 +345,8 @@ M: f ($instance) drop "Throws an error if the I/O operation fails." $errors ; +FROM: prettyprint.private => with-pprint ; + : $prettyprinting-note ( children -- ) drop { "This word should only be called from inside the " diff --git a/basis/locals/definitions/definitions.factor b/basis/locals/definitions/definitions.factor index 99f9d0bd22..a4299d0684 100644 --- a/basis/locals/definitions/definitions.factor +++ b/basis/locals/definitions/definitions.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: accessors definitions effects generic kernel locals -macros memoize prettyprint prettyprint.backend words ; +macros memoize prettyprint prettyprint.backend see words ; IN: locals.definitions PREDICATE: lambda-word < word "lambda" word-prop >boolean ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 0998d84530..18dabed4b0 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -1,5 +1,5 @@ USING: help.syntax help.markup kernel macros prettyprint -memoize combinators arrays generalizations ; +memoize combinators arrays generalizations see ; IN: locals HELP: [| diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 1e372d7cc0..2be725c0f6 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -1,6 +1,7 @@ USING: prettyprint.backend prettyprint.config prettyprint.custom prettyprint.sections prettyprint.private help.markup help.syntax -io kernel words definitions quotations strings generic classes ; +io kernel words definitions quotations strings generic classes +prettyprint.private ; IN: prettyprint ARTICLE: "prettyprint-numbers" "Prettyprinting numbers" @@ -149,10 +150,6 @@ $nl { $subsection unparse-use } "Utility for tabular output:" { $subsection pprint-cell } -"Printing a definition (see " { $link "definitions" } "):" -{ $subsection see } -"Printing the methods defined on a generic word or class (see " { $link "objects" } "):" -{ $subsection see-methods } "More prettyprinter usage:" { $subsection "prettyprint-numbers" } { $subsection "prettyprint-stacks" } @@ -160,7 +157,7 @@ $nl { $subsection "prettyprint-variables" } { $subsection "prettyprint-extension" } { $subsection "prettyprint-limitations" } -{ $see-also "number-strings" } ; +{ $see-also "number-strings" "see" } ; ABOUT: "prettyprint" @@ -232,51 +229,4 @@ HELP: .s HELP: in. { $values { "vocab" "a vocabulary specifier" } } { $description "Prettyprints a " { $snippet "IN:" } " declaration." } -$prettyprinting-note ; - -HELP: synopsis -{ $values { "defspec" "a definition specifier" } { "str" string } } -{ $contract "Prettyprints the prologue of a definition." } ; - -HELP: synopsis* -{ $values { "defspec" "a definition specifier" } } -{ $contract "Adds sections to the current block corresponding to a the prologue of a definition, in source code-like form." } -{ $notes "This word should only be called from inside the " { $link with-pprint } " combinator. Client code should call " { $link synopsis } " instead." } ; - -HELP: comment. -{ $values { "string" "a string" } } -{ $description "Prettyprints some text with the comment style." } -$prettyprinting-note ; - -HELP: see -{ $values { "defspec" "a definition specifier" } } -{ $contract "Prettyprints a definition." } ; - -HELP: see-methods -{ $values { "word" "a " { $link generic } " or a " { $link class } } } -{ $contract "Prettyprints the methods defined on a generic word or class." } ; - -HELP: definer -{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } } -{ $contract "Outputs the parsing words which delimit the definition." } -{ $examples - { $example "USING: definitions prettyprint ;" - "IN: scratchpad" - ": foo ; \\ foo definer . ." - ";\nPOSTPONE: :" - } - { $example "USING: definitions prettyprint ;" - "IN: scratchpad" - "SYMBOL: foo \\ foo definer . ." - "f\nPOSTPONE: SYMBOL:" - } -} -{ $notes "This word is used in the implementation of " { $link see } "." } ; - -HELP: definition -{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } } -{ $contract "Outputs the body of a definition." } -{ $examples - { $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" } -} -{ $notes "This word is used in the implementation of " { $link see } "." } ; +$prettyprinting-note ; \ No newline at end of file diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index b1239086d7..aaaf6b80d1 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint prettyprint.config prettyprint.sections sequences tools.test vectors words effects splitting generic.standard prettyprint.private continuations generic compiler.units tools.walker eval -accessors make vocabs.parser ; +accessors make vocabs.parser see ; IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index af56a4d2d0..7ef15b9a2f 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -1,16 +1,14 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic generic.standard assocs io kernel math -namespaces make sequences strings io.styles io.streams.string -vectors words words.symbol prettyprint.backend prettyprint.custom -prettyprint.sections prettyprint.config sorting splitting -grouping math.parser vocabs definitions effects classes.builtin -classes.tuple io.pathnames classes continuations hashtables -classes.mixin classes.union classes.intersection -classes.predicate classes.singleton combinators quotations sets -accessors colors parser summary vocabs.parser ; +USING: accessors assocs colors combinators grouping io +io.streams.string io.styles kernel make math math.parser namespaces +parser prettyprint.backend prettyprint.config prettyprint.custom +prettyprint.sections quotations sequences sorting strings vocabs +vocabs.parser words ; IN: prettyprint + + : with-use ( obj quot -- ) make-pprint use/in. do-pprint ; inline @@ -165,214 +165,4 @@ SYMBOL: pprint-string-cells? ] each ] with-row ] each - ] tabular-output nl ; - -GENERIC: see ( defspec -- ) - -: comment. ( string -- ) - [ H{ { font-style italic } } styled-text ] when* ; - -: seeing-word ( word -- ) - vocabulary>> pprinter-in set ; - -: definer. ( defspec -- ) - definer drop pprint-word ; - -: stack-effect. ( word -- ) - [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and - [ effect>string comment. ] when* ; - -: word-synopsis ( word -- ) - { - [ seeing-word ] - [ definer. ] - [ pprint-word ] - [ stack-effect. ] - } cleave ; - -M: word synopsis* word-synopsis ; - -M: simple-generic synopsis* word-synopsis ; - -M: standard-generic synopsis* - { - [ definer. ] - [ seeing-word ] - [ pprint-word ] - [ dispatch# pprint* ] - [ stack-effect. ] - } cleave ; - -M: hook-generic synopsis* - { - [ definer. ] - [ seeing-word ] - [ pprint-word ] - [ "combination" word-prop var>> pprint* ] - [ stack-effect. ] - } cleave ; - -M: method-spec synopsis* - first2 method synopsis* ; - -M: method-body synopsis* - [ definer. ] - [ "method-class" word-prop pprint-word ] - [ "method-generic" word-prop pprint-word ] tri ; - -M: mixin-instance synopsis* - [ definer. ] - [ class>> pprint-word ] - [ mixin>> pprint-word ] tri ; - -M: pathname synopsis* pprint* ; - -: synopsis ( defspec -- str ) - [ - 0 margin set - 1 line-limit set - [ synopsis* ] with-in - ] with-string-writer ; - -M: word summary synopsis ; - -GENERIC: declarations. ( obj -- ) - -M: object declarations. drop ; - -: declaration. ( word prop -- ) - [ nip ] [ name>> word-prop ] 2bi - [ pprint-word ] [ drop ] if ; - -M: word declarations. - { - POSTPONE: parsing - POSTPONE: delimiter - POSTPONE: inline - POSTPONE: recursive - POSTPONE: foldable - POSTPONE: flushable - } [ declaration. ] with each ; - -: pprint-; ( -- ) \ ; pprint-word ; - -M: object see - [ - 12 nesting-limit set - 100 length-limit set - - dup definer nip [ pprint-word ] when* declarations. - block> - ] with-use nl ; - -M: method-spec see - first2 method see ; - -GENERIC: see-class* ( word -- ) - -M: union-class see-class* - ; - -M: intersection-class see-class* - ; - -M: mixin-class see-class* - block> ; - -M: predicate-class see-class* - block> ; - -M: singleton-class see-class* ( class -- ) - \ SINGLETON: pprint-word pprint-word ; - -GENERIC: pprint-slot-name ( object -- ) - -M: string pprint-slot-name text ; - -M: array pprint-slot-name - - \ } pprint-word block> ; - -: unparse-slot ( slot-spec -- array ) - [ - dup name>> , - dup class>> object eq? [ - dup class>> , - initial: , - dup initial>> , - ] unless - dup read-only>> [ - read-only , - ] when - drop - ] { } make ; - -: pprint-slot ( slot-spec -- ) - unparse-slot - dup length 1 = [ first ] when - pprint-slot-name ; - -M: tuple-class see-class* - - pprint-; block> ; - -M: word see-class* drop ; - -M: builtin-class see-class* - drop "! Built-in class" comment. ; - -: see-class ( class -- ) - dup class? [ - [ - dup seeing-word dup see-class* - ] with-use nl - ] when drop ; - -M: word see - [ see-class ] - [ [ class? ] [ symbol? not ] bi and [ nl ] when ] - [ - dup [ class? ] [ symbol? ] bi and - [ drop ] [ call-next-method ] if - ] tri ; - -: see-all ( seq -- ) - natural-sort [ nl ] [ see ] interleave ; - -: (see-implementors) ( class -- seq ) - dup implementors [ method ] with map natural-sort ; - -: (see-methods) ( generic -- seq ) - "methods" word-prop values natural-sort ; - -: methods ( word -- seq ) - [ - dup class? [ dup (see-implementors) % ] when - dup generic? [ dup (see-methods) % ] when - drop - ] { } make prune ; - -: see-methods ( word -- ) - methods see-all ; + ] tabular-output nl ; \ No newline at end of file diff --git a/basis/prettyprint/sections/sections-docs.factor b/basis/prettyprint/sections/sections-docs.factor index 4f1c073a2d..ce7430d040 100644 --- a/basis/prettyprint/sections/sections-docs.factor +++ b/basis/prettyprint/sections/sections-docs.factor @@ -199,7 +199,7 @@ HELP: string comment. ] when* ; + +> pprinter-in set ; + +: word-synopsis ( word -- ) + { + [ seeing-word ] + [ definer. ] + [ pprint-word ] + [ stack-effect. ] + } cleave ; + +M: word synopsis* word-synopsis ; + +M: simple-generic synopsis* word-synopsis ; + +M: standard-generic synopsis* + { + [ definer. ] + [ seeing-word ] + [ pprint-word ] + [ dispatch# pprint* ] + [ stack-effect. ] + } cleave ; + +M: hook-generic synopsis* + { + [ definer. ] + [ seeing-word ] + [ pprint-word ] + [ "combination" word-prop var>> pprint* ] + [ stack-effect. ] + } cleave ; + +M: method-spec synopsis* + first2 method synopsis* ; + +M: method-body synopsis* + [ definer. ] + [ "method-class" word-prop pprint-word ] + [ "method-generic" word-prop pprint-word ] tri ; + +M: mixin-instance synopsis* + [ definer. ] + [ class>> pprint-word ] + [ mixin>> pprint-word ] tri ; + +M: pathname synopsis* pprint* ; + +M: word summary synopsis ; + +GENERIC: declarations. ( obj -- ) + +M: object declarations. drop ; + +: declaration. ( word prop -- ) + [ nip ] [ name>> word-prop ] 2bi + [ pprint-word ] [ drop ] if ; + +M: word declarations. + { + POSTPONE: parsing + POSTPONE: delimiter + POSTPONE: inline + POSTPONE: recursive + POSTPONE: foldable + POSTPONE: flushable + } [ declaration. ] with each ; + +: pprint-; ( -- ) \ ; pprint-word ; + +M: object see* + [ + 12 nesting-limit set + 100 length-limit set + + dup definer nip [ pprint-word ] when* declarations. + block> + ] with-use ; + +M: method-spec see* + first2 method see* ; + +GENERIC: see-class* ( word -- ) + +M: union-class see-class* + ; + +M: intersection-class see-class* + ; + +M: mixin-class see-class* + block> ; + +M: predicate-class see-class* + block> ; + +M: singleton-class see-class* ( class -- ) + \ SINGLETON: pprint-word pprint-word ; + +GENERIC: pprint-slot-name ( object -- ) + +M: string pprint-slot-name text ; + +M: array pprint-slot-name + + \ } pprint-word block> ; + +: unparse-slot ( slot-spec -- array ) + [ + dup name>> , + dup class>> object eq? [ + dup class>> , + initial: , + dup initial>> , + ] unless + dup read-only>> [ + read-only , + ] when + drop + ] { } make ; + +: pprint-slot ( slot-spec -- ) + unparse-slot + dup length 1 = [ first ] when + pprint-slot-name ; + +M: tuple-class see-class* + + pprint-; block> ; + +M: word see-class* drop ; + +M: builtin-class see-class* + drop "! Built-in class" comment. ; + +: see-class ( class -- ) + dup class? [ + [ + [ seeing-word ] [ see-class* ] bi + ] with-use + ] [ drop ] if ; + +M: word see* + [ see-class ] + [ [ class? ] [ symbol? not ] bi and [ nl ] when ] + [ + dup [ class? ] [ symbol? ] bi and + [ drop ] [ call-next-method ] if + ] tri ; + +: seeing-implementors ( class -- seq ) + dup implementors [ method ] with map natural-sort ; + +: seeing-methods ( generic -- seq ) + "methods" word-prop values natural-sort ; + +PRIVATE> + +: see-all ( seq -- ) + natural-sort [ nl nl ] [ see* ] interleave ; + +: methods ( word -- seq ) + [ + dup class? [ dup seeing-implementors % ] when + dup generic? [ dup seeing-methods % ] when + drop + ] { } make prune ; + +: see-methods ( word -- ) + methods see-all nl ; \ No newline at end of file diff --git a/basis/tools/crossref/crossref-docs.factor b/basis/tools/crossref/crossref-docs.factor index 820c957cbc..f49ac7ea76 100644 --- a/basis/tools/crossref/crossref-docs.factor +++ b/basis/tools/crossref/crossref-docs.factor @@ -3,7 +3,7 @@ IN: tools.crossref ARTICLE: "tools.crossref" "Cross-referencing tools" { $subsection usage. } -{ $see-also "definitions" "words" see see-methods } ; +{ $see-also "definitions" "words" "see" } ; ABOUT: "tools.crossref" diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index 494e022243..36ccaadc98 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs definitions io io.styles kernel prettyprint -sorting ; +sorting see ; IN: tools.crossref : synopsis-alist ( definitions -- alist ) - [ dup synopsis swap ] { } map>assoc ; + [ [ synopsis ] keep ] { } map>assoc ; : definitions. ( alist -- ) [ write-object nl ] assoc-each ; diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index 0ab1519cd7..bbd9237c87 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -3,7 +3,7 @@ USING: kernel quotations accessors fry assocs present math.order math.vectors arrays locals models.search models.sort models sequences vocabs tools.profiler words prettyprint combinators.smart -definitions.icons ui ui.commands ui.gadgets ui.gadgets.panes +definitions.icons see ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index 9e63be09ab..d3078cc178 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -1,7 +1,7 @@ USING: editors help.markup help.syntax summary inspector io io.styles listener parser prettyprint tools.profiler tools.walker ui.commands ui.gadgets.panes ui.gadgets.presentations ui.operations -ui.tools.operations ui.tools.profiler ui.tools.common vocabs ; +ui.tools.operations ui.tools.profiler ui.tools.common vocabs see ; IN: ui.tools ARTICLE: "starting-ui-tools" "Starting the UI tools" diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index d43c61ff70..21537906da 100644 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -61,7 +61,7 @@ ARTICLE: "definitions" "Definitions" { $subsection "definition-crossref" } { $subsection "definition-checking" } { $subsection "compilation-units" } -{ $see-also "parser" "source-files" "words" "generic" "help-impl" } ; +{ $see-also "see" "parser" "source-files" "words" "generic" "help-impl" } ; ABOUT: "definitions" diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 429e272647..613dbf72a4 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -47,7 +47,7 @@ $nl { $subsection } "A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":" { $subsection method-spec } -{ $see-also see see-methods } ; +{ $see-also "see" } ; ARTICLE: "method-combination" "Custom method combination" "Abstractly, a generic word can be thought of as a big chain of type conditional tests applied to the top of the stack, with methods as the bodies of each test. The " { $emphasis "method combination" } " is this control flow glue between the set of methods, and several aspects of it can be customized:" diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index f5990c295e..9c32a8094e 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -161,7 +161,7 @@ $nl { $subsection "word-definition" } { $subsection "word-props" } { $subsection "word.private" } -{ $see-also "vocabularies" "vocabs.loader" "definitions" } ; +{ $see-also "vocabularies" "vocabs.loader" "definitions" "see" } ; ABOUT: "words" From b0ced3dc9aa5c39a567e5fc5ba033f50604a05e5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 07:20:39 -0500 Subject: [PATCH 05/27] Formatting fix --- basis/see/see.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/see/see.factor b/basis/see/see.factor index 093b959d38..ab9fa2006f 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -199,7 +199,7 @@ M: builtin-class see-class* M: word see* [ see-class ] - [ [ class? ] [ symbol? not ] bi and [ nl ] when ] + [ [ class? ] [ symbol? not ] bi and [ nl nl ] when ] [ dup [ class? ] [ symbol? ] bi and [ drop ] [ call-next-method ] if From eb0bedd9b03ae2ea0b8057d84eb03ae932ca239f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 08:34:25 -0500 Subject: [PATCH 06/27] Fixing up code after 'see' refactoring --- basis/see/see-docs.factor | 6 ++++-- basis/see/summary.txt | 1 + core/definitions/definitions-docs.factor | 2 +- extra/fuel/help/help.factor | 2 +- extra/multi-methods/multi-methods.factor | 2 +- 5 files changed, 8 insertions(+), 5 deletions(-) create mode 100644 basis/see/summary.txt diff --git a/basis/see/see-docs.factor b/basis/see/see-docs.factor index ba26e38106..755d4ac9bc 100644 --- a/basis/see/see-docs.factor +++ b/basis/see/see-docs.factor @@ -47,7 +47,9 @@ HELP: definition ARTICLE: "see" "Printing definitions" "The " { $vocab-link "see" } " vocabulary implements support for printing out " { $link "definitions" } " in the image." $nl -"Printing a definition (see " { $link "definitions" } "):" +"Printing a definition:" { $subsection see } "Printing the methods defined on a generic word or class (see " { $link "objects" } "):" -{ $subsection see-methods } ; \ No newline at end of file +{ $subsection see-methods } ; + +ABOUT: "see" \ No newline at end of file diff --git a/basis/see/summary.txt b/basis/see/summary.txt new file mode 100644 index 0000000000..a6274bcfe2 --- /dev/null +++ b/basis/see/summary.txt @@ -0,0 +1 @@ +Printing loaded definitions as source code diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index 21537906da..80da7daa31 100644 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -56,7 +56,7 @@ $nl { $subsection redefine-error } ; ARTICLE: "definitions" "Definitions" -"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, and help articles. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary. Implementations of the definition protocol include pathnames, words, methods, and help articles." +"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, help articles, and path names (which represent the source file at that location). Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary." { $subsection "definition-protocol" } { $subsection "definition-crossref" } { $subsection "definition-checking" } diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 6196b356ba..6368e542a7 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs combinators help help.crossref help.markup help.topics io io.streams.string kernel make namespaces parser prettyprint sequences summary tools.vocabs tools.vocabs.browser -vocabs vocabs.loader words ; +vocabs vocabs.loader words see ; IN: fuel.help diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 3370ab7f86..7c5d5fb431 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -5,7 +5,7 @@ combinators arrays words assocs parser namespaces make definitions prettyprint prettyprint.backend prettyprint.custom quotations generalizations debugger io compiler.units kernel.private effects accessors hashtables sorting shuffle -math.order sets ; +math.order sets see ; IN: multi-methods ! PART I: Converting hook specializers From 515dcce34ab1bf237983b06e781e1a31ffe87777 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 08:35:48 -0500 Subject: [PATCH 07/27] Move unused utility libraries to unmaintained --- .../combinators/cleave/enhanced/enhanced.factor | 0 .../combinators/conditional/conditional.factor | 0 .../multi-method-syntax/multi-method-syntax.factor | 0 {extra/math => unmaintained}/physics/pos/pos.factor | 0 {extra/math => unmaintained}/physics/vel/vel.factor | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/combinators/cleave/enhanced/enhanced.factor (100%) rename {extra => unmaintained}/combinators/conditional/conditional.factor (100%) rename {extra => unmaintained}/multi-method-syntax/multi-method-syntax.factor (100%) rename {extra/math => unmaintained}/physics/pos/pos.factor (100%) rename {extra/math => unmaintained}/physics/vel/vel.factor (100%) diff --git a/extra/combinators/cleave/enhanced/enhanced.factor b/unmaintained/combinators/cleave/enhanced/enhanced.factor similarity index 100% rename from extra/combinators/cleave/enhanced/enhanced.factor rename to unmaintained/combinators/cleave/enhanced/enhanced.factor diff --git a/extra/combinators/conditional/conditional.factor b/unmaintained/combinators/conditional/conditional.factor similarity index 100% rename from extra/combinators/conditional/conditional.factor rename to unmaintained/combinators/conditional/conditional.factor diff --git a/extra/multi-method-syntax/multi-method-syntax.factor b/unmaintained/multi-method-syntax/multi-method-syntax.factor similarity index 100% rename from extra/multi-method-syntax/multi-method-syntax.factor rename to unmaintained/multi-method-syntax/multi-method-syntax.factor diff --git a/extra/math/physics/pos/pos.factor b/unmaintained/physics/pos/pos.factor similarity index 100% rename from extra/math/physics/pos/pos.factor rename to unmaintained/physics/pos/pos.factor diff --git a/extra/math/physics/vel/vel.factor b/unmaintained/physics/vel/vel.factor similarity index 100% rename from extra/math/physics/vel/vel.factor rename to unmaintained/physics/vel/vel.factor From 52d1e4f9b5e33e1f39343a8c78843ca3efec6fa6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 08:44:27 -0500 Subject: [PATCH 08/27] Update code not to use combinators.cleave --- extra/dns/cache/rr/rr.factor | 4 ++-- extra/dns/dns.factor | 29 +++++++++++++++++------------ extra/dns/server/server.factor | 12 ++++++------ extra/update/util/util.factor | 4 ++-- 4 files changed, 27 insertions(+), 22 deletions(-) diff --git a/extra/dns/cache/rr/rr.factor b/extra/dns/cache/rr/rr.factor index 77d787ff27..cb80190452 100644 --- a/extra/dns/cache/rr/rr.factor +++ b/extra/dns/cache/rr/rr.factor @@ -1,7 +1,7 @@ USING: kernel sequences assocs sets locals combinators accessors system math math.functions unicode.case prettyprint - combinators.cleave dns ; + combinators.smart dns ; IN: dns.cache.rr @@ -16,7 +16,7 @@ TUPLE: time data ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : make-cache-key ( obj -- key ) - { [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } 1arr " " join ; + [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index ca37691ba7..cf98154e7a 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -5,7 +5,7 @@ USING: kernel byte-arrays combinators strings arrays sequences splitting destructors io io.binary io.sockets io.encodings.binary accessors - combinators.cleave + combinators.smart newfx ; @@ -145,12 +145,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : query->ba ( query -- ba ) + [ { [ name>> dn->ba ] [ type>> type-table of uint16->ba ] [ class>> class-table of uint16->ba ] - } - concat ; + } cleave + ] output>array concat ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -169,6 +170,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : soa->ba ( rdata -- ba ) + [ { [ mname>> dn->ba ] [ rname>> dn->ba ] @@ -177,8 +179,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ retry>> uint32->ba ] [ expire>> uint32->ba ] [ minimum>> uint32->ba ] - } - concat ; + } cleave + ] output>array concat ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -198,6 +200,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : rr->ba ( rr -- ba ) + [ { [ name>> dn->ba ] [ type>> type-table of uint16->ba ] @@ -207,12 +210,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ type>> ] [ rdata>> ] bi rdata->ba [ length uint16->ba ] [ ] bi append ] - } - concat ; + } cleave + ] output>array concat ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : header-bits-ba ( message -- ba ) + [ { [ qr>> 15 shift ] [ opcode>> opcode-table of 11 shift ] @@ -222,10 +226,11 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ ra>> 7 shift ] [ z>> 4 shift ] [ rcode>> rcode-table of 0 shift ] - } - sum uint16->ba ; + } cleave + ] sum-outputs uint16->ba ; : message->ba ( message -- ba ) + [ { [ id>> uint16->ba ] [ header-bits-ba ] @@ -237,8 +242,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ answer-section>> [ rr->ba ] map concat ] [ authority-section>> [ rr->ba ] map concat ] [ additional-section>> [ rr->ba ] map concat ] - } - concat ; + } cleave + ] output>array concat ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -475,7 +480,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED : ask ( message -- message ) dns-server ask-server ; -: query->message ( query -- message ) swap {1} >>question-section ; +: query->message ( query -- message ) swap 1array >>question-section ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index d8a8adc88e..b14d765e8d 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -1,8 +1,8 @@ USING: kernel combinators sequences sets math threads namespaces continuations debugger io io.sockets unicode.case accessors destructors - combinators.cleave combinators.short-circuit - newfx fry + combinators.short-circuit combinators.smart + newfx fry arrays dns dns.util dns.misc ; IN: dns.server @@ -16,7 +16,7 @@ SYMBOL: records-var ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : {name-type-class} ( obj -- array ) - { [ name>> >lower ] [ type>> ] [ class>> ] } ; + [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ; : rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ; @@ -52,9 +52,9 @@ SYMBOL: records-var : rr->rdata-names ( rr -- names/f ) { - { [ dup type>> NS = ] [ rdata>> {1} ] } - { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] } - { [ dup type>> CNAME = ] [ rdata>> {1} ] } + { [ dup type>> NS = ] [ rdata>> 1array ] } + { [ dup type>> MX = ] [ rdata>> exchange>> 1array ] } + { [ dup type>> CNAME = ] [ rdata>> 1array ] } { [ t ] [ drop f ] } } cond ; diff --git a/extra/update/util/util.factor b/extra/update/util/util.factor index b638b61528..beeddc7abb 100644 --- a/extra/update/util/util.factor +++ b/extra/update/util/util.factor @@ -1,6 +1,6 @@ USING: kernel classes strings quotations words math math.parser arrays - combinators.cleave + combinators.smart accessors system prettyprint splitting sequences combinators sequences.deep @@ -58,5 +58,5 @@ DEFER: to-strings : datestamp ( -- string ) now - { year>> month>> day>> hour>> minute>> } + [ { [ year>> ] [ month>> ] [ day>> ] [ hour>> ] [ minute>> ] } cleave ] output>array [ pad-00 ] map "-" join ; From bd5013c9e6a5049a261ea1c8a80195401a0083c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 08:44:51 -0500 Subject: [PATCH 09/27] Move combinators.cleave to unmaintained --- {extra => unmaintained}/combinators/cleave/authors.txt | 0 {extra => unmaintained}/combinators/cleave/cleave-tests.factor | 0 {extra => unmaintained}/combinators/cleave/cleave.factor | 0 3 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/combinators/cleave/authors.txt (100%) rename {extra => unmaintained}/combinators/cleave/cleave-tests.factor (100%) rename {extra => unmaintained}/combinators/cleave/cleave.factor (100%) diff --git a/extra/combinators/cleave/authors.txt b/unmaintained/combinators/cleave/authors.txt similarity index 100% rename from extra/combinators/cleave/authors.txt rename to unmaintained/combinators/cleave/authors.txt diff --git a/extra/combinators/cleave/cleave-tests.factor b/unmaintained/combinators/cleave/cleave-tests.factor similarity index 100% rename from extra/combinators/cleave/cleave-tests.factor rename to unmaintained/combinators/cleave/cleave-tests.factor diff --git a/extra/combinators/cleave/cleave.factor b/unmaintained/combinators/cleave/cleave.factor similarity index 100% rename from extra/combinators/cleave/cleave.factor rename to unmaintained/combinators/cleave/cleave.factor From 3cd4f3f626155612667fd2ac990080f3c0029007 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 11 Mar 2009 11:57:26 -0500 Subject: [PATCH 10/27] Fixing regexp docs typo --- basis/regexp/regexp-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/regexp/regexp-docs.factor b/basis/regexp/regexp-docs.factor index 1d28e5e92f..d31b185b2f 100644 --- a/basis/regexp/regexp-docs.factor +++ b/basis/regexp/regexp-docs.factor @@ -23,7 +23,7 @@ ARTICLE: { "regexp" "construction" } "Constructing regular expressions" { $vocab-link "regexp.combinators" } ; ARTICLE: { "regexp" "syntax" } "Regular expression syntax" -"Regexp syntax is largely compatible with Perl, Java and extended POSTFIX regexps, but not completely." $nl +"Regexp syntax is largely compatible with Perl, Java and extended POSIX regexps, but not completely." $nl "A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "." $nl "One missing feature is backreferences. This is because of a design decision to allow only regular expressions following the formal theory of regular languages. For more information, see " { $link { "regexp" "theory" } } ". You can create a new regular expression to match a particular string using " { $vocab-link "regexp.combinators" } " and group capture is available to extract parts of a regular expression match." $nl "A distinction from Perl is that " { $snippet "\\G" } ", which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl From ec5bad2f7c93d82bef1cd2012fd405c474d77b75 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 11 Mar 2009 11:58:58 -0500 Subject: [PATCH 11/27] Removing regexp interpreter --- basis/regexp/traversal/traversal.factor | 69 ------------------------- 1 file changed, 69 deletions(-) delete mode 100644 basis/regexp/traversal/traversal.factor diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor deleted file mode 100644 index b890ca7e12..0000000000 --- a/basis/regexp/traversal/traversal.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators kernel math -quotations sequences regexp.classes fry arrays regexp.matchers -combinators.short-circuit prettyprint regexp.nfa ; -IN: regexp.traversal - -TUPLE: dfa-traverser - dfa-table - current-state - text - current-index - match-index ; - -: ( start-index text dfa -- match ) - dfa-traverser new - swap [ start-state>> >>current-state ] [ >>dfa-table ] bi - swap >>text - swap >>current-index ; - -: final-state? ( dfa-traverser -- ? ) - [ current-state>> ] - [ dfa-table>> final-states>> ] bi key? ; - -: end-of-text? ( dfa-traverser -- ? ) - [ current-index>> ] [ text>> length ] bi >= ; inline - -: text-finished? ( dfa-traverser -- ? ) - { - [ current-state>> not ] - [ end-of-text? ] - } 1|| ; - -: save-final-state ( dfa-traverser -- dfa-traverser ) - dup current-index>> >>match-index ; - -: match-done? ( dfa-traverser -- ? ) - dup final-state? [ save-final-state ] when text-finished? ; - -: increment-state ( dfa-traverser state -- dfa-traverser ) - >>current-state - [ 1 + ] change-current-index ; - -: match-literal ( transition from-state table -- to-state/f ) - transitions>> at at ; - -: match-class ( transition from-state table -- to-state/f ) - transitions>> at* [ - swap '[ drop _ swap class-member? ] assoc-find spin ? - ] [ drop ] if ; - -: match-transition ( obj from-state dfa -- to-state/f ) - { [ match-literal ] [ match-class ] } 3|| ; - -: setup-match ( match -- obj state dfa-table ) - [ [ current-index>> ] [ text>> ] bi nth ] - [ current-state>> ] - [ dfa-table>> ] tri ; - -: do-match ( dfa-traverser -- dfa-traverser ) - dup match-done? [ - dup setup-match match-transition - [ increment-state do-match ] when* - ] unless ; - -TUPLE: dfa-matcher dfa ; -C: dfa-matcher -M: dfa-matcher match-index-from - dfa>> do-match match-index>> ; From d5a67e589185877eb00e012112da000ca821c206 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 12:27:25 -0500 Subject: [PATCH 12/27] Fix compile error in regex --- basis/regexp/regexp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 90218e05bd..7ea5db7d5d 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -139,7 +139,7 @@ M: regexp compile-next-match ( regexp -- regexp ) dup \ next-initial-word = [ drop _ compile-regexp dfa>> '[ _ '[ _ _ execute ] next-match ] - (( i string -- i match/f )) simple-define-temp + (( i string regexp -- i match/f )) simple-define-temp ] when ] change-next-match ; From 329875b1707c750b9ef727a40bb80ece3c0dfddd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 11 Mar 2009 12:29:33 -0500 Subject: [PATCH 13/27] Regexp match iterators are better --- basis/regexp/regexp-tests.factor | 2 ++ basis/regexp/regexp.factor | 54 ++++++++++++++++++++++---------- 2 files changed, 39 insertions(+), 17 deletions(-) diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index f05416ab94..e01241552d 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -431,6 +431,8 @@ IN: regexp-tests [ f ] [ "a bar b" R/ foo/ re-contains? ] unit-test [ t ] [ "foo" R/ foo/ re-contains? ] unit-test +[ { "foo" "fxx" "fab" } ] [ "fab fxx foo" R/ f../r all-matches [ >string ] map ] unit-test + ! [ t ] [ "foo" "\\bfoo\\b" matches? ] unit-test ! [ t ] [ "afoob" "\\Bfoo\\B" matches? ] unit-test ! [ t ] [ "afoob" "\\bfoo\\b" matches? ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 90218e05bd..d116bff73d 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -33,8 +33,6 @@ M: lookbehind question>quot ! Returns ( index string -- ? ) '[ [ 1- ] dip f _ execute ] ] maybe-negated ; - [ swap [ 1+ ] bi@ ] when ] dip ; inline + : match-slice ( i string quot -- slice/f ) [ 2dup ] dip call - [ swap ] [ 2drop f ] if* ; inline + [ swap make-slice ] [ 2drop f ] if* ; inline -: match-from ( i string quot -- slice/f ) - [ [ length [a,b) ] keep ] dip - '[ _ _ match-slice ] map-find drop ; inline +: search-range ( i string reverse? -- seq ) + [ drop 0 [a,b] ] [ length [a,b) ] if ; inline -: next-match ( i string quot -- i match/f ) - match-from [ dup [ to>> ] when ] keep ; inline +:: next-match ( i string quot reverse? -- i slice/f ) + i string reverse? search-range + [ string quot match-slice ] map-find drop + [ dup [ reverse? [ from>> ] [ to>> ] if ] when ] keep ; inline : do-next-match ( i string regexp -- i match/f ) - dup next-match>> execute( i string regexp -- i match/f ) ; + dup next-match>> execute( i string regexp -- i match/f ) ; inline PRIVATE> -: all-matches ( string regexp -- seq ) +TUPLE: match-iterator + { string read-only } + { regexp read-only } + { i read-only } + { value read-only } ; + +: iterate ( iterator -- iterator'/f ) + dup + [ i>> ] [ string>> ] [ regexp>> ] tri do-next-match + [ [ [ string>> ] [ regexp>> ] bi ] 2dip match-iterator boa ] + [ 2drop f ] if* ; + +: value ( iterator/f -- value/f ) + dup [ value>> ] when ; + +: ( string regexp -- match-iterator ) [ check-string ] dip - [ 0 [ dup ] ] 2dip '[ _ _ do-next-match ] produce - nip but-last ; + 2dup end/start nip f + match-iterator boa + iterate ; inline + +: all-matches ( string regexp -- seq ) + [ iterate ] follow [ value ] map ; : count-matches ( string regexp -- n ) all-matches length ; @@ -92,8 +113,7 @@ PRIVATE> PRIVATE> : first-match ( string regexp -- slice/f ) - [ 0 ] [ check-string ] [ ] tri* - do-next-match nip ; + value ; : re-contains? ( string regexp -- ? ) first-match >boolean ; @@ -137,9 +157,9 @@ GENERIC: compile-next-match ( regexp -- regexp ) M: regexp compile-next-match ( regexp -- regexp ) dup '[ dup \ next-initial-word = [ - drop _ compile-regexp dfa>> - '[ _ '[ _ _ execute ] next-match ] - (( i string -- i match/f )) simple-define-temp + drop _ [ compile-regexp dfa>> ] [ reverse-regexp? ] bi + '[ _ '[ _ _ execute ] _ next-match ] + (( i string regexp -- i match/f )) simple-define-temp ] when ] change-next-match ; From b6f6e880bf08188b07ef752a99fee6ae84e6c1a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 13:57:13 -0500 Subject: [PATCH 14/27] Make partially dispatched integer ops foldable --- basis/compiler/tree/cleanup/cleanup-tests.factor | 5 +++++ basis/math/partial-dispatch/partial-dispatch.factor | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 4a2e8671fb..e451694f48 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -514,4 +514,9 @@ cell-bits 32 = [ [ t ] [ [ { fixnum fixnum } declare = ] \ both-fixnums? inlined? +] unit-test + +[ t ] [ + [ { integer integer } declare + drop ] + { + +-integer-integer } inlined? ] unit-test \ No newline at end of file diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 6618578a99..08cd8fb470 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -84,7 +84,7 @@ M: word integer-op-input-classes : define-integer-op-word ( fix-word big-word triple -- ) [ - [ 2nip integer-op-word ] [ integer-op-quot ] 3bi + [ 2nip integer-op-word dup make-foldable ] [ integer-op-quot ] 3bi (( x y -- z )) define-declared ] [ 2nip From fdcd8f210addacf233c705c4726de4cf7caea901 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 13:57:31 -0500 Subject: [PATCH 15/27] Add 'see' to default vocab search path --- core/parser/parser.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index ac1c2695f2..c68d453b15 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -176,6 +176,7 @@ SYMBOL: interactive-vocabs "memory" "namespaces" "prettyprint" + "see" "sequences" "slicing" "sorting" From 40dae755b14acb2c32e7f4fd32fd09c4d94ac45e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 14:02:29 -0500 Subject: [PATCH 16/27] Change execute( to execute-unsafe( since in this case we know the types --- basis/regexp/regexp.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index d116bff73d..791b0b838b 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -40,7 +40,7 @@ M: lookbehind question>quot ! Returns ( index string -- ? ) : match-index-from ( i string regexp -- index/f ) ! This word is unsafe. It assumes that i is a fixnum ! and that string is a string. - dup dfa>> execute( index string regexp -- i/f ) ; + dup dfa>> execute-unsafe( index string regexp -- i/f ) ; GENERIC: end/start ( string regexp -- end start ) M: regexp end/start drop length 0 ; @@ -72,7 +72,7 @@ PRIVATE> [ dup [ reverse? [ from>> ] [ to>> ] if ] when ] keep ; inline : do-next-match ( i string regexp -- i match/f ) - dup next-match>> execute( i string regexp -- i match/f ) ; inline + dup next-match>> execute-unsafe( i string regexp -- i match/f ) ; inline PRIVATE> From 642b5f964918837dcd688121a5548eef154d6573 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 11 Mar 2009 14:45:52 -0500 Subject: [PATCH 17/27] Refactoring next-match --- basis/regexp/regexp.factor | 38 +++++++++++++++++++++++--------------- 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index d116bff73d..df253184c3 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -56,23 +56,33 @@ PRIVATE> [ swap [ 1+ ] bi@ ] when ] dip ; inline +TUPLE: match { i read-only } { j read-only } { seq read-only } ; -: match-slice ( i string quot -- slice/f ) +: match-slice ( i string quot -- match/f ) [ 2dup ] dip call - [ swap make-slice ] [ 2drop f ] if* ; inline + [ swap match boa ] [ 2drop f ] if* ; inline : search-range ( i string reverse? -- seq ) [ drop 0 [a,b] ] [ length [a,b) ] if ; inline -:: next-match ( i string quot reverse? -- i slice/f ) +: match>result ( match reverse? -- i start end string ) + over [ + [ [ i>> ] [ j>> tuck ] [ seq>> ] tri ] dip + [ [ swap [ 1+ ] bi@ ] dip ] when + ] [ 2drop f f f f ] if ; inline + +:: next-match ( i string quot reverse? -- i start end string ) i string reverse? search-range [ string quot match-slice ] map-find drop - [ dup [ reverse? [ from>> ] [ to>> ] if ] when ] keep ; inline + reverse? match>result ; inline -: do-next-match ( i string regexp -- i match/f ) - dup next-match>> execute( i string regexp -- i match/f ) ; inline +: do-next-match ( i string regexp -- i start end string ) + dup next-match>> + execute( i string regexp -- i start end string ) ; + +: next-slice ( i string regexp -- i/f slice/f ) + do-next-match + [ slice boa ] [ drop ] if* ; inline PRIVATE> @@ -84,7 +94,7 @@ TUPLE: match-iterator : iterate ( iterator -- iterator'/f ) dup - [ i>> ] [ string>> ] [ regexp>> ] tri do-next-match + [ i>> ] [ string>> ] [ regexp>> ] tri next-slice [ [ [ string>> ] [ regexp>> ] bi ] 2dip match-iterator boa ] [ 2drop f ] if* ; @@ -149,22 +159,20 @@ M: regexp compile-regexp ( regexp -- regexp ) M: reverse-regexp compile-regexp ( regexp -- regexp ) t backwards? [ do-compile-regexp ] with-variable ; -GENERIC: compile-next-match ( regexp -- regexp ) +DEFER: compile-next-match -: next-initial-word ( i string regexp -- i slice/f ) +: next-initial-word ( i string regexp -- i start end string ) compile-next-match do-next-match ; -M: regexp compile-next-match ( regexp -- regexp ) +: compile-next-match ( regexp -- regexp ) dup '[ dup \ next-initial-word = [ drop _ [ compile-regexp dfa>> ] [ reverse-regexp? ] bi '[ _ '[ _ _ execute ] _ next-match ] - (( i string regexp -- i match/f )) simple-define-temp + (( i string regexp -- i start end string )) simple-define-temp ] when ] change-next-match ; -! Write M: reverse-regexp compile-next-match - PRIVATE> : new-regexp ( string ast options class -- regexp ) From 8b286cea4cadbfff3b9d12a7a23c74c400d8468f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 11 Mar 2009 15:51:54 -0500 Subject: [PATCH 18/27] Adding word breaks to regexp --- basis/regexp/ast/ast.factor | 4 +-- basis/regexp/classes/classes.factor | 2 +- basis/regexp/compiler/compiler.factor | 9 ++++++- basis/regexp/parser/parser.factor | 10 +++++--- basis/regexp/regexp-tests.factor | 32 ++++++++++++------------ basis/regexp/regexp.factor | 13 +++------- basis/unicode/breaks/breaks-tests.factor | 2 ++ basis/unicode/breaks/breaks.factor | 17 +++++++++++++ 8 files changed, 56 insertions(+), 33 deletions(-) diff --git a/basis/regexp/ast/ast.factor b/basis/regexp/ast/ast.factor index 9288766888..ffaed2db62 100644 --- a/basis/regexp/ast/ast.factor +++ b/basis/regexp/ast/ast.factor @@ -58,8 +58,8 @@ M: from-to : char-class ( ranges ? -- term ) [ ] dip [ ] when ; -TUPLE: lookahead term positive? ; +TUPLE: lookahead term ; C: lookahead -TUPLE: lookbehind term positive? ; +TUPLE: lookbehind term ; C: lookbehind diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index 4ddd470189..1959a91cb5 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -12,7 +12,7 @@ ascii-class punctuation-class java-printable-class blank-class control-character-class hex-digit-class java-blank-class c-identifier-class unmatchable-class terminator-class word-boundary-class ; -SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file ; +SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file word-break ; TUPLE: range from to ; C: range diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor index 0e0c0eaae6..c837df0f0f 100644 --- a/basis/regexp/compiler/compiler.factor +++ b/basis/regexp/compiler/compiler.factor @@ -3,7 +3,7 @@ USING: regexp.classes kernel sequences regexp.negation quotations assocs fry math locals combinators accessors words compiler.units kernel.private strings -sequences.private arrays call namespaces +sequences.private arrays call namespaces unicode.breaks regexp.transition-tables combinators.short-circuit ; IN: regexp.compiler @@ -15,6 +15,10 @@ SYMBOL: backwards? quot drop [ 2drop t ] ; +M: f question>quot drop [ 2drop f ] ; + +M: not-class question>quot + class>> question>quot [ not ] compose ; M: beginning-of-input question>quot drop [ drop zero? ] ; @@ -36,6 +40,9 @@ M: $ question>quot M: ^ question>quot drop [ { [ drop zero? ] [ [ 1- ] dip ?nth "\r\n" member? ] } 2|| ] ; +M: word-break question>quot + drop [ word-break-at? ] ; + : (execution-quot) ( next-state -- quot ) ! The conditions here are for lookaround and anchors, etc dup condition? [ diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index adbf0c53d3..c6a69f2508 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -56,6 +56,8 @@ ERROR: bad-class name ; { CHAR: z [ end-of-input ] } { CHAR: Z [ end-of-file ] } { CHAR: A [ beginning-of-input ] } + { CHAR: b [ word-break ] } + { CHAR: B [ word-break ] } [ ] } case ; @@ -138,10 +140,10 @@ Parenthized = "?:" Alternation:a => [[ a ]] => [[ a on off parse-options ]] | "?#" [^)]* => [[ f ]] | "?~" Alternation:a => [[ a ]] - | "?=" Alternation:a => [[ a t ]] - | "?!" Alternation:a => [[ a f ]] - | "?<=" Alternation:a => [[ a t ]] - | "? [[ a f ]] + | "?=" Alternation:a => [[ a ]] + | "?!" Alternation:a => [[ a ]] + | "?<=" Alternation:a => [[ a ]] + | "? [[ a ]] | Alternation Element = "(" Parenthized:p ")" => [[ p ]] diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index e01241552d..0b94f8296d 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -433,24 +433,24 @@ IN: regexp-tests [ { "foo" "fxx" "fab" } ] [ "fab fxx foo" R/ f../r all-matches [ >string ] map ] unit-test -! [ t ] [ "foo" "\\bfoo\\b" matches? ] unit-test -! [ t ] [ "afoob" "\\Bfoo\\B" matches? ] unit-test -! [ t ] [ "afoob" "\\bfoo\\b" matches? ] unit-test -! [ f ] [ "foo" "\\Bfoo\\B" matches? ] unit-test +[ t ] [ "foo" "\\bfoo\\b" re-contains? ] unit-test +[ t ] [ "afoob" "\\Bfoo\\B" re-contains? ] unit-test +[ f ] [ "afoob" "\\bfoo\\b" re-contains? ] unit-test +[ f ] [ "foo" "\\Bfoo\\B" re-contains? ] unit-test -! [ 3 ] [ "foo bar" "foo\\b" match-index-head ] unit-test -! [ f ] [ "fooxbar" "foo\\b" matches? ] unit-test -! [ t ] [ "foo" "foo\\b" matches? ] unit-test -! [ t ] [ "foo bar" "foo\\b bar" matches? ] unit-test -! [ f ] [ "fooxbar" "foo\\bxbar" matches? ] unit-test -! [ f ] [ "foo" "foo\\bbar" matches? ] unit-test +[ 3 ] [ "foo bar" "foo\\b" first-match length ] unit-test +[ f ] [ "fooxbar" "foo\\b" re-contains? ] unit-test +[ t ] [ "foo" "foo\\b" re-contains? ] unit-test +[ t ] [ "foo bar" "foo\\b bar" matches? ] unit-test +[ f ] [ "fooxbar" "foo\\bxbar" matches? ] unit-test +[ f ] [ "foo" "foo\\bbar" matches? ] unit-test -! [ f ] [ "foo bar" "foo\\B" matches? ] unit-test -! [ 3 ] [ "fooxbar" "foo\\B" match-index-head ] unit-test -! [ t ] [ "foo" "foo\\B" matches? ] unit-test -! [ f ] [ "foo bar" "foo\\B bar" matches? ] unit-test -! [ t ] [ "fooxbar" "foo\\Bxbar" matches? ] unit-test -! [ f ] [ "foo" "foo\\Bbar" matches? ] unit-test +[ f ] [ "foo bar" "foo\\B" re-contains? ] unit-test +[ 3 ] [ "fooxbar" "foo\\B" first-match length ] unit-test +[ f ] [ "foo" "foo\\B" re-contains? ] unit-test +[ f ] [ "foo bar" "foo\\B bar" matches? ] unit-test +[ t ] [ "fooxbar" "foo\\Bxbar" matches? ] unit-test +[ f ] [ "foo" "foo\\Bbar" matches? ] unit-test ! [ 1 ] [ "aaacb" "a+?" match-index-head ] unit-test ! [ 1 ] [ "aaacb" "aa??" match-index-head ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 7f27a13104..a7f2fa4e12 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -17,21 +17,16 @@ TUPLE: reverse-regexp < regexp ; > @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline - M: lookahead question>quot ! Returns ( index string -- ? ) - [ ast>dfa dfa>shortest-word '[ f _ execute ] ] maybe-negated ; + term>> ast>dfa dfa>shortest-word '[ f _ execute ] ; : ( ast -- reversed ) "r" string>options ; M: lookbehind question>quot ! Returns ( index string -- ? ) - [ - - ast>dfa dfa>reverse-shortest-word - '[ [ 1- ] dip f _ execute ] - ] maybe-negated ; + term>> + ast>dfa dfa>reverse-shortest-word + '[ [ 1- ] dip f _ execute ] ; : check-string ( string -- string ) ! Make this configurable diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor index d8e220cf18..493c2db0c2 100644 --- a/basis/unicode/breaks/breaks-tests.factor +++ b/basis/unicode/breaks/breaks-tests.factor @@ -37,3 +37,5 @@ IN: unicode.breaks.tests grapheme-break-test parse-test-file [ >graphemes ] test word-break-test parse-test-file [ >words ] test + +[ { t f t t f t } ] [ 6 [ "as df" word-break-at? ] map ] unit-test diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index ddcb99b829..f2e9454545 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -228,3 +228,20 @@ PRIVATE> : >words ( str -- words ) [ first-word ] >pieces ; + + + +: word-break-at? ( i str -- ? ) + { + [ drop zero? ] + [ length = ] + [ + [ nth-next [ word-break-prop ] dip ] 2keep + word-break-next nip + ] + } 2|| ; From 23c8b375ccdaff42d785bce058fd2b3efc7328d8 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 11 Mar 2009 16:06:14 -0500 Subject: [PATCH 19/27] Uncommenting most remaining regexp unit tests --- basis/regexp/regexp-tests.factor | 37 ++++++++++++-------------------- 1 file changed, 14 insertions(+), 23 deletions(-) diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 0b94f8296d..eedbcbbc4f 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -452,30 +452,21 @@ IN: regexp-tests [ t ] [ "fooxbar" "foo\\Bxbar" matches? ] unit-test [ f ] [ "foo" "foo\\Bbar" matches? ] unit-test -! [ 1 ] [ "aaacb" "a+?" match-index-head ] unit-test -! [ 1 ] [ "aaacb" "aa??" match-index-head ] unit-test -! [ f ] [ "aaaab" "a++ab" matches? ] unit-test -! [ t ] [ "aaacb" "a++cb" matches? ] unit-test -! [ 3 ] [ "aacb" "aa?c" match-index-head ] unit-test -! [ 3 ] [ "aacb" "aa??c" match-index-head ] unit-test +[ t ] [ "ab" "a(?=b*)" re-contains? ] unit-test +[ t ] [ "abbbbbc" "a(?=b*c)" re-contains? ] unit-test +[ f ] [ "abbbbb" "a(?=b*c)" re-contains? ] unit-test +[ t ] [ "ab" "a(?=b*)" re-contains? ] unit-test -! "ab" "a(?=b*)" match -! "abbbbbc" "a(?=b*c)" match -! "ab" "a(?=b*)" match +[ "az" ] [ "baz" "(?<=b)(az)" first-match >string ] unit-test +[ f ] [ "chaz" "(?<=b)(az)" re-contains? ] unit-test +[ "a" ] [ "cbaz" "(?<=b*)a" first-match >string ] unit-test +[ f ] [ "baz" "a(?<=b)" re-contains? ] unit-test -! "baz" "(az)(?<=b)" first-match -! "cbaz" "a(?<=b*)" first-match -! "baz" "a(?<=b)" first-match +[ f ] [ "baz" "(? re-contains? ] unit-test +[ t ] [ "caz" "(? re-contains? ] unit-test -! "baz" "a(? first-match -! "caz" "a(? first-match +[ "abcd" ] [ "abcdefg" "a(?=bcdefg)bcd" first-match >string ] unit-test +[ t ] [ "abcdefg" "a(?#bcdefg)bcd" re-contains? ] unit-test +[ t ] [ "abcdefg" "a(?:bcdefg)" matches? ] unit-test -! "abcdefg" "a(?=bcdefg)bcd" first-match -! "abcdefg" "a(?#bcdefg)bcd" first-match -! "abcdefg" "a(?:bcdefg)" first-match - -! "caba" "a(?<=b)" first-match - -! capture group 1: "aaaa" 2: "" -! "aaaa" "(a*)(a*)" match* -! "aaaa" "(a*)(a+)" match* +[ 3 ] [ "caba" "(?<=b)a" first-match from>> ] unit-test From 643da5f073e42af8495fd9c73fd82a07124164f5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 16:21:29 -0500 Subject: [PATCH 20/27] Remove match iterators for a performance boost --- basis/regexp/regexp-docs.factor | 16 ++---- basis/regexp/regexp-tests.factor | 4 +- basis/regexp/regexp.factor | 97 ++++++++++++++++---------------- 3 files changed, 55 insertions(+), 62 deletions(-) diff --git a/basis/regexp/regexp-docs.factor b/basis/regexp/regexp-docs.factor index d31b185b2f..adbeb341bb 100644 --- a/basis/regexp/regexp-docs.factor +++ b/basis/regexp/regexp-docs.factor @@ -42,8 +42,8 @@ ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions { $subsection matches? } { $subsection re-contains? } { $subsection first-match } -{ $subsection all-matches } -{ $subsection re-split1 } +{ $subsection all-matching-slices } +{ $subsection all-matching-subseqs } { $subsection re-split } { $subsection re-replace } { $subsection count-matches } ; @@ -67,25 +67,21 @@ HELP: matches? { $values { "string" string } { "regexp" regexp } { "?" "a boolean" } } { $description "Tests if the string as a whole matches the given regular expression." } ; -HELP: re-split1 -{ $values { "string" string } { "regexp" regexp } { "before" string } { "after/f" string } } -{ $description "Searches the string for a substring which matches the pattern. If found, the input string is split on the leftmost and longest occurence of the match, and the two halves are given as output. If no match is found, then the input string and " { $link f } " are output." } ; - -HELP: all-matches +HELP: all-matching-slices { $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } } { $description "Finds a sequence of disjoint substrings which each match the pattern. It chooses this by finding the leftmost longest match, and then the leftmost longest match which starts after the end of the previous match, and so on." } ; HELP: count-matches { $values { "string" string } { "regexp" regexp } { "n" integer } } -{ $description "Counts how many disjoint matches the regexp has in the string, as made unambiguous by " { $link all-matches } "." } ; +{ $description "Counts how many disjoint matches the regexp has in the string, as made unambiguous by " { $link all-matching-slices } "." } ; HELP: re-split { $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } } -{ $description "Splits the input string into chunks separated by the regular expression. Each chunk contains no match of the regexp. The chunks are chosen by the strategy of " { $link all-matches } "." } ; +{ $description "Splits the input string into chunks separated by the regular expression. Each chunk contains no match of the regexp. The chunks are chosen by the strategy of " { $link all-matching-slices } "." } ; HELP: re-replace { $values { "string" string } { "regexp" regexp } { "replacement" string } { "result" string } } -{ $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matches } "." } ; +{ $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matching-slices } "." } ; HELP: first-match { $values { "string" string } { "regexp" regexp } { "slice/f" "the match, if one exists" } } diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index e01241552d..c6d1487d5a 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -287,7 +287,7 @@ IN: regexp-tests [ { "a" "" } ] [ "a=" R/ =/ re-split [ >string ] map ] unit-test [ { "ABC" "DEF" "GHI" } ] -[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test +[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matching-subseqs ] unit-test [ 3 ] [ "1ABC2DEF3GHI4" R/ [A-Z]+/ count-matches ] unit-test @@ -431,7 +431,7 @@ IN: regexp-tests [ f ] [ "a bar b" R/ foo/ re-contains? ] unit-test [ t ] [ "foo" R/ foo/ re-contains? ] unit-test -[ { "foo" "fxx" "fab" } ] [ "fab fxx foo" R/ f../r all-matches [ >string ] map ] unit-test +[ { "foo" "fxx" "fab" } ] [ "fab fxx foo" R/ f../r all-matching-subseqs ] unit-test ! [ t ] [ "foo" "\\bfoo\\b" matches? ] unit-test ! [ t ] [ "afoob" "\\Bfoo\\B" matches? ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 7f27a13104..e385c515ef 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -49,93 +49,90 @@ M: reverse-regexp end/start drop length 1- -1 swap ; PRIVATE> : matches? ( string regexp -- ? ) - [ end/start ] 2keep [ check-string ] dip + [ end/start ] 2keep match-index-from - [ swap = ] [ drop f ] if* ; + [ = ] [ drop f ] if* ; ( i string quot: ( i string -- i seq j ) reverse? -- match/f ) + i string quot call dup [| j | + j i j + reverse? [ swap [ 1+ ] bi@ ] when + string match boa + ] when ; inline : search-range ( i string reverse? -- seq ) [ drop 0 [a,b] ] [ length [a,b) ] if ; inline -: match>result ( match reverse? -- i start end string ) - over [ - [ [ i>> ] [ j>> tuck ] [ seq>> ] tri ] dip - [ [ swap [ 1+ ] bi@ ] dip ] when - ] [ 2drop f f f f ] if ; inline +: match>result ( match -- i start end string ) + dup + [ { [ i>> ] [ start>> ] [ end>> ] [ string>> ] } cleave ] + [ drop f f f f ] + if ; inline -:: next-match ( i string quot reverse? -- i start end string ) +:: next-match ( i string quot reverse? -- i start end ? ) i string reverse? search-range - [ string quot match-slice ] map-find drop - reverse? match>result ; inline + [ string quot reverse? ] map-find drop + match>result ; inline -: do-next-match ( i string regexp -- i start end string ) +: do-next-match ( i string regexp -- i start end ? ) dup next-match>> - execute-unsafe( i string regexp -- i start end string ) ; + execute-unsafe( i string regexp -- i start end ? ) ; inline -: next-slice ( i string regexp -- i/f slice/f ) - do-next-match - [ slice boa ] [ drop ] if* ; inline +:: (each-match) ( i string regexp quot: ( start end string -- ) -- ) + i string regexp do-next-match [| i' start end | + start end string quot call + i' string regexp quot (each-match) + ] [ 3drop ] if ; inline recursive PRIVATE> -TUPLE: match-iterator - { string read-only } - { regexp read-only } - { i read-only } - { value read-only } ; +: prepare-match-iterator ( string regexp -- i string regexp ) + [ check-string ] dip [ end/start nip ] 2keep ; inline -: iterate ( iterator -- iterator'/f ) - dup - [ i>> ] [ string>> ] [ regexp>> ] tri next-slice - [ [ [ string>> ] [ regexp>> ] bi ] 2dip match-iterator boa ] - [ 2drop f ] if* ; +: each-match ( string regexp quot: ( start end string -- ) -- ) + [ prepare-match-iterator ] dip (each-match) ; inline -: value ( iterator/f -- value/f ) - dup [ value>> ] when ; +: map-matches ( string regexp quot: ( start end string -- obj ) -- seq ) + accumulator [ each-match ] dip >array ; inline -: ( string regexp -- match-iterator ) - [ check-string ] dip - 2dup end/start nip f - match-iterator boa - iterate ; inline +: all-matching-slices ( string regexp -- seq ) + [ slice boa ] map-matches ; -: all-matches ( string regexp -- seq ) - [ iterate ] follow [ value ] map ; +: all-matching-subseqs ( string regexp -- seq ) + [ subseq ] map-matches ; : count-matches ( string regexp -- n ) - all-matches length ; + [ 0 ] 2dip [ 3drop 1+ ] each-match ; > ] map 0 prefix - slices [ from>> ] map string length suffix - [ string ] 2map ; +:: (re-split) ( string regexp quot -- new-slices ) + 0 string regexp [| end start end' string | + end' ! leave it on the stack for the next iteration + end start string quot call + ] map-matches + ! Final chunk + swap string length string quot call suffix ; inline PRIVATE> : first-match ( string regexp -- slice/f ) - value ; + [ prepare-match-iterator do-next-match ] [ drop ] 2bi + '[ _ slice boa nip ] [ 3drop f ] if ; : re-contains? ( string regexp -- ? ) - first-match >boolean ; - -: re-split1 ( string regexp -- before after/f ) - dupd first-match [ 1array split-slices first2 ] [ f ] if* ; + prepare-match-iterator do-next-match [ 3drop ] dip >boolean ; : re-split ( string regexp -- seq ) - dupd all-matches split-slices ; + [ slice boa ] (re-split) ; : re-replace ( string regexp replacement -- result ) - [ re-split ] dip join ; + [ [ subseq ] (re-split) ] dip join ; Date: Wed, 11 Mar 2009 16:36:53 -0500 Subject: [PATCH 21/27] Get rid of match tuple --- basis/regexp/regexp.factor | 28 ++++++++++------------------ 1 file changed, 10 insertions(+), 18 deletions(-) diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index e385c515ef..778421b20d 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -56,28 +56,20 @@ PRIVATE> ( i string quot: ( i string -- i seq j ) reverse? -- match/f ) - i string quot call dup [| j | +:: (next-match) ( i string regexp word: ( i string -- j ) reverse? -- i start end ? ) + i string regexp word execute dup [| j | j i j reverse? [ swap [ 1+ ] bi@ ] when - string match boa - ] when ; inline + string + ] [ drop f f f f ] if ; inline : search-range ( i string reverse? -- seq ) [ drop 0 [a,b] ] [ length [a,b) ] if ; inline -: match>result ( match -- i start end string ) - dup - [ { [ i>> ] [ start>> ] [ end>> ] [ string>> ] } cleave ] - [ drop f f f f ] - if ; inline - -:: next-match ( i string quot reverse? -- i start end ? ) +:: next-match ( i string regexp word reverse? -- i start end ? ) + f f f f i string reverse? search-range - [ string quot reverse? ] map-find drop - match>result ; inline + [ [ 2drop 2drop ] dip string regexp word reverse? (next-match) dup ] find 2drop ; inline : do-next-match ( i string regexp -- i start end ? ) dup next-match>> @@ -89,11 +81,11 @@ TUPLE: match { i read-only } { start read-only } { end read-only } { string read i' string regexp quot (each-match) ] [ 3drop ] if ; inline recursive -PRIVATE> - : prepare-match-iterator ( string regexp -- i string regexp ) [ check-string ] dip [ end/start nip ] 2keep ; inline +PRIVATE> + : each-match ( string regexp quot: ( start end string -- ) -- ) [ prepare-match-iterator ] dip (each-match) ; inline @@ -165,7 +157,7 @@ DEFER: compile-next-match dup '[ dup \ next-initial-word = [ drop _ [ compile-regexp dfa>> ] [ reverse-regexp? ] bi - '[ _ '[ _ _ execute ] _ next-match ] + '[ _ _ next-match ] (( i string regexp -- i start end string )) simple-define-temp ] when ] change-next-match ; From 18ca3b34190c71de6af50443bec5c4daa5e49d44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 16:53:44 -0500 Subject: [PATCH 22/27] Add some declarations so that next-match is faster --- basis/regexp/regexp.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 778421b20d..ab6accb120 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators kernel math sequences strings sets -assocs prettyprint.backend prettyprint.custom make lexer -namespaces parser arrays fry locals regexp.parser splitting -sorting regexp.ast regexp.negation regexp.compiler words -call call.private math.ranges ; +USING: accessors combinators kernel kernel.private math sequences +sequences.private strings sets assocs prettyprint.backend +prettyprint.custom make lexer namespaces parser arrays fry locals +regexp.parser splitting sorting regexp.ast regexp.negation +regexp.compiler words call call.private math.ranges ; IN: regexp TUPLE: regexp @@ -56,7 +56,7 @@ PRIVATE> ] [ drop f f f f ] if ; inline : search-range ( i string reverse? -- seq ) - [ drop 0 [a,b] ] [ length [a,b) ] if ; inline + [ drop dup 1+ -1 ] [ length 1 ] if range boa ; inline :: next-match ( i string regexp word reverse? -- i start end ? ) f f f f @@ -157,7 +157,7 @@ DEFER: compile-next-match dup '[ dup \ next-initial-word = [ drop _ [ compile-regexp dfa>> ] [ reverse-regexp? ] bi - '[ _ _ next-match ] + '[ { array-capacity string regexp } declare _ _ next-match ] (( i string regexp -- i start end string )) simple-define-temp ] when ] change-next-match ; From 034bda42caede36f3afe415940cabd0331caaef3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 17:06:45 -0500 Subject: [PATCH 23/27] Inline initial state in next-match loop --- basis/regexp/regexp.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 22c7e2474f..29f7e3e84e 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -51,8 +51,8 @@ PRIVATE> : search-range ( i string reverse? -- seq ) [ drop dup 1+ -1 ] [ length 1 ] if range boa ; inline -:: next-match ( i string regexp word reverse? -- i start end ? ) +:: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? ) f f f f i string reverse? search-range - [ [ 2drop 2drop ] dip string regexp word reverse? (next-match) dup ] find 2drop ; inline + [ [ 2drop 2drop ] dip string regexp quot reverse? (next-match) dup ] find 2drop ; inline : do-next-match ( i string regexp -- i start end ? ) dup next-match>> @@ -151,7 +151,7 @@ DEFER: compile-next-match : compile-next-match ( regexp -- regexp ) dup '[ dup \ next-initial-word = [ - drop _ [ compile-regexp dfa>> ] [ reverse-regexp? ] bi + drop _ [ compile-regexp dfa>> def>> ] [ reverse-regexp? ] bi '[ { array-capacity string regexp } declare _ _ next-match ] (( i string regexp -- i start end string )) simple-define-temp ] when From 667eca941099c6cce01d8dde4220dc9595d6d843 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 17:33:54 -0500 Subject: [PATCH 24/27] Fix unit tests and help lint for 'see' move --- basis/delegate/delegate-tests.factor | 2 +- .../help/definitions/definitions-tests.factor | 2 +- basis/inspector/inspector-tests.factor | 2 +- basis/locals/locals-tests.factor | 2 +- basis/macros/macros-tests.factor | 2 +- basis/memoize/memoize-tests.factor | 2 +- basis/opengl/textures/textures-tests.factor | 22 +++++++++++-------- basis/ui/gadgets/panes/panes-tests.factor | 2 +- core/classes/singleton/singleton-tests.factor | 2 +- core/classes/tuple/tuple-tests.factor | 2 +- core/classes/union/union-tests.factor | 2 +- core/generic/standard/standard-tests.factor | 2 +- core/kernel/kernel-docs.factor | 2 +- extra/descriptive/descriptive-tests.factor | 2 +- extra/multi-methods/tests/syntax.factor | 2 +- 15 files changed, 27 insertions(+), 23 deletions(-) diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index e2bea82e68..9bf07a5330 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -1,7 +1,7 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string accessors eval multiline generic.standard delegate.protocols -delegate.private assocs ; +delegate.private assocs see ; IN: delegate.tests TUPLE: hello this that ; diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor index d95f6988a2..5d83afae88 100644 --- a/basis/help/definitions/definitions-tests.factor +++ b/basis/help/definitions/definitions-tests.factor @@ -1,6 +1,6 @@ USING: math definitions help.topics help tools.test prettyprint parser io.streams.string kernel source-files -assocs namespaces words io sequences eval accessors ; +assocs namespaces words io sequences eval accessors see ; IN: help.definitions.tests [ ] [ \ + >link see ] unit-test diff --git a/basis/inspector/inspector-tests.factor b/basis/inspector/inspector-tests.factor index 4ce549ac83..3f3e7f13df 100644 --- a/basis/inspector/inspector-tests.factor +++ b/basis/inspector/inspector-tests.factor @@ -8,7 +8,7 @@ f describe H{ } describe H{ } describe -[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test +[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test [ ] [ H{ } clone inspect ] unit-test diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 923f890adf..558fa78494 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel namespaces arrays strings prettyprint io.streams.string parser accessors generic eval combinators combinators.short-circuit combinators.short-circuit.smart math.order math.functions -definitions compiler.units fry lexer words.symbol ; +definitions compiler.units fry lexer words.symbol see ; IN: locals.tests :: foo ( a b -- a a ) a a ; diff --git a/basis/macros/macros-tests.factor b/basis/macros/macros-tests.factor index 7b061ab2f5..7d93ce8a9e 100644 --- a/basis/macros/macros-tests.factor +++ b/basis/macros/macros-tests.factor @@ -1,6 +1,6 @@ IN: macros.tests USING: tools.test macros math kernel arrays -vectors io.streams.string prettyprint parser eval ; +vectors io.streams.string prettyprint parser eval see ; MACRO: see-test ( a b -- c ) + ; diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 168a0061e3..54378bd37e 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel memoize tools.test parser generalizations -prettyprint io.streams.string sequences eval namespaces ; +prettyprint io.streams.string sequences eval namespaces see ; IN: memoize.tests MEMO: fib ( m -- n ) diff --git a/basis/opengl/textures/textures-tests.factor b/basis/opengl/textures/textures-tests.factor index 45b1d8f706..7141caa67d 100644 --- a/basis/opengl/textures/textures-tests.factor +++ b/basis/opengl/textures/textures-tests.factor @@ -5,15 +5,19 @@ images kernel namespaces ; IN: opengl.textures.tests [ ] [ - { 3 5 } - RGB - B{ - 1 2 3 4 5 6 7 8 9 - 10 11 12 13 14 15 16 17 18 - 19 20 21 22 23 24 25 26 27 - 28 29 30 31 32 33 34 35 36 - 37 38 39 40 41 42 43 44 45 - } image boa "image" set + T{ image + { dim { 3 5 } } + { component-order RGB } + { bitmap + B{ + 1 2 3 4 5 6 7 8 9 + 10 11 12 13 14 15 16 17 18 + 19 20 21 22 23 24 25 26 27 + 28 29 30 31 32 33 34 35 36 + 37 38 39 40 41 42 43 44 45 + } + } + } "image" set ] unit-test [ diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor index e486bffd38..2947ce242d 100644 --- a/basis/ui/gadgets/panes/panes-tests.factor +++ b/basis/ui/gadgets/panes/panes-tests.factor @@ -2,7 +2,7 @@ USING: alien ui.gadgets.panes ui.gadgets namespaces kernel sequences io io.styles io.streams.string tools.test prettyprint definitions help help.syntax help.markup help.stylesheet splitting tools.test.ui models math summary -inspector accessors help.topics ; +inspector accessors help.topics see ; IN: ui.gadgets.panes.tests : #children "pane" get children>> length ; diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor index 10ddde75ae..d9011ad776 100644 --- a/core/classes/singleton/singleton-tests.factor +++ b/core/classes/singleton/singleton-tests.factor @@ -1,4 +1,4 @@ -USING: kernel classes.singleton tools.test prettyprint io.streams.string ; +USING: kernel classes.singleton tools.test prettyprint io.streams.string see ; IN: classes.singleton.tests [ ] [ SINGLETON: bzzt ] unit-test diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index d221d28da9..f27d24e39d 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra calendar prettyprint io.streams.string splitting summary -columns math.order classes.private slots slots.private eval ; +columns math.order classes.private slots slots.private eval see ; IN: classes.tuple.tests TUPLE: rect x y w h ; diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor index 97baf08874..0802c0a2d9 100644 --- a/core/classes/union/union-tests.factor +++ b/core/classes/union/union-tests.factor @@ -4,7 +4,7 @@ tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files compiler.units kernel.private sorting vocabs io.streams.string -eval ; +eval see ; IN: classes.union.tests ! DEFER: bah diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 516d408933..2cd64ac9f4 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -5,7 +5,7 @@ specialized-arrays.double byte-arrays bit-arrays parser namespaces make quotations stack-checker vectors growable hashtables sbufs prettyprint byte-vectors bit-vectors specialized-vectors.double definitions generic sets graphs assocs -grouping ; +grouping see ; GENERIC: lo-tag-test ( obj -- obj' ) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 9c5d6f56ea..c178573a0a 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -684,7 +684,7 @@ $nl "This operation is efficient and does not copy the quotation." } { $examples { $example "USING: kernel prettyprint ;" "5 [ . ] curry ." "[ 5 . ]" } - { $example "USING: kernel prettyprint ;" "\\ = [ see ] curry ." "[ \\ = see ]" } + { $example "USING: kernel prettyprint see ;" "\\ = [ see ] curry ." "[ \\ = see ]" } { $example "USING: kernel math prettyprint sequences ;" "{ 1 2 3 } 2 [ - ] curry map ." "{ -1 0 1 }" } } ; diff --git a/extra/descriptive/descriptive-tests.factor b/extra/descriptive/descriptive-tests.factor index 1582ca895d..755c57ceda 100755 --- a/extra/descriptive/descriptive-tests.factor +++ b/extra/descriptive/descriptive-tests.factor @@ -1,4 +1,4 @@ -USING: descriptive kernel math tools.test continuations prettyprint io.streams.string ; +USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see ; IN: descriptive.tests DESCRIPTIVE: divide ( num denom -- fraction ) / ; diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor index 597a1cebeb..9d9c80b214 100644 --- a/extra/multi-methods/tests/syntax.factor +++ b/extra/multi-methods/tests/syntax.factor @@ -1,7 +1,7 @@ IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings definitions prettyprint debugger arrays -hashtables continuations classes assocs accessors ; +hashtables continuations classes assocs accessors see ; GENERIC: first-test From e70748f8f10a2c5ea5a02e9facbd4650b73dbbdd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 11 Mar 2009 19:39:35 -0500 Subject: [PATCH 25/27] Redoing class algebra so conjunction works --- basis/regexp/classes/classes-tests.factor | 8 +- basis/regexp/classes/classes.factor | 170 ++++++++++-------- .../combinators/combinators-tests.factor | 4 - basis/regexp/minimize/minimize-tests.factor | 2 +- 4 files changed, 101 insertions(+), 83 deletions(-) diff --git a/basis/regexp/classes/classes-tests.factor b/basis/regexp/classes/classes-tests.factor index 2deb944b61..e2db86f6c1 100644 --- a/basis/regexp/classes/classes-tests.factor +++ b/basis/regexp/classes/classes-tests.factor @@ -6,7 +6,7 @@ IN: regexp.classes.tests ! Class algebra [ f ] [ { 1 2 } ] unit-test -[ T{ or-class f { 2 1 } } ] [ { 1 2 } ] unit-test +[ T{ or-class f { 1 2 } } ] [ { 1 2 } ] unit-test [ 3 ] [ { 1 2 } 3 2array ] unit-test [ CHAR: A ] [ CHAR: A LETTER-class 2array ] unit-test [ CHAR: A ] [ LETTER-class CHAR: A 2array ] unit-test @@ -26,11 +26,13 @@ IN: regexp.classes.tests [ t ] [ { t t } ] unit-test [ T{ primitive-class { class letter-class } } ] [ letter-class dup 2array ] unit-test [ T{ primitive-class { class letter-class } } ] [ letter-class dup 2array ] unit-test -[ T{ or-class { seq { 2 3 1 } } } ] [ { 1 2 } { 2 3 } 2array ] unit-test -[ T{ or-class { seq { 3 2 } } } ] [ { 2 3 } 1 2array ] unit-test +[ T{ or-class { seq { 1 2 3 } } } ] [ { 1 2 } { 2 3 } 2array ] unit-test +[ T{ or-class { seq { 2 3 } } } ] [ { 2 3 } 1 2array ] unit-test [ f ] [ t ] unit-test [ t ] [ f ] unit-test [ f ] [ 1 1 t answer ] unit-test +[ t ] [ { 1 2 } 1 2 3array ] unit-test +[ f ] [ { 1 2 } 1 2 3array ] unit-test ! Making classes into nested conditionals diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index 1959a91cb5..d26ff7f69c 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math math.order words combinators locals ascii unicode.categories combinators.short-circuit sequences -fry macros arrays assocs sets classes ; +fry macros arrays assocs sets classes mirrors ; IN: regexp.classes SINGLETONS: any-char any-char-no-nl @@ -110,97 +110,116 @@ M: f class-member? 2drop f ; TUPLE: primitive-class class ; C: primitive-class +TUPLE: not-class class ; + +PREDICATE: not-integer < not-class class>> integer? ; +PREDICATE: not-primitive < not-class class>> primitive-class? ; + +M: not-class class-member? + class>> class-member? not ; + TUPLE: or-class seq ; -TUPLE: not-class class ; +M: or-class class-member? + seq>> [ class-member? ] with any? ; TUPLE: and-class seq ; -GENERIC: combine-and ( class1 class2 -- combined ? ) +M: and-class class-member? + seq>> [ class-member? ] with all? ; -: replace-if-= ( object object -- object ? ) - over = ; - -M: object combine-and replace-if-= ; - -M: t combine-and - drop t ; - -M: f combine-and - nip t ; - -M: not-class combine-and - class>> 2dup = [ 2drop f t ] [ - dup integer? [ - 2dup swap class-member? - [ 2drop f f ] - [ drop t ] if - ] [ 2drop f f ] if - ] if ; - -M: integer combine-and - swap 2dup class-member? [ drop t ] [ 2drop f t ] if ; - -GENERIC: combine-or ( class1 class2 -- combined ? ) - -M: object combine-or replace-if-= ; - -M: t combine-or - nip t ; - -M: f combine-or - drop t ; - -M: not-class combine-or - class>> = [ t t ] [ f f ] if ; - -M: integer combine-or - 2dup swap class-member? [ drop t ] [ 2drop f f ] if ; +DEFER: substitute : flatten ( seq class -- newseq ) '[ dup _ instance? [ seq>> ] [ 1array ] if ] map concat ; inline -: try-combine ( elt1 elt2 quot -- combined/f ? ) - 3dup call [ [ 3drop ] dip t ] [ drop swapd call ] if ; inline - -DEFER: answer - -:: try-cancel ( elt1 elt2 empty -- combined/f ? ) - [ elt1 elt2 empty answer dup elt1 = not ] try-combine ; - -:: prefix-combining ( seq elt quot: ( elt1 elt2 -- combined/f ? ) -- newseq ) - f :> combined! - seq [ elt quot call swap combined! ] find drop - [ seq remove-nth combined prefix ] - [ seq elt prefix ] if* ; inline - -: combine-by ( seq quot -- new-seq ) - { } swap '[ _ prefix-combining ] reduce ; inline - :: seq>instance ( seq empty class -- instance ) seq length { { 0 [ empty ] } { 1 [ seq first ] } - [ drop class new seq >>seq ] + [ drop class new seq { } like >>seq ] } case ; inline -:: combine ( seq quot: ( elt1 elt2 -- combined/f ? ) empty class -- newseq ) - seq class flatten - [ quot try-combine ] combine-by - ! [ empty try-cancel ] combine-by ! This makes the algorithm O(n^4) - empty class seq>instance ; inline +TUPLE: class-partition integers not-integers primitives not-primitives and or other ; + +: partition-classes ( seq -- class-partition ) + prune + [ integer? ] partition + [ not-integer? ] partition + [ primitive-class? ] partition ! extend primitive-class to epsilon tags + [ not-primitive? ] partition + [ and-class? ] partition + [ or-class? ] partition + class-partition boa ; + +: class-partition>seq ( class-partition -- seq ) + make-mirror values concat ; + +: repartition ( partition -- partition' ) + ! This could be made more efficient; only and and or are effected + class-partition>seq partition-classes ; + +: filter-not-integers ( partition -- partition' ) + dup + [ primitives>> ] [ not-primitives>> ] [ or>> ] tri + 3append and-class boa + '[ [ class>> _ class-member? ] filter ] change-not-integers ; + +: answer-ors ( partition -- partition' ) + dup [ not-integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append + '[ [ _ [ t substitute ] each ] map ] change-or ; + +: contradiction? ( partition -- ? ) + { + [ [ primitives>> ] [ not-primitives>> ] bi intersects? ] + [ other>> f swap member? ] + } 1|| ; + +: make-and-class ( partition -- and-class ) + answer-ors repartition + [ t swap remove ] change-other + dup contradiction? + [ drop f ] + [ filter-not-integers class-partition>seq prune t and-class seq>instance ] if ; : ( seq -- class ) - [ combine-and ] t and-class combine ; + dup and-class flatten partition-classes + dup integers>> length { + { 0 [ nip make-and-class ] } + { 1 [ integers>> first [ '[ _ swap class-member? ] all? ] keep and ] } + [ 3drop f ] + } case ; -M: and-class class-member? - seq>> [ class-member? ] with all? ; +: filter-integers ( partition -- partition' ) + dup + [ primitives>> ] [ not-primitives>> ] [ and>> ] tri + 3append or-class boa + '[ [ _ class-member? not ] filter ] change-integers ; + +: answer-ands ( partition -- partition' ) + dup [ integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append + '[ [ _ [ f substitute ] each ] map ] change-and ; + +: tautology? ( partition -- ? ) + { + [ [ primitives>> ] [ not-primitives>> ] bi intersects? ] + [ other>> t swap member? ] + } 1|| ; + +: make-or-class ( partition -- and-class ) + answer-ands repartition + [ f swap remove ] change-other + dup tautology? + [ drop t ] + [ filter-integers class-partition>seq prune f or-class seq>instance ] if ; : ( seq -- class ) - [ combine-or ] f or-class combine ; - -M: or-class class-member? - seq>> [ class-member? ] with any? ; + dup or-class flatten partition-classes + dup not-integers>> length { + { 0 [ nip make-or-class ] } + { 1 [ not-integers>> first [ class>> '[ _ swap class-member? ] any? ] keep or ] } + [ 3drop t ] + } case ; GENERIC: ( class -- inverse ) @@ -219,9 +238,6 @@ M: or-class M: t drop f ; M: f drop t ; -M: not-class class-member? - class>> class-member? not ; - M: primitive-class class-member? class>> class-member? ; @@ -247,8 +263,12 @@ M: or-class answer M: not-class answer [ class>> ] 2dip answer ; +GENERIC# substitute 1 ( class from to -- new-class ) +M: object substitute answer ; +M: not-class substitute [ ] bi@ answer ; + : assoc-answer ( table question answer -- new-table ) - '[ _ _ answer ] assoc-map + '[ _ _ substitute ] assoc-map [ nip ] assoc-filter ; : assoc-answers ( table questions answer -- new-table ) diff --git a/basis/regexp/combinators/combinators-tests.factor b/basis/regexp/combinators/combinators-tests.factor index ddfd0dcaad..85fa190bfe 100644 --- a/basis/regexp/combinators/combinators-tests.factor +++ b/basis/regexp/combinators/combinators-tests.factor @@ -9,9 +9,6 @@ IN: regexp.combinators.tests [ t t t ] [ "foo" "bar" "baz" [ strings matches? ] tri@ ] unit-test [ f f f ] [ "food" "ibar" "ba" [ strings matches? ] tri@ ] unit-test -USE: multiline -/* -! Why is conjuction broken? : conj ( -- regexp ) { R' .*a' R' b.*' } ; @@ -22,7 +19,6 @@ USE: multiline [ f ] [ "bljhasflsda" conj matches? ] unit-test [ t ] [ "bsdfdfs" conj matches? ] unit-test [ t ] [ "fsfa" conj matches? ] unit-test -*/ [ f f ] [ "" "hi" [ matches? ] bi@ ] unit-test [ t t ] [ "" "hi" [ matches? ] bi@ ] unit-test diff --git a/basis/regexp/minimize/minimize-tests.factor b/basis/regexp/minimize/minimize-tests.factor index a7a9b50327..17a1d51b88 100644 --- a/basis/regexp/minimize/minimize-tests.factor +++ b/basis/regexp/minimize/minimize-tests.factor @@ -54,5 +54,5 @@ IN: regexp.minimize.tests [ [ ] [ ] while-changes ] must-infer -[ H{ { T{ or-class f { 1 2 } } 3 } { 4 5 } } ] +[ H{ { T{ or-class f { 2 1 } } 3 } { 4 5 } } ] [ H{ { 1 3 } { 2 3 } { 4 5 } } combine-state-transitions ] unit-test From 03f048cce9c0ed0e5ce37b078983ea14657d8897 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Mar 2009 21:51:39 -0500 Subject: [PATCH 26/27] Add a couple of must-infer tests --- basis/html/components/components-tests.factor | 2 ++ basis/xmode/code2html/code2html-tests.factor | 2 ++ 2 files changed, 4 insertions(+) diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index 410c3ce223..0b85455c2e 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -4,6 +4,8 @@ io.streams.null accessors inspector html.streams html.components html.forms namespaces xml.writer ; +\ render must-infer + [ ] [ begin-form ] unit-test [ ] [ 3 "hi" set-value ] unit-test diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor index c0b8a1b560..241ab7ff75 100644 --- a/basis/xmode/code2html/code2html-tests.factor +++ b/basis/xmode/code2html/code2html-tests.factor @@ -3,6 +3,8 @@ USING: xmode.code2html xmode.catalog tools.test multiline splitting memoize kernel io.streams.string xml.writer ; +\ htmlize-file must-infer + [ ] [ \ (load-mode) reset-memoized ] unit-test [ ] [ From 1ca2e8196be8a9f1d681e73c0773717455305a11 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 11 Mar 2009 22:04:47 -0500 Subject: [PATCH 27/27] Making regexp generate less class algebra --- basis/regexp/compiler/compiler.factor | 11 +---------- basis/regexp/disambiguate/disambiguate.factor | 5 ++--- basis/regexp/minimize/minimize.factor | 3 ++- .../transition-tables/transition-tables.factor | 12 ++++++++++++ 4 files changed, 17 insertions(+), 14 deletions(-) diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor index c837df0f0f..186d683f82 100644 --- a/basis/regexp/compiler/compiler.factor +++ b/basis/regexp/compiler/compiler.factor @@ -77,17 +77,8 @@ C: box : literals>cases ( literal-transitions -- case-body ) [ execution-quot ] assoc-map ; -: expand-one-or ( or-class transition -- alist ) - [ seq>> ] dip '[ _ 2array ] map ; - -: expand-or ( alist -- new-alist ) - [ - first2 over or-class? - [ expand-one-or ] [ 2array 1array ] if - ] map concat ; - : split-literals ( transitions -- case default ) - >alist expand-or [ first integer? ] partition + { } assoc-like [ first integer? ] partition [ [ literals>cases ] keep ] dip non-literals>dispatch ; :: step ( last-match index str quot final? direction -- last-index/f ) diff --git a/basis/regexp/disambiguate/disambiguate.factor b/basis/regexp/disambiguate/disambiguate.factor index eac9c7e81d..67b1503f9b 100644 --- a/basis/regexp/disambiguate/disambiguate.factor +++ b/basis/regexp/disambiguate/disambiguate.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors regexp.classes math.bits assocs sequences -arrays sets regexp.dfa math fry regexp.minimize regexp.ast ; +arrays sets regexp.dfa math fry regexp.minimize regexp.ast regexp.transition-tables ; IN: regexp.disambiguate TUPLE: parts in out ; @@ -32,9 +32,8 @@ TUPLE: parts in out ; : preserving-epsilon ( state-transitions quot -- new-state-transitions ) [ [ drop tagged-epsilon? ] assoc-filter ] bi assoc-union H{ } assoc-like ; inline - : disambiguate ( nfa -- nfa ) - [ + expand-ors [ dup new-transitions '[ [ _ swap '[ _ get-transitions ] assoc-map diff --git a/basis/regexp/minimize/minimize.factor b/basis/regexp/minimize/minimize.factor index bdb53c51cb..1885144e6c 100644 --- a/basis/regexp/minimize/minimize.factor +++ b/basis/regexp/minimize/minimize.factor @@ -96,4 +96,5 @@ IN: regexp.minimize clone number-states combine-states - combine-transitions ; + combine-transitions + expand-ors ; diff --git a/basis/regexp/transition-tables/transition-tables.factor b/basis/regexp/transition-tables/transition-tables.factor index 48e84d372c..3c33ae8846 100644 --- a/basis/regexp/transition-tables/transition-tables.factor +++ b/basis/regexp/transition-tables/transition-tables.factor @@ -47,3 +47,15 @@ TUPLE: transition-table transitions start-state final-states ; [ '[ _ condition-at ] change-start-state ] [ '[ [ _ at ] map-set ] change-final-states ] [ '[ _ number-transitions ] change-transitions ] tri ; + +: expand-one-or ( or-class transition -- alist ) + [ seq>> ] dip '[ _ 2array ] map ; + +: expand-or ( state-transitions -- new-transitions ) + >alist [ + first2 over or-class? + [ expand-one-or ] [ 2array 1array ] if + ] map concat >hashtable ; + +: expand-ors ( transition-table -- transition-table ) + [ [ expand-or ] assoc-map ] change-transitions ;