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

543 lines
20 KiB
C
Raw Normal View History

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