combinators.smart: Fix reduce-outputs, rename quot*n to call-n, rewrite more macros as combinators.
parent
9a55bfb5a2
commit
41e4c48647
|
@ -40,6 +40,9 @@ M: input-parameter infer-known* \ inputs/outputs unknown-macro-input ;
|
||||||
|
|
||||||
M: object infer-known* \ inputs/outputs bad-macro-input ;
|
M: object infer-known* \ inputs/outputs bad-macro-input ;
|
||||||
|
|
||||||
|
: drop-inputs ( quot -- newquot )
|
||||||
|
inputs ndrop ; inline
|
||||||
|
|
||||||
: drop-outputs ( quot -- )
|
: drop-outputs ( quot -- )
|
||||||
[ call ] [ outputs ndrop ] bi ; inline
|
[ call ] [ outputs ndrop ] bi ; inline
|
||||||
|
|
||||||
|
@ -59,7 +62,7 @@ M: object infer-known* \ inputs/outputs bad-macro-input ;
|
||||||
[ inputs firstn-unsafe ] [ call ] bi ; inline
|
[ inputs firstn-unsafe ] [ call ] bi ; inline
|
||||||
|
|
||||||
MACRO: reduce-outputs ( quot operation -- newquot )
|
MACRO: reduce-outputs ( quot operation -- newquot )
|
||||||
[ dup outputs 1 [-] ] dip n*quot compose ;
|
[ [ ] [ outputs 1 [-] ] bi ] dip swap '[ @ _ _ call-n ] ;
|
||||||
|
|
||||||
: sum-outputs ( quot -- n )
|
: sum-outputs ( quot -- n )
|
||||||
[ + ] reduce-outputs ; inline
|
[ + ] reduce-outputs ; inline
|
||||||
|
@ -70,37 +73,38 @@ MACRO: reduce-outputs ( quot operation -- newquot )
|
||||||
: map-reduce-outputs ( quot mapper reducer -- )
|
: map-reduce-outputs ( quot mapper reducer -- )
|
||||||
[ '[ _ _ map-outputs ] ] dip reduce-outputs ; inline
|
[ '[ _ _ map-outputs ] ] dip reduce-outputs ; inline
|
||||||
|
|
||||||
MACRO: append-outputs-as ( quot exemplar -- newquot )
|
: append-outputs-as ( quot exemplar -- newquot )
|
||||||
[ dup outputs ] dip '[ @ _ _ nappend-as ] ;
|
[ [ call ] [ outputs ] bi ] dip nappend-as ; inline
|
||||||
|
|
||||||
MACRO: append-outputs ( quot -- seq )
|
: append-outputs ( quot -- seq )
|
||||||
'[ _ { } append-outputs-as ] ;
|
{ } append-outputs-as ; inline
|
||||||
|
|
||||||
MACRO: preserving ( quot -- )
|
: preserving ( quot -- )
|
||||||
[ inputs ] keep '[ _ ndup @ ] ;
|
[ inputs ndup ] [ call ] bi ; inline
|
||||||
|
|
||||||
MACRO: dropping ( quot -- quot' )
|
: dropping ( quot -- quot' )
|
||||||
inputs '[ [ _ ndrop ] ] ;
|
inputs '[ _ ndrop ] ; inline
|
||||||
|
|
||||||
MACRO: nullary ( quot -- quot' ) dropping ;
|
: nullary ( quot -- quot' )
|
||||||
|
dropping call ; inline
|
||||||
|
|
||||||
MACRO: smart-if ( pred true false -- quot )
|
: smart-if ( pred true false -- quot )
|
||||||
'[ _ preserving _ _ if ] ;
|
[ preserving ] 2dip if ; inline
|
||||||
|
|
||||||
MACRO: smart-when ( pred true -- quot )
|
: smart-when ( pred true -- quot )
|
||||||
'[ _ _ [ ] smart-if ] ;
|
[ ] smart-if ; inline
|
||||||
|
|
||||||
MACRO: smart-unless ( pred false -- quot )
|
: smart-unless ( pred false -- quot )
|
||||||
'[ _ [ ] _ smart-if ] ;
|
[ [ ] ] dip smart-if ; inline
|
||||||
|
|
||||||
MACRO: smart-if* ( pred true false -- quot )
|
: smart-if* ( pred true false -- quot )
|
||||||
'[ _ [ preserving ] [ dropping ] bi _ swap _ compose if ] ;
|
[ [ [ preserving ] [ dropping ] bi ] dip swap ] dip compose if ; inline
|
||||||
|
|
||||||
MACRO: smart-when* ( pred true -- quot )
|
: smart-when* ( pred true -- quot )
|
||||||
'[ _ _ [ ] smart-if* ] ;
|
[ ] smart-if* ; inline
|
||||||
|
|
||||||
MACRO: smart-unless* ( pred false -- quot )
|
: smart-unless* ( pred false -- quot )
|
||||||
'[ _ [ ] _ smart-if* ] ;
|
[ [ ] ] dip smart-if* ; inline
|
||||||
|
|
||||||
MACRO: smart-apply ( quot n -- quot )
|
: smart-apply ( quot n -- quot )
|
||||||
[ dup inputs ] dip '[ _ _ _ mnapply ] ;
|
[ dup inputs ] dip mnapply ; inline
|
||||||
|
|
|
@ -6,11 +6,15 @@ combinators macros math.order math.ranges quotations fry effects
|
||||||
memoize.private arrays ;
|
memoize.private arrays ;
|
||||||
IN: generalizations
|
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)
|
ALIAS: n*quot (n*quot)
|
||||||
|
|
||||||
MACRO: quot*n ( n -- )
|
MACRO: call-n ( n -- )
|
||||||
[ call ] <repetition> '[ _ cleave ] ;
|
[ call ] <repetition> '[ _ cleave ] ;
|
||||||
|
|
||||||
: repeat ( n obj quot -- ) swapd times ; inline
|
: repeat ( n obj quot -- ) swapd times ; inline
|
||||||
|
@ -27,7 +31,7 @@ MACRO: nover ( n -- )
|
||||||
dup 1 + '[ _ npick ] n*quot ;
|
dup 1 + '[ _ npick ] n*quot ;
|
||||||
|
|
||||||
: ndup ( n -- )
|
: ndup ( n -- )
|
||||||
[ '[ _ npick ] ] keep quot*n ; inline
|
[ '[ _ npick ] ] keep call-n ; inline
|
||||||
|
|
||||||
MACRO: dupn ( n -- )
|
MACRO: dupn ( n -- )
|
||||||
[ [ drop ] ]
|
[ [ drop ] ]
|
||||||
|
@ -40,25 +44,25 @@ MACRO: -nrot ( n -- )
|
||||||
1 - [ ] [ '[ swap _ dip ] ] repeat ;
|
1 - [ ] [ '[ swap _ dip ] ] repeat ;
|
||||||
|
|
||||||
: ndrop ( n -- )
|
: ndrop ( n -- )
|
||||||
[ drop ] swap quot*n ; inline
|
[ drop ] swap call-n ; inline
|
||||||
|
|
||||||
: nnip ( n -- )
|
: nnip ( n -- )
|
||||||
'[ _ ndrop ] dip ; inline
|
'[ _ ndrop ] dip ; inline
|
||||||
|
|
||||||
: ndip ( n -- )
|
: ndip ( n -- )
|
||||||
[ [ dip ] curry ] swap quot*n call ; inline
|
[ [ dip ] curry ] swap call-n call ; inline
|
||||||
|
|
||||||
: nkeep ( n -- )
|
: nkeep ( n -- )
|
||||||
dup '[ [ _ ndup ] dip _ ndip ] call ; inline
|
dup '[ [ _ ndup ] dip _ ndip ] call ; inline
|
||||||
|
|
||||||
: ncurry ( n -- )
|
: ncurry ( n -- )
|
||||||
[ curry ] swap quot*n ; inline
|
[ curry ] swap call-n ; inline
|
||||||
|
|
||||||
: nwith ( n -- )
|
: nwith ( n -- )
|
||||||
[ with ] swap quot*n ; inline
|
[ with ] swap call-n ; inline
|
||||||
|
|
||||||
MACRO: nbi ( n -- )
|
: nbi ( quot1 quot2 n -- )
|
||||||
'[ [ _ nkeep ] dip call ] ;
|
[ nip nkeep ] [ drop nip call ] 3bi ; inline
|
||||||
|
|
||||||
MACRO: ncleave ( quots n -- )
|
MACRO: ncleave ( quots n -- )
|
||||||
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
|
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
|
||||||
|
@ -115,5 +119,5 @@ MACRO: nweave ( n -- )
|
||||||
[ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
|
[ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
|
||||||
'[ _ _ ncleave ] ;
|
'[ _ _ ncleave ] ;
|
||||||
|
|
||||||
MACRO: nbi-curry ( n -- )
|
: nbi-curry ( n -- )
|
||||||
[ bi-curry ] n*quot ;
|
[ bi-curry ] swap call-n ; inline
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2007 Doug Coleman.
|
! Copyright (C) 2007 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays assocs effects fry generalizations
|
USING: accessors arrays assocs combinators.smart effects
|
||||||
grouping kernel lexer macros math math.order math.vectors
|
effects.parser fry generalizations grouping kernel lexer macros
|
||||||
namespaces parser effects.parser quotations sequences
|
math math.order math.vectors namespaces parser quotations
|
||||||
sequences.private splitting.monotonic stack-checker strings
|
sequences sequences.private splitting.monotonic stack-checker
|
||||||
unicode.case words ;
|
strings unicode.case words ;
|
||||||
IN: roman
|
IN: roman
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
|
@ -20,9 +20,6 @@ TUPLE: xml-test id uri sections description type ;
|
||||||
|
|
||||||
CONSTANT: base "vocab:xml/tests/xmltest/"
|
CONSTANT: base "vocab:xml/tests/xmltest/"
|
||||||
|
|
||||||
MACRO: drop-inputs ( quot -- newquot )
|
|
||||||
inputs '[ _ ndrop ] ;
|
|
||||||
|
|
||||||
: fails? ( quot -- ? )
|
: fails? ( quot -- ? )
|
||||||
[ drop-outputs f ] [ nip drop-inputs t ] bi-curry recover ; inline
|
[ drop-outputs f ] [ nip drop-inputs t ] bi-curry recover ; inline
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue