core/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 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     } -rot '[ _ _ with-words ] with-variables ; inline
  39
  40 : (parse-lambda) ( assoc -- quot )
  41     [ \ ] parse-until >quotation ] with-lambda-scope ;
  42
  43 : parse-lambda ( -- lambda )
  44     parse-local-defs
  45     (parse-lambda) <lambda>
  46     ?rewrite-closures ;
  47
  48 : update-locals ( assoc -- )
  49     qualified-vocabs last words>> swap assoc-union! drop ;
  50
  51 : parse-def ( name/paren -- def )
  52     dup "(" = [ drop ")" parse-tokens ] [ 1array ] if
  53     make-locals [ <def> ] [ update-locals ] bi* ;
  54
  55 M: lambda-parser parse-quotation
  56     H{ } clone (parse-lambda) ;
  57
  58 : parse-let ( -- form )
  59     H{ } clone (parse-lambda) <let> ?rewrite-closures ;
  60
  61 : parse-locals ( -- effect vars assoc )
  62     scan-effect
  63     dup
  64     in>> [ dup pair? [ first ] when ] map make-locals ;
  65
  66 : (parse-locals-definition) ( effect vars assoc reader-quot -- word quot effect )
  67     with-lambda-scope <lambda>
  68     [ nip "lambda" set-word-prop ]
  69     [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
  70     [ drop nip ] 3tri ; inline
  71
  72 : parse-locals-definition ( word reader-quot -- word quot effect )
  73     [ parse-locals ] dip (parse-locals-definition) ; inline
  74
  75 : parse-locals-method-definition ( word reader -- word quot effect )
  76     [ parse-locals pick check-method-effect ] dip
  77     (parse-locals-definition) ; inline
  78
  79 : (::) ( -- word def effect )
  80     [
  81         scan-new-word
  82         [ parse-definition ]
  83         parse-locals-definition
  84     ] with-definition ;
  85
  86 : (M::) ( -- word def )
  87     [
  88         scan-new-method
  89         [
  90             [ parse-definition ]
  91             parse-locals-method-definition drop
  92         ] with-method-definition
  93     ] with-definition ;