combinators.smart: Fix reduce-outputs, rename quot*n to call-n, rewrite more macros as combinators.

db4
Doug Coleman 2011-11-28 12:41:50 -08:00
parent 9a55bfb5a2
commit 41e4c48647
4 changed files with 47 additions and 42 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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