diff --git a/extra/modern/manifest/manifest.factor b/extra/modern/manifest/manifest.factor index 921cb96b4e..74648e7832 100644 --- a/extra/modern/manifest/manifest.factor +++ b/extra/modern/manifest/manifest.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2019 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators -combinators.short-circuit kernel modern sequences -splitting.monotonic strings words ; +combinators.short-circuit kernel modern modern.compiler +sequences splitting.monotonic strings words ; IN: modern.manifest MIXIN: token @@ -228,27 +228,3 @@ GENERIC: upper-colon>definitions ( form -- seq ) { [ dup ?first upper-colon? ] [ upper-colon>definitions ] } [ ] } cond ; - -DEFER: map-literals -: map-literal ( obj quot: ( obj -- obj' ) -- obj ) - over { [ array? ] [ ?first section-open? ] } 1&& [ - [ first3 swap ] dip map-literals swap 3array - ] [ - call - ] if ; inline recursive - -: map-literals ( seq quot: ( obj -- obj' ) -- seq' ) - '[ _ map-literal ] map ; inline recursive - -DEFER: map-literals! -: map-literal! ( obj quot: ( obj -- obj' ) -- obj ) - over { [ array? ] [ ?first section-open? ] } 1&& [ - [ call drop ] [ - map-literals! - ] 2bi - ] [ - call - ] if ; inline recursive - -: map-literals! ( seq quot: ( obj -- obj' ) -- seq ) - '[ _ map-literal! ] map! ; inline recursive diff --git a/extra/modern/modern.factor b/extra/modern/modern.factor index 6c10798da7..3362d60d72 100644 --- a/extra/modern/modern.factor +++ b/extra/modern/modern.factor @@ -66,8 +66,7 @@ DEFER: lex-factor ] loop ] { } make ; -DEFER: section-close? -DEFER: upper-colon? +DEFER: section-close-form? DEFER: lex-factor-nested : lex-colon-until ( string n tag-sequence -- string n' payload ) '[ @@ -77,7 +76,7 @@ DEFER: lex-factor-nested [ dup [ ! This is for ending COLON: forms like ``A: PRIVATE>`` - dup section-close? [ + dup section-close-form? [ drop f ] [ ! } gets a chance, but then also full seq { } after recursion... @@ -249,7 +248,7 @@ MACRO:: read-matched ( ch -- quot: ( string n tag -- string n' slice' ) ) [ html-close? ] } 1|| ; -: upper-colon? ( string -- ? ) +: upper-colon-form? ( string -- ? ) dup { [ length 0 > ] [ [ char: \: = ] all? ] } 1&& [ drop t ] [ @@ -261,7 +260,7 @@ MACRO:: read-matched ( ch -- quot: ( string n tag -- string n' slice' ) ) } 1&& ] if ; -: section-close? ( string -- ? ) +: section-close-form? ( string -- ? ) { [ length 2 >= ] [ "\\" head? not ] ! XXX: good? @@ -290,8 +289,8 @@ MACRO:: read-matched ( ch -- quot: ( string n tag -- string n' slice' ) ) { [ dup "]" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } { [ dup "}" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } { [ dup ")" sequence= ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } ! (n*quot) breaks - { [ dup section-close? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } - { [ dup upper-colon? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } + { [ dup section-close-form? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } + { [ dup upper-colon-form? ] [ drop unclip-last -rot 2array [ rewind-slice ] dip ] } [ drop 2array ] } cond ; @@ -415,7 +414,7 @@ DEFER: lex-factor-top* { char: \! [ read-exclamation ] } { char: > [ [ [ char: > = not ] slice-until-exclude drop ] dip merge-slices - dup section-close? [ + dup section-close-form? [ [ slice-til-whitespace drop ] dip ?span-slices ] unless ] } @@ -432,7 +431,7 @@ DEFER: lex-factor-top* ! A: B: then interrupt the current parser ! A: b: then keep going merge-slice-til-whitespace - dup { [ upper-colon? ] [ ":" = ] } 1|| + dup { [ upper-colon-form? ] [ ":" = ] } 1|| ! dup upper-colon? [ rewind-slice f ] [ read-colon ] if diff --git a/extra/modern/out/out.factor b/extra/modern/out/out.factor index b5c3068bbf..19dd4b0891 100644 --- a/extra/modern/out/out.factor +++ b/extra/modern/out/out.factor @@ -30,6 +30,7 @@ M: renamed write-literal* [ slice>> ] tri ; ! for refactoring : write-literal ( obj -- ) f swap write-literal* drop ; +![[ DEFER: map-literals : (map-literals) ( obj quot: ( obj -- obj' ) -- seq ) over array? [ @@ -41,6 +42,32 @@ DEFER: map-literals : map-literals ( obj quot: ( obj -- obj' ) -- seq ) '[ _ (map-literals) ] map ; inline recursive +]] + +DEFER: map-literals +: map-literal ( obj quot: ( ..a obj -- ..a obj' ) -- obj ) + over section? [ + [ second ] dip map-literals + ] [ + call + ] if ; inline recursive + +: map-literals ( seq quot: ( ..a obj -- ..a obj' ) -- seq' ) + '[ _ map-literal ] map ; inline recursive + +DEFER: map-literals! +: map-literal! ( obj quot: ( obj -- obj' ) -- obj ) + over { [ array? ] [ ?first section-open? ] } 1&& [ + [ call drop ] [ + map-literals! + ] 2bi + ] [ + call + ] if ; inline recursive + +: map-literals! ( seq quot: ( obj -- obj' ) -- seq ) + '[ _ map-literal! ] map! ; inline recursive + : write-modern-string ( seq -- string ) [ write-literal ] with-string-writer ; inline diff --git a/extra/modern/tools/authors.txt b/extra/modern/tools/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/modern/tools/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/modern/tools/tools.factor b/extra/modern/tools/tools.factor new file mode 100644 index 0000000000..2b54f2cc44 --- /dev/null +++ b/extra/modern/tools/tools.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2019 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs combinators.short-circuit kernel modern +modern.compiler modern.out modern.slices sequences +sequences.extras ; +IN: modern.tools + +: vocabs>using-tool ( vocabs -- assoc ) + [ vocab>literals ] map-zip + [ + [ + { [ upper-colon? ] [ first "USING:" sequence= ] } 1&& + ] filter + [ second >strings ] map + ] assoc-map ; + +! Needs filter-literals +: vocabs>using-tool2 ( vocabs -- assoc ) + [ vocab>literals ] map-zip + [ + [ + dup { [ upper-colon? ] [ first "USING:" sequence= ] } 1&& [ + second >strings + ] [ + drop f + ] if + ] map-literals harvest concat harvest + ] assoc-map ; \ No newline at end of file