! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra classes.algebra.private
-classes.private kernel make words ;
+classes.private kernel words ;
IN: classes.predicate
PREDICATE: predicate-class < class
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string quotations
+math kernel ;
+IN: combinators.short-circuit
+
+HELP: 0&&
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
+
+HELP: 0||
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- ? )" } } { "?" "the first true result, or " { $link f } } }
+{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ;
+
+HELP: 1&&
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
+
+HELP: 1||
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- ? )" } } { "?" "the first true result, or " { $link f } } }
+{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
+
+HELP: 2&&
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
+
+HELP: 2||
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- ? )" } } { "?" "the first true result, or " { $link f } } }
+{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
+
+HELP: 3&&
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
+
+HELP: 3||
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- ? )" } } { "?" "the first true result, or " { $link f } } }
+{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
+
+HELP: n&&
+{ $values
+ { "quots" "a sequence of quotations" } { "n" integer }
+ { "quot" quotation } }
+{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each quotation, evaluating the result in the same manner as " { $link 0&& } "." } ;
+
+HELP: n||
+{ $values
+ { "quots" "a sequence of quotations" } { "n" integer }
+ { "quot" quotation } }
+{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ;
+
+ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
+"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
+"AND combinators:"
+{ $subsections
+ 0&&
+ 1&&
+ 2&&
+ 3&&
+}
+"OR combinators:"
+{ $subsections
+ 0||
+ 1||
+ 2||
+ 3||
+}
+"Generalized combinators:"
+{ $subsections
+ n&&
+ n||
+}
+;
+
+ABOUT: "combinators.short-circuit"
--- /dev/null
+USING: accessors combinators.short-circuit kernel math
+tools.test ;
+IN: combinators.short-circuit.tests
+
+{ 3 } [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test
+{ 5 } [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& ] unit-test
+{ 30 } [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& ] unit-test
+
+{ f } [ { [ 1 ] [ f ] [ 3 ] } 0&& ] unit-test
+{ f } [ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] unit-test
+{ f } [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& ] unit-test
+
+{ "factor" } [ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| ] unit-test
+{ 11 } [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| ] unit-test
+{ 30 } [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| ] unit-test
+{ f } [ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] unit-test
+
+: compiled-&& ( a -- ? ) { [ 0 > ] [ even? ] [ 2 + ] } 1&& ;
+
+{ f } [ 3 compiled-&& ] unit-test
+{ 4 } [ 2 compiled-&& ] unit-test
+
+: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ;
+
+{ 30 } [ 10 20 compiled-|| ] unit-test
+{ 2 } [ 1 1 compiled-|| ] unit-test
+
+! && and || should be row-polymorphic both when compiled and when interpreted
+
+: row-&& ( -- ? )
+ f t { [ drop dup ] } 1&& nip ;
+
+{ f } [ row-&& ] unit-test
+{ f } [ \ row-&& def>> call ] unit-test
+
+: row-|| ( -- ? )
+ f t { [ drop dup ] } 1|| nip ;
+
+{ f } [ row-|| ] unit-test
+{ f } [ \ row-|| def>> call ] unit-test
--- /dev/null
+USING: arrays combinators fry generalizations kernel macros
+math sequences ;
+IN: combinators.short-circuit
+
+<PRIVATE
+
+MACRO: keeping ( n quot -- quot' )
+ swap dup 1 + '[ _ _ nkeep _ nrot ] ;
+
+PRIVATE>
+
+MACRO: n&& ( quots n -- quot )
+ [
+ [ [ f ] ] 2dip swap [
+ [ '[ drop _ _ keeping dup not ] ]
+ [ drop '[ drop _ ndrop f ] ]
+ 2bi 2array
+ ] with map
+ ] [ '[ _ nnip ] suffix 1array ] bi
+ [ cond ] 3append ;
+
+: 0&& ( quots -- ? ) 0 n&& ;
+: 1&& ( obj quots -- ? ) 1 n&& ;
+: 2&& ( obj1 obj2 quots -- ? ) 2 n&& ;
+: 3&& ( obj1 obj2 obj3 quots -- ? ) 3 n&& ;
+
+MACRO: n|| ( quots n -- quot )
+ [
+ [ [ f ] ] 2dip swap [
+ [ '[ drop _ _ keeping dup ] ]
+ [ drop '[ _ nnip ] ]
+ 2bi 2array
+ ] with map
+ ] [ '[ drop _ ndrop t ] [ f ] 2array suffix 1array ] bi
+ [ cond ] 3append ;
+
+: 0|| ( quots -- ? ) 0 n|| ;
+: 1|| ( obj quots -- ? ) 1 n|| ;
+: 2|| ( obj1 obj2 quots -- ? ) 2 n|| ;
+: 3|| ( obj1 obj2 obj3 quots -- ? ) 3 n|| ;
--- /dev/null
+Short-circuiting logical operations
--- /dev/null
+extensions
dup callable? [ ] [ [ call ] curry ] if ; inline
: [ncurry] ( n -- quot )
- [ V{ } clone ] dip (ncurry) >quotation ;
+ [ V{ dup callable? [ >quotation ] unless } clone ] dip (ncurry) >quotation ;
: [ndip] ( quot n -- quot' )
{
--- /dev/null
+Chris Double
+Doug Coleman
+Eduardo Cavazos
+Slava Pestov
--- /dev/null
+USING: help.syntax help.markup kernel sequences quotations
+math arrays combinators ;
+IN: generalizations
+
+HELP: nsum
+{ $values { "n" integer } }
+{ $description "Adds the top " { $snippet "n" } " stack values." } ;
+
+HELP: npick
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link dup } ", "
+{ $link over } " and " { $link pick } " that can work "
+"for any stack depth. The nth item down the stack will be copied and "
+"placed on the top of the stack."
+}
+{ $examples
+ { $example
+ "USING: kernel generalizations prettyprint"
+ "sequences.generalizations ;"
+ ""
+ "1 2 3 4 4 npick 5 narray ."
+ "{ 1 2 3 4 1 }"
+ }
+ "Some core words expressed in terms of " { $link npick } ":"
+ { $table
+ { { $link dup } { $snippet "1 npick" } }
+ { { $link over } { $snippet "2 npick" } }
+ { { $link pick } { $snippet "3 npick" } }
+ }
+} ;
+
+HELP: ndup
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link dup } ", "
+{ $link 2dup } " and " { $link 3dup } " that can work "
+"for any number of items. The n topmost items on the stack will be copied and "
+"placed on the top of the stack."
+}
+{ $examples
+ { $example
+ "USING: prettyprint generalizations kernel"
+ "sequences.generalizations ;"
+ ""
+ "1 2 3 4 4 ndup 8 narray ."
+ "{ 1 2 3 4 1 2 3 4 }"
+ }
+ "Some core words expressed in terms of " { $link ndup } ":"
+ { $table
+ { { $link dup } { $snippet "1 ndup" } }
+ { { $link 2dup } { $snippet "2 ndup" } }
+ { { $link 3dup } { $snippet "3 ndup" } }
+ }
+} ;
+
+HELP: dupn
+{ $values { "n" integer } }
+{ $description "Calls " { $link dup } " enough times that " { $snippet "n" } " references to the element at the top of the stack before " { $snippet "dupn" } " is called are on the top of the stack." }
+{ $notes { $snippet "2 dupn" } " is equivalent to " { $link dup } ". " { $snippet "1 dupn" } " is a no-op. " { $snippet "0 dupn" } " is equivalent to " { $link drop } "." } ;
+
+HELP: nnip
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link nip } " and " { $link 2nip }
+" that can work "
+"for any number of items."
+}
+{ $examples
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip ." "4" }
+ "Some core words expressed in terms of " { $link nnip } ":"
+ { $table
+ { { $link nip } { $snippet "1 nnip" } }
+ { { $link 2nip } { $snippet "2 nnip" } }
+ }
+} ;
+
+HELP: ndrop
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link drop }
+" that can work "
+"for any number of items."
+}
+{ $examples
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop ." "1" }
+ "Some core words expressed in terms of " { $link ndrop } ":"
+ { $table
+ { { $link drop } { $snippet "1 ndrop" } }
+ { { $link 2drop } { $snippet "2 ndrop" } }
+ { { $link 3drop } { $snippet "3 ndrop" } }
+ }
+} ;
+
+HELP: nrot
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link rot } " that works for any "
+"number of items on the stack."
+}
+{ $examples
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 nrot 4array ." "{ 2 3 4 1 }" }
+ "Some core words expressed in terms of " { $link nrot } ":"
+ { $table
+ { { $link swap } { $snippet "2 nrot" } }
+ { { $link rot } { $snippet "3 nrot" } }
+ }
+} ;
+
+HELP: -nrot
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link -rot } " that works for any "
+"number of items on the stack."
+}
+{ $examples
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 -nrot 4array ." "{ 4 1 2 3 }" }
+ "Some core words expressed in terms of " { $link -nrot } ":"
+ { $table
+ { { $link swap } { $snippet "2 -nrot" } }
+ { { $link -rot } { $snippet "3 -nrot" } }
+ }
+} ;
+
+HELP: ndip
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link dip } " that can work "
+"for any stack depth. The quotation will be called with a stack that "
+"has 'n' items removed first. The 'n' items are then put back on the "
+"stack. The quotation can consume and produce any number of items."
+}
+{ $examples
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip 3array ." "{ 1 1 2 }" }
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip 2array ." "{ 2 3 }" }
+ "Some core words expressed in terms of " { $link ndip } ":"
+ { $table
+ { { $link dip } { $snippet "1 ndip" } }
+ { { $link 2dip } { $snippet "2 ndip" } }
+ { { $link 3dip } { $snippet "3 ndip" } }
+ }
+} ;
+
+HELP: nkeep
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link keep } " that can work "
+"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
+"saved, the quotation called, and the items restored."
+}
+{ $examples
+ { $example
+ "USING: generalizations kernel prettyprint"
+ "sequences.generalizations ;"
+ ""
+ "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ."
+ "{ 99 1 2 3 4 5 }"
+ }
+ "Some core words expressed in terms of " { $link nkeep } ":"
+ { $table
+ { { $link keep } { $snippet "1 nkeep" } }
+ { { $link 2keep } { $snippet "2 nkeep" } }
+ { { $link 3keep } { $snippet "3 nkeep" } }
+ }
+} ;
+
+HELP: ncurry
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link curry } " that can work for any stack depth."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link ncurry } ":"
+ { $table
+ { { $link curry } { $snippet "1 ncurry" } }
+ { { $link 2curry } { $snippet "2 ncurry" } }
+ { { $link 3curry } { $snippet "3 ncurry" } }
+ }
+} ;
+
+HELP: nwith
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link with } " that can work for any stack depth."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link nwith } ":"
+ { $table
+ { { $link with } { $snippet "1 nwith" } }
+ }
+} ;
+
+HELP: napply
+{ $values { "quot" quotation } { "n" integer } }
+{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link napply } ":"
+ { $table
+ { { $link call } { $snippet "1 napply" } }
+ { { $link bi@ } { $snippet "2 napply" } }
+ { { $link tri@ } { $snippet "3 napply" } }
+ }
+} ;
+
+HELP: ncleave
+{ $values { "quots" "a sequence of quotations" } { "n" integer } }
+{ $description "A generalization of " { $link cleave } " and " { $link 2cleave } " that can work for any quotation arity."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link ncleave } ":"
+ { $table
+ { { $link cleave } { $snippet "1 ncleave" } }
+ { { $link 2cleave } { $snippet "2 ncleave" } }
+ }
+} ;
+
+HELP: nspread
+{ $values { "quots" "a sequence of quotations" } { "n" integer } }
+{ $description "A generalization of " { $link spread } " that can work for any quotation arity."
+} ;
+
+HELP: cleave*
+{ $values { "n" integer } }
+{ $description "Like " { $link cleave } ", but instead of taking a single array of quotations, cleaves using quotations taken from the top " { $snippet "n" } " elements of the datastack." }
+{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi" } " or " { $snippet "tri-curry@ tri" } " dataflow patterns." } ;
+
+HELP: spread*
+{ $values { "n" integer } }
+{ $description "Like " { $link spread } ", but instead of taking a single array of quotations, spreads using quotations taken from the top " { $snippet "n" } " elements of the datastack." }
+{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi*" } " or " { $snippet "tri-curry@ tri*" } " dataflow patterns." } ;
+
+HELP: apply-curry
+{ $values { "a..." { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } }
+{ $description "Curries each of the top " { $snippet "n" } " items of the datastack onto " { $snippet "quot" } ", leaving " { $snippet "n" } " quotations on the datastack. A generalization of " { $link bi-curry@ } " and " { $link tri-curry@ } "." }
+{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry@ bi" } ", " { $snippet "tri-curry@ tri" } ", " { $snippet "bi-curry@ bi*" } ", and " { $snippet "tri-curry@ tri*" } "." } ;
+
+HELP: cleave-curry
+{ $values { "a" object } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }
+{ $description "Curries " { $snippet "a" } " onto the " { $snippet "n" } " quotations on the top of the datastack. A generalization of " { $link bi-curry } " and " { $link tri-curry } "." }
+{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry bi" } ", " { $snippet "tri-curry tri" } ", " { $snippet "bi-curry bi*" } ", and " { $snippet "tri-curry tri*" } "." } ;
+
+HELP: spread-curry
+{ $values { "a..." { $snippet "n" } " objects on the datastack" } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }
+{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." }
+{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ;
+
+HELP: mnswap
+{ $values { "m" integer } { "n" integer } }
+{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
+{ $examples
+ "Some core words expressed in terms of " { $link mnswap } ":"
+ { $table
+ { { $link swap } { $snippet "1 1 mnswap" } }
+ { { $link rot } { $snippet "2 1 mnswap" } }
+ { { $link -rot } { $snippet "1 2 mnswap" } }
+ }
+} ;
+
+HELP: nweave
+{ $values { "n" integer } }
+{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." }
+{ $examples
+ { $example
+ "USING: arrays kernel generalizations prettyprint ;"
+ "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ."
+ "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }"
+ }
+} ;
+
+HELP: n*quot
+{ $values
+ { "n" integer } { "quot" quotation }
+ { "quotquot" quotation }
+}
+{ $examples
+ { $example "USING: generalizations prettyprint math ;"
+ "3 [ + ] n*quot ."
+ "[ + + + ]"
+ }
+}
+{ $description "Construct a quotation containing the contents of " { $snippet "seq" } " repeated " { $snippet "n" } " times." } ;
+
+ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
+{ $subsections
+ ndup
+ dupn
+ npick
+ nrot
+ -nrot
+ nnip
+ ndrop
+ mnswap
+ nweave
+} ;
+
+ARTICLE: "combinator-generalizations" "Generalized combinators"
+{ $subsections
+ ndip
+ nkeep
+ napply
+ ncleave
+ nspread
+ cleave*
+ spread*
+ apply-curry
+ cleave-curry
+ spread-curry
+} ;
+
+ARTICLE: "other-generalizations" "Additional generalizations"
+{ $subsections
+ ncurry
+ nwith
+ nsum
+} ;
+
+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 "
+"input parameter."
+{ $subsections
+ "shuffle-generalizations"
+ "combinator-generalizations"
+ "other-generalizations"
+}
+"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence operations." ;
+
+ABOUT: "generalizations"
--- /dev/null
+USING: tools.test generalizations kernel math arrays sequences
+ascii fry math.parser io io.streams.string ;
+IN: generalizations.tests
+
+{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test
+{ 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 2 3 4 0 npick ] [ nonpositive-npick? ] must-fail-with
+[ 1 2 3 4 -11 npick ] [ nonpositive-npick? ] must-fail-with
+
+[ 1 1 ndup ] must-infer
+{ 1 1 } [ 1 1 ndup ] unit-test
+{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test
+{ 1 2 3 1 2 3 } [ 1 2 3 3 ndup ] unit-test
+{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4 ndup ] unit-test
+[ 1 2 2 nrot ] must-infer
+{ 2 1 } [ 1 2 2 nrot ] unit-test
+{ 2 3 1 } [ 1 2 3 3 nrot ] unit-test
+{ 2 3 4 1 } [ 1 2 3 4 4 nrot ] unit-test
+[ 1 2 2 -nrot ] must-infer
+{ 2 1 } [ 1 2 2 -nrot ] unit-test
+{ 3 1 2 } [ 1 2 3 3 -nrot ] unit-test
+{ 4 1 2 3 } [ 1 2 3 4 4 -nrot ] unit-test
+[ 1 2 3 4 3 nnip ] must-infer
+{ 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
+
+[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
+[ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer
+{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
+{ 2 1 2 3 4 5 } [ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] unit-test
+{ [ 1 2 3 + ] } [ 1 2 3 [ + ] 3 ncurry ] unit-test
+
+{ "HELLO" } [ "hello" [ >upper ] 1 napply ] unit-test
+{ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } } [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
+[ [ dup 2^ 2array ] 5 napply ] must-infer
+
+{ { "xyc" "xyd" } } [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
+
+{ 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
+
+{ 17 } [ 3 1 3 3 7 5 nsum ] unit-test
+{ 4 1 } [ 4 nsum ] must-infer-as
+
+{ "e1" "o1" "o2" "e2" "o1" "o2" } [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test
+{ 3 5 } [ 2 nweave ] must-infer-as
+
+{ { 0 1 2 } { 3 5 4 } { 7 8 6 } }
+[ 9 [ ] each-integer { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
+
+{ 1 2 3 4 1 2 3 } [ 1 2 3 4 3 nover ] unit-test
+
+{ [ 1 2 3 ] [ 1 2 3 ] }
+[ 1 2 3 [ ] [ ] 3 nbi-curry ] unit-test
+
+{ 15 3 } [ 1 2 3 4 5 [ + + + + ] [ - - - - ] 5 nbi ] unit-test
+
+: nover-test ( -- a b c d e f g )
+ 1 2 3 4 3 nover ;
+
+{ 1 2 3 4 1 2 3 } [ nover-test ] unit-test
+
+[ '[ number>string _ append ] 4 napply ] must-infer
+
+{ 6 8 10 12 } [
+ 1 2 3 4
+ 5 6 7 8 [ + ] 4 apply-curry 4 spread*
+] unit-test
+
+{ 6 } [ 5 [ 1 + ] 1 spread* ] unit-test
+{ 6 } [ 5 [ 1 + ] 1 cleave* ] unit-test
+{ 6 } [ 5 [ 1 + ] 1 napply ] unit-test
+
+{ 6 } [ 6 0 spread* ] unit-test
+{ 6 } [ 6 0 cleave* ] unit-test
+{ 6 } [ 6 [ 1 + ] 0 napply ] unit-test
+
+{ 6 7 8 9 } [
+ 1
+ 5 6 7 8 [ + ] 4 apply-curry 4 cleave*
+] unit-test
+
+{ 8 3 8 3/2 } [
+ 6 5 4 3
+ 2 [ + ] [ - ] [ * ] [ / ] 4 cleave-curry 4 spread*
+] unit-test
+
+{ 8 4 0 -3 } [
+ 6 5 4 3
+ 2 1 0 -1 [ + ] [ - ] [ * ] [ / ] 4 spread-curry 4 spread*
+] unit-test
+
+{ { 1 2 } { 3 4 } { 5 6 } }
+[ 1 2 3 4 5 6 [ 2array ] 2 3 mnapply ] unit-test
+
+{ 1 4 9 16 }
+[ 1 1 2 2 3 3 4 4 [ * ] 2 4 mnapply ] unit-test
+
+{ 1 8 27 64 125 }
+[ 1 1 1 2 2 2 3 3 3 4 4 4 5 5 5 [ * * ] 3 5 mnapply ] unit-test
+
+{ { 1 2 3 } { 4 5 6 } }
+[ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test
+
+{ { 1 2 3 } { 4 5 6 } }
+[ 1 2 3 4 5 6 [ 3array ] [ 3array ] 3 2 nspread* ] unit-test
+
+{ }
+[ [ 2array ] 2 0 mnapply ] unit-test
+
+{ }
+[ 2 0 nspread* ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo
+! Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel kernel.private sequences sequences.private math
+combinators macros math.order math.ranges quotations fry effects
+memoize.private arrays ;
+IN: generalizations
+
+! These words can be inline combinators the word does no math on
+! the input parameters, e.g. n.
+! If math is done, the word needs to be a macro so the math can
+! be done at compile-time.
+<<
+
+ALIAS: n*quot (n*quot)
+
+MACRO: call-n ( n -- quot )
+ [ call ] <repetition> '[ _ cleave ] ;
+
+: repeat ( n obj quot -- ) swapd times ; inline
+
+>>
+
+MACRO: nsum ( n -- quot )
+ 1 - [ + ] n*quot ;
+
+ERROR: nonpositive-npick n ;
+
+MACRO: npick ( n -- quot )
+ {
+ { [ dup 0 <= ] [ nonpositive-npick ] }
+ { [ dup 1 = ] [ drop [ dup ] ] }
+ [ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ]
+ } cond ;
+
+MACRO: nover ( n -- quot )
+ dup 1 + '[ _ npick ] n*quot ;
+
+: ndup ( n -- )
+ [ '[ _ npick ] ] keep call-n ; inline
+
+MACRO: dupn ( n -- quot )
+ [ [ drop ] ]
+ [ 1 - [ dup ] n*quot ] if-zero ;
+
+MACRO: nrot ( n -- quot )
+ 1 - [ ] [ '[ _ dip swap ] ] repeat ;
+
+MACRO: -nrot ( n -- quot )
+ 1 - [ ] [ '[ swap _ dip ] ] repeat ;
+
+: ndrop ( n -- )
+ [ drop ] swap call-n ; inline
+
+: nnip ( n -- )
+ '[ _ ndrop ] dip ; inline
+
+: ndip ( n -- )
+ [ [ dip ] curry ] swap call-n call ; inline
+
+: nkeep ( n -- )
+ dup '[ [ _ ndup ] dip _ ndip ] call ; inline
+
+: ncurry ( n -- )
+ [ curry ] swap call-n ; inline
+
+: nwith ( n -- )
+ [ with ] swap call-n ; inline
+
+: nbi ( quot1 quot2 n -- )
+ [ nip nkeep ] [ drop nip call ] 3bi ; inline
+
+MACRO: ncleave ( quots n -- quot )
+ [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
+ compose ;
+
+MACRO: nspread ( quots n -- quot )
+ over empty? [ 2drop [ ] ] [
+ [ [ but-last ] dip ]
+ [ [ last ] dip ] 2bi
+ swap
+ '[ [ _ _ nspread ] _ ndip @ ]
+ ] if ;
+
+MACRO: spread* ( n -- quot )
+ [ [ ] ] [
+ [1,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as
+ [ call ] compose
+ ] if-zero ;
+
+MACRO: nspread* ( m n -- quot )
+ [ drop [ ] ] [
+ [ * 0 ] [ drop neg ] 2bi
+ <range> rest >array dup length <iota> <reversed>
+ [ '[ [ [ _ ndip ] curry ] _ ndip ] ] 2map
+ [ [ ] concat-as ]
+ [ length 1 - [ compose ] <array> concat append ] bi
+ [ call ] compose
+ ] if-zero ;
+
+MACRO: cleave* ( n -- quot )
+ [ [ ] ]
+ [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
+ if-zero ;
+
+: napply ( quot n -- )
+ [ dupn ] [ spread* ] bi ; inline
+
+: mnapply ( quot m n -- )
+ [ nip dupn ] [ nspread* ] 2bi ; inline
+
+: apply-curry ( a... quot n -- )
+ [ currier ] dip napply ; inline
+
+: cleave-curry ( a quot... n -- )
+ [ currier ] swap [ napply ] [ cleave* ] bi ; inline
+
+: spread-curry ( a... quot... n -- )
+ [ currier ] swap [ napply ] [ spread* ] bi ; inline
+
+MACRO: mnswap ( m n -- quot )
+ 1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
+
+MACRO: nweave ( n -- quot )
+ [ dup <iota> <reversed> [ '[ _ _ mnswap ] ] with map ] keep
+ '[ _ _ ncleave ] ;
+
+: nbi-curry ( n -- )
+ [ bi-curry ] swap call-n ; inline
+
+MACRO: map-compose ( quots quot -- quot' )
+ '[ _ compose ] map '[ _ ] ;
--- /dev/null
+Generalized stack shufflers and combinators to arbitrary numbers of inputs
--- /dev/null
+! Copyright (C) 2010 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs hashtables.identity kernel literals tools.test ;
+IN: hashtables.identity.tests
+
+CONSTANT: the-real-slim-shady "marshall mathers"
+
+CONSTANT: will
+ IH{
+ { $ the-real-slim-shady t }
+ { "marshall mathers" f }
+ }
+
+: please-stand-up ( assoc key -- value )
+ of ;
+
+{ t } [ will the-real-slim-shady please-stand-up ] unit-test
+{ t } [ will clone the-real-slim-shady please-stand-up ] unit-test
+
+{ 2 } [ will assoc-size ] unit-test
+{ { { "marshall mathers" f } } } [
+ the-real-slim-shady will clone
+ [ delete-at ] [ >alist ] bi
+] unit-test
+{ t } [
+ t the-real-slim-shady identity-associate
+ t the-real-slim-shady identity-associate =
+] unit-test
+{ f } [
+ t the-real-slim-shady identity-associate
+ t "marshall mathers" identity-associate =
+] unit-test
+
+CONSTANT: same-as-it-ever-was "same as it ever was"
+
+{ IH{ { $ same-as-it-ever-was $ same-as-it-ever-was } } }
+[ H{ { $ same-as-it-ever-was $ same-as-it-ever-was } } IH{ } assoc-like ] unit-test
--- /dev/null
+! Copyright (C) 2010 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs hashtables hashtables.wrapped kernel
+parser vocabs.loader ;
+IN: hashtables.identity
+
+<PRIVATE
+
+TUPLE: identity-wrapper
+ { underlying read-only } identity-hashcode ;
+
+: <identity-wrapper> ( wrapped-key -- identity-wrapper )
+ dup identity-hashcode identity-wrapper boa ; inline
+
+M: identity-wrapper equal?
+ over identity-wrapper?
+ [ [ underlying>> ] bi@ eq? ]
+ [ 2drop f ] if ; inline
+
+M: identity-wrapper hashcode* nip identity-hashcode>> ; inline
+
+PRIVATE>
+
+TUPLE: identity-hashtable < wrapped-hashtable ;
+
+: <identity-hashtable> ( n -- ihashtable )
+ <hashtable> identity-hashtable boa ; inline
+
+M: identity-hashtable wrap-key drop <identity-wrapper> ;
+
+M: identity-hashtable clone
+ underlying>> clone identity-hashtable boa ; inline
+
+: identity-associate ( value key -- ihashtable )
+ 2 <identity-hashtable> [ set-at ] keep ; inline
+
+: >identity-hashtable ( assoc -- ihashtable )
+ [ assoc-size <identity-hashtable> ] keep assoc-union! ;
+
+M: identity-hashtable assoc-like
+ drop dup identity-hashtable? [ >identity-hashtable ] unless ; inline
+
+M: identity-hashtable new-assoc drop <identity-hashtable> ;
+
+{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when
+{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when
--- /dev/null
+Hashtables keyed by object identity (eq?) rather than by logical value (=)\r
--- /dev/null
+collections
--- /dev/null
+John Benediktsson
--- /dev/null
+collections
--- /dev/null
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays assocs hashtables kernel sequences
+vocabs.loader ;
+IN: hashtables.wrapped
+
+TUPLE: wrapped-hashtable
+ { underlying hashtable read-only } ;
+
+GENERIC: wrap-key ( key wrapped-hash -- wrapped-key )
+
+<PRIVATE
+
+: wrapper@ ( key wrapped-hash -- wrapped-key hash )
+ [ wrap-key ] [ nip underlying>> ] 2bi ; inline
+
+PRIVATE>
+
+M: wrapped-hashtable at*
+ wrapper@ at* ; inline
+
+M: wrapped-hashtable clear-assoc
+ underlying>> clear-assoc ; inline
+
+M: wrapped-hashtable delete-at
+ wrapper@ delete-at ; inline
+
+M: wrapped-hashtable assoc-size
+ underlying>> assoc-size ; inline
+
+M: wrapped-hashtable set-at
+ wrapper@ set-at ; inline
+
+M: wrapped-hashtable >alist
+ underlying>> >alist [
+ [ 0 swap [ underlying>> ] change-nth ] each
+ ] keep ;
+
+M: wrapped-hashtable keys
+ underlying>> keys [ underlying>> ] map! ;
+
+M: wrapped-hashtable values
+ underlying>> values ;
+
+M: wrapped-hashtable equal?
+ over wrapped-hashtable? [ [ underlying>> ] same? ] [ 2drop f ] if ;
+
+INSTANCE: wrapped-hashtable assoc
+
+{ "hashtables.wrapped" "prettyprint" } "hashtables.wrapped.prettyprint" require-when
ERROR: unexpected want got ;
-: forbid-tab ( c -- c )
- [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; inline
-
-: skip ( i seq ? -- n )
- over length [
- [ swap forbid-tab CHAR: \s eq? xor ] curry find-from drop
- ] dip or ; inline
-
: change-lexer-column ( ..a lexer quot: ( ..a col line -- ..b newcol ) -- ..b )
[ lexer check-instance [ column>> ] [ line-text>> ] bi ] prepose
keep column<< ; inline
-GENERIC: skip-blank ( lexer -- )
-
<PRIVATE
: shebang? ( lexer -- lexer ? )
] [ f ] if
] [ f ] if ; inline
+: forbid-tab ( c -- c )
+ [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; inline
+
PRIVATE>
+SBUF""
+URL"google.com"
+
+GENERIC: skip-blank ( lexer -- )
+
M: lexer skip-blank
shebang? [
[ nip length ] change-lexer-column
] [
- [ t skip ] change-lexer-column
+ [
+ [ [ forbid-tab CHAR: \s eq? not ] find-from drop ]
+ [ length or ] bi
+ ] change-lexer-column
] if ;
GENERIC: skip-word ( lexer -- )
M: lexer skip-word
[
- 2dup nth CHAR: \" eq? [ drop 1 + ] [ f skip ] if
+ [ [ forbid-tab " \"" member-eq? ] find-from CHAR: \" eq? [ 1 + ] when ]
+ [ length or ] bi
] change-lexer-column ;
: still-parsing? ( lexer -- ? )
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: locals.backend.tests
+USING: tools.test locals.backend kernel arrays accessors ;
+
+: get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
+
+\ get-local-test-1 def>> must-infer
+
+{ 3 } [ get-local-test-1 ] unit-test
+
+: get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ;
+
+\ get-local-test-2 def>> must-infer
+
+{ 3 } [ get-local-test-2 ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slots.private ;
+IN: locals.backend
+
+PRIMITIVE: drop-locals ( n -- )
+PRIMITIVE: get-local ( n -- obj )
+PRIMITIVE: load-local ( obj -- )
+PRIMITIVE: load-locals ( ... n -- )
+
+: local-value ( box -- value ) 2 slot ; inline
+
+: set-local-value ( value box -- ) 2 set-slot ; inline
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel summary ;
+IN: locals.errors
+
+ERROR: >r/r>-in-lambda-error ;
+
+M: >r/r>-in-lambda-error summary
+ drop
+ "Explicit retain stack manipulation is not permitted in lambda bodies" ;
+
+ERROR: let-form-in-literal-error ;
+
+M: let-form-in-literal-error summary
+ drop "[let not permitted inside literals" ;
+
+ERROR: local-writer-in-literal-error ;
+
+M: local-writer-in-literal-error summary
+ drop "Local writer words not permitted inside literals" ;
+
+ERROR: :>-outside-lambda-error ;
+
+M: :>-outside-lambda-error summary
+ drop ":> cannot be used outside of [let, [|, or :: forms" ;
+
+ERROR: bad-local args obj ;
+
+M: bad-local summary
+ drop "You have found a bug in locals. Please report." ;
+
+ERROR: bad-rewrite args obj ;
+
+M: bad-rewrite summary
+ drop "You have found a bug in locals. Please report." ;
--- /dev/null
+Errors thrown by locals implementation
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry fry.private generalizations kernel
+locals.types sequences ;
+IN: locals.fry
+
+! Support for mixing locals with fry
+
+M: let count-inputs body>> count-inputs ;
+M: lambda count-inputs body>> count-inputs ;
+
+M: lambda fry
+ clone [ [ count-inputs ] [ fry ] bi ] change-body
+ [ [ vars>> length ] keep '[ _ _ mnswap _ call ] ]
+ [ drop [ncurry] curry [ call ] compose ] 2bi ;
+
+M: let fry
+ clone [ fry ] change-body ;
+
+INSTANCE: lambda fried
+INSTANCE: let fried
--- /dev/null
+Support for mixing fry and locals
--- /dev/null
+USING: help.syntax help.markup kernel macros prettyprint
+memoize combinators arrays generalizations see ;
+IN: locals
+
+HELP: [|
+{ $syntax "[| bindings... | body... ]" }
+{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." }
+{ $examples "See " { $link "locals-examples" } "." } ;
+
+HELP: [let
+{ $syntax "[let code :> var code :> var code... ]" }
+{ $description "Establishes a new scope for lexical variable bindings. Variables bound with " { $link POSTPONE: :> } " within the body of the " { $snippet "[let" } " will be lexically scoped to the body of the " { $snippet "[let" } " form." }
+{ $examples "See " { $link "locals-examples" } "." } ;
+
+HELP: :>
+{ $syntax ":> var" ":> var!" ":> ( var-1 var-2 ... )" }
+{ $description "Binds one or more new lexical variables. In the " { $snippet ":> var" } " form, the value on the top of the datastack is bound to a new lexical variable named " { $snippet "var" } " and is scoped to the enclosing quotation, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: :: } " definition."
+$nl
+"The " { $snippet ":> ( var-1 ... )" } " form binds multiple variables to the top values of the datastack in right to left order, with the last variable bound to the top of the datastack. These two snippets have the same effect:"
+{ $code ":> c :> b :> a" }
+{ $code ":> ( a b c )" }
+$nl
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information." }
+{ $notes
+ "This syntax can only be used inside a lexical scope established by a " { $link POSTPONE: :: } " definition, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: [| } " quotation. Normal quotations have their own lexical scope only if they are inside an outer scope. Definition forms such as " { $link POSTPONE: : } " do not establish a lexical scope by themselves unless documented otherwise, nor is there a lexical scope available at the top level of source files or in the listener. " { $link POSTPONE: [let } " can be used to create a lexical scope where one is not otherwise available." }
+{ $examples "See " { $link "locals-examples" } "." } ;
+
+{ POSTPONE: [let POSTPONE: :> } related-words
+
+HELP: ::
+{ $syntax ":: word ( vars... -- outputs... ) body... ;" }
+{ $description "Defines a word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
+$nl
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
+{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: : } " definitions." }
+{ $examples "See " { $link "locals-examples" } "." } ;
+
+{ POSTPONE: : POSTPONE: :: } related-words
+
+HELP: MACRO::
+{ $syntax "MACRO:: word ( vars... -- outputs... ) body... ;" }
+{ $description "Defines a macro with named inputs. The macro binds its input variables to lexical variables from left to right, then executes the body with those bindings in scope."
+$nl
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
+{ $notes "The expansion of a macro cannot reference lexical variables bound in the outer scope. There are also limitations on passing arguments involving lexical variables into macros. See " { $link "locals-limitations" } " for details." }
+{ $examples "See " { $link "locals-examples" } "." } ;
+
+{ POSTPONE: MACRO: POSTPONE: MACRO:: } related-words
+
+HELP: MEMO::
+{ $syntax "MEMO:: word ( vars... -- outputs... ) body... ;" }
+{ $description "Defines a memoized word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
+$nl
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
+{ $examples "See " { $link "locals-examples" } "." } ;
+
+{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
+
+HELP: M::
+{ $syntax "M:: class generic ( vars... -- outputs... ) body... ;" }
+{ $description "Defines a new method on " { $snippet "generic" } " for " { $snippet "class" } " with named inputs. The method binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
+$nl
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
+{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: M: } " definitions." }
+{ $examples "See " { $link "locals-examples" } "." } ;
+
+{ POSTPONE: M: POSTPONE: M:: } related-words
+
+ARTICLE: "locals-examples" "Examples of lexical variables"
+{ $heading "Definitions with lexical variables" }
+"The following example demonstrates lexical variable bindings in word definitions. The " { $snippet "quadratic-roots" } " word is defined with " { $link POSTPONE: :: } ", so it takes its inputs from the top three elements of the datastack and binds them to the variables " { $snippet "a" } ", " { $snippet "b" } ", and " { $snippet "c" } ". In the body, the " { $snippet "disc" } " variable is bound using " { $link POSTPONE: :> } " and then used in the following line of code."
+{ $example "USING: locals math math.functions kernel ;
+IN: scratchpad
+:: quadratic-roots ( a b c -- x y )
+ b sq 4 a c * * - sqrt :> disc
+ b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ;
+1.0 1.0 -6.0 quadratic-roots"
+"\n--- Data stack:\n2.0\n-3.0"
+}
+"If you wanted to perform the quadratic formula interactively from the listener, you could use " { $link POSTPONE: [let } " to provide a scope for the variables:"
+{ $example "USING: locals math math.functions kernel ;
+IN: scratchpad
+[let 1.0 :> a 1.0 :> b -6.0 :> c
+ b sq 4 a c * * - sqrt :> disc
+ b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@
+]"
+"\n--- Data stack:\n2.0\n-3.0"
+}
+
+$nl
+
+{ $heading "Quotations with lexical variables, and closures" }
+"These next two examples demonstrate lexical variable bindings in quotations defined with " { $link POSTPONE: [| } ". In this example, the values " { $snippet "5" } " and " { $snippet "3" } " are put on the datastack. When the quotation is called, it takes those values as inputs and binds them respectively to " { $snippet "m" } " and " { $snippet "n" } " before executing the quotation:"
+{ $example
+ "USING: kernel locals math ;"
+ "IN: scratchpad"
+ "5 3 [| m n | m n - ] call( x x -- x )"
+ "\n--- Data stack:\n2"
+}
+$nl
+
+"In this example, the " { $snippet "adder" } " word creates a quotation that closes over its argument " { $snippet "n" } ". When called, the result quotation of " { $snippet "5 adder" } " pulls " { $snippet "3" } " off the datastack and binds it to " { $snippet "m" } ", which is added to the value " { $snippet "5" } " bound to " { $snippet "n" } " in the outer scope of " { $snippet "adder" } ":"
+{ $example
+ "USING: kernel locals math ;"
+ "IN: scratchpad"
+ ":: adder ( n -- quot ) [| m | m n + ] ;"
+ "3 5 adder call( x -- x )"
+ "\n--- Data stack:\n8"
+}
+$nl
+
+{ $heading "Mutable bindings" }
+"This next example demonstrates closures and mutable variable bindings. The " { $snippet "<counter>" } " word outputs a tuple containing a pair of quotations that respectively increment and decrement an internal counter in the mutable " { $snippet "value" } " variable and then return the new value. The quotations close over the counter, so each invocation of the word gives new quotations with a new internal counter."
+{ $example
+"USING: accessors locals kernel math ;
+IN: scratchpad
+
+TUPLE: counter adder subtractor ;
+
+:: <counter> ( -- counter )
+ 0 :> value!
+ counter new
+ [ value 1 + dup value! ] >>adder
+ [ value 1 - dup value! ] >>subtractor ;
+<counter>
+[ adder>> call( -- x ) ]
+[ adder>> call( -- x ) ]
+[ subtractor>> call( -- x ) ] tri"
+"\n--- Data stack:\n1\n2\n1"
+}
+ $nl
+ "The same variable name can be bound multiple times in the same scope. This is different from reassigning the value of a mutable variable. The most recent binding for a variable name will mask previous bindings for that name. However, the old binding referring to the previous value can still persist in closures. The following contrived example demonstrates this:"
+ { $example
+"USING: kernel locals ;
+IN: scratchpad
+:: rebinding-example ( -- quot1 quot2 )
+ 5 :> a [ a ]
+ 6 :> a [ a ] ;
+:: mutable-example ( -- quot1 quot2 )
+ 5 :> a! [ a ]
+ 6 a! [ a ] ;
+rebinding-example [ call( -- x ) ] bi@
+mutable-example [ call( -- x ) ] bi@"
+"\n--- Data stack:\n5\n6\n6\n6"
+}
+ "In " { $snippet "rebinding-example" } ", the binding of " { $snippet "a" } " to " { $snippet "5" } " is closed over in the first quotation, and the binding of " { $snippet "a" } " to " { $snippet "6" } " is closed over in the second, so calling both quotations results in " { $snippet "5" } " and " { $snippet "6" } " respectively. By contrast, in " { $snippet "mutable-example" } ", both quotations close over a single binding of " { $snippet "a" } ". Even though " { $snippet "a" } " is assigned to " { $snippet "6" } " after the first quotation is made, calling either quotation will output the new value of " { $snippet "a" } "."
+{ $heading "Lexical variables in literals" }
+"Some kinds of literals can include references to lexical variables as described in " { $link "locals-literals" } ". For example, the " { $link 3array } " word could be implemented as follows:"
+{ $example
+"USING: locals ;
+IN: scratchpad
+
+:: my-3array ( x y z -- array ) { x y z } ;
+1 \"two\" 3.0 my-3array"
+"\n--- Data stack:\n{ 1 \"two\" 3.0 }"
+} ;
+
+ARTICLE: "locals-literals" "Lexical variables in literals"
+"Certain data type literals are permitted to contain lexical variables. Any such literals are rewritten into code which constructs an instance of the type with the values of the variables spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
+$nl
+"The data types which receive this special handling are the following:"
+{ $list
+ { $link "arrays" }
+ { $link "hashtables" }
+ { $link "vectors" }
+ { $link "tuples" }
+ { $link "wrappers" }
+}
+{ $heading "Object identity" }
+"This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:"
+{ $example
+ "USING: kernel ;"
+ "IN: scratchpad"
+ "TUPLE: person first-name last-name ;"
+ ": ordinary-word-test ( -- tuple )"
+ " T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
+ "ordinary-word-test ordinary-word-test eq?"
+ "\n--- Data stack:\nt"
+}
+"Inside a lexical scope, literals which do not contain lexical variables still behave in the same way:"
+{ $example
+ "USING: kernel locals ;"
+ "IN: scratchpad"
+ "TUPLE: person first-name last-name ;"
+ ":: locals-word-test ( -- tuple )"
+ " T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
+ "locals-word-test locals-word-test eq?"
+ "\n--- Data stack:\nt"
+}
+"However, literals with lexical variables in them actually construct a new object:"
+{ $example
+ "USING: locals kernel splitting ;"
+ "IN: scratchpad"
+ "TUPLE: person first-name last-name ;"
+ ":: constructor-test ( -- tuple )"
+ " \"Jane Smith\" \" \" split1 :> last :> first"
+ " T{ person { first-name first } { last-name last } } ;"
+ "constructor-test constructor-test eq?"
+ "\n--- Data stack:\nf"
+}
+"One exception to the above rule is that array instances containing free lexical variables (that is, immutable lexical variables not referenced in a closure) do retain identity. This allows macros such as " { $link cond } " to expand at compile time even when their arguments reference variables." ;
+
+ARTICLE: "locals-mutable" "Mutable lexical variables"
+"When a lexical variable is bound using " { $link POSTPONE: :> } ", " { $link POSTPONE: :: } ", or " { $link POSTPONE: [| } ", the variable may be made mutable by suffixing its name with an exclamation point (" { $snippet "!" } "). A mutable variable's value is read by giving its name without the exclamation point as usual. To write to the variable, use its name with the " { $snippet "!" } " suffix."
+$nl
+"Mutable bindings are implemented in a manner similar to that taken by the ML language. Each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it."
+$nl
+"Writing to mutable variables from outer lexical scopes is fully supported and has full closure semantics. See " { $link "locals-examples" } " for examples of mutable lexical variables in action." ;
+
+ARTICLE: "locals-fry" "Lexical variables and fry"
+"Lexical variables integrate with " { $link "fry" } " so that mixing variables with fried quotations gives intuitive results."
+$nl
+"The following two code snippets are equivalent:"
+{ $code "'[ sq _ + ]" }
+{ $code "[ [ sq ] dip + ] curry" }
+"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as “inserted” in the “hole” in the quotation's second element."
+$nl
+"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
+{ $code "3 [ - ] curry" }
+{ $code "[ 3 - ]" }
+"When quotations take named parameters using " { $link POSTPONE: [| } ", " { $link curry } " fills in the variable bindings from right to left. The following two snippets are equivalent:"
+{ $code "3 [| a b | a b - ] curry" }
+{ $code "[| a | a 3 - ]" }
+"Because of this, the behavior of " { $snippet "fry" } " changes when applied to such a quotation to ensure that fry conceptually behaves the same as with normal quotations, placing the fried values “underneath” the variable bindings. Thus, the following snippets are no longer equivalent:"
+{ $code "'[ [| a | _ a - ] ]" }
+{ $code "'[ [| a | a - ] curry ] call" }
+"Instead, the first line above expands into something like the following:"
+{ $code "[ [ swap [| a | a - ] ] curry call ]" }
+$nl
+"The precise behavior is as follows. When frying a " { $link POSTPONE: [| } " quotation, a stack shuffle (" { $link mnswap } ") is prepended so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the quotation's " { $snippet "n" } " named input bindings." ;
+
+ARTICLE: "locals-limitations" "Limitations of lexical variables"
+"There are two main limitations of the current implementation, and both concern macros."
+{ $heading "Macro expansions with free variables" }
+"The expansion of a macro cannot reference lexical variables bound in the outer scope. For example, the following macro is invalid:"
+{ $code "MACRO:: twice ( quot -- ) [ quot call quot call ] ;" }
+"The following is fine, though:"
+{ $code "MACRO:: twice ( quot -- ) quot quot '[ @ @ ] ;" }
+{ $heading "Static stack effect inference and macros" }
+"A macro will only expand at compile-time if all of its inputs are literal. Likewise, the word containing the macro will only have a static stack effect and compile successfully if the macro's inputs are literal. When lexical variables are used in a macro's literal arguments, there is an additional restriction: The literals must immediately precede the macro call lexically."
+$nl
+"For example, all of the following three code snippets are superficially equivalent, but only the first will compile:"
+{ $code
+ ":: good-cond-usage ( a -- ... )"
+ " {"
+ " { [ a 0 < ] [ ... ] }"
+ " { [ a 0 > ] [ ... ] }"
+ " { [ a 0 = ] [ ... ] }"
+ " } cond ;"
+}
+"The next two snippets will not compile because the argument to " { $link cond } " does not immediately precede the call:"
+{ $code
+ ": my-cond ( alist -- ) cond ; inline"
+ ""
+ ":: bad-cond-usage ( a -- ... )"
+ " {"
+ " { [ a 0 < ] [ ... ] }"
+ " { [ a 0 > ] [ ... ] }"
+ " { [ a 0 = ] [ ... ] }"
+ " } my-cond ;"
+}
+{ $code
+ ":: bad-cond-usage ( a -- ... )"
+ " {"
+ " { [ a 0 < ] [ ... ] }"
+ " { [ a 0 > ] [ ... ] }"
+ " { [ a 0 = ] [ ... ] }"
+ " } swap swap cond ;"
+}
+"The reason is that lexical variable references are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to lexical variable transformation. However, " { $vocab-link "macros.expander" } " cannot deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ;
+
+ARTICLE: "locals" "Lexical variables"
+"The " { $vocab-link "locals" } " vocabulary provides lexically scoped local variables. Full closure semantics, both downward and upward, are supported. Mutable variable bindings are also provided, supporting assignment to bindings in the current scope or in outer scopes."
+{ $subsections
+ "locals-examples"
+}
+"Word definitions where the inputs are bound to lexical variables:"
+{ $subsections
+ POSTPONE: ::
+ POSTPONE: M::
+ POSTPONE: MEMO::
+ POSTPONE: MACRO::
+}
+"Lexical scoping and binding forms:"
+{ $subsections
+ POSTPONE: [let
+ POSTPONE: :>
+}
+"Quotation literals where the inputs are bound to lexical variables:"
+{ $subsections POSTPONE: [| }
+"Additional topics:"
+{ $subsections
+ "locals-literals"
+ "locals-mutable"
+ "locals-fry"
+ "locals-limitations"
+}
+"Lexical variables complement " { $link "namespaces" } "." ;
+
+ABOUT: "locals"
--- /dev/null
+USING: locals math sequences tools.test hashtables words kernel
+namespaces arrays strings prettyprint io.streams.string parser
+accessors generic eval combinators combinators.short-circuit
+combinators.short-circuit.smart math.order math.functions
+definitions compiler.units fry lexer words.symbol see multiline
+combinators.smart ;
+IN: locals.tests
+
+:: foo ( a b -- a a ) a a ;
+
+{ 1 1 } [ 1 2 foo ] unit-test
+
+:: add-test ( a b -- c ) a b + ;
+
+{ 3 } [ 1 2 add-test ] unit-test
+
+:: sub-test ( a b -- c ) a b - ;
+
+{ -1 } [ 1 2 sub-test ] unit-test
+
+:: map-test ( a b -- seq ) a [ b + ] map ;
+
+{ { 5 6 7 } } [ { 1 2 3 } 4 map-test ] unit-test
+
+:: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
+
+{ { 5 6 7 } } [ { 1 2 3 } 4 map-test-2 ] unit-test
+
+:: let-test ( c -- d )
+ [let 1 :> a 2 :> b a b + c + ] ;
+
+{ 7 } [ 4 let-test ] unit-test
+
+:: let-test-2 ( a -- a )
+ a [let :> a [let a :> b a ] ] ;
+
+{ 3 } [ 3 let-test-2 ] unit-test
+
+:: let-test-3 ( a -- a )
+ a [let :> a [let [ a ] :> b [let 3 :> a b ] ] ] ;
+
+:: let-test-4 ( a -- b )
+ a [let 1 :> a :> b a b 2array ] ;
+
+{ { 1 2 } } [ 2 let-test-4 ] unit-test
+
+:: let-test-5 ( a b -- b )
+ a b [let :> a :> b a b 2array ] ;
+
+{ { 2 1 } } [ 1 2 let-test-5 ] unit-test
+
+:: let-test-6 ( a -- b )
+ a [let :> a 1 :> b a b 2array ] ;
+
+{ { 2 1 } } [ 2 let-test-6 ] unit-test
+
+{ -1 } [ -1 let-test-3 call ] unit-test
+
+:: write-test-1 ( n! -- q )
+ [| i | n i + dup n! ] ;
+
+0 write-test-1 "q" set
+
+{ 1 1 } "q" get must-infer-as
+
+{ 1 } [ 1 "q" get call ] unit-test
+
+{ 2 } [ 1 "q" get call ] unit-test
+
+{ 3 } [ 1 "q" get call ] unit-test
+
+{ 5 } [ 2 "q" get call ] unit-test
+
+:: write-test-2 ( -- q )
+ [let 0 :> n! [| i | n i + dup n! ] ] ;
+
+write-test-2 "q" set
+
+{ 1 } [ 1 "q" get call ] unit-test
+
+{ 2 } [ 1 "q" get call ] unit-test
+
+{ 3 } [ 1 "q" get call ] unit-test
+
+{ 5 } [ 2 "q" get call ] unit-test
+
+{ 10 20 }
+[
+ 20 10 [| a! | [| b! | a b ] ] call call
+] unit-test
+
+:: write-test-3 ( a! -- q ) [| b | b a! ] ;
+
+{ } [ 1 2 write-test-3 call ] unit-test
+
+:: write-test-4 ( x! -- q ) [ [let 0 :> y! f x! ] ] ;
+
+{ } [ 5 write-test-4 drop ] unit-test
+
+:: let-let-test ( n -- n ) [let n 3 + :> n n ] ;
+
+{ 13 } [ 10 let-let-test ] unit-test
+
+GENERIC: lambda-generic ( a b -- c )
+
+GENERIC#: lambda-generic-1 1 ( a b -- c )
+
+M:: integer lambda-generic-1 ( a b -- c ) a b * ;
+
+M:: string lambda-generic-1 ( a b -- c )
+ a b CHAR: x <string> lambda-generic ;
+
+M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
+
+GENERIC#: lambda-generic-2 1 ( a b -- c )
+
+M:: integer lambda-generic-2 ( a b -- c )
+ a CHAR: x <string> b lambda-generic ;
+
+M:: string lambda-generic-2 ( a b -- c ) a b append ;
+
+M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
+
+{ 10 } [ 5 2 lambda-generic ] unit-test
+
+{ "abab" } [ "aba" "b" lambda-generic ] unit-test
+
+{ "abaxxx" } [ "aba" 3 lambda-generic ] unit-test
+
+{ "xaba" } [ 1 "aba" lambda-generic ] unit-test
+
+{ } [ \ lambda-generic-1 see ] unit-test
+
+{ } [ \ lambda-generic-2 see ] unit-test
+
+{ } [ \ lambda-generic see ] unit-test
+
+:: unparse-test-1 ( a -- ) [let 3 :> a! 4 :> b ] ;
+
+{ "[let 3 :> a! 4 :> b ]" } [
+ \ unparse-test-1 "lambda" word-prop body>> first unparse
+] unit-test
+
+:: unparse-test-3 ( -- b ) [| a! | ] ;
+
+{ "[| a! | ]" } [
+ \ unparse-test-3 "lambda" word-prop body>> first unparse
+] unit-test
+
+DEFER: xyzzy
+
+{ } [
+ "IN: locals.tests USE: math GENERIC: xyzzy ( a -- b ) M: integer xyzzy ;"
+ <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+{ 10 } [ 10 xyzzy ] unit-test
+
+{ } [
+ "IN: locals.tests USE: math USE: locals GENERIC: xyzzy ( a -- b ) M:: integer xyzzy ( n -- x ) 5 ;"
+ <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+{ 5 } [ 10 xyzzy ] unit-test
+
+GENERIC: next-method-test ( a -- b )
+
+M: integer next-method-test 3 + ;
+
+M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
+
+{ 5 } [ 1 next-method-test ] unit-test
+
+: no-with-locals-test ( -- seq ) { 1 2 3 } [| x | x 3 + ] map ;
+
+{ { 4 5 6 } } [ no-with-locals-test ] unit-test
+
+{ 3 0 } [| a b c | ] must-infer-as
+
+{ } [ 1 [let :> a ] ] unit-test
+
+{ 3 } [ 1 [let :> a 3 ] ] unit-test
+
+{ } [ 1 2 [let :> a :> b ] ] unit-test
+
+:: a-word-with-locals ( a b -- ) ;
+
+CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
+
+{ } [ new-definition eval( -- ) ] unit-test
+
+{ t } [
+ [ \ a-word-with-locals see ] with-string-writer
+ new-definition =
+] unit-test
+
+CONSTANT: method-definition "USING: locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n"
+
+GENERIC: method-with-locals ( x -- y )
+
+M:: sequence method-with-locals ( a -- y ) a reverse ;
+
+{ t } [
+ [ \ sequence \ method-with-locals lookup-method see ] with-string-writer
+ method-definition =
+] unit-test
+
+:: cond-test ( a b -- c )
+ {
+ { [ a b < ] [ 3 ] }
+ { [ a b = ] [ 4 ] }
+ { [ a b > ] [ 5 ] }
+ } cond ;
+
+\ cond-test def>> must-infer
+
+{ 3 } [ 1 2 cond-test ] unit-test
+{ 4 } [ 2 2 cond-test ] unit-test
+{ 5 } [ 3 2 cond-test ] unit-test
+
+:: 0&&-test ( a -- ? )
+ { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
+
+\ 0&&-test def>> must-infer
+
+{ f } [ 1.5 0&&-test ] unit-test
+{ f } [ 3 0&&-test ] unit-test
+{ f } [ 8 0&&-test ] unit-test
+{ t } [ 12 0&&-test ] unit-test
+
+:: &&-test ( a -- ? )
+ { [ a integer? ] [ a even? ] [ a 10 > ] } && ;
+
+\ &&-test def>> must-infer
+
+{ f } [ 1.5 &&-test ] unit-test
+{ f } [ 3 &&-test ] unit-test
+{ f } [ 8 &&-test ] unit-test
+{ t } [ 12 &&-test ] unit-test
+
+:: let-and-cond-test-1 ( -- a )
+ [let 10 :> a
+ [let 20 :> a
+ {
+ { [ t ] [ [let 30 :> c a ] ] }
+ } cond
+ ]
+ ] ;
+
+\ let-and-cond-test-1 def>> must-infer
+
+{ 20 } [ let-and-cond-test-1 ] unit-test
+
+:: let-and-cond-test-2 ( -- pair )
+ [let 10 :> A
+ [let 20 :> B
+ { { [ t ] [ { A B } ] } } cond
+ ]
+ ] ;
+
+\ let-and-cond-test-2 def>> must-infer
+
+{ { 10 20 } } [ let-and-cond-test-2 ] unit-test
+
+{ { 10 } } [ 10 [| a | { a } ] call ] unit-test
+{ { 10 20 } } [ 10 20 [| a b | { a b } ] call ] unit-test
+{ { 10 20 30 } } [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
+
+{ { 10 20 30 } } [ [let 10 :> a 20 :> b 30 :> c { a b c } ] ] unit-test
+
+{ V{ 10 20 30 } } [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
+
+{ H{ { 10 "a" } { 20 "b" } { 30 "c" } } }
+[ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
+
+TUPLE: test-tuple a b c ;
+
+{ T{ test-tuple f 0 3 "abc" } }
+[ 0 3 "abc" [| a b c | T{ test-tuple f a b c } ] call ] unit-test
+
+{ 3 1 } [| a b c | T{ test-tuple f a b c } ] must-infer-as
+
+ERROR: punned-class x ;
+
+{ T{ punned-class f 3 } } [ 3 [| a | T{ punned-class f a } ] call ] unit-test
+
+:: literal-identity-test ( -- a b )
+ { 1 } V{ } ;
+
+{ t t } [
+ literal-identity-test
+ literal-identity-test
+ [ eq? ] [ eq? ] bi-curry* bi*
+] unit-test
+
+:: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ;
+
+{ { 4 } } [ 3 mutable-local-in-literal-test ] unit-test
+
+:: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
+ obj1 obj2 <=> {
+ { +lt+ [ lt-quot call ] }
+ { +eq+ [ eq-quot call ] }
+ { +gt+ [ gt-quot call ] }
+ } case ; inline
+
+[ [ ] [ ] [ ] compare-case ] must-infer
+
+:: big-case-test ( a -- b )
+ a {
+ { 0 [ a 1 + ] }
+ { 1 [ a 1 - ] }
+ { 2 [ a 1 swap / ] }
+ { 3 [ a dup * ] }
+ { 4 [ a sqrt ] }
+ { 5 [ a a ^ ] }
+ } case ;
+
+\ big-case-test def>> must-infer
+
+{ 9 } [ 3 big-case-test ] unit-test
+
+! Dan found this problem
+: littledan-case-problem-1 ( a -- b )
+ {
+ { t [ 3 ] }
+ { f [ 4 ] }
+ [| x | x 12 + { "howdy" } nth ]
+ } case ;
+
+\ littledan-case-problem-1 def>> must-infer
+
+{ "howdy" } [ -12 \ littledan-case-problem-1 def>> call ] unit-test
+{ "howdy" } [ -12 littledan-case-problem-1 ] unit-test
+
+:: littledan-case-problem-2 ( a -- b )
+ a {
+ { t [ a not ] }
+ { f [ 4 ] }
+ [| x | x a - { "howdy" } nth ]
+ } case ;
+
+\ littledan-case-problem-2 def>> must-infer
+
+{ "howdy" } [ -12 \ littledan-case-problem-2 def>> call ] unit-test
+{ "howdy" } [ -12 littledan-case-problem-2 ] unit-test
+
+:: littledan-cond-problem-1 ( a -- b )
+ a {
+ { [ dup 0 < ] [ drop a not ] }
+ { [| y | y y 0 > ] [ drop 4 ] }
+ [| x | x a - { "howdy" } nth ]
+ } cond ;
+
+\ littledan-cond-problem-1 def>> must-infer
+
+{ f } [ -12 \ littledan-cond-problem-1 def>> call ] unit-test
+{ 4 } [ 12 \ littledan-cond-problem-1 def>> call ] unit-test
+{ "howdy" } [ 0 \ littledan-cond-problem-1 def>> call ] unit-test
+{ f } [ -12 littledan-cond-problem-1 ] unit-test
+{ 4 } [ 12 littledan-cond-problem-1 ] unit-test
+{ "howdy" } [ 0 littledan-cond-problem-1 ] unit-test
+
+/*
+:: littledan-case-problem-3 ( a quot -- b )
+ a {
+ { t [ a not ] }
+ { f [ 4 ] }
+ quot
+ } case ; inline
+
+{ f } [ t [ ] littledan-case-problem-3 ] unit-test
+{ 144 } [ 12 [ sq ] littledan-case-problem-3 ] unit-test
+[| | [| a | a ] littledan-case-problem-3 ] must-infer
+
+: littledan-case-problem-4 ( a -- b )
+ [ 1 + ] littledan-case-problem-3 ;
+
+\ littledan-case-problem-4 def>> must-infer
+*/
+
+GENERIC: lambda-method-forget-test ( a -- b )
+
+M:: integer lambda-method-forget-test ( a -- b ) a ;
+
+{ } [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
+
+{ 10 } [ 10 [| A | { [ A ] } ] call first call ] unit-test
+
+[
+ "USING: locals fry math ; 1 '[ [let 10 :> A A _ + ] ]"
+ eval( -- ) call
+] [ error>> >r/r>-in-fry-error? ] must-fail-with
+
+:: (funny-macro-test) ( obj quot -- ? ) obj { [ quot call ] } 1&& ; inline
+: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
+
+\ funny-macro-test def>> must-infer
+
+{ t } [ 3 funny-macro-test ] unit-test
+{ f } [ 2 funny-macro-test ] unit-test
+
+[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
+
+{ 25 } [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
+{ 25 } [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
+
+:: FAILdog-1 ( -- b ) { [| c | c ] } ;
+
+\ FAILdog-1 def>> must-infer
+
+:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
+
+\ FAILdog-2 def>> must-infer
+
+{ 3 } [ 3 [| a | \ a ] call ] unit-test
+
+[ "USE: locals [| | { [let 0 :> a a ] } ]" eval( -- ) ] must-fail
+
+[ "USE: locals [| | [let 0 :> a! { a! } ] ]" eval( -- ) ] must-fail
+
+[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
+
+[ "USE: locals 3 :> a" eval( -- ) ] must-fail
+
+{ 3 } [ 3 [| | :> a a ] call ] unit-test
+
+{ 3 } [ 3 [| | :> a! a ] call ] unit-test
+
+{ 3 } [ 2 [| | :> a! a 1 + a! a ] call ] unit-test
+
+: fry-locals-test-1 ( -- n )
+ [let 6 '[ [let 4 :> A A _ + ] ] call ] ;
+
+\ fry-locals-test-1 def>> must-infer
+{ 10 } [ fry-locals-test-1 ] unit-test
+
+:: fry-locals-test-2 ( -- n )
+ [let 6 '[ [let 4 :> A A _ + ] ] call ] ;
+
+\ fry-locals-test-2 def>> must-infer
+{ 10 } [ fry-locals-test-2 ] unit-test
+
+{ 1 } [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
+{ -1 } [ 3 4 [| | [| a | a - ] call ] call ] unit-test
+{ -1 } [ 3 4 [| | [| a | a - ] curry call ] call ] unit-test
+{ -1 } [ 3 4 [| a | a - ] curry call ] unit-test
+{ 1 } [ 3 4 [| | '[ [| a | _ a - ] call ] call ] call ] unit-test
+{ -1 } [ 3 4 [| | '[ [| a | a _ - ] call ] call ] call ] unit-test
+
+{ { 1 2 3 4 } } [
+ 1 3 2 4
+ [| | '[ [| a b | a _ b _ 4array ] call ] call ] call
+] unit-test
+
+{ 10 } [
+ [| | 0 '[ [let 10 :> A A _ + ] ] call ] call
+] unit-test
+
+! littledan found this problem
+{ "bar" } [ [let [let "bar" :> foo foo ] :> a a ] ] unit-test
+{ 10 } [ [let 10 :> a [let a :> b b ] ] ] unit-test
+
+{ { \ + } } [ [let \ + :> x { \ x } ] ] unit-test
+
+{ { \ + 3 } } [ [let 3 :> a { \ + a } ] ] unit-test
+
+{ 3 } [ [let \ + :> a 1 2 [ \ a execute ] ] call ] unit-test
+
+! erg found this problem
+:: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
+
+{ 3 } [ 3 f erg's-:>-bug ] unit-test
+
+{ 3 } [ 3 t erg's-:>-bug ] unit-test
+
+:: erg's-:>-bug-2 ( n ? -- n ) ? n '[ _ :> n n ] [ n :> b b ] if ;
+
+{ 3 } [ 3 f erg's-:>-bug-2 ] unit-test
+
+{ 3 } [ 3 t erg's-:>-bug-2 ] unit-test
+
+! dharmatech found this problem
+GENERIC: ed's-bug ( a -- b )
+
+M: string ed's-bug reverse ;
+M: integer ed's-bug neg ;
+
+:: ed's-test-case ( a -- b )
+ { [ a ed's-bug ] } && ;
+
+{ t } [ \ ed's-test-case word-optimized? ] unit-test
+
+! multiple bind
+{ 3 1 2 } [ [let 1 2 3 :> ( a b c ) c a b ] ] unit-test
+
+! Test smart combinators and locals interaction
+:: smart-combinator-locals ( a b c -- seq ) [ a b c ] output>array ;
+
+{ { 1 2 3 } } [ 1 2 3 smart-combinator-locals ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences vocabs vocabs.loader ;
+IN: locals
+
+{
+ "locals.parser"
+ "locals.types"
+ "locals.errors"
+ "locals.macros"
+ "locals.fry"
+} [ require ] each
+
+{ "locals" "prettyprint" } "locals.definitions" require-when
+{ "locals" "prettyprint" } "locals.prettyprint" require-when
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel locals.types macros.expander fry ;
+IN: locals.macros
+
+M: lambda expand-macros clone [ expand-macros ] change-body ;
+
+M: lambda expand-macros* expand-macros literal ;
+
+M: let expand-macros
+ clone [ expand-macros ] change-body ;
+
+M: let expand-macros* expand-macros literal ;
+
+M: lambda condomize? drop t ;
+
+M: lambda condomize [ call ] curry ;
--- /dev/null
+Support for macro expansion inside lambdas
--- /dev/null
+USING: help.markup help.syntax locals locals.types quotations strings
+vocabs.parser ;
+IN: locals.parser
+
+HELP: in-lambda?
+{ $var-description { $link t } " if we're currently parsing a lambda with lexical variables." } ;
+
+HELP: parse-def
+{ $values
+ { "name/paren" string }
+ { "def" "a " { $link def } " or a " { $link multi-def } }
+}
+{ $description "Parses the lexical variable bindings following a " { $link POSTPONE: :> } " token." } ;
+
+HELP: with-lambda-scope
+{ $values { "assoc" "local variables" } { "reader-quot" quotation } { "quot" quotation } }
+{ $description "Runs the quotation in a lambda scope. That means that any local variables are available for lookup in the " { $link manifest } ", but are cleaned up after the quotation finishes." } ;
+
+ARTICLE: "locals.parser" "Utility words used by locals parsing words"
+"Words for parsing local words."
+$nl
+"Words for parsing variable assignments:"
+{ $subsections parse-def parse-multi-def parse-single-def }
+"Parsers for word and method definitions:"
+{ $subsections (::) (M::) } ;
+
+ABOUT: "locals.parser"
--- /dev/null
+USING: accessors assocs compiler.units kernel lexer locals.backend
+locals.parser namespaces parser prettyprint sequences sorting
+tools.test vocabs vocabs.parser ;
+IN: locals.parser.tests
+
+! XXX: remove the << and >> below and make test-all pass
+
+<<
+! (::)
+{
+ "dobiedoo"
+ [ 1 load-locals 1 drop-locals ]
+ ( x -- y )
+} [
+ [
+ { "dobiedoo ( x -- y ) ;" } <lexer> [ (::) ] with-lexer
+ ] with-compilation-unit
+ [ name>> ] 2dip
+] unit-test
+
+! parse-def
+{ "um" t } [
+ [
+ "um" parse-def
+ local>> name>>
+ qualified-vocabs last words>> keys "um" swap member?
+ ] with-compilation-unit
+] unit-test
+>>
+
+! check-local-name
+{ "hello" } [
+ "hello" check-local-name
+] unit-test
+
+! make-locals
+{ { "a" "b" "c" } } [
+ [ { "a" "b" "c" } make-locals ] with-compilation-unit
+ nip values [ name>> ] map
+] unit-test
+
+! parse-local-defs
+{ { "tok1" "tok2" } } [
+ [
+ { "tok1 tok2 |" } <lexer> [ parse-local-defs ] with-lexer
+ ] with-compilation-unit
+ nip values [ name>> ] map
+] unit-test
+
+! parse-multi-def
+{
+ { "tok1" "tok2" }
+ { "tok1" "tok2" }
+} [
+ [
+ { "tok1 tok2 )" } <lexer> [ parse-multi-def ] with-lexer
+ ] with-compilation-unit
+ [ locals>> [ name>> ] map ] [ keys ] bi*
+] unit-test
+
+<<
+{
+ "V{ 99 :> kkk kkk }"
+} [
+ [
+ "locals" use-vocab
+ { "99 :> kkk kkk ;" } <lexer> [
+ H{ } clone [ \ ; parse-until ] with-lambda-scope
+ ] with-lexer
+ ] with-compilation-unit unparse
+] unit-test
+>>
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs effects.parser fry generic.parser
+kernel lexer locals.errors locals.rewrite.closures locals.types
+make namespaces parser quotations sequences splitting
+vocabs.parser words ;
+IN: locals.parser
+
+SYMBOL: in-lambda?
+
+: ?rewrite-closures ( form -- form' )
+ in-lambda? get [ 1array ] [ rewrite-closures ] if ;
+
+ERROR: invalid-local-name name ;
+
+: check-local-name ( name -- name )
+ dup { "]" "]!" } member? [ invalid-local-name ] when ;
+
+: make-local ( name -- word )
+ check-local-name "!" ?tail [
+ <local-reader>
+ dup <local-writer> dup name>> ,,
+ ] [ <local> ] if
+ dup dup name>> ,, ;
+
+: make-locals ( seq -- words assoc )
+ [ [ make-local ] map ] H{ } make ;
+
+: parse-local-defs ( -- words assoc )
+ "|" parse-tokens make-locals ;
+
+SINGLETON: lambda-parser
+
+: with-lambda-scope ( assoc reader-quot: ( -- quot ) -- quot )
+ H{
+ { in-lambda? t }
+ { quotation-parser lambda-parser }
+ } swap '[
+ [ use-words @ ] [ unuse-words ] bi
+ ] with-variables ; inline
+
+: (parse-lambda) ( assoc -- quot )
+ [ \ ] parse-until >quotation ] with-lambda-scope ;
+
+: parse-lambda ( -- lambda )
+ parse-local-defs
+ (parse-lambda) <lambda>
+ ?rewrite-closures ;
+
+: parse-multi-def ( -- multi-def assoc )
+ ")" parse-tokens make-locals [ <multi-def> ] dip ;
+
+: parse-single-def ( name -- def assoc )
+ [ make-local <def> ] H{ } make ;
+
+: update-locals ( assoc -- )
+ qualified-vocabs last words>> swap assoc-union! drop ;
+
+: parse-def ( name/paren -- def )
+ dup "(" = [ drop parse-multi-def ] [ parse-single-def ] if update-locals ;
+
+M: lambda-parser parse-quotation
+ H{ } clone (parse-lambda) ;
+
+: parse-let ( -- form )
+ H{ } clone (parse-lambda) <let> ?rewrite-closures ;
+
+: parse-locals ( -- effect vars assoc )
+ scan-effect
+ dup
+ in>> [ dup pair? [ first ] when ] map make-locals ;
+
+: (parse-locals-definition) ( effect vars assoc reader-quot -- word quot effect )
+ with-lambda-scope <lambda>
+ [ nip "lambda" set-word-prop ]
+ [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
+ [ drop nip ] 3tri ; inline
+
+: parse-locals-definition ( word reader-quot -- word quot effect )
+ [ parse-locals ] dip (parse-locals-definition) ; inline
+
+: parse-locals-method-definition ( word reader -- word quot effect )
+ [ parse-locals pick check-method-effect ] dip
+ (parse-locals-definition) ; inline
+
+: (::) ( -- word def effect )
+ [
+ scan-new-word
+ [ parse-definition ]
+ parse-locals-definition
+ ] with-definition ;
+
+: (M::) ( -- word def )
+ [
+ scan-new-method
+ [
+ [ parse-definition ]
+ parse-locals-method-definition drop
+ ] with-method-definition
+ ] with-definition ;
--- /dev/null
+Utility words used by locals parsing words
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals.rewrite.point-free
+locals.rewrite.sugar locals.types macros.expander make
+quotations sequences sets words ;
+IN: locals.rewrite.closures
+
+! Step 2: identify free variables and make them into explicit
+! parameters of lambdas which are curried on
+
+GENERIC: rewrite-closures* ( obj -- )
+
+: (rewrite-closures) ( form -- form' )
+ [ [ rewrite-closures* ] each ] [ ] make ;
+
+: rewrite-closures ( form -- form' )
+ expand-macros (rewrite-sugar) (rewrite-closures) point-free ;
+
+GENERIC: defs-vars* ( seq form -- seq' )
+
+: defs-vars ( form -- vars ) { } [ defs-vars* ] reduce members ;
+
+M: def defs-vars* local>> unquote suffix ;
+
+M: quotation defs-vars* [ defs-vars* ] each ;
+
+M: object defs-vars* drop ;
+
+GENERIC: uses-vars* ( seq form -- seq' )
+
+: uses-vars ( form -- vars ) { } [ uses-vars* ] reduce members ;
+
+M: local-writer uses-vars* "local-reader" word-prop suffix ;
+
+M: lexical uses-vars* suffix ;
+
+M: quote uses-vars* local>> uses-vars* ;
+
+M: object uses-vars* drop ;
+
+M: quotation uses-vars* [ uses-vars* ] each ;
+
+: free-vars ( form -- seq )
+ [ uses-vars ] [ defs-vars ] bi diff ;
+
+M: callable rewrite-closures*
+ ! Turn free variables into bound variables, curry them
+ ! onto the body
+ dup free-vars [ <quote> ] map
+ [ % ]
+ [ var-defs prepend (rewrite-closures) point-free , ]
+ [ length \ curry <repetition> % ]
+ tri ;
+
+M: object rewrite-closures* , ;
--- /dev/null
+Rewriting closures to not have any free variables
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays fry kernel math quotations sequences
+words combinators make locals.backend locals.types
+locals.errors ;
+IN: locals.rewrite.point-free
+
+! Step 3: rewrite locals usage within a single quotation into
+! retain stack manipulation
+
+: local-index ( args obj -- n )
+ 2dup '[ unquote _ eq? ] find drop
+ [ 2nip ] [ bad-local ] if* ;
+
+: read-local-quot ( args obj -- quot )
+ local-index neg [ get-local ] curry ;
+
+GENERIC: localize ( args obj -- args quot )
+
+M: local localize dupd read-local-quot ;
+
+M: quote localize dupd local>> read-local-quot ;
+
+M: local-reader localize dupd read-local-quot [ local-value ] append ;
+
+M: local-writer localize
+ dupd "local-reader" word-prop
+ read-local-quot [ set-local-value ] append ;
+
+M: def localize
+ local>>
+ [ prefix ]
+ [ local-reader? [ 1array load-local ] [ load-local ] ? ]
+ bi ;
+
+M: object localize 1quotation ;
+
+! We special-case all the :> at the start of a quotation
+: load-locals-quot ( args -- quot )
+ [ [ ] ] [
+ dup [ local-reader? ] any? [
+ dup [ local-reader? [ 1array ] [ ] ? ] map
+ deep-spread>quot
+ ] [ [ ] ] if swap length [ load-locals ] curry append
+ ] if-empty ;
+
+: load-locals-index ( quot -- n )
+ [ [ dup def? [ local>> local-reader? ] [ drop t ] if ] find drop ]
+ [ length ] bi or ;
+
+: point-free-start ( quot -- args rest )
+ dup load-locals-index
+ cut [ [ local>> ] map dup <reversed> load-locals-quot % ] dip ;
+
+: point-free-body ( args quot -- args )
+ [ localize % ] each ;
+
+: drop-locals-quot ( args -- )
+ [ length , [ drop-locals ] % ] unless-empty ;
+
+: point-free-end ( args obj -- )
+ dup special?
+ [ localize % drop-locals-quot ]
+ [ [ drop-locals-quot ] [ , ] bi* ]
+ if ;
+
+: point-free ( quot -- newquot )
+ [
+ point-free-start
+ [ drop-locals-quot ] [
+ unclip-last
+ [ point-free-body ]
+ [ point-free-end ]
+ bi*
+ ] if-empty
+ ] [ ] make ;
--- /dev/null
+Rewriting applicative code to use the retain stack instead of named values
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes classes.tuple fry
+sequences.generalizations hashtables kernel locals locals.backend
+locals.errors locals.types make quotations sequences vectors
+words ;
+IN: locals.rewrite.sugar
+
+! Step 1: rewrite [| into :> forms, turn
+! literals with locals in them into code which constructs
+! the literal after pushing locals on the stack
+
+GENERIC: rewrite-sugar* ( obj -- )
+
+: (rewrite-sugar) ( form -- form' )
+ [ rewrite-sugar* ] [ ] make ;
+
+GENERIC: quotation-rewrite ( form -- form' )
+
+M: callable quotation-rewrite [ [ rewrite-sugar* ] each ] [ ] make ;
+
+: var-defs ( vars -- defs ) <reversed> [ <def> ] [ ] map-as ;
+
+M: lambda quotation-rewrite
+ [ body>> ] [ vars>> var-defs ] bi
+ prepend quotation-rewrite ;
+
+M: callable rewrite-sugar* quotation-rewrite , ;
+
+M: lambda rewrite-sugar* quotation-rewrite , ;
+
+GENERIC: rewrite-literal? ( obj -- ? )
+
+M: special rewrite-literal? drop t ;
+
+M: array rewrite-literal? [ rewrite-literal? ] any? ;
+
+M: quotation rewrite-literal? [ rewrite-literal? ] any? ;
+
+M: vector rewrite-literal? [ rewrite-literal? ] any? ;
+
+M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
+
+M: hashtable rewrite-literal? >alist rewrite-literal? ;
+
+M: tuple rewrite-literal? tuple>array rewrite-literal? ;
+
+M: object rewrite-literal? drop f ;
+
+GENERIC: rewrite-element ( obj -- )
+
+: rewrite-elements ( seq -- )
+ [ rewrite-element ] each ;
+
+: rewrite-sequence ( seq -- )
+ [ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ;
+
+M: array rewrite-element
+ dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
+
+M: vector rewrite-element
+ dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
+
+M: hashtable rewrite-element
+ dup rewrite-literal? [ >alist rewrite-sequence \ >hashtable , ] [ , ] if ;
+
+M: tuple rewrite-element
+ dup rewrite-literal? [
+ [ tuple-slots rewrite-elements ] [ class-of ] bi '[ _ boa ] %
+ ] [ , ] if ;
+
+M: quotation rewrite-element rewrite-sugar* ;
+
+M: lambda rewrite-element rewrite-sugar* ;
+
+M: let rewrite-element let-form-in-literal-error ;
+
+M: local rewrite-element , ;
+
+M: local-reader rewrite-element , ;
+
+M: local-writer rewrite-element
+ local-writer-in-literal-error ;
+
+M: word rewrite-element <wrapper> , ;
+
+: rewrite-wrapper ( wrapper -- )
+ dup rewrite-literal?
+ [ wrapped>> rewrite-element ] [ , ] if ;
+
+M: wrapper rewrite-element
+ rewrite-wrapper \ <wrapper> , ;
+
+M: object rewrite-element , ;
+
+M: array rewrite-sugar* rewrite-element ;
+
+M: vector rewrite-sugar* rewrite-element ;
+
+M: tuple rewrite-sugar* rewrite-element ;
+
+M: def rewrite-sugar* , ;
+
+M: multi-def rewrite-sugar* locals>> <reversed> [ <def> , ] each ;
+
+M: hashtable rewrite-sugar* rewrite-element ;
+
+M: wrapper rewrite-sugar*
+ rewrite-wrapper ;
+
+M: word rewrite-sugar*
+ dup { load-locals get-local drop-locals } member-eq?
+ [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
+
+M: object rewrite-sugar* , ;
+
+M: let rewrite-sugar*
+ body>> quotation-rewrite % ;
--- /dev/null
+Desugaring locals in literals and let binding
--- /dev/null
+Efficient named local variables and lexical closures
--- /dev/null
+extensions
--- /dev/null
+Data types used by locals implementation
--- /dev/null
+USING: accessors compiler.units kernel locals.types tools.test words ;
+IN: locals.types.tests
+
+{ t } [
+ [ "hello" <local> ] with-compilation-unit "local?" word-prop
+] unit-test
+
+{ t "hello!" } [
+ [ "hello" <local-reader> <local-writer> ] with-compilation-unit
+ [ "local-writer?" word-prop ] [ name>> ] bi
+] unit-test
--- /dev/null
+! Copyright (C) 2007, 2010 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel sequences words
+quotations ;
+IN: locals.types
+
+TUPLE: lambda vars body ;
+
+C: <lambda> lambda
+
+TUPLE: let body ;
+
+C: <let> let
+
+TUPLE: quote local ;
+
+C: <quote> quote
+
+: unquote ( quote -- local ) dup quote? [ local>> ] when ; inline
+
+TUPLE: def local ;
+
+C: <def> def
+
+TUPLE: multi-def locals ;
+
+C: <multi-def> multi-def
+
+PREDICATE: local < word "local?" word-prop ;
+
+: <local> ( name -- word )
+ ! Create a local variable identifier
+ f <word>
+ dup t "local?" set-word-prop ;
+
+M: local literalize ;
+
+PREDICATE: local-reader < word "local-reader?" word-prop ;
+
+: <local-reader> ( name -- word )
+ f <word>
+ dup t "local-reader?" set-word-prop ;
+
+M: local-reader literalize ;
+
+PREDICATE: local-writer < word "local-writer?" word-prop ;
+
+: <local-writer> ( reader -- word )
+ dup name>> "!" append f <word> {
+ [ nip t "local-writer?" set-word-prop ]
+ [ swap "local-reader" set-word-prop ]
+ [ "local-writer" set-word-prop ]
+ [ nip ]
+ } 2cleave ;
+
+UNION: lexical local local-reader local-writer ;
+UNION: special lexical quote def ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: macros.expander.tests
+USING: macros.expander tools.test math combinators.short-circuit
+kernel combinators ;
+
+{ t } [ 20 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test
+
+{ f } [ 15 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test
+
+{ f } [ 5.0 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test
+
+{ [ no-case ] } [ [ { } case ] expand-macros ] unit-test
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators combinators.short-circuit
+continuations effects fry generalizations kernel make math
+namespaces quotations sequences sequences.private vectors words
+;
+IN: macros.expander
+
+GENERIC: expand-macros ( quot -- quot' )
+
+SYMBOL: stack
+
+: begin ( -- )
+ V{ } clone stack set ;
+
+: end ( -- )
+ stack get [ [ literalize , ] each ] [ delete-all ] bi ;
+
+GENERIC: condomize? ( obj -- ? )
+
+M: array condomize? [ condomize? ] any? ;
+M: callable condomize? [ condomize? ] any? ;
+M: object condomize? drop f ;
+
+GENERIC: condomize ( obj -- obj' )
+
+M: array condomize [ condomize ] map ;
+M: callable condomize [ condomize ] map ;
+M: object condomize ;
+
+: literal ( obj -- )
+ dup condomize? [ condomize ] when stack get push ;
+
+GENERIC: expand-macros* ( obj -- )
+
+M: wrapper expand-macros* wrapped>> literal ;
+
+: expand-dispatch? ( word -- ? )
+ \ dispatch eq? stack get length 1 >= and ;
+
+: expand-dispatch ( -- )
+ stack get pop end
+ [ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
+ [
+ length <iota> [ <reversed> ] keep
+ [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
+ ] bi ;
+
+: word, ( word -- ) end , ;
+
+: expand-macro ( word quot -- )
+ '[
+ drop
+ stack [ _ with-datastack >vector ] change
+ stack get pop >quotation end
+ [ expand-macros* ] each
+ ] [
+ drop
+ word,
+ ] recover ;
+
+: macro-quot ( word -- quot/f )
+ {
+ [ "transform-quot" word-prop ]
+ [ "macro" word-prop ]
+ } 1|| ;
+
+: macro-effect ( word -- n )
+ {
+ [ "transform-n" word-prop ]
+ [ stack-effect in>> length ]
+ } 1|| ;
+
+: expand-macro? ( word -- quot ? )
+ dup macro-quot [
+ swap macro-effect stack get length <=
+ ] [
+ drop f f
+ ] if* ;
+
+M: word expand-macros*
+ {
+ { [ dup expand-dispatch? ] [ drop expand-dispatch ] }
+ { [ dup expand-macro? ] [ expand-macro ] }
+ [ drop word, ]
+ } cond ;
+
+M: object expand-macros* literal ;
+
+M: callable expand-macros*
+ expand-macros literal ;
+
+M: callable expand-macros
+ [ begin [ expand-macros* ] each end ] [ ] make ;
--- /dev/null
+Macro expansion utility, used for debugging and in the locals implementation
--- /dev/null
+USING: help.markup help.syntax quotations kernel
+stack-checker.transforms sequences combinators ;
+IN: macros
+
+HELP: MACRO:
+{ $syntax "MACRO: word ( inputs... -- quot ) definition... ;" }
+{ $description "Defines a macro word. The definition must have stack effect " { $snippet "( inputs... -- quot )" } "." }
+{ $notes
+ "A call of a macro inside a word definition is replaced with the quotation expansion at compile-time. The following two conditions must hold:"
+ { $list
+ { "All inputs to the macro call must be literals" }
+ { "The expansion quotation produced by the macro has a static stack effect" }
+ }
+ "Macros allow computation to be moved from run-time to compile-time, splicing the result of this computation into the generated quotation."
+}
+{ $examples
+ "A macro that calls a quotation but preserves any values it consumes off the stack:"
+ { $code
+ "USING: fry generalizations kernel macros stack-checker ;"
+ "MACRO: preserving ( quot -- quot' )"
+ " [ inputs ] keep '[ _ ndup @ ] ;"
+ }
+ "Using this macro, we can define a variant of " { $link if } " which takes a predicate quotation instead of a boolean; any values consumed by the predicate quotation are restored immediately after:"
+ { $code
+ ": ifte ( pred true false -- ) [ preserving ] 2dip if ; inline"
+ }
+ "Note that " { $snippet "ifte" } " is an ordinary word, and it passes one of its inputs to the macro. If another word calls " { $snippet "ifte" } " with all three input quotations literal, then " { $snippet "ifte" } " will be inlined and " { $snippet "preserving" } " will expand at compile-time, and the generated machine code will be exactly the same as if the inputs consumed by the predicate were duplicated by hand."
+ $nl
+ "The " { $snippet "ifte" } " combinator presented here has similar semantics to the " { $snippet "ifte" } " combinator of the Joy programming language."
+} ;
+
+HELP: macro
+{ $class-description "Class of words defined with " { $link POSTPONE: MACRO: } "." } ;
+
+ARTICLE: "macros" "Macros"
+"The " { $vocab-link "macros" } " vocabulary implements " { $emphasis "macros" } ", which are code transformations that may run at compile-time under the right circumstances."
+$nl
+"Macros can be used to implement combinators whose stack effects depend on an input parameter. Since macros are expanded at compile time, this permits the compiler to infer a static stack effect for the word calling the macro."
+$nl
+"Macros can also be used to calculate lookup tables and generate code at compile time, which can improve performance, raise the level of abstraction, and simplify code."
+$nl
+"Factor macros are similar to Lisp macros; they are not like C preprocessor macros."
+$nl
+"Defining new macros:"
+{ $subsections POSTPONE: MACRO: }
+"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion. The ordinary definition is only used from code compiled with the non-optimizing compiler. Under normal circumstances, macros should be used instead of compiler transforms; compiler transforms are only used for words such as " { $link cond } " which are frequently invoked during the bootstrap process, and this having a performant non-optimized definition which does not generate code on the fly is important."
+{ $subsections define-transform }
+{ $see-also "generalizations" "fry" } ;
+
+ABOUT: "macros"
--- /dev/null
+USING: tools.test macros math kernel arrays
+vectors io.streams.string prettyprint parser eval see
+stack-checker compiler.units definitions vocabs ;
+IN: macros.tests
+
+MACRO: see-test ( a b -- quot ) + ;
+
+{ t } [ \ see-test macro? ] unit-test
+
+{ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- quot ) + ;\n" }
+[ [ \ see-test see ] with-string-writer ]
+unit-test
+
+{ t } [ \ see-test macro? ] unit-test
+
+{ t } [
+ "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval( -- )
+ [ \ see-test see ] with-string-writer =
+] unit-test
+
+{ f } [ \ see-test macro? ] unit-test
+
+{ } [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- quot ) infer drop [ ] ;" eval( -- ) ] unit-test
+{ } [ "USING: macros kernel ; IN: hanging-macro : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
+
+{ } [ [ "hanging-macro" forget-vocab ] with-compilation-unit ] unit-test
+
+{ } [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ;" eval( -- ) ] unit-test
+ [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ; inline" eval( -- ) ] must-fail
+
+! The macro expander code should infer
+MACRO: bad-macro ( a -- b ) 1 2 3 [ ] ;
+
+! Must fail twice, and not memoize a bad result
+[ [ 0 bad-macro ] call ] must-fail
+[ [ 0 bad-macro ] call ] must-fail
+
+[ [ 0 bad-macro ] infer ] must-fail
+
+{ } [ [ \ bad-macro forget ] with-compilation-unit ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators compiler.units definitions effects
+effects.parser fry kernel memoize words ;
+IN: macros
+
+<PRIVATE
+
+: real-macro-effect ( effect -- effect' )
+ in>> { "quot" } <effect> ;
+
+: check-macro-effect ( word effect -- )
+ [ real-macro-effect ] keep 2dup effect=
+ [ 3drop ] [ bad-stack-effect ] if ;
+
+PRIVATE>
+
+: define-macro ( word definition effect -- )
+ {
+ [ nip check-macro-effect ]
+ [
+ [ '[ _ _ call-effect ] ] keep
+ [ memoize-quot '[ @ call ] ] keep
+ define-declared
+ ]
+ [ drop "macro" set-word-prop ]
+ [ 2drop changed-effect ]
+ } 3cleave ;
+
+PREDICATE: macro < word "macro" word-prop >boolean ;
+
+M: macro make-inline cannot-be-inline ;
+
+M: macro definer drop \ MACRO: \ ; ;
+
+M: macro definition "macro" word-prop ;
+
+M: macro reset-word
+ [ call-next-method ] [ f "macro" set-word-prop ] bi ;
+
+M: macro always-bump-effect-counter? drop t ;
--- /dev/null
+Utility for defining compiler transforms
--- /dev/null
+extensions
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+USING: help.syntax help.markup arrays sequences ;
+IN: math.ranges
+
+ARTICLE: "math.ranges" "Numeric ranges"
+"A " { $emphasis "range" } " is a virtual sequence with real number elements "
+"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } ". Ascending as well as descending ranges are supported."
+$nl
+"The class of ranges:"
+{ $subsections range }
+"Creating ranges with integer end-points. The standard mathematical convention is used, where " { $snippet "(" } " or " { $snippet ")" } " denotes that the end-point itself " { $emphasis "is not" } " part of the range; " { $snippet "[" } " or " { $snippet "]" } " denotes that the end-point " { $emphasis "is" } " part of the range:"
+{ $subsections
+ [a..b]
+ (a..b]
+ [a..b)
+ (a..b)
+ [0..b]
+ [1..b]
+ [0..b)
+}
+"Creating general ranges:"
+{ $subsections <range> }
+"Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example,"
+{ $code "3 10 [a..b] [ sqrt ] map" }
+"Computing the factorial of 100 with a descending range:"
+{ $code "100 1 [a..b] product" }
+"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link map! } "." ;
+
+ABOUT: "math.ranges"
--- /dev/null
+USING: arrays kernel math math.ranges sequences sets tools.test ;
+
+{ { } } [ 1 1 (a..b) >array ] unit-test
+{ { } } [ 1 1 (a..b] >array ] unit-test
+{ { } } [ 1 1 [a..b) >array ] unit-test
+{ { 1 } } [ 1 1 [a..b] >array ] unit-test
+
+{ { } } [ 1 2 (a..b) >array ] unit-test
+{ { 2 } } [ 1 2 (a..b] >array ] unit-test
+{ { 1 } } [ 1 2 [a..b) >array ] unit-test
+{ { 1 2 } } [ 1 2 [a..b] >array ] unit-test
+
+{ { } } [ 2 1 (a..b) >array ] unit-test
+{ { 1 } } [ 2 1 (a..b] >array ] unit-test
+{ { 2 } } [ 2 1 [a..b) >array ] unit-test
+{ { 2 1 } } [ 2 1 [a..b] >array ] unit-test
+
+{ { 1 2 3 4 5 } } [ 1 5 1 <range> >array ] unit-test
+{ { 5 4 3 2 1 } } [ 5 1 -1 <range> >array ] unit-test
+
+{ { 0 1/3 2/3 1 } } [ 0 1 1/3 <range> >array ] unit-test
+{ { 0 1/3 2/3 1 } } [ 1 0 -1/3 <range> >array reverse ] unit-test
+
+{ 0 } [ 0 -1 .0001 <range> length ] unit-test
+{ 0 } [ 0 -1 .5 <range> length ] unit-test
+{ 0 } [ 0 -1 1 <range> length ] unit-test
+{ 0 } [ 0 -1 2 <range> length ] unit-test
+{ 0 } [ 0 -1 3 <range> length ] unit-test
+{ 0 } [ 0 -1 4 <range> length ] unit-test
+
+{ 0 } [ 0 -2 .0001 <range> length ] unit-test
+{ 0 } [ 0 -2 1 <range> length ] unit-test
+{ 0 } [ 0 -2 2 <range> length ] unit-test
+{ 0 } [ 0 -2 3 <range> length ] unit-test
+{ 0 } [ 0 -2 4 <range> length ] unit-test
+
+{ 0 } [ -1 0 -.0001 <range> length ] unit-test
+{ 0 } [ -1 0 -.5 <range> length ] unit-test
+{ 0 } [ -1 0 -1 <range> length ] unit-test
+{ 0 } [ -1 0 -2 <range> length ] unit-test
+{ 0 } [ -1 0 -3 <range> length ] unit-test
+{ 0 } [ -1 0 -4 <range> length ] unit-test
+
+{ 0 } [ -2 0 -.0001 <range> length ] unit-test
+{ 0 } [ -2 0 -1 <range> length ] unit-test
+{ 0 } [ -2 0 -2 <range> length ] unit-test
+{ 0 } [ -2 0 -3 <range> length ] unit-test
+{ 0 } [ -2 0 -4 <range> length ] unit-test
+
+{ 100 } [
+ 1 100 [a..b] [ 2^ [1..b] ] map members length
+] unit-test
+
+{ t } [ -10 10 1 <range> [ sum ] [ >array sum ] bi = ] unit-test
+{ t } [ -10 10 2 <range> [ sum ] [ >array sum ] bi = ] unit-test
+{ t } [ 10 -10 -1 <range> [ sum ] [ >array sum ] bi = ] unit-test
+{ t } [ 10 -10 -2 <range> [ sum ] [ >array sum ] bi = ] unit-test
--- /dev/null
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes.tuple kernel math math.order sequences
+sequences.private ;
+IN: math.ranges
+
+TUPLE: range
+{ from read-only }
+{ length read-only }
+{ step read-only } ;
+
+<PRIVATE
+
+: sign/mod ( x y -- z w )
+ [ [ /i ] 2keep pick * - ] keep 0 < [ neg ] when ; inline
+
+PRIVATE>
+
+: <range> ( a b step -- range )
+ [ over - ] dip
+ [ sign/mod 0 < [ 1 + ] unless 0 max ] keep
+ range boa ; inline
+
+M: range length length>> ; inline
+
+M: range nth-unsafe
+ [ step>> * ] keep from>> + ; inline
+
+! We want M\ tuple hashcode, not M\ sequence hashcode here!
+! sequences hashcode is O(n) in number of elements
+M: range hashcode* tuple-hashcode ;
+
+INSTANCE: range immutable-sequence
+
+M: range sum [ length ] [ first ] [ last ] tri + * 2 / ;
+
+<PRIVATE
+
+: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
+
+: (a.. ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline
+
+: ..b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline
+
+PRIVATE>
+
+: [a..b] ( a b -- range ) twiddle <range> ; inline
+
+: (a..b] ( a b -- range ) twiddle (a.. <range> ; inline
+
+: [a..b) ( a b -- range ) twiddle ..b) <range> ; inline
+
+: (a..b) ( a b -- range ) twiddle (a.. ..b) <range> ; inline
+
+: [0..b] ( b -- range ) 0 swap [a..b] ; inline
+
+: [1..b] ( b -- range ) 1 swap [a..b] ; inline
+
+: [0..b) ( b -- range ) 0 swap [a..b) ; inline
+
+: [1..b) ( b -- range ) 1 swap [a..b) ; inline
+
+! backwards compatibility for new syntax
+ALIAS: [a,b] [a..b]
+ALIAS: (a,b] (a..b]
+ALIAS: [a,b) [a..b)
+ALIAS: (a,b) (a..b)
+ALIAS: [0,b] [0..b]
+ALIAS: [1,b] [1..b]
+ALIAS: [0,b) [0..b)
+ALIAS: [1,b) [1..b)
--- /dev/null
+Virtual sequence consisting of a range of numbers
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup words quotations effects ;
+IN: memoize
+
+ARTICLE: "memoize" "Memoization"
+"The " { $vocab-link "memoize" } " vocabulary implements a simple form of memoization, which is when a word caches results for every unique set of inputs that is supplied. Calling a memoized word with the same inputs more than once does not recalculate anything."
+$nl
+"Memoization is useful in situations where the set of possible inputs is small, but the results are expensive to compute and should be cached. Memoized words should not have any side effects."
+$nl
+"Defining a memoized word at parse time:"
+{ $subsections POSTPONE: MEMO: }
+"Defining a memoized word at run time:"
+{ $subsections define-memoized }
+"Clearing memoized results:"
+{ $subsections reset-memoized } ;
+
+ABOUT: "memoize"
+
+HELP: define-memoized
+{ $values { "word" word } { "quot" quotation } { "effect" effect } }
+{ $description "Defines the given word at run time as one which memoizes its outputs given a particular input." } ;
+
+HELP: MEMO:
+{ $syntax "MEMO: word ( stack -- effect ) definition... ;" }
+{ $values { "word" "a new word to define" } { "definition" "a word definition" } }
+{ $description "Defines the given word at parse time as one which memoizes its output given a particular input. The stack effect is mandatory." } ;
+
+{ define-memoized POSTPONE: MEMO: } related-words
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math kernel memoize tools.test parser generalizations
+prettyprint io.streams.string sequences eval namespaces see ;
+IN: memoize.tests
+
+MEMO: fib ( m -- n )
+ dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
+
+MEMO: x ( a b c d e -- f g h i j )
+ [ 1 + ] 4 ndip ;
+
+{ 89 } [ 10 fib ] unit-test
+
+{
+ 1 0 0 0 0
+ 1 0 0 0 0
+} [
+ 0 0 0 0 0 x
+ 0 0 0 0 0 x
+] unit-test
+
+MEMO: see-test ( a -- b ) reverse ;
+
+{ "USING: memoize sequences ;\nIN: memoize.tests\nMEMO: see-test ( a -- b ) reverse ;\n" }
+[ [ \ see-test see ] with-string-writer ]
+unit-test
+
+{ } [ "IN: memoize.tests : fib ( -- ) ;" eval( -- ) ] unit-test
+
+{ "IN: memoize.tests\n: fib ( -- ) ;\n" } [ [ \ fib see ] with-string-writer ] unit-test
+
+[ sq ] ( a -- b ) memoize-quot "q" set
+
+{ 9 } [ 3 "q" get call ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2010 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs definitions effects
+effects.parser fry hashtables.identity kernel kernel.private
+math sequences sequences.private words ;
+IN: memoize
+
+<PRIVATE
+
+! We can't use n*quot, narray and firstn from generalizations because
+! they're macros, and macros use memoize!
+: (n*quot) ( n quot -- quotquot )
+ <repetition> [ ] concat-as ;
+
+: [nsequence] ( length exemplar -- quot )
+ [ [ [ 1 - ] keep ] dip '[ _ _ _ new-sequence ] ]
+ [ drop [ [ set-nth-unsafe ] 2keep [ 1 - ] dip ] (n*quot) ] 2bi
+ [ nip ] 3append ;
+
+: [firstn] ( length -- quot )
+ [ 0 swap ] swap
+ [ [ nth-unsafe ] 2keep [ 1 + ] dip ] (n*quot)
+ [ 2drop ] 3append ;
+
+: packer ( seq -- quot )
+ length dup 4 <=
+ [ { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ]
+ [ { } [nsequence] ] if ;
+
+: unpacker ( seq -- quot )
+ length dup dup 4 <=
+ [ { [ drop ] [ ] [ first2-unsafe ] [ first3-unsafe ] [ first4-unsafe ] } nth ]
+ [ [firstn] ] if swap 1 >
+ [ [ { array } declare ] prepose ] when ;
+
+: pack/unpack ( quot effect -- newquot )
+ [ in>> packer ] [ out>> unpacker ] bi surround ;
+
+: unpack/pack ( quot effect -- newquot )
+ [ in>> unpacker ] [ out>> packer ] bi surround ;
+
+: make/n ( table quot effect -- quot )
+ [ unpack/pack '[ _ _ cache ] ] keep pack/unpack ;
+
+: make/0 ( table quot effect -- quot )
+ out>> [
+ packer '[
+ _ dup first-unsafe
+ [ ] [ @ @ [ 0 rot set-nth-unsafe ] keep ] ?if
+ ]
+ ] keep unpacker compose ;
+
+: make-memoizer ( table quot effect -- quot )
+ dup in>> length zero? [ make/0 ] [ make/n ] if ;
+
+PRIVATE>
+
+: (define-memoized) ( word quot effect hashtable -- )
+ [ [ drop "memo-quot" set-word-prop ] ] dip
+ '[ 2drop _ "memoize" set-word-prop ]
+ [ [ [ dup "memoize" word-prop ] 2dip make-memoizer ] keep define-declared ]
+ 3tri ;
+
+: define-memoized ( word quot effect -- )
+ dup in>> length zero? [ f 1array ] [ H{ } clone ] if
+ (define-memoized) ;
+
+: define-identity-memoized ( word quot effect -- )
+ dup in>> length zero? [ f 1array ] [ IH{ } clone ] if
+ (define-memoized) ;
+
+PREDICATE: memoized < word "memoize" word-prop >boolean ;
+
+M: memoized definer drop \ MEMO: \ ; ;
+
+M: memoized definition "memo-quot" word-prop ;
+
+M: memoized reset-word
+ [ call-next-method ]
+ [ { "memoize" "memo-quot" } remove-word-props ]
+ bi ;
+
+: memoize-quot ( quot effect -- memo-quot )
+ dup in>> length zero? [ f 1array ] [ H{ } clone ] if
+ -rot make-memoizer ;
+
+: reset-memoized ( word -- )
+ "memoize" word-prop dup sequence?
+ [ f swap set-first ] [ clear-assoc ] if ;
+
+: invalidate-memoized ( inputs... word -- )
+ [ stack-effect in>> packer call ]
+ [
+ "memoize" word-prop dup sequence?
+ [ f swap set-first ] [ delete-at ] if
+ ]
+ bi ;
+
+\ invalidate-memoized t "no-compile" set-word-prop
--- /dev/null
+Memoization
--- /dev/null
+extensions
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup kernel sequences quotations
+math arrays combinators ;
+IN: sequences.generalizations
+
+HELP: nsequence
+{ $values { "n" integer } { "seq" "an exemplar" } }
+{ $description "A generalization of " { $link 2sequence } ", "
+{ $link 3sequence } ", and " { $link 4sequence } " "
+"that constructs a sequence from the top " { $snippet "n" } " elements of the stack."
+}
+{ $examples
+ { $example "USING: prettyprint sequences.generalizations ;" "CHAR: f CHAR: i CHAR: s CHAR: h 4 \"\" nsequence ." "\"fish\"" }
+} ;
+
+HELP: narray
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link 1array } ", "
+{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "
+"that constructs an array from the top " { $snippet "n" } " elements of the stack."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link narray } ":"
+ { $table
+ { { $link 1array } { $snippet "1 narray" } }
+ { { $link 2array } { $snippet "2 narray" } }
+ { { $link 3array } { $snippet "3 narray" } }
+ { { $link 4array } { $snippet "4 narray" } }
+ }
+} ;
+
+{ nsequence narray } related-words
+
+HELP: firstn
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link first } ", "
+{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "
+"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link firstn } ":"
+ { $table
+ { { $link first } { $snippet "1 firstn" } }
+ { { $link first2 } { $snippet "2 firstn" } }
+ { { $link first3 } { $snippet "3 firstn" } }
+ { { $link first4 } { $snippet "4 firstn" } }
+ }
+} ;
+
+HELP: ?firstn
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link ?first } " that pushes the first " { $snippet "n" } " elements of a sequence on the stack, or " { $link f } " if the sequence is shorter than the requested number of elements." }
+{ $examples
+ "Some core words expressed in terms of " { $link ?firstn } ":"
+ { $table
+ { { $link ?first } { $snippet "1 ?firstn" } }
+ }
+} ;
+
+HELP: set-firstn
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link set-first } " "
+"that sets the first " { $snippet "n" } " elements of a sequence from the top " { $snippet "n" } " elements of the stack." } ;
+
+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: math prettyprint sequences.generalizations ;"
+ "{ 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: math prettyprint sequences.generalizations ;"
+ "{ 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: neach
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ) } } { "n" integer } }
+{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
+
+HELP: nmap
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- result ) } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
+{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
+
+HELP: nmap-as
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- result ) } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
+{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
+
+HELP: mnmap
+{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" { $quotation ( m*element -- result*n ) } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }
+{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ;
+
+HELP: mnmap-as
+{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" { $quotation ( m*element -- result*n ) } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
+{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ;
+
+HELP: nproduce
+{ $values { "pred" { $quotation ( -- ? ) } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "n" integer } { "seq..." { $snippet "n" } " arrays on the datastack" } }
+{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
+
+HELP: nproduce-as
+{ $values { "pred" { $quotation ( -- ? ) } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "exemplar..." { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
+{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
+
+HELP: nmap-reduce
+{ $values { "map-quot" { $quotation ( element... -- intermediate ) } } { "reduce-quot" { $quotation ( prev intermediate -- next ) } } { "n" integer } }
+{ $description "A generalization of " { $link map-reduce } " that can be applied to any number of sequences." } ;
+
+HELP: nall?
+{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "?" boolean } }
+{ $description "A generalization of " { $link all? } " that can be applied to any number of sequences." } ;
+
+HELP: nfind
+{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "i" integer } { "elts..." { $snippet "n" } " elements on the datastack" } }
+{ $description "A generalization of " { $link find } " that can be applied to any number of sequences." } ;
+
+HELP: nany?
+{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "?" boolean } }
+{ $description "A generalization of " { $link any? } " that can be applied to any number of sequences." } ;
+
+ARTICLE: "sequences.generalizations" "Generalized sequence words"
+"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of various sequence operations."
+{ $subsections
+ narray
+ nsequence
+ firstn
+ set-firstn
+ nappend
+ nappend-as
+}
+"Generalized " { $link "sequences-combinators" } ":"
+{ $subsections
+ neach
+ nmap
+ nmap-as
+ mnmap
+ mnmap-as
+ nproduce
+ nproduce-as
+} ;
+
+ABOUT: "sequences.generalizations"
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test generalizations kernel math arrays sequences
+sequences.generalizations ascii fry math.parser io io.streams.string ;
+IN: sequences.generalizations.tests
+
+{ 1 2 3 4 } [ { 1 2 3 4 } 4 firstn ] unit-test
+{ { 1 2 3 4 } } [ 1 2 3 4 { f f f f } [ 4 set-firstn ] keep ] unit-test
+[ 1 2 3 4 { f f f } [ 4 set-firstn ] keep ] must-fail
+{ } [ { } 0 firstn ] unit-test
+{ "a" } [ { "a" } 1 firstn ] unit-test
+
+{ } [ { } 0 ?firstn ] unit-test
+{ f } [ { } 1 ?firstn ] unit-test
+{ f f } [ { } 2 ?firstn ] unit-test
+{ 1 f } [ { 1 } 2 ?firstn ] unit-test
+{ 1 2 } [ { 1 2 } 2 ?firstn ] unit-test
+{ 1 2 } [ { 1 2 3 } 2 ?firstn ] unit-test
+
+{ [ 1 2 ] } [ 1 2 2 [ ] nsequence ] unit-test
+{ { 1 2 3 4 5 } } [ 1 2 3 4 5 { 0 0 0 0 0 } 5 (nsequence) ] 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
+
+: neach-test ( a b c d -- )
+ [ 4 nappend print ] 4 neach ;
+: nmap-test ( a b c d -- e )
+ [ 4 nappend ] 4 nmap ;
+: nmap-as-test ( a b c d -- e )
+ [ 4 nappend ] [ ] 4 nmap-as ;
+: mnmap-3-test ( a b c d -- e f g )
+ [ append ] 4 3 mnmap ;
+: mnmap-2-test ( a b c d -- e f )
+ [ [ append ] 2bi@ ] 4 2 mnmap ;
+: mnmap-as-test ( a b c d -- e f )
+ [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;
+: mnmap-1-test ( a b c d -- e )
+ [ 4 nappend ] 4 1 mnmap ;
+: mnmap-0-test ( a b c d -- )
+ [ 4 nappend print ] 4 0 mnmap ;
+: nproduce-as-test ( n -- a b )
+ [ dup zero? not ]
+ [ [ 2 - ] [ ] [ 1 - ] tri ] { } B{ } 2 nproduce-as nipd ;
+: nproduce-test ( n -- a b )
+ [ dup zero? not ]
+ [ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce nipd ;
+
+{ "A1a!
+B2b@
+C3c#
+D4d$
+" } [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ [ neach-test ] with-string-writer
+] unit-test
+
+{ { "A1a!" "B2b@" "C3c#" "D4d$" } }
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ nmap-test
+] unit-test
+
+{ [ "A1a!" "B2b@" "C3c#" "D4d$" ] }
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ nmap-as-test
+] unit-test
+
+{
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a!" "b@" "c#" "d$" }
+} [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-3-test
+] unit-test
+
+{
+ { "A1" "B2" "C3" "D4" }
+ { "a!" "b@" "c#" "d$" }
+} [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-2-test
+] unit-test
+
+{
+ { "A1" "B2" "C3" "D4" }
+ [ "a!" "b@" "c#" "d$" ]
+} [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-as-test
+] unit-test
+
+{ { "A1a!" "B2b@" "C3c#" "D4d$" } }
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-1-test
+] unit-test
+
+{ "A1a!
+B2b@
+C3c#
+D4d$
+" } [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ [ mnmap-0-test ] with-string-writer
+] unit-test
+
+{ { 10 8 6 4 2 } B{ 9 7 5 3 1 } }
+[ 10 nproduce-as-test ] unit-test
+
+{ { 10 8 6 4 2 } { 9 7 5 3 1 } }
+[ 10 nproduce-test ] unit-test
+
+{ 45 } [
+ { 1 2 3 } { 4 5 6 } { 7 8 9 } [ + + ] [ + ] 3 nmap-reduce
+] unit-test
+
+{ t } [
+ { 1 3 5 } { 2 4 6 } { 4 8 12 } [ + + odd? ] 3 nall?
+] unit-test
+
+{ t } [
+ { 2 4 5 } { 4 6 7 } { 6 8 9 }
+ [ [ odd? ] tri@ and and ] 3 nany?
+] unit-test
+
+{ f } [
+ { 1 2 3 } { 4 5 6 } { 7 8 9 }
+ [ [ odd? ] tri@ and and ] 3 nany?
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators fry generalizations kernel macros math
+math.order memoize.private quotations sequences
+sequences.private ;
+IN: sequences.generalizations
+
+MACRO: (nsequence) ( n -- quot )
+ <iota> reverse [ '[ [ _ swap set-nth-unsafe ] keep ] ] map concat ;
+
+MACRO: nsequence ( n exemplar -- quot )
+ [ [nsequence] ] keep '[ @ _ like ] ;
+
+MACRO: narray ( n -- quot )
+ '[ _ { } nsequence ] ;
+
+MACRO: firstn-unsafe ( n -- quot )
+ [firstn] ;
+
+MACRO: firstn ( n -- quot )
+ [ [ drop ] ] [
+ [ 1 - swap bounds-check 2drop ]
+ [ firstn-unsafe ]
+ bi-curry '[ _ _ bi ]
+ ] if-zero ;
+
+MACRO: set-firstn-unsafe ( n -- quot )
+ [ 1 + ]
+ [ <iota> [ '[ _ rot [ set-nth-unsafe ] keep ] ] map ] bi
+ '[ _ -nrot _ spread drop ] ;
+
+MACRO: set-firstn ( n -- quot )
+ [ [ drop ] ] [
+ [ 1 - swap bounds-check 2drop ]
+ [ set-firstn-unsafe ]
+ bi-curry '[ _ _ bi ]
+ ] if-zero ;
+
+MACRO: ?firstn ( n -- quot )
+ dup '[ _ f pad-tail _ firstn-unsafe ] ;
+
+: nappend ( n -- seq ) narray concat ; inline
+
+: nappend-as ( n exemplar -- seq )
+ [ narray ] [ concat-as ] bi* ; inline
+
+MACRO: nmin-length ( n -- quot )
+ dup 1 - [ min ] n*quot
+ '[ [ length ] _ napply @ ] ;
+
+: nnth ( n seq... n -- )
+ [ nth ] swap [ apply-curry ] [ cleave* ] bi ; inline
+
+: nnth-unsafe ( n seq... n -- )
+ [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
+
+MACRO: nset-nth-unsafe ( n -- quot )
+ [ [ drop ] ]
+ [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
+ if-zero ;
+
+: (neach) ( seq... quot n -- len quot' )
+ dup dup dup
+ '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
+
+: neach ( seq... quot n -- )
+ (neach) each-integer ; inline
+
+: nmap-as ( seq... quot exemplar n -- result )
+ '[ _ (neach) ] dip map-integers ; inline
+
+: nmap ( seq... quot n -- result )
+ dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
+
+MACRO: nnew-sequence ( n -- quot )
+ [ [ drop ] ]
+ [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
+
+: nnew-like ( len exemplar... quot n -- result... )
+ 5 dupn '[
+ _ nover
+ [ [ _ nnew-sequence ] dip call ]
+ _ ndip [ like ]
+ _ apply-curry
+ _ spread*
+ ] call ; inline
+
+MACRO: (ncollect) ( n -- quot )
+ 3 dupn 1 +
+ '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
+
+: ncollect ( len quot into... n -- )
+ (ncollect) each-integer ; inline
+
+: nmap-integers ( len quot exemplar... n -- result... )
+ 4 dupn
+ '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
+
+: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
+ dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
+
+: mnmap ( m*seq quot m n -- result*n )
+ 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
+
+: ncollector-as ( quot exemplar... n -- quot' vec... )
+ 5 dupn '[
+ [ [ length ] keep new-resizable ] _ napply
+ [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
+ ] call ; inline
+
+: ncollector ( quot n -- quot' vec... )
+ [ V{ } swap dupn ] keep ncollector-as ; inline
+
+: nproduce-as ( pred quot exemplar... n -- seq... )
+ 7 dupn '[
+ _ ndup
+ [ _ ncollector-as [ while ] _ ndip ]
+ _ ncurry _ ndip
+ [ like ] _ apply-curry _ spread*
+ ] call ; inline
+
+: nproduce ( pred quot n -- seq... )
+ [ { } swap dupn ] keep nproduce-as ; inline
+
+MACRO: nmap-reduce ( map-quot reduce-quot n -- quot )
+ -rot dupd compose overd over '[
+ [ [ first ] _ napply @ 1 ] _ nkeep
+ _ _ (neach) (each-integer)
+ ] ;
+
+: nall? ( seqs... quot n -- ? )
+ (neach) all-integers? ; inline
+
+MACRO: finish-nfind ( n -- quot )
+ [ 1 + ] keep dup dup dup f <array> >quotation '[
+ _ npick
+ [ [ dup ] _ ndip _ nnth-unsafe ]
+ [ _ ndrop @ ]
+ if
+ ] ;
+
+: (nfind) ( seqs... quot n quot' -- i elts... )
+ over
+ [ '[ _ _ (neach) @ ] ] dip
+ [ '[ _ finish-nfind ] ] keep
+ nbi ; inline
+
+: nfind ( seqs... quot n -- i elts... )
+ [ find-integer ] (nfind) ; inline
+
+: nany? ( seqs... quot n -- ? )
+ [ nfind ] [ ndrop ] bi >boolean ; inline
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: summary
+USING: kernel strings help.markup help.syntax ;
+
+ARTICLE: "summary" "Converting objects to summary strings"
+"A word for getting very brief descriptions of words and general objects:"
+{ $subsections summary } ;
+
+HELP: summary
+{ $values { "object" object } { "string" string } }
+{ $contract "Outputs a brief description of the object." }
+{ $notes "New methods can be defined by user code. Most often, this is used with error classes so that " { $link "debugger" } " can print friendlier error messages." } ;
+
+ABOUT: "summary"
--- /dev/null
+USING: combinators continuations kernel summary tools.test ;
+IN: summary.tests
+
+{ "array with 2 elements" } [ { 1 2 } summary ] unit-test
+{ "string with 5 code points" } [ "hello" summary ] unit-test
+{ "hash-set with 3 members" } [ HS{ 1 2 3 } summary ] unit-test
+{ "hashtable with 1 entries" } [ H{ { 3 4 } } summary ] unit-test
+{ "Quotation's stack effect does not match call site" } [
+ [ [ ] f wrong-values ] [ ] recover summary
+] unit-test
+
+TUPLE: ooga-booga ;
+{ "ooga-booga" } [ ooga-booga boa summary ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs classes continuations kernel make math
+math.parser sequences sets strings ;
+IN: summary
+
+GENERIC: summary ( object -- string )
+
+: object-summary ( object -- string ) class-of name>> ; inline
+
+: container-summary ( obj size word -- str )
+ [ object-summary ] 2dip [
+ [ % " with " % ] [ # ] [ " " % % ] tri*
+ ] "" make ;
+
+GENERIC: tuple-summary ( object -- string )
+
+M: assoc tuple-summary
+ dup assoc-size "entries" container-summary ;
+
+M: object tuple-summary
+ object-summary ;
+
+M: set tuple-summary
+ dup cardinality "members" container-summary ;
+
+M: tuple summary
+ tuple-summary ;
+
+M: object summary object-summary ;
+
+M: sequence summary
+ dup length "elements" container-summary ;
+
+M: string summary
+ dup length "code points" container-summary ;
+
+! Override sequence => integer instance
+M: f summary object-summary ;
+
+M: integer summary object-summary ;
+
+: safe-summary ( object -- string )
+ [ summary ]
+ [ drop object-summary "~summary error: " "~" surround ]
+ recover ;
--- /dev/null
+Generic word for converting an object into a brief one-line string
projects / factor.git / commitdiff