/**
Copies an array from the specified source array, beginning at the specified position,
to the specified position of the destination array. A subsequence of array components
are copied from the source array referenced by src to the destination array referenced
by dest. The number of components copied is equal to the length argument. T
he components at positions srcPos through srcPos+length-1 in the source array are
copied into positions destPos through destPos+length-1, respectively, of the
destination array.
If the src and dest arguments refer to the same array object, then the copying is performed as if the components at positions srcPos through srcPos+length-1 were first copied to a temporary array with length components and then the contents of the temporary array were copied into positions destPos through destPos+length-1 of the destination array.
If dest is null, then a NullPointerException is thrown.
If src is null, then a NullPointerException is thrown and the destination array is not modified.
Otherwise, if any of the following is true, an ArrayStoreException is thrown and the destination is not modified:
The src argument refers to an object that is not an array.
The dest argument refers to an object that is not an array.
The src argument and dest argument refer to arrays whose component types are different primitive types.
The src argument refers to an array with a primitive component type and the dest argument refers to an array with a reference component type.
The src argument refers to an array with a reference component type and the dest argument refers to an array with a primitive component type.
Otherwise, if any of the following is true, an IndexOutOfBoundsException is thrown and the destination is not modified:
The srcPos argument is negative.
The destPos argument is negative.
The length argument is negative.
srcPos+length is greater than src.length, the length of the source array.
destPos+length is greater than dest.length, the length of the destination array.
Otherwise, if any actual component of the source array from position srcPos through srcPos+length-1 cannot be converted to the component type of the destination array by assignment conversion, an ArrayStoreException is thrown. In this case, let k be the smallest nonnegative integer less than length such that src[srcPos+k] cannot be converted to the component type of the destination array; when the exception is thrown, source array components from positions srcPos through srcPos+k-1 will already have been copied to destination array positions destPos through destPos+k-1 and no other positions of the destination array will have been modified. (Because of the restrictions already itemized, this paragraph effectively applies only to the situation where both arrays have component types that are reference types.)
Parameters:
src the source array.
srcPos starting position in the source array.
dest the destination array.
destPos starting position in the destination data.
length the number of array elements to be copied.
Throws:
HaikuWRONG: IndexOutOfBoundsException - if copying would cause access of data outside array bounds.
Experiment (see ArrayIndexTest) shows that Sun'S JVM throws: ArrayIndexOutOfBoundsException
ArrayStoreException - if an element in the src array could not be stored into the dest array because of a type mismatch.
NullPointerException - if either src or dest is null.
*/
void native_java_lang_System_arraycopy_Ljava_lang_Object_ILjava_lang_Object_IIV() {
int length= top.s1.i;
int destPos= ipop();
array_t* dest= (array_t*) apop();
int srcPos= ipop();
array_t* src= (array_t*) apop();
int size;
popTop();
#if HAIKU_InternalExceptionEnable & NullPointerException
if (src==NULL || dest==NULL) {
throwException(NullPointerException, 0);
return;
}
#endif
#if HAIKU_InternalExceptionEnable & ArrayIndexOutOfBoundsException
if ( srcPos<0 ||destPos<0 ||length <0 || srcPos+length > src->length || destPos+length >dest->length) throwException(ArrayIndexOutOfBoundsException, srcPos);
#endif
if (length==0) return;
size=getSize(dest); // Hierhin wg. möglicher integer div by 0 (if dest->length==0)
#if HAIKU_InternalExceptionEnable & ArrayStoreException
if (size!=getSize(src)) throwException(ArrayStoreException, size);
#endif
if (!isExceptionThrown(NULL))
memcpy(dest->array+destPos*size, src->array+srcPos*size, length*size);
}
void
isetprompt(void)
{
nialptr z;
int t;
z = apop();
if (kind(z) == phrasetype || kind(z) == chartype) {
/* return old prompt */
apush(makephrase(prompt));
/* get new prompt */
if (kind(z) == phrasetype) {
t = tknlength(z);
if (t > MAXPROMPTSIZE)
goto spout;
strcpy(prompt, pfirstchar(z));
}
else if (kind(z) == chartype) {
t = tally(z);
if (t > MAXPROMPTSIZE)
goto spout;
strcpy(prompt, pfirstchar(z));
}
}
else
buildfault("arg to setprompt must be string or phrase");
freeup(z);
return;
spout:
freeup(apop()); /* old prompt already stacked */
buildfault("prompt too long");
}
/* sets various inter globals. The arg may be a phrase or string.
It is mapped to upper case to make the match.
*/
void
iset(void)
{
char *msg;
nialptr name = apop();
if (equalsymbol(name, "SKETCH")) {
msg = (sketch ? "sketch" : "diagram");
sketch = true;
}
else if (equalsymbol(name, "DIAGRAM")) {
msg = (sketch ? "sketch" : "diagram");
sketch = false;
}
else if (equalsymbol(name, "TRACE")) {
msg = (trace ? "trace" : "notrace");
trace = true;
}
else if (equalsymbol(name, "NOTRACE")) {
msg = (trace ? "trace" : "notrace");
trace = false;
}
else if (equalsymbol(name, "DECOR")) {
msg = (decor ? "decor" : "nodecor");
decor = true;
}
else if (equalsymbol(name, "NODECOR")) {
msg = (decor ? "decor" : "nodecor");
decor = false;
}
else if (equalsymbol(name, "LOG")) {
msg = (keeplog ? "log" : "nolog");
if (keeplog == false) {
keeplog = true;
}
}
else if (equalsymbol(name, "NOLOG")) {
msg = (keeplog ? "log" : "nolog");
if (keeplog) {
keeplog = false;
}
}
#ifdef DEBUG
else if (equalsymbol(name, "DEBUG")) {
msg = (debug ? "debug" : "nodebug");
debug = true;
}
else if (equalsymbol(name, "NODEBUG")) {
msg = (debug ? "debug" : "nodebug");
debug = false;
}
#endif
else {
apush(makefault("?unknown set type"));
freeup(name);
return;
}
apush(makephrase(msg));
freeup(name);
}
void
iload(void)
{
nialptr x = apop();
int n = ngetname(x, gcharbuf);
freeup(x);
if (n == 0)
buildfault("invalid file name");
else {
FILE *f1;
check_ext(gcharbuf, ".nws",FORCE_EXTENSION);
f1 = openfile(gcharbuf, 'r', 'b');
if (f1 == OPENFAILED) {
buildfault("cannot open nws file");
return;
}
wsfileport = f1;
/* jump to do1command */
longjmp(loadsave_env, NC_WS_LOAD);
}
#ifdef DEBUG
if (debug) {
memchk();
nprintf(OF_DEBUG, "after iload memchk\n");
}
#endif
}
void native_java_lang_Thread_setStateAndSwitch_II() {
native_java_lang_Thread* thisThread=(native_java_lang_Thread*) apop();
// extern int ccount[];
// int i;
// for(i=0; i<6; i++) {
// printf("%d -> %d\n", i, ccount[i]);
// };
thisThread->state=top.s1.i;
switchThread();
}
void
iloaddefs(void)
{
nialptr nm,
x = apop();
int mode;
/* get the file name as a Nial array */
if (atomic(x) || kind(x) == chartype)
nm = x;
else if (kind(x) == atype)
nm = fetch_array(x, 0);
else {
buildfault("invalid file name");
freeup(x);
return;
}
mode = 0; /* default to silent mode */
if (kind(x) == atype && tally(x) == 2) {
/* argument has a mode filed, select it */
nialptr it = fetch_array(x, 1);
if (kind(it) == inttype)
mode = intval(it);
if (kind(it) == booltype)
mode = boolval(it);
}
/* try to put filename into gcharbuf */
if (!ngetname(nm, gcharbuf)) {
buildfault("invalid file name");
freeup(x);
}
else
{ /* check the extension as .ndf */
check_ext(gcharbuf, ".ndf",NOFORCE_EXTENSION);
freeup(x); /* do freeup here so file name doesn't show in iusedspace */
/* load the definition file */
if (loaddefs(true, gcharbuf, mode)) {
apush(Nullexpr);
}
else
buildfault(errmsgptr); /* this is safe since call is from iloaddefs */
}
#ifdef DEBUG
memchk();
#endif
}
void
iedit(void)
{
nialptr nm = apop();
if (ngetname(nm, gcharbuf) == 0)
buildfault("invalid_name");
else {
calleditor(gcharbuf);
apush(Nullexpr);
}
freeup(nm);
}
nialptr
getuppername()
{
nialptr x = apop();
int n = ngetname(x, gcharbuf);
freeup(x);
if (n == 0)
return (grounded);
else {
cnvtup(gcharbuf);
return (makephrase(gcharbuf));
}
}
void
ihost()
{
nialptr x = apop();
if (ngetname(x, gcharbuf) == 0)
buildfault("invalid host command");
else {
if (command(gcharbuf) == NORMALRETURN) {
apush(Nullexpr);
}
else
buildfault(errmsgptr);
}
freeup(x);
}
void
isetprofile()
{
nialptr z;
int tv,
oldprofile = profile; /* old value of profiling switch */
z = apop();
if (kind(z) == inttype)
tv = intval(z);
else if (kind(z) == booltype)
tv = boolval(z);
else {
buildfault("invalid arg to setprofile");
return;
}
if (tv && !oldprofile) { /* turning on profiling */
profile = true;
if (newprofile) {
inittime();
calltree = make_node();
current_node = calltree;
/* initialize first node */
set_opid(calltree, 0); /* doesn't correspond to a defn */
set_start_time(calltree, profile_time());
/*
nprintf(OF_DEBUG,"start time for call tree%f\n",calltree->start_time);
*/
swplace = 0;
#ifdef OLD_BUILD_SYMBOL_TABLE
build_symbol_table();
#endif
newprofile = false;
}
}
else if (oldprofile != false) {
double lasttime = profile_time();
profile = false;
if (current_node != calltree) {
exit_cover(NC_PROFILE_SYNCH_W);
}
set_end_time(calltree, lasttime);
add_time(calltree);
}
apush(createbool(oldprofile));
}
void
isetdebugmessages(void)
{
nialptr x = apop();
int oldstatus = debug_messages_on;
if (atomic(x) && kind(x) == booltype)
debug_messages_on = boolval(x);
else if (atomic(x) && kind(x) == inttype)
debug_messages_on = intval(x);
else {
apush(makefault("?setdebugmessages expects a truth-value"));
freeup(x);
return;
}
apush(createbool(oldstatus));
}
void
isetlogname(void)
{
nialptr z;
if (kind(top) == phrasetype)
istring();
z = apop();
if (kind(z) != chartype || strlen(pfirstchar(z)) > MAXLOGFNMSIZE) {
buildfault("invalid log name");
}
else {
apush(makephrase(logfnm)); /* push current name */
strcpy(logfnm, pfirstchar(z));
}
freeup(z);
}
void
isetinterrupts()
{
nialptr x;
int oldstatus;
oldstatus = nouserinterrupts;
x = apop();
if (atomic(x) && kind(x) == booltype) {
nouserinterrupts = !boolval(x);
apush(createbool(!oldstatus));
}
else if (atomic(x) && kind(x) == inttype) {
nouserinterrupts = (intval(x) != 1);
apush(createbool(!oldstatus));
}
else
buildfault("setinterrupts expects a boolean");
}
void
isetwidth(void)
{
nialptr z;
nialint ts;
z = apop();
if (kind(z) == inttype) {
ts = intval(z);
if (ts >= 0) {
apush(createint(ssizew));
ssizew = ts;
}
else
buildfault("width out of range");
}
else
buildfault("width not an integer");
freeup(z);
}
void
isave(void)
{
nialptr x = apop();
int n = ngetname(x, gcharbuf);
freeup(x); /* not needed */
if (n == 0)
buildfault("invalid file name");
else {
FILE *f1;
check_ext(gcharbuf, ".nws",FORCE_EXTENSION);
f1 = openfile(gcharbuf, 'w', 'b');
if (f1 == OPENFAILED) {
buildfault("cannot open nws file");
return;
}
wsfileport = f1;
/* jump to do1command */
longjmp(loadsave_env, NC_WS_SAVE);
}
}
void PopCommand::execute()
{
if ( d->done )
return;
switch ( d->cmd ) {
case Quit:
log( "Closing connection due to QUIT command", Log::Debug );
d->pop->setState( POP::Update );
d->pop->ok( "Goodbye" );
break;
case Capa:
{
EString c( "TOP\r\n"
"UIDL\r\n"
"SASL\r\n"
"USER\r\n"
"RESP-CODES\r\n"
"PIPELINING\r\n"
"IMPLEMENTATION Archiveopteryx POP3 Server, "
"http://archiveopteryx.org.\r\n" );
if ( Configuration::toggle( Configuration::UseTls ) )
c.append( "STLS\r\n" );
c.append( ".\r\n" );
d->pop->ok( "Capabilities:" );
d->pop->enqueue( c );
}
break;
case Stls:
if ( !startTls() )
return;
break;
case Auth:
if ( !auth() )
return;
break;
case User:
if ( !user() )
return;
break;
case Pass:
if ( !pass() )
return;
break;
case Apop:
if ( !apop() )
return;
break;
case Session:
if ( !session() )
return;
break;
case Stat:
if ( !stat() )
return;
break;
case List:
if ( !list() )
return;
break;
case Top:
if ( !retr( true ) )
return;
break;
case Retr:
if ( !retr( false ) )
return;
break;
case Dele:
if ( !dele() )
return;
break;
case Noop:
d->pop->ok( "Done" );
break;
case Rset:
d->pop->ok( "Done" );
break;
case Uidl:
if ( !uidl() )
return;
break;
}
finish();
}
void
iprofile()
{
char sbuf[1000];
nialptr z;
FILE *prf = STDOUT;
int c1,
c2;
int i;
double real_total_time = 0;
double profile_duration_time;
int NMWIDTH = 30;
/* grab the argument */
z = apop();
if (newprofile) {
buildfault("no profile available");
freeup(z);
return;
}
/* handle input argument */
if (kind(z) == phrasetype) {
apush(z);
istring();
z = apop();
}
if (tally(z) != 0) {
if (!istext(z)) {
buildfault("profile file name arg is not text");
freeup(z);
return;
}
else {
prf = openfile(pfirstchar(z), 'w', 't');
if (prf == OPENFAILED) {
buildfault("unable to open specified file to write profile to");
freeup(z);
return;
/* exit_cover(NC_PROFILE_FILE_W); removed Nov 22/95 because this
* cleared profile information */
}
}
}
freeup(z);
/* If profiling is still on, then turn it off */
if (profile == true) {
apush(createbool(0));
isetprofile();
apop();
}
#ifndef OLD_BUILD_SYMBOL_TABLE
if (symtab)
free_symtab();
symtab = NULL;
build_symbol_table();
#endif
profile_duration_time = (calltree->total_time);
for (i = 0;i <calltree->num_children;i++) {
real_total_time += calltree->children[i]->total_time;
}
/* traverse the call tree placing nodes in the symbol table entries */
if (!traversed) {
traverse_tree(calltree);
traversed = true;
}
/* generate the output and place it in the output file or stdout */
/* if a filename has been specified then write that out */
if (tally(z)) {
sprintf(sbuf,"Profile output file: \"%s\"\n\n",pfirstchar(z));
writechars(prf, sbuf, strlen(sbuf), false);
}
sprintf(sbuf, "\nTotal execution time of profile session: \t%f\n", profile_duration_time);
writechars(prf, sbuf, strlen(sbuf), false);
sprintf(sbuf, "Total execution time in top level calls: \t%f\n\n",real_total_time);
writechars(prf, sbuf, strlen(sbuf), false);
/* header line for all data */
sprintf(sbuf, "op name[.tr arg] calls[rec] ");
writechars(prf, sbuf, strlen(sbuf), false);
sprintf(sbuf, "time time/call %% time\n");
writechars(prf, sbuf, strlen(sbuf), false);
for (c1 = 0; c1 < symtabsize; c1++) {
if ((symtab[c1]->num_locs > 0) || (symtab[c1]->num_rcalls > 0)) {
double totaloptime = 0;
int totalopcalls = 0;
int totalropcalls;
char *tmp;
for (c2 = 0; c2 < symtab[c1]->num_locs; c2++) {
if (symtab[c1]->id != symtab[c1]->locations[c2]->parent->opid)
/* omit adding calls and time for direct recursions */
{
totaloptime += symtab[c1]->locations[c2]->total_time;
totalopcalls += symtab[c1]->locations[c2]->total_calls;
}
}
totalropcalls = symtab[c1]->num_rcalls;
sprintf(sbuf, "%s%5d", (tmp = padright(NMWIDTH, (char *) symtab[c1]->name)),
totalopcalls);
writechars(prf, sbuf, strlen(sbuf), false);
free(tmp);
if (totalropcalls != 0) {
sprintf(sbuf, "[%5d]", totalropcalls);
writechars(prf, sbuf, strlen(sbuf), false);
}
else {
sprintf(sbuf, " ");
writechars(prf, sbuf, strlen(sbuf), false);
}
/* details for each definition */
sprintf(sbuf, "%8.2f %8.4f %8.1f%s\n",
totaloptime,
(totaloptime / totalopcalls),
100 * (totaloptime / real_total_time),
((symtab[c1]->toplevel_call == true)?"<":""));
writechars(prf, sbuf, strlen(sbuf), false);
{
struct node **chlist;
int c,
used;
char tname[40];
chlist = merge_children(symtab[c1], &used);
for (c = 0; c < used; c++) {
char *tmp;
if (chlist[c]->opid == symtab[c1]->id) /* recursions only counted */
break;
strcpy(tname, num_to_name(chlist[c]->opid));
/* details for each definition it calls */
if (chlist[c]->total_time > 0.0)
sprintf(sbuf, " %s%5d %8.2f %8.4f %8.2f\n",
(tmp = padright(NMWIDTH - 1, tname)),
chlist[c]->total_calls,
chlist[c]->total_time,
chlist[c]->total_time / chlist[c]->total_calls,
100 * (chlist[c]->total_time / totaloptime));
else
sprintf(sbuf, " %s%5d %8.2f %8.4f %8.2f\n",
(tmp = padright(NMWIDTH - 1, tname)),
chlist[c]->total_calls,
chlist[c]->total_time,
0.0, 0.0);
writechars(prf, sbuf, strlen(sbuf), false);
free(tmp);
}
free_merge_list(chlist, used);
}
sprintf(sbuf, "\n");
writechars(prf, sbuf, strlen(sbuf), false);
}
}
if (prf != STDOUT)
closefile(prf);
apush(Nullexpr);
return;
}
void
iprofiletable()
{
nialptr result; /* result to be returned */
int c1,
c2;
int num_funs = 0; /* total number of used functions */
int pos = 0; /* current count of used fucntions */
if (newprofile) {
buildfault("no profile available");
return;
}
#ifndef OLD_BUILD_SYMBOL_TABLE
if (symtab)
free_symtab();
symtab = NULL;
build_symbol_table();
#endif
/* If profiling is still on, then turn it off */
if (profile == true) {
apush(createbool(0));
isetprofile();
apop();
}
/* traverse the call tree placing nodes in the symbol table entries */
if (!traversed) {
traverse_tree(calltree);
traversed = true;
}
/* count the number of called functions so we know how big to
make the container array. Funcitons in the symbol table that
are not called at all are excluded */
for (c1 = 0; c1 < symtabsize; c1++)
if ((symtab[c1]->num_locs > 0) || (symtab[c1]->num_rcalls > 0))
num_funs++;
/* create the outer most container to hold the table */
result = new_create_array(atype, 1, 0, &num_funs);
for (c1 = 0; c1 < symtabsize; c1++) {
if ((symtab[c1]->num_locs > 0) || (symtab[c1]->num_rcalls > 0)) {
double totaloptime = 0;
int totalopcalls = 0;
int totalropcalls;
int len = 5;
/* create the table entry */
nialptr table_entry = new_create_array(atype, 1, 0, &len);
/* store it in the outer table */
store_array(result, pos, table_entry);
for (c2 = 0; c2 < symtab[c1]->num_locs; c2++) {
if (symtab[c1]->id != symtab[c1]->locations[c2]->parent->opid)
/* omit adding calls and time for direct recursions */
{
totaloptime += symtab[c1]->locations[c2]->total_time;
totalopcalls += symtab[c1]->locations[c2]->total_calls;
}
}
totalropcalls = symtab[c1]->num_rcalls;
/* fill in the cells in the table entry */
store_array(table_entry, 0, makephrase(symtab[c1]->name));
store_array(table_entry, 1, createint(totalopcalls));
store_array(table_entry, 2, createint(totalropcalls));
store_array(table_entry, 3, createreal(totaloptime));
{
struct node **chlist;
nialptr child_array;
int c,
used,
cpos = 0;
int children = 0;
chlist = merge_children(symtab[c1], &used);
for (c = 0; c < used; c++)
if (chlist[c]->opid != symtab[c1]->id) /* recursions only counted */
children++;
child_array = new_create_array(atype, 1, 0, &children);
store_array(table_entry, 4, child_array);
for (c = 0; c < used; c++) {
nialptr child_entry;
int len = 5;
if (chlist[c]->opid == symtab[c1]->id) /* recursions only counted */
break;
/* create each child entry and place it in the child list */
child_entry = new_create_array(atype, 1, 0, &len);
store_array(child_array, cpos, child_entry);
/* fill in the information about the child entry */
store_array(child_entry, 0, makephrase(num_to_name(chlist[c]->opid)));
store_array(child_entry, 1, createint(chlist[c]->total_calls));
store_array(child_entry, 2, createint(0));
store_array(child_entry, 3, createreal(chlist[c]->total_time));
store_array(child_entry, 4, Null);
cpos++;
}
free_merge_list(chlist, used);
}
}
pos++;
}
apush(result);
}
void
ifromraw(void)
{
nialptr z = apop();
nialptr res;
int slen;
int totype;
int dataerror = 0;
int numelements;
nialptr bools;
if (tally(z) != 2) {
apush(makefault("?Must supply a type and a value to fromraw"));
freeup(z);
return;
}
totype = kind(fetch_array(z, 0));
if (totype == atype) {
apush(makefault("?fromraw cannot convert to a nested array"));
freeup(z);
return;
}
bools = fetch_array(z, 1);
if ((kind(bools) != booltype)) {
apush(makefault("?Must supply a Boolean value to fromraw"));
freeup(z);
return;
}
/* no conversion needed */
if (totype == booltype) {
apush(bools);
freeup(z);
return;
}
/* compute number of elements by type and validate length of bools */
slen = 0;
switch (totype) {
case inttype:
numelements = tally(bools) / sizeof(int);
if (tally(bools) % sizeof(int) != 0)
dataerror = 1;
break;
case realtype:
numelements = tally(bools) / sizeof(double);
if (tally(bools) % sizeof(double) != 0)
dataerror = 1;
break;
case phrasetype:
case faulttype:
slen = tally(bools) / sizeof(char);
numelements = 1;
case chartype:
numelements = tally(bools) / sizeof(char);
break;
}
numelements /= 8;
if (dataerror) {
apush(makefault("?fromraw must have correct multiple of bools for desired datatype"));
freeup(z);
return;
}
/* create the result copy */
res = new_create_array(totype, 1, slen, &numelements);
/* do the data copy */
switch (totype) {
case inttype:
memcpy(pfirstchar(res), pfirstchar(bools), tally(bools) / 8);
break;
case realtype:
memcpy_fwo(pfirstchar(res), pfirstchar(bools), tally(bools) / 8, MCPY_FROMRAW);
break;
/* Have to use strncpy here to preserve the data */
case chartype:
case phrasetype:
case faulttype:
memcpy_fbo(pfirstchar(res), pfirstchar(bools), tally(bools) / 8, MCPY_FROMRAW);
break;
}
if (totype == chartype)
*(pfirstchar(res) + numelements) = '\0';
apush(res);
freeup(z);
return;
}
void
itoraw(void)
{
nialptr z = apop();
nialptr res;
int bits = 0;
/* can only convert non-nested arrays */
if (kind(z) == atype) {
apush(makefault("?Must supply a non-nested array value to toraw"));
freeup(z);
return;
}
/* if we are given a bool array then just return it */
if (kind(z) == booltype) {
apush(z);
return;
}
/* for the remaining types, calculate the number of bytes */
switch (kind(z)) {
case inttype:
bits = tally(z) * sizeof(nialint);
break;
case realtype:
bits = tally(z) * sizeof(double);
break;
case chartype:
bits = tally(z);
break;
case phrasetype:
case faulttype:
bits = strlen(pfirstchar(z));
break;
}
/* from bytes to bits */
bits *= 8;
/* Create the new array */
res = new_create_array(booltype, 1, 0, &bits);
/* This assumes the same order of bools and a bool array shows */
/* do the data copy */
switch (kind(z)) {
case inttype:
memcpy(pfirstchar(res), pfirstchar(z), bits / 8);
break;
case realtype:
memcpy_fwo(pfirstchar(res), pfirstchar(z), bits / 8, MCPY_TORAW);
break;
/* Have to use strncpy here to preserve the data */
case chartype:
case phrasetype:
case faulttype:
memcpy_fbo(pfirstchar(res), pfirstchar(z), bits / 8, MCPY_TORAW);
break;
}
/* push the result and leave */
apush(res);
freeup(z);
return;
}
void
iinverse()
{
nialptr a,
aa = Null,
x;
int va,
afreed;
nialint n,
i,
j;
double *ptr;
char errmsg[80];
a = apop();
va = valence(a);
if (va != 2) {
buildfault("incorrect valence in inverse");
freeup(a);
return;
}
n = pickshape(a, 0);
if (n != pickshape(a, 1)) {
buildfault("matrix is not square in inverse");
freeup(a);
return;
}
afreed = false;
switch (kind(a)) {
case booltype:
aa = bool_to_real(a); /* makes a real copy of a */
afreed = true;
break;
case inttype:
aa = int_to_real(a); /* makes a real copy of a */
afreed = true;
break;
case realtype:
{ /* make a real copy of a */
aa = new_create_array(realtype, va, 0, shpptr(a, va));
copy(aa, 0, a, 0, tally(a));
break;
}
case chartype:
case phrasetype:
case faulttype:
{
buildfault("arg not numeric type in inverse");
freeup(a);
return;
}
case atype:
{
nialint i = 0;
if (!simple(a)) {
buildfault("arg not simple in inverse");
freeup(a);
return;
}
while (i < tally(a)) {
if (!numeric(kind(fetch_array(a, i)))) {
buildfault("arg not numeric type in inverse");
freeup(a);
return;
}
i++;
}
aa = to_real(a); /* makes a real copy of a */
}
}
/* initialize x to a real identity matrix */
x = new_create_array(realtype, va, 0, shpptr(aa, va));
ptr = pfirstreal(x);
for (i = 0; i < n; i++)
for (j = 0; j < n; j++)
*ptr++ = (i == j ? 1.0 : 0.0);
if (Gausselim(pfirstreal(aa), pfirstreal(x), n, n, errmsg)) {
apush(x);
}
else {
buildfault(errmsg);
freeup(x);
}
freeup(aa); /* the modified copy of a has to be freed */
/* if a direct copies of a was made, then it needs to be freed up. the
* conversion routine does its own freeup. */
if (!afreed)
freeup(a);
}
void
isolve()
{
nialptr z,
a,
aa = Null,
b,
x = Null;
int va,
vb,
afreed,
bfreed;
nialint n,
nrhs;
char errmsg[80];
z = apop();
if (tally(z) != 2) {
buildfault("arg to solve not a pair");
freeup(z);
return;
}
splitfb(z, &a, &b);
va = valence(a);
vb = valence(b);
if (va != 2 || vb > 2) {
buildfault("incorrect valence in solve");
freeup(a);
freeup(b);
freeup(z);
return;
}
n = pickshape(a, 0);
if (n != pickshape(a, 1) || n != pickshape(b, 0)) {
buildfault("shapes do not conform in solve");
freeup(a);
freeup(b);
freeup(z);
return;
}
bfreed = false;
switch (kind(b)) {
case booltype:
x = bool_to_real(b);
bfreed = true;
break;
case inttype:
x = int_to_real(b);
bfreed = true;
break;
case realtype:
{ /* make a copy of b in x */
x = new_create_array(realtype, vb, 0, shpptr(b, vb));
copy(x, 0, b, 0, tally(b));
break;
}
case chartype:
case phrasetype:
case faulttype:
{
buildfault("second arg not numeric type in solve");
freeup(a);
freeup(b);
freeup(z);
return;
}
case atype:
{
nialint i = 0;
if (!simple(b)) {
buildfault("second arg not simple in solve");
freeup(a);
freeup(b);
freeup(z);
return;
}
while (i < tally(b)) {
if (!numeric(kind(fetch_array(b, i)))) {
buildfault("second arg not numeric type in solve");
freeup(a);
freeup(b);
freeup(z);
return;
}
i++;
}
x = to_real(b); /* makes a copy of b as reals */
}
}
afreed = false;
switch (kind(a)) {
case booltype:
aa = bool_to_real(a); /* makes a copy of a as reals */
afreed = true;
break;
case inttype:
aa = int_to_real(a); /* makes a copy of a as reals */
afreed = true;
break;
case realtype:
{ /* makes a copy of a */
aa = new_create_array(realtype, va, 0, shpptr(a, va));
copy(aa, 0, a, 0, tally(a));
break;
}
case chartype:
case phrasetype:
case faulttype:
{
buildfault("first arg not numeric type in solve");
freeup(a);
if (!bfreed)
freeup(b);
freeup(z);
freeup(x);
return;
}
case atype:
{
nialint i = 0;
if (!simple(a)) {
buildfault("first arg not simple in solve");
freeup(a);
if (!bfreed)
freeup(b);
freeup(z);
freeup(x);
return;
}
while (i < tally(a)) {
if (!numeric(kind(fetch_array(a, i)))) {
buildfault("first arg not numeric type in solve");
freeup(a);
if (!bfreed)
freeup(b);
freeup(z);
freeup(x);
return;
}
i++;
}
aa = to_real(a); /* makes a copy of a as reals */
}
}
nrhs = (vb == 1 ? 1 : pickshape(x, 1));
/* use the Gaussian elimination algorithm to solve the equation(s) */
if (Gausselim(pfirstreal(aa), pfirstreal(x), n, nrhs, errmsg)) {
apush(x);
}
else {
buildfault(errmsg);
freeup(x);
}
freeup(aa); /* the modified copy of a has to be freed */
if (!bfreed)
freeup(b);
if (!afreed)
freeup(a);
freeup(z);
}
void
iinnerproduct()
{
nialptr z,
a,
b,
x;
int va,
vb,
vx,
replicatea,
replicateb;
nialint m,
n,
bn,
p,
i,
j,
k,
sh[2];
double sum,
*ap,
*bp,
*xp;
z = apop();
if (tally(z) != 2) {
buildfault("arg to innerproduct not a pair");
freeup(z);
return;
}
splitfb(z, &a, &b);
va = valence(a);
vb = valence(b);
if (va > 2 || vb > 2) {
buildfault("incorrect valence in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
/* ensure b is realtype */
switch (kind(b)) {
case booltype:
b = bool_to_real(b);
break;
case inttype:
b = int_to_real(b);
break;
case realtype:
break;
case chartype:
case phrasetype:
case faulttype:
{
buildfault("second arg not numeric type in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
case atype:
{
nialint i = 0;
if (!simple(b)) {
buildfault("arg not simple in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
while (i < tally(b)) {
if (!numeric(kind(fetch_array(b, i)))) {
buildfault("second arg not numeric type in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
i++;
}
b = to_real(b); /* safe because freeup(z) will clear old b */
}
}
/* ensure a is realtype */
switch (kind(a)) {
case booltype:
a = bool_to_real(a);
break;
case inttype:
a = int_to_real(a);
break;
case realtype:
break;
case chartype:
case phrasetype:
case faulttype:
{
buildfault("first arg not numeric type in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
case atype:
{
nialint i = 0;
if (!simple(a)) {
buildfault("first arg not simple in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
while (i < tally(a)) {
if (!numeric(kind(fetch_array(a, i)))) {
buildfault("first arg not numeric type in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
i++;
}
a = to_real(a); /* safe becasue freeup of z clears old a */
}
}
if (va == 0) {
m = 1;
n = 1;
}
else if (va == 1) {
m = 1;
n = pickshape(a, 0);
}
else {
m = pickshape(a, 0);
n = pickshape(a, 1);
}
if (vb == 0) {
bn = 1;
p = 1;
}
else if (vb == 1) {
bn = pickshape(b, 0);
p = 1;
}
else {
bn = pickshape(b, 0);
p = pickshape(b, 1);
}
replicatea = (va == 0);
replicateb = (vb == 0);
if (!(replicatea || replicateb) && n != bn) {
buildfault("conform error in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
/* get valence for the result */
vx = (va <= 1 ? (vb <= 1 ? 0 : 1) : (vb <= 1 ? 1 : 2));
if (vx == 2) {
sh[0] = m;
sh[1] = p;
}
else if (vx == 1)
sh[0] = (va == 2 ? m : p);
/* if vx==0 then sh is not used */
/* allocate space for the result matrix */
x = new_create_array(realtype, vx, 0, sh);
ap = pfirstreal(a); /* safe: no allocations */
bp = pfirstreal(b); /* safe: no allocations */
xp = pfirstreal(x); /* safe: no allocations */
/* type of loop chosen on the kind of ip being done */
if (vx == 2) { /* matrix - matrix */
for (i = 0; i < m; i++) {
for (j = 0; j < p; j++) {
sum = 0.;
for (k = 0; k < n; k++)
sum += *(ap + (n * i + k)) * *(bp + (p * k + j));
*(xp + (p * i + j)) = sum;
}
checksignal(NC_CS_NORMAL);
}
}
else if (va == 2) { /* matrix - vector */
for (i = 0; i < m; i++) {
sum = 0.;
if (replicateb)
for (k = 0; k < n; k++)
sum += *(ap + (n * i + k)) * *bp;
else
for (k = 0; k < n; k++)
sum += *(ap + (n * i + k)) * *(bp + k);
*(xp + i) = sum;
}
}
else if (vb == 2) { /* vector - matrix */
for (j = 0; j < p; j++) {
sum = 0.;
if (replicatea)
for (k = 0; k < bn; k++)
sum += *ap * *(bp + (p * k + j));
else
for (k = 0; k < bn; k++)
sum += *(ap + k) * *(bp + (p * k + j));
*(xp + j) = sum;
}
}
else { /* vector - vector */
sum = 0.;
if (replicatea)
for (k = 0; k < bn; k++)
sum += *ap * *(bp + k);
else if (replicateb)
for (k = 0; k < n; k++)
sum += *(ap + k) * *bp;
else
for (k = 0; k < n; k++)
sum += *(ap + k) * *(bp + k);
*xp = sum;
}
apush(x);
freeup(a);
freeup(b);
freeup(z);
}
void
iregisterdllfun(void)
{
int i,
index;
ResType argtypes[MAX_ARGS]; /* list of types of arguments */
bool vararg[MAX_ARGS]; /* is the argument a variable arg */
bool ispointer[MAX_ARGS]; /* is the argument a pointer */
int varargcount = 0; /* number of variable args */
int ispointercount = 0; /* number of pointer args */
nialptr z = apop();
char *nialname; /* names used by calldllfun */
char *dllname; /* the real name of the function */
/* in the DLL file */
char *library; /* name of the DLL file */
ResType resulttype; /* the type of the result */
nialptr nargtypes; /* the arg type array */
int argcount;
int j;
int sz;
nialptr current; /* usually hold the current entry in the dlllist */
int is_register;
/* if we have 5 args we are registering a function */
if ((tally(z) == 5) && (kind(z) == atype))
is_register = 1; /* register mode */
else
/* only one arg and it is a char or a phrase, we are deleting the fun */
if ((kind(z) == chartype) || (kind(z) == phrasetype))
is_register = 0; /* delete mode */
else { /* error mode */
apush(makefault("?Incorrect number of arguments to registerdllfun"));
freeup(z);
return;
}
if (is_register) {
/* The Nial level name for the DLL function */
STRING_CHECK(z, 0)
nialname = STRING_GET(z, 0);
/* The internal DLL name for the function */
STRING_CHECK(z, 1)
dllname = STRING_GET(z, 1);
/* The name of the library file */
STRING_CHECK(z, 2)
library = STRING_GET(z, 2);
/* The name of the result type */
STRING_CHECK(z, 3)
resulttype = StringToTypeID(STRING_GET(z, 3));
/* did we find an unrecognized result type? */
if (resulttype < 0) {
apush(makefault("?Return type not recognized"));
freeup(z);
return;
}
if (kind(fetch_array(z, 4)) != atype) {
apush(makefault("?Argument must be a list of strings or phrases"));
freeup(z);
return;
}
nargtypes = fetch_array(z, 4);
argcount = tally(nargtypes);
/* Check each of the argument type */
for (j = 0; j < argcount; j++)
STRING_CHECK_FREEUP(nargtypes, j, z)
/* create an integer list of argument types from the phrase/string list */
for (i = 0; i < argcount; i++) {
char *tmp;
tmp = pfirstchar(fetch_array(nargtypes, i)); /* safe: no allocation */
argtypes[i] = StringToTypeID(tmp);
/* the ith argument name was not recognized */
if (argtypes[i] < 0) {
char stmp[256];
wsprintf(stmp, "?Type \"%s\" for argument %d not recognized", tmp, i + 1);
apush(makefault(stmp));
freeup(z);
return;
}
/* set the vararg and ispointer flags for this arg */
vararg[i] = IsVarArg(tmp);
ispointer[i] = IsPointer(tmp);
/* keep count of these special args */
if (vararg[i])
varargcount++;
if (ispointer[i])
ispointercount++;
}
/* NEW workspace Version */
/* If the list does not yet exist, then create a one element list here */
if (tally(dlllist) == 0) {
nialptr tmp = create_new_dll_entry; /* build a empty entry */
setup_dll_entry(tmp) /* fill it with empty data */
apush(tmp);
isolitary(); /* make it a list */
decrrefcnt(dlllist);
freeup(dlllist);
dlllist = apop();
incrrefcnt(dlllist);
index = 0;
}
else {
int pos;
/* does the requested name already exist in out list? */
if ((pos = inlist(nialname)) >= 0) {
/* yes it's here already, so note its position, and free the old
* entry */
index = pos;
freeEntry(index);
}
else {
/* if we got here, then we need to create a new entry and add it to
* and existing dlllist */
nialptr tmp = create_new_dll_entry;
setup_dll_entry(tmp)
decrrefcnt(dlllist);
append(dlllist, tmp);
dlllist = apop();
incrrefcnt(dlllist);
index = tally(dlllist) - 1; /* this is the location of the new entry */
}
}
/* grab the entry to work on */
current = fetch_array(dlllist, index);
/* fill in data */
set_handle(current, NULL);
set_nialname(current, nialname);
set_dllname(current, dllname);
set_callingconvention(current, (dllname[0] == '_' ? C_CALL : PASCAL_CALL));
set_library(current, library);
set_isloaded(current, false);
set_resulttype(current, resulttype);
set_argcount(current, argcount);
set_varargcount(current, varargcount);
set_ispointercount(current, ispointercount);
sz = argcount;
replace_array(current, 10, (sz == 0 ? Null : new_create_array(inttype, 1, 0, &sz)));
for (j = 0; j < sz; j++)
set_argtypes(current, j, argtypes[j]);
replace_array(current, 11, (sz == 0 ? Null : new_create_array(booltype, 1, 0, &sz)));
for (j = 0; j < sz; j++)
set_ispointer(current, j, ispointer[j]);
replace_array(current, 14, (sz == 0 ? Null : new_create_array(booltype, 1, 0, &sz)));
for (j = 0; j < sz; j++)
set_vararg(current, j, vararg[j]);
}
else { /* delete entry code */
int
loaddefs(int fromfile, char *fname, int mode)
{
nialptr ts;
int repeatloop,
keepreading,
nolines,
inremark,
linecnt;
FILE *f1 = NULL; /* initialized to avoid complaint */
int errorsfound;
if (fromfile) {
f1 = openfile(fname, 'r', 't');
if (f1 == OPENFAILED)
return (false);
pushsysfile(f1);
}
/* a loaddefs always affects the global environment. We reset current_env to
relect this. The code to restore the environment is below. This must be
saved on the stack, otherwise it can get thrown away since it may only
be owned by a transient definition value. The following example failed
before I protected this on the stack: retry is { host 'vi bug.ndf';
loaddefs"bug l } where this definition was in the file bug.ndf. */
apush(current_env);
current_env = Null;
ts = topstack; /* to monitor stack growth on each action */
errorsfound = 0; /* reset parse error counter */
repeatloop = true;
linecnt = 0;
/* loop to pick up groups of lines */
while (repeatloop) {
/* continue as long as their are line groups */
/* test on each circuit if an interrupt signal has been posted */
#ifdef USER_BREAK_FLAG
if (fromfile)
checksignal(NC_CS_NORMAL);
#endif
inremark = false;
nolines = 0;
keepreading = true;
/* loop to pick up lines until a whitespace line occurs */
while (keepreading) {
if (fromfile) {
/* reading a line from the file */
readfileline(f1, (mode ? 2 : 0)); /* mode==2 only in a loaddefs */
/* readfileline places result on the stack */
if (top == Eoffault) {
apop(); /* to remove the end of file marker */
repeatloop = false;
break; /* to end read loop */
}
}
else {
/* select a line from array defsndf loadded from defstbl.h */
char *line;
line = defsndf[linecnt++];
if (linecnt == NOLINES) {
repeatloop = false;
keepreading = false; /* to end read loop */
}
mkstring(line); /* convert the line to a Nial string and push it */
}
if (nolines == 0) { /* check first line of group for a remark */
char firstchar;
int i = 0;
/* loop to skip blanks */
while (i < tally(top) && fetch_char(top, i) <= BLANK)
i++;
/* note whether first char is "#" */
firstchar = fetch_char(top, i);
if (tally(top))
inremark = firstchar == HASHSYMBOL;
else
inremark = false;
}
/* if the line is all while space then we are at the end of a group */
if (top == Null || allwhitespace(pfirstchar(top))) {
keepreading = false;
freeup(apop()); /* to get rid of the empty line */
}
else /* count the line on the stack */
nolines++;
}
/* we have a group of lines to process */
if (nolines > 0) {
mklist(nolines); /* create a list of lines and link them*/
ilink();
if (inremark) {
freeup(apop()); /* remarks are ignored */
}
else
{
/* carry out the actions of the main loop */
iscan();
parse(true);
/* check whether parse produced an error */
if (kind(top) == faulttype) {
if (top != Nullexpr) {
errorsfound++;
if (mode == 0) { /* show error message */
apush(top);
ipicture();
show(apop());
}
}
}
/* evaluate the parse tree, if it is a fault, it is the value returned */
ieval();
#ifdef DEBUG
memchk();
#endif
if (mode) { /* show the result */
if (top != Nullexpr) {
ipicture();
show(apop());
}
else
apop(); /* the Nullexpr */
}
else
freeup(apop()); /* free because it might not be Nullexpr */
}
if (mode) { /* now display empty line */
writechars(STDOUT, "", (nialint) 0, true);
if (keeplog && f1 == STDIN)
writelog("", 0, true);
}
}
/* check that the stack hasn't grown */
if (ts != topstack) {
while (ts != topstack)
freeup(apop());
exit_cover(NC_STACK_GROWN_I);
}
}
/* done reading groups of lines */
if (fromfile) {
closefile(f1);
popsysfile();
}
/* restore the current_env */
current_env = apop();
if (errorsfound > 0)
nprintf(OF_NORMAL_LOG, "errors found: %d\n", errorsfound);
return (true);
}
void
main(int argc, char *argv[])
{
char buf[TICKREQLEN];
Ticketreq tr;
ARGBEGIN{
case 'd':
debug++;
}ARGEND
strcpy(raddr, "unknown");
if(argc >= 1)
getraddr(argv[argc-1]);
alarm(10*60*1000); /* kill a connection after 10 minutes */
db = ndbopen("/lib/ndb/auth");
if(db == 0)
syslog(0, AUTHLOG, "no /lib/ndb/auth");
srand(time(0)*getpid());
for(;;){
if(readn(0, buf, TICKREQLEN) <= 0)
exits(0);
convM2TR(buf, &tr);
switch(buf[0]){
case AuthTreq:
ticketrequest(&tr);
break;
case AuthChal:
challengebox(&tr);
break;
case AuthPass:
changepasswd(&tr);
break;
case AuthApop:
apop(&tr, AuthApop);
break;
case AuthChap:
chap(&tr);
break;
case AuthMSchap:
mschap(&tr);
break;
case AuthCram:
apop(&tr, AuthCram);
break;
case AuthHttp:
http(&tr);
break;
case AuthVNC:
vnc(&tr);
break;
default:
syslog(0, AUTHLOG, "unknown ticket request type: %d", buf[0]);
exits(0);
}
}
/* not reached */
}
