diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 3df709c9fa..75f83c1a55 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -76,6 +76,37 @@ HELP: sum-outputs } } ; +HELP: append-outputs +{ $values + { "quot" quotation } + { "seq" sequence } +} +{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns a sequence of the outputs appended." } +{ $examples + { $example + "USING: combinators.smart prettyprint ;" + "[ { 1 2 } { \"A\" \"b\" } ] append-outputs ." + "{ 1 2 \"A\" \"b\" }" + } +} ; + +HELP: append-outputs-as +{ $values + { "quot" quotation } { "exemplar" sequence } + { "seq" sequence } +} +{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns a sequence of type " { $snippet "exemplar" } " of the outputs appended." } +{ $examples + { $example + "USING: combinators.smart prettyprint ;" + "[ { 1 2 } { \"A\" \"b\" } ] V{ } append-outputs-as ." + "V{ 1 2 \"A\" \"b\" }" + } +} ; + +{ append-outputs append-outputs-as } related-words + + ARTICLE: "combinators.smart" "Smart combinators" "The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl "Smart inputs from a sequence:" @@ -86,6 +117,9 @@ ARTICLE: "combinators.smart" "Smart combinators" "Reducing the output of a quotation:" { $subsection reduce-outputs } "Summing the output of a quotation:" -{ $subsection sum-outputs } ; +{ $subsection sum-outputs } +"Appending the results of a quotation:" +{ $subsection append-outputs } +{ $subsection append-outputs-as } ; ABOUT: "combinators.smart" diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 54c53477db..370dc26960 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -12,10 +12,28 @@ IN: combinators.smart.tests [ { 9 11 } [ + ] input> ] dip '[ @ _ _ nappend-as ] ; + +: append-outputs ( quot -- seq ) + { } append-outputs-as ; inline diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 9fde1fd1b1..a676be3be8 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -259,6 +259,55 @@ HELP: mnswap } } ; +HELP: n*quot +{ $values + { "n" integer } { "seq" sequence } + { "seq'" sequence } +} +{ $examples + { $example "USING: generalizations prettyprint math ;" + "3 [ + ] n*quot ." + "[ + + + ]" + } +} +{ $description "Construct a quotation containing the contents of " { $snippet "seq" } " repeated " { $snippet "n"} " times." } ; + +HELP: nappend +{ $values + { "n" integer } + { "seq" sequence } +} +{ $description "Outputs a new sequence consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." } +{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." } +{ $examples + { $example "USING: generalizations prettyprint math ;" + "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 nappend ." + "{ 1 2 3 4 5 6 7 8 }" + } +} ; + +HELP: nappend-as +{ $values + { "n" integer } { "exemplar" sequence } + { "seq" sequence } +} +{ $description "Outputs a new sequence of type " { $snippet "exemplar" } " consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." } +{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." } +{ $examples + { $example "USING: generalizations prettyprint math ;" + "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 V{ } nappend-as ." + "V{ 1 2 3 4 5 6 7 8 }" + } +} ; + +{ nappend nappend-as } related-words + +HELP: ntuck +{ $values + { "n" integer } +} +{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; + ARTICLE: "generalizations" "Generalized shuffle words and combinators" "The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " "macros where the arity of the input quotations depends on an " @@ -268,6 +317,8 @@ $nl { $subsection narray } { $subsection nsequence } { $subsection firstn } +{ $subsection nappend } +{ $subsection nappend-as } "Generated stack shuffle operations:" { $subsection ndup } { $subsection npick } @@ -275,6 +326,7 @@ $nl { $subsection -nrot } { $subsection nnip } { $subsection ndrop } +{ $subsection ntuck } { $subsection nrev } { $subsection mnswap } "Generalized combinators:" diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 4eb4c4e686..35e02f08b4 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -5,6 +5,7 @@ IN: generalizations.tests { 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test { 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test { 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test + [ 1 1 ndup ] must-infer { 1 1 } [ 1 1 ndup ] unit-test { 1 2 1 2 } [ 1 2 2 ndup ] unit-test @@ -22,6 +23,8 @@ IN: generalizations.tests { 4 } [ 1 2 3 4 3 nnip ] unit-test [ 1 2 3 4 4 ndrop ] must-infer { 0 } [ 0 1 2 3 4 4 ndrop ] unit-test +[ [ 1 ] 5 ndip ] must-infer +[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test [ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer { 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test @@ -44,3 +47,9 @@ IN: generalizations.tests [ 4 5 1 2 3 ] [ 1 2 3 4 5 2 3 mnswap ] unit-test [ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 2 4 mnswap 4 2 mnswap ] unit-test + +[ { 1 2 3 4 } ] [ { 1 } { 2 } { 3 } { 4 } 4 nappend ] unit-test +[ V{ 1 2 3 4 } ] [ { 1 } { 2 } { 3 } { 4 } 4 V{ } nappend-as ] unit-test + +[ 4 nappend ] must-infer +[ 4 { } nappend-as ] must-infer diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index a447d5c706..c6a17df099 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -2,7 +2,7 @@ ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private math math.ranges -combinators macros quotations fry ; +combinators macros quotations fry macros locals ; IN: generalizations << @@ -78,3 +78,8 @@ MACRO: napply ( quot n -- ) MACRO: mnswap ( m n -- ) 1+ '[ _ -nrot ] spread>quot ; + +: nappend-as ( n exemplar -- seq ) + [ narray concat ] dip like ; inline + +: nappend ( n -- seq ) narray concat ; inline diff --git a/basis/pack/pack-tests.factor b/basis/pack/pack-tests.factor index 1be37292a0..999a952174 100755 --- a/basis/pack/pack-tests.factor +++ b/basis/pack/pack-tests.factor @@ -1,5 +1,6 @@ USING: io io.streams.string kernel namespaces make -pack strings tools.test ; +pack strings tools.test pack.private ; +IN: pack.tests [ B{ 1 0 2 0 0 3 0 0 0 4 0 0 0 0 0 0 0 5 } ] [ { 1 2 3 4 5 } @@ -37,15 +38,6 @@ pack strings tools.test ; "cstiq" [ pack-native ] keep unpack-native ] unit-test -[ 2 ] [ - [ 2 "int" b, ] B{ } make - [ "int" read-native ] with-input-stream -] unit-test - -[ "FRAM" ] [ "FRAM\0" [ read-c-string ] with-string-reader ] unit-test -[ f ] [ "" [ read-c-string ] with-string-reader ] unit-test -[ 5 ] [ "FRAM\0\u000005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] with-string-reader ] unit-test - [ 9 ] [ "iic" packed-length ] unit-test [ "iii" read-packed-le ] must-infer [ "iii" read-packed-be ] must-infer @@ -53,3 +45,10 @@ pack strings tools.test ; [ "iii" unpack-le ] must-infer [ "iii" unpack-be ] must-infer [ "iii" unpack-native ] must-infer +[ "iii" pack ] must-infer +[ "iii" unpack ] must-infer + +: test-pack ( str -- ba ) + "iii" pack ; + +[ test-pack ] must-infer diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 136deb9ff5..aec4414c71 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -3,7 +3,9 @@ USING: alien alien.c-types arrays assocs byte-arrays io io.binary io.streams.string kernel math math.parser namespaces make parser prettyprint quotations sequences strings vectors -words macros math.functions math.bitwise fry ; +words macros math.functions math.bitwise fry generalizations +combinators.smart io.streams.byte-array io.encodings.binary +math.vectors combinators multiline ; IN: pack SYMBOL: big-endian @@ -18,131 +20,77 @@ SYMBOL: big-endian PRIVATE> -: >endian ( obj n -- str ) - big-endian get [ >be ] [ >le ] if ; inline - -: endian> ( obj -- str ) - big-endian get [ be> ] [ le> ] if ; inline - -GENERIC: b, ( n obj -- ) -M: integer b, ( m n -- ) >endian % ; - -! for doing native, platform-dependent sized values -M: string b, ( n string -- ) heap-size b, ; -: read-native ( string -- n ) heap-size read endian> ; - -! Portable -: s8, ( n -- ) 1 b, ; -: u8, ( n -- ) 1 b, ; -: s16, ( n -- ) 2 b, ; -: u16, ( n -- ) 2 b, ; -: s24, ( n -- ) 3 b, ; -: u24, ( n -- ) 3 b, ; -: s32, ( n -- ) 4 b, ; -: u32, ( n -- ) 4 b, ; -: s64, ( n -- ) 8 b, ; -: u64, ( n -- ) 8 b, ; -: s128, ( n -- ) 16 b, ; -: u128, ( n -- ) 16 b, ; -: float, ( n -- ) float>bits 4 b, ; -: double, ( n -- ) double>bits 8 b, ; -: c-string, ( str -- ) % 0 u8, ; - -128-ber) ( n -- ) - dup 0 > [ - [ HEX: 7f bitand HEX: 80 bitor , ] keep -7 shift - (>128-ber) - ] [ - drop - ] if ; - -PRIVATE> - -: >128-ber ( n -- str ) - [ - [ HEX: 7f bitand , ] keep -7 shift - (>128-ber) - ] { } make reverse ; - : >signed ( x n -- y ) 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; -: read-signed ( n -- str ) - dup read endian> swap 8 * >signed ; +: >endian ( obj n -- str ) + big-endian get [ >be ] [ >le ] if ; inline -: read-unsigned ( n -- m ) read endian> ; +: unsigned-endian> ( obj -- str ) + big-endian get [ be> ] [ le> ] if ; inline -: read-s8 ( -- n ) 1 read-signed ; -: read-u8 ( -- n ) 1 read-unsigned ; -: read-s16 ( -- n ) 2 read-signed ; -: read-u16 ( -- n ) 2 read-unsigned ; -: read-s24 ( -- n ) 3 read-signed ; -: read-u24 ( -- n ) 3 read-unsigned ; -: read-s32 ( -- n ) 4 read-signed ; -: read-u32 ( -- n ) 4 read-unsigned ; -: read-s64 ( -- n ) 8 read-signed ; -: read-u64 ( -- n ) 8 read-unsigned ; -: read-s128 ( -- n ) 16 read-signed ; -: read-u128 ( -- n ) 16 read-unsigned ; +: signed-endian> ( obj n -- str ) + [ unsigned-endian> ] dip >signed ; -: read-float ( -- n ) - 4 read endian> bits>float ; +GENERIC: >n-byte-array ( obj n -- byte-array ) -: read-double ( -- n ) - 8 read endian> bits>double ; +M: integer >n-byte-array ( m n -- byte-array ) >endian ; -: read-c-string ( -- str/f ) - "\0" read-until swap and ; +! for doing native, platform-dependent sized values +M: string >n-byte-array ( n string -- byte-array ) heap-size >n-byte-array ; -: read-c-string* ( n -- str/f ) - read [ zero? ] trim-right [ f ] when-empty ; - -: (read-128-ber) ( n -- n ) - read1 - [ [ 7 shift ] [ 7 clear-bit ] bi* bitor ] keep - 7 bit? [ (read-128-ber) ] when ; - -: read-128-ber ( -- n ) - 0 (read-128-ber) ; +: s8>byte-array ( n -- byte-array ) 1 >n-byte-array ; +: u8>byte-array ( n -- byte-array ) 1 >n-byte-array ; +: s16>byte-array ( n -- byte-array ) 2 >n-byte-array ; +: u16>byte-array ( n -- byte-array ) 2 >n-byte-array ; +: s24>byte-array ( n -- byte-array ) 3 >n-byte-array ; +: u24>byte-array ( n -- byte-array ) 3 >n-byte-array ; +: s32>byte-array ( n -- byte-array ) 4 >n-byte-array ; +: u32>byte-array ( n -- byte-array ) 4 >n-byte-array ; +: s64>byte-array ( n -- byte-array ) 8 >n-byte-array ; +: u64>byte-array ( n -- byte-array ) 8 >n-byte-array ; +: s128>byte-array ( n -- byte-array ) 16 >n-byte-array ; +: u128>byte-array ( n -- byte-array ) 16 >n-byte-array ; +: write-float ( n -- byte-array ) float>bits 4 >n-byte-array ; +: write-double ( n -- byte-array ) double>bits 8 >n-byte-array ; +: write-c-string ( byte-array -- byte-array ) { 0 } B{ } append-as ; byte-array } + { CHAR: C u8>byte-array } + { CHAR: s s16>byte-array } + { CHAR: S u16>byte-array } + { CHAR: t s24>byte-array } + { CHAR: T u24>byte-array } + { CHAR: i s32>byte-array } + { CHAR: I u32>byte-array } + { CHAR: q s64>byte-array } + { CHAR: Q u64>byte-array } + { CHAR: f write-float } + { CHAR: F write-float } + { CHAR: d write-double } + { CHAR: D write-double } } CONSTANT: unpack-table H{ - { CHAR: c read-s8 } - { CHAR: C read-u8 } - { CHAR: s read-s16 } - { CHAR: S read-u16 } - { CHAR: t read-s24 } - { CHAR: T read-u24 } - { CHAR: i read-s32 } - { CHAR: I read-u32 } - { CHAR: q read-s64 } - { CHAR: Q read-u64 } - { CHAR: f read-float } - { CHAR: F read-float } - { CHAR: d read-double } - { CHAR: D read-double } + { CHAR: c [ 8 signed-endian> ] } + { CHAR: C [ unsigned-endian> ] } + { CHAR: s [ 16 signed-endian> ] } + { CHAR: S [ unsigned-endian> ] } + { CHAR: t [ 24 signed-endian> ] } + { CHAR: T [ unsigned-endian> ] } + { CHAR: i [ 32 signed-endian> ] } + { CHAR: I [ unsigned-endian> ] } + { CHAR: q [ 64 signed-endian> ] } + { CHAR: Q [ unsigned-endian> ] } + { CHAR: f [ unsigned-endian> bits>float ] } + { CHAR: F [ unsigned-endian> bits>float ] } + { CHAR: d [ unsigned-endian> bits>double ] } + { CHAR: D [ unsigned-endian> bits>double ] } } CONSTANT: packed-length-table @@ -163,11 +111,19 @@ CONSTANT: packed-length-table { CHAR: D 8 } } -MACRO: pack ( seq str -- quot ) - [ pack-table at 1quotation '[ _ @ ] ] [ ] 2map-as concat - '[ _ B{ } make ] ; +MACRO: pack ( str -- quot ) + [ pack-table at '[ _ execute ] ] { } map-as + '[ _ spread ] + '[ _ input + +: ch>packed-length ( ch -- n ) + packed-length-table at ; inline + +: packed-length ( str -- n ) + [ ch>packed-length ] sigma ; : pack-native ( seq str -- seq ) [ set-big-endian pack ] with-scope ; inline @@ -180,9 +136,14 @@ PRIVATE> packed-length ] { } map-as start/end ] + [ [ unpack-table at '[ @ ] ] { } map-as ] bi + [ '[ [ _ _ ] dip @ ] ] 3map + '[ _ cleave ] '[ _ output>array ] ; PRIVATE> @@ -195,9 +156,6 @@ PRIVATE> : unpack-le ( seq str -- seq ) [ big-endian off unpack ] with-scope ; inline -: packed-length ( str -- n ) - [ packed-length-table at ] sigma ; - ERROR: packed-read-fail str bytes ;