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 ( lexer quot -- )
  61     [ check-lexer [ column>> ] [ line-text>> ] bi ] prepose
  62     keep column<< ; inline
  63
  64 GENERIC: skip-blank ( lexer -- )
  65
  66 M: lexer skip-blank
  67     [ t skip ] change-lexer-column ;
  68
  69 GENERIC: skip-word ( lexer -- )
  70
  71 <PRIVATE
  72
  73 : quote? ( column text -- ? )
  74     { fixnum string } declare nth CHAR: " eq? ;
  75
  76 : shebang? ( column text -- ? )
  77     { fixnum string } declare swap zero? [
  78         dup length 1 > [
  79             dup first-unsafe CHAR: # =
  80             [ second-unsafe CHAR: ! = ] [ drop f ] if
  81         ] [ drop f ] if
  82     ] [ drop f ] if ;
  83
  84 PRIVATE>
  85
  86 M: lexer skip-word
  87     [
  88         {
  89             { [ 2dup quote? ] [ drop 1 + ] }
  90             { [ 2dup shebang? ] [ drop 2 + ] }
  91             [ f skip ]
  92         } cond
  93     ] change-lexer-column ;
  94
  95 : still-parsing? ( lexer -- ? )
  96     check-lexer [ line>> ] [ text>> length ] bi <= ;
  97
  98 : still-parsing-line? ( lexer -- ? )
  99     check-lexer [ column>> ] [ line-length>> ] bi < ;
 100
 101 : (parse-token) ( lexer -- str )
 102     check-lexer {
 103         [ column>> ]
 104         [ skip-word ]
 105         [ column>> ]
 106         [ line-text>> ]
 107     } cleave subseq ;
 108
 109 : parse-token ( lexer -- str/f )
 110     dup still-parsing? [
 111         dup skip-blank
 112         dup still-parsing-line?
 113         [ (parse-token) ] [ dup next-line parse-token ] if
 114     ] [ drop f ] if ;
 115
 116 : ?scan-token ( -- str/f ) lexer get parse-token ;
 117
 118 PREDICATE: unexpected-eof < unexpected got>> not ;
 119
 120 : throw-unexpected-eof ( word -- * ) f unexpected ;
 121
 122 : scan-token ( -- str )
 123     ?scan-token [ "token" throw-unexpected-eof ] unless* ;
 124
 125 : expect ( token -- )
 126     scan-token 2dup = [ 2drop ] [ unexpected ] if ;
 127
 128 : each-token ( ... end quot: ( ... token -- ... ) -- ... )
 129     [ scan-token ] 2dip 2over =
 130     [ 3drop ] [ [ nip call ] [ each-token ] 2bi ] if ; inline recursive
 131
 132 : map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
 133     collector [ each-token ] dip { } like ; inline
 134
 135 : parse-tokens ( end -- seq )
 136     [ ] map-tokens ;
 137
 138 TUPLE: lexer-error line column line-text parsing-words error ;
 139
 140 M: lexer-error error-file error>> error-file ;
 141
 142 M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
 143
 144 : <lexer-error> ( msg -- error )
 145     [
 146         lexer get {
 147             [ line>> ]
 148             [ column>> ]
 149             [ line-text>> ]
 150             [ parsing-words>> clone ]
 151         } cleave
 152     ] dip lexer-error boa ;
 153
 154 : simple-lexer-dump ( error -- )
 155     [ line>> number>string ": " append ]
 156     [ line-text>> ]
 157     [ column>> ] tri
 158     pick length + CHAR: \s <string>
 159     [ write ] [ print ] [ write "^" print ] tri* ;
 160
 161 : (parsing-word-lexer-dump) ( error parsing-word -- )
 162     [
 163         line>> number>string
 164         over line>> number>string length
 165         CHAR: \s pad-head
 166         ": " append write
 167     ] [ line-text>> print ] bi
 168     simple-lexer-dump ;
 169
 170 : parsing-word-lexer-dump ( error parsing-word -- )
 171     2dup [ line>> ] same?
 172     [ drop simple-lexer-dump ]
 173     [ (parsing-word-lexer-dump) ] if ;
 174
 175 : lexer-dump ( error -- )
 176     dup parsing-words>>
 177     [ simple-lexer-dump ]
 178     [ last parsing-word-lexer-dump ] if-empty ;
 179
 180 : with-lexer ( lexer quot -- newquot )
 181     [ [ <lexer-error> rethrow ] recover ] curry
 182     [ lexer ] dip with-variable ; inline