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

330 lines
12 KiB
C
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/* =====> SERROR.C */
/* TIPC Scheme '84 Runtime Support - Error Processors
(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: 13 June 1984
Last Modification:
(tc) 05 June 1986 - Set or Ref of Fluid variable which is not
defined in fluid environment is now non-
restartable from error processor or inspector.
(rb) 21 Jan 1988 - getmem errors return to Scheme toplevel rather
than aborting to DOS
(tc) 16 Feb 1988 - added PRO_ERROR routine for protected mode
*/
#include "ctype.h"
#include "scheme.h"
#include "slist.h"
static char digits[10]={'0','1','2','3','4','5','6','7','8','9'};
static char bdigits[10]={' ','1','2','3','4','5','6','7','8','9'};
/************************************************************************/
/* Wrong Number of Arguments to a Closure */
/************************************************************************/
#define NUM_ARGS 16 /* offset of operand count in a closure object */
wrong_args(args_passed, closure)
int args_passed; /* number of arguments passed */
int closure[2]; /* pointer to called closure object */
{
int args_expected; /* the number of arguments expected */
/*%%int i; /* our old friend the index variable */*/
int page,disp; /* page/displacement parts of closure pointer */
/*%%long *this_reg; /* pointer to a register during fixup */*/
/*%%long unbound; /* pointer to the symbol ***unbound*** */*/
static char *msg=
"Invalid argument count: Function expected xx argument(s)\nbut was called with yy as follows:";
/* 11111111112222222222333333333344444444445555555 5556666666666777777777788888888889
012345678901234567890123456789012345678901234567890123456 7890123456789012345678901234567890
*/
static int insert_offset = 77; /* offset in msg for arguments passed */
long make_ptr(); /* makes a Scheme pointer from page, disp */
ENTER(wrong_args);
/* determine the number of arguments expected */
page = CORRPAGE(closure[C_PAGE]);
disp = closure[C_DISP];
if (ptype[page] == CONTTYPE*2)
{
args_expected = 1;
}
else
{
args_expected = get_fix(SPECFIX, get_word(page, disp+NUM_ARGS));
if (args_expected < 0) args_expected = ~ args_expected;
}
/* Insert arguments expected into error message text */
msg[42] = bdigits[args_expected / 10];
msg[43] = digits[args_expected % 10];
/* set Scheme variables to reflect error condition */
arg_err(closure, args_passed, msg, insert_offset);
/***** Argument "fixup" code turned off 25 July 1985 (JCJ) *****
/* if too few arguments, set undefined registers to "***unbound***" */
if (args_expected > args_passed)
{
unbound = make_ptr(UN_PAGE, UN_DISP); /* create ***unbound*** pointer */
this_reg = (&reg0)+args_expected; /* pointer to last undefined register */
while (args_expected > args_passed)
{
*this_reg = unbound; /* set register contents to ***unbound*** */
this_reg--;
args_expected--;
} /* end: while (args_expected > args_passed) */
} /* end: if (args_expected > args_passed) */
***** Argument "fixup" code turned off 25 July 1985 (JCJ) *****/
} /* end of function: wrong_args(args_passed, closure) */
/************************************************************************/
/* Local Support-- Cons up "call" expression, output message text */
/************************************************************************/
arg_err(ftn, args_passed, msg, offset)
int ftn[2]; /* function object */
int args_passed; /* the count of arguments passed */
char *msg; /* the error message text */
int offset; /* offset in "msg" for inserting argument count */
{
int i; /* index variable */
long *this_reg; /* pointer to a register during "consing" */
/* insert count of arguments passed into the error message string */
msg[offset] = bdigits[args_passed / 10];
msg[offset+1] = digits[args_passed % 10];
/* cons up the function and arguments into a list */
this_reg = (&reg0)+args_passed; /* pointer to last argument register */
tmp_page = tmp_disp = 0; /* initialize end-of-list to nil */
for (i = 0; i < args_passed; i++, this_reg--)
cons(tmp_reg, this_reg, tmp_reg);
cons(tmp_reg, ftn, tmp_reg); /* put procedure object at front of list */
/* set up the error message text and irritant */
set_error(1, msg, tmp_reg);
} /* end of function: arg_err(ftn, args_passed, msg, offset) */
/************************************************************************/
/* Error-- Attempted to call a non-procedural object */
/************************************************************************/
not_proc(non_ftn_obj, args_passed)
int non_ftn_obj[2]; /* pointer to object in functional position */
int args_passed; /* the number of arguments in the call */
{
static char *msg=
"Attempt to call a non-procedural object with xx argument(s) as follows:";
/* 1111111111222222222233333333334444444444555555555566666666667
012345678901234567890123456789012345678901234567890123456 7890123456789 */
static int insert_offset = 45; /* offset in msg for argument count */
arg_err(non_ftn_obj, args_passed, msg, insert_offset);
} /* end of function: not_proc(non_ftn_obj, args_passed) */
/************************************************************************/
/* Error-- Symbol Not Fluidly Bound */
/************************************************************************/
not_fluidly_bound(page,disp,source)
int page; /* symbol's page number */
int disp; /* symbol's displacement */
int source[2]; /* register containing the value to be bound */
{
/* create pointer to symbol and set up error parameters */
tmp_page = ADJPAGE(page);
tmp_disp = disp;
set_numeric_error(1, SET_FLUID_ERROR, tmp_reg);
} /* end of function: not_fluidly_bound(page,disp,source) */
/************************************************************************/
/* Error-- Symbol Not Globally Bound */
/************************************************************************/
not_globally_bound(page,disp,source)
int page; /* symbol's page number */
int disp; /* symbol's displacement */
int source[2]; /* register containing the value to be bound */
{
/* create pointer to symbol and set up error parameters */
tmp_page = ADJPAGE(page);
tmp_disp = disp;
set_numeric_error(0, SET_GLOBAL_ERROR, tmp_reg);
} /* end of function: not_globally_bound(page,disp,source) */
/************************************************************************/
/* Error-- Symbol Not Lexically Bound */
/************************************************************************/
not_lexically_bound(page, disp)
int page; /* symbol's page number */
int disp; /* symbol's displacement */
{
/* create pointer to symbol and set up error parameters */
tmp_page = ADJPAGE(page);
tmp_disp = disp;
set_numeric_error(0, SET_LEXICAL_ERROR, tmp_reg);
} /* end of function: not_lexically_bound(page, disp) */
/************************************************************************/
/* Error-- Symbol Not Bound */
/************************************************************************/
sym_undefined(page,disp,env,dest)
int page; /* symbol's page number */
int disp; /* symbol's displacement */
int env[2]; /* the environment supposed to contain said symbol */
int dest[2]; /* register into which the value was to be loaded */
{
int error_number; /* numeric error code */
int error_restart; /* Can you resume from error? 0=yes,1=no */
error_restart = 0; /* Default to resumable */
if (env == GNV_reg)
error_number = REF_GLOBAL_ERROR;
else
{
if (env == FNV_reg)
{
error_number = REF_FLUID_ERROR;
error_restart = 1; /* Can't continue from fluid error */
}
else
error_number = REF_LEXICAL_ERROR;
}
/* create pointer to undefined symbol and set message parameters */
tmp_page = ADJPAGE(page);
tmp_disp = disp;
set_numeric_error(error_restart, error_number, tmp_reg);
} /* end of function: sym_undefined(page,disp,env,dest) */
/************************************************************************/
/* getmem error */
/************************************************************************/
getmem_error(routine)
char *routine;
{
void rbrk();
void force_re();
printf("[VM INTERNAL ERROR] %s: getmem error\n", routine);
printf("Press any key to return to Scheme toplevel.\n"); /*rb*/
getch();
rbrk(); /*rb*/
force_re(); /* we won't return */ /*rb*/
exit();
}
/************************************************************************/
/* rlsmem error */
/************************************************************************/
rlsmem_error(routine)
char *routine;
{
printf("[VM INTERNAL ERROR] %s: rlsmem error", routine);
}
/************************************************************************/
/* set error condition */
/************************************************************************/
set_error(code, message, irritant)
int code; /* error condition code */
char *message; /* text of error condition */
int irritant[2]; /* object causing the error */
{
/* bind error code to the symbol |*error-code*| */
C_push(tmp_reg);
intern (tm2_reg, "*ERROR-CODE*", 12);
tmp_page = SPECFIX*2;
tmp_disp = code & 0x7fff;
sym_bind(tm2_reg, tmp_reg, GNV_reg);
/* bind error message text to the symbol |*error-message*| */
intern (tm2_reg, "*ERROR-MESSAGE*", 15);
alloc_string(tmp_reg, message);
sym_bind(tm2_reg, tmp_reg, GNV_reg);
/* bind irritant to the symbol |*irritant*| */
C_pop(tmp_reg);
intern (tm2_reg, "*IRRITANT*", 10);
sym_bind(tm2_reg, irritant, GNV_reg);
} /* end of function: set_error(code, message, irritant) */
/************************************************************************/
/* set numeric error condition */
/************************************************************************/
set_numeric_error(code, error_number, irritant)
int code; /* error condition code */
int error_number; /* numeric error code for a given error condition */
int irritant[2]; /* object causing the error */
{
int lcl_reg[2]; /* a temporary register for fixnum values */
/* bind error code to the symbol |*ERROR-CODE*| */
intern (tm2_reg, "*ERROR-CODE*", 12);
lcl_reg[C_PAGE] = SPECFIX*2;
lcl_reg[C_DISP] = code & 0x7fff;
sym_bind(tm2_reg, lcl_reg, GNV_reg);
/* bind error message text to the symbol |*ERROR-MESSAGE*| */
intern (tm2_reg, "*ERROR-MESSAGE*", 15);
lcl_reg[C_DISP] = error_number;
sym_bind(tm2_reg, lcl_reg, GNV_reg);
/* bind irritant to the symbol |*IRRITANT*| */
intern (tm2_reg, "*IRRITANT*", 10);
sym_bind(tm2_reg, irritant, GNV_reg);
} /* end of function: set_numeric_error(code, error_number, irritant) */
/************************************************************************/
/* Process Invalid Source Operand Condition */
/************************************************************************/
set_src_err(op, args, arg1, arg2, arg3, arg4)
char *op; /* name of instruction failing */
int args; /* number of arguments (operands) to instruction */
int arg1[2],arg2[2],arg3[2],arg4[2]; /* register argument(s) */
{
int i; /* the usual index variable */
int *reg_ptr;
/*%%int sym[2]; /* local "register" for symbol name */*/
mov_reg(tmp_reg, nil_reg);
reg_ptr = (&arg1) + args - 1;
for (i = 0; i < args; i++, reg_ptr--)
cons(tmp_reg, *reg_ptr, tmp_reg);
intern(tm2_reg, op, strlen(op));
cons(tmp_reg, tm2_reg, tmp_reg);
set_numeric_error(1, INVALID_OPERAND_ERROR, tmp_reg);
} /* end of function: set_src_err(op, args, arg1, arg2, arg3, arg4) */
#ifdef PROMEM
/************************************************************************/
/* Process Protected Mode Error */
/************************************************************************/
pro_error(rtn,fnc,errnum)
char *rtn,*fnc;
int errnum;
{
char ch;
printf("\nFatal Error during %s , performing %s - Error # %d",
rtn,fnc,errnum);
printf("\nPress any key for attempt to SCHEME-RESET");
ch = getch();
printf("\n[Returning to top level]\n");
force_reset();
}
#endif

Reference in New Issue View Git Blame Copy Permalink