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

generalizations and delegate no longer uses >r/r>

db4
Slava Pestov 2008-11-25 16:47:47 -06:00
parent fc5d53327d
commit 30f93f547f
2 changed files with 24 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
basis/delegate/delegate.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions words slots assocs sequences arrays vectors definitions
prettyprint math hashtables sets macros namespaces make ; prettyprint math hashtables sets generalizations namespaces make ;
IN: delegate IN: delegate
: protocol-words ( protocol -- words ) : protocol-words ( protocol -- words )
@ -25,15 +25,7 @@ M: tuple-class group-words
: consult-method ( word class quot -- ) : consult-method ( word class quot -- )
[ drop swap first create-method ] [ drop swap first create-method ]
[ [ nip [ , dup second , \ ndip , first , ] [ ] make ] 3bi
nip
[
over second saver %
%
dup second restorer %
first ,
] [ ] make
] 3bi
define ; define ;
: change-word-prop ( word prop quot -- ) : change-word-prop ( word prop quot -- )

42
basis/generalizations/generalizations.factor
View File

@ -1,10 +1,18 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
! 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 namespaces math USING: kernel sequences sequences.private math math.ranges
math.ranges combinators macros quotations fry arrays ; combinators macros quotations fry ;
IN: generalizations IN: generalizations
<<
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
: repeat ( n obj quot -- ) swapd times ; inline
>>
MACRO: nsequence ( n seq -- quot ) MACRO: nsequence ( n seq -- quot )
[ [
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
@ -22,44 +30,38 @@ MACRO: firstn ( n -- )
bi prefix '[ _ cleave ] bi prefix '[ _ cleave ]
] if ; ] if ;
: npick-wrap ( quot n -- quot ) MACRO: npick ( n -- quot )
dup 1 > 1- [ dup ] [ '[ _ dip swap ] ] repeat ;
[ swap '[ _ dip swap ] swap 1 - npick-wrap ]
[ drop ]
if ;
MACRO: npick ( n -- quot ) [ dup ] swap npick-wrap ;
MACRO: ndup ( n -- ) MACRO: ndup ( n -- )
dup '[ _ npick ] n*quot ; dup '[ _ npick ] n*quot ;
MACRO: nrot ( n -- ) MACRO: nrot ( n -- )
1- dup saver swap [ r> swap ] n*quot append ; 1- [ ] [ '[ _ dip swap ] ] repeat ;
MACRO: -nrot ( n -- ) MACRO: -nrot ( n -- )
1- dup [ swap >r ] n*quot swap restorer append ; 1- [ ] [ '[ swap _ dip ] ] repeat ;
MACRO: ndrop ( n -- ) MACRO: ndrop ( n -- )
[ drop ] n*quot ; [ drop ] n*quot ;
: nnip ( n -- ) MACRO: nnip ( n -- )
swap >r ndrop r> ; inline '[ [ _ ndrop ] dip ] ;
MACRO: ntuck ( n -- ) MACRO: ntuck ( n -- )
2 + [ dupd -nrot ] curry ; 2 + '[ dup _ -nrot ] ;
MACRO: nrev ( n -- quot ) MACRO: nrev ( n -- quot )
1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ; 1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
MACRO: ndip ( quot n -- ) MACRO: ndip ( quot n -- )
dup saver -rot restorer 3append ; [ '[ _ dip ] ] times ;
MACRO: nslip ( n -- ) MACRO: nslip ( n -- )
dup saver [ call ] rot restorer 3append ; '[ [ call ] _ ndip ] ;
MACRO: nkeep ( n -- ) MACRO: nkeep ( quot n -- )
[ ] [ 1+ ] [ ] tri tuck '[ _ ndup _ _ ndip ] ;
'[ [ _ ndup ] dip _ -nrot _ nslip ] ;
MACRO: ncurry ( n -- ) MACRO: ncurry ( n -- )
[ curry ] n*quot ; [ curry ] n*quot ;
@ -69,5 +71,5 @@ MACRO: nwith ( n -- )
MACRO: napply ( n -- ) MACRO: napply ( n -- )
2 [a,b] 2 [a,b]
[ [ 1- ] keep '[ _ ntuck _ nslip ] ] [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
map concat >quotation [ call ] append ; map concat >quotation [ call ] append ;