basis/fry/fry.factor

   1 ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences combinators parser splitting math
   4 quotations arrays make qualified words ;
   5 IN: fry
   6
   7 : _ ( -- * ) "Only valid inside a fry" throw ;
   8 : @ ( -- * ) "Only valid inside a fry" throw ;
   9
  10 <PRIVATE
  11
  12 DEFER: (shallow-fry)
  13 DEFER: shallow-fry
  14
  15 : ((shallow-fry)) ( accum quot adder -- result )
  16     >r shallow-fry r>
  17     append swap [
  18         [ prepose ] curry append
  19     ] unless-empty ; inline
  20
  21 : (shallow-fry) ( accum quot -- result )
  22     [ 1quotation ] [
  23         unclip {
  24             { \ , [ "Oops!!" throw ] }
  25             { \ _ [ [ curry ] ((shallow-fry)) ] }
  26             { \ @ [ [ compose ] ((shallow-fry)) ] }
  27             [ swap >r suffix r> (shallow-fry) ]
  28         } case
  29     ] if-empty ;
  30
  31 : shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
  32
  33 PREDICATE: fry-specifier < word { _ @ , } memq? ;
  34
  35 GENERIC: count-inputs ( quot -- n )
  36
  37 M: callable count-inputs [ count-inputs ] sigma ;
  38 M: fry-specifier count-inputs \ , eq? [ "Oops!!" throw ] when 1 ;
  39 M: object count-inputs drop 0 ;
  40
  41 PRIVATE>
  42
  43 : fry ( quot -- quot' )
  44     [
  45         [
  46             dup callable? [
  47                 [ count-inputs \ _ <repetition> % ] [ fry % ] bi
  48             ] [ , ] if
  49         ] each
  50     ] [ ] make shallow-fry ;
  51
  52 : '[ \ ] parse-until fry over push-all ; parsing