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