#include "sl.h"#include "cvalues.h"#include "read.h"#include "nan.h" enum {	TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,	TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,	TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN,	TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE,	TOK_OPENC, TOK_CLOSEC, TOK_VERBATIM,}; #define PAtLoc "at %"PRIu32":%"PRIu32 typedef struct Rctx Rctx; struct Rctx {	sl_v tokval;	sl_loc loc;	u32int toktype;	bool ws;	char buf[1024];}; static sl_v do_read_sexpr(Rctx *ctx, sl_v label); #define RS value2c(sl_ios*, sl.readstate->source) boolsl_read_numtok(const char *tok, sl_v *pval, int base){	char *end;	s64int i64;	double d; 	if(*tok == '\0')		return false;	if(!((tok[0] == '0' && tok[1] == 'x') || (base >= 15)) && strpbrk(tok, ".eEpP")){		d = strtod(tok, &end);		if(*end == '\0'){			if(pval)				*pval = mk_double(d);			return true;		}		// floats can end in f or f0		if(end > tok && end[0] == 'f' &&			(end[1] == '\0' ||			 (end[1] == '0' && end[2] == '\0'))){			if(pval)				*pval = mk_float((float)d);			return true;		}	} 	if(tok[0] == '+'){		if(!strcmp(tok, "+NaN") || !strcasecmp(tok, "+nan.0")){			if(pval)				*pval = mk_double(D_PNAN);			return true;		}		if(!strcmp(tok, "+Inf") || !strcasecmp(tok, "+inf.0")){			if(pval)				*pval = mk_double(D_PINF);			return true;		}	}else if(tok[0] == '-'){		if(!strcmp(tok, "-NaN") || !strcasecmp(tok, "-nan.0")){			if(pval)				*pval = mk_double(D_NNAN);			return true;		}		if(!strcmp(tok, "-Inf") || !strcasecmp(tok, "-inf.0")){			if(pval)				*pval = mk_double(D_NINF);			return true;		}	}	i64 = strtoll(tok, &end, base);	if(*end != '\0')		return false;	if(pval != nil){		mpint *m;		if(fits_fixnum(i64))			*pval = fixnum(i64);		else if((m = strtomp(tok, &end, base, nil)) != nil)			*pval = mk_mp(m);		else			return false;	}	return true;} static charnextchar(Rctx *ctx){	int c;	sl_ios *f = RS; 	do{		c = ios_getc(RS);		if(c == IOS_EOF)			return 0;		if(c == ';'){			// single-line comment			do{				c = ios_getc(f);				if(c == IOS_EOF)					return 0;			}while(c != '\n');		}		if(c == '\n' && ctx->ws)			return '\n';	}while(c == ' ' || isspace(c));	return c;} static voidtake(Rctx *ctx){	ctx->toktype = TOK_NONE;} static _Noreturn void sl_printfmt(2, 3)parse_error(sl_loc *loc, const char *format, ...){	char msgbuf[512];	va_list args;	int n; 	n = snprintf(msgbuf, sizeof(msgbuf), "%s:%"PRIu64":%"PRIu64": ",		loc->filename, (u64int)loc->lineno, (u64int)loc->colno);	if(n >= (int)sizeof(msgbuf))		n = 0;	va_start(args, format);	vsnprintf(msgbuf+n, sizeof(msgbuf)-n, format, args);	sl_v msg = str_from_cstr(msgbuf);	va_end(args); 	sl_raise(mk_list2(sl_errparse, msg));} static voidaccumchar(Rctx *ctx, char c, int *pi){	ctx->buf[(*pi)++] = c;	if(*pi >= (int)(sizeof(ctx->buf)-1))		parse_error(&ctx->loc, "token too long");} // return: 1 if escaped (forced to be symbol)static boolread_token(Rctx *ctx, char c, bool digits){	int i = 0, ch, nc = 0;	bool escaped = false, issym = false; 	while(1){		if(nc != 0){			if(nc != 1)				ios_getc(RS);			ch = ios_peekc(RS);			if(ch == IOS_EOF)				goto terminate;			c = ch;		}		if(c == '|'){			issym = true;			escaped = !escaped;		}else if(c == '\\'){			issym = true;			ios_getc(RS);			ch = ios_peekc(RS);			if(ch == IOS_EOF)				goto terminate;			accumchar(ctx, ch, &i);		}else if(!escaped && !(symchar(c) && (!digits || isdigit(c)))){			break;		}else{			accumchar(ctx, c, &i);		}		nc++;	}	if(nc == 0)		ios_skip(RS, -1);terminate:	ctx->buf[i++] = '\0';	return issym;} static intisdigit_base(char c, int base){	if(base < 11)		return c >= '0' && c < '0'+base;	return (c >= '0' && c <= '9') || (c >= 'a' && c < 'a'+base-10) || (c >= 'A' && c < 'A'+base-10);} static u32intpeek(Rctx *ctx){	u8int c;	char *end;	sl_fx x;	int ch, base; 	if(ctx->toktype != TOK_NONE){		ctx->ws = false;		return ctx->toktype;	}	c = nextchar(ctx);	ctx->loc = RS->loc;	if(ios_eof(RS) || isspace(c)){		ctx->ws = false;		return TOK_NONE;	}	if(c == '(')		ctx->toktype = TOK_OPEN;	else if(c == ')')		ctx->toktype = TOK_CLOSE;	else if(c == '[')		ctx->toktype = TOK_OPENB;	else if(c == ']')		ctx->toktype = TOK_CLOSEB;	else if(c == '{')		ctx->toktype = TOK_OPENC;	else if(c == '}')		ctx->toktype = TOK_CLOSEC;	else if(c == '\'')		ctx->toktype = TOK_QUOTE;	else if(c == '`')		ctx->toktype = TOK_BQ;	else if(c == '"')		ctx->toktype = TOK_DOUBLEQUOTE;	else if(c == 0xc2 && ios_peekc(RS) == 0xab){ // «		ctx->toktype = TOK_VERBATIM;		ios_getc(RS);	}else if(c == '#'){		c = ch = ios_getc(RS);		if(ch == IOS_EOF)			parse_error(&ctx->loc, "invalid read macro");		if(c == '.')			ctx->toktype = TOK_SHARPDOT;		else if(c == '\'')			ctx->toktype = TOK_SHARPQUOTE;		else if(c == '\\'){			Rune cval;			if(ios_getrune(RS, &cval) == IOS_EOF)				parse_error(&ctx->loc, "end of input in character constant");			if(cval == 'u' || cval == 'U' || cval == 'x'){				read_token(ctx, 'u', 0);				if(ctx->buf[1] != '\0'){ // not a solitary 'u','U','x'					if(!sl_read_numtok(&ctx->buf[1], &ctx->tokval, 16))						parse_error(&ctx->loc, "invalid hex character constant");					cval = numval(ctx->tokval);				}			}else if(cval >= 'a' && cval <= 'z'){				read_token(ctx, cval, 0);				ctx->tokval = mk_sym(ctx->buf, true);				if(ctx->buf[1] == '\0') USED(cval); /* one character */				else if(ctx->tokval == sl_nulsym)       cval = 0x00;				else if(ctx->tokval == sl_alarmsym)     cval = 0x07;				else if(ctx->tokval == sl_backspacesym) cval = 0x08;				else if(ctx->tokval == sl_tabsym)       cval = 0x09;				else if(ctx->tokval == sl_linefeedsym)  cval = 0x0A;				else if(ctx->tokval == sl_newlinesym)   cval = 0x0A;				else if(ctx->tokval == sl_vtabsym)      cval = 0x0B;				else if(ctx->tokval == sl_pagesym)      cval = 0x0C;				else if(ctx->tokval == sl_returnsym)    cval = 0x0D;				else if(ctx->tokval == sl_escsym)       cval = 0x1B;				else if(ctx->tokval == sl_spacesym)     cval = 0x20;				else if(ctx->tokval == sl_deletesym)    cval = 0x7F;				else					parse_error(&ctx->loc, "unknown character #\\%s", ctx->buf);			}			ctx->toktype = TOK_NUM;			ctx->tokval = mk_rune(cval);		}else if(c == '('){			ctx->toktype = TOK_SHARPOPEN;		}else if(c == '<'){			parse_error(&ctx->loc, "unreadable object");		}else if(isdigit(c)){			read_token(ctx, c, 1);			c = ios_getc(RS);			if(c == '#')				ctx->toktype = TOK_BACKREF;			else if(c == '=')				ctx->toktype = TOK_LABEL;			else				parse_error(&ctx->loc, "invalid label");			x = strtoll(ctx->buf, &end, 10);			if(*end != '\0')				parse_error(&ctx->loc, "invalid label");			ctx->tokval = fixnum(x);		}else if(c == '!'){			// #! single line comment for shbang script support			do{				ch = ios_getc(RS);			}while(ch != IOS_EOF && ch != '\n');			return peek(ctx);		}else if(c == '|'){			// multiline comment			int commentlevel = 1;			while(1){				ch = ios_getc(RS);			hashpipe_gotc:				if(ch == IOS_EOF)					parse_error(&ctx->loc, "eof within comment");				if(ch == '|'){					ch = ios_getc(RS);					if(ch == '#'){						commentlevel--;						if(commentlevel == 0)							break;						else							continue;					}					goto hashpipe_gotc;				}else if(ch == '#'){					ch = ios_getc(RS);					if(ch == '|')						commentlevel++;					else						goto hashpipe_gotc;				}			}			return peek(ctx);		}else if(c == ';'){			// datum comment			(void)do_read_sexpr(ctx, UNBOUND); // skip			return peek(ctx);		}else if(c == ':'){			// gensym			ch = ios_getc(RS);			if(ch == 'g')				ch = ios_getc(RS);			read_token(ctx, ch, 0);			x = strtol(ctx->buf, &end, 10);			if(*end != '\0' || ctx->buf[0] == '\0')				parse_error(&ctx->loc, "invalid gensym label");			ctx->toktype = TOK_GENSYM;			ctx->tokval = fixnum(x);		}else if(symchar(c)){			read_token(ctx, ch, 0); 			if(((c == 'b' && (base = 2)) ||			    (c == 'o' && (base = 8)) ||			    (c == 'd' && (base = 10)) ||			    (c == 'x' && (base = 16))) && (isdigit_base(ctx->buf[1], base) || ctx->buf[1] == '-')){				if(!sl_read_numtok(&ctx->buf[1], &ctx->tokval, base))					parse_error(&ctx->loc, "invalid base %d constant", base);				ctx->ws = false;				return (ctx->toktype = TOK_NUM);			} 			ctx->toktype = TOK_SHARPSYM;			ctx->tokval = mk_sym(ctx->buf, true);		}else{			parse_error(&ctx->loc, "unknown read macro");		}	}else if(c == ','){		ctx->toktype = TOK_COMMA;		ch = ios_peekc(RS);		if(ch == IOS_EOF)			return ctx->toktype;		if(ch == '@')			ctx->toktype = TOK_COMMAAT;		else if(ch == '.')			ctx->toktype = TOK_COMMADOT;		else{			ctx->ws = false;			return ctx->toktype;		}		ios_getc(RS);	}else{		bool ok = read_token(ctx, c, 0);		const char *s = ctx->buf;		if(!ok){			if(s[0] == '.' && s[1] == 0){				ctx->ws = false;				return (ctx->toktype = TOK_DOT);			}			if(sl_read_numtok(s, &ctx->tokval, 0)){				ctx->ws = false;				return (ctx->toktype = TOK_NUM);			}		}		ctx->toktype = TOK_SYM;		if(strcasecmp(s, "nil") == 0)			ctx->tokval = sl_nil;		else if(s[1] == 0 && (s[0] == 't' || s[0] == 'T'))			ctx->tokval = sl_t;		else{			ctx->tokval = mk_sym(s, true);			if(s[strlen(s)-1] == '#')				ctx->toktype = TOK_GENSYM;		}	}	ctx->ws = false;	return ctx->toktype;} // NOTE: this is NOT an efficient operation. it is only used by the// reader, and requires at least 1 and up to 3 garbage collections!static sl_vvec_grow(sl_v v, bool rewrite_refs){	usize i, s = vec_size(v);	usize d = vec_grow_amt(s);	PUSH(v);	assert(s+d > s);	sl_v newv = alloc_vec(s+d, 1);	v = sl.sp[-1];	for(i = 0; i < s; i++)		vec_elt(newv, i) = vec_elt(v, i);	// use gc to rewrite references from the old vector to the new	sl.sp[-1] = newv;	if(s > 0 && rewrite_refs){		((usize*)ptr(v))[0] |= 0x1;		vec_elt(v, 0) = newv;		sl_gc(false);	}	return POP();} static sl_vread_vec(Rctx *ctx, sl_v label, u32int closer){	sl_v v = sl_emptyvec, elt;	u32int i = 0;	PUSH(v);	if(label != UNBOUND)		ptrhash_put(&sl.readstate->backrefs, (void*)label, (void*)v);	while(peek(ctx) != closer){		if(ios_eof(RS))			parse_error(&ctx->loc, "unexpected end of input");		v = sl.sp[-1]; // reload after possible alloc in peek()		if(i >= vec_size(v)){			v = sl.sp[-1] = vec_grow(v, label != UNBOUND);			if(label != UNBOUND)				ptrhash_put(&sl.readstate->backrefs, (void*)label, (void*)v);		}		elt = do_read_sexpr(ctx, UNBOUND);		v = sl.sp[-1];		assert(i < vec_size(v));		vec_elt(v, i) = elt;		i++;	}	take(ctx);	if(i > 0)		vec_setsize(v, i);	return POP();} static sl_vread_verbatim(Rctx *ctx){	char *temp;	usize i = 0, sz = sizeof(ctx->buf);	char *buf = ctx->buf; 	while(1){		if(i >= sz-UTFmax){ // -UTFmax: leaves room for longest utf8 sequence			sz *= 2;			if(buf == ctx->buf){				if((temp = MEM_ALLOC(sz)) != nil)					memcpy(temp, ctx->buf, i);			}else				temp = MEM_REALLOC(buf, sz);			if(temp == nil){				if(buf == ctx->buf)					MEM_FREE(buf);				parse_error(&ctx->loc, "out of memory reading verbatim string");			}			buf = temp;		}		int c = ios_getc(RS);		if(c == IOS_EOF){			if(buf != ctx->buf)				MEM_FREE(buf);			parse_error(&ctx->loc, "unexpected end of input in verbatim string");		}		if(c == 0xc2 && ios_peekc(RS) == 0xbb){ // »			ios_getc(RS);			break;		}		buf[i++] = c;	}	sl_v s = cvalue_str(i);	memcpy(cvalue_data(s), buf, i);	if(buf != ctx->buf)		MEM_FREE(buf);	return s;} static sl_vread_str(Rctx *ctx){	char *buf, *temp;	char eseq[10];

Lines 1–500 of 797. Load more