core/lexer/lexer.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences accessors namespaces math words strings
   4 io vectors arrays math.parser combinators continuations
   5 source-files.errors ;
   6 IN: lexer
   7
   8 TUPLE: lexer
   9 { text array }
  10 { line fixnum }
  11 { line-text maybe{ string } }
  12 { line-length fixnum }
  13 { column fixnum }
  14 { parsing-words vector } ;
  15
  16 TUPLE: lexer-parsing-word word line line-text column ;
  17
  18 : next-line ( lexer -- )
  19     dup [ line>> ] [ text>> ] bi ?nth
  20     [ >>line-text ] [ length >>line-length ] bi
  21     [ 1 + ] change-line
  22     0 >>column
  23     drop ;
  24
  25 : push-parsing-word ( word -- )
  26     lexer-parsing-word new
  27     swap >>word
  28     lexer get [
  29         [ line>>      >>line      ]
  30         [ line-text>> >>line-text ]
  31         [ column>>    >>column    ] tri
  32     ] [ parsing-words>> push ] bi ;
  33
  34 : pop-parsing-word ( -- )
  35     lexer get parsing-words>> pop* ;
  36
  37 : new-lexer ( text class -- lexer )
  38     new
  39         0 >>line
  40         swap >>text
  41         V{ } clone >>parsing-words
  42     dup next-line ; inline
  43
  44 : <lexer> ( text -- lexer )
  45     lexer new-lexer ;
  46
  47 ERROR: unexpected want got ;
  48
  49 : forbid-tab ( c -- c )
  50     [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; inline
  51
  52 : skip ( i seq ? -- n )
  53     over length
  54     [ [ swap forbid-tab CHAR: \s eq? xor ] curry find-from drop ] dip or ;
  55
  56 : change-lexer-column ( lexer quot -- )
  57     [ [ column>> ] [ line-text>> ] bi ] prepose keep
  58     column<< ; inline
  59
  60 GENERIC: skip-blank ( lexer -- )
  61
  62 M: lexer skip-blank ( lexer -- )
  63     [ t skip ] change-lexer-column ;
  64
  65 GENERIC: skip-word ( lexer -- )
  66
  67 <PRIVATE
  68
  69 : quote? ( column text -- ? )
  70     nth CHAR: " eq? ; inline
  71
  72 : shebang? ( column text -- ? )
  73     swap zero? [ "#!" head? ] [ drop f ] if ; inline
  74
  75 PRIVATE>
  76
  77 M: lexer skip-word ( lexer -- )
  78     [
  79         {
  80             { [ 2dup quote? ] [ drop 1 + ] }
  81             { [ 2dup shebang? ] [ drop 2 + ] }
  82             [ f skip ]
  83         } cond
  84     ] change-lexer-column ;
  85
  86 : still-parsing? ( lexer -- ? )
  87     [ line>> ] [ text>> length ] bi <= ;
  88
  89 : still-parsing-line? ( lexer -- ? )
  90     [ column>> ] [ line-length>> ] bi < ;
  91
  92 : (parse-token) ( lexer -- str )
  93     {
  94         [ column>> ]
  95         [ skip-word ]
  96         [ column>> ]
  97         [ line-text>> ]
  98     } cleave subseq ;
  99
 100 : parse-token ( lexer -- str/f )
 101     dup still-parsing? [
 102         dup skip-blank
 103         dup still-parsing-line?
 104         [ (parse-token) ] [ dup next-line parse-token ] if
 105     ] [ drop f ] if ;
 106
 107 : (scan-token) ( -- str/f ) lexer get parse-token ;
 108
 109 PREDICATE: unexpected-eof < unexpected got>> not ;
 110
 111 : unexpected-eof ( word -- * ) f unexpected ;
 112
 113 : scan-token ( -- str ) (scan-token) [ "token" unexpected-eof ] unless* ;
 114
 115 : expect ( token -- )
 116     scan-token 2dup = [ 2drop ] [ unexpected ] if ;
 117
 118 : each-token ( ... end quot: ( ... token -- ... ) -- ... )
 119     [ scan-token ] 2dip 2over =
 120     [ 3drop ] [ [ nip call ] [ each-token ] 2bi ] if ; inline recursive
 121
 122 : map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
 123     collector [ each-token ] dip { } like ; inline
 124
 125 : parse-tokens ( end -- seq )
 126     [ ] map-tokens ;
 127
 128 TUPLE: lexer-error line column line-text parsing-words error ;
 129
 130 M: lexer-error error-file error>> error-file ;
 131
 132 M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
 133
 134 : <lexer-error> ( msg -- error )
 135     \ lexer-error new
 136     lexer get [
 137         [ line>> >>line ]
 138         [ column>> >>column ] bi
 139     ] [
 140         [ line-text>> >>line-text ]
 141         [ parsing-words>> clone >>parsing-words ] bi
 142     ] bi
 143     swap >>error ;
 144
 145 : simple-lexer-dump ( error -- )
 146     [ line>> number>string ": " append ]
 147     [ line-text>> dup string? [ drop "" ] unless ]
 148     [ column>> 0 or ] tri
 149     pick length + CHAR: \s <string>
 150     [ write ] [ print ] [ write "^" print ] tri* ;
 151
 152 : (parsing-word-lexer-dump) ( error parsing-word -- )
 153     [
 154         line>> number>string
 155         over line>> number>string length
 156         CHAR: \s pad-head
 157         ": " append write
 158     ] [ line-text>> dup string? [ drop "" ] unless print ] bi
 159     simple-lexer-dump ;
 160
 161 : parsing-word-lexer-dump ( error parsing-word -- )
 162     2dup [ line>> ] same?
 163     [ drop simple-lexer-dump ]
 164     [ (parsing-word-lexer-dump) ] if ;
 165
 166 : lexer-dump ( error -- )
 167     dup parsing-words>>
 168     [ simple-lexer-dump ]
 169     [ last parsing-word-lexer-dump ] if-empty ;
 170
 171 : with-lexer ( lexer quot -- newquot )
 172     [ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline