core/locals/parser/parser.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
   2 ! See https://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
   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 : parse-multi-def ( -- multi-def assoc )
  49     ")" parse-tokens make-locals [ <multi-def> ] dip ;
  50
  51 : parse-single-def ( name -- def assoc )
  52     [ make-local <def> ] H{ } make ;
  53
  54 : update-locals ( assoc -- )
  55     qualified-vocabs last words>> swap assoc-union! drop ;
  56
  57 : parse-def ( name/paren -- def )
  58     dup "(" = [ drop parse-multi-def ] [ parse-single-def ] if update-locals ;
  59
  60 M: lambda-parser parse-quotation
  61     H{ } clone (parse-lambda) ;
  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-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
  76
  77 : parse-locals-definition ( word reader-quot -- 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     [
  86         scan-new-word
  87         [ parse-definition ]
  88         parse-locals-definition
  89     ] with-definition ;
  90
  91 : (M::) ( -- word def )
  92     [
  93         scan-new-method
  94         [
  95             [ parse-definition ]
  96             parse-locals-method-definition drop
  97         ] with-method-definition
  98     ] with-definition ;