Merge branch 'master' of git://factorcode.org/git/factor
						commit
						f67e583d27
					
				| 
						 | 
				
			
			@ -52,17 +52,17 @@ HELP: 3||
 | 
			
		|||
     { "quot" quotation } }
 | 
			
		||||
{ $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&&-rewrite
 | 
			
		||||
HELP: n&&
 | 
			
		||||
{ $values
 | 
			
		||||
     { "quots" "a sequence of quotations" } { "N" integer }
 | 
			
		||||
     { "quot" quotation } }
 | 
			
		||||
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ;
 | 
			
		||||
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
 | 
			
		||||
 | 
			
		||||
HELP: n||-rewrite
 | 
			
		||||
HELP: n||
 | 
			
		||||
{ $values
 | 
			
		||||
     { "quots" "a sequence of quotations" } { "N" integer }
 | 
			
		||||
     { "quots" "a sequence of quotations" } { "n" integer }
 | 
			
		||||
     { "quot" quotation } }
 | 
			
		||||
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR 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
 | 
			
		||||
| 
						 | 
				
			
			@ -77,8 +77,8 @@ ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
 | 
			
		|||
{ $subsection 2|| }
 | 
			
		||||
{ $subsection 3|| }
 | 
			
		||||
"Generalized combinators:"
 | 
			
		||||
{ $subsection n&&-rewrite }
 | 
			
		||||
{ $subsection n||-rewrite }
 | 
			
		||||
{ $subsection n&& }
 | 
			
		||||
{ $subsection n|| }
 | 
			
		||||
;
 | 
			
		||||
 | 
			
		||||
ABOUT: "combinators.short-circuit"
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,35 +1,26 @@
 | 
			
		|||
 | 
			
		||||
USING: kernel combinators quotations arrays sequences assocs
 | 
			
		||||
       locals generalizations macros fry ;
 | 
			
		||||
 | 
			
		||||
locals generalizations macros fry ;
 | 
			
		||||
IN: combinators.short-circuit
 | 
			
		||||
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
MACRO:: n&& ( quots n -- quot )
 | 
			
		||||
    [ f ]
 | 
			
		||||
    quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
 | 
			
		||||
    [ n nnip ] suffix 1array
 | 
			
		||||
    [ cond ] 3append ;
 | 
			
		||||
 | 
			
		||||
:: n&&-rewrite ( quots N -- quot )
 | 
			
		||||
   quots
 | 
			
		||||
     [ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
 | 
			
		||||
   map
 | 
			
		||||
   [ t ] [ N nnip ] 2array suffix
 | 
			
		||||
   '[ f _ cond ] ;
 | 
			
		||||
MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
 | 
			
		||||
MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
 | 
			
		||||
MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
 | 
			
		||||
MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
 | 
			
		||||
 | 
			
		||||
MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
 | 
			
		||||
MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
 | 
			
		||||
MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ;
 | 
			
		||||
MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ;
 | 
			
		||||
MACRO:: n|| ( quots n -- quot )
 | 
			
		||||
    [ f ]
 | 
			
		||||
    quots
 | 
			
		||||
    [| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
 | 
			
		||||
    { [ drop n ndrop t ] [ f ] } suffix 1array
 | 
			
		||||
    [ cond ] 3append ;
 | 
			
		||||
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
 | 
			
		||||
:: n||-rewrite ( quots N -- quot )
 | 
			
		||||
   quots
 | 
			
		||||
     [ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
 | 
			
		||||
   map
 | 
			
		||||
   [ drop N ndrop t ] [ f ] 2array suffix
 | 
			
		||||
   '[ f _ cond ] ;
 | 
			
		||||
 | 
			
		||||
MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
 | 
			
		||||
MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
 | 
			
		||||
MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ;
 | 
			
		||||
MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ;
 | 
			
		||||
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
 | 
			
		||||
MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
 | 
			
		||||
MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
 | 
			
		||||
MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,7 +1,5 @@
 | 
			
		|||
 | 
			
		||||
USING: kernel sequences math stack-checker effects accessors macros
 | 
			
		||||
       combinators.short-circuit ;
 | 
			
		||||
 | 
			
		||||
fry combinators.short-circuit ;
 | 
			
		||||
IN: combinators.short-circuit.smart
 | 
			
		||||
 | 
			
		||||
<PRIVATE
 | 
			
		||||
| 
						 | 
				
			
			@ -13,6 +11,6 @@ IN: combinators.short-circuit.smart
 | 
			
		|||
 | 
			
		||||
PRIVATE>
 | 
			
		||||
 | 
			
		||||
MACRO: && ( quots -- quot ) dup arity n&&-rewrite ;
 | 
			
		||||
MACRO: && ( quots -- quot ) dup arity '[ _ _ n&& ] ;
 | 
			
		||||
 | 
			
		||||
MACRO: || ( quots -- quot ) dup arity n||-rewrite ;
 | 
			
		||||
MACRO: || ( quots -- quot ) dup arity '[ _ _ n|| ] ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -2,7 +2,7 @@
 | 
			
		|||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: assocs classes classes.algebra classes.tuple
 | 
			
		||||
classes.tuple.private kernel accessors math math.intervals
 | 
			
		||||
namespaces sequences words combinators combinators.short-circuit
 | 
			
		||||
namespaces sequences words combinators
 | 
			
		||||
arrays compiler.tree.propagation.copy ;
 | 
			
		||||
IN: compiler.tree.propagation.info
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -253,12 +253,13 @@ DEFER: (value-info-union)
 | 
			
		|||
        { [ over not ] [ 2drop f ] }
 | 
			
		||||
        [
 | 
			
		||||
            {
 | 
			
		||||
                [ [ class>> ] bi@ class<= ]
 | 
			
		||||
                [ [ interval>> ] bi@ interval-subset? ]
 | 
			
		||||
                [ literals<= ]
 | 
			
		||||
                [ [ length>> ] bi@ value-info<= ]
 | 
			
		||||
                [ [ slots>> ] bi@ [ value-info<= ] 2all? ]
 | 
			
		||||
            } 2&&
 | 
			
		||||
                { [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
 | 
			
		||||
                { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
 | 
			
		||||
                { [ 2dup literals<= not ] [ f ] }
 | 
			
		||||
                { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
 | 
			
		||||
                { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
 | 
			
		||||
                [ t ]
 | 
			
		||||
            } cond 2nip
 | 
			
		||||
        ]
 | 
			
		||||
    } cond ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -351,7 +351,7 @@ big-endian on
 | 
			
		|||
    7 6 4 SUBF
 | 
			
		||||
    5 ds-reg -4 STW
 | 
			
		||||
    7 ds-reg 0 STW
 | 
			
		||||
] f f f \ fixnum-/mod-fast define-sub-primitive
 | 
			
		||||
] f f f \ fixnum/mod-fast define-sub-primitive
 | 
			
		||||
 | 
			
		||||
[
 | 
			
		||||
    3 ds-reg 0 LWZ
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
Marc Fauconneau
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1,16 @@
 | 
			
		|||
USING: editors io.files io.launcher kernel math.parser
 | 
			
		||||
namespaces sequences windows.shell32 make ;
 | 
			
		||||
IN: editors.notepad2
 | 
			
		||||
 | 
			
		||||
: notepad2-path ( -- str )
 | 
			
		||||
    \ notepad2-path get-global [
 | 
			
		||||
        program-files "C:\\Windows\\system32\\notepad.exe" append-path
 | 
			
		||||
   ] unless* ;
 | 
			
		||||
 | 
			
		||||
: notepad2 ( file line -- )
 | 
			
		||||
    [
 | 
			
		||||
        notepad2-path ,
 | 
			
		||||
        "/g" , number>string , ,
 | 
			
		||||
    ] { } make run-detached drop ;
 | 
			
		||||
 | 
			
		||||
[ notepad2 ] edit-hook set-global
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
Notepad2 editor integration
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
unportable
 | 
			
		||||
| 
						 | 
				
			
			@ -19,6 +19,9 @@ HELP: '[
 | 
			
		|||
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
 | 
			
		||||
{ $examples "See " { $link "fry.examples" } "." } ;
 | 
			
		||||
 | 
			
		||||
HELP: >r/r>-in-fry-error
 | 
			
		||||
{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to " { $link >r } " or " { $link r> } ". Explicit retain stack manipulation of this form does not work with fry; use " { $link dip } " instead." } ;
 | 
			
		||||
 | 
			
		||||
ARTICLE: "fry.examples" "Examples of fried quotations"
 | 
			
		||||
"The easiest way to understand fried quotations is to look at some examples."
 | 
			
		||||
$nl
 | 
			
		||||
| 
						 | 
				
			
			@ -73,7 +76,10 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
 | 
			
		|||
} ;
 | 
			
		||||
 | 
			
		||||
ARTICLE: "fry.limitations" "Fried quotation limitations"
 | 
			
		||||
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;
 | 
			
		||||
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead."
 | 
			
		||||
$nl
 | 
			
		||||
"An error thrown if a fried quotation contains calls to " { $link >r } " and " { $link r> } ":"
 | 
			
		||||
{ $subsection >r/r>-in-fry-error } ;
 | 
			
		||||
 | 
			
		||||
ARTICLE: "fry" "Fried quotations"
 | 
			
		||||
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,23 +1,20 @@
 | 
			
		|||
IN: fry.tests
 | 
			
		||||
USING: fry tools.test math prettyprint kernel io arrays
 | 
			
		||||
sequences ;
 | 
			
		||||
sequences eval accessors ;
 | 
			
		||||
 | 
			
		||||
[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
 | 
			
		||||
 | 
			
		||||
[ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test
 | 
			
		||||
 | 
			
		||||
[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
 | 
			
		||||
[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
 | 
			
		||||
 | 
			
		||||
[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
 | 
			
		||||
[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
 | 
			
		||||
 | 
			
		||||
[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
 | 
			
		||||
[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
 | 
			
		||||
 | 
			
		||||
[ [ "a" write "b" print ] ]
 | 
			
		||||
[ [ "a" "b" [ write ] dip print ] ]
 | 
			
		||||
[ "a" "b" '[ _ write _ print ] ] unit-test
 | 
			
		||||
 | 
			
		||||
[ [ 1 2 + 3 4 - ] ]
 | 
			
		||||
[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
 | 
			
		||||
 | 
			
		||||
[ 1/2 ] [
 | 
			
		||||
    1 '[ [ _ ] dip / ] 2 swap call
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			@ -58,3 +55,10 @@ sequences ;
 | 
			
		|||
[ { { { 3 } } } ] [
 | 
			
		||||
    3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ "USING: fry kernel ; f '[ >r _ r> ]" eval ]
 | 
			
		||||
[ error>> >r/r>-in-fry-error? ] must-fail-with
 | 
			
		||||
 | 
			
		||||
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
 | 
			
		||||
    1 2 3 4 '[ "a" _ 2array "b" _ 2array "c" _ 2array "d" _ 2array 4array ] call
 | 
			
		||||
] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,33 +1,37 @@
 | 
			
		|||
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: kernel sequences combinators parser splitting math
 | 
			
		||||
quotations arrays make words ;
 | 
			
		||||
quotations arrays make words locals.backend summary sets ;
 | 
			
		||||
IN: fry
 | 
			
		||||
 | 
			
		||||
: _ ( -- * ) "Only valid inside a fry" throw ;
 | 
			
		||||
: @ ( -- * ) "Only valid inside a fry" throw ;
 | 
			
		||||
 | 
			
		||||
ERROR: >r/r>-in-fry-error ;
 | 
			
		||||
 | 
			
		||||
<PRIVATE
 | 
			
		||||
 | 
			
		||||
DEFER: (shallow-fry)
 | 
			
		||||
DEFER: shallow-fry
 | 
			
		||||
: [ncurry] ( n -- quot )
 | 
			
		||||
    {
 | 
			
		||||
        { 0 [ [ ] ] }
 | 
			
		||||
        { 1 [ [ curry ] ] }
 | 
			
		||||
        { 2 [ [ 2curry ] ] }
 | 
			
		||||
        { 3 [ [ 3curry ] ] }
 | 
			
		||||
        [ \ curry <repetition> ]
 | 
			
		||||
    } case ;
 | 
			
		||||
 | 
			
		||||
: ((shallow-fry)) ( accum quot adder -- result )
 | 
			
		||||
    >r shallow-fry r>
 | 
			
		||||
    append swap [
 | 
			
		||||
        [ prepose ] curry append
 | 
			
		||||
    ] unless-empty ; inline
 | 
			
		||||
M: >r/r>-in-fry-error summary
 | 
			
		||||
    drop
 | 
			
		||||
    "Explicit retain stack manipulation is not permitted in fried quotations" ;
 | 
			
		||||
 | 
			
		||||
: (shallow-fry) ( accum quot -- result )
 | 
			
		||||
    [ 1quotation ] [
 | 
			
		||||
        unclip {
 | 
			
		||||
            { \ _ [ [ curry ] ((shallow-fry)) ] }
 | 
			
		||||
            { \ @ [ [ compose ] ((shallow-fry)) ] }
 | 
			
		||||
            [ swap >r suffix r> (shallow-fry) ]
 | 
			
		||||
        } case
 | 
			
		||||
    ] if-empty ;
 | 
			
		||||
: check-fry ( quot -- quot )
 | 
			
		||||
    dup { >r r> load-locals get-local drop-locals } intersect
 | 
			
		||||
    empty? [ >r/r>-in-fry-error ] unless ;
 | 
			
		||||
 | 
			
		||||
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
 | 
			
		||||
: shallow-fry ( quot -- quot' )
 | 
			
		||||
    check-fry
 | 
			
		||||
    [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
 | 
			
		||||
    { _ } split [ length 1- [ncurry] ] [ spread>quot ] bi prefix ;
 | 
			
		||||
 | 
			
		||||
PREDICATE: fry-specifier < word { _ @ } memq? ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -36,3 +36,5 @@ IN: generalizations.tests
 | 
			
		|||
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
 | 
			
		||||
[ ] [ { } 0 firstn ] unit-test
 | 
			
		||||
[ "a" ] [ { "a" } 1 firstn ] unit-test
 | 
			
		||||
 | 
			
		||||
[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -6,8 +6,11 @@ math.ranges combinators macros quotations fry arrays ;
 | 
			
		|||
IN: generalizations
 | 
			
		||||
 | 
			
		||||
MACRO: nsequence ( n seq -- quot )
 | 
			
		||||
    [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
 | 
			
		||||
    [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce ;
 | 
			
		||||
    [
 | 
			
		||||
        [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
 | 
			
		||||
        [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
 | 
			
		||||
    ] keep
 | 
			
		||||
    '[ @ _ like ] ;
 | 
			
		||||
 | 
			
		||||
MACRO: narray ( n -- quot )
 | 
			
		||||
    '[ _ { } nsequence ] ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -132,8 +132,8 @@ $nl
 | 
			
		|||
"Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ;
 | 
			
		||||
 | 
			
		||||
ARTICLE: "locals-limitations" "Limitations of locals"
 | 
			
		||||
"The first limitation is that the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator."
 | 
			
		||||
$nl
 | 
			
		||||
"The first limitation is also shared by " { $vocab-link "fry" } ": the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator. An error is thrown at parse time if an attempt is made to use " { $link >r } " and " { $link r> } " inside a lambda body:"
 | 
			
		||||
{ $subsection >r/r>-in-lambda-error }
 | 
			
		||||
"Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:"
 | 
			
		||||
{ $code
 | 
			
		||||
    ":: good-cond-usage ( a -- ... )"
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -2,7 +2,7 @@ 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 ;
 | 
			
		||||
definitions compiler.units fry ;
 | 
			
		||||
IN: locals.tests
 | 
			
		||||
 | 
			
		||||
:: foo ( a b -- a a ) a a ;
 | 
			
		||||
| 
						 | 
				
			
			@ -286,6 +286,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 | 
			
		|||
        { [ a b > ] [ 5 ] }
 | 
			
		||||
    } cond ;
 | 
			
		||||
 | 
			
		||||
\ cond-test must-infer
 | 
			
		||||
 | 
			
		||||
[ 3 ] [ 1 2 cond-test ] unit-test
 | 
			
		||||
[ 4 ] [ 2 2 cond-test ] unit-test
 | 
			
		||||
[ 5 ] [ 3 2 cond-test ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			@ -293,6 +295,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 | 
			
		|||
:: 0&&-test ( a -- ? )
 | 
			
		||||
    { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
 | 
			
		||||
 | 
			
		||||
\ 0&&-test must-infer
 | 
			
		||||
 | 
			
		||||
[ f ] [ 1.5 0&&-test ] unit-test
 | 
			
		||||
[ f ] [ 3 0&&-test ] unit-test
 | 
			
		||||
[ f ] [ 8 0&&-test ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			@ -301,6 +305,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 | 
			
		|||
:: &&-test ( a -- ? )
 | 
			
		||||
    { [ a integer? ] [ a even? ] [ a 10 > ] } && ;
 | 
			
		||||
 | 
			
		||||
\ &&-test must-infer
 | 
			
		||||
 | 
			
		||||
[ f ] [ 1.5 &&-test ] unit-test
 | 
			
		||||
[ f ] [ 3 &&-test ] unit-test
 | 
			
		||||
[ f ] [ 8 &&-test ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			@ -346,6 +352,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 | 
			
		|||
 | 
			
		||||
{ 3 1 } [| from to seq | T{ slice f from to seq } ] 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 )
 | 
			
		||||
    { } V{ } ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -390,6 +400,18 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 | 
			
		|||
 | 
			
		||||
[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
 | 
			
		||||
 | 
			
		||||
[
 | 
			
		||||
    "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
 | 
			
		||||
] [ error>> >r/r>-in-fry-error? ] must-fail-with
 | 
			
		||||
 | 
			
		||||
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
 | 
			
		||||
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
 | 
			
		||||
 | 
			
		||||
\ funny-macro-test must-infer
 | 
			
		||||
 | 
			
		||||
[ t ] [ 3 funny-macro-test ] unit-test
 | 
			
		||||
[ f ] [ 2 funny-macro-test ] unit-test
 | 
			
		||||
 | 
			
		||||
! :: wlet-&&-test ( a -- ? )
 | 
			
		||||
!     [wlet | is-integer? [ a integer? ]
 | 
			
		||||
!             is-even? [ a even? ]
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -6,12 +6,18 @@ quotations debugger macros arrays macros splitting combinators
 | 
			
		|||
prettyprint.backend definitions prettyprint hashtables
 | 
			
		||||
prettyprint.sections sets sequences.private effects
 | 
			
		||||
effects.parser generic generic.parser compiler.units accessors
 | 
			
		||||
locals.backend memoize macros.expander lexer classes ;
 | 
			
		||||
locals.backend memoize macros.expander lexer classes summary ;
 | 
			
		||||
IN: locals
 | 
			
		||||
 | 
			
		||||
! Inspired by
 | 
			
		||||
! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
 | 
			
		||||
 | 
			
		||||
ERROR: >r/r>-in-lambda-error ;
 | 
			
		||||
 | 
			
		||||
M: >r/r>-in-lambda-error summary
 | 
			
		||||
    drop
 | 
			
		||||
    "Explicit retain stack manipulation is not permitted in lambda bodies" ;
 | 
			
		||||
 | 
			
		||||
<PRIVATE
 | 
			
		||||
 | 
			
		||||
TUPLE: lambda vars body ;
 | 
			
		||||
| 
						 | 
				
			
			@ -141,20 +147,17 @@ GENERIC: free-vars* ( form -- )
 | 
			
		|||
: free-vars ( form -- vars )
 | 
			
		||||
    [ free-vars* ] { } make prune ;
 | 
			
		||||
 | 
			
		||||
: add-if-free ( object -- )
 | 
			
		||||
    {
 | 
			
		||||
        { [ dup local-writer? ] [ "local-reader" word-prop , ] }
 | 
			
		||||
        { [ dup lexical? ] [ , ] }
 | 
			
		||||
        { [ dup quote? ] [ local>> , ] }
 | 
			
		||||
        { [ t ] [ free-vars* ] }
 | 
			
		||||
    } cond ;
 | 
			
		||||
M: local-writer free-vars* "local-reader" word-prop , ;
 | 
			
		||||
 | 
			
		||||
M: lexical free-vars* , ;
 | 
			
		||||
 | 
			
		||||
M: quote free-vars* , ;
 | 
			
		||||
 | 
			
		||||
M: object free-vars* drop ;
 | 
			
		||||
 | 
			
		||||
M: quotation free-vars* [ add-if-free ] each ;
 | 
			
		||||
M: quotation free-vars* [ free-vars* ] each ;
 | 
			
		||||
 | 
			
		||||
M: lambda free-vars*
 | 
			
		||||
    [ vars>> ] [ body>> ] bi free-vars swap diff % ;
 | 
			
		||||
M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ;
 | 
			
		||||
 | 
			
		||||
GENERIC: lambda-rewrite* ( obj -- )
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -201,6 +204,8 @@ M: special rewrite-literal? drop t ;
 | 
			
		|||
 | 
			
		||||
M: array rewrite-literal? [ rewrite-literal? ] contains? ;
 | 
			
		||||
 | 
			
		||||
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
 | 
			
		||||
 | 
			
		||||
M: hashtable rewrite-literal? drop t ;
 | 
			
		||||
 | 
			
		||||
M: vector rewrite-literal? drop t ;
 | 
			
		||||
| 
						 | 
				
			
			@ -215,17 +220,20 @@ GENERIC: rewrite-element ( obj -- )
 | 
			
		|||
    [ rewrite-element ] each ;
 | 
			
		||||
 | 
			
		||||
: rewrite-sequence ( seq -- )
 | 
			
		||||
    [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
 | 
			
		||||
    [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
 | 
			
		||||
 | 
			
		||||
M: array rewrite-element
 | 
			
		||||
    dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
 | 
			
		||||
 | 
			
		||||
M: quotation rewrite-element
 | 
			
		||||
    dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
 | 
			
		||||
 | 
			
		||||
M: vector rewrite-element rewrite-sequence ;
 | 
			
		||||
 | 
			
		||||
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
 | 
			
		||||
 | 
			
		||||
M: tuple rewrite-element
 | 
			
		||||
    [ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ;
 | 
			
		||||
    [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
 | 
			
		||||
 | 
			
		||||
M: local rewrite-element , ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -243,6 +251,10 @@ M: tuple local-rewrite* rewrite-element ;
 | 
			
		|||
 | 
			
		||||
M: hashtable local-rewrite* rewrite-element ;
 | 
			
		||||
 | 
			
		||||
M: word local-rewrite*
 | 
			
		||||
    dup { >r r> } memq?
 | 
			
		||||
    [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
 | 
			
		||||
 | 
			
		||||
M: object lambda-rewrite* , ;
 | 
			
		||||
 | 
			
		||||
M: object local-rewrite* , ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -37,9 +37,17 @@ M: wrapper expand-macros* wrapped>> literal ;
 | 
			
		|||
        [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
 | 
			
		||||
    ] bi ;
 | 
			
		||||
 | 
			
		||||
: expand-macro ( quot -- )
 | 
			
		||||
    stack [ swap with-datastack >vector ] change
 | 
			
		||||
    stack get pop >quotation end (expand-macros) ;
 | 
			
		||||
: word, ( word -- ) end , ;
 | 
			
		||||
 | 
			
		||||
: expand-macro ( word quot -- )
 | 
			
		||||
    '[
 | 
			
		||||
        drop
 | 
			
		||||
        stack [ _ with-datastack >vector ] change
 | 
			
		||||
        stack get pop >quotation end (expand-macros)
 | 
			
		||||
    ] [
 | 
			
		||||
        drop
 | 
			
		||||
        word,
 | 
			
		||||
    ] recover ;
 | 
			
		||||
 | 
			
		||||
: expand-macro? ( word -- quot ? )
 | 
			
		||||
    dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
 | 
			
		||||
| 
						 | 
				
			
			@ -47,11 +55,9 @@ M: wrapper expand-macros* wrapped>> literal ;
 | 
			
		|||
        stack get length <=
 | 
			
		||||
    ] [ 2drop f f ] if ;
 | 
			
		||||
 | 
			
		||||
: word, ( word -- ) end , ;
 | 
			
		||||
 | 
			
		||||
M: word expand-macros*
 | 
			
		||||
    dup expand-dispatch? [ drop expand-dispatch ] [
 | 
			
		||||
        dup expand-macro? [ nip expand-macro ] [
 | 
			
		||||
        dup expand-macro? [ expand-macro ] [
 | 
			
		||||
            drop word,
 | 
			
		||||
        ] if
 | 
			
		||||
    ] if ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -216,27 +216,8 @@ M: object pprint* pprint-object ;
 | 
			
		|||
M: vector pprint* pprint-object ;
 | 
			
		||||
M: byte-vector pprint* pprint-object ;
 | 
			
		||||
M: hashtable pprint* pprint-object ;
 | 
			
		||||
 | 
			
		||||
GENERIC: valid-callable? ( obj -- ? )
 | 
			
		||||
 | 
			
		||||
M: object valid-callable? drop f ;
 | 
			
		||||
 | 
			
		||||
M: quotation valid-callable? drop t ;
 | 
			
		||||
 | 
			
		||||
M: curry valid-callable? quot>> valid-callable? ;
 | 
			
		||||
 | 
			
		||||
M: compose valid-callable?
 | 
			
		||||
    [ first>> ] [ second>> ] bi [ valid-callable? ] both? ;
 | 
			
		||||
 | 
			
		||||
M: curry pprint*
 | 
			
		||||
    dup valid-callable? [ pprint-object ] [
 | 
			
		||||
        "( invalid curry )" swap present-text
 | 
			
		||||
    ] if ;
 | 
			
		||||
 | 
			
		||||
M: compose pprint*
 | 
			
		||||
    dup valid-callable? [ pprint-object ] [
 | 
			
		||||
        "( invalid compose )" swap present-text
 | 
			
		||||
    ] if ;
 | 
			
		||||
M: curry pprint* pprint-object ;
 | 
			
		||||
M: compose pprint* pprint-object ;
 | 
			
		||||
 | 
			
		||||
M: wrapper pprint*
 | 
			
		||||
    dup wrapped>> word? [
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -323,10 +323,6 @@ M: class-see-layout class-see-layout ;
 | 
			
		|||
    [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ ] [ 1 \ + curry unparse drop ] unit-test
 | 
			
		||||
 | 
			
		||||
[ ] [ 1 \ + compose unparse drop ] unit-test
 | 
			
		||||
 | 
			
		||||
GENERIC: generic-see-test-with-f ( obj -- obj )
 | 
			
		||||
 | 
			
		||||
M: f generic-see-test-with-f ;
 | 
			
		||||
| 
						 | 
				
			
			@ -365,8 +361,3 @@ M: started-out-hustlin' ended-up-ballin' ; inline
 | 
			
		|||
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
 | 
			
		||||
    [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
 | 
			
		||||
] unit-test
 | 
			
		||||
 | 
			
		||||
[ "( invalid curry )" ] [ 1 2 curry unparse ] unit-test
 | 
			
		||||
[ "( invalid curry )" ] [ 1 2 3 curry curry unparse ] unit-test
 | 
			
		||||
[ "( invalid compose )" ] [ 1 2 compose unparse ] unit-test
 | 
			
		||||
[ "( invalid compose )" ] [ [ 1 ] 2 3 curry compose unparse ] unit-test
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -303,7 +303,13 @@ tuple
 | 
			
		|||
    [ f "inline" set-word-prop ]
 | 
			
		||||
    [ make-flushable ]
 | 
			
		||||
    [ ]
 | 
			
		||||
    [ tuple-layout [ <tuple-boa> ] curry ]
 | 
			
		||||
    [
 | 
			
		||||
        [
 | 
			
		||||
            callable instance-check-quot %
 | 
			
		||||
            tuple-layout ,
 | 
			
		||||
            \ <tuple-boa> ,
 | 
			
		||||
        ] [ ] make
 | 
			
		||||
    ]
 | 
			
		||||
} cleave
 | 
			
		||||
(( obj quot -- curry )) define-declared
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -319,7 +325,16 @@ tuple
 | 
			
		|||
    [ f "inline" set-word-prop ]
 | 
			
		||||
    [ make-flushable ]
 | 
			
		||||
    [ ]
 | 
			
		||||
    [ tuple-layout [ <tuple-boa> ] curry ]
 | 
			
		||||
    [
 | 
			
		||||
        [
 | 
			
		||||
            \ >r ,
 | 
			
		||||
            callable instance-check-quot %
 | 
			
		||||
            \ r> ,
 | 
			
		||||
            callable instance-check-quot %
 | 
			
		||||
            tuple-layout ,
 | 
			
		||||
            \ <tuple-boa> ,
 | 
			
		||||
        ] [ ] make
 | 
			
		||||
    ]
 | 
			
		||||
} cleave
 | 
			
		||||
(( quot1 quot2 -- compose )) define-declared
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -121,7 +121,7 @@ ERROR: bad-superclass class ;
 | 
			
		|||
    [
 | 
			
		||||
        \ dup ,
 | 
			
		||||
        [ "predicate" word-prop % ]
 | 
			
		||||
        [ [ bad-slot-value ] curry , ] bi
 | 
			
		||||
        [ [ literalize , \ bad-slot-value , ] [ ] make , ] bi
 | 
			
		||||
        \ unless ,
 | 
			
		||||
    ] [ ] make ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -28,10 +28,7 @@ IN: combinators
 | 
			
		|||
 | 
			
		||||
! spread
 | 
			
		||||
: spread>quot ( seq -- quot )
 | 
			
		||||
    [ ] [
 | 
			
		||||
        [ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip
 | 
			
		||||
        append
 | 
			
		||||
    ] reduce ;
 | 
			
		||||
    [ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ;
 | 
			
		||||
 | 
			
		||||
: spread ( objs... seq -- )
 | 
			
		||||
    spread>quot call ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words
 | 
			
		|||
io.streams.string namespaces classes effects source-files
 | 
			
		||||
assocs sequences strings io.files definitions continuations
 | 
			
		||||
sorting classes.tuple compiler.units debugger vocabs
 | 
			
		||||
vocabs.loader accessors eval combinators ;
 | 
			
		||||
vocabs.loader accessors eval combinators lexer ;
 | 
			
		||||
IN: parser.tests
 | 
			
		||||
 | 
			
		||||
[
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -15,4 +15,4 @@ IN: quotations.tests
 | 
			
		|||
 | 
			
		||||
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
 | 
			
		||||
 | 
			
		||||
! [ 1 \ + curry ] must-fail
 | 
			
		||||
[ 1 \ + curry ] must-fail
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
 | 
			
		||||
USING: combinators.short-circuit kernel namespaces
 | 
			
		||||
USING: kernel namespaces
 | 
			
		||||
       math
 | 
			
		||||
       math.constants
 | 
			
		||||
       math.functions
 | 
			
		||||
| 
						 | 
				
			
			@ -10,6 +10,7 @@ USING: combinators.short-circuit kernel namespaces
 | 
			
		|||
       math.physics.vel
 | 
			
		||||
       combinators arrays sequences random vars
 | 
			
		||||
       combinators.lib
 | 
			
		||||
       combinators.short-circuit
 | 
			
		||||
       accessors ;
 | 
			
		||||
 | 
			
		||||
IN: boids
 | 
			
		||||
| 
						 | 
				
			
			@ -156,7 +157,7 @@ VAR: separation-radius
 | 
			
		|||
  2&& ;
 | 
			
		||||
 | 
			
		||||
: alignment-neighborhood ( self -- boids )
 | 
			
		||||
boids> [ within-alignment-neighborhood? ] with filter ;
 | 
			
		||||
  boids> [ within-alignment-neighborhood? ] with filter ;
 | 
			
		||||
 | 
			
		||||
: alignment-force ( self -- force )
 | 
			
		||||
  alignment-neighborhood
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,43 +0,0 @@
 | 
			
		|||
 | 
			
		||||
USING: kernel namespaces sequences math
 | 
			
		||||
       listener io prettyprint sequences.lib bake bake.fry ;
 | 
			
		||||
 | 
			
		||||
IN: display-stack
 | 
			
		||||
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
 | 
			
		||||
SYMBOL: watched-variables
 | 
			
		||||
 | 
			
		||||
: watch-var ( sym -- ) watched-variables get push ;
 | 
			
		||||
 | 
			
		||||
: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
 | 
			
		||||
 | 
			
		||||
: unwatch-var ( sym -- ) watched-variables get delete ;
 | 
			
		||||
 | 
			
		||||
: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
 | 
			
		||||
 | 
			
		||||
: print-watched-variables ( -- )
 | 
			
		||||
  watched-variables get length 0 >
 | 
			
		||||
    [
 | 
			
		||||
      "----------" print
 | 
			
		||||
      watched-variables get
 | 
			
		||||
        watched-variables get [ unparse ] map longest length 2 +
 | 
			
		||||
        '[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ]
 | 
			
		||||
      each
 | 
			
		||||
 | 
			
		||||
    ]
 | 
			
		||||
  when ;
 | 
			
		||||
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
 | 
			
		||||
: display-stack ( -- )
 | 
			
		||||
  V{ } clone watched-variables set
 | 
			
		||||
    [
 | 
			
		||||
      print-watched-variables
 | 
			
		||||
      "----------" print
 | 
			
		||||
      datastack [ . ] each
 | 
			
		||||
      "----------" print
 | 
			
		||||
      retainstack reverse [ . ] each
 | 
			
		||||
    ]
 | 
			
		||||
  listener-hook set ;
 | 
			
		||||
 | 
			
		||||
		Loading…
	
		Reference in New Issue