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
8 TUPLE: lexer text line line-text line-length column ;
10 : next-line ( lexer -- )
11 dup [ line>> ] [ text>> ] bi ?nth >>line-text
12 dup line-text>> length >>line-length
17 : new-lexer ( text class -- lexer )
21 dup next-line ; inline
23 : <lexer> ( text -- lexer )
26 ERROR: unexpected want got ;
28 : forbid-tab ( c -- c )
29 [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; inline
31 : skip ( i seq ? -- n )
33 [ [ swap forbid-tab CHAR: \s eq? xor ] curry find-from drop ] dip or ;
35 : change-lexer-column ( lexer quot -- )
36 [ [ column>> ] [ line-text>> ] bi ] prepose keep
39 GENERIC: skip-blank ( lexer -- )
41 M: lexer skip-blank ( lexer -- )
42 [ t skip ] change-lexer-column ;
44 GENERIC: skip-word ( lexer -- )
46 M: lexer skip-word ( lexer -- )
48 2dup nth CHAR: " eq? [ drop 1 + ] [ f skip ] if
49 ] change-lexer-column ;
51 : still-parsing? ( lexer -- ? )
52 [ line>> ] [ text>> length ] bi <= ;
54 : still-parsing-line? ( lexer -- ? )
55 [ column>> ] [ line-length>> ] bi < ;
57 : (parse-token) ( lexer -- str )
65 : parse-token ( lexer -- str/f )
68 dup still-parsing-line?
69 [ (parse-token) ] [ dup next-line parse-token ] if
72 : scan ( -- str/f ) lexer get parse-token ;
74 PREDICATE: unexpected-eof < unexpected
77 : unexpected-eof ( word -- * ) f unexpected ;
81 [ 2dup = [ 2drop ] [ unexpected ] if ]
85 : (each-token) ( end quot -- pred quot )
86 [ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline
88 : each-token ( end quot -- )
89 (each-token) while drop ; inline
91 : map-tokens ( end quot -- seq )
92 (each-token) produce nip ; inline
94 : parse-tokens ( end -- seq )
97 TUPLE: lexer-error line column line-text error ;
99 M: lexer-error error-file error>> error-file ;
100 M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
102 : <lexer-error> ( msg -- error )
106 [ column>> >>column ]
107 [ line-text>> >>line-text ]
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* ;
118 : with-lexer ( lexer quot -- newquot )
119 [ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
121 SYMBOL: lexer-factory
123 [ <lexer> ] lexer-factory set-global