Branch data Line data Source code
1 : : enum {
2 : : TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
3 : : TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
4 : : TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN,
5 : : TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE
6 : : };
7 : :
8 : : #define readF(fl_ctx) value2c(ios_t*,fl_ctx->readstate->source)
9 : :
10 : : // defines which characters are ordinary symbol characters.
11 : : // exceptions are '.', which is an ordinary symbol character
12 : : // unless it's the only character in the symbol, and '#', which is
13 : : // an ordinary symbol character unless it's the first character.
14 : 5522580 : static inline int symchar(char c)
15 : : {
16 : : static const char *special = "()[]'\";`,\\| \f\n\r\t\v";
17 : 5522580 : return !strchr(special, c);
18 : : }
19 : :
20 : : // like strtoull, but accepts "0b" prefix for base 2 and "0o" prefix for base 8
21 : 753496 : static unsigned long long strtoull_0b0o(const char *nptr, char **endptr, int base)
22 : : {
23 [ + + ]: 753496 : if (*nptr == '0') {
24 [ + + + - : 27174 : if ((base == 2 && nptr[1] == 'b' && nptr[2] >= '0' && nptr[2] <= '1') ||
+ - - + +
+ ]
25 [ + - + - : 356 : (base == 8 && nptr[1] == 'o' && nptr[2] >= '0' && nptr[2] <= '7')) {
+ - ]
26 : 384 : nptr += 2;
27 : : }
28 : : }
29 : 753496 : return strtoull(nptr, endptr, base);
30 : : }
31 : :
32 : 768992 : int isnumtok_base(fl_context_t *fl_ctx, char *tok, value_t *pval, int base)
33 : : {
34 : : char *end;
35 : : int64_t i64;
36 : : uint64_t ui64;
37 : : double d;
38 [ - + ]: 768992 : if (*tok == '\0')
39 : 0 : return 0;
40 [ + + + + : 768992 : if (!((tok[0]=='0' && tok[1]=='x') || (base >= 15)) &&
+ + ]
41 [ + + ]: 760412 : strpbrk(tok, ".eEpP")) {
42 : 381734 : d = jl_strtod_c(tok, &end);
43 [ + + ]: 381734 : if (*end == '\0') {
44 [ + - ]: 9464 : if (pval) *pval = mk_double(fl_ctx, d);
45 : 9464 : return 1;
46 : : }
47 : : // floats can end in f or f0
48 [ + + - + ]: 372270 : if (end > tok && end[0] == 'f' &&
49 [ # # ]: 0 : (end[1] == '\0' ||
50 [ # # # # ]: 0 : (end[1] == '0' && end[2] == '\0'))) {
51 [ # # ]: 0 : if (pval) *pval = mk_float(fl_ctx, (float)d);
52 : 0 : return 1;
53 : : }
54 : : }
55 : : // hexadecimal float literals
56 [ + + + + : 387258 : else if (((tok[0]=='0' && tok[1]=='x') || (base == 16)) &&
+ + ]
57 [ + + ]: 8580 : strpbrk(tok, "pP")) {
58 : 68 : d = jl_strtod_c(tok, &end);
59 [ + - ]: 68 : if (*end == '\0') {
60 [ + - ]: 68 : if (pval) *pval = mk_double(fl_ctx, d);
61 : 68 : return 1;
62 : : }
63 : : // floats can end in f or f0
64 [ # # # # ]: 0 : if (end > tok && end[0] == 'f' &&
65 [ # # ]: 0 : (end[1] == '\0' ||
66 [ # # # # ]: 0 : (end[1] == '0' && end[2] == '\0'))) {
67 [ # # ]: 0 : if (pval) *pval = mk_float(fl_ctx, (float)d);
68 : 0 : return 1;
69 : : }
70 : : }
71 : :
72 [ + + ]: 759460 : if (tok[0] == '+') {
73 [ + - - + ]: 1200 : if (!strcmp(tok,"+NaN") || !strcasecmp(tok,"+nan.0")) {
74 [ # # ]: 0 : if (pval) *pval = mk_double(fl_ctx, D_PNAN);
75 : 0 : return 1;
76 : : }
77 [ + - + + ]: 1200 : if (!strcmp(tok,"+Inf") || !strcasecmp(tok,"+inf.0")) {
78 [ + - ]: 30 : if (pval) *pval = mk_double(fl_ctx, D_PINF);
79 : 30 : return 1;
80 : : }
81 : : }
82 [ + + ]: 758260 : else if (tok[0] == '-') {
83 [ + - - + ]: 5934 : if (!strcmp(tok,"-NaN") || !strcasecmp(tok,"-nan.0")) {
84 [ # # ]: 0 : if (pval) *pval = mk_double(fl_ctx, D_NNAN);
85 : 0 : return 1;
86 : : }
87 [ + - + + ]: 5934 : if (!strcmp(tok,"-Inf") || !strcasecmp(tok,"-inf.0")) {
88 [ + - ]: 30 : if (pval) *pval = mk_double(fl_ctx, D_NINF);
89 : 30 : return 1;
90 : : }
91 : 5904 : errno = 0;
92 : 5904 : i64 = strtoll(tok, &end, base);
93 [ - + ]: 5904 : if (errno)
94 : 0 : return 0;
95 : 5904 : int done = (*end == '\0'); // must access *end before alloc
96 [ + - ]: 5904 : if (pval) *pval = return_from_int64(fl_ctx, i64);
97 : 5904 : return done;
98 : : }
99 : 753496 : errno = 0;
100 : 753496 : ui64 = strtoull_0b0o(tok, &end, base);
101 [ + + ]: 753496 : if (errno)
102 : 72 : return 0;
103 : 753424 : int done = (*end == '\0'); // must access *end before alloc
104 [ + - ]: 753424 : if (pval) *pval = return_from_uint64(fl_ctx, ui64);
105 : 753424 : return done;
106 : : }
107 : :
108 : 0 : static int isnumtok(fl_context_t *fl_ctx, char *tok, value_t *pval)
109 : : {
110 : 0 : return isnumtok_base(fl_ctx, tok, pval, 0);
111 : : }
112 : :
113 : 648720 : static int read_numtok(fl_context_t *fl_ctx, char *tok, value_t *pval, int base)
114 : : {
115 : : int result;
116 : 648720 : errno = 0;
117 : 648720 : result = isnumtok_base(fl_ctx, tok, pval, base);
118 [ - + ]: 648720 : if (errno == ERANGE)
119 : 0 : lerrorf(fl_ctx, fl_ctx->ParseError, "read: overflow in numeric constant %s", tok);
120 : 648720 : return result;
121 : : }
122 : :
123 : 1528598 : static char nextchar(fl_context_t *fl_ctx)
124 : : {
125 : : int ch;
126 : : char c;
127 : 1528598 : ios_t *f = readF(fl_ctx);
128 : :
129 : : do {
130 [ + - ]: 3136480 : if (f->bpos < f->size) {
131 : 3136480 : ch = f->buf[f->bpos++];
132 : : }
133 : : else {
134 : 0 : ch = ios_getc(f);
135 [ # # ]: 0 : if (ch == IOS_EOF)
136 : 0 : return 0;
137 : : }
138 : 3136480 : c = (char)ch;
139 [ - + ]: 3136480 : if (c == ';') {
140 : : // single-line comment
141 : : do {
142 : 0 : ch = ios_getc(f);
143 [ # # ]: 0 : if (ch == IOS_EOF)
144 : 0 : return 0;
145 [ # # ]: 0 : } while ((char)ch != '\n');
146 : 0 : c = (char)ch;
147 : : }
148 [ + + + + ]: 3136480 : } while (c==' ' || isspace((unsigned char)c));
149 : 1528598 : return c;
150 : : }
151 : :
152 : 1440128 : static void take(fl_context_t *fl_ctx)
153 : : {
154 : 1440128 : fl_ctx->readtoktype = TOK_NONE;
155 : 1440128 : }
156 : :
157 : 4222280 : static void accumchar(fl_context_t *fl_ctx, char c, int *pi)
158 : : {
159 : 4222280 : fl_ctx->readbuf[(*pi)++] = c;
160 [ - + ]: 4222280 : if (*pi >= (int)(sizeof(fl_ctx->readbuf)-1))
161 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: token too long");
162 : 4222280 : }
163 : :
164 : : // return: 1 if escaped (forced to be symbol)
165 : 1007340 : static int read_token(fl_context_t *fl_ctx, char c, int digits)
166 : : {
167 : 1007340 : int i=0, ch, escaped=0, issym=0, nc=0;
168 : :
169 : : while (1) {
170 [ + + ]: 5241920 : if (nc != 0) {
171 [ + + ]: 4234600 : if (nc != 1)
172 : 3227240 : (void)ios_getc(readF(fl_ctx)); // consume ch
173 : 4234600 : ch = ios_peekc(readF(fl_ctx));
174 [ - + ]: 4234600 : if (ch == IOS_EOF)
175 : 0 : goto terminate;
176 : 4234600 : c = (char)ch;
177 : : }
178 [ + + ]: 5241920 : if (c == '|') {
179 : 12300 : issym = 1;
180 : 12300 : escaped = !escaped;
181 : : }
182 [ + + ]: 5229640 : else if (c == '\\') {
183 : 4800 : issym = 1;
184 : 4800 : (void)ios_getc(readF(fl_ctx)); // consume '\'
185 : 4800 : ch = ios_peekc(readF(fl_ctx));
186 [ - + ]: 4800 : if (ch == IOS_EOF)
187 : 0 : goto terminate;
188 : 4800 : accumchar(fl_ctx, (char)ch, &i);
189 : : }
190 [ + + + + : 5224840 : else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {
+ + + + ]
191 : : break;
192 : : }
193 : : else {
194 : 4217480 : accumchar(fl_ctx, c, &i);
195 : : }
196 : 4234600 : nc++;
197 : : }
198 [ + - ]: 1007340 : if (nc == 0)
199 : 0 : ios_skip(readF(fl_ctx), -1); // rewind stream for the caller, to prepare for throwing an error
200 : 1007340 : terminate:
201 : 1007340 : fl_ctx->readbuf[i++] = '\0';
202 : 1007340 : return issym;
203 : : }
204 : :
205 : : static value_t do_read_sexpr(fl_context_t *fl_ctx, value_t label);
206 : :
207 : 2595280 : static uint32_t peek(fl_context_t *fl_ctx)
208 : : {
209 : : char c, *end;
210 : : fixnum_t x;
211 : : int ch, base;
212 : :
213 [ + + ]: 2595280 : if (fl_ctx->readtoktype != TOK_NONE)
214 : 1155150 : return fl_ctx->readtoktype;
215 : 1440128 : c = nextchar(fl_ctx);
216 [ - + ]: 1440128 : if (ios_eof(readF(fl_ctx))) return TOK_NONE;
217 [ + + ]: 1440128 : if (c == '(') {
218 : 14100 : fl_ctx->readtoktype = TOK_OPEN;
219 : : }
220 [ + + ]: 1426028 : else if (c == ')') {
221 : 102570 : fl_ctx->readtoktype = TOK_CLOSE;
222 : : }
223 [ + + ]: 1323458 : else if (c == '[') {
224 : 50460 : fl_ctx->readtoktype = TOK_OPENB;
225 : : }
226 [ + + ]: 1272998 : else if (c == ']') {
227 : 50460 : fl_ctx->readtoktype = TOK_CLOSEB;
228 : : }
229 [ + + ]: 1222538 : else if (c == '\'') {
230 : 480 : fl_ctx->readtoktype = TOK_QUOTE;
231 : : }
232 [ - + ]: 1222058 : else if (c == '`') {
233 : 0 : fl_ctx->readtoktype = TOK_BQ;
234 : : }
235 [ + + ]: 1222058 : else if (c == '"') {
236 : 169418 : fl_ctx->readtoktype = TOK_DOUBLEQUOTE;
237 : : }
238 [ + + ]: 1052640 : else if (c == '#') {
239 : 396120 : ch = ios_getc(readF(fl_ctx)); c = (char)ch;
240 [ - + ]: 396120 : if (ch == IOS_EOF)
241 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: invalid read macro");
242 [ + + ]: 396120 : if (c == '.') {
243 : 3420 : fl_ctx->readtoktype = TOK_SHARPDOT;
244 : : }
245 [ - + ]: 392700 : else if (c == '\'') {
246 : 0 : fl_ctx->readtoktype = TOK_SHARPQUOTE;
247 : : }
248 [ + + ]: 392700 : else if (c == '\\') {
249 : : uint32_t cval;
250 [ - + ]: 43290 : if (ios_getutf8(readF(fl_ctx), &cval) == IOS_EOF)
251 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: end of input in character constant");
252 [ + - + - ]: 43290 : if (cval == (uint32_t)'u' || cval == (uint32_t)'U' ||
253 [ + + ]: 43290 : cval == (uint32_t)'x') {
254 : 30 : read_token(fl_ctx, 'u', 0);
255 [ - + ]: 30 : if (fl_ctx->readbuf[1] != '\0') { // not a solitary 'u','U','x'
256 [ # # ]: 0 : if (!read_numtok(fl_ctx, &fl_ctx->readbuf[1], &fl_ctx->readtokval, 16))
257 : 0 : lerror(fl_ctx, fl_ctx->ParseError,
258 : : "read: invalid hex character constant");
259 : 0 : cval = numval(fl_ctx->readtokval);
260 : : }
261 : : }
262 [ + + + + ]: 43260 : else if (cval >= 'a' && cval <= 'z') {
263 : 1380 : read_token(fl_ctx, (char)cval, 0);
264 : 1380 : fl_ctx->readtokval = symbol(fl_ctx, fl_ctx->readbuf);
265 [ + + ]: 1380 : if (fl_ctx->readbuf[1] == '\0') /* one character */;
266 [ - + ]: 1080 : else if (fl_ctx->readtokval == fl_ctx->nulsym) cval = 0x00;
267 [ - + ]: 1080 : else if (fl_ctx->readtokval == fl_ctx->alarmsym) cval = 0x07;
268 [ - + ]: 1080 : else if (fl_ctx->readtokval == fl_ctx->backspacesym) cval = 0x08;
269 [ + + ]: 1080 : else if (fl_ctx->readtokval == fl_ctx->tabsym) cval = 0x09;
270 [ + + ]: 1020 : else if (fl_ctx->readtokval == fl_ctx->linefeedsym) cval = 0x0A;
271 [ - + ]: 180 : else if (fl_ctx->readtokval == fl_ctx->newlinesym) cval = 0x0A;
272 [ - + ]: 180 : else if (fl_ctx->readtokval == fl_ctx->vtabsym) cval = 0x0B;
273 [ - + ]: 180 : else if (fl_ctx->readtokval == fl_ctx->pagesym) cval = 0x0C;
274 [ + + ]: 180 : else if (fl_ctx->readtokval == fl_ctx->returnsym) cval = 0x0D;
275 [ - + ]: 120 : else if (fl_ctx->readtokval == fl_ctx->escsym) cval = 0x1B;
276 [ + - ]: 120 : else if (fl_ctx->readtokval == fl_ctx->spacesym) cval = 0x20;
277 [ # # ]: 0 : else if (fl_ctx->readtokval == fl_ctx->deletesym) cval = 0x7F;
278 : : else
279 : 0 : lerrorf(fl_ctx, fl_ctx->ParseError, "read: unknown character #\\%s", fl_ctx->readbuf);
280 : : }
281 : 43290 : fl_ctx->readtoktype = TOK_NUM;
282 : 43290 : fl_ctx->readtokval = mk_wchar(fl_ctx, cval);
283 : : }
284 [ - + ]: 349410 : else if (c == '(') {
285 : 0 : fl_ctx->readtoktype = TOK_SHARPOPEN;
286 : : }
287 [ - + ]: 349410 : else if (c == '<') {
288 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: unreadable object");
289 : : }
290 [ + + ]: 349410 : else if (isdigit(c)) {
291 : 41910 : read_token(fl_ctx, c, 1);
292 : 41910 : c = (char)ios_getc(readF(fl_ctx));
293 [ + + ]: 41910 : if (c == '#')
294 : 22380 : fl_ctx->readtoktype = TOK_BACKREF;
295 [ + - ]: 19530 : else if (c == '=')
296 : 19530 : fl_ctx->readtoktype = TOK_LABEL;
297 : : else
298 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: invalid label");
299 : 41910 : errno = 0;
300 : 41910 : x = strtol(fl_ctx->readbuf, &end, 10);
301 [ + - - + ]: 41910 : if (*end != '\0' || errno)
302 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: invalid label");
303 : 41910 : fl_ctx->readtokval = fixnum(x);
304 : : }
305 [ - + ]: 307500 : else if (c == '!') {
306 : : // #! single line comment for shbang script support
307 : : do {
308 : 0 : ch = ios_getc(readF(fl_ctx));
309 [ # # # # ]: 0 : } while (ch != IOS_EOF && (char)ch != '\n');
310 : 0 : return peek(fl_ctx);
311 : : }
312 [ - + ]: 307500 : else if (c == '|') {
313 : : // multiline comment
314 : 0 : int commentlevel=1;
315 : : while (1) {
316 : 0 : ch = ios_getc(readF(fl_ctx));
317 : 0 : hashpipe_gotc:
318 [ # # ]: 0 : if (ch == IOS_EOF)
319 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: eof within comment");
320 [ # # ]: 0 : if ((char)ch == '|') {
321 : 0 : ch = ios_getc(readF(fl_ctx));
322 [ # # ]: 0 : if ((char)ch == '#') {
323 : 0 : commentlevel--;
324 [ # # ]: 0 : if (commentlevel == 0)
325 : 0 : break;
326 : : else
327 : 0 : continue;
328 : : }
329 : 0 : goto hashpipe_gotc;
330 : : }
331 [ # # ]: 0 : else if ((char)ch == '#') {
332 : 0 : ch = ios_getc(readF(fl_ctx));
333 [ # # ]: 0 : if ((char)ch == '|')
334 : 0 : commentlevel++;
335 : : else
336 : 0 : goto hashpipe_gotc;
337 : : }
338 : : }
339 : : // this was whitespace, so keep peeking
340 : 0 : return peek(fl_ctx);
341 : : }
342 [ - + ]: 307500 : else if (c == ';') {
343 : : // datum comment
344 : 0 : (void)do_read_sexpr(fl_ctx, UNBOUND); // skip
345 : 0 : return peek(fl_ctx);
346 : : }
347 [ - + ]: 307500 : else if (c == ':') {
348 : : // gensym
349 : 0 : ch = ios_getc(readF(fl_ctx));
350 [ # # ]: 0 : if ((char)ch == 'g')
351 : 0 : ch = ios_getc(readF(fl_ctx));
352 : 0 : read_token(fl_ctx, (char)ch, 0);
353 : 0 : errno = 0;
354 : 0 : x = strtol(fl_ctx->readbuf, &end, 10);
355 [ # # # # : 0 : if (*end != '\0' || fl_ctx->readbuf[0] == '\0' || errno)
# # ]
356 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: invalid gensym label");
357 : 0 : fl_ctx->readtoktype = TOK_GENSYM;
358 : 0 : fl_ctx->readtokval = fixnum(x);
359 : : }
360 [ + - ]: 307500 : else if (symchar(c)) {
361 : 307500 : read_token(fl_ctx, ch, 0);
362 : :
363 [ - + - + ]: 307500 : if (((c == 'b' && (base= 2)) ||
364 [ - + ]: 307500 : (c == 'o' && (base= 8)) ||
365 [ - + ]: 307500 : (c == 'd' && (base=10)) ||
366 [ # # ]: 0 : (c == 'x' && (base=16))) &&
367 : 0 : (isdigit_base(fl_ctx->readbuf[1],base) ||
368 [ # # ]: 0 : fl_ctx->readbuf[1]=='-')) {
369 [ # # ]: 0 : if (!read_numtok(fl_ctx, &fl_ctx->readbuf[1], &fl_ctx->readtokval, base))
370 : 0 : lerrorf(fl_ctx, fl_ctx->ParseError, "read: invalid base %d constant", base);
371 : 0 : return (fl_ctx->readtoktype=TOK_NUM);
372 : : }
373 : :
374 : 307500 : fl_ctx->readtoktype = TOK_SHARPSYM;
375 : 307500 : fl_ctx->readtokval = symbol(fl_ctx, fl_ctx->readbuf);
376 : : }
377 : : else {
378 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: unknown read macro");
379 : : }
380 : : }
381 [ - + ]: 656520 : else if (c == ',') {
382 : 0 : fl_ctx->readtoktype = TOK_COMMA;
383 : 0 : ch = ios_peekc(readF(fl_ctx));
384 [ # # ]: 0 : if (ch == IOS_EOF)
385 : 0 : return fl_ctx->readtoktype;
386 [ # # ]: 0 : if ((char)ch == '@')
387 : 0 : fl_ctx->readtoktype = TOK_COMMAAT;
388 [ # # ]: 0 : else if ((char)ch == '.')
389 : 0 : fl_ctx->readtoktype = TOK_COMMADOT;
390 : : else
391 : 0 : return fl_ctx->readtoktype;
392 : 0 : (void)ios_getc(readF(fl_ctx)); // consume ch
393 : : }
394 : : else {
395 [ + + ]: 656520 : if (!read_token(fl_ctx, c, 0)) {
396 [ + + + + ]: 650370 : if (fl_ctx->readbuf[0]=='.' && fl_ctx->readbuf[1]=='\0') {
397 : 1650 : return (fl_ctx->readtoktype=TOK_DOT);
398 : : }
399 : : else {
400 [ + + ]: 648720 : if (read_numtok(fl_ctx, fl_ctx->readbuf, &fl_ctx->readtokval, 0))
401 : 43650 : return (fl_ctx->readtoktype=TOK_NUM);
402 : : }
403 : : }
404 : 611220 : fl_ctx->readtoktype = TOK_SYM;
405 : 611220 : fl_ctx->readtokval = symbol(fl_ctx, fl_ctx->readbuf);
406 : : }
407 : 1394828 : return fl_ctx->readtoktype;
408 : : }
409 : :
410 : : // NOTE: this is NOT an efficient operation. it is only used by the
411 : : // reader, and requires at least 1 and up to 3 garbage collections!
412 : 67350 : static value_t vector_grow(fl_context_t *fl_ctx, value_t v, int rewrite_refs)
413 : : {
414 : 67350 : size_t i, s = vector_size(v);
415 [ + + ]: 67350 : size_t d = vector_grow_amt(s);
416 : 67350 : PUSH(fl_ctx, v);
417 : 67350 : value_t newv = alloc_vector(fl_ctx, s+d, 1);
418 : 67350 : v = fl_ctx->Stack[fl_ctx->SP-1];
419 [ + + ]: 289290 : for(i=0; i < s; i++)
420 : 221940 : vector_elt(newv, i) = vector_elt(v, i);
421 : : // use gc to rewrite references from the old vector to the new
422 : 67350 : fl_ctx->Stack[fl_ctx->SP-1] = newv;
423 [ + + - + ]: 67350 : if (s > 0 && rewrite_refs) {
424 : 0 : ((size_t*)ptr(v))[0] |= 0x1;
425 : 0 : vector_elt(v, 0) = newv;
426 : 0 : gc(fl_ctx, 0);
427 : : }
428 : 67350 : return POP(fl_ctx);
429 : : }
430 : :
431 : 50460 : static value_t read_vector(fl_context_t *fl_ctx, value_t label, uint32_t closer)
432 : : {
433 : 50460 : value_t v=fl_ctx->the_empty_vector, elt;
434 : 50460 : uint32_t i=0;
435 : 50460 : PUSH(fl_ctx, v);
436 [ + + ]: 50460 : if (label != UNBOUND)
437 : 60 : ptrhash_put(&fl_ctx->readstate->backrefs, (void*)label, (void*)v);
438 [ + + ]: 302910 : while (peek(fl_ctx) != closer) {
439 [ - + ]: 252450 : if (ios_eof(readF(fl_ctx)))
440 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected end of input");
441 : 252450 : v = fl_ctx->Stack[fl_ctx->SP-1]; // reload after possible alloc in peek()
442 [ + + ]: 252450 : if (i >= vector_size(v)) {
443 : 67350 : v = fl_ctx->Stack[fl_ctx->SP-1] = vector_grow(fl_ctx, v, label != UNBOUND);
444 [ + + ]: 67350 : if (label != UNBOUND)
445 : 60 : ptrhash_put(&fl_ctx->readstate->backrefs, (void*)label, (void*)v);
446 : : }
447 : 252450 : elt = do_read_sexpr(fl_ctx, UNBOUND);
448 : 252450 : v = fl_ctx->Stack[fl_ctx->SP-1];
449 : 252450 : vector_elt(v,i) = elt;
450 : 252450 : i++;
451 : : }
452 : 50460 : take(fl_ctx);
453 [ + + ]: 50460 : if (i > 0)
454 : 46080 : vector_setsize(v, i);
455 : 50460 : return POP(fl_ctx);
456 : : }
457 : :
458 : 169418 : static value_t read_string(fl_context_t *fl_ctx)
459 : : {
460 : : char *buf, *temp;
461 : : char eseq[10];
462 : 169418 : size_t i=0, j, sz = 64, ndig;
463 : : int c;
464 : : value_t s;
465 : 169418 : uint32_t wc=0;
466 : :
467 : 169418 : buf = (char*)malloc(sz);
468 [ - + ]: 169418 : if (buf == NULL) {
469 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: out of memory reading string");
470 : : }
471 : : while (1) {
472 [ + + ]: 10759380 : if (i >= sz-4) { // -4: leaves room for longest utf8 sequence
473 : 57948 : sz *= 2;
474 : 57948 : temp = (char*)realloc(buf, sz);
475 [ - + ]: 57948 : if (temp == NULL) {
476 : 0 : free(buf);
477 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: out of memory reading string");
478 : : }
479 : 57948 : buf = temp;
480 : : }
481 : 10759380 : c = ios_getc(readF(fl_ctx));
482 [ - + ]: 10759380 : if (c == IOS_EOF) {
483 : 0 : free(buf);
484 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected end of input in string");
485 : : }
486 [ + + ]: 10759380 : if (c == '"')
487 : 169418 : break;
488 [ + + ]: 10589960 : else if (c == '\\') {
489 : 130836 : c = ios_getc(readF(fl_ctx));
490 [ - + ]: 130836 : if (c == IOS_EOF) {
491 : 0 : free(buf);
492 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: end of input in escape sequence");
493 : : }
494 : 130836 : j = 0;
495 [ + + ]: 130836 : if (octal_digit(c)) {
496 : : while (1) {
497 : 564 : eseq[j++] = c;
498 : 564 : c = ios_peekc(readF(fl_ctx));
499 [ + - + + : 564 : if (c == IOS_EOF || !octal_digit(c) || j >= 3)
+ - ]
500 : : break;
501 : 248 : (void)ios_getc(readF(fl_ctx)); // consume c
502 : : }
503 : 316 : eseq[j] = '\0';
504 : 316 : wc = strtol(eseq, NULL, 8);
505 : : // \DDD and \xXX read bytes, not characters
506 : 316 : buf[i++] = ((char)wc);
507 : : }
508 [ + + + + ]: 130520 : else if ((c=='x' && (ndig=2)) ||
509 [ + + ]: 50992 : (c=='u' && (ndig=4)) ||
510 : 36 : (c=='U' && (ndig=8))) {
511 : : while (1) {
512 : 240978 : c = ios_peekc(readF(fl_ctx));
513 [ + - + + : 240978 : if (c == IOS_EOF || !hex_digit(c) || j >= ndig)
+ + ]
514 : : break;
515 : 160976 : eseq[j++] = c;
516 : 160976 : (void)ios_getc(readF(fl_ctx)); // consume c
517 : : }
518 : 80002 : eseq[j] = '\0';
519 [ + - ]: 80002 : if (j) wc = strtol(eseq, NULL, 16);
520 [ + - - + ]: 80002 : if (!j || wc > 0x10ffff) {
521 : 0 : free(buf);
522 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: invalid escape sequence");
523 : : }
524 [ + + ]: 80002 : if (ndig == 2)
525 : 79528 : buf[i++] = ((char)wc);
526 : : else
527 : 474 : i += u8_wc_toutf8(&buf[i], wc);
528 : : }
529 : : else {
530 : 50518 : char esc = read_escape_control_char((char)c);
531 [ + + - + ]: 50518 : if (esc == (char)c && !strchr("\\'\"$`", esc)) {
532 : 0 : free(buf);
533 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: invalid escape sequence");
534 : : }
535 : 50518 : buf[i++] = esc;
536 : : }
537 : : }
538 : : else {
539 : 10459120 : buf[i++] = c;
540 : : }
541 : : }
542 : 169418 : s = cvalue_string(fl_ctx, i);
543 : 169418 : memcpy(cvalue_data(s), buf, i);
544 : 169418 : free(buf);
545 : 169418 : return s;
546 : : }
547 : :
548 : : // build a list of conses. this is complicated by the fact that all conses
549 : : // can move whenever a new cons is allocated. we have to refer to every cons
550 : : // through a handle to a relocatable pointer (i.e. a pointer on the stack).
551 : 102570 : static void read_list(fl_context_t *fl_ctx, value_t *pval, value_t label)
552 : : {
553 : : value_t c, *pc;
554 : : uint32_t t;
555 : :
556 : 102570 : PUSH(fl_ctx, fl_ctx->NIL);
557 : 102570 : pc = &fl_ctx->Stack[fl_ctx->SP-1]; // to keep track of current cons cell
558 : 102570 : t = peek(fl_ctx);
559 [ + + ]: 1005270 : while (t != TOK_CLOSE) {
560 [ - + ]: 902700 : if (ios_eof(readF(fl_ctx)))
561 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected end of input");
562 : 902700 : c = mk_cons(fl_ctx); car_(c) = cdr_(c) = fl_ctx->NIL;
563 [ + + ]: 902700 : if (iscons(*pc)) {
564 : 800400 : cdr_(*pc) = c;
565 : : }
566 : : else {
567 : 102300 : *pval = c;
568 [ + + ]: 102300 : if (label != UNBOUND)
569 : 360 : ptrhash_put(&fl_ctx->readstate->backrefs, (void*)label, (void*)c);
570 : : }
571 : 902700 : *pc = c;
572 : 902700 : c = do_read_sexpr(fl_ctx, UNBOUND); // must be on separate lines due to
573 : 902700 : car_(*pc) = c; // undefined evaluation order
574 : :
575 : 902700 : t = peek(fl_ctx);
576 [ + + ]: 902700 : if (t == TOK_DOT) {
577 : 1650 : take(fl_ctx);
578 : 1650 : c = do_read_sexpr(fl_ctx, UNBOUND);
579 : 1650 : cdr_(*pc) = c;
580 : 1650 : t = peek(fl_ctx);
581 [ - + ]: 1650 : if (ios_eof(readF(fl_ctx)))
582 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected end of input");
583 [ - + ]: 1650 : if (t != TOK_CLOSE)
584 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: expected ')'");
585 : : }
586 : : }
587 : 102570 : take(fl_ctx);
588 : 102570 : (void)POP(fl_ctx);
589 : 102570 : }
590 : :
591 : : // label is the backreference we'd like to fix up with this read
592 : 1285448 : static value_t do_read_sexpr(fl_context_t *fl_ctx, value_t label)
593 : : {
594 : : value_t v, sym, oldtokval, *head;
595 : : value_t *pv;
596 : : uint32_t t;
597 : : char c;
598 : :
599 : 1285448 : t = peek(fl_ctx);
600 : 1285448 : take(fl_ctx);
601 [ - - - + : 1285448 : switch (t) {
- - - - +
- + + + -
+ + + - +
- ]
602 : 0 : case TOK_CLOSE:
603 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected ')'");
604 : 0 : case TOK_CLOSEB:
605 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected ']'");
606 : 0 : case TOK_DOT:
607 : 0 : lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected '.'");
608 : 698160 : case TOK_SYM:
609 : : case TOK_NUM:
610 : 698160 : return fl_ctx->readtokval;
611 : 0 : case TOK_COMMA:
612 : 0 : head = &fl_ctx->COMMA; goto listwith;
613 : 0 : case TOK_COMMAAT:
614 : 0 : head = &fl_ctx->COMMAAT; goto listwith;
615 : 0 : case TOK_COMMADOT:
616 : 0 : head = &fl_ctx->COMMADOT; goto listwith;
617 : 0 : case TOK_BQ:
618 : 0 : head = &fl_ctx->BACKQUOTE; goto listwith;
619 : 480 : case TOK_QUOTE:
620 : 480 : head = &fl_ctx->QUOTE;
621 : 480 : listwith:
622 : : #ifdef MEMDEBUG2
623 : : v = fl_list2(fl_ctx, *head, fl_ctx->NIL);
624 : : #else
625 : 480 : v = cons_reserve(fl_ctx, 2);
626 : 480 : car_(v) = *head;
627 : 480 : cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
628 : 480 : car_(cdr_(v)) = cdr_(cdr_(v)) = fl_ctx->NIL;
629 : : #endif
630 : 480 : PUSH(fl_ctx, v);
631 [ - + ]: 480 : if (label != UNBOUND)
632 : 0 : ptrhash_put(&fl_ctx->readstate->backrefs, (void*)label, (void*)v);
633 : 480 : v = do_read_sexpr(fl_ctx, UNBOUND);
634 : 480 : car_(cdr_(fl_ctx->Stack[fl_ctx->SP-1])) = v;
635 : 480 : return POP(fl_ctx);
636 : 0 : case TOK_SHARPQUOTE:
637 : : // femtoLisp doesn't need symbol-function, so #' does nothing
638 : 0 : return do_read_sexpr(fl_ctx, label);
639 : 14100 : case TOK_OPEN:
640 : 14100 : PUSH(fl_ctx, fl_ctx->NIL);
641 : 14100 : read_list(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-1], label);
642 : 14100 : return POP(fl_ctx);
643 : 307500 : case TOK_SHARPSYM:
644 : 307500 : sym = fl_ctx->readtokval;
645 [ + + - + ]: 307500 : if (sym == fl_ctx->tsym || sym == fl_ctx->Tsym)
646 : 218730 : return fl_ctx->T;
647 [ + + - + ]: 88770 : else if (sym == fl_ctx->fsym || sym == fl_ctx->Fsym)
648 : 300 : return fl_ctx->F;
649 : : // constructor notation
650 : 88470 : c = nextchar(fl_ctx);
651 [ - + ]: 88470 : if (c != '(') {
652 : 0 : take(fl_ctx);
653 : 0 : lerrorf(fl_ctx, fl_ctx->ParseError, "read: expected argument list for %s",
654 : : symbol_name(fl_ctx, fl_ctx->readtokval));
655 : : }
656 : 88470 : PUSH(fl_ctx, fl_ctx->NIL);
657 : 88470 : read_list(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-1], UNBOUND);
658 [ - + ]: 88470 : if (sym == fl_ctx->vu8sym) {
659 : 0 : sym = fl_ctx->arraysym;
660 : 0 : fl_ctx->Stack[fl_ctx->SP-1] = fl_cons(fl_ctx, fl_ctx->uint8sym, fl_ctx->Stack[fl_ctx->SP-1]);
661 : : }
662 [ + + ]: 88470 : else if (sym == fl_ctx->fnsym) {
663 : 87510 : sym = fl_ctx->FUNCTION;
664 : : }
665 : 88470 : v = symbol_value(sym);
666 [ - + ]: 88470 : if (v == UNBOUND)
667 : 0 : fl_raise(fl_ctx, fl_list2(fl_ctx, fl_ctx->UnboundError, sym));
668 : 88470 : return fl_apply(fl_ctx, v, POP(fl_ctx));
669 : 50460 : case TOK_OPENB:
670 : 50460 : return read_vector(fl_ctx, label, TOK_CLOSEB);
671 : 0 : case TOK_SHARPOPEN:
672 : 0 : return read_vector(fl_ctx, label, TOK_CLOSE);
673 : 3420 : case TOK_SHARPDOT:
674 : : // eval-when-read
675 : : // evaluated expressions can refer to existing backreferences, but they
676 : : // cannot see pending labels. in other words:
677 : : // (... #2=#.#0# ... ) OK
678 : : // (... #2=#.(#2#) ... ) DO NOT WANT
679 : 3420 : sym = do_read_sexpr(fl_ctx, UNBOUND);
680 [ + - ]: 3420 : if (issymbol(sym)) {
681 : 3420 : v = symbol_value(sym);
682 [ - + ]: 3420 : if (v == UNBOUND)
683 : 0 : fl_raise(fl_ctx, fl_list2(fl_ctx, fl_ctx->UnboundError, sym));
684 : 3420 : return v;
685 : : }
686 : 0 : return fl_toplevel_eval(fl_ctx, sym);
687 : 19530 : case TOK_LABEL:
688 : : // create backreference label
689 [ - + ]: 19530 : if (ptrhash_has(&fl_ctx->readstate->backrefs, (void*)fl_ctx->readtokval))
690 : 0 : lerrorf(fl_ctx, fl_ctx->ParseError, "read: label %ld redefined", numval(fl_ctx->readtokval));
691 : 19530 : oldtokval = fl_ctx->readtokval;
692 : 19530 : v = do_read_sexpr(fl_ctx, fl_ctx->readtokval);
693 : 19530 : ptrhash_put(&fl_ctx->readstate->backrefs, (void*)oldtokval, (void*)v);
694 : 19530 : return v;
695 : 22380 : case TOK_BACKREF:
696 : : // look up backreference
697 : 22380 : v = (value_t)ptrhash_get(&fl_ctx->readstate->backrefs, (void*)fl_ctx->readtokval);
698 [ - + ]: 22380 : if (v == (value_t)HT_NOTFOUND)
699 : 0 : lerrorf(fl_ctx, fl_ctx->ParseError, "read: undefined label %ld", numval(fl_ctx->readtokval));
700 : 22380 : return v;
701 : 0 : case TOK_GENSYM:
702 : 0 : pv = (value_t*)ptrhash_bp(&fl_ctx->readstate->gensyms, (void*)fl_ctx->readtokval);
703 [ # # ]: 0 : if (*pv == (value_t)HT_NOTFOUND)
704 : 0 : *pv = fl_gensym(fl_ctx, NULL, 0);
705 : 0 : return *pv;
706 : 169418 : case TOK_DOUBLEQUOTE:
707 : 169418 : return read_string(fl_ctx);
708 : : }
709 : 0 : return FL_UNSPECIFIED(fl_ctx);
710 : : }
711 : :
712 : 105218 : value_t fl_read_sexpr(fl_context_t *fl_ctx, value_t f)
713 : : {
714 : : value_t v;
715 : : fl_readstate_t state;
716 : 105218 : state.prev = fl_ctx->readstate;
717 : 105218 : htable_new(&state.backrefs, 8);
718 : 105218 : htable_new(&state.gensyms, 8);
719 : 105218 : state.source = f;
720 : 105218 : fl_ctx->readstate = &state;
721 [ - + ]: 105218 : assert(fl_ctx->readtoktype == TOK_NONE);
722 : 105218 : fl_gc_handle(fl_ctx, &fl_ctx->readtokval);
723 : :
724 : 105218 : v = do_read_sexpr(fl_ctx, UNBOUND);
725 : :
726 : 105218 : fl_free_gc_handles(fl_ctx, 1);
727 : 105218 : fl_ctx->readstate = state.prev;
728 : 105218 : free_readstate(&state);
729 : 105218 : return v;
730 : : }
731 : :
732 : 30 : static void fl_read_init(fl_context_t *fl_ctx)
733 : : {
734 : 30 : fl_ctx->readtoktype = TOK_NONE;
735 : 30 : fl_ctx->readtokval = 0;
736 : 30 : memset(fl_ctx->readbuf, 0, sizeof(fl_ctx->readbuf));
737 : 30 : }
|
