1 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs kernel lexer make math math.parser
4 namespaces parser sequences splitting strings arrays
8 ERROR: bad-escape char ;
10 : escape ( escape -- ch )
22 } ?at [ bad-escape ] unless ;
24 SYMBOL: name>char-hook
27 [ "Unicode support not available" throw ]
30 : unicode-escape ( str -- ch str' )
32 CHAR: } over index cut-slice
33 [ >string name>char-hook get call( name -- char ) ] dip
36 6 cut-slice [ hex> ] dip
39 : next-escape ( str -- ch str' )
43 unclip-slice escape swap
46 : (unescape-string) ( str -- )
47 CHAR: \\ over index dup [
48 cut-slice [ % ] dip rest-slice
55 : unescape-string ( str -- str' )
56 [ (unescape-string) ] "" make ;
58 : (parse-string) ( str -- m )
59 dup [ "\"\\" member? ] find dup [
60 [ cut-slice [ % ] dip rest-slice ] dip
64 next-escape [ , ] dip (parse-string)
67 "Unterminated string" throw
70 : parse-string ( -- str )
72 [ swap tail-slice (parse-string) ] "" make swap
73 ] change-lexer-column ;
77 : lexer-subseq ( i -- before )
81 [ column>> ] [ line-text>> ] bi
87 : rest-of-line ( lexer -- seq )
88 [ line-text>> ] [ column>> ] bi tail-slice ;
90 : current-char ( lexer -- ch/f )
91 [ column>> ] [ line-text>> ] bi ?nth ;
93 : advance-char ( lexer -- )
94 [ 1 + ] change-column drop ;
96 ERROR: escaped-char-expected ;
98 : next-char ( lexer -- ch )
99 dup still-parsing-line? [
100 [ current-char ] [ advance-char ] bi
102 escaped-char-expected
105 : lexer-head? ( string -- ? )
106 [ lexer get rest-of-line ] dip head? ;
108 : advance-lexer ( n -- )
109 [ lexer get ] dip [ + ] curry change-column drop ; inline
111 : find-next-token ( ch -- i elt )
113 [ lexer get [ column>> ] [ line-text>> ] bi ] dip
114 [ member? ] curry find-from ;
116 : next-line% ( lexer -- )
118 [ next-line "\n" % ] bi ;
120 : take-double-quotes ( -- string )
121 lexer get dup current-char CHAR: " = [
122 [ ] [ column>> ] [ line-text>> ] tri
123 [ CHAR: " = not ] find-from drop [
124 swap column>> - CHAR: " <repetition>
130 ] if dup length advance-lexer ;
132 : end-string-parse ( delimiter -- )
134 take-double-quotes 3 tail %
136 lexer get advance-char
139 DEFER: (parse-multiline-string)
141 : parse-found-token ( i string token -- )
142 [ lexer-subseq % ] dip
144 lexer get [ next-char , ] [ next-char , ] bi (parse-multiline-string)
149 lexer get next-char , (parse-multiline-string)
153 ERROR: trailing-characters string ;
155 : (parse-multiline-string) ( string -- )
156 lexer get still-parsing? [
157 dup first find-next-token [
160 drop lexer get next-line%
161 (parse-multiline-string)
169 : parse-multiline-string ( -- string )
170 lexer get rest-of-line "\"\"" head? [
171 lexer get [ 2 + ] change-column drop
175 ] if [ (parse-multiline-string) ] "" make unescape-string ;