library/combinators.factor

   1 ! :folding=indent:collapseFolds=1:
   2
   3 ! $Id$
   4 !
   5 ! Copyright (C) 2003, 2004 Slava Pestov.
   6 !
   7 ! Redistribution and use in source and binary forms, with or without
   8 ! modification, are permitted provided that the following conditions are met:
   9 !
  10 ! 1. Redistributions of source code must retain the above copyright notice,
  11 !    this list of conditions and the following disclaimer.
  12 !
  13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  14 !    this list of conditions and the following disclaimer in the documentation
  15 !    and/or other materials provided with the distribution.
  16 !
  17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27
  28 IN: combinators
  29 USE: kernel
  30 USE: lists
  31 USE: stack
  32
  33 : slip ( quot x -- x )
  34     >r call r> ; inline interpret-only
  35
  36 : 2slip ( quot x y -- x y )
  37     >r >r call r> r> ; inline interpret-only
  38
  39 : 3slip ( quot x y z -- x y z )
  40     >r >r >r call r> r> r> ; inline interpret-only
  41
  42 : keep ( a quot -- a )
  43     #! Execute the quotation with a on the stack, and restore a
  44     #! after the quotation returns.
  45     over >r call r> ;
  46
  47 : apply ( code input -- code output )
  48     #! Apply code to input.
  49     swap dup >r call r> swap ;
  50
  51 : cond ( x list -- )
  52     #! The list is of this form:
  53     #!
  54     #! [ [ condition 1 ] [ code 1 ]
  55     #!   [ condition 2 ] [ code 2 ]
  56     #!   ... ]
  57     #!
  58     #! Each condition is evaluated in turn. If it returns true,
  59     #! the code is evaluated. If it returns false, the next
  60     #! condition is checked.
  61     #!
  62     #! Before evaluating each condition, the top of the stack is
  63     #! duplicated. After the last condition is evaluated, the
  64     #! top of the stack is popped.
  65     #!
  66     #! So each condition and code block must have stack effect:
  67     #! ( X -- )
  68     #!
  69     #! This combinator will not compile.
  70     dup [
  71         uncons >r over >r call r> r> rot [
  72             car call
  73         ] [
  74             cdr cond
  75         ] ifte
  76     ] [
  77         2drop
  78     ] ifte ; interpret-only
  79
  80 : ifte* ( cond true false -- )
  81     #! If the condition is not f, execute the 'true' quotation,
  82     #! with the condition on the stack. Otherwise, pop the
  83     #! condition and execute the 'false' quotation.
  84     pick [ drop call ] [ nip nip call ] ifte ;
  85     inline interpret-only
  86
  87 : unless ( cond quot -- )
  88     #! Execute a quotation only when the condition is f. The
  89     #! condition is popped off the stack.
  90     #!
  91     #! In order to compile, the quotation must consume as many
  92     #! values as it produces.
  93     [ ] swap ifte ; inline interpret-only
  94
  95 : unless* ( cond quot -- )
  96     #! If cond is f, pop it off the stack and evaluate the
  97     #! quotation. Otherwise, leave cond on the stack.
  98     #!
  99     #! In order to compile, the quotation must consume one less
 100     #! value than it produces.
 101     over [ drop ] [ nip call ] ifte ; inline interpret-only
 102
 103 : when ( cond quot -- )
 104     #! Execute a quotation only when the condition is not f. The
 105     #! condition is popped off the stack.
 106     #!
 107     #! In order to compile, the quotation must consume as many
 108     #! values as it produces.
 109     [ ] ifte ; inline interpret-only
 110
 111 : when* ( cond quot -- )
 112     #! If the condition is true, it is left on the stack, and
 113     #! the quotation is evaluated. Otherwise, the condition is
 114     #! popped off the stack.
 115     #!
 116     #! In order to compile, the quotation must consume one more
 117     #! value than it produces.
 118     over [ call ] [ 2drop ] ifte ; inline interpret-only
 119
 120 : forever ( quot -- )
 121     #! The code is evaluated in an infinite loop. Typically, a
 122     #! continuation is used to escape the infinite loop.
 123     #!
 124     #! This combinator will not compile.
 125     dup slip forever ; interpret-only
 126
 127 ! DEPRECATED
 128
 129 : 2apply ( x y quot -- )
 130     #! First applies the code to x, then to y.
 131     #!
 132     #! If the quotation compiles, this combinator compiles.
 133     2dup >r >r nip call r> r> call ; inline interpret-only
 134
 135 : cleave ( x quot quot -- )
 136     #! Executes each quotation, with x on top of the stack.
 137     #!
 138     #! If the quotation compiles, this combinator compiles.
 139     >r over >r call r> r> call ; inline interpret-only
 140
 141 : dip ( a [ b ] -- b a )
 142     #! Call b as if b was not present on the stack.
 143     #!
 144     #! If the quotation compiles, this combinator compiles.
 145     swap >r call r> ; inline interpret-only
 146
 147 : 2dip ( a b [ c ] -- c a b )
 148     #! Call c as if a and b were not present on the stack.
 149     #!
 150     #! If the quotation compiles, this combinator compiles.
 151     -rot >r >r call r> r> ; inline interpret-only
 152
 153 : interleave ( X quot -- )
 154     #! Evaluate each element of the list with X on top of the
 155     #! stack. When done, X is popped off the stack.
 156     #!
 157     #! To avoid unexpected results, each element of the list
 158     #! must have stack effect ( X -- ).
 159     #!
 160     #! This combinator will not compile.
 161     dup [
 162         over [ unswons dip ] dip swap interleave
 163     ] [
 164         2drop
 165     ] ifte ; interpret-only
 166
 167 : while ( cond body -- )
 168     #! Evaluate cond. If it leaves t on the stack, evaluate
 169     #! body, and recurse.
 170     #!
 171     #! In order to compile, the stack effect of
 172     #! cond * ( X -- ) * body must consume as many values as
 173     #! it produces.
 174     2dup >r >r >r call [
 175         r> call r> r> while
 176     ] [
 177         r> drop r> drop r> drop
 178     ] ifte ; inline interpret-only