/* If f is a valid parameter field spec, such as p_val, then overwrite *f
* with the proper FN_XXX character and return YES, else return NO.
* Let the p_value field also be called p_filename, p_length and p_default.
* Call error() if f starts with p_ but is not found or if ambiguous
* (and abbrevs are enabled).
*/
int
fieldcvt (register char *f)
{
/* Field name and corresponding code tables.
*/
static char *fntbl[] = {
"p_name", "p_type", "p_mode", "p_value", "p_minimum",
"p_maximum", "p_prompt", "p_filename", "p_length", "p_default",
"p_xtype", NULL
};
static char fctbl[] = {
FN_NAME, FN_TYPE, FN_MODE, FN_VALUE, FN_MIN,
FN_MAX, FN_PROMPT, FN_VALUE, FN_LENGTH, FN_VALUE,
FN_XTYPE, NULL
};
int kentry;
/* Do a quick screening first. returning NO just means that f does
* not even look like a field name.
*/
if (strncmp (f, "p_", 2))
return (NO);
kentry = keyword (fntbl, f);
if (kentry == KWBAD)
cl_error (E_UERR, "bad param field `%s'", f);
else if (kentry == KWAMBIG)
cl_error (E_UERR, "ambiguous param field `%s'", f);
*f = fctbl[kentry];
return (YES);
}
/* CASESET -- Fill in the values for which the current case block is to be
* executed.
*/
void
caseset (memel *parg, int ncaseval)
{
struct operand *o;
static char *badcase = "Invalid case constant.";
int ival;
for (ival = 0; ival < ncaseval; ival++) {
memel p = pop();
o = (struct operand *) p;
if (o->o_type == OT_STRING) {
/* Only chars, not full strings.
*/
if (*o->o_val.v_s == 0)
cl_error (E_UERR, badcase);
if (*(o->o_val.v_s + 1) != 0)
cl_error (E_UERR, badcase);
*parg++ = (int) *o->o_val.v_s;
} else if (o->o_type == OT_INT) {
*parg++ = o->o_val.v_i;
} else
cl_error (E_UERR, badcase);
}
}
/* CL_VOCINIT -- Initialize the VO Client interface.
*/
void
cl_vocinit (void)
{
register struct pfile *pfp;
struct operand o;
int n, status;
if (VOClient_initialized == 0) {
c_xwhen (X_IPC, voc_onipc, &old_onipc);
pfp = newtask->t_pfp;
if ((n = nargs (pfp)) > 1) {
cl_error (E_UERR, e_posargs, "vocinit");
return;
} else if (n < 1) {
status = voc_initVOClient (envget("vo_runid"));
} else {
pushbparams (pfp->pf_pp);
popop(); /* discard fake name. */
opcast (OT_STRING);
o = popop(); /* get ltask */
status = voc_initVOClient (o.o_val.v_s);
}
if (status) {
cl_error (E_UERR, "Can't init VOClient", "vocinit");
} else
VOClient_initialized = 1;
}
}
void
o_swon (memel *argp)
{
register char *pname = (char *)argp;
register struct param *pp;
struct pfile *pfp;
struct operand o;
char *pk, *t, *p, *f;
breakout (pname, &pk, &t, &p, &f);
if (*pk)
cl_error (E_UERR, e_simplep, p);
pfp = newtask->t_pfp;
pp = ppfind (pfp, t, p, 0, NO);
if (pp == NULL)
cl_error (E_UERR, e_pnonexist, p);
if ((XINT)pp == ERR)
cl_error (E_UERR, e_pambig, p, newtask->t_ltp->lt_lname);
o.o_type = OT_BOOL;
o.o_val.v_i = YES;
pushop (&o);
paramset (pp, FN_VALUE);
if (pp->p_type & PT_PSET)
psetreload (pfp, pp);
pp->p_flags |= P_CLSET;
}
int cl_getaddrinfo(char *addr, char *port, t_client *cl)
{
struct addrinfo *results;
struct addrinfo *tmp;
if (cl_init_addrinfo(addr, (port == NULL) ? DEF_PORT : port, &results))
return (cl_error(" Failed", NULL));
tmp = results;
while (tmp != NULL)
{
cl->sock = socket(tmp->ai_family, tmp->ai_socktype, tmp->ai_protocol);
if (cl->sock == -1)
continue ;
if (connect(cl->sock, tmp->ai_addr, tmp->ai_addrlen) == 0)
break ;
close(cl->sock);
cl->sock = -1;
tmp = tmp->ai_next;
}
freeaddrinfo(results);
if (tmp == NULL)
return (cl_error("No server found.", NULL));
ft_putendl(" \e[32mOK\e[0m");
return (0);
}
int cl_list_getnext(const void * cfg, cl_list_t * list, void * item, int * addr){
cl_list_block_t * ptr;
void * new_item;
ptr = (cl_list_block_t*)list->block_data.data;
block_t current_block;
if ( list->current_item < list->total_in_block ){
if ( addr != NULL ){
*addr = get_item_addr(list->current_block, list->current_item, list->item_size);
}
cl_debug(DEBUG_LEVEL+4, "item addr: 0x%X\n", get_item_addr(list->current_block, list->current_item, list->item_size));
new_item = get_item(ptr, list->current_item, list->item_size);
if ( item != NULL ){
memcpy(item, new_item, list->item_size);
}
/*
cl_debug(DEBUG_LEVEL, "Item contents:");
for(i=0; i < list->item_size; i++){
if ( CL_DEBUG >= DEBUG_LEVEL ){
printf("0x%X ", ((unsigned char*)new_item)[i]);
}
}
if ( CL_DEBUG >= DEBUG_LEVEL ){
printf("\n");
}
*/
if( list->is_free(new_item) ){
cl_debug(DEBUG_LEVEL, "end of list (free entries) %d item(s)\n", list->current_item+1);
return 1;
}
list->current_item++;
} else {
return -1;
}
if ( list->current_item == list->total_in_block ){
cl_debug(DEBUG_LEVEL + 2, "load next block %d\n", ptr->hdr.next);
if ( ptr->hdr.next != BLOCK_INVALID ){
current_block = list->current_block;
list->current_block = ptr->hdr.next;
if ( current_block == ptr->hdr.next ){
cl_error("circular list\n");
return -1;
}
if ( list_update(cfg, list, current_block) < 0 ){
cl_error("error loading block %d\n", list->current_block);
return -1;
}
} else {
cl_debug(DEBUG_LEVEL, "end of list (none free)\n");
return 0;
}
}
return 0;
}
/* ARGSUSED */
void
onint (
int *vex, /* virtual exception code */
int (**next_handler)(void) /* next handler to be called */
)
{
if (firstask->t_flags & T_BATCH) {
/* Batch task.
*/
iofinish (currentask);
bkg_abort();
clexit();
} else if (currentask->t_flags & (T_SCRIPT|T_CL|T_BUILTIN)) {
/* CL task.
*/
cl_error (E_UERR, "interrupt!!!");
} else {
/* External task connected via IPC. Pass the interrupt on to
* the child.
*/
c_prsignal (currentask->t_pid, X_INT);
/* Cancel any output and disable i/o on the tasks pseudofiles.
* This is necessary to cancel any i/o still buffered in the
* IPC channel. Commonly when the task is writing to STDOUT,
* for example, the CL will be writing the last buffer sent
* to the terminal, while the task waits after having already
* pushed the next buffer into the IPC. When we resume reading
* from the task we will see this buffered output on the next
* read and we wish to discard it. Leave STDERR connected to
* give a path to the terminal for recovery actions such as
* turning standout or graphics mode off. This gives the task
* a chance to cleanup but does not permit full recovery. The
* pseudofiles will be reconnected for the next task run.
*/
c_fseti (fileno(stdout), F_CANCEL, OK);
c_fseti (fileno(currentask->t_in), F_CANCEL, OK);
c_fseti (fileno(currentask->t_out), F_CANCEL, OK);
c_prredir (currentask->t_pid, STDIN, 0);
c_prredir (currentask->t_pid, STDOUT, 0);
/* If a subprocess is repeatedly interrupted we assume that it
* is hung in a loop and abort, advising the user to kill the
* process.
*/
if (++ninterrupts >= MAX_INTERRUPTS)
cl_error (E_UERR, "subprocess is hung; should be killed");
else
longjmp (intenv, 1);
}
*next_handler = NULL;
}
/* Given a, possibly abbreviated, function name to run, look it up and
* run it if found. it gets nargs arguments from the operand stack.
*/
void
intrfunc (char *fname, int nargs)
{
int op_index, op;
int i, n, subi[2];
int trim_side = TRIM_LEFT|TRIM_RIGHT;
char *trim = " \t";
char sbuf[SZ_LINE+1];
struct operand o;
op_index = keyword (ifnames, fname);
if (op_index == KWBAD)
cl_error (E_UERR, "unknown function `%s'", fname);
if (op_index == KWAMBIG)
cl_error (E_UERR, "ambiguous function `%s'", fname);
op = optbl[op_index];
/* if do this by shifting the cases and op to the right OP_BITS, this
* will compile as a jump table. not worth it until it gets larger.
*/
switch (op & ~OP_MASK) {
case UNOP:
if (nargs != 1)
cl_error (E_UERR, e_onearg, ifnames[op_index]);
unop (op & OP_MASK);
break;
case BINOP:
if (nargs != 2)
cl_error (E_UERR, e_twoargs, ifnames[op_index]);
binop (op & OP_MASK);
break;
case MULTOP:
multop (op & OP_MASK, op_index, nargs);
break;
case VOCOP:
vocop (op & OP_MASK, op_index, nargs);
break;
case SAMPOP:
sampop (op & OP_MASK, op_index, nargs);
break;
default:
err: cl_error (E_IERR, e_badsw, op, "intrfunc()");
}
}
/* <string operand> .
* if argument to which we are assigning is a simple string or filename (or
* list, since assigning to a list sets a filename too), set it to o_val.v_s,
* else use o_val.v_s as the name of a parameter and use its value as the name
* of the variable, that is, do an indirect through o_val.v_s.
* compiled when the parser sees a simple identifier, not in an expression.
* this avoids quotes around simple strings and filenames.
* if the parameter is to be fake, make it type string and do not do the
* indirection.
*/
void
o_indirabsset (memel *argp)
{
char *argname = (char *) argp;
char *pk, *t, *p, *f;
struct pfile *pfp;
struct param *pp;
int type, string_len;
pfp = newtask->t_pfp;
if (pfp->pf_flags & PF_FAKE) {
struct operand o;
o = popop();
string_len = strlen (o.o_val.v_s);
pp = newfakeparam (pfp, argname, 0, OT_STRING, string_len);
f = argname;
*f = FN_NULL;
pushop (&o);
} else {
breakout (argname, &pk, &t, &p, &f);
if (*pk)
cl_error (E_UERR, e_simplep, p);
pp = ppfind (pfp, t, p, 0, NO);
if (pp == NULL)
cl_error (E_UERR, e_pnonexist, p);
if ((XINT)pp == ERR)
cl_error (E_UERR, e_pambig, p, pfp->pf_ltp->lt_lname);
}
/* lone identifiers are treated as strings, rather than variables,
* if the corresponding parameter is a simple string, filename or list.
* note that fakeparams are made as strings.
*/
type = pp->p_type;
if (type & (PT_FILNAM|PT_LIST|PT_PSET)) {
struct operand o;
o = popop();
pushop (&o);
} else if ((type & OT_BASIC) != OT_STRING ||
type & (PT_STRUCT|PT_IMCUR|PT_GCUR|PT_UKEY)) {
opindir(); /* replace top op with value of o_val.v_s */
}
paramset (pp, *f);
if (pp->p_type & PT_PSET)
psetreload (pfp, pp);
pp->p_flags |= P_CLSET;
}
int list_update(const void * cfg, cl_list_t * list, block_t prev_block){
cl_list_hdr_t * list_hdr;
list->current_item = 0;
if( cl_block_load(cfg, list->current_block, &(list->block_data)) < 0 ){
cl_error("failed to laod block %d\n", list->current_block);
return -1;
}
list_hdr = (cl_list_hdr_t*)list->block_data.data;
//hwpl_debug("loaded %d (prev:%d next:%d) 0x%X %d\n", list->current_block, list_hdr->prev, list_hdr->next, list->block_data.hdr.type, list->block_data.hdr.serialno);
if( (prev_block != list_hdr->prev) || (list_typeisvalid(list->block_data.hdr.type) == false) ){ //this check makes sure the list is consistent
cl_error("list has an error\n");
return -1;
}
return 0;
}
/* Break a param spec of the form [[pack.]task.]param[.field] into its
* component parts. Full is a pointer to the full name. The others are the
* addresses of char pointers in the calling routine that are to be set to
* point to the starting address, within full, of their respective components.
* All dots are set to \0 and serve as eos's for each component.
* If any of the parts are absent, the respective pointer is made to point at
* the trailing null of full.
* The last part, field, is handled by fieldcvt(). it overwrites the first
* char of the field component with the proper FN_XXX character; it is not
* made into a string by adding an additional \0.
* Call error() and do not return if something goes wrong.
* Also used to break apart the components of full task names, [pack.]task. In
* this case, the task name will be found at p and the package name at t.
* Fair enough; just keep them straight when calling.
* Modified 3/26/84 by TAM to use a static buffer, rather than mutilating
* the input string. This caused problems when programs looped and
* executed the same PUSHPARAM (or similar) more than once, e.g.
* while (i<10) {= task.param; i += 1; }.
* This bug is particularly manifest when accessing arrays in specified tasks,
* e.g. = task.array[*]
*/
void
breakout (char *full, char **pk, char **t, char **p, char **f)
{
register char *cp;
register int npts, n;
char *pts[3];
static char buffer[SZ_LINE+1];
strncpy (buffer, full, SZ_LINE);
buffer[SZ_LINE] = '\0';
for (npts=0, cp=buffer; *cp; cp++) {
if (*cp == '.') {
if (*(cp+1) == EOS) {
*cp = EOS; /* chop dot if last character */
break;
} else {
if (npts > 3)
cl_error (E_UERR, "too many dots in param name `%s'",
full);
pts[npts++] = cp;
}
}
}
for (n=0; n < npts; n++)
*(pts[n]++) = '\0'; /* null over and skip dots */
switch (npts) {
case 0: /* just a simple param name without dots */
*p = buffer;
*pk = *t = *f = cp;
break;
case 1: /* p.f or t.p depending on f */
if (fieldcvt (pts[0])) {
/* p.f */
*pk = *t = cp; *p = buffer; *f = pts[0];
} else {
/* t.p */
*pk = *f = cp; *t = buffer; *p = pts[0];
}
break;
case 2: /* t.p.f or pk.t.p depending on f */
if (fieldcvt (pts[1])) {
/* t.p.f */
*pk = cp; *t = buffer; *p = pts[0]; *f = pts[1];
} else {
/* pk.t.p */
*pk = buffer; *t = pts[0]; *p = pts[1]; *f = cp;
}
break;
case 3: /* full spec */
*pk = buffer; *t = pts[0]; *p = pts[1]; *f = pts[2];
fieldcvt (*f);
break;
}
}
/* Y_TYPEDEF -- Convert a type specifier keyword into a datatype code.
*/
int
y_typedef (char *key)
{
if (strcmp (key, "string") == 0 || strcmp (key, "char") == 0)
return (V_STRING);
else if (strcmp (key, "int") == 0)
return (V_INT);
else if (strcmp (key, "real") == 0)
return (V_REAL);
else if (strcmp (key, "bool") == 0)
return (V_BOOL);
else if (strcmp (key, "file") == 0)
return (V_FILE);
else if (strcmp (key, "gcur") == 0)
return (V_GCUR);
else if (strcmp (key, "imcur") == 0)
return (V_IMCUR);
else if (strcmp (key, "ukey") == 0)
return (V_UKEY);
else if (strcmp (key, "pset") == 0)
return (V_PSET);
else if (strcmp (key, "struct") == 0)
return (V_STRUCT);
else
cl_error (E_UERR, "illegal type specifier `%s'", key);
/*NOTREACHED*/
return (0);
}
/* MAKE_IMLOOP -- compiles the meta-code for the indexing of arrays in
* implicit array loops e.g. a[*,5].
*/
int
make_imloop (int i1, int i2)
{
int mode;
if (n_oarr) {
/* Array limits already defined, check for agreement.
*/
if (i1 != oarr_beg[i_oarr] || i2 != oarr_end[i_oarr])
cl_error (E_UERR, "Inconsistent open refs.\n");
mode = -1;
} else {
oarr_beg[i_oarr] = i1;
oarr_end[i_oarr] = i2;
if (i_oarr)
mode = -1;
else
/* This is the PUSHINDEX which will
* initialize the loop variables.
*/
mode = 0;
}
i_oarr++;
return (mode);
}
/* <name of file to be used as stdout> .
*/
void
o_redir (void)
{
struct operand o;
char *fname, *mode;
opcast (OT_STRING);
o = popop();
fname = (o.o_val.v_s);
if (newtask->t_flags & T_FOREIGN && newtask->t_stdout == stdout) {
/* If foreign task let ZOSCMD open the spool file.
*/
newtask->ft_out = comdstr (fname);
} else if (strcmp (fname, IPCOUT) == 0) {
/* Redirect the task stdout via IPC to a subprocess. */
newtask->t_stdout = newtask->t_out;
newtask->t_flags |= T_IPCIO;
} else {
mode = (newtask->t_flags & T_STDOUTB) ? "wb" : "w";
if ((newtask->t_stdout = fopen (fname, mode)) == NULL)
cl_error (E_UERR, e_wopen, fname);
newtask->t_flags |= T_MYOUT;
}
}
/* <new value for argument at command position *argp> .
*/
void
o_posargset (memel *argp)
{
int pos = (int) *argp;
struct pfile *pfp;
struct param *pp;
struct operand o;
int string_len=0;
pfp = newtask->t_pfp;
if (pos < 0) {
/* Lone comma in arg list, merely bump nargs counter */
pfp->pf_n++;
return;
}
if (pfp->pf_flags & PF_FAKE) {
o = popop();
if ((o.o_type & OT_BASIC) == OT_STRING)
string_len = strlen (o.o_val.v_s);
pp = newfakeparam (pfp, (char *) NULL, pos, o.o_type, string_len);
pushop (&o);
} else {
pp = paramfind (pfp, (char *) NULL, pos, NO);
if (pp == NULL)
cl_error (E_UERR, e_posargs, newtask->t_ltp->lt_lname);
}
paramset (pp, FN_NULL);
pfp->pf_n++;
pp->p_flags |= P_CLSET;
}
void
o_doscanf (void)
{
struct operand o;
struct operand o_sv[64];
char format[SZ_LINE];
int nargs, i;
/* Get number of arguments. */
o = popop();
nargs = o.o_val.v_i;
/* Get scan format. Unfortunately the way the parser works this
* is the last operand on the stack. We need to pop and save the
* first nargs-1 operands and restore them when done.
*/
for (i=0; i < nargs-1; i++)
o_sv[i] = popop();
o = popop();
if ((o.o_type & OT_BASIC) != OT_STRING)
cl_error (E_UERR, "scanf: bad format string\n");
strcpy (format, o.o_val.v_s);
for (--i; i >= 0; i--)
pushop (&o_sv[i]);
/* Do the scan. */
cl_scanf (format, nargs-2, "stdin");
}
/* <name of file to be used as stderr> .
* redirect everything, including the stderr channel.
*/
void
o_allredir (void)
{
struct operand o;
char *fname, *mode;
opcast (OT_STRING);
o = popop();
fname = (o.o_val.v_s);
if (newtask->t_flags & T_FOREIGN &&
newtask->t_stdout == stdout && newtask->t_stderr == stderr) {
/* If foreign task and i/o has not already been redirected by
* the parent, let ZOSCMD open the spool file.
*/
newtask->ft_out = newtask->ft_err = comdstr (fname);
} else {
mode = (newtask->t_flags & T_STDOUTB) ? "wb" : "w";
if ((newtask->t_stderr = fopen (fname, mode)) == NULL)
cl_error (E_UERR, e_wopen, fname);
newtask->t_stdout = newtask->t_stderr;
newtask->t_flags |= (T_MYOUT|T_MYERR);
}
}
/* CL_VOCSTOP -- Stop the VO Client interface.
*/
void
cl_vocstop (void)
{
register struct pfile *pfp;
struct operand o;
int n, status;
if (VOClient_initialized == 1) {
c_xwhen (X_IPC, old_onipc, &old_onipc);
pfp = newtask->t_pfp;
if ((n = nargs (pfp)) > 1) {
cl_error (E_UERR, e_posargs, "vocstop");
return;
} else if (n < 1) {
voc_closeVOClient (1);
} else {
pushbparams (pfp->pf_pp);
popop(); /* discard fake name. */
opcast (OT_INT);
o = popop(); /* get ltask */
voc_closeVOClient (o.o_val.v_i);
}
VOClient_initialized = 0;
}
}
/* unconditional goto.
* *argp is the SIGNED increment to be added to pc.
*/
void
o_dogoto (memel *argp)
{
extern XINT pc;
pc += (int)*argp;
if (pc >= STACKSIZ)
cl_error (E_IERR, "pc set wildly to %d during goto", pc);
}
void
FEtype_error_proper_list(cl_object x) {
cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
make_constant_base_string("Not a proper list ~D"),
ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(1, x),
ECL_SYM(":EXPECTED-TYPE",1232), ecl_read_from_cstring("si::proper-list"),
ECL_SYM(":DATUM",1214), x);
}
void
o_dofscanf (void)
{
struct operand o, o_sv[64];
char format[SZ_LINE];
char pname[SZ_FNAME];
int nargs, i;
/* Get number of arguments. */
o = popop();
nargs = o.o_val.v_i;
/* Get scan format and input parameter name. The arguments on the
* stack are pushed in the order input param name, format string,
* and then the output arguments.
*/
/* Get output arguments. */
for (i=0; i < nargs-2; i++)
o_sv[i] = popop();
/* Get format string. */
o = popop();
if ((o.o_type & OT_BASIC) != OT_STRING)
cl_error (E_UERR, "fscanf: bad format string\n");
strcpy (format, o.o_val.v_s);
/* Get parameter name. */
o = popop();
if ((o.o_type & OT_BASIC) != OT_STRING)
cl_error (E_UERR, "fscanf: bad input parameter specification\n");
strcpy (pname, o.o_val.v_s);
/* Restore the output argument operands. */
for (--i; i >= 0; i--)
pushop (&o_sv[i]);
/* Restore the input parameter name operand. */
o.o_type = OT_STRING;
o.o_val.v_s = pname;
pushop (&o);
/* Do the scan. */
cl_scanf (format, nargs-2, "");
}
/* INTR_ENABLE -- Reenable interrupts, reposting the interrupt vector saved
* in a prior call to INTR_DISABLE.
*/
void
intr_enable (void)
{
PFI junk;
if (--intr_sp < 0)
cl_error (E_IERR, "interrupt save stack underflow");
c_xwhen (X_INT, intr_save[intr_sp], &junk);
}
/* GETPIPE -- Get the name of the last pipefile.
*/
char *
getpipe (void)
{
char *pipefile();
if (nextpipe == 0)
cl_error (E_IERR, "Pipestack underflow");
return (pipefile (pipetable[nextpipe-1]));
}
static void
FEtype_error_plist(cl_object x)
{
cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
make_constant_base_string("Not a valid property list ~D"),
ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(1, x),
ECL_SYM(":EXPECTED-TYPE",1232), ECL_SYM("SI::PROPERTY-LIST",1658),
ECL_SYM(":DATUM",1214), x);
}
int cl_list_setblockstatus(const void * cfg, block_t list_block, uint8_t status){
cl_list_hdr_t hdr;
block_t tmp_block;
block_t last_block;
int i,j;
int total;
last_block = BLOCK_INVALID;
for(tmp_block = list_block; tmp_block != BLOCK_INVALID; tmp_block = hdr.next){
if ( cl_dev_read(cfg, get_hdr_addr(tmp_block), &hdr, sizeof(hdr)) != sizeof(hdr) ){
cl_error("failed to read\n");
return -1;
}
if ( hdr.prev != last_block ){
cl_error("bad list\n");
return -1;
}
cl_debug(DEBUG_LEVEL, "this block is %d (prev:%d next:%d)\n", tmp_block, hdr.prev, hdr.next);
last_block = tmp_block;
i++;
}
total = 0;
for(tmp_block = last_block; tmp_block != BLOCK_INVALID; tmp_block = hdr.prev){
cl_debug(DEBUG_LEVEL, "this block is %d (prev)\n", tmp_block);
if ( cl_dev_read(cfg, get_hdr_addr(tmp_block), &hdr, sizeof(hdr)) != sizeof(hdr) ){
cl_error("failed to read\n");
return -1;
}
total++;
cl_debug(DEBUG_LEVEL, "set list block %d status to 0x%X\n", tmp_block, status);
if ( cl_block_setstatus(cfg, tmp_block, status) < 0 ){
cl_error("failed to set status of %d to %d\n", tmp_block, status);
return -1;
}
j++;
}
return 0;
}
/* TPRINTF -- Printf that always goes through the pipe out to the currently
* running task. Be a bit more careful here in case a pipe is broken or
* something is going haywire.
*/
tprintf (char *fmt, ...)
{
va_list args;
FILE *out;
out = currentask->t_out;
if (out == NULL)
cl_error (E_IERR, "no t_out for currentask `%s'",
currentask->t_ltp->lt_lname);
else {
va_start (args, fmt);
u_doprnt (fmt, &args, out);
va_end (args);
fflush (out);
if (ferror (out))
cl_error (E_UERR|E_P, "pipe write error to `%s'",
currentask->t_ltp->lt_lname);
}
}
/* LOOPINCR -- increments the loop counter and stores the destination
* address for NEXT statements. It should be called just before the
* destination is compiled.
*/
void
loopincr (void)
{
if (nestlevel >= MAX_LOOP)
cl_error (E_UERR, "Nesting too deeply.");
brkdest[nestlevel] = 0;
nextdest[nestlevel] = pc;
nestlevel++;
}
/* INTR_DISABLE -- Disable interrupts, e.g., to protect a critical section
* of code.
*/
void
intr_disable (void)
{
PFI junk;
if (intr_sp >= LEN_INTRSTK)
cl_error (E_IERR, "interrupt save stack overflow");
c_xwhen (X_INT, X_IGNORE, &junk);
intr_save[intr_sp++] = (XINT) junk;
}
/* . <new constant>
* The "illegal constant" business comes from the possibility of syntactically
* correct but valuely wrong sexagesimal constants, such as 1:222:1.
* We don't want to abort in sexa() because it may be used to digest a query
* response and producing a quiet undefined op there is correct.
*/
void
o_pushconst (memel *argp)
{
/* argument is pointer to an operand */
struct operand *op;
op = (struct operand *) argp;
if (opundef (op))
cl_error (E_UERR, "illegal constant");
pushop (op);
}
void
FEtype_error_index(cl_object seq, cl_fixnum ndx)
{
cl_object n = ecl_make_fixnum(ndx);
cl_index l = ECL_INSTANCEP(seq)? seq->instance.length : ecl_length(seq);
cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
make_constant_base_string("~S is not a valid index into the object ~S"),
ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(2, n, seq),
ECL_SYM(":EXPECTED-TYPE",1232), cl_list(3, ECL_SYM("INTEGER",437), ecl_make_fixnum(0), ecl_make_fixnum(l-1)),
ECL_SYM(":DATUM",1214), n);
}
