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