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 debugger io vectors arrays math.parser combinators inspector
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 : skip ( i seq ? -- n )
28 [ swap CHAR: \s eq? xor ] curry find-from drop
29 [ r> drop ] [ r> length ] if* ;
31 : change-lexer-column ( lexer quot -- )
33 [ dup lexer-column swap lexer-line-text rot call ] keep
34 set-lexer-column ; inline
36 GENERIC: skip-blank ( lexer -- )
38 M: lexer skip-blank ( lexer -- )
39 [ t skip ] change-lexer-column ;
41 GENERIC: skip-word ( lexer -- )
43 M: lexer skip-word ( lexer -- )
45 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
46 ] change-lexer-column ;
48 : still-parsing? ( lexer -- ? )
49 dup lexer-line swap lexer-text length <= ;
51 : still-parsing-line? ( lexer -- ? )
52 dup lexer-column swap lexer-line-length < ;
54 : (parse-token) ( lexer -- str )
58 lexer-line-text subseq ;
60 : parse-token ( lexer -- str/f )
63 dup still-parsing-line?
64 [ (parse-token) ] [ dup next-line parse-token ] if
67 : scan ( -- str/f ) lexer get parse-token ;
69 ERROR: unexpected want got ;
71 GENERIC: expected>string ( obj -- str )
73 M: f expected>string drop "end of input" ;
74 M: word expected>string name>> ;
75 M: string expected>string ;
79 dup unexpected-want expected>string write
81 unexpected-got expected>string print ;
83 PREDICATE: unexpected-eof < unexpected
86 : unexpected-eof ( word -- * ) f unexpected ;
88 : (parse-tokens) ( accum end -- accum )
92 [ pick push (parse-tokens) ] [ unexpected-eof ] if*
95 : parse-tokens ( end -- seq )
96 100 <vector> swap (parse-tokens) >array ;
98 TUPLE: lexer-error line column line-text error ;
100 : <lexer-error> ( msg -- error )
104 [ column>> >>column ]
105 [ line-text>> >>line-text ]
109 : lexer-dump ( error -- )
110 [ line>> number>string ": " append ]
111 [ line-text>> dup string? [ drop "" ] unless ]
112 [ column>> 0 or ] tri
113 pick length + CHAR: \s <string>
114 [ write ] [ print ] [ write "^" print ] tri* ;
116 M: lexer-error error.
117 [ lexer-dump ] [ error>> error. ] bi ;
119 M: lexer-error summary
122 M: lexer-error compute-restarts
123 error>> compute-restarts ;
125 M: lexer-error error-help
128 : with-lexer ( lexer quot -- newquot )
129 [ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
131 SYMBOL: lexer-factory
133 [ <lexer> ] lexer-factory set-global