basis/locals/parser/parser.factor

   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
   6 vocabs.parser words ;
   7 IN: locals.parser
   8
   9 SYMBOL: in-lambda?
  10
  11 : ?rewrite-closures ( form -- form' )
  12     in-lambda? get [ 1array ] [ rewrite-closures ] if ;
  13
  14 ERROR: invalid-local-name name ;
  15
  16 : check-local-name ( name -- name )
  17     dup { "]" "]!" } member? [ invalid-local-name ] when ;
  18
  19 : make-local ( name -- word )
  20     check-local-name "!" ?tail [
  21         <local-reader>
  22         dup <local-writer> dup name>> ,,
  23     ] [ <local> ] if
  24     dup dup name>> ,, ;
  25
  26 : make-locals ( seq -- words assoc )
  27     [ [ make-local ] map ] H{ } make ;
  28
  29 : parse-local-defs ( -- words assoc )
  30     "|" parse-tokens make-locals ;
  31
  32 SINGLETON: lambda-parser
  33
  34 : with-lambda-scope ( assoc reader-quot: ( -- quot ) -- quot )
  35     H{
  36         { in-lambda? t }
  37         { quotation-parser lambda-parser }
  38     } swap '[
  39         [ use-words @ ] [ unuse-words ] bi
  40     ] with-variables ; inline
  41
  42 : (parse-lambda) ( assoc -- quot )
  43     [ \ ] parse-until >quotation ] with-lambda-scope ;
  44
  45 : parse-lambda ( -- lambda )
  46     parse-local-defs
  47     (parse-lambda) <lambda>
  48     ?rewrite-closures ;
  49
  50 : parse-multi-def ( -- multi-def assoc )
  51     ")" parse-tokens make-locals [ <multi-def> ] dip ;
  52
  53 : parse-single-def ( name -- def assoc )
  54     [ make-local <def> ] H{ } make ;
  55
  56 : update-locals ( assoc -- )
  57     qualified-vocabs last words>> swap assoc-union! drop ;
  58
  59 : parse-def ( name/paren -- def )
  60     dup "(" = [ drop parse-multi-def ] [ parse-single-def ] if update-locals ;
  61
  62 M: lambda-parser parse-quotation ( -- quotation )
  63     H{ } clone (parse-lambda) ;
  64
  65 : parse-let ( -- form )
  66     H{ } clone (parse-lambda) <let> ?rewrite-closures ;
  67
  68 : parse-locals ( -- effect vars assoc )
  69     scan-effect
  70     dup
  71     in>> [ dup pair? [ first ] when ] map make-locals ;
  72
  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
  78
  79 : parse-locals-definition ( word reader-quot -- word quot effect )
  80     [ parse-locals ] dip (parse-locals-definition) ; inline
  81
  82 : parse-locals-method-definition ( word reader -- word quot effect )
  83     [ parse-locals pick check-method-effect ] dip
  84     (parse-locals-definition) ; inline
  85
  86 : (::) ( -- word def effect )
  87     [
  88         scan-new-word
  89         [ parse-definition ]
  90         parse-locals-definition
  91     ] with-definition ;
  92
  93 : (M::) ( -- word def )
  94     [
  95         scan-new-method
  96         [
  97             [ parse-definition ]
  98             parse-locals-method-definition drop
  99         ] with-method-definition
 100     ] with-definition ;