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