core/effects/parser/parser.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: lexer sets sequences kernel splitting effects
   4 combinators arrays make vocabs.parser classes parser ;
   5 IN: effects.parser
   6
   7 DEFER: parse-effect
   8
   9 ERROR: bad-effect ;
  10 ERROR: invalid-row-variable ;
  11 ERROR: row-variable-can't-have-type ;
  12 ERROR: stack-effect-omits-dashes ;
  13
  14 SYMBOL: effect-var
  15
  16 <PRIVATE
  17 : end-token? ( end token -- token ? ) [ nip ] [ = ] 2bi ; inline
  18 : effect-opener? ( token -- token ? ) dup { f "(" "((" "--" } member? ; inline
  19 : effect-closer? ( token -- token ? ) dup { ")" "))" } member? ; inline
  20 : row-variable? ( token -- token' ? ) ".." ?head ; inline
  21
  22 : parse-effect-var ( first? var name -- var )
  23     nip
  24     [ ":" ?tail [ row-variable-can't-have-type ] when ] curry
  25     [ invalid-row-variable ] if ;
  26
  27 : parse-effect-value ( token -- value )
  28     ":" ?tail [
  29         scan-token {
  30             { [ dup "(" = ] [ drop ")" parse-effect ] }
  31             [ parse-word dup class? [ bad-effect ] unless ]
  32         } cond 2array
  33     ] when ;
  34 PRIVATE>
  35
  36 : parse-effect-token ( first? var end -- var more? )
  37     scan {
  38         { [ end-token? ] [ drop nip f ] }
  39         { [ effect-opener? ] [ bad-effect ] }
  40         { [ effect-closer? ] [ stack-effect-omits-dashes ] }
  41         { [ row-variable? ] [ parse-effect-var t ] }
  42         [ [ drop ] 2dip parse-effect-value , t ]
  43     } cond ;
  44
  45 : parse-effect-tokens ( end -- var tokens )
  46     [
  47         [ t f ] dip [ parse-effect-token [ f ] 2dip ] curry [ ] while nip
  48     ] { } make ;
  49
  50 : parse-effect ( end -- effect )
  51     [ "--" parse-effect-tokens ] dip parse-effect-tokens
  52     <variable-effect> ;
  53
  54 : complete-effect ( -- effect )
  55     "(" expect ")" parse-effect ;
  56
  57 : parse-call( ( accum word -- accum )
  58     [ ")" parse-effect ] dip 2array append! ;
  59
  60 : (:) ( -- word def effect )
  61     CREATE-WORD
  62     complete-effect
  63     parse-definition swap ;