/* xformat - formatted output function */
LVAL xformat(void)
{
unsigned char *fmt;
LVAL stream,val;
int ch;
/* protect stream in case it is a new ustream */
xlsave1(stream);
/* get the stream and format string */
stream = xlgetarg();
if (stream == NIL)
val = stream = newustream();
else {
if (stream == s_true)
stream = getvalue(s_stdout);
else if (!streamp(stream) && !ustreamp(stream))
xlbadtype(stream);
val = NIL;
}
fmt = getstring(xlgastring());
/* process the format string */
while ((ch = *fmt++))
if (ch == '~') {
switch (*fmt++) {
case '\0':
xlerror("expecting a format directive",cvstring((char *) (fmt-1)));
case 'a': case 'A':
xlprint(stream,xlgetarg(),FALSE);
break;
case 's': case 'S':
xlprint(stream,xlgetarg(),TRUE);
break;
case '%':
xlterpri(stream);
break;
case '~':
xlputc(stream,'~');
break;
case '\n':
case '\r':
/* mac may read \r -- this should be ignored */
if (*fmt == '\r') fmt++;
while (*fmt && *fmt != '\n' && isspace(*fmt))
++fmt;
break;
default:
xlerror("unknown format directive",cvstring((char *) (fmt-1)));
}
}
else
xlputc(stream,ch);
/* return the value */
if (val) val = getstroutput(val);
xlpop();
return val;
}
/* putclosure - output a closure */
LOCAL void putclosure(LVAL fptr, LVAL val)
{
LVAL name;
if (name = getname(val))
sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
else
strcpy(buf,"#<Closure: #");
xlputstr(fptr,buf);
sprintf(buf,AFMT,val);
xlputstr(fptr,buf);
xlputc(fptr,'>');
/*
xlputstr(fptr,"\nName: "); xlprint(fptr,getname(val),TRUE);
xlputstr(fptr,"\nType: "); xlprint(fptr,gettype(val),TRUE);
xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE);
xlputstr(fptr,"\nArgs: "); xlprint(fptr,getargs(val),TRUE);
xlputstr(fptr,"\nOargs: "); xlprint(fptr,getoargs(val),TRUE);
xlputstr(fptr,"\nRest: "); xlprint(fptr,getrest(val),TRUE);
xlputstr(fptr,"\nKargs: "); xlprint(fptr,getkargs(val),TRUE);
xlputstr(fptr,"\nAargs: "); xlprint(fptr,getaargs(val),TRUE);
xlputstr(fptr,"\nBody: "); xlprint(fptr,getbody(val),TRUE);
xlputstr(fptr,"\nEnv: "); xlprint(fptr,closure_getenv(val),TRUE);
xlputstr(fptr,"\nFenv: "); xlprint(fptr,getfenv(val),TRUE);
*/
}
LVAL xssystem()
{
char *cmd;
int status;
LVAL stream = NIL;
FILE *p;
int ch;
cmd = (char *) getstring(xlgastring());
if (moreargs()) {
stream = xlgetarg();
if (stream == s_true)
stream = getvalue(s_stdout);
else if (!streamp(stream) && !ustreamp(stream))
xlbadtype(stream);
}
if (stream == NIL) {
status = system(cmd);
if (status == 127) xlfail("shell could not execute command");
}
else {
if ((p = popen(cmd, "r")) == NULL)
xlfail("could not execute command");
while ((ch = getc(p)) != EOF) xlputc(stream, ch);
status = pclose(p);
}
return(cvfixnum((FIXTYPE) status));
}
/* putatm - output an atom */
void putatm(LVAL fptr, char *tag, LVAL val)
{
sprintf(buf,"#<%s: #",tag);
xlputstr(fptr,buf);
sprintf(buf,AFMT,val);
xlputstr(fptr,buf);
xlputc(fptr,'>');
}
/* putsubr - output a subr/fsubr */
LOCAL void putsubr(LVAL fptr, char *tag, LVAL val)
{
sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name);
xlputstr(fptr,buf);
sprintf(buf,AFMT,val);
xlputstr(fptr,buf);
xlputc(fptr,'>');
}
/* putstring - output a string */
LOCAL void putstring(LVAL fptr, LVAL str)
{
unsigned char *p;
int ch;
/* output each character */
for (p = getstring(str); (ch = *p) != '\0'; ++p)
xlputc(fptr,ch);
}
/* putqstring - output a quoted string */
LOCAL void putqstring(LVAL fptr, LVAL str)
{
unsigned char *p;
int ch;
/* get the string pointer */
p = getstring(str);
/* output the initial quote */
xlputc(fptr,'"');
/* output each character in the string */
for (p = getstring(str); (ch = *p) != '\0'; ++p)
/* check for a control character */
if (ch < 040 || ch == '\\' || ch > 0176) {
xlputc(fptr,'\\');
switch (ch) {
case '\011':
xlputc(fptr,'t');
break;
case '\012':
xlputc(fptr,'n');
break;
case '\014':
xlputc(fptr,'f');
break;
case '\015':
xlputc(fptr,'r');
break;
case '\\':
xlputc(fptr,'\\');
break;
default:
putoct(fptr,ch);
break;
}
}
/* output a normal character */
else
xlputc(fptr,ch);
/* output the terminating quote */
xlputc(fptr,'"');
}
/* xwrbyte - write a byte to a file */
LVAL xwrbyte(void)
{
LVAL fptr,chr;
/* get the byte and file pointer */
chr = xlgafixnum();
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
xllastarg();
/* put byte to the file */
xlputc(fptr,(int)getfixnum(chr));
/* return the character */
return (chr);
}
/* xwrchar - write a character to a file */
LVAL xwrchar(void)
{
LVAL fptr,chr;
/* get the character and file pointer */
chr = xlgachar();
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
xllastarg();
/* put character to the file */
xlputc(fptr,getchcode(chr));
/* return the character */
return (chr);
}
/* xmkstrinput - make a string input stream */
LVAL xmkstrinput(void)
{
int start,end,len,i;
unsigned char *str;
LVAL string,val;
/* protect the return value */
xlsave1(val);
/* get the string and length */
string = xlgastring();
str = getstring(string);
len = getslength(string) - 1;
/* get the starting offset */
if (moreargs()) {
val = xlgafixnum();
start = (int)getfixnum(val);
}
else start = 0;
/* get the ending offset */
if (moreargs()) {
val = xlgafixnum();
end = (int)getfixnum(val);
}
else end = len;
xllastarg();
/* check the bounds */
if (start < 0 || start > len)
xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
if (end < 0 || end > len)
xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
/* make the stream */
val = newustream();
/* copy the substring into the stream */
for (i = start; i < end; ++i)
xlputc(val,str[i]);
/* restore the stack */
xlpop();
/* return the new stream */
return (val);
}
/* xwrfloat - write a float to a file */
LVAL xwrfloat(void)
{
LVAL val, fptr;
union {
char b[8];
float f;
double d;
} v;
int n = 4;
int i;
int index = 3; /* where to start in array */
int incr = -1; /* how to step through array */
/* get the float and file pointer and optional byte count */
val = xlgaflonum();
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
if (moreargs()) {
LVAL count = typearg(fixp);
n = getfixnum(count);
if (n < 0) {
n = -n;
index = 0;
incr = 1;
}
if (n != 4 && n != 8) {
xlerror("must be 4 or 8 bytes", count);
}
}
xllastarg();
#ifdef XL_BIG_ENDIAN
/* flip the bytes */
index = n - 1 - index;
incr = -incr;
#endif
/* build output v.b */
if (n == 4) v.f = (float) getflonum(val);
else v.d = getflonum(val);
/* put bytes to the file */
for (i = 0; i < n; i++) {
xlputc(fptr, v.b[index]);
index += incr;
}
/* return the flonum */
return val;
}
/* positive count means write big-endian */
LVAL xwrint(void)
{
LVAL val, fptr;
unsigned char b[4];
long i;
int n = 4;
int index = 3; /* where to start in array */
int incr = -1; /* how to step through array */
int v;
/* get the int and file pointer and optional byte count */
val = xlgafixnum();
v = getfixnum(val);
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
if (moreargs()) {
LVAL count = typearg(fixp);
n = getfixnum(count);
index = n - 1;
if (n < 0) {
n = -n;
index = 0;
incr = 1;
}
if (n > 4) {
xlerror("4-byte limit", count);
}
}
xllastarg();
/* build output b as little-endian */
for (i = 0; i < n; i++) {
b[i] = (unsigned char) v;
v = v >> 8;
}
/* put bytes to the file */
while (n) {
n--;
xlputc(fptr, b[index]);
index += incr;
}
/* return the integer */
return val;
}
/* putsymbol - output a symbol */
LOCAL void putsymbol(LVAL fptr, char *str, int escflag)
{
int downcase;
LVAL type;
char *p;
/* check for printing without escapes */
if (!escflag) {
xlputstr(fptr,str);
return;
}
/* check to see if symbol needs escape characters */
if (tentry(*str) == k_const) {
for (p = str; *p; ++p)
if (islower(*p)
|| ((type = tentry(*p)) != k_const
&& (!consp(type) || car(type) != k_nmacro))) {
xlputc(fptr,'|');
while (*str) {
if (*str == '\\' || *str == '|')
xlputc(fptr,'\\');
xlputc(fptr,*str++);
}
xlputc(fptr,'|');
return;
}
}
/* get the case translation flag */
downcase = (getvalue(s_printcase) == k_downcase);
/* check for the first character being '#' */
if (*str == '#' || *str == '.' || xlisnumber(str,NULL))
xlputc(fptr,'\\');
/* output each character */
while (*str) {
/* don't escape colon until we add support for packages */
if (*str == '\\' || *str == '|' /* || *str == ':' */)
xlputc(fptr,'\\');
xlputc(fptr,(downcase && isupper(*str) ? tolower(*str++) : *str++));
}
}
/* putchcode - output a character */
LOCAL void putchcode(LVAL fptr, int ch, int escflag)
{
if (escflag) {
switch (ch) {
case '\n':
xlputstr(fptr,"#\\Newline");
break;
case ' ':
xlputstr(fptr,"#\\Space");
break;
case '\t':
xlputstr(fptr, "#\\Tab");
break;
default:
sprintf(buf,"#\\%c",ch);
xlputstr(fptr,buf);
break;
}
}
else
xlputc(fptr,ch);
}
/* xlprint - print an xlisp value */
void xlprint(LVAL fptr, LVAL vptr, int flag)
{
LVAL nptr,next;
int n,i;
/* print nil */
if (vptr == NIL) {
putsymbol(fptr,"NIL",flag);
return;
}
/* check value type */
switch (ntype(vptr)) {
case SUBR:
putsubr(fptr,"Subr",vptr);
break;
case FSUBR:
putsubr(fptr,"FSubr",vptr);
break;
case CONS:
xlputc(fptr,'(');
for (nptr = vptr; nptr != NIL; nptr = next) {
xlprint(fptr,car(nptr),flag);
if (next = cdr(nptr))
if (consp(next))
xlputc(fptr,' ');
else {
xlputstr(fptr," . ");
xlprint(fptr,next,flag);
break;
}
}
xlputc(fptr,')');
break;
case SYMBOL:
putsymbol(fptr,(char *) getstring(getpname(vptr)),flag);
break;
case FIXNUM:
putfixnum(fptr,getfixnum(vptr));
break;
case FLONUM:
putflonum(fptr,getflonum(vptr));
break;
case CHAR:
putchcode(fptr,getchcode(vptr),flag);
break;
case STRING:
if (flag)
putqstring(fptr,vptr);
else
putstring(fptr,vptr);
break;
case STREAM:
putatm(fptr,"File-Stream",vptr);
break;
case USTREAM:
putatm(fptr,"Unnamed-Stream",vptr);
break;
case OBJECT:
putatm(fptr,"Object",vptr);
break;
case VECTOR:
xlputc(fptr,'#');
xlputc(fptr,'(');
for (i = 0, n = getsize(vptr); n-- > 0; ) {
xlprint(fptr,getelement(vptr,i++),flag);
if (n) xlputc(fptr,' ');
}
xlputc(fptr,')');
break;
case CLOSURE:
putclosure(fptr,vptr);
break;
case EXTERN:
if (getdesc(vptr)) {
(*(getdesc(vptr)->print_meth))(fptr, getinst(vptr));
}
break;
case FREE_NODE:
putatm(fptr,"Free",vptr);
break;
default:
putatm(fptr,"Foo",vptr);
break;
}
}
/* ppterpri - terminate the print line and indent */
LOCAL void ppterpri(void)
{
xlterpri(ppfile);
for (pplevel = 0; pplevel < ppmargin; pplevel++)
xlputc(ppfile,' ');
}
/* ppputc - output a character and update the indent level */
LOCAL void ppputc(int ch)
{
xlputc(ppfile,ch);
pplevel++;
}
/* xlputstr - output a string */
void xlputstr(LVAL fptr, char *str)
{
while (*str)
xlputc(fptr,*str++);
}
/* xlterpri - terminate the current print line */
void xlterpri(LVAL fptr)
{
xlputc(fptr,'\n');
}
