ls9-printer.nw

Printer

<<ls9 definitions>>=
#define HAVE_LONG_ABSOLUTE_FUNCTION
@

<<ls9 macros>>=
#define quoted(x, q) \
	(car(x) == (q) && cdr(x) != NIL && NIL == cddr(x))
@

<<ls9 impl>>=
full abs_wrap(ifull x)
{
#ifdef HAVE_LONG_ABSOLUTE_FUNCTION
	return (full)labs((long int)x);
#else
	return (full)abs((int)x);
#endif
}

char *ntoa(ifull x, full r) {
	static char	buf[200];
	full		i = 0, neg;
	char		*p = &buf[sizeof(buf)-1];
	char		d[] = "0123456789abcdefghijklmnopqrstuvwxyz";

	neg = x<0;
	*p = 0;
	while (x || 0 == i) {
		i++;
		p--;
		*p = d[abs_wrap(x % (ifull)r)];
		x = x / (ifull)r;
	}
	if (neg) {
		p--;
		*p = '-';
	}
	return p;
}

void prchar(full sl, full x) {
	if (sl) {
		prints("#\\");
		if (9 == charval(x)) prints("ht");
		else if (10 == charval(x)) prints("nl");
		else if (' ' == charval(x)) prints("sp");
		else if (charval(x) < 32 || charval(x) > 126) {
			prints("\\");
			prints(ntoa((ifull)fixval(x), 8));
		}
		else writec((int)charval(x));
	}
	else {
		writec((int)charval(x));
	}
}

void prfix(full x) {
	/* CAST */
	prints(ntoa((ifull)fixval(x), 10));
}

void prstr(full sl, full x) {
	full	i;
	int	c;

	if (sl) {
		writec('"');
		for (i=0; i<stringlen(x)-1; i++) {
			c = (byte) string(x)[i];
			if ('"' == c)
				prints("\\\"");
			else if ('\\' == c)
				prints("\\\\");
			else if (10 == c)
				prints("\\n");
			else if (c < ' ' || c > 126) {
				writec('\\');
				if (octalp(string(x)[i+1])) {
					if (c < 100) writec('0');
					if (c < 10) writec('0');
				}
				prints(ntoa(c, 8));
			}
			else
				writec(c);
		}
		writec('"');
	}
	else {
		printb(string(x));
	}
}

void prlist(full sl, full x, int d) {
	writec(LP);
	while (x != NIL && Plimit != 1) {
		prex(sl, car(x), d+1);
		x = cdr(x);
		if (x != NIL) {
			writec(' ');
			if (atomp(x)) {
				prints(". ");
				prex(sl, x, d+1);
				break;
			}
		}
	}
	writec(RP);
}

void prvec(full sl, full x, int d) {
	full	i;

	prints("#(");
	for (i=0; i<veclen(x); i++) {
		prex(sl, vector(x)[i], d+1);
		if (i < veclen(x)-1) writec(' ');
	}
	writec(')');
}

void prport(int out, full x) {
	prints("#<");
	prints(out? "out": "in");
	prints("port ");
	/* CAST */
	prints(ntoa((ifull)portno(x), 10));
	prints(">");
}

void pruspec(full x) {
	prints("#<special object ");
	/* CAST */
	prints(ntoa((ifull)x, 10));
	prints(">");
}

void pruatom(full x) {
	prints("#<atom ");
	/* CAST */
	prints(ntoa((ifull)car(x), 10));
	prints(">");
}

void prquote(full sl, full x, int d) {
	if (car(x) == S_quote) writec('\'');
	else if (car(x) == S_qquote) writec('@');
	else if (car(x) == S_unquote) writec(',');
	else if (car(x) == S_splice) prints(",@");
	prex(sl, cadr(x), d);
}

void prex(full sl, full x, int d) {
	if (d > PRDEPTH) {
		prints("\n");
		error("prin: nesting too deep", UNDEF);
	}
	if (Intr) {
		Intr = 0;
		error("interrupted", UNDEF);
	}
	if (NIL == x) prints("nil");
	else if (TRUE == x) prints("t");
	else if (EOFMARK == x) prints("#<eof>");
	else if (UNDEF == x) prints("#<undef>");
	else if (charp(x)) prchar(sl, x);
	else if (fixp(x)) prfix(x);
	else if (symbolp(x)) printb(symname(x));
	else if (stringp(x)) prstr(sl, x);
	else if (vectorp(x)) prvec(sl, x, d);
	else if (closurep(x)) prints("#<function>");
	else if (ctagp(x)) prints("#<catch tag>");
	else if (inportp(x)) prport(0, x);
	else if (outportp(x)) prport(1, x);
	else if (specialp(x)) pruspec(x);
	else if (atomp(x)) pruatom(x);
	else if (quoted(x, S_quote)) prquote(sl, x, d);
	else if (quoted(x, S_qquote)) prquote(sl, x, d);
	else if (quoted(x, S_unquote)) prquote(sl, x, d);
	else if (quoted(x, S_splice)) prquote(sl, x, d);
	else prlist(sl, x, d);
}

void xprint(full sl, full x) {
	prex(sl, x, 0);
	if (1 == Plimit) {
		Plimit = 0;
		prints("...");
	}
}

void prin(full x) {
	xprint(1, x);
}

void princ(full x) {
	xprint(0, x);
}

void print(full x) {
	prin(x); nl();
}
@