shithub: femtolisp

ref: 176253d3aeab23f81935da43799cbd9895ca7436
dir: /print.c/

View raw version
#include "llt.h"
#include "flisp.h"
#include "operators.h"
#include "opcodes.h"
#include "cvalues.h"
#include "ieee754.h"
#include "print.h"
#include "read.h"

static void
outc(char c, ios_t *f)
{
	ios_putc(c, f);
	if(c == '\n')
		FL(hpos) = 0;
	else
		FL(hpos)++;
}

static void
outs(const char *s, ios_t *f)
{
	ios_puts(s, f);
	FL(hpos) += u8_strwidth(s);
}

static void
outsn(const char *s, ios_t *f, size_t n)
{
	ios_write(f, s, n);
	FL(hpos) += u8_strwidth(s);
}

static int
outindent(int n, ios_t *f)
{
	// move back to left margin if we get too indented
	if(n > FL(scr_width)-12)
		n = 2;
	int n0 = n;
	ios_putc('\n', f);
	FL(vpos)++;
	FL(hpos) = n;
	while(n >= 8){
		ios_putc('\t', f);
		n -= 8;
	}
	while(n){
		ios_putc(' ', f);
		n--;
	}
	return n0;
}

void
fl_print_chr(char c, ios_t *f)
{
	outc(c, f);
}

void
fl_print_str(const char *s, ios_t *f)
{
	outs(s, f);
}

void
print_traverse(value_t v)
{
	value_t *bp;
	while(iscons(v)){
		if(ismarked(v)){
			bp = (value_t*)ptrhash_bp(&FL(printconses), (void*)v);
			if(*bp == (value_t)HT_NOTFOUND)
				*bp = fixnum(FL(printlabel)++);
			return;
		}
		mark_cons(v);
		print_traverse(car_(v));
		v = cdr_(v);
	}
	if(!ismanaged(v) || issymbol(v))
		return;
	if(ismarked(v)){
		bp = (value_t*)ptrhash_bp(&FL(printconses), (void*)v);
		if(*bp == (value_t)HT_NOTFOUND)
			*bp = fixnum(FL(printlabel)++);
		return;
	}
	if(isvector(v)){
		if(vector_size(v) > 0)
			mark_cons(v);
		unsigned int i;
		for(i = 0; i < vector_size(v); i++)
			print_traverse(vector_elt(v, i));
	}else if(iscprim(v)){
		// don't consider shared references to e.g. chars
	}else if(isclosure(v)){
		mark_cons(v);
		function_t *f = ptr(v);
		print_traverse(f->bcode);
		print_traverse(f->vals);
		print_traverse(f->env);
	}else if(iscvalue(v)){
		cvalue_t *cv = ptr(v);
		// don't consider shared references to ""
		if(!cv_isstr(cv) || cv_len(cv) != 0)
			mark_cons(v);
		fltype_t *t = cv_class(cv);
		if(t->vtable != nil && t->vtable->print_traverse != nil)
			t->vtable->print_traverse(v);
	}
}

static void
print_symbol_name(ios_t *f, const char *name)
{
	int i, escape = 0, charescape = 0;

	if((name[0] == '\0') ||
		(name[0] == '.' && name[1] == '\0') ||
		(name[0] == '#') ||
		isnumtok(name, nil))
		escape = 1;
	i = 0;
	while(name[i]){
		if(!symchar(name[i])){
			escape = 1;
			if(name[i] == '|' || name[i] == '\\'){
				charescape = 1;
				break;
			}
		}
		i++;
	}
	if(escape){
		if(charescape){
			outc('|', f);
			i = 0;
			while(name[i]){
				if(name[i] == '|' || name[i] == '\\')
					outc('\\', f);
				outc(name[i], f);
				i++;
			}
			outc('|', f);
		}else{
			outc('|', f);
			outs(name, f);
			outc('|', f);
		}
	}else{
		outs(name, f);
	}
}

/*
  The following implements a simple pretty-printing algorithm. This is
  an unlimited-width approach that doesn't require an extra pass.
  It uses some heuristics to guess whether an expression is "small",
  and avoids wrapping symbols across lines. The result is high
  performance and nice output for typical code. Quality is poor for
  pathological or deeply-nested expressions, but those are difficult
  to print anyway.
*/
#define SMALL_STR_LEN 20
static inline int
tinyp(value_t v)
{
	if(issymbol(v))
		return (u8_strwidth(symbol_name(v)) < SMALL_STR_LEN);
	if(fl_isstring(v))
		return (cv_len((cvalue_t*)ptr(v)) < SMALL_STR_LEN);
	return (
		isfixnum(v) || isbuiltin(v) || iscprim(v) ||
		v == FL(f) || v == FL(t) ||
		v == FL(Nil) || v == FL(eof)
	);
}

static int
smallp(value_t v)
{
	if(tinyp(v))
		return 1;
	if(fl_isnumber(v))
		return 1;
	if(iscons(v)){
		if(tinyp(car_(v)) &&
		   (tinyp(cdr_(v)) || (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) && cdr_(cdr_(v)) == FL(Nil))))
			return 1;
		return 0;
	}
	if(isvector(v)){
		size_t s = vector_size(v);
		return (
			s == 0 ||
			(tinyp(vector_elt(v, 0)) && (s == 1 || (s == 2 && tinyp(vector_elt(v, 1)))))
		);
	}
	return 0;
}

static int
specialindent(value_t head)
{
	// indent these forms 2 spaces, not lined up with the first argument
	if(head == FL(lambda) || head == FL(trycatch) || head == FL(definesym) ||
		head == FL(defmacrosym) || head == FL(forsym))
		return 2;
	return -1;
}

static int
lengthestimate(value_t v)
{
	// get the width of an expression if we can do so cheaply
	if(issymbol(v))
		return u8_strwidth(symbol_name(v));
	if(iscprim(v) && ptr(v) != nil && cp_class((cprim_t*)ptr(v)) == FL(runetype))
		return 4;
	return -1;
}

static int
allsmallp(value_t v)
{
	int n = 1;
	while(iscons(v)){
		if(!smallp(car_(v)))
			return 0;
		v = cdr_(v);
		n++;
		if(n > 25)
			return n;
	}
	return n;
}

static int
indentafter3(value_t head, value_t v)
{
	// for certain X always indent (X a b c) after b
	return ((head == FL(forsym)) && !allsmallp(cdr_(v)));
}

static int
indentafter2(value_t head, value_t v)
{
	// for certain X always indent (X a b) after a
	return ((head == FL(definesym) || head == FL(defmacrosym)) &&
			!allsmallp(cdr_(v)));
}

static int
indentevery(value_t v)
{
	// indent before every subform of a special form, unless every
	// subform is "small"
	value_t c = car_(v);
	if(c == FL(lambda) || c == FL(setqsym))
		return 0;
	//if(c == FL(IF)) // TODO: others
	//	return !allsmallp(cdr_(v));
	return 0;
}

static int
blockindent(value_t v)
{
	// in this case we switch to block indent mode, where the head
	// is no longer considered special:
	// (a b c d e
	//  f g h i j)
	return (allsmallp(v) > 9);
}

static void
print_pair(ios_t *f, value_t v)
{
	value_t cd;
	char *op;
	if(iscons(cdr_(v)) && cdr_(cdr_(v)) == FL(Nil) &&
		!ptrhash_has(&FL(printconses), (void*)cdr_(v)) &&
		(((car_(v) == FL(quote))	 && (op = "'"))  ||
		 ((car_(v) == FL(backquote)) && (op = "`"))  ||
		 ((car_(v) == FL(comma))	 && (op = ","))  ||
		 ((car_(v) == FL(commaat))   && (op = ",@")) ||
		 ((car_(v) == FL(commadot))  && (op = ",.")))){
		// special prefix syntax
		unmark_cons(v);
		unmark_cons(cdr_(v));
		outs(op, f);
		fl_print_child(f, car_(cdr_(v)));
		return;
	}
	int startpos = FL(hpos);
	outc('(', f);
	int newindent = FL(hpos), blk = blockindent(v);
	int lastv, n = 0, si, ind, est, always = 0, nextsmall, thistiny;
	if(!blk)
		always = indentevery(v);
	value_t head = car_(v);
	int after3 = indentafter3(head, v);
	int after2 = indentafter2(head, v);
	int n_unindented = 1;
	while(1){
		cd = cdr_(v);
		if(FL(print_length) >= 0 && n >= FL(print_length) && cd != FL(Nil)){
			outsn("...)", f, 4);
			break;
		}
		lastv = FL(vpos);
		unmark_cons(v);
		fl_print_child(f, car_(v));
		if(!iscons(cd) || ptrhash_has(&FL(printconses), (void*)cd)){
			if(cd != FL(Nil)){
				outsn(" . ", f, 3);
				fl_print_child(f, cd);
			}
			outc(')', f);
			break;
		}

		if(!FL(print_pretty) ||
			((head == FL(lambda)) && n == 0)){
			// never break line before lambda-list
			ind = 0;
		}else{
			est = lengthestimate(car_(cd));
			nextsmall = smallp(car_(cd));
			thistiny = tinyp(car_(v));
			ind = (((FL(vpos) > lastv) ||
					(FL(hpos)>FL(scr_width)/2 && !nextsmall && !thistiny && n>0)) ||

				   (FL(hpos) > FL(scr_width)-4) ||

				   (est != -1 && (FL(hpos)+est > FL(scr_width)-2)) ||

				   ((head == FL(lambda)) && !nextsmall) ||

				   (n > 0 && always) ||

				   (n == 2 && after3) ||
				   (n == 1 && after2) ||

				   (n_unindented >= 3 && !nextsmall) ||

				   (n == 0 && !smallp(head)));
		}

		if(ind){
			newindent = outindent(newindent, f);
			n_unindented = 1;
		}else{
			n_unindented++;
			outc(' ', f);
			if(n == 0){
				// set indent level after printing head
				si = specialindent(head);
				if(si != -1)
					newindent = startpos + si;
				else if(!blk)
					newindent = FL(hpos);
			}
		}
		n++;
		v = cd;
	}
}

static void cvalue_print(ios_t *f, value_t v);

static int
print_circle_prefix(ios_t *f, value_t v)
{
	value_t label;
	if((label = (value_t)ptrhash_get(&FL(printconses), (void*)v)) != (value_t)HT_NOTFOUND){
		if(!ismarked(v)){
			FL(hpos) += ios_printf(f, "#%"PRIdPTR"#", numval(label));
			return 1;
		}
		FL(hpos) += ios_printf(f, "#%"PRIdPTR"=", numval(label));
	}
	if(ismanaged(v))
		unmark_cons(v);
	return 0;
}

void
fl_print_child(ios_t *f, value_t v)
{
	const char *name;
	if(FL(print_level) >= 0 && FL(p_level) >= FL(print_level) && (iscons(v) || isvector(v) || isclosure(v))){
		outc('#', f);
		return;
	}
	FL(p_level)++;

	switch(tag(v)){
	case TAG_NUM: case TAG_NUM1:
		FL(hpos) += ios_printf(f, "%"PRId64, (int64_t)numval(v));
		break;
	case TAG_SYM:
		name = symbol_name(v);
		if(FL(print_princ))
			outs(name, f);
		else if(ismanaged(v)){
			outsn("#:", f, 2);
			outs(name, f);
		}else
			print_symbol_name(f, name);
		break;
	case TAG_FUNCTION:
		if(v == FL(t))
			outsn("#t", f, 2);
		else if(v == FL(f))
			outsn("#f", f, 2);
		else if(v == FL(Nil))
			outsn("()", f, 2);
		else if(v == FL(eof))
			outsn("#<eof>", f, 6);
		else if(isbuiltin(v)){
			if(!FL(print_princ))
				outsn("#.", f, 2);
			outs(builtins[uintval(v)].name, f);
		}else{
			assert(isclosure(v));
			if(!FL(print_princ)){
				if(print_circle_prefix(f, v))
					break;
				function_t *fn = ptr(v);
				outs("#fn(", f);
				char *data = cvalue_data(fn->bcode);
				size_t i, sz = cvalue_len(fn->bcode);
				for(i = 0; i < sz; i++)
					data[i] += 48;
				fl_print_child(f, fn->bcode);
				for(i = 0; i < sz; i++)
					data[i] -= 48;
				outc(' ', f);
				fl_print_child(f, fn->vals);
				if(fn->env != FL(Nil)){
					outc(' ', f);
					fl_print_child(f, fn->env);
				}
				if(fn->name != FL(lambda)){
					outc(' ', f);
					fl_print_child(f, fn->name);
				}
				outc(')', f);
			}else{
				outs("#<function>", f);
			}
		}
		break;
	case TAG_CPRIM:
		if(v == UNBOUND)
			outs("#<undefined>", f);
		else
			cvalue_print(f, v);
		break;
	case TAG_CVALUE:
	case TAG_VECTOR:
	case TAG_CONS:
		if(!FL(print_princ) && print_circle_prefix(f, v))
			break;
		if(isvector(v)){
			outs("#(", f);
			int newindent = FL(hpos), est;
			int i, sz = vector_size(v);
			for(i = 0; i < sz; i++){
				if(FL(print_length) >= 0 && i >= FL(print_length) && i < sz-1){
					outsn("...", f, 3);
					break;
				}
				fl_print_child(f, vector_elt(v, i));
				if(i < sz-1){
					if(!FL(print_pretty))
						outc(' ', f);
					else{
						est = lengthestimate(vector_elt(v, i+1));
						if(FL(hpos) > FL(scr_width)-4 ||
						   (est != -1 && (FL(hpos)+est > FL(scr_width)-2)) ||
						   (FL(hpos) > FL(scr_width)/2 && !smallp(vector_elt(v, i+1)) && !tinyp(vector_elt(v, i))))
							newindent = outindent(newindent, f);
						else
							outc(' ', f);
					}
				}
			}
			outc(')', f);
			break;
		}
		if(iscvalue(v))
			cvalue_print(f, v);
		else
			print_pair(f, v);
		break;
	}
	FL(p_level)--;
}

static void
print_string(ios_t *f, const char *str, size_t sz)
{
	char buf[512];
	size_t i = 0;
	uint8_t c;
	static char hexdig[] = "0123456789abcdef";

	if(!u8_isvalid(str, sz)){
		// alternate print algorithm that preserves data if it's not UTF-8
		for(i = 0; i < sz; i++){
			c = str[i];
			if(c == '\\')
				outsn("\\\\", f, 2);
			else if(c == '"')
				outsn("\\\"", f, 2);
			else if(c >= 32 && c < 0x7f)
				outc(c, f);
			else{
				outsn("\\x", f, 2);
				outc(hexdig[c>>4], f);
				outc(hexdig[c&0xf], f);
			}
		}
	}else{
		while(i < sz){
			size_t n = u8_escape(buf, sizeof(buf), str, &i, sz, 1, 0);
			outsn(buf, f, n-1);
		}
	}
}

static int
double_exponent(double d)
{
	union ieee754_double dl;

	dl.d = d;
	return dl.ieee.exponent - IEEE754_DOUBLE_BIAS;
}

static void
snprint_real(char *s, size_t cnt, double r,
             int width, // printf field width, or 0
			 int dec, // # decimal digits desired, recommend 16
             // # of zeros in .00...0x before using scientific notation
             // recommend 3-4 or so
             int max_digs_rt,
             // # of digits left of decimal before scientific notation
             // recommend 10
             int max_digs_lf)
{
	int mag;
	double fpart, temp;
	char format[8];
	char num_format[3];
	int sz, keepz = 0;

	s[0] = '\0';
	if(width == -1){
		width = 0;
		keepz = 1;
	}
	if(isnan(r)){
		strncpy(s, signbit(r) ? "-nan" : "nan", cnt);
		return;
	}
	if(r == 0){
		strncpy(s, "0", cnt);
		return;
	}

	num_format[0] = 'l';
	num_format[2] = '\0';

	mag = double_exponent(r);

	mag = (int)(((double)mag)/LOG2_10 + 0.5);
	if(r == 0)
		mag = 0;
	if((mag > max_digs_lf-1) || (mag < -max_digs_rt)){
		num_format[1] = 'e';
		temp = r/pow(10, mag); /* see if number will have a decimal */
		fpart = temp - floor(temp); /* when written in scientific notation */
	}else{
		num_format[1] = 'f';
		fpart = r - floor(r);
	}
	if(fpart == 0)
		dec = 0;
	if(width == 0)
		snprintf(format, 8, "%%.%d%s", dec, num_format);
	else
		snprintf(format, 8, "%%%d.%d%s", width, dec, num_format);
	sz = snprintf(s, cnt, format, r);
	/* trim trailing zeros from fractions. not when using scientific
	   notation, since we might have e.g. 1.2000e+100. also not when we
	   need a specific output width */
	if(width == 0 && !keepz){
		if(sz > 2 && fpart && num_format[1] != 'e'){
			while(s[sz-1] == '0'){
				s[sz-1] = '\0';
				sz--;
			}
			// don't need trailing .
			if(s[sz-1] == '.'){
				s[--sz] = '\0';
			}
		}
	}
	// TODO. currently 1.1e20 prints as 1.1000000000000000e+20; be able to
	// get rid of all those zeros.
}

// 'weak' means we don't need to accurately reproduce the type, so
// for example #int32(0) can be printed as just 0. this is used
// printing in a context where a type is already implied, e.g. inside
// an array.
static void
cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, int weak)
{
	if(type == FL(bytesym)){
		uint8_t ch = *(uint8_t*)data;
		if(FL(print_princ))
			outc(ch, f);
		else if(weak)
			FL(hpos) += ios_printf(f, "0x%hhx", ch);
		else
			FL(hpos) += ios_printf(f, "#byte(0x%hhx)", ch);
	}else if(type == FL(runesym)){
		Rune r = *(Rune*)data;
		char seq[UTFmax+1];
		int nb = runetochar(seq, &r);
		seq[nb] = '\0';
		if(FL(print_princ)){
			outsn(seq, f, nb);
		}else{
			outsn("#\\", f, 2);
			switch(r){
			case 0x00: outsn("nul", f, 3); break;
			case 0x07: outsn("alarm", f, 5); break;
			case 0x08: outsn("backspace", f, 9); break;
			case 0x09: outsn("tab", f, 3); break;
			case 0x0a: outsn("newline", f, 7); break;
			case 0x0b: outsn("vtab", f, 4); break;
			case 0x0c: outsn("page", f, 4); break;
			case 0x0d: outsn("return", f, 6); break;
			case 0x1b: outsn("esc", f, 3); break;
			case ' ':  outsn("space", f, 5); break;
			case 0x7f: outsn("delete", f, 6); break;
			default:
				if(u8_iswprint(r))
					outs(seq, f);
				else
					FL(hpos) += ios_printf(f, "x%04x", r);
				break;
			}
		}
	}else if(type == FL(floatsym) || type == FL(doublesym)){
		char buf[64];
		double d;
		int ndec;
		if(type == FL(floatsym)){
			d = (double)*(float*)data;
			ndec = 8;
		}else{
			d = *(double*)data;
			ndec = 16;
		}
		if(!isfinite(d)){
			char *rep;
			if(isnan(d))
				rep = signbit(d) ? "-nan.0" : "+nan.0";
			else
				rep = signbit(d) ? "-inf.0" : "+inf.0";
			if(type == FL(floatsym) && !FL(print_princ) && !weak)
				FL(hpos) += ios_printf(f, "#%s(%s)", symbol_name(type), rep);
			else
				outs(rep, f);
		}else if(d == 0){
			if(1/d < 0)
				outsn("-0.0", f, 4);
			else
				outsn("0.0", f, 3);
			if(type == FL(floatsym) && !FL(print_princ) && !weak)
				outc('f', f);
		}else{
			snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
			int hasdec = (strpbrk(buf, ".eE") != nil);
			outs(buf, f);
			if(!hasdec)
				outsn(".0", f, 2);
			if(type == FL(floatsym) && !FL(print_princ) && !weak)
				outc('f', f);
		}
#if defined(ULONG64)
	}else if(type == FL(uint64sym) || type == FL(ulongsym)){
#else
	}else if(type == FL(uint64sym)){
#endif
		uint64_t ui64 = *(uint64_t*)data;
		if(weak || FL(print_princ))
			FL(hpos) += ios_printf(f, "%"PRIu64, ui64);
		else
			FL(hpos) += ios_printf(f, "#%s(%"PRIu64")", symbol_name(type), ui64);
	}else if(type == FL(bignumsym)){
		mpint *i = *(mpint**)data;
		char *s = mptoa(i, 10, nil, 0);
		if(weak || FL(print_princ))
			FL(hpos) += ios_printf(f, "%s", s);
		else
			FL(hpos) += ios_printf(f, "#%s(%s)", symbol_name(type), s);
		LLT_FREE(s);
	}else if(issymbol(type)){
		// handle other integer prims. we know it's smaller than uint64
		// at this point, so int64 is big enough to capture everything.
		numerictype_t nt = sym_to_numtype(type);
		if(valid_numtype(nt)){
			int64_t i64 = conv_to_int64(data, nt);
			if(weak || FL(print_princ))
				FL(hpos) += ios_printf(f, "%"PRId64, i64);
			else
				FL(hpos) += ios_printf(f, "#%s(%"PRId64")", symbol_name(type), i64);
		}else{
			FL(hpos) += ios_printf(f, "#<%s>", symbol_name(type));
		}
	}else if(iscons(type)){
		if(car_(type) == FL(arraysym)){
			size_t i;
			value_t eltype = car(cdr_(type));
			size_t cnt, elsize;
			if(iscons(cdr_(cdr_(type)))){
				cnt = toulong(car_(cdr_(cdr_(type))));
				elsize = cnt ? len/cnt : 0;
			}else{
				// incomplete array type
				int junk;
				elsize = ctype_sizeof(eltype, &junk);
				cnt = elsize ? len/elsize : 0;
			}
			if(eltype == FL(bytesym)){
				if(FL(print_princ)){
					ios_write(f, data, len);
					/*
					char *nl = llt_memrchr(data, '\n', len);
					if(nl)
						FL(hpos) = u8_strwidth(nl+1);
					else
						FL(hpos) += u8_strwidth(data);
					*/
				}else{
					outc('"', f);
					print_string(f, (char*)data, len);
					outc('"', f);
				}
				return;
			}else if(eltype == FL(runesym)){
				char buf[UTFmax];
				if(!FL(print_princ))
					outc('"', f);
				for(i = 0; i < cnt; i++, data = (char*)data + elsize){
					int n = runetochar(buf, (Rune*)data);
					if(FL(print_princ))
						ios_write(f, buf, n);
					else
						print_string(f, buf, n);
				}
				if(!FL(print_princ))
					outc('"', f);
				return;
			}
			if(!weak){
				if(eltype == FL(uint8sym)){
					outsn("#vu8(", f, 5);
				}else{
					outsn("#array(", f, 7);
					fl_print_child(f, eltype);
					if(cnt > 0)
						outc(' ', f);
				}
			}else{
				outs("#(", f);
			}
			for(i = 0; i < cnt; i++){
				if(i > 0)
					outc(' ', f);
				cvalue_printdata(f, data, elsize, eltype, 1);
				data = (char*)data + elsize;
			}
			outc(')', f);
		}else if(car_(type) == FL(enumsym)){
			int n = *(int*)data;
			value_t syms = car(cdr_(type));
			assert(isvector(syms));
			if(!weak){
				outsn("#enum(", f, 6);
				fl_print_child(f, syms);
				outc(' ', f);
			}
			if(n >= (int)vector_size(syms)){
				cvalue_printdata(f, data, len, FL(int32sym), 1);
			}else{
				fl_print_child(f, vector_elt(syms, n));
			}
			if(!weak)
				outc(')', f);
		}
	}
}

static void
cvalue_print(ios_t *f, value_t v)
{
	cvalue_t *cv = (cvalue_t*)ptr(v);
	void *data = cptr(v);
	value_t label;

	if(cv_class(cv) == FL(builtintype)){
		void *fptr = *(void**)data;
		label = (value_t)ptrhash_get(&FL(reverse_dlsym_lookup_table), cv);
		if(label == (value_t)HT_NOTFOUND){
			FL(hpos) += ios_printf(f, "#<builtin @%p>", fptr);
		}else{
			if(FL(print_princ)){
				outs(symbol_name(label), f);
			}else{
				outsn("#fn(", f, 4);
				outs(symbol_name(label), f);
				outc(')', f);
			}
		}
	}else if(cv_class(cv)->vtable != nil && cv_class(cv)->vtable->print != nil){
		cv_class(cv)->vtable->print(v, f);
	}else{
		value_t type = cv_type(cv);
		size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv);
		cvalue_printdata(f, data, len, type, 0);
	}
}

static void
set_print_width(void)
{
	value_t pw = symbol_value(FL(printwidthsym));
	if(!isfixnum(pw))
		return;
	FL(scr_width) = numval(pw);
}

void
fl_print(ios_t *f, value_t v)
{
	FL(print_pretty) = symbol_value(FL(printprettysym)) != FL(f);
	if(FL(print_pretty))
		set_print_width();
	FL(print_princ) = symbol_value(FL(printreadablysym)) == FL(f);
	value_t pl = symbol_value(FL(printlengthsym));
	FL(print_length) = isfixnum(pl) ? numval(pl) : -1;
	pl = symbol_value(FL(printlevelsym));
	FL(print_level) = isfixnum(pl) ? numval(pl) : -1;
	FL(p_level) = 0;

	FL(printlabel) = 0;
	if(!FL(print_princ))
		print_traverse(v);
	FL(hpos) = FL(vpos) = 0;

	fl_print_child(f, v);

	if(FL(print_level) >= 0 || FL(print_length) >= 0)
		memset(FL(consflags), 0, 4*bitvector_nwords(FL(heapsize)/sizeof(cons_t)));

	if((iscons(v) || isvector(v) || isfunction(v) || iscvalue(v)) &&
		!fl_isstring(v) && v != FL(t) && v != FL(f) && v != FL(Nil))
		htable_reset(&FL(printconses), 32);
}