void do_forget (void)
{ char name[16];
header *hd;
int r;
if (udfon)
{ output("Cannot forget functions in a function!\n");
error=720; return;
}
while (1)
{ scan_space();
scan_name(name);
r=xor(name);
hd=(header *)ramstart;
while ((char *)hd<udfend)
{ if (r==hd->xor && !strcmp(hd->name,name)) break;
hd=nextof(hd);
}
if ((char *)hd>=udfend)
{ output1("Function %s not found!\n",name);
error=160; return;
}
kill_udf(name);
scan_space();
if (*next!=',') break;
else next++;
}
}
int JSON::parse_array(const char *begin, const char *end, bool withname, std::vector<JSON::Node> *children)
{
children->clear();
char const *ptr = begin;
while (1) {
int n;
Node node;
if (withname) {
n = parse_name(ptr, end, &node);
if (n > 0) {
ptr += n;
ptr += scan_space(ptr, end);
if (*ptr == ':') {
ptr++;
}
}
}
n = parse_value(ptr, end, &node);
if (node.type != Type::Unknown) {
children->push_back(node);
}
ptr += n;
ptr += scan_space(ptr, end);
if (ptr < end && *ptr == ',') {
ptr++;
continue;
}
return ptr - begin;
}
}
void do_loop (void)
/***** do_loop
do a loop command in a UDF.
loop value to value; .... ; end
*****/
{ int h;
char *jump;
header *init,*end;
long vend,oldindex;
if (!udfon)
{ output("Loop only allowed in functions!\n");
error=57; return;
}
init=scan(); if (error) return;
init=getvalue(init); if (error) return;
if (init->type!=s_real)
{ output("Startvalue must be real!\n"); error=72; return;
}
oldindex=loopindex;
loopindex=(long)*realof(init);
scan_space(); if (strncmp(next,"to",2))
{ output("Endvalue missing in loop!\n"); error=73; goto end;
}
next+=2;
end=scan(); if (error) goto end;
end=getvalue(end); if (error) goto end;
if (end->type!=s_real)
{ output("Endvalue must be real!\n"); error=73; goto end;
}
vend=(long)*realof(end);
if (loopindex>vend) { scan_end(); goto end; }
newram=endlocal;
scan_space(); if (*next==';' || *next==',') next++;
jump=next;
while (!error)
{ if (*next==1)
{ output("End missing in loop!\n");
error=401; goto end;
}
h=command();
if (udfon!=1 || h==c_return) break;
if (h==c_break) { scan_end(); break; }
if (h==c_end)
{ loopindex++;
if (loopindex>vend) break;
else next=jump;
if (test_key()==escape)
{ output("User interrupted!\n");
error=1; break;
}
}
}
end : loopindex=oldindex;
}
void do_repeat (void)
/***** do_loop
do a loop command in a UDF.
for value to value; .... ; endfor
*****/
{ int h;
char *jump;
if (!udfon)
{ output("Repeat only allowed in functions!\n");
error=57; return;
}
newram=endlocal;
scan_space(); if (*next==';' || *next==',') next++;
jump=next;
while (!error)
{ if (*next==1)
{ output("End missing in repeat statement!\n");
error=401; break;
}
h=command();
if (udfon!=1 || h==c_return) break;
if (h==c_break) { scan_end(); break; }
if (h==c_end)
{ next=jump;
if (test_key()==escape)
{ output1("User interrupted\n");
error=1; break;
}
}
}
}
void do_do (void)
{ int udfold;
char name[16];
char *oldnext=next,*udflineold;
header *var;
scan_space(); scan_name(name); if (error) return;
var=searchudf(name);
if (!var || var->type!=s_udf)
{ output("Need a udf!\n"); error=220; return;
}
udflineold=udfline; udfline=next=udfof(var); udfold=udfon; udfon=1;
while (!error && udfon==1)
{ command();
if (udfon==2) break;
if (test_key()==escape)
{ output("User interrupted!\n"); error=58; break;
}
}
if (error) output1("Error in function %s\n",var->name);
if (udfon==0)
{ output1("Return missing in %s!\n",var->name); error=55; }
udfon=udfold; udfline=udflineold;
if (udfon) next=oldnext;
else { next=input_line; *next=0; }
}
void do_cd (void)
{ header *hd;
char name[256];
char *s;
scan_space();
if (*next==';' || *next==',' || *next==0)
{ s=cd("");
output1("%s\n",s);
return;
}
if (*next=='(')
{ hd=scan_value();
if (error) return;
if (hd->type!=s_string)
{ output("String value expected!\n");
error=1; return;
}
strcpy(name,stringof(hd));
}
else
{ scan_namemax(name,256);
}
if (error) return;
s=cd(name);
if (*next!=';') output1("%s\n",s);
if (*next==',' || *next==';') next++;
}
int JSON::parse_value(const char *begin, const char *end, JSON::Node *node)
{
char const *ptr = begin;
int n;
ptr += scan_space(ptr, end);
if (ptr < end) {
if (*ptr == '[') {
ptr++;
node->type = Type::Array;
n = parse_array(ptr, end, false, &node->children);
ptr += n;
if (ptr < end && *ptr == ']') {
ptr++;
return ptr - begin;
}
} else if (*ptr == '{') {
ptr++;
node->type = Type::Object;
n = parse_array(ptr, end, true, &node->children);
ptr += n;
if (ptr < end && *ptr == '}') {
ptr++;
return ptr - begin;
}
} else if (*ptr == '\"') {
n = parse_string(ptr, end, &node->value);
if (n > 0) {
ptr += n;
node->type = Type::String;
return ptr - begin;
}
} else {
char const *left = ptr;
while (ptr < end) {
int c = *ptr & 0xff;
if (isspace(c)) break;
if (strchr("[]{},:\"", c)) break;
ptr++;
}
if (left < ptr) {
std::string value(left, ptr);
if (value == "null") {
node->type = Type::Null;
} else if (value == "false") {
node->type = Type::Boolean;
node->value = "0";
} else if (value == "true") {
node->type = Type::Boolean;
node->value = "1";
} else {
node->type = Type::Number;
node->value = value;
}
return ptr - begin;
}
}
}
return 0;
}
void load_file (void)
/***** load_file
interpret a file.
*****/
{ char filename[256];
char oldline[1024],fn[256],*oldnext;
int oldbooktype=booktype,pn;
header *hd;
FILE *oldinfile;
if (udfon)
{ output("Cannot load a file in a function!\n");
error=221; return;
}
scan_space();
if (*next=='(')
{ hd=scan_value();
if (error) return;
if (hd->type!=s_string)
{ output("String value expected!\n");
error=1; return;
}
strcpy(filename,stringof(hd));
}
else
{ scan_namemax(filename,256);
}
if (error) return;
oldinfile=infile;
pn=-1;
retry :
if (pn>=0)
{ strcpy(fn,path[pn]);
strcat(fn,PATH_DELIM_STR);
strcat(fn,filename);
}
else strcpy(fn,filename);
infile=fopen(fn,"r");
if (!infile)
{ strcat(fn,EXTENSION);
infile=fopen(fn,"r");
pn++;
if (!infile)
{ if (pn>=npath)
{ output1("Could not open %s!\n",filename);
error=53; infile=oldinfile; return;
}
else goto retry;
}
}
strcpy(oldline,input_line); oldnext=next;
*input_line=0; next=input_line;
booktype=0;
while (!error && infile && !quit) command();
booktype=oldbooktype;
if (infile) fclose(infile);
infile=oldinfile;
strcpy(input_line,oldline); next=oldnext;
}
void do_trace(void)
/**** do_trace
toggles tracing or sets the trace bit of a udf.
****/
{ header *f;
char name[64];
scan_space();
if (!strncmp(next,"off",3))
{ trace=0; next+=3;
}
else if (!strncmp(next,"alloff",6))
{ next+=6;
f=(header *)ramstart;
while ((char *)f<udfend && f->type==s_udf)
{ f->flags&=~1;
f=nextof(f);
}
trace=0;
}
else if (!strncmp(next,"on",2))
{ trace=1; next+=2;
}
else if (*next==';' || *next==',' || *next==0) trace=!trace;
else
{ if (*next=='"') next++;
scan_name(name); if (error) return;
if (*next=='"') next++;
f=searchudf(name);
if (!f || f->type!=s_udf)
{ output("Function not found!\n");
error=11021; return;
}
f->flags^=1;
if (f->flags&1) output1("Tracing %s\n",name);
else output1("No longer tracing %s\n",name);
scan_space();
}
if (*next==';' || *next==',') next++;
}
void do_comments (void)
/**** do_comments
toggles comments
****/
{ scan_space();
if (!strncmp(next,"off",3))
{ printcomments=0; next+=3;
}
else if (!strncmp(next,"on",2))
{ printcomments=1; output("\n"); next+=2;
}
else printcomments=!printcomments;
}
void do_prompt (void)
/**** do_prompt
toggles notebook prompt.
****/
{ scan_space();
if (!strncmp(next,"off",3))
{ promptnotebook=0; next+=3;
}
else if (!strncmp(next,"on",2))
{ promptnotebook=1; output("\n"); next+=2;
}
else promptnotebook=!promptnotebook;
}
void do_output (void)
/**** do_output
toggles output.
****/
{ scan_space();
if (!strncmp(next,"off",3))
{ outputing=0; next+=3;
}
else if (!strncmp(next,"on",2))
{ outputing=1; output("\n"); next+=2;
}
else outputing=!outputing;
}
void load_book (void)
/***** load_book
interpret a notebook file.
*****/
{ header *hd;
char name[256];
char oldline[1024],fn[256],*oldnext;
int oldbooktype=booktype;
FILE *oldinfile;
if (udfon)
{ output("Cannot load a notebook in a function!\n");
error=221; return;
}
scan_space();
if (*next=='(')
{ hd=scan_value();
if (error) return;
if (hd->type!=s_string)
{ output("String value expected!\n");
error=1; return;
}
strcpy(name,stringof(hd));
}
else
{ scan_namemax(name,256);
}
if (error) return;
oldinfile=infile;
infile=fopen(name,"r");
if (!infile)
{ strcpy(fn,name);
strcat(fn,BOOKEXTENSION);
infile=fopen(fn,"r");
if (!infile)
{ output1("Could not open %s!\n",stringof(name));
error=53; infile=oldinfile; return;
}
}
strcpy(oldline,input_line); oldnext=next;
*input_line=0; next=input_line;
booktype=1;
while (!error && infile && !quit)
{ startglobal=startlocal; endglobal=endlocal;
command();
}
booktype=oldbooktype;
if (infile) fclose(infile);
infile=oldinfile;
strcpy(input_line,oldline); next=oldnext;
}
int command (void)
/***** command
scan a command and interpret it.
return, if the user wants to quit.
*****/
{ header *expr;
int ret=c_none;
quit=0; error=0; errorout=0;
while(1)
{ scan_space();
if (*next) break;
else next_line();
}
if (*next==1) return ret;
expr=scan_expression();
if (!expr) { newram=endlocal; return ret; }
if (error)
{ newram=endlocal;
print_error(next);
next=input_line; input_line[0]=0;
return ret;
}
if (expr==&commandheader)
{ newram=endlocal;
return commandtype;
}
switch (expr->type)
{ case s_real :
case s_complex :
case s_matrix :
case s_cmatrix :
case s_imatrix :
case s_string :
case s_interval :
if (*next!=';') give_out(expr);
if (*next==',' || *next==';') next++;
break;
case s_reference :
case s_submatrix :
case s_csubmatrix :
case s_isubmatrix :
do_assignment(expr);
break;
default : break;
}
if (error) print_error(next);
newram=endlocal;
if (error) { next=input_line; input_line[0]=0; }
return ret;
}
void do_global (void)
{ char name[16];
int r;
header *hd;
while (1)
{ scan_space(); scan_name(name); r=xor(name);
hd=(header *)udfend;
if (hd==(header *)startlocal) break;
while ((char *)hd<startlocal)
{ if (r==hd->xor && !strcmp(hd->name,name)) break;
hd=nextof(hd);
}
if ((char *)hd>=startlocal)
{ output1("Variable %s not found!\n",name);
error=160; return;
}
newram=endlocal;
hd=new_reference(hd,name);
newram=endlocal=(char *)nextof(hd);
scan_space();
if (*next!=',') break;
else next++;
}
}
void do_postscript (void)
{ header *file;
scan_space();
file=scan_value();
if (error || file->type!=s_string)
{ output("Postscript needs a filename!\n");
error=201; return;
}
FILE *metafile=fopen(stringof(file),"w");
if (!metafile)
{ output1("Could not open %s.\n",stringof(file));
}
dump_postscript(metafile);
fclose(metafile);
}
void do_dump (void)
{ header *file;
if (outfile)
{ if (fclose(outfile))
{ output("Error while closing dumpfile.\n");
}
outfile=0;
}
scan_space();
if (*next==';' || *next==',' || *next==0)
{ if (*next) next++; return; }
file=scan_value();
if (error || file->type!=s_string)
{ output("Dump needs a filename!\n");
error=201; return;
}
outfile=fopen(stringof(file),"a");
if (!outfile)
{ output1("Could not open %s.\n",stringof(file));
}
}
void do_dir (void)
{ header *file;
char *s;
scan_space();
if (*next==';' || *next==',' || *next==0)
{ file=new_string("*.*",5,"");
}
else file=scan_value();
if (error || file->type!=s_string)
{ output("Dir needs a string!\n");
error=201; return;
}
s=dir(stringof(file));
if (!s || !*s) return;
output1("%s\n",s);
while (1)
{ s=dir(0);
if (!s || !*s) break;
output1("%s\n",s);
}
if (*next==',' || *next==';') next++;
}
void do_path (void)
{ header *ppath;
char s[256],*p,*q;
int i;
scan_space();
if (*next==';' || *next==',' || *next==0)
{ out :
for (i=0; i<npath; i++)
{ output1("%s;",path[i]);
}
output("\n");
return;
}
ppath=scan_value();
if (error || ppath->type!=s_string)
{ output("Path needs a string!\n");
error=201; return;
}
p=stringof(ppath);
for (i=0; i<npath; i++) free(path[i]);
npath=0;
while (*p)
{ q=s;
while (*p && *p!=';') *q++=*p++;
if (q>s && *(q-1)==PATH_DELIM_CHAR) q--;
*q=0;
if (*p==';') p++;
path[npath]=(char *)malloc(strlen(s)+1);
strcpy(path[npath],s);
npath++;
}
if (npath==0)
{ path[0]=(char *)malloc(5);
strcpy(path[0],".");
}
if (*next!=';') goto out;
}
int JSON::parse_name(const char *begin, const char *end, JSON::Node *node)
{
char const *ptr = begin;
ptr += scan_space(ptr, end);
char const *name = ptr;
int quote = 0;
if (*ptr == '\"') {
quote = *ptr;
name++;
ptr++;
}
while (ptr < end) {
if (quote) {
if (*ptr == quote) {
if (name < ptr) {
node->name = std::string(name, ptr);
ptr++;
return ptr - begin;
} else {
return 0;
}
} else {
ptr++;
}
} else if (strchr(":={}[]", *ptr) || isspace(*ptr & 0xff)) {
if (name < ptr) {
node->name = std::string(name, ptr);
return ptr - begin;
}
return 0;
} else {
ptr++;
}
}
return 0;
}
void do_hexdump (void)
{ char name[16];
unsigned char *p,*end;
int i=0,j;
ULONG count=0;
header *hd;
scan_space(); scan_name(name); if (error) return;
hd=searchvar(name);
if (!hd) hd=searchudf(name);
if (error || hd==0) return;
p=(unsigned char *)hd; end=p+hd->size;
output1("\n%5lx ",count);
while (p<end)
{ hex_out(*p++); i++; count++;
if (i>=16)
{ i=0; string_out(p-16);
output1("\n%5lx ",count);
if (test_key()==escape) break;
}
}
for (j=i; j<16; j++) output(" ");
string_out(p-i);
output("\n");
}
callin_entry_list* citab_parse (void)
{
int parameter_count, i, fclose_res;
uint4 inp_mask, out_mask, mask;
mstr labref, callnam;
enum xc_types ret_tok, parameter_types[MAXIMUM_PARAMETERS], pr;
char str_buffer[MAX_TABLINE_LEN], *tbp, *end;
FILE *ext_table_file_handle;
callin_entry_list *entry_ptr, *save_entry_ptr = 0;
error_def(ERR_CITABENV);
error_def(ERR_CITABOPN);
error_def(ERR_CIENTNAME);
error_def(ERR_COLON);
error_def(ERR_CIRTNTYP);
error_def(ERR_CIRCALLNAME);
error_def(ERR_CIDIRECTIVE);
error_def(ERR_CIRPARMNAME);
error_def(ERR_CIPARTYPE);
error_def(ERR_CIUNTYPE);
error_def(ERR_SYSCALL);
error_def(ERR_CIMAXPARAM);
ext_table_file_name = GETENV(CALLIN_ENV_NAME);
if (!ext_table_file_name) /* environment variable not set */
rts_error(VARLSTCNT(4) ERR_CITABENV, 2, LEN_AND_STR(CALLIN_ENV_NAME));
ext_table_file_handle = Fopen(ext_table_file_name, "r");
if (!ext_table_file_handle) /* call-in table not found */
rts_error(VARLSTCNT(11) ERR_CITABOPN, 2, LEN_AND_STR(ext_table_file_name),
ERR_SYSCALL, 5, LEN_AND_LIT("fopen"), CALLFROM, errno);
ext_source_line_num = 0;
while (read_table(LIT_AND_LEN(str_buffer), ext_table_file_handle))
{
if (!*(tbp = scan_space(str_buffer)))
continue;
if (!(end = scan_ident(tbp)))
ext_stx_error(ERR_CIRCALLNAME, ext_table_file_name);
callnam.addr = tbp;
callnam.len = INTCAST(end - tbp);
tbp = scan_space(end);
if (':' != *tbp++)
ext_stx_error(ERR_COLON, ext_table_file_name);
ret_tok = scan_keyword(&tbp); /* return type */
switch (ret_tok) /* return type valid ? */
{
case xc_void:
case xc_char_star:
case xc_int_star:
case xc_uint_star:
case xc_long_star:
case xc_ulong_star:
case xc_float_star:
case xc_double_star:
case xc_string_star:
break;
default:
ext_stx_error(ERR_CIRTNTYP, ext_table_file_name);
}
labref.addr = tbp;
if ((end = scan_labelref(tbp)))
labref.len = INTCAST(end - tbp);
else
ext_stx_error(ERR_CIENTNAME, ext_table_file_name);
tbp = scan_space(end);
inp_mask = out_mask = 0;
for (parameter_count = 0; (*tbp && ')' != *tbp); parameter_count++)
{
if (MAXIMUM_PARAMETERS <= parameter_count)
ext_stx_error(ERR_CIMAXPARAM, ext_table_file_name);
/* must have comma if this is not the first parameter, otherwise '(' */
if (((0 == parameter_count)?'(':',') != *tbp++)
ext_stx_error(ERR_CIRPARMNAME, ext_table_file_name);
tbp = scan_space(tbp);
if ((0 == parameter_count) && (*tbp == ')')) /* special case () */
break;
/* looking for an I, a O or an IO */
mask = (1 << parameter_count);
inp_mask |= ('I' == *tbp) ? (tbp++, mask) : 0;
out_mask |= ('O' == *tbp) ? (tbp++, mask) : 0;
if ((!(inp_mask & mask) && !(out_mask & mask)) || (':' != *tbp++))
ext_stx_error(ERR_CIDIRECTIVE, ext_table_file_name);
switch ((pr = scan_keyword(&tbp))) /* valid param type? */
{
case xc_int:
case xc_uint:
case xc_long:
case xc_ulong:
case xc_float:
case xc_double:
if (out_mask & mask)
ext_stx_error(ERR_CIPARTYPE, ext_table_file_name);
/* fall-thru */
case xc_char_star:
case xc_int_star:
case xc_uint_star:
case xc_long_star:
case xc_ulong_star:
case xc_float_star:
case xc_double_star:
case xc_string_star:
break;
default:
ext_stx_error(ERR_CIUNTYPE, ext_table_file_name);
}
parameter_types[parameter_count] = pr;
tbp = scan_space(tbp);
}
if (!*tbp)
ext_stx_error(ERR_CIRPARMNAME, ext_table_file_name);
entry_ptr = get_memory(sizeof(callin_entry_list));
entry_ptr->next_entry = save_entry_ptr;
save_entry_ptr = entry_ptr;
entry_ptr->return_type = ret_tok;
entry_ptr->argcnt = parameter_count;
entry_ptr->input_mask = inp_mask;
entry_ptr->output_mask = out_mask;
entry_ptr->parms = get_memory(parameter_count * sizeof(entry_ptr->parms[0]));
for (i = 0 ; i < parameter_count ; i++)
entry_ptr->parms[i] = parameter_types[i];
put_mstr(&labref, &entry_ptr->label_ref);
put_mstr(&callnam, &entry_ptr->call_name);
}
FCLOSE(ext_table_file_handle, fclose_res);
return entry_ptr;
}
/* Note: need condition handler to clean-up allocated structures and close intput file in the event of an error */
struct extcall_package_list *exttab_parse(mval *package)
{
int parameter_alloc_values[MAXIMUM_PARAMETERS], parameter_count, ret_pre_alloc_val, i, fclose_res;
boolean_t is_input[MAXIMUM_PARAMETERS], is_output[MAXIMUM_PARAMETERS], got_status;
mstr callnam, rtnnam;
void_ptr_t pakhandle;
enum xc_types ret_tok, parameter_types[MAXIMUM_PARAMETERS], pr;
char str_buffer[MAX_TABLINE_LEN], *tbp, *end;
FILE *ext_table_file_handle;
struct extcall_package_list *pak;
struct extcall_entry_list *entry_ptr;
error_def(ERR_ZCRTENOTF);
error_def(ERR_ZCALLTABLE);
error_def(ERR_ZCUSRRTN);
error_def(ERR_ZCCTENV);
error_def(ERR_ZCCTOPN);
error_def(ERR_ZCCTNULLF);
error_def(ERR_ZCUNAVAIL);
error_def(ERR_ZCENTNAME);
error_def(ERR_ZCCOLON);
error_def(ERR_ZCRTNTYP);
error_def(ERR_ZCRCALLNAME);
error_def(ERR_ZCUNTYPE);
error_def(ERR_ZCMLTSTATUS);
error_def(ERR_ZCRPARMNAME);
error_def(ERR_ZCPREALLVALPAR);
error_def(ERR_ZCPREALLVALINV);
/* First, construct package name environment variable */
memcpy(str_buffer, PACKAGE_ENV_PREFIX, sizeof(PACKAGE_ENV_PREFIX));
tbp = &str_buffer[sizeof(PACKAGE_ENV_PREFIX) - 1];
if (package->str.len)
{
/* guaranteed by compiler */
assert(package->str.len < MAX_NAME_LENGTH - sizeof(PACKAGE_ENV_PREFIX) - 1);
*tbp++ = '_';
memcpy(tbp, package->str.addr, package->str.len);
tbp += package->str.len;
}
*tbp = 0;
/* Now we have the environment name, lookup file name */
ext_table_file_name = GETENV(str_buffer);
if (NULL == ext_table_file_name)
{
/* Environment variable for the package not found */
rts_error(VARLSTCNT(4) ERR_ZCCTENV, 2, LEN_AND_STR(str_buffer));
}
ext_table_file_handle = Fopen(ext_table_file_name, "r");
if (NULL == ext_table_file_handle)
{
/* Package's external call table could not be found */
rts_error(VARLSTCNT(4) ERR_ZCCTOPN, 2, LEN_AND_STR(ext_table_file_name));
}
ext_source_line_num = 0;
/* pick-up name of shareable library */
tbp = read_table(LIT_AND_LEN(str_buffer), ext_table_file_handle);
if (NULL == tbp)
{
/* External call table is a null file */
rts_error(VARLSTCNT(4) ERR_ZCCTNULLF, 2, package->str.len, package->str.addr);
}
pakhandle = fgn_getpak(str_buffer, INFO);
if (NULL == pakhandle)
{
/* Unable to obtain handle to the shared library */
rts_error(VARLSTCNT(4) ERR_ZCUNAVAIL, 2, package->str.len, package->str.addr);
}
pak = get_memory(sizeof(*pak));
pak->first_entry = 0;
put_mstr(&package->str, &pak->package_name);
pak->package_handle = pakhandle;
/* At this point, we have a valid package, pointed to by pak */
#ifdef DEBUG_EXTCALL
FPRINTF(stderr, "GT.M external call opened package name: %s\n", pak->package_name.addr);
#endif
for (;;)
{
star_found = FALSE;
tbp = read_table(LIT_AND_LEN(str_buffer), ext_table_file_handle);
if (NULL == tbp)
break;
tbp = scan_space(str_buffer);
/* empty line? */
if (!*tbp)
continue;
/* No, must be entryref */
end = scan_ident(tbp);
if (!end)
ext_stx_error(ERR_ZCENTNAME, ext_table_file_name);
if ('^' == *end)
{
end++;
end = scan_ident(end);
if (!end)
ext_stx_error(ERR_ZCENTNAME, ext_table_file_name);
}
rtnnam.addr = tbp;
rtnnam.len = INTCAST(end - tbp);
tbp = scan_space(end);
if (':' != *tbp++)
ext_stx_error(ERR_ZCCOLON, ext_table_file_name);
/* get return type */
ret_tok = scan_keyword(&tbp);
/* check for legal return type */
switch (ret_tok)
{
case xc_status:
case xc_void:
case xc_int:
case xc_uint:
case xc_long:
case xc_ulong:
case xc_char_star:
case xc_float_star:
case xc_string_star:
case xc_int_star:
case xc_uint_star:
case xc_long_star:
case xc_ulong_star:
case xc_double_star:
case xc_char_starstar:
case xc_pointertofunc:
case xc_pointertofunc_star:
break;
default:
ext_stx_error(ERR_ZCRTNTYP, ext_table_file_name);
}
got_status = (ret_tok == xc_status);
/* get call name */
if ('[' == *tbp)
{
if (star_found)
ret_pre_alloc_val = scan_array_bound(&tbp,ret_tok);
else
ext_stx_error(ERR_ZCPREALLVALPAR, ext_table_file_name);
/* We should allow the pre-allocated value upto to the maximum string size (MAX_STRLEN) plus 1 for the
* extra terminating NULL. Negative values would have been caught by scan_array_bound() above */
if (ret_pre_alloc_val > MAX_STRLEN + 1)
ext_stx_error(ERR_ZCPREALLVALINV, ext_table_file_name);
} else
ret_pre_alloc_val = -1;
end = scan_ident(tbp);
if (!end)
ext_stx_error(ERR_ZCRCALLNAME, ext_table_file_name);
callnam.addr = tbp;
callnam.len = INTCAST(end - tbp);
tbp = scan_space(end);
tbp = scan_space(tbp);
for (parameter_count = 0;(MAXIMUM_PARAMETERS > parameter_count) && (')' != *tbp); parameter_count++)
{
star_found = FALSE;
/* must have comma if this is not the first parameter, otherwise '(' */
if (((0 == parameter_count)?'(':',') != *tbp++)
ext_stx_error(ERR_ZCRPARMNAME, ext_table_file_name);
tbp = scan_space(tbp);
/* special case: () is ok */
if ((0 == parameter_count) && (*tbp == ')'))
break;
/* looking for an I, an O or an IO */
is_input[parameter_count] = is_output[parameter_count] = FALSE;
if ('I' == *tbp)
{
is_input[parameter_count] = TRUE;
tbp++;
}
if ('O' == *tbp)
{
is_output[parameter_count] = TRUE;
tbp++;
}
if (((FALSE == is_input[parameter_count]) && (FALSE == is_output[parameter_count]))
||(':' != *tbp++))
ext_stx_error(ERR_ZCRCALLNAME, ext_table_file_name);
/* scanned colon--now get type */
pr = scan_keyword(&tbp);
if (xc_notfound == pr)
ext_stx_error(ERR_ZCUNTYPE, ext_table_file_name);
if (xc_status == pr)
{
/* Only one type "status" allowed per call */
if (got_status)
ext_stx_error(ERR_ZCMLTSTATUS, ext_table_file_name);
else
got_status = TRUE;
}
parameter_types[parameter_count] = pr;
if ('[' == *tbp)
{
if (star_found && !is_input[parameter_count])
parameter_alloc_values[parameter_count] = scan_array_bound(&tbp, pr);
else
ext_stx_error(ERR_ZCPREALLVALPAR, ext_table_file_name);
/* We should allow the pre-allocated value upto to the maximum string size (MAX_STRLEN) plus 1 for
* the extra terminating NULL. Negative values would have been caught by scan_array_bound() above */
if (parameter_alloc_values[parameter_count] > MAX_STRLEN + 1)
ext_stx_error(ERR_ZCPREALLVALINV, ext_table_file_name);
} else
parameter_alloc_values[parameter_count] = -1;
tbp = scan_space(tbp);
}
entry_ptr = get_memory(sizeof(*entry_ptr));
entry_ptr->next_entry = pak->first_entry;
pak->first_entry = entry_ptr;
entry_ptr->return_type = ret_tok;
entry_ptr->ret_pre_alloc_val = ret_pre_alloc_val;
entry_ptr->argcnt = parameter_count;
entry_ptr->input_mask = array_to_mask(is_input, parameter_count);
entry_ptr->output_mask = array_to_mask(is_output, parameter_count);
entry_ptr->parms = get_memory(parameter_count * sizeof(entry_ptr->parms[0]));
entry_ptr->param_pre_alloc_size = get_memory(parameter_count * sizeof(intszofptr_t));
entry_ptr->parmblk_size = (SIZEOF(void *) * parameter_count) + SIZEOF(intszofptr_t);
for (i = 0 ; i < parameter_count ; i++)
{
entry_ptr->parms[i] = parameter_types[i];
entry_ptr->parmblk_size += parm_space_needed[parameter_types[i]];
entry_ptr->param_pre_alloc_size[i] = parameter_alloc_values[i];
}
put_mstr(&rtnnam, &entry_ptr->entry_name);
put_mstr(&callnam, &entry_ptr->call_name);
/* the reason for passing INFO severity is that PROFILE has several routines listed in
* the external call table that are not in the shared library. PROFILE folks would
* rather see info/warning messages for such routines at shared library open time,
* than error out. These unimplemented routines, they say were not being called from
* the application and wouldn't cause any application failures. If we fail to open
* the shared libary, or we fail to locate a routine that is called from the
* application, we issue rts_error message (in extab_parse.c) */
entry_ptr->fcn = fgn_getrtn(pak->package_handle, &entry_ptr->call_name, INFO);
#ifdef DEBUG_EXTCALL
FPRINTF(stderr, " package entry point: %s, address: %x\n", entry_ptr->entry_name.addr, entry_ptr->fcn);
#endif
}
FCLOSE(ext_table_file_handle, fclose_res);
return pak;
}
static enum xc_types scan_keyword(char **c)
{
const static struct
{
char nam[MAX_NAM_LEN];
enum xc_types typ[MAXIMUM_STARS + 1]; /* one entry for each level of indirection eg [1] is type* */
} xctab[] =
{
/* typename type type * type ** */
{"void", xc_void, xc_notfound, xc_notfound },
{"gtm_int_t", xc_int, xc_int_star, xc_notfound },
{"xc_int_t", xc_int, xc_int_star, xc_notfound },
{"int", xc_int, xc_int_star, xc_notfound },
{"gtm_uint_t", xc_uint, xc_uint_star, xc_notfound },
{"xc_uint_t", xc_uint, xc_uint_star, xc_notfound },
{"uint", xc_uint, xc_uint_star, xc_notfound },
{"gtm_long_t", xc_long, xc_long_star, xc_notfound },
{"xc_long_t", xc_long, xc_long_star, xc_notfound },
{"long", xc_long, xc_long_star, xc_notfound },
{"gtm_ulong_t", xc_ulong, xc_ulong_star, xc_notfound },
{"xc_ulong_t", xc_ulong, xc_ulong_star, xc_notfound },
{"ulong", xc_ulong, xc_ulong_star, xc_notfound },
{"gtm_status_t", xc_status, xc_notfound, xc_notfound },
{"xc_status_t", xc_status, xc_notfound, xc_notfound },
{"gtm_char_t", xc_notfound, xc_char_star, xc_char_starstar },
{"xc_char_t", xc_notfound, xc_char_star, xc_char_starstar },
{"char", xc_notfound, xc_char_star, xc_char_starstar },
{"gtm_string_t", xc_notfound, xc_string_star, xc_notfound },
{"xc_string_t", xc_notfound, xc_string_star, xc_notfound },
{"string", xc_notfound, xc_string_star, xc_notfound },
{"gtm_float_t", xc_float, xc_float_star, xc_notfound },
{"xc_float_t", xc_float, xc_float_star, xc_notfound },
{"float", xc_float, xc_float_star, xc_notfound },
{"gtm_double_t", xc_double, xc_double_star, xc_notfound },
{"xc_double_t", xc_double, xc_double_star, xc_notfound },
{"double", xc_double, xc_double_star, xc_notfound },
{"gtm_pointertofunc_t", xc_pointertofunc, xc_pointertofunc_star, xc_notfound },
{"xc_pointertofunc_t", xc_pointertofunc, xc_pointertofunc_star, xc_notfound }
};
char *b = *c;
char *d;
int len, i, star_count;
b = scan_space(b);
d = scan_ident(b);
if (!d)
return xc_notfound;
len = (int)(d - b);
for (i = 0 ; i < sizeof(xctab) / sizeof(xctab[0]) ; i++)
{
if ((0 == memcmp(xctab[i].nam, b, len)) && ('\0' == xctab[i].nam[len]))
{
/* got name */
/* scan stars */
for (star_count = 0;(MAXIMUM_STARS >= star_count);star_count++, d++)
{
d = scan_space(d);
if ('*' != *d)
break;
star_found = TRUE;
}
assert(star_count <= MAXIMUM_STARS);
*c = scan_space(d);
return xctab[i].typ[star_count];
}
}
return xc_notfound;
}
int JSON::parse_string(const char *begin, const char *end, std::string *out)
{
char const *ptr = begin;
ptr += scan_space(ptr, end);
if (*ptr == '\"') {
ptr++;
std::vector<char> vec;
while (ptr < end) {
if (*ptr == '\"') {
*out = to_stdstr(vec);
ptr++;
return ptr - begin;
} else if (*ptr == '\\') {
ptr++;
if (ptr < end) {
auto push = [&](char c){ vec.push_back(c); ptr++; };
switch (*ptr) {
case 'a': push('\a'); break;
case 'b': push('\b'); break;
case 'n': push('\n'); break;
case 'r': push('\r'); break;
case 'f': push('\f'); break;
case 't': push('\t'); break;
case 'v': push('\v'); break;
case '\\':
case '\'':
case '\"':
push(*ptr);
break;
case 'x':
ptr++;
if (ptr + 1 < end && isxdigit(ptr[0] & 0xff) && isxdigit(ptr[1] & 0xff)) {
char tmp[3];
tmp[0] = ptr[0];
tmp[1] = ptr[1];
tmp[2] = 0;
vec.push_back((char)strtol(tmp, 0, 16));
ptr += 2;
}
break;
default:
if (*ptr >= '0' && *ptr <= '7') {
int i;
int v = 0;
for (i = 0; i < 3; i++) {
if (ptr + i < end && ptr[i] >= '0' && ptr[i] <= '7') {
v = v * 8 + (ptr[i] - '0');
} else {
break;
}
}
vec.push_back(v);
ptr += i;
} else {
vec.push_back(*ptr);
ptr++;
}
break;
}
}
} else {
vec.push_back(*ptr);
ptr++;
}
}
}
return 0;
}
void do_assignment (header *var)
/***** do_assignment
assign a value to a variable.
*****/
{ header *variable[8],*rightside[8],*rs,*v,*mark;
int rscount,varcount,i,j;
ULONG offset,oldoffset,dif;
char *oldendlocal;
scan_space();
if (*next=='=')
{ next++;
nosubmref=1; rs=scan_value(); nosubmref=0;
if (error) return;
varcount=0;
/* count the variables, that get assigned something */
while (var<rs)
{ if (var->type!=s_reference && var->type!=s_submatrix
&& var->type!=s_csubmatrix && var->type!=s_isubmatrix)
{ output("Cannot assign to value!\n");
error=210;
}
variable[varcount]=var; var=nextof(var); varcount++;
if (varcount>=8)
{ output("To many commas!\n"); error=100; return;
}
}
/* count and note the values, that are assigned to the
variables */
rscount=0;
while (rs<(header *)newram)
{ rightside[rscount]=rs;
rs=nextof(rs); rscount++;
if (rscount>=8)
{ output("To many commas!\n"); error=101; return;
}
}
/* cannot assign 2 values to 3 variables , e.g. */
if (rscount>1 && rscount<varcount)
{ output("Illegal multiple assignment!\n"); error=102; return;
}
oldendlocal=endlocal;
offset=0;
/* do all the assignments */
if (varcount==1) var=assign(variable[0],rightside[0]);
else
for (i=0; i<varcount; i++)
{ oldoffset=offset;
/* assign a variable */
var=assign(addsize(variable[i],offset),
addsize(rightside[(rscount>1)?i:0],offset));
if (error) return;
offset=endlocal-oldendlocal;
if (oldoffset!=offset) /* size of var. changed */
{ v=addsize(variable[i],offset);
if (v->type==s_reference) mark=referenceof(v);
else mark=submrefof(v);
/* now shift all references of the var.s */
if (mark) /* not a new variable */
for (j=i+1; j<varcount; j++)
{ v=addsize(variable[j],offset);
dif=offset-oldoffset;
if (v->type==s_reference && referenceof(v)>mark)
referenceof(v)=addsize(referenceof(v),dif);
else if (submrefof(v)>mark)
submrefof(v)=addsize(submrefof(v),dif);
}
}
}
}
else /* just an expression which is a variable */
{ var=getvalue(var);
}
if (error) return;
if (*next!=';') give_out(var);
if (*next==',' || *next==';') next++;
}
void do_for (void)
/***** do_for
do a for command in a UDF.
for i=value to value step value; .... ; end
*****/
{ int h,signum;
char name[16],*jump;
header *hd,*init,*end,*step;
double vend,vstep;
struct { header hd; double value; } rv;
if (!udfon)
{ output("For only allowed in functions!\n"); error=57; return;
}
rv.hd.type=s_real; *rv.hd.name=0;
rv.hd.size=sizeof(header)+sizeof(double); rv.value=0.0;
scan_space(); scan_name(name); if (error) return;
kill_local(name);
newram=endlocal;
hd=new_reference(&rv.hd,name); if (error) return;
endlocal=newram=(char *)hd+hd->size;
scan_space(); if (*next!='=')
{ output("Syntax error in for.\n"); error=71; goto end;
}
next++; init=scan(); if (error) goto end;
init=getvalue(init); if (error) goto end;
if (init->type!=s_real)
{ output("Startvalue must be real!\n"); error=72; goto end;
}
rv.value=*realof(init);
scan_space(); if (strncmp(next,"to",2))
{ output("Endvalue missing in for!\n"); error=73; goto end;
}
next+=2;
end=scan(); if (error) goto end;
end=getvalue(end); if (error) goto end;
if (end->type!=s_real)
{ output("Endvalue must be real!\n"); error=73; goto end;
}
vend=*realof(end);
scan_space();
if (!strncmp(next,"step",4))
{ next+=4;
step=scan(); if (error) goto end;
step=getvalue(step); if (error) goto end;
if (step->type!=s_real)
{ output("Stepvalue must be real!\n"); error=73; goto end;
}
vstep=*realof(step);
}
else vstep=1.0;
signum=(vstep>=0)?1:-1;
vend=vend+signum*epsilon;
if (signum>0 && rv.value>vend) { scan_end(); goto end; }
else if (signum<0 && rv.value<vend) { scan_end(); goto end; }
newram=endlocal;
scan_space(); if (*next==';' || *next==',') next++;
jump=next;
while (!error)
{ if (*next==1)
{ output("End missing!\n");
error=401; goto end;
}
h=command();
if (udfon!=1 || h==c_return) break;
if (h==c_break) { scan_end(); break; }
if (h==c_end)
{ rv.value+=vstep;
if (signum>0 && rv.value>vend) break;
else if (signum<0 && rv.value<vend) break;
else next=jump;
if (test_key()==escape)
{ output("User interrupted!\n");
error=1; break;
}
}
}
end : kill_local(name);
}
