steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into new_ui

db4
Slava Pestov 2009-01-19 14:16:25 -06:00
parent 0c1cf6209d e4d3472ad3
commit 0760d327d7
19 changed files with 332 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
basis/combinators/smart/smart-docs.factor
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"

22
basis/combinators/smart/smart-tests.factor
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

6
basis/combinators/smart/smart.factor
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

52
basis/generalizations/generalizations-docs.factor
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:"

9
basis/generalizations/generalizations-tests.factor
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

7
basis/generalizations/generalizations.factor
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

19
basis/pack/pack-tests.factor
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

190
basis/pack/pack.factor
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

1
basis/unix/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov
Eduardo Cavazos

1
basis/unix/unix.factor
View File

@ -1,4 +1,5 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel libc
sequences continuations byte-arrays strings math namespaces

7
core/assocs/assocs-docs.factor
View File

@ -115,6 +115,7 @@ $nl
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-filter }
{ $subsection assoc-filter-as }
{ $subsection assoc-contains? }
{ $subsection assoc-all? }
"Additional combinators:"
@ -232,6 +233,12 @@ HELP: assoc-filter
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
HELP: assoc-filter-as
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "exemplar" assoc } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "exemplar" } " consisting of all entries for which the predicate quotation yields true." } ;
{ assoc-filter assoc-filter-as } related-words
HELP: assoc-contains?
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;

4
core/byte-arrays/byte-arrays-docs.factor
View File

@ -30,6 +30,10 @@ HELP: <byte-array> ( n -- byte-array )
{ $values { "n" "a non-negative integer" } { "byte-array" "a new byte array" } }
{ $description "Creates a new byte array holding " { $snippet "n" } " bytes." } ;
HELP: (byte-array)
{ $values { "n" "a non-negative integer" } { "byte-array" "a new byte array" } }
{ $description "Creates a new byte array with unspecified contents of length " { $snippet "n" } " bytes." } ;
HELP: >byte-array
{ $values { "seq" "a sequence" } { "byte-array" byte-array } }
{ $description

6
core/math/math-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel sequences quotations
math.private ;
math.private byte-arrays io.binary ;
IN: math
HELP: number=
@ -306,6 +306,10 @@ HELP: find-last-integer
{ $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find-last } "." } ;
HELP: byte-array>bignum
{ $values { "byte-array" byte-array } { "n" integer } }
{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link >le } " or " { $link >be } " instead." } ;
ARTICLE: "division-by-zero" "Division by zero"
"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
$nl

46
core/sequences/sequences-docs.factor
View File

@ -679,12 +679,28 @@ HELP: append
}
} ;
HELP: append-as
{ $values { "seq1" sequence } { "seq2" sequence } { "exemplar" sequence } { "newseq" sequence } }
{ $description "Outputs a new sequence of the same type as " { $snippet "exemplar" } " consisting of the elements of " { $snippet "seq1" } " followed by " { $snippet "seq2" } "." }
{ $errors "Throws an error if " { $snippet "seq1" } " or " { $snippet "seq2" } " contain elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." }
{ $examples
{ $example "USING: prettyprint sequences ;"
"{ 1 2 } B{ 3 4 } B{ } append-as ."
"B{ 1 2 3 4 }"
}
{ $example "USING: prettyprint sequences strings ;"
"\"go\" \"ing\" SBUF\" \" append-as ."
"SBUF\" going\""
}
} ;
{ append append-as } related-words
HELP: prepend
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a new sequence of the same type as " { $snippet "seq2" } " consisting of the elements of " { $snippet "seq2" } " followed by " { $snippet "seq1" } "." }
{ $errors "Throws an error if " { $snippet "seq1" } " contains elements not permitted in sequences of the same class as " { $snippet "seq2" } "." }
{ $examples
{ $example "USING: prettyprint sequences ;"
{ $examples { $example "USING: prettyprint sequences ;"
"{ 1 2 } B{ 3 4 } prepend ."
"B{ 3 4 1 2 }"
}
@ -705,6 +721,19 @@ HELP: 3append
}
} ;
HELP: 3append-as
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "exemplar" sequence } { "newseq" sequence } }
{ $description "Outputs a new sequence consisting of the elements of " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } " in turn of the same type as " { $snippet "exemplar" } "." }
{ $errors "Throws an error if " { $snippet "seq1" } ", " { $snippet "seq2" } ", or " { $snippet "seq3" } " contain elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." }
{ $examples
{ $example "USING: prettyprint sequences ;"
"\"a\" \"b\" \"c\" SBUF\" \" 3append-as ."
"SBUF\" abc\""
}
} ;
{ 3append 3append-as } related-words
HELP: surround
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } }
{ $description "Outputs a new sequence with " { $snippet "seq1" } " inserted between " { $snippet "seq2" } " and " { $snippet "seq3" } "." }
@ -891,6 +920,16 @@ HELP: produce
{ $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] produce ." "{ 8 2 2 9 }" }
} ;
HELP: produce-as
{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "tail" "a quotation" } { "exemplar" sequence } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence of type " { $snippet "exemplar" } " at the end." }
{ $examples
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
{ $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] V{ } produce-as nip ." "V{ 668 334 167 83 41 20 10 5 2 1 0 }" }
"The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link produce } " call:"
{ $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] B{ } produce-as ." "B{ 8 2 2 9 }" }
} ;
HELP: sigma
{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
{ $description "Like map sum, but without creating an intermediate sequence." }
@ -1359,8 +1398,10 @@ ARTICLE: "sequences-reshape" "Reshaping sequences"
ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append }
{ $subsection append-as }
{ $subsection prepend }
{ $subsection 3append }
{ $subsection 3append-as }
{ $subsection surround }
{ $subsection glue }
{ $subsection concat }
@ -1417,6 +1458,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
{ $subsection map-index }
{ $subsection accumulate }
{ $subsection produce }
{ $subsection produce-as }
"Filtering:"
{ $subsection push-if }
{ $subsection filter }

3
misc/fuel/README
View File

@ -74,6 +74,9 @@ beast.
- C-cz : switch to listener
- C-co : cycle between code, tests and docs factor files
- C-cs : switch to other factor buffer (M-x fuel-switch-to-buffer)
- C-x4s : switch to other factor buffer in other window
- C-x5s : switch to other factor buffer in other frame
- M-. : edit word at point in Emacs (see fuel-edit-word-method custom var)
- M-, : go back to where M-. was last invoked

26
misc/fuel/fuel-edit.el
View File

@ -132,6 +132,32 @@ was last invoked."
(pop-tag-mark)
(error "No previous location for find word or vocab invokation")))
(defvar fuel-edit--buffer-history nil)
(defun fuel-switch-to-buffer (&optional method)
"Switch to any of the existing Factor buffers, with completion."
(interactive)
(let ((buffer (completing-read "Factor buffer: "
(remove (buffer-name)
(mapcar 'buffer-name (buffer-list)))
'(lambda (s) (string-match "\\.factor$" s))
t
nil
fuel-edit--buffer-history)))
(cond ((eq method 'window) (switch-to-buffer-other-window buffer))
((eq method 'frame) (switch-to-buffer-other-frame buffer))
(t (switch-to-buffer buffer)))))
(defun fuel-switch-to-buffer-other-window ()
"Switch to any of the existing Factor buffers, in other window."
(interactive)
(fuel-switch-to-buffer 'window))
(defun fuel-switch-to-buffer-other-frame ()
"Switch to any of the existing Factor buffers, in other frame."
(interactive)
(fuel-switch-to-buffer 'frame))
(provide 'fuel-edit)
;;; fuel-edit.el ends here

42
misc/fuel/fuel-font-lock.el
View File

@ -73,18 +73,20 @@
;;; Font lock:
(defun fuel-font-lock--syntactic-face (state)
(cond ((nth 3 state) 'factor-font-lock-string)
((char-equal (char-after (nth 8 state)) ?\ )
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
(cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name)
((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
'factor-font-lock-symbol)
(t 'default))))
((char-equal (char-after (nth 8 state)) ?U)
'factor-font-lock-parsing-word)
(t 'factor-font-lock-comment)))
(if (nth 3 state) 'factor-font-lock-string
(let ((c (char-after (nth 8 state))))
(cond ((char-equal c ?\ )
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
(cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name)
((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
'factor-font-lock-symbol)
(t 'default))))
((char-equal c ?U) 'factor-font-lock-parsing-word)
((char-equal c ?\() 'factor-font-lock-stack-effect)
((char-equal c ?\") 'factor-font-lock-string)
(t 'factor-font-lock-comment)))))
(defconst fuel-font-lock--font-lock-keywords
`((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
@ -135,16 +137,18 @@
;;; Fontify strings as Factor code:
(defvar fuel-font-lock--font-lock-buffer
(let ((buffer (get-buffer-create " *fuel font lock*")))
(set-buffer buffer)
(set-syntax-table fuel-syntax--syntax-table)
(fuel-font-lock--font-lock-setup)
buffer))
(defun fuel-font-lock--font-lock-buffer ()
(let ((name " *fuel font lock*"))
(or (get-buffer name)
(let ((buffer (get-buffer-create name)))
(set-buffer buffer)
(set-syntax-table fuel-syntax--syntax-table)
(fuel-font-lock--font-lock-setup)
buffer))))
(defun fuel-font-lock--factor-str (str)
(save-current-buffer
(set-buffer fuel-font-lock--font-lock-buffer)
(set-buffer (fuel-font-lock--font-lock-buffer))
(erase-buffer)
(insert str)
(let ((font-lock-verbose nil)) (font-lock-fontify-buffer))

3
misc/fuel/fuel-mode.el
View File

@ -177,6 +177,9 @@ interacting with a factor listener is at your disposal.
(fuel-mode--key-1 ?l 'fuel-run-file)
(fuel-mode--key-1 ?r 'fuel-eval-region)
(fuel-mode--key-1 ?z 'run-factor)
(fuel-mode--key-1 ?s 'fuel-switch-to-buffer)
(define-key fuel-mode-map "\C-x4s" 'fuel-switch-to-buffer-other-window)
(define-key fuel-mode-map "\C-x5s" 'fuel-switch-to-buffer-other-frame)
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)

7
misc/fuel/fuel-syntax.el
View File

@ -240,14 +240,15 @@
(defconst fuel-syntax--syntactic-keywords
`(;; CHARs:
("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
;; Comments:
("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">"))
("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
("\\_<\\((\\) \\([^)\n]*?\\) \\()\\)\\_>" (1 "<b") (2 "w") (3 ">b"))
;; Strings
("\\_<\\(\"\\)\\([^\n\r\f\"]\\|\\\\\"\\)*\\(\"\\)\\_>" (1 "\"") (3 "\""))
("\\_<<\\(\"\\)\\_>" (1 "\""))
("\\_<\\(\"\\)>\\_>" (1 "\""))
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
;; Multiline constructs
("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
("\\_<USING:\\( \\)" (1 "<b"))