conservatory
/
pcs
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
pcs/prociosp.c

552 lines
17 KiB
C
Raw Permalink Normal View History

Unpack disk4.tgz
2023-05-20 05:57:06 -04:00
/* =====> 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() */