1 ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays classes combinators continuations io
4 kernel math math.parser namespaces sequences source-files.errors
12 { line-length fixnum }
14 { parsing-words vector } ;
16 TUPLE: lexer-parsing-word word line line-text column ;
18 : next-line ( lexer -- )
20 dup [ line>> ] [ text>> ] bi ?nth "" or
21 [ >>line-text ] [ length >>line-length ] bi
26 : push-parsing-word ( word -- )
27 lexer get lexer check-instance [
28 [ line>> ] [ line-text>> ] [ column>> ] tri
29 lexer-parsing-word boa
30 ] [ parsing-words>> push ] bi ;
32 : pop-parsing-word ( -- )
33 lexer get lexer check-instance parsing-words>> pop* ;
35 : new-lexer ( text class -- lexer )
39 V{ } clone >>parsing-words
40 dup next-line ; inline
42 : <lexer> ( text -- lexer )
45 ERROR: unexpected want got ;
47 : change-lexer-column ( ..a lexer quot: ( ..a col line -- ..b newcol ) -- ..b )
48 [ lexer check-instance [ column>> ] [ line-text>> ] bi ] prepose
49 keep column<< ; inline
51 : forbid-tab ( c -- c )
52 [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; inline
56 : shebang? ( lexer -- lexer ? )
59 dup line-text>> "#!" head?
63 : (skip-blank) ( col line -- newcol )
64 [ [ forbid-tab CHAR: \s eq? not ] find-from drop ]
67 : (skip-word) ( col line -- newcol )
68 [ [ forbid-tab " \"" member-eq? ] find-from CHAR: \" eq? [ 1 + ] when ]
73 GENERIC: skip-blank ( lexer -- )
77 [ nip length ] change-lexer-column
79 [ (skip-blank) ] change-lexer-column
82 GENERIC: skip-word ( lexer -- )
85 [ (skip-word) ] change-lexer-column ;
87 : still-parsing? ( lexer -- ? )
88 lexer check-instance [ line>> ] [ text>> length ] bi <= ;
90 : still-parsing-line? ( lexer -- ? )
91 lexer check-instance [ column>> ] [ line-length>> ] bi < ;
93 : (parse-raw) ( lexer -- str )
94 lexer check-instance {
101 : parse-raw ( lexer -- str/f )
104 dup still-parsing-line?
105 [ (parse-raw) ] [ dup next-line parse-raw ] if
110 : skip-comments ( lexer str -- str' )
112 drop [ next-line ] keep parse-token
117 : parse-token ( lexer -- str/f )
118 dup parse-raw [ skip-comments ] [ drop f ] if* ;
120 : ?scan-token ( -- str/f ) lexer get parse-token ;
122 PREDICATE: unexpected-eof < unexpected got>> not ;
124 : throw-unexpected-eof ( word -- * ) f unexpected ;
126 : scan-token ( -- str )
127 ?scan-token [ "token" throw-unexpected-eof ] unless* ;
129 : expect ( token -- )
130 scan-token 2dup = [ 2drop ] [ unexpected ] if ;
132 : each-token ( ... end quot: ( ... token -- ... ) -- ... )
133 [ scan-token ] 2dip 2over =
134 [ 3drop ] [ [ nip call ] [ each-token ] 2bi ] if ; inline recursive
136 : map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
137 collector [ each-token ] dip { } like ; inline
139 : parse-tokens ( end -- seq )
142 TUPLE: lexer-error line column line-text parsing-words error ;
144 M: lexer-error error-file error>> error-file ;
146 M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
148 : <lexer-error> ( msg -- error )
154 [ parsing-words>> clone ]
156 ] dip lexer-error boa ;
160 : simple-lexer-dump ( error -- )
161 [ line>> number>string ": " append ]
164 pick length + CHAR: \s <string>
165 [ write ] [ print ] [ write "^" print ] tri* ;
167 : parsing-word-lexer-dump ( error parsing-word -- error )
168 2dup [ line>> ] same? [ drop ] [
171 over line>> number>string length
174 ] [ line-text>> print ] bi
179 : lexer-dump ( error -- )
180 dup parsing-words>> ?last [
181 parsing-word-lexer-dump
182 ] when* simple-lexer-dump ;
184 : with-lexer ( lexer quot -- newquot )
185 [ [ <lexer-error> rethrow ] recover ] curry
186 [ lexer ] dip with-variable ; inline