1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators combinators.short-circuit
4 continuations effects fry generalizations kernel make math
5 namespaces quotations sequences sequences.private vectors words
9 GENERIC: expand-macros ( quot -- quot' )
14 V{ } clone stack set ;
17 stack get [ [ literalize , ] each ] [ delete-all ] bi ;
19 GENERIC: condomize? ( obj -- ? )
21 M: array condomize? [ condomize? ] any? ;
22 M: callable condomize? [ condomize? ] any? ;
23 M: object condomize? drop f ;
25 GENERIC: condomize ( obj -- obj' )
27 M: array condomize [ condomize ] map ;
28 M: callable condomize [ condomize ] map ;
32 dup condomize? [ condomize ] when stack get push ;
34 GENERIC: expand-macros* ( obj -- )
36 M: wrapper expand-macros* wrapped>> literal ;
38 : expand-dispatch? ( word -- ? )
39 \ dispatch eq? stack get length 1 >= and ;
41 : expand-dispatch ( -- )
43 [ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
45 length iota [ <reversed> ] keep
46 [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
49 : word, ( word -- ) end , ;
51 : expand-macro ( word quot -- )
54 stack [ _ with-datastack >vector ] change
55 stack get pop >quotation end
56 [ expand-macros* ] each
62 : macro-quot ( word -- quot/f )
64 [ "transform-quot" word-prop ]
68 : macro-effect ( word -- n )
70 [ "transform-n" word-prop ]
71 [ stack-effect in>> length ]
74 : expand-macro? ( word -- quot ? )
76 swap macro-effect stack get length <=
81 M: word expand-macros*
83 { [ dup expand-dispatch? ] [ drop expand-dispatch ] }
84 { [ dup expand-macro? ] [ expand-macro ] }
88 M: object expand-macros* literal ;
90 M: callable expand-macros*
91 expand-macros literal ;
93 M: callable expand-macros ( quot -- quot' )
94 [ begin [ expand-macros* ] each end ] [ ] make ;