552 lines
17 KiB
C
552 lines
17 KiB
C
/* =====> PROCIOSP.C */
|
||
/* TIPC Scheme '84 Runtime Support - File Input/Output Support
|
||
(C) Copyright 1985 by Texas Instruments Incorporated.
|
||
All rights reserved.
|
||
|
||
Author: John C. Jensen
|
||
Installation: Texas Instruments Incorporated, Dallas, Texas
|
||
Division: Central Research Laboratories
|
||
Cost Center: Computer Science Laboratory
|
||
Project: Computer Architecture Branch
|
||
Date Written: 4 February 1985
|
||
Last Modification:
|
||
14 Jan 1987 - dbs Modified to allow for random i/o.
|
||
16 Mar 1987 - tc Dos I/O errors call DOS-ERR now.
|
||
24 Nov 1987 - tc Renamed from SIN_OUT.C to IOSUPORT.C
|
||
Combined routines from sprint.c,sread.c
|
||
get_port.c and zcio.c
|
||
*/
|
||
#include "scheme.h"
|
||
#include "sport.h"
|
||
#include "slist.h"
|
||
|
||
#define FILE_NOT_FOUND 2 /* MS-DOS error code */
|
||
#define NON_RESTART 1 /* Operation not restartable */
|
||
|
||
extern char decpoint; /* Current decimal point character */
|
||
extern unsigned GC_ING; /* Garbage collecting indicator */
|
||
|
||
char *getmem(); /* Lattice C's memory allocation support */
|
||
|
||
|
||
|
||
/************************************************************************/
|
||
/* Get Port Object */
|
||
/* */
|
||
/* Purpose: To determine is a register contains a valid port object */
|
||
/* representation and to return the appropriate port */
|
||
/* pointer in "tmp_reg". */
|
||
/************************************************************************/
|
||
get_port(reg, mode)
|
||
int reg[2], mode;
|
||
{
|
||
int disp; /* displacement component of a pointer */
|
||
int page; /* page number component of a pointer */
|
||
|
||
/* fetch page and displacement portions of port pointer */
|
||
page = CORRPAGE(reg[C_PAGE]);
|
||
disp = reg[C_DISP];
|
||
|
||
/* check to see if port pointer is nil-- if so, search fluid env */
|
||
if (!page)
|
||
{
|
||
if (mode) intern (tmp_reg, "OUTPUT-PORT", 11);
|
||
else intern (tmp_reg, "INPUT-PORT", 10);
|
||
|
||
/* search fluid environment for interned symbol */
|
||
ASSERT(fluid_lookup(tmp_reg));
|
||
page = CORRPAGE(tmp_page);
|
||
disp = tmp_disp;
|
||
} /* end: if (!page) */
|
||
|
||
/* At this point, the page, disp should point to a port, or the
|
||
symbol 'console */
|
||
if (ptype[page] != PORTTYPE*2)
|
||
{
|
||
if (CORRPAGE(CON_PAGE) != page || CON_DISP != disp) return(1);
|
||
tmp_page = SPECPOR*2;
|
||
tmp_disp = (mode ? OUT_DISP : IN_DISP);
|
||
}
|
||
else
|
||
{
|
||
tmp_page = ADJPAGE(page);
|
||
tmp_disp = disp;
|
||
}
|
||
return(0);
|
||
} /* end of function: get_port(reg, mode) */
|
||
|
||
|
||
/************************************************************************/
|
||
/* Open a Port */
|
||
/************************************************************************/
|
||
spopen(file, mode)
|
||
int file[2]; /* pathname, 'console, nil, or #<port> */
|
||
int mode[2]; /* 'read, 'write, 'append */
|
||
{
|
||
/* extern int prn_handle; (tc) */
|
||
int direction; /* 'read, 'write, 'append code */
|
||
int disp; /* displacement component of a pointer */
|
||
int handle; /* handle assigned to file by open */
|
||
int hsize; /* high word of file size - dbs */
|
||
int lsize; /* low word of file size - dbs */
|
||
int i; /* our old favorite index variable */
|
||
int len; /* length of file's pathname (plus 1) */
|
||
int page; /* page number component of a pointer */
|
||
int p_flags; /* port flags */
|
||
int retstat = 0; /* the return status */
|
||
int stat; /* status returned from open request */
|
||
char *string; /* file pathname buffer pointer */
|
||
float fsize; /* file size - dbs */
|
||
|
||
ENTER(spopen);
|
||
|
||
/* identify mode value */
|
||
if ((direction = get_mode(mode)) == -1) goto src_err;
|
||
|
||
page = CORRPAGE(file[C_PAGE]);
|
||
disp = file[C_DISP];
|
||
|
||
switch(ptype[page])
|
||
{
|
||
case STRTYPE*2: len = get_word(page, disp+1);
|
||
if (len < 0) /* Adjust for small string */
|
||
len = len + BLK_OVHD;
|
||
else
|
||
len = len - BLK_OVHD;
|
||
|
||
if (!(string = getmem(len+1))) getmem_error(rtn_name);
|
||
get_str(string, page, disp);
|
||
string[len] = '\0';
|
||
for (i=0; i<len; i++)
|
||
string[i] = toupper(string[i]);
|
||
switch (direction)
|
||
{
|
||
case READ: if ((stat = zopen(&handle,
|
||
string, direction,
|
||
&hsize,&lsize)))
|
||
{
|
||
open_error:
|
||
rlsstr(string);
|
||
/* Call to dos_err will not return */
|
||
stat += (IO_ERROR_START - 1);
|
||
dos_err(NON_RESTART,stat,file);
|
||
}
|
||
break;
|
||
case WRITE: if ((stat = zcreate(&handle, string)))
|
||
goto open_error;
|
||
/*
|
||
if (((stat = strcmp(string,"PRN")) == 0) ||
|
||
((stat = strcmp(string,"LST")) == 0))
|
||
prn_handle = handle;
|
||
*/
|
||
break;
|
||
case APPEND: if ((stat = zopen(&handle, string,
|
||
direction,&hsize,&lsize)) == FILE_NOT_FOUND)
|
||
{
|
||
if((stat = zcreate(&handle, string)))
|
||
goto open_error;
|
||
break;
|
||
}
|
||
if (stat) goto open_error;
|
||
/* do
|
||
{
|
||
if (zread(handle, buffer, &length))
|
||
break;
|
||
} while (length); */
|
||
if (((stat = strcmp(string,"PRN")) == 0) ||
|
||
((stat = strcmp(string,"LST")) == 0))
|
||
break;
|
||
mov_fptr(handle);
|
||
fsize = (hsize * 65536) + lsize;
|
||
}
|
||
mov_reg(tmp_reg, file); /* save pointer to filename */
|
||
alloc_block(file, PORTTYPE, WINDSIZE+BUFFSIZE);
|
||
page = CORRPAGE(file[C_PAGE]);
|
||
disp = file[C_DISP];
|
||
zero_blk(page, disp);
|
||
if (direction == WRITE)
|
||
put_word(page, disp+UL_LINE, 1);
|
||
else
|
||
if (direction == APPEND)
|
||
{ /* update the chunk# and buffer position */
|
||
i = fsize / 256;
|
||
put_word(page, disp+UL_LINE, i + 1);
|
||
i = fsize - (i * 256);
|
||
put_word(page, disp+BUF_POS, i);
|
||
direction = WRITE; /* unsets read flag - dbs */
|
||
}
|
||
put_word(page, disp+P_FLAGS, OPEN+direction);
|
||
put_word(page, disp+N_COLS, 80);
|
||
put_word(page, disp+HANDLE, handle);
|
||
put_word(page, disp+N_LINES, hsize);
|
||
put_word(page, disp+B_ATTRIB, lsize);
|
||
/* put pointer to pathname into port object */
|
||
put_ptr(page, disp+STR_PTR, tmp_page, tmp_disp);
|
||
rlsstr(string); /* release pathname buffer */
|
||
break;
|
||
|
||
case SYMTYPE*2: if (file[C_PAGE] != CON_PAGE ||
|
||
file[C_DISP] != CON_DISP) goto src_err;
|
||
break;
|
||
|
||
case PORTTYPE*2: p_flags = get_word(page, disp+P_FLAGS);
|
||
if (p_flags & OPEN) break;
|
||
|
||
src_err:
|
||
default: set_src_err("OPEN-PORT", 2, file, mode);
|
||
retstat = -1;
|
||
} /* end: switch(ptype[page]) */
|
||
end_of_function:
|
||
return(retstat);
|
||
} /* end of function: spopen(file, mode) */
|
||
|
||
/************************************************************************/
|
||
/* Close a Port */
|
||
/************************************************************************/
|
||
spclose(port)
|
||
int port[2]; /* register containing port pointer */
|
||
{
|
||
int page; /* page number component of a pointer */
|
||
int p_flags; /* port flags */
|
||
int retstat = 0; /* the return status */
|
||
int stat; /* status returned from open request */
|
||
|
||
static int err_code[2] = {0, SPECFIX*2}; /* close error status */
|
||
|
||
if (!get_port(port, 0))
|
||
{
|
||
page = CORRPAGE(tmp_page);
|
||
p_flags = get_word(page, tmp_disp+P_FLAGS);
|
||
if (p_flags & OPEN && !(p_flags & WINDOW))
|
||
{
|
||
/***** write EOF to file before closing *****/
|
||
stat = 0x1A; /* ascii code of EOF character */
|
||
retstat = 1; /* number of bytes to write */
|
||
|
||
if ((p_flags & WRITE) || (p_flags & READ_WRITE))
|
||
if ((stat = zwrite(get_word(page,tmp_disp+HANDLE),&stat,&retstat)))
|
||
{
|
||
stat += (IO_ERROR_START - 1);
|
||
goto io_err;
|
||
}
|
||
|
||
if ((stat = zclose(get_word(page, tmp_disp+HANDLE))))
|
||
{
|
||
stat += (IO_ERROR_START - 1);
|
||
io_err:
|
||
/* We will not return from dos_err */
|
||
dos_err(NON_RESTART,stat,port);
|
||
}
|
||
put_word(page, tmp_disp+P_FLAGS, p_flags & (! OPEN));
|
||
put_word(page, tmp_disp+BUF_POS, BUFFSIZE);
|
||
}
|
||
}
|
||
else
|
||
{
|
||
set_src_err("CLOSE-PORT", 1, port);
|
||
retstat = -1;
|
||
}
|
||
return(retstat);
|
||
} /* end of function: spclose(port) */
|
||
|
||
/************************************************************************/
|
||
/* Local Support: Determine Input/Output Mode Value */
|
||
/************************************************************************/
|
||
get_mode(reg, in_or_out)
|
||
int reg[2]; /* mode register ('read, 'write, 'append) */
|
||
int in_or_out; /* 0 = input, 1 = output */
|
||
{
|
||
if (ptype[CORRPAGE(reg[C_PAGE])] == SYMTYPE*2)
|
||
{
|
||
intern(tmp_reg, "READ", 4);
|
||
if (tmp_disp == reg[C_DISP] && tmp_page == reg[C_PAGE]) return(0);
|
||
intern(tmp_reg, "WRITE", 5);
|
||
if (tmp_disp == reg[C_DISP] && tmp_page == reg[C_PAGE]) return(1);
|
||
intern(tmp_reg, "APPEND", 6);
|
||
if (tmp_disp == reg[C_DISP] && tmp_page == reg[C_PAGE]) return(2);
|
||
}
|
||
return(-1);
|
||
} /* end of function: get_mode(reg, in_or_out) */
|
||
|
||
/************************************************************************/
|
||
/* Clear Window */
|
||
/************************************************************************/
|
||
clear_window(reg)
|
||
int reg[2]; /* register containing port pointer */
|
||
{
|
||
int b_attrib; /* border attributes */
|
||
int disp; /* displacement component of a pointer */
|
||
int n_cols; /* number of columns in the window */
|
||
int n_lines; /* number of lines in the window */
|
||
int page; /* page number component of a pointer */
|
||
int retstat = 0; /* the return status */
|
||
char *string; /* buffer pointer for label's text */
|
||
int t_attrib; /* text attributes */
|
||
int ul_col; /* upper left corner's column number */
|
||
int ul_line; /* upper left corner's line number */
|
||
|
||
char *string_asciz(); /* fetches characters of a string */
|
||
|
||
ENTER(clear_window);
|
||
|
||
get_port(reg,0);
|
||
page = CORRPAGE(tmp_page);
|
||
disp = tmp_disp;
|
||
if (ptype[page] == PORTTYPE*2 &&
|
||
get_byte(page, disp+P_FLAGS) & WINDOW)
|
||
{
|
||
pt_flds4(tmp_reg, &ul_line, &ul_col, &n_lines, &n_cols);
|
||
t_attrib = get_word(page, disp+T_ATTRIB);
|
||
b_attrib = get_word(page, disp+B_ATTRIB);
|
||
zclear(ul_line, ul_col, n_lines, n_cols, t_attrib);
|
||
if (b_attrib != -1)
|
||
{
|
||
tmp_page = get_byte(page, disp+STR_PTR);
|
||
tmp_disp = get_word(page, disp+STR_PTR+1);
|
||
string = string_asciz(tmp_reg);
|
||
zborder(ul_line, ul_col, n_lines, n_cols, b_attrib, string);
|
||
rlsstr(string);
|
||
}
|
||
/* put the cursor in the "home" position (upper left hand corner) */
|
||
put_word(page, disp+CUR_LINE, 0);
|
||
put_word(page, disp+CUR_COL, 0);
|
||
}
|
||
else
|
||
{
|
||
set_src_err("WINDOW-CLEAR", 1, reg);
|
||
retstat = -1;
|
||
}
|
||
return(retstat);
|
||
} /* end of function: clear_window(reg) */
|
||
|
||
/***************************************************************/
|
||
/* PRINTFLO(f) */
|
||
/* Given a double-length floating-point number, this */
|
||
/* procedure formats and prints the ASCII representation of */
|
||
/* the number. */
|
||
/***************************************************************/
|
||
printflo(f)
|
||
double f;
|
||
{
|
||
char buf[32];
|
||
printtxt(buf, makeflo(f,buf,0,outrange(f)));
|
||
}
|
||
|
||
/***************************************************************/
|
||
/* OUTRANGE(f) */
|
||
/* Returns a non-zero value if the value of the given */
|
||
/* flonum F is not "close" to 1, zero otherwise. */
|
||
/***************************************************************/
|
||
outrange(f)
|
||
double f;
|
||
{
|
||
if (f<0) f = -f;
|
||
return((f<1.0e-3) || (f>=1.0e7));
|
||
}
|
||
|
||
/***************************************************************/
|
||
/* MAKEFLO(flo,buf,prec,ex) */
|
||
/* Takes a flonum FLO and converts it to a human-readable */
|
||
/* form, storing the characters in the buffer BUF. PREC */
|
||
/* specifies the number of decimal places to be used (as many */
|
||
/* as necessary, up to a maximum, if PREC is 0) and EX */
|
||
/* specifies whether to use exponential (if nonzero) or fixed- */
|
||
/* decimal format. MAKEFLO returns the number of characters */
|
||
/* placed in BUF, and BUF should be at least 32 bytes. */
|
||
/***************************************************************/
|
||
makeflo(flo,buf,prec,ex)
|
||
double flo;
|
||
char *buf;
|
||
int prec,ex;
|
||
{
|
||
char digits[32];
|
||
int scl = 0;
|
||
if (flo==0.0)
|
||
{
|
||
*digits='0'; ex=0;
|
||
}
|
||
else
|
||
{
|
||
scale(&flo,&scl);
|
||
flo2big(flo*1.0e15,buf);
|
||
big2asc(buf,digits);
|
||
}
|
||
return(formflo(digits,buf,scl,prec,ex));
|
||
}
|
||
|
||
/***************************************************************/
|
||
/* SCALE(&flo,&x) */
|
||
/* Given a pointer FLO to a double-length flonum and a */
|
||
/* pointer X to an integer, SCALE puts at those two locations */
|
||
/* a new flonum and integer such that FLO equals the new */
|
||
/* flonum times 10 to the integer's power and the new flonum */
|
||
/* is in the interval [ 1.0, 10.0 ). */
|
||
/***************************************************************/
|
||
scale(flo,x)
|
||
double *flo;
|
||
int *x;
|
||
{
|
||
double local;
|
||
double squar = 10.0;
|
||
double tensquar[9];
|
||
int scale,wassmall,i;
|
||
scale = wassmall = i = 0;
|
||
local = ((*flo>0) ? *flo : -*flo);
|
||
if (local == 0)
|
||
*x = 0;
|
||
else
|
||
{
|
||
if (local < 1.0)
|
||
{
|
||
wassmall = -1;
|
||
local = 1.0/local;
|
||
}
|
||
tensquar[0] = 10.0;
|
||
while (++i<9)
|
||
{
|
||
squar *= squar;
|
||
tensquar[i] = squar;
|
||
}
|
||
while (--i>=0)
|
||
{
|
||
scale <<=1;
|
||
if (local>=tensquar[i])
|
||
{
|
||
local /= tensquar[i];
|
||
scale++;
|
||
}
|
||
}
|
||
if (wassmall)
|
||
{
|
||
scale = -scale;
|
||
local = 1.0/local;
|
||
if (local!=1.0)
|
||
{
|
||
local *= 10;
|
||
scale--;
|
||
}
|
||
}
|
||
*x = scale;
|
||
*flo = ((*flo < 0.0) ? -local : local);
|
||
}
|
||
}
|
||
|
||
/**************************************************************/
|
||
/* SCANFLO(s,flo,base) */
|
||
/* The string S, which ends in a control char, holds a */
|
||
/* representation of a floating-point number. The value of */
|
||
/* this number is stored in *FLO. */
|
||
/**************************************************************/
|
||
scanflo(s,flo,base)
|
||
char *s;
|
||
double *flo;
|
||
int base;
|
||
{
|
||
int i=0;
|
||
int neg=0;
|
||
int x=0;
|
||
double place;
|
||
switch (*s)
|
||
{
|
||
case '-': neg=-1;
|
||
case '+': i++; break;
|
||
default: break;
|
||
}
|
||
while (s[i]=='#') i+=2;
|
||
*flo = 0.0;
|
||
while (isdig(s[i],base))
|
||
{
|
||
*flo = (*flo * base) + digval(s[i++]);
|
||
}
|
||
if (!(s[i]==decpoint)) goto EXPON;
|
||
POINT:
|
||
i++; place = 1.0;
|
||
while (isdig(s[i],base))
|
||
{
|
||
place /= base;
|
||
*flo += place*digval(s[i++]);
|
||
}
|
||
if (s[i]<' ') goto GOTFLO;
|
||
EXPON:
|
||
i++;
|
||
if (s[i]=='-')
|
||
{
|
||
i++; place = 1.0/base;
|
||
}
|
||
else place=base;
|
||
while (isdigit(s[i]))
|
||
x = (x*10) + digval(s[i++]);
|
||
while (x)
|
||
{
|
||
if (x!=(x>>1)<<1)
|
||
*flo *= place;
|
||
if (place<1.0e153) place*=place;
|
||
x >>= 1;
|
||
}
|
||
GOTFLO:
|
||
if (neg)
|
||
*flo = -*flo;
|
||
}
|
||
|
||
|
||
/**************************************************************/
|
||
/* ALLOC_INT(reg,buf) */
|
||
/* This allocates an integer, either a fixnum or a */
|
||
/* bignum, depending on the size of the integer, i.e., if */
|
||
/* the absolute value < 16384, then a fixnum is allocated. */
|
||
/* The value is read from BUF. */
|
||
/**************************************************************/
|
||
alloc_int(reg,buf)
|
||
int reg[2];
|
||
char *buf;
|
||
{
|
||
unsigned i,j;
|
||
int pg;
|
||
i = 256*buf[1] + buf[0];
|
||
j = 256*buf[4] + buf[3];
|
||
pg = buf[2] & 1;
|
||
if ((i == 1) && (j <= 16383+pg)) /* If fixnum */
|
||
alloc_fixnum(reg, (pg ? -j : j));
|
||
else
|
||
{
|
||
alloc_block(reg, BIGTYPE, 2*i + 1);
|
||
toblock(reg, 3, buf+2, 2*i +1);
|
||
}
|
||
}
|
||
|
||
/************************************************************************/
|
||
/* Write "GC On"Message to the who-line */
|
||
/************************************************************************/
|
||
gc_on()
|
||
{
|
||
int lcl_reg[2];
|
||
char *text;
|
||
char *string_asciz();
|
||
|
||
GC_ING = 1;
|
||
|
||
intern(lcl_reg, "PCS-GC-MESSAGE", 14);
|
||
if (sym_lookup (lcl_reg, GNV_reg) &&
|
||
(text = string_asciz(lcl_reg)))
|
||
{
|
||
who_write("\n");
|
||
who_write(text);
|
||
rlsstr(text);
|
||
}
|
||
else
|
||
{
|
||
who_write("\n * Garbage Collecting *");
|
||
}
|
||
} /* end of function: gc_on() */
|
||
|
||
/************************************************************************/
|
||
/* Un-Write "GC On"Message to the who-line */
|
||
/************************************************************************/
|
||
gc_off()
|
||
{
|
||
|
||
GC_ING = 0;
|
||
|
||
who_clear();
|
||
} /* end of function: gc_off() */
|
||
|