core/lexer/lexer.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences accessors namespaces math words strings
   4 debugger io vectors arrays math.parser combinators inspector
   5 continuations ;
   6 IN: lexer
   7
   8 TUPLE: lexer text line line-text line-length column ;
   9
  10 : next-line ( lexer -- )
  11     dup [ line>> ] [ text>> ] bi ?nth >>line-text
  12     dup line-text>> length >>line-length
  13     [ 1+ ] change-line
  14     0 >>column
  15     drop ;
  16
  17 : new-lexer ( text class -- lexer )
  18     new
  19         0 >>line
  20         swap >>text
  21     dup next-line ; inline
  22
  23 : <lexer> ( text -- lexer )
  24     lexer new-lexer ;
  25
  26 : skip ( i seq ? -- n )
  27     over >r
  28     [ swap CHAR: \s eq? xor ] curry find-from drop
  29     [ r> drop ] [ r> length ] if* ;
  30
  31 : change-lexer-column ( lexer quot -- )
  32     swap
  33     [ dup lexer-column swap lexer-line-text rot call ] keep
  34     set-lexer-column ; inline
  35
  36 GENERIC: skip-blank ( lexer -- )
  37
  38 M: lexer skip-blank ( lexer -- )
  39     [ t skip ] change-lexer-column ;
  40
  41 GENERIC: skip-word ( lexer -- )
  42
  43 M: lexer skip-word ( lexer -- )
  44     [
  45         2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
  46     ] change-lexer-column ;
  47
  48 : still-parsing? ( lexer -- ? )
  49     dup lexer-line swap lexer-text length <= ;
  50
  51 : still-parsing-line? ( lexer -- ? )
  52     dup lexer-column swap lexer-line-length < ;
  53
  54 : (parse-token) ( lexer -- str )
  55     [ lexer-column ] keep
  56     [ skip-word ] keep
  57     [ lexer-column ] keep
  58     lexer-line-text subseq ;
  59
  60 :  parse-token ( lexer -- str/f )
  61     dup still-parsing? [
  62         dup skip-blank
  63         dup still-parsing-line?
  64         [ (parse-token) ] [ dup next-line parse-token ] if
  65     ] [ drop f ] if ;
  66
  67 : scan ( -- str/f ) lexer get parse-token ;
  68
  69 ERROR: unexpected want got ;
  70
  71 GENERIC: expected>string ( obj -- str )
  72
  73 M: f expected>string drop "end of input" ;
  74 M: word expected>string word-name ;
  75 M: string expected>string ;
  76
  77 M: unexpected error.
  78     "Expected " write
  79     dup unexpected-want expected>string write
  80     " but got " write
  81     unexpected-got expected>string print ;
  82
  83 PREDICATE: unexpected-eof < unexpected
  84     unexpected-got not ;
  85
  86 : unexpected-eof ( word -- * ) f unexpected ;
  87
  88 : (parse-tokens) ( accum end -- accum )
  89     scan 2dup = [
  90         2drop
  91     ] [
  92         [ pick push (parse-tokens) ] [ unexpected-eof ] if*
  93     ] if ;
  94
  95 : parse-tokens ( end -- seq )
  96     100 <vector> swap (parse-tokens) >array ;
  97
  98 TUPLE: lexer-error line column line-text error ;
  99
 100 : <lexer-error> ( msg -- error )
 101     \ lexer-error new
 102         lexer get
 103         [ line>> >>line ]
 104         [ column>> >>column ]
 105         [ line-text>> >>line-text ]
 106         tri
 107         swap >>error ;
 108
 109 : lexer-dump ( error -- )
 110     [ line>> number>string ": " append ]
 111     [ line-text>> dup string? [ drop "" ] unless ]
 112     [ column>> 0 or ] tri
 113     pick length + CHAR: \s <string>
 114     [ write ] [ print ] [ write "^" print ] tri* ;
 115
 116 M: lexer-error error.
 117     [ lexer-dump ] [ error>> error. ] bi ;
 118
 119 M: lexer-error summary
 120     error>> summary ;
 121
 122 M: lexer-error compute-restarts
 123     error>> compute-restarts ;
 124
 125 M: lexer-error error-help
 126     error>> error-help ;
 127
 128 : with-lexer ( lexer quot -- newquot )
 129     [ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
 130
 131 SYMBOL: lexer-factory
 132
 133 [ <lexer> ] lexer-factory set-global