543 lines
20 KiB
C
543 lines
20 KiB
C
/* =====> SUPPORT.C */
|
||
/* TIPC Scheme '84 Runtime Support - Non-Arithmetic Support
|
||
(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: 24 May 1984
|
||
Last Modification: 21 October 1985
|
||
*/
|
||
#include "scheme.h"
|
||
#include "slist.h"
|
||
|
||
char *getmem(); /* Lattice C's memory allocation routine */
|
||
|
||
/**********************************************************************/
|
||
/* Substring */
|
||
/**********************************************************************/
|
||
ssubstr(string, start_reg, end_reg)
|
||
int string[2]; /* register containing string pointer */
|
||
int start_reg[2]; /* register containing starting character position */
|
||
int end_reg[2]; /* register containing ending character position */
|
||
{
|
||
int end; /* ending character position */
|
||
int start; /* starting character position */
|
||
int str_page, str_disp;/* string's page and displacement pointers */
|
||
int i;
|
||
|
||
str_page = CORRPAGE(string[C_PAGE]);
|
||
str_disp = string[C_DISP];
|
||
|
||
/* validate input arguments */
|
||
i = get_word(str_page,str_disp+1);
|
||
if (i < 0)
|
||
i = i + BLK_OVHD + PTRSIZE; /* adjust for small string */
|
||
if (ptype[str_page] == STRTYPE*2 &&
|
||
start_reg[C_PAGE] == SPECFIX*2 &&
|
||
end_reg[C_PAGE] == SPECFIX*2 &&
|
||
(start = get_fix(CORRPAGE(start_reg[C_PAGE]),start_reg[C_DISP])) >= 0 &&
|
||
(end = get_fix(CORRPAGE(end_reg[C_PAGE]),end_reg[C_DISP])) >= start &&
|
||
end <= i-BLK_OVHD)
|
||
{ /* arguments o.k.-- allocate new string and copy substring characters */
|
||
alloc_block(tmp_reg, STRTYPE, end-start);
|
||
msubstr(tmp_reg, string, start, end);
|
||
string[C_PAGE] = tmp_page;
|
||
string[C_DISP] = tmp_disp;
|
||
}
|
||
else
|
||
{ /* invalid arguments to substring */
|
||
set_src_err("SUBSTRING", 3, string, start_reg, end_reg);
|
||
return(-1);
|
||
}
|
||
return(0);
|
||
} /* end of function: ssubstr(string, start_reg, end_reg) */
|
||
|
||
|
||
/**********************************************************************/
|
||
/* Test if two pointers are equal? */
|
||
/**********************************************************************/
|
||
sequal_p(reg1, reg2)
|
||
int reg1[2], reg2[2];
|
||
{
|
||
int disp1,disp2; /* displacements of the two pointers */
|
||
int i; /* index & temporary variable */
|
||
int length; /* length of a variable length object */
|
||
int page1,page2; /* page numbers of the two pointers */
|
||
int result = FALSE; /* result of the comparison */
|
||
int temp_r1[2],temp_r2[2]; /* temporary "registers" for equal_p calls */
|
||
int type; /* type of the pointers being compared */
|
||
|
||
double get_flo(); /* fetch flonum from Scheme's memory */
|
||
|
||
/* Localize page and displacement values */
|
||
page1 = reg1[C_PAGE];
|
||
page2 = reg2[C_PAGE];
|
||
disp1 = reg1[C_DISP];
|
||
disp2 = reg2[C_DISP];
|
||
|
||
recurse:
|
||
/* Quick test in case the pointers are "eq?" */
|
||
if (disp1 == disp2 && page1 == page2) return(TRUE);
|
||
|
||
/* If pointer types are the same, check further */
|
||
if ((type = ptype[(page1 = CORRPAGE(page1)) ]) ==
|
||
ptype[(page2 = CORRPAGE(page2)) ] )
|
||
{
|
||
/* Check to see if shift-break key depressed */
|
||
if (s_break) restart(3);
|
||
/* Check to make sure we haven't recursed too deeply */
|
||
if (stkspc() < 64)
|
||
{
|
||
printf("[VM ERROR encountered!] Stack overflow in EQUAL?\n%s%s",
|
||
"Expression lists circular or too complex\n",
|
||
"Attempting to execute SCHEME-RESET\n[Returning to top level]");
|
||
force_reset();
|
||
/* note: control does not return here */
|
||
}
|
||
/* If okay, check the objects */
|
||
switch (type>>1)
|
||
{
|
||
case LISTTYPE: /* test if one pointer is nil */
|
||
if ((!page1 && page2) || (!page2 && page1))
|
||
return (FALSE);
|
||
ldreg(temp_r1, page1, disp1);
|
||
ldreg(temp_r2, page2, disp2);
|
||
/* test "equal?-ness" of "cars" */
|
||
if (sequal_p(temp_r1, temp_r2))
|
||
{
|
||
i = page1;
|
||
page1 = get_byte(i, disp1+3);
|
||
disp1 = get_word(i, disp1+4);
|
||
i = page2;
|
||
page2 = get_byte(i, disp2+3);
|
||
disp2 = get_word(i, disp2+4);
|
||
/* test "equal?-ness" of "cdrs" */
|
||
goto recurse;
|
||
}
|
||
break;
|
||
|
||
case FLOTYPE: result = (get_flo(page1, disp1) ==
|
||
get_flo(page2, disp2));
|
||
break;
|
||
case BIGTYPE:
|
||
case STRTYPE: /* Compare the objects */
|
||
result = mcmpstr(reg1, reg2);
|
||
break;
|
||
|
||
case ARYTYPE: /* test each entry of the arrays for equality */
|
||
if ((length = get_word(page1, disp1 + 1)) ==
|
||
get_word(page2, disp2 + 1) )
|
||
{
|
||
for (i = PTRSIZE; i < length; i += PTRSIZE)
|
||
{
|
||
disp1 += PTRSIZE;
|
||
ldreg(temp_r1, page1, disp1);
|
||
disp2 += PTRSIZE;
|
||
ldreg(temp_r2, page2, disp2);
|
||
/* test "equal?-ness" of vector elements */
|
||
if (!(result = sequal_p(temp_r1, temp_r2))) break;
|
||
}
|
||
}
|
||
break;
|
||
|
||
case FIXTYPE:
|
||
case CHARTYPE:
|
||
case SYMTYPE:
|
||
case CONTTYPE:
|
||
case CLOSTYPE:
|
||
case CODETYPE:
|
||
case PORTTYPE:
|
||
case ENVTYPE: /* For these types, assume that "eq?-ness" is o.k. */
|
||
break;
|
||
|
||
case REFTYPE:
|
||
case FREETYPE:
|
||
default: printf("[VM INTERNAL ERROR] EQUAL?: unexpected type=%d\n",type);
|
||
getch();
|
||
} /* end: switch (type>>1) */
|
||
}
|
||
return(result);
|
||
}
|
||
|
||
/************************************************************************/
|
||
/* String->Symbol */
|
||
/************************************************************************/
|
||
str_2_sym(reg)
|
||
int reg[2];
|
||
{
|
||
int page, disp, len;
|
||
char *string; /* pointer to character string */
|
||
ENTER(str_2_sym);
|
||
|
||
page = CORRPAGE(reg[C_PAGE]);
|
||
disp = reg[C_DISP];
|
||
if (ptype[page] != STRTYPE*2)
|
||
{
|
||
set_src_err("STRING->SYMBOL", 1, reg);
|
||
return(-1);
|
||
}
|
||
else
|
||
{
|
||
len = get_word(page, disp+1);
|
||
if (len < 0)
|
||
len = len + BLK_OVHD + PTRSIZE; /* adjust for small string */
|
||
len -= BLK_OVHD;
|
||
if (!(string = getmem(len+1))) getmem_error(rtn_name);
|
||
get_str(string, page, disp);
|
||
string[len] = '\0';
|
||
intern(reg, string, len);
|
||
rlsstr(string);
|
||
}
|
||
return(0);
|
||
} /* end of function: str_2_sym(reg) */
|
||
|
||
/************************************************************************/
|
||
/* String->Uninterned-symbol */
|
||
/************************************************************************/
|
||
str_2_usym(reg)
|
||
int reg[2];
|
||
{
|
||
int page, disp, len;
|
||
char *string; /* pointer to character string */
|
||
ENTER(str_2_usym);
|
||
|
||
page = CORRPAGE(reg[C_PAGE]);
|
||
disp = reg[C_DISP];
|
||
if (ptype[page] != STRTYPE*2)
|
||
{
|
||
set_src_err("STRING->UNINTERNED-SYMBOL", 1, reg);
|
||
return(-1);
|
||
}
|
||
else
|
||
{
|
||
len = get_word(page, disp+1);
|
||
if (len < 0)
|
||
len = len + BLK_OVHD + PTRSIZE; /* adjust for small string */
|
||
len -= BLK_OVHD;
|
||
if (!(string = getmem(len+1))) getmem_error(rtn_name);
|
||
get_str(string, page, disp);
|
||
string[len] = '\0';
|
||
alloc_sym(reg, len);
|
||
put_sym(string, CORRPAGE(reg[C_PAGE]), reg[C_DISP],NIL_PAGE*2,NIL_DISP,0);
|
||
rlsstr(string);
|
||
}
|
||
return(0);
|
||
} /* end of function: str_2_usym(reg) */
|
||
|
||
/************************************************************************/
|
||
/* Symbol->String */
|
||
/************************************************************************/
|
||
sym_2_str(reg)
|
||
int reg[2];
|
||
{
|
||
int page;
|
||
char *string; /* pointer to character string */
|
||
|
||
char *symbol_name(); /* retrieves symbol's print name */
|
||
|
||
ENTER(sym_2_str);
|
||
|
||
page = CORRPAGE(reg[C_PAGE]);
|
||
if (ptype[page] != SYMTYPE*2)
|
||
{
|
||
set_src_err("SYMBOL->STRING", 1, reg);
|
||
return(-1);
|
||
}
|
||
else
|
||
{
|
||
string = symbol_name(page, reg[C_DISP]);
|
||
alloc_string(reg, string);
|
||
rlsstr(string);
|
||
}
|
||
return(0);
|
||
} /* end of function: sym_2_str(reg) */
|
||
|
||
/************************************************************************/
|
||
/* Retrieve Symbol Name */
|
||
/* */
|
||
/* Purpose: To fetch the print name of a symbol from Scheme's memory */
|
||
/* and return it in a Lattice C string. */
|
||
/************************************************************************/
|
||
char *symbol_name(page,disp)
|
||
int page,disp; /* pointer to the string data type */
|
||
{
|
||
char *name = NULL;
|
||
int length; /* length of symbol + 1 (characters) */
|
||
ENTER(symbol_name);
|
||
|
||
if (ptype[page] == SYMTYPE*2)
|
||
{
|
||
length = get_word(page, disp+1) - (BLK_OVHD + PTRSIZE);
|
||
if (!(name = getmem(length))) getmem_error(rtn_name);
|
||
get_sym(name, page, disp);
|
||
name[length-1] = '\0';
|
||
}
|
||
return(name);
|
||
} /* end of function: char *symbol_name(page,disp) */
|
||
|
||
/************************************************************************/
|
||
/* Retrieve String Value */
|
||
/* */
|
||
/* Purpose: To fetch the value of a string from Scheme's memory */
|
||
/* and return it in a Lattice C string. */
|
||
/************************************************************************/
|
||
char *string_asciz(reg)
|
||
int reg[2]; /* register containing the string pointer */
|
||
{
|
||
char *name = NULL; /* ASCIZ string to be returned to caller */
|
||
int page,disp; /* page and displacement components of string pointer */
|
||
int length; /* length of string + 1 (characters) */
|
||
|
||
ENTER(string_asciz);
|
||
|
||
page = CORRPAGE(reg[C_PAGE]);
|
||
disp = reg[C_DISP];
|
||
|
||
if (ptype[page] == STRTYPE*2)
|
||
{
|
||
length = get_word(page, disp+1);
|
||
if (length < 0)
|
||
length = length + BLK_OVHD + PTRSIZE; /* adjust for small string */
|
||
length = length - BLK_OVHD + 1;
|
||
if (!(name = getmem(length))) getmem_error(rtn_name);
|
||
get_str(name, page, disp);
|
||
name[length-1] = '\0';
|
||
}
|
||
return(name);
|
||
} /* end of function: char *string_asciz(reg) */
|
||
|
||
/************************************************************************/
|
||
/* Release String */
|
||
/* */
|
||
/* Purpose: To release the memory allocated to a Lattice C character */
|
||
/* string. If the string is null, the rlsmem is skipped. */
|
||
/************************************************************************/
|
||
rlsstr(string)
|
||
char *string;
|
||
{
|
||
if (string) /* is the string allocated? */
|
||
{
|
||
if (rlsmem(string, strlen(string)+1)) /* release string's memory */
|
||
{
|
||
rlsmem_error("rlsstr"); /* if rlsmem error, print message */
|
||
}
|
||
}
|
||
} /* end of function: rlsstr(string) */
|
||
|
||
/************************************************************************/
|
||
/* Convert Scheme Integer to C Long Integer */
|
||
/* */
|
||
/* Purpose: To obtain the value of a Scheme integer (up to 32 bits) */
|
||
/* for manipulation by the Lattice C support routines. */
|
||
/* */
|
||
/* Description: Given a Scheme pointer to an integer value, this */
|
||
/* routine returns the long integer corresponding to */
|
||
/* the value of the Scheme integer. */
|
||
/* */
|
||
/* Calling Sequence: stat = int2long(value, ptr) */
|
||
/* where value - address of location where the long */
|
||
/* integer result is to be stored. */
|
||
/* ptr - a Scheme register address containing the */
|
||
/* Scheme representation of the integer */
|
||
/* value. */
|
||
/* stat - return code; 0 = no errors, value returned */
|
||
/* 1 = error, integer too large or ptr */
|
||
/* was not an integer. */
|
||
/************************************************************************/
|
||
int2long(v, reg)
|
||
long *v; /* pointer to location for long integer result */
|
||
int reg[2]; /* Scheme "register" containing the integer object */
|
||
{
|
||
int page; /* Page field of register */
|
||
|
||
page = CORRPAGE(reg[C_PAGE]);
|
||
switch (ptype[page])
|
||
{
|
||
case FIXTYPE*2: *v = get_fix(page, reg[C_DISP]);
|
||
return(0);
|
||
case BIGTYPE*2: return(ldlong(v, reg));
|
||
default: return(1); /* Invalid argument type */
|
||
} /* end: switch (ptype[page]) */
|
||
} /* end of function: int2long(value, reg) */
|
||
|
||
|
||
/************************************************************************/
|
||
/* Convert C Long Integer to Sheme Integer */
|
||
/* */
|
||
/* Purpose: To convert a Lattice C long integer value to the equivalent*/
|
||
/* Scheme representation. */
|
||
/* */
|
||
/* Description: Given a long integer value, this routine creates the */
|
||
/* equivalent Scheme integer object and returns it in the */
|
||
/* designated register. */
|
||
/* */
|
||
/* Calling Sequence: long2int(reg, value) */
|
||
/* where value - the Lattice C long integer value to be */
|
||
/* converted to Scheme representation */
|
||
/* reg - a Scheme register address to hold the */
|
||
/* result. */
|
||
/************************************************************************/
|
||
long2int(reg, value)
|
||
int reg[2]; /* Scheme register to hold the result */
|
||
long value; /* the Lattice C long integer value to be converted */
|
||
{
|
||
/* determine if value can be represented as a fixnum */
|
||
if (value <= 16383 && value >= -16384)
|
||
{
|
||
reg[C_PAGE] = SPECFIX*2;
|
||
reg[C_DISP] = value & 0x7fff;
|
||
}
|
||
else /* value is a bignum */
|
||
{
|
||
enlarge(reg,value);
|
||
}
|
||
} /* end of function: long2int(reg, value) */
|
||
|
||
|
||
/************************************************************************/
|
||
/* Append two lists */
|
||
/************************************************************************/
|
||
sappend(dest,src)
|
||
int dest[2]; /* Future result register */
|
||
int src[2]; /* List onto which to append */
|
||
{
|
||
int car[2]; /* Temporary car field pointer */
|
||
int saved = FALSE; /* Whether a list copy has been pushed */
|
||
|
||
C_push(src); C_push(src);
|
||
mov_reg(tm2_reg, dest); /* save destination operand, in case of error */
|
||
while (dest[C_PAGE] && ptype[CORRPAGE(dest[C_PAGE])]==LISTTYPE*2)
|
||
{
|
||
if (s_break) restart(3); /* shift-break? if so, start over */
|
||
car[C_PAGE] = dest[C_PAGE]; car[C_DISP] = dest[C_DISP];
|
||
take_car(car);
|
||
cons(src, car, nil_reg);
|
||
if (!saved)
|
||
{
|
||
C_push(src); saved = TRUE;
|
||
}
|
||
else
|
||
{
|
||
asetcdr(tmp_reg, src);
|
||
}
|
||
tmp_page = src[C_PAGE]; tmp_disp = src[C_DISP];
|
||
take_cdr(dest);
|
||
}
|
||
if (dest[C_PAGE])
|
||
{
|
||
if (saved) C_pop(src);
|
||
C_pop(src);
|
||
C_pop(src); /* Restore old SRC */
|
||
set_src_err("APPEND", 2, tm2_reg, src);
|
||
return(-1);
|
||
}
|
||
C_pop(dest);
|
||
if (saved)
|
||
{
|
||
C_pop(tmp_reg); /* Retrieve 2nd arg to append */
|
||
asetcdr(src, tmp_reg);
|
||
}
|
||
C_pop(src); /* Restore old SRC */
|
||
return(0);
|
||
}
|
||
|
||
/************************************************************************/
|
||
/* Get Current Time */
|
||
/************************************************************************/
|
||
ptime(reg)
|
||
int reg[2];
|
||
{
|
||
int i; /* the usual index variable */
|
||
int time[4]; /* array for result of get_time() call */
|
||
|
||
get_time(time); /* ask MS-DOS what time it is */
|
||
|
||
/* cons the hours, minutes, seconds, hundredths into a list */
|
||
tmp_page = SPECFIX*2; /* set tmp_reg's tag=fixnum */
|
||
reg[C_PAGE] = reg[C_DISP] = 0; /* set reg to nil */
|
||
for (i = 3; i >= 0; i--)
|
||
{
|
||
tmp_disp = time[i]; /* move in immediate (fixnum) */
|
||
cons(reg, tmp_reg, reg); /* append value to front of list */
|
||
}
|
||
} /* end of function: ptime(reg) */
|
||
|
||
/************************************************************************/
|
||
/* Start PCS Engine Timer */
|
||
/************************************************************************/
|
||
cset_tim(value)
|
||
int value[2]; /* number to place in timer */
|
||
{
|
||
long int result; /* temporary for long arith */
|
||
unsigned hi,lo; /* parts of 32-bit value for timer */
|
||
int pg,ds; /* page and displacement in register */
|
||
pg=CORRPAGE(value[C_PAGE]); ds=value[C_DISP];
|
||
hi = 0;
|
||
switch (ptype[pg]>>1)
|
||
{
|
||
case BIGTYPE: switch (get_word(pg,ds+1))
|
||
{
|
||
case 8: hi = get_word(pg,ds+6);
|
||
case 6: lo = get_word(pg,ds+4);
|
||
break;
|
||
default: hi = lo = 65535; break;
|
||
}
|
||
break;
|
||
case FIXTYPE: lo=ds; break;
|
||
default: set_src_err("%START-TIMER", 1, value);
|
||
}
|
||
#ifdef PROMEM
|
||
/* Multiply the number of ticks by 1000 to get the number of */
|
||
/* vm instructions to execute before timing out */
|
||
result = ((hi * 65536) + lo) * 1000;
|
||
lo = result & 0xffff;
|
||
hi = result / 65536l;
|
||
#endif
|
||
if (!settimer(hi,lo))
|
||
{
|
||
set_error(1, "Timer already running", nil_reg);
|
||
return(-1);
|
||
}
|
||
return(0);
|
||
}
|
||
|
||
/************************************************************************/
|
||
/* Stop PCS Engine Timer and Return Value */
|
||
/************************************************************************/
|
||
crst_tim(value)
|
||
int value[2];
|
||
{
|
||
long int rsttimer(); /* RSTTIMER returns a long int value */
|
||
long int result; /* and puts it here */
|
||
unsigned hi,lo; /* where it is broken into these pieces */
|
||
int pg,ds; /* Page, displacement of new number */
|
||
#ifdef PROMEM
|
||
/* divide number of vm instructions remaining by 1000 to get the */
|
||
/* number of engine ticks remaining */
|
||
result = rsttimer() / 1000;
|
||
#else
|
||
result = rsttimer();
|
||
#endif
|
||
lo = result & 0xffff;
|
||
hi = result / 65536l;
|
||
if ((!hi) && (lo<16384)) alloc_fixnum(value,lo);
|
||
else
|
||
{
|
||
alloc_block(value, BIGTYPE, (hi? 5 : 3));
|
||
pg = CORRPAGE(value[C_PAGE]);
|
||
ds = value[C_DISP]+3;
|
||
put_byte(pg, ds++, 0); /* Positive sign */
|
||
put_word(pg, ds++, lo);
|
||
if (hi)
|
||
{
|
||
ds++; put_word(pg, ds, hi);
|
||
}
|
||
}
|
||
return(0);
|
||
}
|
||
|
||
|