basis/fry/fry.factor

   1 ! Copyright (C) 2009 Slava Pestov, Eduardo Cavazos, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators kernel locals.backend math
   4 namespaces parser quotations sequences sets splitting words ;
   5 IN: fry
   6
   7 ERROR: not-in-a-fry ;
   8
   9 SYMBOL: in-fry?
  10
  11 SYNTAX: _ in-fry? get [ \ _ suffix! ] [ not-in-a-fry ] if ;
  12
  13 SYNTAX: @ in-fry? get [ \ @ suffix! ] [ not-in-a-fry ] if ;
  14
  15 ERROR: >r/r>-in-fry-error ;
  16
  17 GENERIC: fry ( quot -- quot' )
  18
  19 <PRIVATE
  20
  21 : check-fry ( quot -- quot )
  22     dup { load-local load-locals get-local drop-locals } intersect
  23     [ >r/r>-in-fry-error ] unless-empty ;
  24
  25 PREDICATE: fry-specifier < word { POSTPONE: _ POSTPONE: @ } member-eq? ;
  26
  27 GENERIC: count-inputs ( quot -- n )
  28
  29 M: callable count-inputs [ count-inputs ] map-sum ;
  30 M: fry-specifier count-inputs drop 1 ;
  31 M: object count-inputs drop 0 ;
  32
  33 MIXIN: fried
  34 PREDICATE: fried-callable < callable
  35     count-inputs 0 > ;
  36 INSTANCE: fried-callable fried
  37
  38 : (ncurry) ( quot n -- quot )
  39     {
  40         { 0 [ ] }
  41         { 1 [ \ curry  suffix! ] }
  42         { 2 [ \ 2curry suffix! ] }
  43         { 3 [ \ 3curry suffix! ] }
  44         [ [ \ 3curry suffix! ] dip 3 - (ncurry) ]
  45     } case ;
  46
  47 : wrap-non-callable ( obj -- quot )
  48     dup callable? [ ] [ [ call ] curry ] if ; inline
  49
  50 : [ncurry] ( n -- quot )
  51     [ V{ } clone ] dip (ncurry) >quotation ;
  52
  53 : [ndip] ( quot n -- quot' )
  54     {
  55         { 0 [ wrap-non-callable ] }
  56         { 1 [ \ dip  [ ] 2sequence ] }
  57         { 2 [ \ 2dip [ ] 2sequence ] }
  58         { 3 [ \ 3dip [ ] 2sequence ] }
  59         [ [ \ 3dip [ ] 2sequence ] dip 3 - [ndip] ]
  60     } case ;
  61
  62 : (make-curry) ( tail quot -- quot' )
  63     swap [ncurry] curry [ compose ] compose ;
  64
  65 : make-compose ( consecutive quot -- consecutive quot' )
  66     [
  67         [ [ ] ]
  68         [ [ncurry] ] if-zero
  69     ] [
  70         [ [ compose ] ]
  71         [ [ compose compose ] curry ] if-empty
  72     ] bi* compose
  73     0 swap ;
  74
  75 : make-curry ( consecutive quot -- consecutive' quot' )
  76     [ 1 + ] dip
  77     [ [ ] ] [ (make-curry) 0 swap ] if-empty ;
  78
  79 : convert-curry ( consecutive quot -- consecutive' quot' )
  80     [ [ ] make-curry ] [
  81         dup first \ @ =
  82         [ rest >quotation make-compose ]
  83         [ >quotation make-curry ] if
  84     ] if-empty ;
  85
  86 : prune-curries ( seq -- seq' )
  87     dup [ empty? not ] find
  88     [ [ 1 + tail ] dip but-last prefix ]
  89     [ 2drop { } ] if* ;
  90
  91 : convert-curries ( seq -- tail seq' )
  92     unclip-slice [ 0 swap [ convert-curry ] map ] dip
  93     [ prune-curries ]
  94     [ >quotation 1quotation prefix ] if-empty ;
  95
  96 : mark-composes ( quot -- quot' )
  97     [ dup \ @ = [ drop [ POSTPONE: _ POSTPONE: @ ] ] [ 1quotation ] if ] map concat ; inline
  98
  99 : shallow-fry ( quot -- quot' )
 100     check-fry mark-composes
 101     { POSTPONE: _ } split convert-curries
 102     [ [ [ ] ] [ [ ] (make-curry) but-last ] if-zero ]
 103     [ shallow-spread>quot swap [ [ ] (make-curry) compose ] unless-zero ] if-empty ;
 104
 105 DEFER: dredge-fry
 106
 107 TUPLE: dredge-fry-state
 108     { in-quot read-only }
 109     { prequot read-only }
 110     { quot read-only } ;
 111
 112 : <dredge-fry> ( quot -- dredge-fry )
 113     V{ } clone V{ } clone dredge-fry-state boa ; inline
 114
 115 : in-quot-slices ( n i state -- head tail )
 116     in-quot>>
 117     [ <slice> ]
 118     [ nipd swap 1 + tail-slice ] 3bi ; inline
 119
 120 : push-head-slice ( head state -- )
 121     quot>> [ push-all ] [ \ _ swap push ] bi ; inline
 122
 123 : push-subquot ( tail elt state -- )
 124     [ fry swap >quotation count-inputs [ndip] ] dip prequot>> push-all ; inline
 125
 126 : (dredge-fry-subquot) ( n state i elt -- )
 127     rot {
 128         [ nip in-quot-slices ] ! head tail i elt state
 129         [ [ 2drop swap ] dip push-head-slice ]
 130         [ nipd push-subquot ]
 131         [ [ 1 + ] [ drop ] [ ] tri* dredge-fry ]
 132     } 3cleave ; inline recursive
 133
 134 : (dredge-fry-simple) ( n state -- )
 135     [ in-quot>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive
 136
 137 : dredge-fry ( n dredge-fry -- )
 138     2dup in-quot>> [ fried? ] find-from
 139     [ (dredge-fry-subquot) ]
 140     [ drop (dredge-fry-simple) ] if* ; inline recursive
 141
 142 PRIVATE>
 143
 144 M: callable fry ( quot -- quot' )
 145     [ [ [ ] ] ] [
 146         0 swap <dredge-fry>
 147         [ dredge-fry ] [
 148             [ prequot>> >quotation ]
 149             [ quot>> >quotation shallow-fry ] bi append
 150         ] bi
 151     ] if-empty ;
 152
 153 SYNTAX: '[ t in-fry? [ parse-quotation ] with-variable fry append! ;