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 generic.parser
4 kernel lexer locals.errors locals.rewrite 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 }
38 } -rot '[ _ _ with-words ] with-variables ; inline
40 : (parse-lambda) ( assoc -- quot )
41 [ \ ] parse-until >quotation ] with-lambda-scope ;
43 : parse-lambda ( -- lambda )
45 (parse-lambda) <lambda>
48 : parse-multi-def ( -- multi-def assoc )
49 ")" parse-tokens make-locals [ <multi-def> ] dip ;
51 : parse-single-def ( name -- def assoc )
52 [ make-local <def> ] H{ } make ;
54 : update-locals ( assoc -- )
55 qualified-vocabs last words>> swap assoc-union! drop ;
57 : parse-def ( name/paren -- def )
58 dup "(" = [ drop parse-multi-def ] [ parse-single-def ] if update-locals ;
60 M: lambda-parser parse-quotation
61 H{ } clone (parse-lambda) ;
63 : parse-let ( -- form )
64 H{ } clone (parse-lambda) <let> ?rewrite-closures ;
66 : parse-locals ( -- effect vars assoc )
69 in>> [ dup pair? [ first ] when ] map make-locals ;
71 : (parse-locals-definition) ( effect vars assoc reader-quot -- word quot effect )
72 with-lambda-scope <lambda>
73 [ nip "lambda" set-word-prop ]
74 [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
75 [ drop nip ] 3tri ; inline
77 : parse-locals-definition ( word reader-quot -- word quot effect )
78 [ parse-locals ] dip (parse-locals-definition) ; inline
80 : parse-locals-method-definition ( word reader -- word quot effect )
81 [ parse-locals pick check-method-effect ] dip
82 (parse-locals-definition) ; inline
84 : (::) ( -- word def effect )
88 parse-locals-definition
91 : (M::) ( -- word def )
96 parse-locals-method-definition drop
97 ] with-method-definition