1 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators kernel kernel.private lexer
4 math math.order math.parser namespaces sbufs sequences splitting
8 ERROR: bad-escape char ;
10 : escape ( escape -- ch )
25 } ?at [ 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 : oct-escape ( str -- ch/f str' )
38 3 short head-slice [ CHAR: 0 CHAR: 7 between? not ] find drop
39 ] keep '[ _ length ] unless* [ f ] when-zero
40 [ cut-slice [ oct> ] dip ] [ f swap ] if* ;
42 : unicode-escape ( str -- ch str' )
44 CHAR: } over index cut-slice [
48 >string name>char-hook get call( name -- char )
52 6 cut-slice [ hex> ] dip
55 : next-escape ( str -- ch str' )
58 { CHAR: u [ unicode-escape ] }
59 { CHAR: x [ hex-escape ] }
60 { CHAR: \n [ f swap ] }
67 : (unescape-string) ( accum str i/f -- accum )
68 { sbuf object object } declare
70 cut-slice [ append! ] dip
71 rest-slice next-escape [ [ suffix! ] when* ] dip
72 CHAR: \\ over index (unescape-string)
79 : unescape-string ( str -- str' )
81 [ [ length <sbuf> ] keep ] dip (unescape-string)
86 : lexer-subseq ( i lexer -- before )
87 { fixnum lexer } declare
88 [ [ column>> ] [ line-text>> ] bi swapd subseq ]
91 : rest-of-line ( lexer -- seq )
93 [ line-text>> ] [ column>> ] bi tail-slice ;
95 : current-char ( lexer -- ch/f )
97 [ column>> ] [ line-text>> ] bi ?nth ;
99 : advance-char ( lexer -- )
101 [ 1 + ] change-column drop ;
103 : next-char ( lexer -- ch/f )
105 dup still-parsing-line? [
106 [ current-char ] [ advance-char ] bi
111 : next-line% ( accum lexer -- )
112 { sbuf lexer } declare
113 [ rest-of-line swap push-all ] [ next-line ] bi ;
115 : find-next-token ( lexer -- i elt )
117 [ column>> ] [ line-text>> ] bi
118 [ "\"\\" member-eq? ] find-from ;
120 : check-space ( lexer -- )
121 dup current-char forbid-tab {
122 { CHAR: \s [ advance-char ] }
124 [ "[space]" swap 1string "'" 1surround unexpected ]
127 DEFER: (parse-string)
129 : parse-found-token ( accum lexer i elt -- )
130 { sbuf lexer fixnum fixnum } declare
131 [ over lexer-subseq pick push-all ] dip
133 dup dup [ next-char ] bi@
134 [ [ pick push ] bi@ ]
135 [ drop 2dup next-line% ] if*
137 ] [ dup advance-char check-space drop ] if ;
139 : (parse-string) ( accum lexer -- )
140 { sbuf lexer } declare
142 dup find-next-token [
150 "'\"'" "[eof]" unexpected
155 : parse-string ( -- str )
157 lexer get (parse-string)
158 ] keep unescape-string ;