401 lines
14 KiB
C
401 lines
14 KiB
C
/* =====> SFASL.C */
|
||
/* TIPC Scheme '84 Runtime Support - Fast Loader
|
||
(C) Copyright 1984,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: 28 December 1984
|
||
Last Modification: 18 October 1985
|
||
*/
|
||
#include "stdio.h"
|
||
#include "scheme.h"
|
||
#include "slist.h"
|
||
|
||
#define skip_space() while(isspace(sgetc()));
|
||
|
||
/* data structures to control file access */
|
||
#define NUM_FILES 4 /* the maximum recursion of "%fasl" operations */
|
||
#define BUF_LENGTH 4096 /* buffer length for fasl files */
|
||
#define READ 0 /* file access code for "read" */
|
||
#define CTL_Z 0x1A /* MS-DOS end-of-file character */
|
||
static char *buffer; /* character string buffer */
|
||
static int ch = 0; /* the current character */
|
||
static int file_no = -1; /* the current file number */
|
||
static char *file_buffer[NUM_FILES] = {0,0,0,0}; /* character buffers */
|
||
static int file_handle[NUM_FILES] = {0,0,0,0}; /* handles for open files */
|
||
static char *file_pos[NUM_FILES] = {0,0,0,0}; /* current position in buffer */
|
||
static int file_end[NUM_FILES] = {0,0,0,0}; /* end of buffer */
|
||
|
||
static char *f_pos = NULL;
|
||
static char *f_end = NULL;
|
||
|
||
static int zeros[3] = {0,0,0};
|
||
|
||
char *getmem(); /* Lattice C's memory allocation routine */
|
||
|
||
/************************************************************************/
|
||
/* Read In a Fast Load Format Object Module */
|
||
/************************************************************************/
|
||
fasl(reg)
|
||
int reg[2]; /* parameter register */
|
||
{
|
||
char lcl_buffer[256]; /* character string buffer */
|
||
int codebytes; /* the number of codebytes in a code block */
|
||
int constants; /* the number of constants in a code block */
|
||
int disp; /* displacement portion of a pointer */
|
||
int i; /* index variable */
|
||
int len; /* length of a character string or symbol */
|
||
int page; /* page number portion of a pointer */
|
||
int retstat = 0; /* the return code */
|
||
int type; /* type code for parameter pointer */
|
||
int dummy; /* dummy variable for zopen - dbs */
|
||
|
||
static max_nest[2] = {NUM_FILES, SPECFIX*2}; /* maximum FSL nesting level */
|
||
|
||
ENTER (sfasl);
|
||
|
||
buffer = lcl_buffer;
|
||
page = CORRPAGE(reg[C_PAGE]);
|
||
disp = reg[C_DISP];
|
||
type = ptype[page];
|
||
|
||
if (type == STRTYPE*2)
|
||
{
|
||
if(file_no >= NUM_FILES-1)
|
||
{
|
||
set_error(1, "FAST-LOAD nesting too deep. Maximum is", max_nest);
|
||
retstat = -1;
|
||
goto return_eof;
|
||
}
|
||
len = get_word(page,disp+1);
|
||
if (len < 0)
|
||
len = len + BLK_OVHD;
|
||
else
|
||
len = len - BLK_OVHD;
|
||
get_str(buffer, page, disp);
|
||
buffer[len] = '\0';
|
||
file_no++;
|
||
if ((i = zopen(&file_handle[file_no], buffer, READ, &dummy, &dummy)))
|
||
{
|
||
/* alloc_string(tmp_reg, buffer); */
|
||
/* set_error(0, "Unable to open FAST-LOAD file", tmp_reg); */
|
||
/* retstat = -1; */
|
||
/* file_no--; */
|
||
/* goto return_eof; */
|
||
|
||
/* Call to dos_err will not return */
|
||
i += IO_ERROR_START;
|
||
alloc_string(tmp_reg, buffer);
|
||
dos_err(1,i,tmp_reg);
|
||
}
|
||
if (!(file_pos[file_no] = (file_buffer[file_no] =
|
||
getmem(BUF_LENGTH)))) getmem_error(rtn_name);
|
||
file_end[file_no] = 0;
|
||
}
|
||
|
||
f_pos = file_pos[file_no];
|
||
f_end = file_buffer[file_no] + (file_end[file_no]);
|
||
|
||
ASSERT (file_no >= 0 /* make sure file exists */);
|
||
|
||
/* read and validate fasl program header; get # constants and codebytes */
|
||
skip_space();
|
||
while (ch == '#')
|
||
{
|
||
for (i = 0; i < 11; i++)
|
||
if (sgetc() != "!fast-load "[i]) goto invalid_fasl;
|
||
while (sgetc() != '\n') /* do nothing */ ;
|
||
skip_space();
|
||
}
|
||
if (ch == EOF || ch == CTL_Z) goto close_file;
|
||
if (ch != 'h') goto invalid_fasl;
|
||
constants = next_word();
|
||
codebytes = next_word();
|
||
|
||
/* allocate and zero the code block */
|
||
alloc_block(reg, CODETYPE, constants*PTRSIZE + PTRSIZE + codebytes);
|
||
page = CORRPAGE(reg[C_PAGE]);
|
||
disp = reg[C_DISP];
|
||
zero_blk(page, disp);
|
||
disp += BLK_OVHD;
|
||
|
||
/* insert the entry point offset */
|
||
put_ptr(page, disp, SPECFIX*2, constants*PTRSIZE + PTRSIZE +BLK_OVHD);
|
||
|
||
/* process the constants list entries */
|
||
disp = PTRSIZE + BLK_OVHD;
|
||
while (constants--)
|
||
{
|
||
if (read_constant()) goto invalid_fasl;
|
||
put_ptr(CORRPAGE(reg[C_PAGE]), reg[C_DISP]+disp, tmp_page, tmp_disp);
|
||
disp += PTRSIZE;
|
||
} /* end: while (constants--) */
|
||
|
||
/* validate the "text" portion header and read in bytecodes */
|
||
skip_space();
|
||
if (ch != 't') goto invalid_fasl;
|
||
zap_chars(reg, disp, codebytes);
|
||
|
||
/* validate the fasl module trailer */
|
||
skip_space();
|
||
if (ch == 'z')
|
||
{
|
||
file_pos[file_no] = f_pos;
|
||
goto end_of_function;
|
||
}
|
||
|
||
invalid_fasl:
|
||
set_error(0, "Invalid FAST-LOAD module", nil_reg);
|
||
retstat = -1;
|
||
|
||
close_file:
|
||
zclose(file_handle[file_no]);
|
||
if (rlsmem(file_buffer[file_no], BUF_LENGTH))
|
||
rlsmem_error(rtn_name);
|
||
file_no--;
|
||
return_eof:
|
||
reg[C_PAGE] = EOF_PAGE*2;
|
||
reg[C_DISP] = EOF_DISP;
|
||
|
||
end_of_function:
|
||
return(retstat);
|
||
} /* end of function: fasl(reg) */
|
||
|
||
/************************************************************************/
|
||
/* Read In a Constant Entry */
|
||
/************************************************************************/
|
||
read_constant()
|
||
{
|
||
int disp; /* displacement component of a pointer */
|
||
int i; /* index variable */
|
||
int len; /* length of a string or symbol */
|
||
int lpage=0; /* page number for a list cell */
|
||
int page; /* page number component of a pointer */
|
||
|
||
double next_flonum(); /* reads a flonum from the input file */
|
||
|
||
tail_recursion:
|
||
skip_space();
|
||
switch(ch)
|
||
{
|
||
case 'x': /* symbol */
|
||
len = next_byte();
|
||
for (i = 0; i < len; i++) buffer[i] = sgetc();
|
||
intern(tmp_reg, buffer, len);
|
||
break;
|
||
|
||
case 'i': /* short integer constant */
|
||
tmp_page = SPECFIX*2;
|
||
tmp_disp = next_word();
|
||
break;
|
||
|
||
case 'l': /* list cell */
|
||
if (nextcell[listpage] != END_LIST)
|
||
{
|
||
tmp_page = ADJPAGE(listpage);
|
||
tmp_disp = nextcell[listpage];
|
||
nextcell[listpage] = get_word(listpage, tmp_disp+1);
|
||
}
|
||
else
|
||
alloc_list_cell(tmp_reg);
|
||
toblock(tmp_reg, 0, zeros, LISTSIZE);
|
||
if (lpage)
|
||
{ /* we're building a linked list-- update previous cdr */
|
||
C_pop(tm2_reg);
|
||
put_ptr((lpage=CORRPAGE(tm2_page)), tm2_disp+3, tmp_page,
|
||
tmp_disp);
|
||
}
|
||
else
|
||
{ /* starting a list-- preserve list header pointer */
|
||
C_push(tmp_reg);
|
||
}
|
||
C_push(tmp_reg); /* record this list cell's location */
|
||
if (stkspc() < 64)
|
||
{
|
||
stk_ovfl:
|
||
printf("\n[VM ERROR encountered!] PC stack overflow during FAST-LOAD\n%s%s",
|
||
"Attempting to execute SCHEME-RESET\n",
|
||
"[Returning to top level]\n");
|
||
force_reset();
|
||
}
|
||
read_constant();
|
||
/*********
|
||
C_pop(tm2_reg); /* restore current list cell pointer */
|
||
C_push(tm2_reg); /* save for next iteration */
|
||
**********/
|
||
put_ptr((lpage=CORRPAGE((int) S_stack[TOS])),
|
||
*((int *) (S_stack+TOS+1)), tmp_page, tmp_disp);
|
||
goto tail_recursion;
|
||
|
||
case 'n': /* null pointer */
|
||
tmp_page = tmp_disp = 0;
|
||
break;
|
||
|
||
case 's': /* string constant */
|
||
len = next_word();
|
||
alloc_block(tmp_reg, STRTYPE, len);
|
||
zap_chars(tmp_reg, 3, len);
|
||
break;
|
||
|
||
case 'c': /* character constant */
|
||
tmp_page = SPECCHAR*2;
|
||
tmp_disp = next_byte();
|
||
break;
|
||
|
||
case 'b': /* bignum constant */
|
||
len = next_byte();
|
||
alloc_block(tmp_reg, BIGTYPE, len+len+1);
|
||
page = CORRPAGE(tmp_page);
|
||
disp = tmp_disp + BLK_OVHD;
|
||
put_byte(page, disp++, next_byte());
|
||
while (len--)
|
||
{
|
||
put_word(page, disp, next_word());
|
||
disp += WORDINCR;
|
||
}
|
||
break;
|
||
|
||
case 'f': /* flonum constant */
|
||
alloc_flonum(tmp_reg, next_flonum());
|
||
break;
|
||
|
||
case 'v': /* vector */
|
||
len = next_word();
|
||
alloc_block(tm2_reg, VECTTYPE, len+len+len);
|
||
zero_blk(CORRPAGE(tm2_page),tm2_disp);
|
||
if (stkspc() < 64) goto stk_ovfl;
|
||
for (i = 0, disp = BLK_OVHD; i < len; i++, disp += PTRSIZE)
|
||
{
|
||
C_push(tm2_reg); /* save pointer to vector object */
|
||
read_constant(); /* read next vector entry */
|
||
C_pop(tm2_reg); /* restore pointer to vector object */
|
||
put_ptr(CORRPAGE(tm2_page), tm2_disp+disp, tmp_page, tmp_disp);
|
||
} /* end: for (i = 0, etc.) */
|
||
mov_reg(tmp_reg, tm2_reg);
|
||
break;
|
||
|
||
default: /* error-- unexpected constant tag */
|
||
/* printf("read_constant: invalid constant tag '%c'\n", ch); */
|
||
return(1);
|
||
|
||
} /* end: switch(ch) */
|
||
|
||
/* if we're filling in the last cdr field of a linked list, fix it up */
|
||
if (lpage)
|
||
{
|
||
C_pop(tm2_reg);
|
||
put_ptr(CORRPAGE(tm2_page), tm2_disp+3, tmp_page, tmp_disp);
|
||
C_pop(tmp_reg); /* restore list header pointer */
|
||
}
|
||
return(0);
|
||
} /* end of function: read_constant() */
|
||
|
||
|
||
/************************************************************************/
|
||
/* Read In a Hexadecimal Byte */
|
||
/************************************************************************/
|
||
static int low_digit[23] = {0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,
|
||
-1,-1,-1,-1,-1,-1,-1,
|
||
0x0A,0x0B,0x0C,0x0D,0x0E,0x0F};
|
||
static int high_digit[23] = {0x00,0x10,0x20,0x30,0x40,0x50,0x60,0x70,0x80,0x90,
|
||
-1,-1,-1,-1,-1,-1,-1,
|
||
0xA0,0xB0,0xC0,0xD0,0xE0,0xF0};
|
||
next_byte()
|
||
{
|
||
int value;
|
||
skip_space();
|
||
return(high_digit[ch - '0'] + low_digit[sgetc() - '0']);
|
||
} /* end of function: next_byte() */
|
||
|
||
/************************************************************************/
|
||
/* Read In a Hexadecimal Word */
|
||
/************************************************************************/
|
||
next_word()
|
||
{
|
||
int value;
|
||
value = next_byte() << 8;
|
||
return(value | next_byte());
|
||
} /* end of function: next_word() */
|
||
|
||
/************************************************************************/
|
||
/* Read In a Floating Point Value */
|
||
/************************************************************************/
|
||
double next_flonum()
|
||
{
|
||
int flo_parts[4]; /* "words" comprising a floating point value */
|
||
int i; /* index variable */
|
||
|
||
/* read in the four words comprising a floating point constant */
|
||
for (i = 0; i < 4; i++)
|
||
flo_parts[i] = next_word();
|
||
|
||
/* convert "parts" of floating point value to a true floating point number */
|
||
return(*((double *) flo_parts));
|
||
} /* end of function: next_flonum() */
|
||
|
||
/************************************************************************/
|
||
/* Read Character From Current Input File */
|
||
/************************************************************************/
|
||
sgetc()
|
||
{
|
||
int stat; /* status returned from read */
|
||
if (f_pos >= f_end)
|
||
{
|
||
file_end[file_no] = BUF_LENGTH;
|
||
if((stat = zread(file_handle[file_no], file_buffer[file_no],
|
||
&file_end[file_no])))
|
||
{
|
||
printf("[VM INTERNAL ERROR] sfasl: read error status=%d\n", stat);
|
||
}
|
||
if ((f_pos = file_buffer[file_no]) >= (f_end = f_pos + file_end[file_no]))
|
||
{
|
||
return((ch = EOF));
|
||
}
|
||
}
|
||
return((ch = *f_pos++));
|
||
} /* end of function: sgetc() */
|
||
|
||
/************************************************************************/
|
||
/* Copy Block of Characters from Input Buffer to Scheme Block */
|
||
/************************************************************************/
|
||
zap_chars(ptr, offset, len)
|
||
int ptr[2]; /* register holding pointer to Scheme Block */
|
||
int offset; /* beginning offset into the Scheme Block */
|
||
int len; /* the number of characters to transfer */
|
||
{
|
||
int actual; /* the number of characters transfered in one move */
|
||
|
||
while (len)
|
||
{
|
||
if (f_pos >= f_end)
|
||
{
|
||
sgetc();
|
||
f_pos--;
|
||
}
|
||
actual = f_end - f_pos;
|
||
if (len < actual) actual = len;
|
||
toblock(ptr, offset, f_pos, actual);
|
||
len -= actual;
|
||
offset += actual;
|
||
f_pos += actual;
|
||
} /* end: while (len) */
|
||
} /* end of function: zap_chars(ptr, offset, len) */
|
||
|
||
/************************************************************************/
|
||
/* Reset Fasl Data Structures */
|
||
/************************************************************************/
|
||
reset_fasl()
|
||
{
|
||
while (file_no >= 0)
|
||
{
|
||
zclose(file_handle[file_no]);
|
||
if (rlsmem(file_buffer[file_no], BUF_LENGTH))
|
||
rlsmem_error("reset_fasl");
|
||
file_no--;
|
||
} /* end: while (file_no >= 0) */
|
||
} /* end of function: reset_fasl() */
|
||
|