Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-01-18 23:44:55 -06:00
commit e4d3472ad3
8 changed files with 211 additions and 130 deletions

View File

@ -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"

View File

@ -12,10 +12,28 @@ IN: combinators.smart.tests
[ { 9 11 } [ + ] input<sequence ] must-infer
[ 20 ] [ { 9 11 } [ + ] input<sequence ] unit-test
[ 6 ] [ [ 1 2 3 ] [ + ] reduce-outputs ] unit-test
[ [ 1 2 3 ] [ + ] reduce-outputs ] must-infer
[ 6 ] [ [ 1 2 3 ] sum-outputs ] unit-test
[ "ab" ]
[
[ "a" "b" ] "" append-outputs-as
] unit-test
[ "" ]
[
[ ] "" append-outputs-as
] unit-test
[ { } ]
[
[ ] append-outputs
] unit-test
[ B{ 1 2 3 } ]
[
[ { 1 } { 2 } { 3 } ] B{ } append-outputs-as
] unit-test

View File

@ -20,3 +20,9 @@ MACRO: reduce-outputs ( quot operation -- newquot )
: sum-outputs ( quot -- n )
[ + ] reduce-outputs ; inline
MACRO: append-outputs-as ( quot exemplar -- newquot )
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
: append-outputs ( quot -- seq )
{ } append-outputs-as ; inline

View File

@ -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:"

View File

@ -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

View File

@ -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 ] <repetition> spread>quot ;
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline
: nappend ( n -- seq ) narray concat ; inline

View File

@ -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
<string-reader> [ "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

View File

@ -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, ;
<PRIVATE
: (>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 ;
<PRIVATE
CONSTANT: pack-table
H{
{ CHAR: c s8, }
{ CHAR: C u8, }
{ CHAR: s s16, }
{ CHAR: S u16, }
{ CHAR: t s24, }
{ CHAR: T u24, }
{ CHAR: i s32, }
{ CHAR: I u32, }
{ CHAR: q s64, }
{ CHAR: Q u64, }
{ CHAR: f float, }
{ CHAR: F float, }
{ CHAR: d double, }
{ CHAR: D double, }
{ CHAR: c s8>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<sequence ]
'[ _ B{ } append-outputs-as ] ;
PRIVATE>
: 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>
<PRIVATE
: start/end ( seq -- seq1 seq2 )
[ 0 [ + ] accumulate nip dup ] keep v+ ; inline
MACRO: unpack ( str -- quot )
[ unpack-table at 1quotation '[ @ , ] ] { } map-as concat
'[ [ _ { } make ] with-string-reader ] ;
[ [ ch>packed-length ] { } map-as start/end ]
[ [ unpack-table at '[ @ ] ] { } map-as ] bi
[ '[ [ _ _ ] dip <slice> @ ] ] 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 ;
<PRIVATE