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 words locals.backend summary sets ;
   5 IN: fry
   6
   7 : _ ( -- * ) "Only valid inside a fry" throw ;
   8 : @ ( -- * ) "Only valid inside a fry" throw ;
   9
  10 ERROR: >r/r>-in-fry-error ;
  11
  12 <PRIVATE
  13
  14 : [ncurry] ( n -- quot )
  15     {
  16         { 0 [ [ ] ] }
  17         { 1 [ [ curry ] ] }
  18         { 2 [ [ 2curry ] ] }
  19         { 3 [ [ 3curry ] ] }
  20         [ \ curry <repetition> ]
  21     } case ;
  22
  23 M: >r/r>-in-fry-error summary
  24     drop
  25     "Explicit retain stack manipulation is not permitted in fried quotations" ;
  26
  27 : check-fry ( quot -- quot )
  28     dup { load-local load-locals get-local drop-locals } intersect
  29     empty? [ >r/r>-in-fry-error ] unless ;
  30
  31 PREDICATE: fry-specifier < word { _ @ } memq? ;
  32
  33 GENERIC: count-inputs ( quot -- n )
  34
  35 M: callable count-inputs [ count-inputs ] sigma ;
  36 M: fry-specifier count-inputs drop 1 ;
  37 M: object count-inputs drop 0 ;
  38
  39 GENERIC: deep-fry ( obj -- )
  40
  41 : shallow-fry ( quot -- quot' curry# )
  42     check-fry
  43     [ [ deep-fry ] each ] [ ] make
  44     [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
  45     { _ } split [ spread>quot ] [ length 1- ] bi ;
  46
  47 PRIVATE>
  48
  49 : fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ;
  50
  51 M: callable deep-fry
  52     [ count-inputs \ _ <repetition> % ] [ fry % ] bi ;
  53
  54 M: object deep-fry , ;
  55
  56 : '[ \ ] parse-until fry over push-all ; parsing