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

effects: fix bug reported by Joe where printing { f } { } <effect> kills the listener; simpler implementation of 'shuffle'; add compiler transform to 'shuffle' if effect is constant

db4
Slava Pestov 2009-02-09 16:26:56 -06:00
parent 739330577f
commit 3bd22a39f6
3 changed files with 21 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/generalizations/generalizations.factor
View File

@ -2,7 +2,7 @@
! Cavazos, Slava Pestov. ! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private math combinators USING: kernel sequences sequences.private math combinators
macros quotations fry ; macros quotations fry stack-checker.transforms effects ;
IN: generalizations IN: generalizations
<< <<
@ -95,3 +95,11 @@ MACRO: nweave ( n -- )
[ narray concat ] dip like ; inline [ narray concat ] dip like ; inline
: nappend ( n -- seq ) narray concat ; inline : nappend ( n -- seq ) narray concat ; inline
: nths-quot ( indices -- quot )
[ [ '[ _ swap nth ] ] map ] [ length ] bi
'[ _ cleave _ narray ] ;
\ shuffle [
shuffle-mapping nths-quot
] 1 define-transform

6
core/effects/effects-tests.factor
View File

@ -9,9 +9,13 @@ USING: effects tools.test prettyprint accessors sequences ;
[ 2 ] [ (( a b -- c )) in>> length ] unit-test [ 2 ] [ (( a b -- c )) in>> length ] unit-test
[ 1 ] [ (( a b -- c )) out>> length ] unit-test [ 1 ] [ (( a b -- c )) out>> length ] unit-test
[ "(( object -- object ))" ] [ { f } { f } <effect> unparse ] unit-test
[ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test [ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
[ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test [ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test
[ "(( a b -- ))" ] [ { "a" "b" } { } <effect> unparse ] unit-test [ "(( a b -- ))" ] [ { "a" "b" } { } <effect> unparse ] unit-test
[ "(( -- ))" ] [ { } { } <effect> unparse ] unit-test [ "(( -- ))" ] [ { } { } <effect> unparse ] unit-test
[ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test [ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test
[ { "x" "y" } ] [ { "y" "x" } (( a b -- b a )) shuffle ] unit-test
[ { "y" "x" "y" } ] [ { "y" "x" } (( a b -- a b a )) shuffle ] unit-test
[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test

16
core/effects/effects.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser namespaces make sequences strings USING: kernel math math.parser namespaces make sequences strings
words assocs combinators accessors arrays ; words assocs combinators accessors arrays ;
@ -24,6 +24,7 @@ TUPLE: effect in out terminated? ;
GENERIC: effect>string ( obj -- str ) GENERIC: effect>string ( obj -- str )
M: string effect>string ; M: string effect>string ;
M: object effect>string drop "object" ;
M: word effect>string name>> ; M: word effect>string name>> ;
M: integer effect>string number>string ; M: integer effect>string number>string ;
M: pair effect>string first2 [ effect>string ] bi@ ": " glue ; M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
@ -45,8 +46,8 @@ M: effect effect>string ( effect -- string )
GENERIC: stack-effect ( word -- effect/f ) GENERIC: stack-effect ( word -- effect/f )
M: word stack-effect M: word stack-effect
{ "declared-effect" "inferred-effect" } "inferred-effect" "declared-effect"
swap props>> [ at ] curry map [ ] find nip ; [ word-prop ] bi-curry@ bi or ;
M: effect clone M: effect clone
[ in>> clone ] [ out>> clone ] bi <effect> ; [ in>> clone ] [ out>> clone ] bi <effect> ;
@ -57,11 +58,8 @@ M: effect clone
: split-shuffle ( stack shuffle -- stack1 stack2 ) : split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ; in>> length cut* ;
: load-shuffle ( stack shuffle -- ) : shuffle-mapping ( effect -- mapping )
in>> [ set ] 2each ; [ out>> ] [ in>> ] bi [ index ] curry map ;
: shuffled-values ( shuffle -- values )
out>> [ get ] map ;
: shuffle ( stack shuffle -- newstack ) : shuffle ( stack shuffle -- newstack )
[ [ load-shuffle ] keep shuffled-values ] with-scope ; shuffle-mapping swap nths ;