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