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