basis/locals/parser/parser.factor

   1 ! Copyright (C) 2007, 2008 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
   5 locals.rewrite.closures locals.types make namespaces parser
   6 quotations sequences splitting words ;
   7 IN: locals.parser
   8
   9 : make-local ( name -- word )
  10     "!" ?tail [
  11         <local-reader>
  12         dup <local-writer> dup name>> set
  13     ] [ <local> ] if
  14     dup dup name>> set ;
  15
  16 : make-locals ( seq -- words assoc )
  17     [ [ make-local ] map ] H{ } make-assoc ;
  18
  19 : make-local-word ( name def -- word )
  20     [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
  21     "local-word-def" set-word-prop ;
  22
  23 SYMBOL: locals
  24
  25 : push-locals ( assoc -- )
  26     use get push ;
  27
  28 : pop-locals ( assoc -- )
  29     use get delete ;
  30
  31 SYMBOL: in-lambda?
  32
  33 : (parse-lambda) ( assoc end -- quot )
  34     [
  35         in-lambda? on
  36         over locals set
  37         over push-locals
  38         parse-until >quotation
  39         swap pop-locals
  40     ] with-scope ;
  41
  42 : parse-lambda ( -- lambda )
  43     "|" parse-tokens make-locals
  44     \ ] (parse-lambda) <lambda> ;
  45
  46 : parse-binding ( end -- pair/f )
  47     scan {
  48         { [ dup not ] [ unexpected-eof ] }
  49         { [ 2dup = ] [ 2drop f ] }
  50         [ nip scan-object 2array ]
  51     } cond ;
  52
  53 : (parse-bindings) ( end -- )
  54     dup parse-binding dup [
  55         first2 [ make-local ] dip 2array ,
  56         (parse-bindings)
  57     ] [ 2drop ] if ;
  58
  59 : parse-bindings ( end -- bindings vars )
  60     [
  61         [ (parse-bindings) ] H{ } make-assoc
  62     ] { } make swap ;
  63
  64 : parse-bindings* ( end -- words assoc )
  65     [
  66         [
  67             namespace push-locals
  68             (parse-bindings)
  69             namespace pop-locals
  70         ] { } make-assoc
  71     ] { } make swap ;
  72
  73 : (parse-wbindings) ( end -- )
  74     dup parse-binding dup [
  75         first2 [ make-local-word ] keep 2array ,
  76         (parse-wbindings)
  77     ] [ 2drop ] if ;
  78
  79 : parse-wbindings ( end -- bindings vars )
  80     [
  81         [ (parse-wbindings) ] H{ } make-assoc
  82     ] { } make swap ;
  83
  84 : parse-locals ( -- vars assoc )
  85     "(" expect ")" parse-effect
  86     word [ over "declared-effect" set-word-prop ] when*
  87     in>> [ dup pair? [ first ] when ] map make-locals ;
  88
  89 : parse-locals-definition ( word -- word quot )
  90     parse-locals \ ; (parse-lambda) <lambda>
  91     2dup "lambda" set-word-prop
  92     rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
  93
  94 : (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
  95
  96 : (M::) ( -- word def )
  97     CREATE-METHOD
  98     [ parse-locals-definition ] with-method-definition ;
  99
 100 : parsed-lambda ( accum form -- accum )
 101     in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ;