core/lexer/lexer.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   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 IN: lexer
   6
   7 TUPLE: lexer text line line-text line-length column ;
   8
   9 : next-line ( lexer -- )
  10     dup [ line>> ] [ text>> ] bi ?nth >>line-text
  11     dup line-text>> length >>line-length
  12     [ 1+ ] change-line
  13     0 >>column
  14     drop ;
  15
  16 : new-lexer ( text class -- lexer )
  17     new
  18         0 >>line
  19         swap >>text
  20     dup next-line ; inline
  21
  22 : <lexer> ( text -- lexer )
  23     lexer new-lexer ;
  24
  25 : skip ( i seq ? -- n )
  26     over length
  27     [ [ swap CHAR: \s eq? xor ] curry find-from drop ] dip or ;
  28
  29 : change-lexer-column ( lexer quot -- )
  30     [ [ column>> ] [ line-text>> ] bi ] prepose keep
  31     (>>column) ; inline
  32
  33 GENERIC: skip-blank ( lexer -- )
  34
  35 M: lexer skip-blank ( lexer -- )
  36     [ t skip ] change-lexer-column ;
  37
  38 GENERIC: skip-word ( lexer -- )
  39
  40 M: lexer skip-word ( lexer -- )
  41     [
  42         2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
  43     ] change-lexer-column ;
  44
  45 : still-parsing? ( lexer -- ? )
  46     [ line>> ] [ text>> ] bi length <= ;
  47
  48 : still-parsing-line? ( lexer -- ? )
  49     [ column>> ] [ line-length>> ] bi < ;
  50
  51 : (parse-token) ( lexer -- str )
  52     {
  53         [ column>> ]
  54         [ skip-word ]
  55         [ column>> ]
  56         [ line-text>> ]
  57     } cleave subseq ;
  58
  59 :  parse-token ( lexer -- str/f )
  60     dup still-parsing? [
  61         dup skip-blank
  62         dup still-parsing-line?
  63         [ (parse-token) ] [ dup next-line parse-token ] if
  64     ] [ drop f ] if ;
  65
  66 : scan ( -- str/f ) lexer get parse-token ;
  67
  68 ERROR: unexpected want got ;
  69
  70 PREDICATE: unexpected-eof < unexpected
  71     got>> not ;
  72
  73 : unexpected-eof ( word -- * ) f unexpected ;
  74
  75 : expect ( token -- )
  76     scan
  77     [ 2dup = [ 2drop ] [ unexpected ] if ]
  78     [ unexpected-eof ]
  79     if* ;
  80
  81 : (parse-tokens) ( accum end -- accum )
  82     scan 2dup = [
  83         2drop
  84     ] [
  85         [ pick push (parse-tokens) ] [ unexpected-eof ] if*
  86     ] if ;
  87
  88 : parse-tokens ( end -- seq )
  89     100 <vector> swap (parse-tokens) >array ;
  90
  91 TUPLE: lexer-error line column line-text error ;
  92
  93 : <lexer-error> ( msg -- error )
  94     \ lexer-error new
  95         lexer get
  96         [ line>> >>line ]
  97         [ column>> >>column ]
  98         [ line-text>> >>line-text ]
  99         tri
 100         swap >>error ;
 101
 102 : lexer-dump ( error -- )
 103     [ line>> number>string ": " append ]
 104     [ line-text>> dup string? [ drop "" ] unless ]
 105     [ column>> 0 or ] tri
 106     pick length + CHAR: \s <string>
 107     [ write ] [ print ] [ write "^" print ] tri* ;
 108
 109 : with-lexer ( lexer quot -- newquot )
 110     [ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
 111
 112 SYMBOL: lexer-factory
 113
 114 [ <lexer> ] lexer-factory set-global