2008-03-03 17:44:24 -05:00
|
|
|
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-07-03 12:25:27 -04:00
|
|
|
USING: kernel sequences combinators parser splitting math
|
2008-11-21 06:17:51 -05:00
|
|
|
quotations arrays make words locals.backend summary sets ;
|
2008-03-03 17:44:24 -05:00
|
|
|
IN: fry
|
|
|
|
|
2008-09-10 23:11:40 -04:00
|
|
|
: _ ( -- * ) "Only valid inside a fry" throw ;
|
2008-06-08 16:32:55 -04:00
|
|
|
: @ ( -- * ) "Only valid inside a fry" throw ;
|
2008-09-10 21:07:00 -04:00
|
|
|
|
2008-11-21 06:17:51 -05:00
|
|
|
ERROR: >r/r>-in-fry-error ;
|
|
|
|
|
2008-09-10 21:07:00 -04:00
|
|
|
<PRIVATE
|
2008-03-03 17:44:24 -05:00
|
|
|
|
2008-11-21 06:17:51 -05:00
|
|
|
: [ncurry] ( n -- quot )
|
|
|
|
{
|
|
|
|
{ 0 [ [ ] ] }
|
|
|
|
{ 1 [ [ curry ] ] }
|
|
|
|
{ 2 [ [ 2curry ] ] }
|
|
|
|
{ 3 [ [ 3curry ] ] }
|
2008-11-21 06:47:47 -05:00
|
|
|
[ \ curry <repetition> ]
|
2008-11-21 06:17:51 -05:00
|
|
|
} case ;
|
|
|
|
|
|
|
|
M: >r/r>-in-fry-error summary
|
|
|
|
drop
|
|
|
|
"Explicit retain stack manipulation is not permitted in fried quotations" ;
|
|
|
|
|
|
|
|
: check-fry ( quot -- quot )
|
2008-12-17 20:17:37 -05:00
|
|
|
dup { load-local load-locals get-local drop-locals } intersect
|
2008-11-21 06:17:51 -05:00
|
|
|
empty? [ >r/r>-in-fry-error ] unless ;
|
|
|
|
|
2008-09-11 01:36:55 -04:00
|
|
|
PREDICATE: fry-specifier < word { _ @ } memq? ;
|
2008-03-03 17:44:24 -05:00
|
|
|
|
2008-09-10 21:07:00 -04:00
|
|
|
GENERIC: count-inputs ( quot -- n )
|
|
|
|
|
|
|
|
M: callable count-inputs [ count-inputs ] sigma ;
|
2008-09-11 01:36:55 -04:00
|
|
|
M: fry-specifier count-inputs drop 1 ;
|
2008-09-10 21:07:00 -04:00
|
|
|
M: object count-inputs drop 0 ;
|
|
|
|
|
2008-11-27 22:55:20 -05:00
|
|
|
GENERIC: deep-fry ( obj -- )
|
|
|
|
|
|
|
|
: shallow-fry ( quot -- quot' curry# )
|
|
|
|
check-fry
|
|
|
|
[ [ deep-fry ] each ] [ ] make
|
|
|
|
[ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
|
|
|
|
{ _ } split [ spread>quot ] [ length 1- ] bi ;
|
|
|
|
|
2008-09-10 21:07:00 -04:00
|
|
|
PRIVATE>
|
2008-05-26 01:48:18 -04:00
|
|
|
|
2008-11-27 22:55:20 -05:00
|
|
|
: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ;
|
|
|
|
|
|
|
|
M: callable deep-fry
|
|
|
|
[ count-inputs \ _ <repetition> % ] [ fry % ] bi ;
|
|
|
|
|
|
|
|
M: object deep-fry , ;
|
2008-04-22 17:29:20 -04:00
|
|
|
|
2009-03-21 02:27:50 -04:00
|
|
|
SYNTAX: '[ parse-quotation fry over push-all ;
|