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     over >r
  27     [ swap CHAR: \s eq? xor ] curry find-from drop
  28     [ r> drop ] [ r> length ] if* ;
  29
  30 : change-lexer-column ( lexer quot -- )
  31     swap
  32     [ dup lexer-column swap lexer-line-text rot call ] keep
  33     set-lexer-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     dup lexer-line swap lexer-text length <= ;
  49
  50 : still-parsing-line? ( lexer -- ? )
  51     dup lexer-column swap lexer-line-length < ;
  52
  53 : (parse-token) ( lexer -- str )
  54     [ lexer-column ] keep
  55     [ skip-word ] keep
  56     [ lexer-column ] keep
  57     lexer-line-text 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     unexpected-got not ;
  72
  73 : unexpected-eof ( word -- * ) f unexpected ;
  74
  75 : (parse-tokens) ( accum end -- accum )
  76     scan 2dup = [
  77         2drop
  78     ] [
  79         [ pick push (parse-tokens) ] [ unexpected-eof ] if*
  80     ] if ;
  81
  82 : parse-tokens ( end -- seq )
  83     100 <vector> swap (parse-tokens) >array ;
  84
  85 TUPLE: lexer-error line column line-text error ;
  86
  87 : <lexer-error> ( msg -- error )
  88     \ lexer-error new
  89         lexer get
  90         [ line>> >>line ]
  91         [ column>> >>column ]
  92         [ line-text>> >>line-text ]
  93         tri
  94         swap >>error ;
  95
  96 : lexer-dump ( error -- )
  97     [ line>> number>string ": " append ]
  98     [ line-text>> dup string? [ drop "" ] unless ]
  99     [ column>> 0 or ] tri
 100     pick length + CHAR: \s <string>
 101     [ write ] [ print ] [ write "^" print ] tri* ;
 102
 103 : with-lexer ( lexer quot -- newquot )
 104     [ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
 105
 106 SYMBOL: lexer-factory
 107
 108 [ <lexer> ] lexer-factory set-global