1 ! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs effects.parser fry generic.parser
4 kernel lexer locals.errors locals.rewrite.closures locals.types
5 make namespaces parser quotations sequences splitting
11 : ?rewrite-closures ( form -- form' )
12 in-lambda? get [ 1array ] [ rewrite-closures ] if ;
14 ERROR: invalid-local-name name ;
16 : check-local-name ( name -- name )
17 dup { "]" "]!" } member? [ invalid-local-name ] when ;
19 : make-local ( name -- word )
20 check-local-name "!" ?tail [
22 dup <local-writer> dup name>> ,,
26 : make-locals ( seq -- words assoc )
27 [ [ make-local ] map ] H{ } make ;
29 : parse-local-defs ( -- words assoc )
30 "|" parse-tokens make-locals ;
32 SINGLETON: lambda-parser
34 : with-lambda-scope ( assoc reader-quot: ( -- quot ) -- quot )
37 { quotation-parser lambda-parser }
39 [ use-words @ ] [ unuse-words ] bi
40 ] with-variables ; inline
42 : (parse-lambda) ( assoc -- quot )
43 [ \ ] parse-until >quotation ] with-lambda-scope ;
45 : parse-lambda ( -- lambda )
47 (parse-lambda) <lambda>
50 : parse-multi-def ( -- multi-def assoc )
51 ")" parse-tokens make-locals [ <multi-def> ] dip ;
53 : parse-single-def ( name -- def assoc )
54 [ make-local <def> ] H{ } make ;
56 : update-locals ( assoc -- )
57 qualified-vocabs last words>> swap assoc-union! drop ;
59 : parse-def ( name/paren -- def )
60 dup "(" = [ drop parse-multi-def ] [ parse-single-def ] if update-locals ;
62 M: lambda-parser parse-quotation
63 H{ } clone (parse-lambda) ;
65 : parse-let ( -- form )
66 H{ } clone (parse-lambda) <let> ?rewrite-closures ;
68 : parse-locals ( -- effect vars assoc )
71 in>> [ dup pair? [ first ] when ] map make-locals ;
73 : (parse-locals-definition) ( effect vars assoc reader-quot -- word quot effect )
74 with-lambda-scope <lambda>
75 [ nip "lambda" set-word-prop ]
76 [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
77 [ drop nip ] 3tri ; inline
79 : parse-locals-definition ( word reader-quot -- word quot effect )
80 [ parse-locals ] dip (parse-locals-definition) ; inline
82 : parse-locals-method-definition ( word reader -- word quot effect )
83 [ parse-locals pick check-method-effect ] dip
84 (parse-locals-definition) ; inline
86 : (::) ( -- word def effect )
90 parse-locals-definition
93 : (M::) ( -- word def )
98 parse-locals-method-definition drop
99 ] with-method-definition