1 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators kernel kernel.private
4 lexer math math.parser namespaces sbufs sequences splitting
8 ERROR: bad-escape char ;
10 : escape ( escape -- ch )
25 } ?at [ throw-bad-escape ] unless ;
27 SYMBOL: name>char-hook
30 [ "Unicode support not available" throw ]
33 : hex-escape ( str -- ch str' )
34 2 cut-slice [ hex> ] dip ;
36 : unicode-escape ( str -- ch str' )
38 CHAR: } over index cut-slice
39 [ >string name>char-hook get call( name -- char ) ] dip
42 6 cut-slice [ hex> ] dip
45 : next-escape ( str -- ch str' )
47 { CHAR: u [ unicode-escape ] }
48 { CHAR: x [ hex-escape ] }
54 : (unescape-string) ( accum str i/f -- accum )
55 { sbuf object object } declare
57 cut-slice [ append! ] dip
58 rest-slice next-escape [ suffix! ] dip
59 CHAR: \\ over index (unescape-string)
66 : unescape-string ( str -- str' )
68 [ [ length <sbuf> ] keep ] dip (unescape-string)
73 : (parse-string) ( accum str -- accum m )
74 { sbuf slice } declare
75 dup [ "\"\\" member? ] find [
76 [ cut-slice [ append! ] dip rest-slice ] dip
80 next-escape [ suffix! ] dip (parse-string)
83 "Unterminated string" throw
88 : parse-string ( -- str )
89 SBUF" " clone lexer get [
90 swap tail-slice (parse-string) [ "" like ] dip
91 ] change-lexer-column ;
95 : lexer-subseq ( i lexer -- before )
96 { fixnum lexer } declare
97 [ [ column>> ] [ line-text>> ] bi swapd subseq ]
100 : rest-of-line ( lexer -- seq )
102 [ line-text>> ] [ column>> ] bi tail-slice ;
104 : current-char ( lexer -- ch/f )
106 [ column>> ] [ line-text>> ] bi ?nth ;
108 : advance-char ( lexer -- )
110 [ 1 + ] change-column drop ;
112 ERROR: escaped-char-expected ;
114 : next-char ( lexer -- ch )
116 dup still-parsing-line? [
117 [ current-char ] [ advance-char ] bi
119 throw-escaped-char-expected
122 : lexer-head? ( lexer string -- ? )
123 { lexer string } declare
124 [ rest-of-line ] dip head? ;
126 : advance-lexer ( lexer n -- )
127 { lexer fixnum } declare
128 [ + ] curry change-column drop ;
130 : find-next-token ( lexer ch -- i elt )
131 { lexer fixnum } declare
132 [ [ column>> ] [ line-text>> ] bi ] dip
133 CHAR: \ 2array [ member? ] curry find-from ;
135 : next-line% ( accum lexer -- )
136 { sbuf lexer } declare
137 [ rest-of-line swap push-all ]
138 [ next-line CHAR: \n swap push ] 2bi ;
140 : take-double-quotes ( lexer -- string )
142 dup current-char CHAR: " = [
143 dup [ column>> ] [ line-text>> ] bi
144 [ CHAR: " = not ] find-from drop [
145 over column>> - CHAR: " <repetition>
149 [ length advance-lexer ] keep
152 : end-string-parse ( accum lexer delimiter -- )
153 { sbuf lexer string } declare
155 take-double-quotes 3 tail-slice swap push-all
160 DEFER: (parse-multiline-string-until)
162 : parse-found-token ( accum lexer string i token -- )
163 { sbuf lexer string fixnum fixnum } declare
164 [ [ 2over ] dip swap lexer-subseq swap push-all ] dip
166 2over next-char swap push
167 2over next-char swap push
168 (parse-multiline-string-until)
173 2over next-char swap push
174 (parse-multiline-string-until)
178 : (parse-multiline-string-until) ( accum lexer string -- )
179 { sbuf lexer fixnum } declare
180 over still-parsing? [
181 2dup first find-next-token [
184 drop 2over next-line%
185 (parse-multiline-string-until)
193 : parse-multiline-string-until ( arg -- string )
194 [ SBUF" " clone ] dip [
195 [ lexer get ] dip (parse-multiline-string-until)
196 ] curry keep unescape-string ;