1 ! Copyright (C) 2022 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators
4 combinators.short-circuit combinators.smart fry generalizations
5 kernel lexer make math math.order multiline namespaces parser
6 prettyprint quotations sequences sequences.deep
7 sequences.private sets sorting.slots splitting
8 splitting.monotonic strings.parser ;
11 MACRO: nswapd ( ndown1 ndown2 dip -- quot )
12 [ 2dup < [ swap ] when
13 [ [ - ] keep ] [ ] 2bi ] dip
14 '[ [ _ _ -nrotd _ _ nrotd ] _ ndip ] ;
18 TUPLE: local name mutable? ;
20 : <local> ( name -- local )
24 [ >>mutable? ] when* ; inline
27 INSTANCE: fry-quot immutable-sequence
29 : <fry-quot> ( seq -- fry-quot )
33 M: fry-quot length seq>> length ;
34 M: fry-quot nth-unsafe seq>> nth-unsafe ;
36 : find-locals ( seq -- hash )
37 [ local? ] deep-filter members
38 { { name>> >=< } } sort-by zip-index reverse ;
43 SYNTAX: FRY[ parse-quotation <fry-quot> fry >quotation append! ;
44 SYNTAX: FRY2[ parse-quotation <fry-quot> fry2 append! ;
45 ! SYNTAX: LFRY[ parse-quotation <fry-quot> fry3 append! ;
46 SYNTAX: L" lexer get skip-blank parse-string <local> suffix! ;
49 : split-fry ( quot -- seq )
51 [ { _ @ } member? ] bi@
52 2array { { t f } { f f } } member?
55 : trim-fry ( seq -- quot )
58 unclip drop >quotation '[ _ curry ]
61 unclip drop >quotation '[ B _ compose ] ! B '[ call @ ]
66 ] map [ >quotation ] map dup .
68 '[ [ _ spread ] [ ] output>sequence concat ] ; inline
70 : fry2 ( quot -- quot' ) split-fry trim-fry ; inline
74 ! : fry3 ( quot -- quot' )
75 ! [ find-locals ] keep
76 ! [ convert-locals call ] keep
77 ! [ dup local? [ drop \ _ ] when ] map split-fry trim-fry ; inline
79 :: convert-locals ( locals quot -- quot' )
80 locals assoc-size :> size
84 { [ dup \ _ = ] [ drop 1 - [ ] , ] }
85 ! { [ dup \ @ = ] [ drop "omg" throw 1 - [ ] , ] }
87 [ locals at dup size swap - swap [ + ] dip '[ 1 _ _ mntuckd ] , ] keepd
89 ! { [ dup fry-quot? ] [
91 ! ! size '[ _ 1 1 noverd ] ,
92 ! ! [ locals ] dip '[ _ _ convert-locals fry ] ,
93 ! [ locals ] dip convert-locals fry '[ _ ] , ! fry ,
94 ! ! size '[ _ ndrop ] ,
100 ] [ ] make concat ; inline