2008-03-03 17:44:24 -05:00
|
|
|
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
|
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
|
USING: kernel sequences combinators parser splitting
|
2008-03-11 04:30:35 -04:00
|
|
|
quotations arrays namespaces qualified ;
|
|
|
|
|
QUALIFIED: namespaces
|
2008-03-03 17:44:24 -05:00
|
|
|
IN: fry
|
|
|
|
|
|
|
|
|
|
: , "Only valid inside a fry" throw ;
|
|
|
|
|
: @ "Only valid inside a fry" throw ;
|
|
|
|
|
: _ "Only valid inside a fry" throw ;
|
|
|
|
|
|
2008-04-22 17:29:20 -04:00
|
|
|
DEFER: (shallow-fry)
|
2008-03-03 17:44:24 -05:00
|
|
|
|
2008-04-22 17:29:20 -04:00
|
|
|
: ((shallow-fry)) ( accum quot adder -- result )
|
|
|
|
|
>r [ ] swap (shallow-fry) r>
|
2008-03-03 17:44:24 -05:00
|
|
|
append swap dup empty? [ drop ] [
|
2008-04-26 00:17:08 -04:00
|
|
|
[ prepose ] curry append
|
2008-03-03 17:44:24 -05:00
|
|
|
] if ; inline
|
|
|
|
|
|
2008-04-22 17:29:20 -04:00
|
|
|
: (shallow-fry) ( accum quot -- result )
|
2008-03-03 17:44:24 -05:00
|
|
|
dup empty? [
|
|
|
|
|
drop 1quotation
|
|
|
|
|
] [
|
|
|
|
|
unclip {
|
2008-04-22 17:29:20 -04:00
|
|
|
{ \ , [ [ curry ] ((shallow-fry)) ] }
|
|
|
|
|
{ \ @ [ [ compose ] ((shallow-fry)) ] }
|
2008-03-11 04:30:35 -04:00
|
|
|
|
|
|
|
|
! to avoid confusion, remove if fry goes core
|
2008-04-22 17:29:20 -04:00
|
|
|
{ \ namespaces:, [ [ curry ] ((shallow-fry)) ] }
|
2008-03-11 04:30:35 -04:00
|
|
|
|
2008-04-22 17:29:20 -04:00
|
|
|
[ swap >r suffix r> (shallow-fry) ]
|
2008-03-03 17:44:24 -05:00
|
|
|
} case
|
|
|
|
|
] if ;
|
|
|
|
|
|
2008-04-22 17:29:20 -04:00
|
|
|
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
|
2008-03-03 17:44:24 -05:00
|
|
|
|
2008-04-22 17:29:20 -04:00
|
|
|
: deep-fry ( quot -- quot' )
|
2008-03-03 17:44:24 -05:00
|
|
|
{ _ } last-split1 [
|
|
|
|
|
[
|
2008-04-22 17:29:20 -04:00
|
|
|
shallow-fry %
|
2008-03-03 17:44:24 -05:00
|
|
|
[ >r ] %
|
2008-04-22 17:29:20 -04:00
|
|
|
deep-fry %
|
2008-03-03 17:44:24 -05:00
|
|
|
[ [ dip ] curry r> compose ] %
|
|
|
|
|
] [ ] make
|
|
|
|
|
] [
|
2008-04-22 17:29:20 -04:00
|
|
|
shallow-fry
|
2008-03-03 17:44:24 -05:00
|
|
|
] if* ;
|
|
|
|
|
|
2008-04-22 17:29:20 -04:00
|
|
|
: fry ( quot -- quot' )
|
|
|
|
|
[
|
|
|
|
|
[
|
|
|
|
|
dup callable? [
|
|
|
|
|
[
|
2008-04-26 00:17:08 -04:00
|
|
|
[ { , namespaces:, @ } member? ] filter length
|
2008-04-22 17:29:20 -04:00
|
|
|
\ , <repetition> %
|
|
|
|
|
]
|
|
|
|
|
[ deep-fry % ] bi
|
|
|
|
|
] [ namespaces:, ] if
|
|
|
|
|
] each
|
|
|
|
|
] [ ] make deep-fry ;
|
|
|
|
|
|
2008-03-03 17:44:24 -05:00
|
|
|
: '[ \ ] parse-until fry over push-all ; parsing
|