static void coerce_arg(rtype type, rtype ftype, int l, string code,
string *buf, int *i, int *lbuf,
int int_allowed, frame name)
{
frame f = make_frame(type, NULL, l, code, "");
if ((type == T_INTNUM || type == T_INTLNG) && !int_allowed)
f = coerce_frame(f, T_NUMBER);
f = coerce_frame(f, ftype);
if (f->decls)
name->decls = nconc(name->decls, copy_list(f->decls, 0));
NORET(f->code);
*buf = copy_into_buf(*buf, f->code, i, lbuf, strlen(f->code));
mcfree(f->code);
mcfree(f);
}
int comp_fini(bool status, mstr *obj, opctype retcode, oprtype *retopr, int src_len)
{
triple *ref;
error_def(ERR_INDEXTRACHARS);
if (status && source_column != src_len + 2 && source_buffer[source_column] != '\0')
{
status = FALSE;
stx_error(ERR_INDEXTRACHARS);
}
if (status)
{
cg_phase = CGP_RESOLVE;
assert(for_stack_ptr == for_stack);
if (*for_stack_ptr)
tnxtarg(*for_stack_ptr);
ref = newtriple(retcode);
if (retopr)
ref->operand[0] = *retopr;
start_fetches(OC_NOOP);
resolve_ref(0); /* cannot fail because there are no MLAB_REF's in indirect code */
alloc_reg();
stp_gcol(0);
assert(indr_stringpool.base == stringpool.base);
indr_stringpool = stringpool;
stringpool = rts_stringpool;
compile_time = FALSE;
ind_code(obj);
indr_stringpool.free = indr_stringpool.base;
}
else
{
assert(indr_stringpool.base == stringpool.base);
indr_stringpool = stringpool;
stringpool = rts_stringpool;
indr_stringpool.free = indr_stringpool.base;
compile_time = FALSE;
cg_phase = CGP_NOSTATE;
}
transform = TRUE;
mcfree();
return status;
}
void op_zcompile(mval *v, boolean_t mExtReqd)
{
unsigned status;
command_qualifier save_qlf;
unsigned short len;
char source_file_string[FILE_NAME_SIZE + 1],
obj_file[FILE_NAME_SIZE + 1],
list_file[FILE_NAME_SIZE + 1],
ceprep_file[FILE_NAME_SIZE + 1];
# ifdef UNIX
CLI_ENTRY *save_cmd_ary;
# endif
size_t mcallocated, alloc;
mcalloc_hdr *lastmca, *nextmca;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
MV_FORCE_STR(v);
if (!v->str.len)
return;
save_qlf = glb_cmd_qlf;
glb_cmd_qlf.object_file.str.addr = obj_file;
glb_cmd_qlf.object_file.str.len = FILE_NAME_SIZE;
glb_cmd_qlf.list_file.str.addr = list_file;
glb_cmd_qlf.list_file.str.len = FILE_NAME_SIZE;
glb_cmd_qlf.ceprep_file.str.addr = ceprep_file;
glb_cmd_qlf.ceprep_file.str.len = FILE_NAME_SIZE;
zl_cmd_qlf(&v->str, &glb_cmd_qlf);
cmd_qlf = glb_cmd_qlf;
assert(run_time);
assert(rts_stringpool.base == stringpool.base);
rts_stringpool = stringpool;
if (!indr_stringpool.base)
{
stp_init (STP_INITSIZE);
indr_stringpool = stringpool;
} else
stringpool = indr_stringpool;
run_time = FALSE;
TREF(compile_time) = TRUE;
TREF(transform) = FALSE;
TREF(dollar_zcstatus) = SS_NORMAL;
len = FILE_NAME_SIZE;
# ifdef UNIX
/* The caller of this function could be GT.M, DSE, MUPIP, GTCM GNP server, GTCM OMI server etc. Most of them have their
* own command parsing tables and some dont even have one. Nevertheless, we need to parse the string as if it was a
* MUMPS compilation command. So we switch temporarily to the MUMPS parsing table "mumps_cmd_ary". Note that the only
* rts_errors possible between save and restore of the cmd_ary are in compile_source_file and those are internally
* handled by source_ch which will transfer control back to us (right after the the call to compile_source_file below)
* and hence proper restoring of cmd_ary is guaranteed even in case of errors.
*/
save_cmd_ary = cmd_ary;
cmd_ary = mumps_cmd_ary;
# endif
mcfree(); /* If last compile errored out, may have left things uninitialized for us */
/* Find out how much space we have in mcalloc blocks */
for (mcallocated = 0, nextmca = mcavailptr; nextmca; nextmca = nextmca->link)
mcallocated += nextmca->size;
if (0 == mcallocated)
mcallocated = MC_DSBLKSIZE - MCALLOC_HDR_SZ; /* Min size is one default block size */
for (status = cli_get_str("INFILE",source_file_string, &len);
status;
status = cli_get_str("INFILE",source_file_string, &len))
{
compile_source_file(len, source_file_string, mExtReqd);
len = FILE_NAME_SIZE;
}
/* Determine if need to remove any added added mc blocks. Min value of mcallocated will ensure
* we leave at least one block alone.
*/
for (alloc = 0, nextmca = mcavailptr;
nextmca && (alloc < mcallocated);
alloc += nextmca->size, lastmca = nextmca, nextmca = nextmca->link);
if (nextmca)
{ /* Start freeing at the nextmca node since these are added blocks */
lastmca->link = NULL; /* Sever link to further blocks here */
/* Release any remaining blocks if any */
for (lastmca = nextmca; lastmca; lastmca = nextmca)
{
nextmca = lastmca->link;
free(lastmca);
}
}
# ifdef UNIX
cmd_ary = save_cmd_ary; /* restore cmd_ary */
# endif
assert((FALSE == run_time) && (TRUE == TREF(compile_time)));
run_time = TRUE;
TREF(compile_time) = FALSE;
TREF(transform) = TRUE;
indr_stringpool = stringpool;
stringpool = rts_stringpool;
indr_stringpool.free = indr_stringpool.base;
glb_cmd_qlf = save_qlf;
}
static frame make_regular_call_frame(frame name, frame args, string header,
int int_allowed, int kappafn)
{
char fname[ATOBUF_SIZE + 4];
string varg, next, n = NULL;
int i = 0;
string arg = strchr(header, ' ') + 1;
string rest = NULL;
string kappac = header[1] == STA ? "" : kappafn ? KPC : appfn_prefix;
string buf;
int lbuf = (args ? args->cl : 0) + 128;
int nnullp = strcmp(name->code, "Null?");
list delvars = NULL;
int bren = -1;
sprintf(fname, "%s%s", kappac, name->code);
if (!call_level && nnullp)
error(1, "Call level error while parsing call to '%s' in %s",
name->code, block_name);
if (!nnullp) --trilog;
--call_level;
if (parsing_rule_if && args && slotref_parsed & (1 << call_level))
{
if (strcmp(name->code, "KnownValue?") && nnullp)
warn("Suspicious call to '%s' in premise of rule %s",
name->code, block_name);
slotref_parsed &= ~(1 << call_level);
}
if (!arg[0])
return merge_frames(header[0], header[0], name, NULL, name->cl + 6,
RET, fname, "()", "");
buf = (string) mcalloc(lbuf);
varg = args ? argtok(args->code, &rest) : NULL;
if (header[0] == T_STRING)
{
MAKE_BUFFER(bname, SLOBUF);
sprintf(buf, "%s%s", bname, arg[1] ? ", " : "");
i = strlen(bname) + (arg[1] ? 2 : 0);
}
for (arg += (header[0] == T_STRING); arg[0]; varg = next) {
char arg0 = arg[0] & ~PTRF;
if (arg0 == T_HANDLE && arg[1] != VAGC)
{
next = varg;
strcpy(buf + i, "hInstance, ");
i += 11;
++arg;
continue;
}
if (varg)
{
next = argtok(rest, &rest);
n = (next ? next : varg + strlen(varg) + 1);
}
else
next = NULL;
if (varg && varg[0] != arg0) /* not the normal case. */
{
if (varg[0] == T_UNKNOWN || varg[0] == T_UNDEF)
{
if (varg[1] == UNOC) /* case of an unfinished function call. */
{
varg[2] = arg0;
buf = copy_into_buf(buf, varg + 1, &i, &lbuf,
n - varg - 2);
}
else
{
list m = member(varg, block_decls, 0, 0, 1, 1);
int vl = strlen(varg);
if (m) /* case of a variable of unknown type. */
{
if (car(m)[0] == T_UNKNOWN || car(m)[0] == T_UNDEF)
{
list a = member(varg, args->decls, 0, 0, 1, 1);
list b = member(varg, block_args, 0, 0, 1, 1);
list d = a ? NULL
: member(varg, delvars, 0, 0, 1, 1);
if (arg0 == T_STRING && !b)
{
buf[i++] = '"';
buf = copy_into_buf(buf, varg + 1, &i, &lbuf,
n - varg - 2);
buf[i++] = '"';
if (a && !d)
{
delvars = cons(car(a), delvars);
args->decls = delete(varg,
args->decls, 1, 1);
}
}
else
{
if (!b) /* declaring as atom or object. */
{
string tmp;
rtype dt =
arg0 == T_OBJECT ? T_OBJECT : T_ATOM;
tmp = create_adda_call(dt, varg, vl);
tmp[0] = dt;
if (a && car(m) == car(a))
{
mcfree(car(m));
car(m) = car(a) = tmp;
}
else
{
car(m) = tmp;
if (!a && d)
args->decls =
cons(car(d), args->decls);
}
}
else
{
if (a)
car(a)[0] = arg0;
else if (d)
{
car(d)[0] = arg0;
args->decls = cons(car(d),
args->decls);
}
car(m)[0] = arg0;
}
if (car(m)[0] == arg0)
goto normal;
else
goto coerce;
}
}
else coerce:
coerce_arg(car(m)[0], arg0, n - varg, varg + 1,
&buf, &i, &lbuf, int_allowed, name);
}
else /* case of a finished function */
{
string fn = strchr(varg + 1, '(');
int fl = fn - varg - 1 - appfn_pl;
m = member(varg, headers, 0, fl, appfn_pl + 1, 2);
coerce_arg(car(m)[0], arg0, n - varg, varg + 1,
&buf, &i, &lbuf, int_allowed, name);
#ifdef OLD
else if (user_headers.count)
{
char fname[48];
string *pr;
strncpy(fname, varg + appfn_pl + 1, fl);
fname[fl] = '\0';
pr = bsearch(&fname, user_headers.table,
user_headers.count,
sizeof(string), (sortfn) hcomp);
coerce_arg(*pr[0], arg0, n - varg, varg + 1,
&buf, &i, &lbuf, int_allowed, name);
}
#endif
}
}
}
else
{
int bd = arg0 == T_ATOM && varg[0] == T_OBJECT;
if (bren == -1 && bd)
bren = !strcmp(name->code, "RenameInstance") ||
!strcmp(name->code, "RenameClass");
if (bren == 1 && bd)
{
char nv1[32], nv2[32];
novar(nv1, varg + 1);
novar(nv2, name->code);
warn("%s was compiled as an object in call to %s, line %d.",
nv1, nv2, yylineno);
}
coerce_arg(varg[0], arg0, n - varg, varg + 1, &buf, &i,
&lbuf, int_allowed, name);
}
}
int comp_fini(int status, mstr *obj, opctype retcode, oprtype *retopr, oprtype *dst, mstr_len_t src_len)
{
triple *ref;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if (status)
{
while (TK_SPACE == TREF(window_token)) /* Eat up trailing white space */
advancewindow();
if (TK_ERROR == TREF(window_token))
{
status = EXPR_FAIL;
stx_error(ERR_INDRCOMPFAIL);
} else if ((TK_EOL != TREF(window_token)) || (source_column < src_len))
{
status = EXPR_FAIL;
stx_error(ERR_INDEXTRACHARS);
} else
{
cg_phase = CGP_RESOLVE;
assert(TREF(for_stack_ptr) == TADR(for_stack));
if (*TREF(for_stack_ptr))
tnxtarg(*TREF(for_stack_ptr));
ref = newtriple(retcode);
if (retopr)
ref->operand[0] = *retopr;
if (OC_IRETMVAL == retcode)
ref->operand[1] = *dst;
start_fetches(OC_NOOP);
resolve_ref(0); /* cannot fail because there are no MLAB_REF's in indirect code */
alloc_reg();
INVOKE_STP_GCOL(0);
/* The above invocation of stp_gcol with a parameter of 0 is a critical part of compilation
* (both routine compilations and indirect dynamic compilations). This collapses the indirect
* (compilation) stringpool so that only the literals are left. This stringpool is then written
* out to the compiled object as the literal pool for that compilation. Temporary stringpool
* use for conversions or whatever are eliminated. Note the path is different in stp_gcol for
* the indirect stringpool which is only used during compilations.
*/
assert(indr_stringpool.base == stringpool.base);
indr_stringpool = stringpool;
stringpool = rts_stringpool;
TREF(compile_time) = FALSE;
ind_code(obj);
indr_stringpool.free = indr_stringpool.base;
}
} else
{ /* If this assert fails, it means a syntax problem could have been caught earlier. Consider placing a more useful
* and specific error message at that location.
*/
assert(FALSE);
stx_error(ERR_INDRCOMPFAIL);
}
if (EXPR_FAIL == status)
{
assert(indr_stringpool.base == stringpool.base);
indr_stringpool = stringpool;
stringpool = rts_stringpool;
indr_stringpool.free = indr_stringpool.base;
TREF(compile_time) = FALSE;
cg_phase = CGP_NOSTATE;
}
TREF(transform) = TRUE;
COMPILE_HASHTAB_CLEANUP;
mcfree();
return status;
}
static frame make_trsl_frame(frame f1, frame f2, rtype type,
void (*merge_fn)(string, string,
string, va_list), ...)
{
frame knv = NULL;
string c = coerce_from_atom[type - T_NUMBER];
char cv1[12], cv2[12];
int f1s = f1->type == T_SLOT;
int f2s = f2->type == T_SLOT;
string check = " " QSM " idTrue : idFalse) : idNull";
string trcb;
char buf[512];
va_list ap;
va_start(ap, merge_fn);
NORET(f1->code);
NORET(f2->code);
if (!det_type(type) || type == T_OBJECT)
type = T_ATOM;
if (f1s)
knv = prepare_knv_frame(f1, knv, cv1, c);
else if (trcb = strchr(f1->code, TRLC))
knv = prepare_trsl_frame(f1, knv, trcb);
else if (type == T_ATOM || type == T_BOOL)
{
f1 = prepare_frame(f1, type);
if (member(f1->code, block_args, 0, 0, 0, 1) ||
!member(f1->code, block_decls, 0, 0, 0, 1))
{
knv = make_lknv_frame(f1, ++vcount, 1, type);
f1->cl = 8;
f1->code = (string) recalloc(f1->code, f1->cl);
sprintf(f1->code, "_v%d", vcount);
}
}
if (f2s)
knv = prepare_knv_frame(f2, knv, cv2, c);
else if (trcb = strchr(f2->code, TRLC))
knv = prepare_trsl_frame(f2, knv, trcb);
else if (type == T_ATOM || type == T_BOOL)
{
f2 = prepare_frame(f2, type);
if (member(f2->code, block_args, 0, 0, 0, 1) ||
!member(f2->code, block_decls, 0, 0, 0, 1))
{
frame knv1 = make_lknv_frame(f2, ++vcount, 1, type);
knv = knv ? merge_frames(T_CBOOL, T_UNKNOWN, knv, knv1,
knv->cl + knv1->cl + 7,
knv->code, " "AMP AMP" " NST TABS,
knv1->code, "") :
knv1;
f2->cl = 8;
f2->code = (string) recalloc(f2->code, f2->cl);
sprintf(f2->code, "_v%d", vcount);
}
}
if (knv)
f1->decls = merge_decl_lists(T_UNKNOWN, f1->decls, knv->decls);
(*merge_fn)(buf, f1s ? cv1 : NORET(f1->code),
f2s ? cv2 : NORET(f2->code), ap);
if (knv)
{
f1 = merge_frames(T_BOOL, type, f1, f2,
knv->cl + strlen(buf) + strlen(check) + 12,
RET, knv->code, " " QSM NST TABS " (", TRL, buf, TRL,
check, "");
mcfree(knv->code);
mcfree(knv);
}
else
f1 = merge_frames(T_BOOL, type, f1, f2, strlen(buf) + 4,
RET, TRL, buf, TRL, "");
va_end(ap);
f1->block = -1;
return f1;
}
