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 combinators effects.parser
   4 generic.parser kernel lexer locals.errors fry
   5 locals.rewrite.closures locals.types make namespaces parser
   6 quotations sequences splitting words vocabs.parser ;
   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 : make-local ( name -- word )
  15     "!" ?tail [
  16         <local-reader>
  17         dup <local-writer> dup name>> set
  18     ] [ <local> ] if
  19     dup dup name>> set ;
  20
  21 : make-locals ( seq -- words assoc )
  22     [ [ make-local ] map ] H{ } make-assoc ;
  23
  24 : parse-local-defs ( -- words assoc )
  25     [ "|" [ make-local ] map-tokens ] H{ } make-assoc ;
  26
  27 SINGLETON: lambda-parser
  28
  29 SYMBOL: locals
  30
  31 : ((parse-lambda)) ( assoc quot -- quot' )
  32     '[
  33         in-lambda? on
  34         lambda-parser quotation-parser set
  35         [ locals set ]
  36         [ use-words @ ]
  37         [ unuse-words ] tri
  38     ] with-scope ; inline
  39
  40 : (parse-lambda) ( assoc -- quot )
  41     [ \ ] parse-until >quotation ] ((parse-lambda)) ;
  42
  43 : parse-lambda ( -- lambda )
  44     parse-local-defs
  45     (parse-lambda) <lambda>
  46     ?rewrite-closures ;
  47
  48 : parse-multi-def ( locals -- multi-def )
  49     [ ")" [ make-local ] map-tokens ] with-variables <multi-def> ;
  50
  51 : parse-def ( name/paren locals -- def )
  52     over "(" = [ nip parse-multi-def ] [ [ make-local ] with-variables <def> ] if ;
  53
  54 M: lambda-parser parse-quotation ( -- quotation )
  55     H{ } clone (parse-lambda) ;
  56
  57 : parse-binding ( end -- pair/f )
  58     scan-token {
  59         { [ 2dup = ] [ 2drop f ] }
  60         [ nip scan-object 2array ]
  61     } cond ;
  62
  63 : parse-let ( -- form )
  64     H{ } clone (parse-lambda) <let> ?rewrite-closures ;
  65
  66 : parse-locals ( -- effect vars assoc )
  67     scan-effect
  68     dup
  69     in>> [ dup pair? [ first ] when ] map make-locals ;
  70
  71 : (parse-locals-definition) ( effect vars assoc reader -- word quot effect )
  72     ((parse-lambda)) <lambda>
  73     [ nip "lambda" set-word-prop ]
  74     [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
  75     [ drop nip ] 3tri ; inline
  76
  77 : parse-locals-definition ( word reader -- word quot effect )
  78     [ parse-locals ] dip (parse-locals-definition) ; inline
  79
  80 : parse-locals-method-definition ( word reader -- word quot effect )
  81     [ parse-locals pick check-method-effect ] dip
  82     (parse-locals-definition) ; inline
  83
  84 : (::) ( -- word def effect )
  85     scan-new-word
  86     [ parse-definition ]
  87     parse-locals-definition ;
  88
  89 : (M::) ( -- word def )
  90     scan-new-method
  91     [
  92         [ parse-definition ]
  93         parse-locals-method-definition drop
  94     ] with-method-definition ;