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