From 8e8b5f59f575c3fab2327aa98516ff185d628557 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 2 Dec 2017 19:05:25 -0600 Subject: [PATCH] factor: update sorting functor by adding a name type to functors2. --- .../dataflow-analysis.factor | 6 ++-- basis/sorting/functor/functor.factor | 17 +++------- basis/sorting/title/title.factor | 8 ++--- core/functors2/functors2.factor | 34 +++++++++++-------- 4 files changed, 31 insertions(+), 34 deletions(-) diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index 2bceb4709a..4431c96ddb 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -56,7 +56,7 @@ MIXIN: dataflow-analysis M: dataflow-analysis join-sets 2drop assoc-refine ; M: dataflow-analysis ignore-block? drop kill-block?>> ; -SAME-FUNCTOR: dataflow-analysis ( name: string -- ) [[ +SAME-FUNCTOR: dataflow-analysis ( name: name -- ) [[ USING: assocs namespaces ; SINGLETON: ${name} SYMBOL: ${name}-ins @@ -74,7 +74,7 @@ M: forward-analysis block-order drop reverse-post-order ; M: forward-analysis successors drop successors>> ; M: forward-analysis predecessors drop predecessors>> ; -SAME-FUNCTOR: forward-analysis ( name: string -- ) [[ +SAME-FUNCTOR: forward-analysis ( name: name -- ) [[ USING: assocs kernel namespaces ; QUALIFIED: namespaces @@ -97,7 +97,7 @@ M: backward-analysis block-order drop post-order ; M: backward-analysis successors drop predecessors>> ; M: backward-analysis predecessors drop successors>> ; -SAME-FUNCTOR: backward-analysis ( name: string -- ) [[ +SAME-FUNCTOR: backward-analysis ( name: name -- ) [[ USING: assocs kernel namespaces ; QUALIFIED: namespaces diff --git a/basis/sorting/functor/functor.factor b/basis/sorting/functor/functor.factor index c4078576c4..ef9d55338d 100644 --- a/basis/sorting/functor/functor.factor +++ b/basis/sorting/functor/functor.factor @@ -1,16 +1,9 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: functors kernel math.order sequences sorting ; +USING: functors2 quotations strings ; IN: sorting.functor - DEFINES ${NAME}<=> -NAME>=< DEFINES ${NAME}>=< - -WHERE - -: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ; -: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ; - -;FUNCTOR> +SAME-FUNCTOR: sorting ( NAME: name QUOT: string -- ) [[ + : ${NAME}<=> ( obj1 obj2 -- <=> ) ${QUOT} compare ; + : ${NAME}>=< ( obj1 obj2 -- >=< ) ${NAME}<=> invert-comparison ; +]] diff --git a/basis/sorting/title/title.factor b/basis/sorting/title/title.factor index 7925287cb5..97c84f01f9 100644 --- a/basis/sorting/title/title.factor +++ b/basis/sorting/title/title.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: sorting.functor regexp kernel accessors sequences -unicode ; +USING: accessors kernel math.order regexp sequences +sorting.functor unicode ; IN: sorting.title -<< "title" [ +SORTING: title "[ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* -] define-sorting >> +]" diff --git a/core/functors2/functors2.factor b/core/functors2/functors2.factor index 865b72e7d7..b61f59412b 100644 --- a/core/functors2/functors2.factor +++ b/core/functors2/functors2.factor @@ -4,7 +4,7 @@ USING: accessors arrays ascii assocs classes classes.parser combinators effects.parser generalizations interpolate io.streams.string kernel lexer make math.parser namespaces parser quotations sequences sequences.generalizations strings -vocabs.generated vocabs.parser words splitting ; +vocabs.generated vocabs.parser words splitting combinators.short-circuit ; QUALIFIED: sets IN: functors2 @@ -16,7 +16,7 @@ ERROR: not-all-unique seq ; : effect-in>drop-variables ( effect -- quot ) in>> ensure-unique - [ '[ dup string? [ name>> ] unless _ dup array? [ first ] when set ] ] map + [ '[ dup word? [ name>> ] when _ dup array? [ first ] when set ] ] map '[ _ spread ] ; inline : make-in-drop-variables ( def effect -- def effect ) @@ -27,21 +27,21 @@ ERROR: not-all-unique seq ; >> : functor-definer-word-name ( word -- string ) - dup string? [ name>> ] unless >lower "define-" prepend ; + dup word? [ name>> ] when >lower "define-" prepend ; : functor-syntax-word-name ( word -- string ) - dup string? [ name>> ] unless >upper ":" append ; + dup word? [ name>> ] when >upper ":" append ; : functor-word-name ( word -- string ) - dup string? [ name>> ] unless "-functor" append ; + dup word? [ name>> ] when "-functor" append ; : functor-instantiated-vocab-name ( functor-word parameters -- string ) dupd '[ ! box-functor:functors:box:float:1827917291 - _ dup string? [ vocabulary>> ] unless % + _ dup word? [ vocabulary>> ] when % ":functors:" % - _ dup string? [ name>> ] unless % ! functor name, e.g. box + _ dup word? [ name>> ] when % ! functor name, e.g. box ":" % _ hashcode number>string % ! narray for all the template parameters ] "" make ; @@ -50,7 +50,7 @@ ERROR: not-all-unique seq ; drop '[ ! box-functor:functors:box:float:1827917291 - _ dup string? [ vocabulary>> ] unless % + _ dup word? [ vocabulary>> ] when % ] "" make ; : prepend-input-vocabs-generated ( word def effect -- word def effect ) @@ -63,7 +63,7 @@ ERROR: not-all-unique seq ; ] [ [ [ - [ dup string? [ drop current-vocab name>> ] [ vocabulary>> ] if ] [ dup string? [ name>> ] unless ] bi + [ dup word? [ vocabulary>> ] [ drop current-vocab name>> ] if ] [ dup word? [ name>> ] when ] bi " => " glue "FROM: " " ;\n" surround ] ] replicate @@ -89,8 +89,12 @@ ERROR: not-all-unique seq ; ] [ [ [ - [ dup string? [ drop current-vocab name>> ] [ vocabulary>> ] if ] [ dup string? [ name>> ] unless ] bi - " => " glue "FROM: " " ;\n" surround drop "" + dup { [ word? ] [ string? ] } 1|| [ + [ dup word? [ vocabulary>> ] [ drop current-vocab name>> ] if ] [ dup word? [ name>> ] when ] bi + " => " glue "FROM: " " ;\n" surround drop "" + ] [ + drop "" + ] if ] ] replicate ] [ ] tri dup @@ -125,13 +129,15 @@ ERROR: no-type arg ; : argument>type ( argument -- type ) dup array? [ ?second ] [ no-type ] if ; -SINGLETONS: new-class new-word existing-class existing-word ; +SINGLETONS: name new-class new-word existing-class existing-word ; CONSTANT: scanner-table H{ { new-class [ scan-new-class ] } { existing-class [ scan-class ] } { new-word [ scan-new-word ] } { existing-word [ scan-word ] } - { string [ scan-token ] } + { name [ scan-token ] } + { string [ scan-object ] } + { quotation [ scan-object ] } } : type>scanner ( obj -- quot ) @@ -153,7 +159,6 @@ CONSTANT: scanner-table H{ ] dip in>> [ argument>type type>scanner - ! [ scan-object ] ] { } map-as [ ] concat-as swap 1quotation @@ -176,7 +181,6 @@ CONSTANT: scanner-table H{ ] dip in>> [ argument>type type>scanner - ! [ scan-object ] ] { } map-as [ ] concat-as swap 1quotation