1 ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators effects.parser
4 generic.parser kernel lexer locals.errors
5 locals.rewrite.closures locals.types make namespaces parser
6 quotations sequences splitting words ;
9 : make-local ( name -- word )
12 dup <local-writer> dup name>> set
16 : make-locals ( seq -- words assoc )
17 [ [ make-local ] map ] H{ } make-assoc ;
19 : make-local-word ( name def -- word )
20 [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
21 "local-word-def" set-word-prop ;
25 : push-locals ( assoc -- )
28 : pop-locals ( assoc -- )
33 : (parse-lambda) ( assoc end -- quot )
38 parse-until >quotation
42 : parse-lambda ( -- lambda )
43 "|" parse-tokens make-locals
44 \ ] (parse-lambda) <lambda> ;
46 : parse-binding ( end -- pair/f )
48 { [ dup not ] [ unexpected-eof ] }
49 { [ 2dup = ] [ 2drop f ] }
50 [ nip scan-object 2array ]
53 : (parse-bindings) ( end -- )
54 dup parse-binding dup [
55 first2 [ make-local ] dip 2array ,
59 : parse-bindings ( end -- bindings vars )
61 [ (parse-bindings) ] H{ } make-assoc
64 : parse-bindings* ( end -- words assoc )
73 : (parse-wbindings) ( end -- )
74 dup parse-binding dup [
75 first2 [ make-local-word ] keep 2array ,
79 : parse-wbindings ( end -- bindings vars )
81 [ (parse-wbindings) ] H{ } make-assoc
84 : parse-locals ( -- vars assoc )
85 "(" expect ")" parse-effect
86 word [ over "declared-effect" set-word-prop ] when*
87 in>> [ dup pair? [ first ] when ] map make-locals ;
89 : parse-locals-definition ( word -- word quot )
90 parse-locals \ ; (parse-lambda) <lambda>
91 2dup "lambda" set-word-prop
92 rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
94 : (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
96 : (M::) ( -- word def )
98 [ parse-locals-definition ] with-method-definition ;
100 : parsed-lambda ( accum form -- accum )
101 in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ;