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 parser
4 quotations sequences sets splitting words ;
7 : _ ( -- * ) "Only valid inside a fry" throw ;
8 : @ ( -- * ) "Only valid inside a fry" throw ;
10 ERROR: >r/r>-in-fry-error ;
12 GENERIC: fry ( quot -- quot' )
16 : check-fry ( quot -- quot )
17 dup { load-local load-locals get-local drop-locals } intersect
18 [ throw->r/r>-in-fry-error ] unless-empty ;
20 PREDICATE: fry-specifier < word { _ @ } member-eq? ;
22 GENERIC: count-inputs ( quot -- n )
24 M: callable count-inputs [ count-inputs ] map-sum ;
25 M: fry-specifier count-inputs drop 1 ;
26 M: object count-inputs drop 0 ;
29 PREDICATE: fried-callable < callable
31 INSTANCE: fried-callable fried
33 : (ncurry) ( quot n -- quot )
36 { 1 [ \ curry suffix! ] }
37 { 2 [ \ 2curry suffix! ] }
38 { 3 [ \ 3curry suffix! ] }
39 [ [ \ 3curry suffix! ] dip 3 - (ncurry) ]
42 : wrap-non-callable ( obj -- quot )
43 dup callable? [ ] [ [ call ] curry ] if ; inline
45 : [ncurry] ( n -- quot )
46 [ V{ } clone ] dip (ncurry) >quotation ;
48 : [ndip] ( quot n -- quot' )
50 { 0 [ wrap-non-callable ] }
51 { 1 [ \ dip [ ] 2sequence ] }
52 { 2 [ \ 2dip [ ] 2sequence ] }
53 { 3 [ \ 3dip [ ] 2sequence ] }
54 [ [ \ 3dip [ ] 2sequence ] dip 3 - [ndip] ]
57 : (make-curry) ( tail quot -- quot' )
58 swap [ncurry] curry [ compose ] compose ;
60 : make-compose ( consecutive quot -- consecutive quot' )
66 [ [ compose compose ] curry ] if-empty
70 : make-curry ( consecutive quot -- consecutive' quot' )
72 [ [ ] ] [ (make-curry) 0 swap ] if-empty ;
74 : convert-curry ( consecutive quot -- consecutive' quot' )
77 [ rest >quotation make-compose ]
78 [ >quotation make-curry ] if
81 : prune-curries ( seq -- seq' )
82 dup [ empty? not ] find
83 [ [ 1 + tail ] dip but-last prefix ]
86 : convert-curries ( seq -- tail seq' )
87 unclip-slice [ 0 swap [ convert-curry ] map ] dip
89 [ >quotation 1quotation prefix ] if-empty ;
91 : mark-composes ( quot -- quot' )
92 [ dup \ @ = [ drop [ _ @ ] ] [ 1quotation ] if ] map concat ; inline
94 : shallow-fry ( quot -- quot' )
95 check-fry mark-composes
96 { _ } split convert-curries
97 [ [ [ ] ] [ [ ] (make-curry) but-last ] if-zero ]
98 [ shallow-spread>quot swap [ [ ] (make-curry) compose ] unless-zero ] if-empty ;
102 TUPLE: dredge-fry-state
103 { in-quot read-only }
104 { prequot read-only }
107 : <dredge-fry> ( quot -- dredge-fry )
108 V{ } clone V{ } clone dredge-fry-state boa ; inline
110 : in-quot-slices ( n i state -- head tail )
113 [ [ drop ] 2dip swap 1 + tail-slice ] 3bi ; inline
115 : push-head-slice ( head state -- )
116 quot>> [ push-all ] [ \ _ swap push ] bi ; inline
118 : push-subquot ( tail elt state -- )
119 [ fry swap >quotation count-inputs [ndip] ] dip prequot>> push-all ; inline
121 : (dredge-fry-subquot) ( n state i elt -- )
123 [ nip in-quot-slices ] ! head tail i elt state
124 [ [ 2drop swap ] dip push-head-slice ]
125 [ [ drop ] 2dip push-subquot ]
126 [ [ 1 + ] [ drop ] [ ] tri* dredge-fry ]
127 } 3cleave ; inline recursive
129 : (dredge-fry-simple) ( n state -- )
130 [ in-quot>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive
132 : dredge-fry ( n dredge-fry -- )
133 2dup in-quot>> [ fried? ] find-from
134 [ (dredge-fry-subquot) ]
135 [ drop (dredge-fry-simple) ] if* ; inline recursive
139 M: callable fry ( quot -- quot' )
143 [ prequot>> >quotation ]
144 [ quot>> >quotation shallow-fry ] bi append
148 SYNTAX: '[ parse-quotation fry append! ;