core/effects/parser/parser.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators continuations effects
   4 kernel lexer make namespaces parser sequences sets
   5 splitting vocabs.parser words ;
   6 IN: effects.parser
   7
   8 DEFER: parse-effect
   9
  10 ERROR: bad-effect ;
  11 ERROR: invalid-row-variable ;
  12 ERROR: row-variable-can't-have-type ;
  13 ERROR: stack-effect-omits-dashes ;
  14
  15 SYMBOL: effect-var
  16
  17 <PRIVATE
  18 : end-token? ( end token -- token ? ) [ nip ] [ = ] 2bi ; inline
  19 : effect-opener? ( token -- token ? ) dup { f "(" "--" } member? ; inline
  20 : effect-closer? ( token -- token ? ) dup ")" sequence= ; inline
  21 : row-variable? ( token -- token' ? ) ".." ?head ; inline
  22 : standalone-type? ( token -- token' ? ) ":" ?head ; inline
  23
  24 : parse-effect-var ( first? var name -- var )
  25     nip
  26     [ ":" ?tail [ row-variable-can't-have-type ] when ] curry
  27     [ invalid-row-variable ] if ;
  28
  29 : parse-effect-value ( token -- value )
  30     ":" ?tail [ scan-object 2array ] when ;
  31
  32 ERROR: bad-standalone-effect obj ;
  33 : parse-standalone-type ( obj -- var )
  34     parse-datum
  35     dup parsing-word? [
  36         ?execute-parsing dup length 1 =
  37         [ first ] [ bad-standalone-effect ] if
  38     ] when f swap 2array ;
  39 PRIVATE>
  40
  41 : parse-effect-token ( first? var end -- var more? )
  42     scan-token {
  43         { [ end-token? ] [ drop nip f ] }
  44         { [ effect-opener? ] [ bad-effect ] }
  45         { [ effect-closer? ] [ stack-effect-omits-dashes ] }
  46         { [ row-variable? ] [ parse-effect-var t ] }
  47         [
  48             [ drop ] 2dip standalone-type?
  49             [ parse-standalone-type ] [ parse-effect-value ] if , t
  50         ]
  51     } cond ;
  52
  53 : parse-effect-tokens ( end -- var tokens )
  54     [
  55         [ t f ] dip [ parse-effect-token [ f ] 2dip ] curry [ ] while nip
  56     ] { } make ;
  57
  58 : parse-effect ( end -- effect )
  59     [ "--" parse-effect-tokens ] dip parse-effect-tokens
  60     <variable-effect> ;
  61
  62 : scan-effect ( -- effect )
  63     "(" expect ")" parse-effect ;
  64
  65 : parse-call-paren ( accum word -- accum )
  66     [ ")" parse-effect ] dip 2array append! ;
  67
  68 CONSTANT: in-definition HS{ }
  69
  70 ERROR: can't-nest-definitions word ;
  71
  72 : set-in-definition ( -- )
  73     manifest get current-vocab>> t or in-definition ?adjoin
  74     [ last-word can't-nest-definitions ] unless ;
  75
  76 : unset-in-definition ( -- )
  77     manifest get current-vocab>> t or in-definition delete ;
  78
  79 : with-definition ( quot -- )
  80     [ set-in-definition ] prepose [ unset-in-definition ] [ ] cleanup ; inline
  81
  82 : (:) ( -- word def effect )
  83     [
  84         scan-new-word
  85         scan-effect
  86         parse-definition swap
  87     ] with-definition ;