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 combinators continuations
   4 effects.parser fry generic.parser kernel lexer locals.errors
   5 locals.rewrite.closures locals.types make namespaces parser
   6 quotations sequences splitting 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? [ throw-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     '[
  36         in-lambda? on
  37         lambda-parser quotation-parser set
  38         use-words @
  39         qualified-vocabs pop* ! can't use unuse-words here
  40     ] with-scope ; 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-binding ( end -- pair/f )
  66     scan-token {
  67         { [ 2dup = ] [ 2drop f ] }
  68         [ nip scan-object 2array ]
  69     } cond ;
  70
  71 : parse-let ( -- form )
  72     H{ } clone (parse-lambda) <let> ?rewrite-closures ;
  73
  74 : parse-locals ( -- effect vars assoc )
  75     scan-effect
  76     dup
  77     in>> [ dup pair? [ first ] when ] map make-locals ;
  78
  79 : (parse-locals-definition) ( effect vars assoc reader-quot -- word quot effect )
  80     with-lambda-scope <lambda>
  81     [ nip "lambda" set-word-prop ]
  82     [ nip rewrite-closures dup length 1 = [ first ] [ throw-bad-rewrite ] if ]
  83     [ drop nip ] 3tri ; inline
  84
  85 : parse-locals-definition ( word reader-quot -- word quot effect )
  86     [ parse-locals ] dip (parse-locals-definition) ; inline
  87
  88 : parse-locals-method-definition ( word reader -- word quot effect )
  89     [ parse-locals pick check-method-effect ] dip
  90     (parse-locals-definition) ; inline
  91
  92 : (::) ( -- word def effect )
  93     [
  94         scan-new-word
  95         [ parse-definition ]
  96         parse-locals-definition
  97     ] with-definition ;
  98
  99 : (M::) ( -- word def )
 100     [
 101         scan-new-method
 102         [
 103             [ parse-definition ]
 104             parse-locals-method-definition drop
 105         ] with-method-definition
 106     ] with-definition ;