globle void PrognFunction(
DATA_OBJECT_PTR returnValue)
{
int numa, i;
numa = RtnArgCount();
if (numa == 0)
{
returnValue->type = SYMBOL;
returnValue->value = FalseSymbol;
return;
}
i = 1;
while ((i <= numa) && (GetHaltExecution() != TRUE))
{
RtnUnknown(i,returnValue);
if ((BreakFlag == TRUE) || (ReturnFlag == TRUE))
break;
i++;
}
if (GetHaltExecution() == TRUE)
{
returnValue->type = SYMBOL;
returnValue->value = FalseSymbol;
return;
}
return;
}
/**
* CLIPS function that is responsible for calling
* ruby objects
*/
void cl_rcall()
{
int argc = RtnArgCount();
// Sanity check
if(argc < 2) return;
// Get object and method
char *s_obj = RtnLexeme(1);
char *s_mtd = RtnLexeme(2);
// Get variant as I need them
VALUE obj; sscanf(s_obj, "%lx", &obj);
ID mtd = rb_intern(s_mtd);
if(argc == 2)
{
rb_funcall(obj, mtd, 0);
} else {
VALUE argv[argc - 2];
int i;
for(i = 3; i <= argc; i++)
{
DATA_OBJECT argument;
RtnUnknown(i, &argument);
argv[i - 3] = cl_generic_convert_dataobject(argument);
}
rb_funcall2(obj, mtd, argc-2, argv);
}
}
/*eg. (addrunfnc "nrecv_route" "nrecv_route" 1)*/
int addrunfnc()
{
char str[99],fnc[99];
int priority=1,start=0,remove=0,cnt;
cnt= RtnArgCount();
sprintf(str,"%s",(char *)RtnLexeme(1));
sprintf(fnc,"%s",(char *)RtnLexeme(2));
if(cnt>2) priority = (int)RtnLong(3);
if(cnt>3) start = (int)RtnLong(4);
if(cnt>4) remove = (int)RtnLong(5);
if(!remove)
{
/* if(start==1) return(AddRunStartFunction(str,PTIF fnc,priority));*/
/* else if(start==2) return(AddRunStopFunction(str,PTIF fnc,priority));*/
/* else */
/*bad argument 2 type for AddRunFunction(): int (*)() ( void (*)() expected)*/
return(AddRunFunction(str,PTIF2 fnc,priority));
} else
{
/* if(start==1) return(RemoveRunStartFunction(str));*/
/* else if(start==2) return(RemoveRunStopFunction(str));*/
/* else */
return(RemoveRunFunction(str));
}
}
globle void ReturnFunction(
DATA_OBJECT_PTR result)
{
if (RtnArgCount() == 0)
{
result->type = RVOID;
result->value = FalseSymbol;
}
else
RtnUnknown(1,result);
ReturnFlag = TRUE;
}
/*ret: 1st element at the ptr memory location*/
VOID deref(DATA_OBJECT_PTR rp)
{
int n,i,j,*npi,ret=0,t;
float *npf;
char tstr[89],type,*sp;
n = RtnArgCount();
printf("[ac=%d]",n);
sprintf(tstr,"%s",(char *)RtnLexeme(1));
type = tolower(tstr[0]);
switch(type)
{
case 'i': npi = (int *)get_ptr(2);
break;
case 'f': npf = (float *)get_ptr(2);
break;
case 'b': sp = (char *)get_ptr(2);
break;
default: printf("bad type %s\n",tstr);
break;
}
if(n > 2) /*then set the values*/
{
for(i=3; i<=n; i++)
{
switch(type)
{
case 'i': printf("[set%d at%d]",(npi[i-3] = get_int(i)),i); break;
case 'f': printf("[set%f at%d]",(npf[i-3] = get_float(i)),i); break;
case 'b': get_str(i,tstr); /*fix-finish*/
t = strlen(tstr);
for(j=0; j<t; j++)
printf("[%c]",(sp[j] = tstr[j]));
break;
}
}
switch(type) /*if setting want ptr, which might be newly malloced*/
{
case 'i' : set_long(rp,(long)npi); break;
case 'f' : set_long(rp,(long)npf); break;
case 'b' : set_long(rp,(long)sp); break;
}
}
else
switch(type)
{
case 'i' : set_int(rp,(int)npi[0]); break;
case 'f' : set_float(rp,(float)npf[0]); break;
case 'b' : printf("[str=%s]",sp);
set_symb(rp,(char *)sp); break;
}
return;
}
/*DefineFunction2("memset",'i',PTIF mem_set,"mem_set","23uuik"); */
int mem_set() /*bzero( a, n )*/
{
int n;
char *a,b='\0',z[9];
a=(char *)get_ptr(1);
n = (int)RtnLong(2);
if(RtnArgCount() >2) {
sprintf(z,"%s",(char *)RtnLexeme(3));
b=z[0];
}
if(!a && !b) {memset(a,b,n); return(0);}
else printf("[memset nil ptr]");
return(1);
}
/***********************************************************
NAME : ClassInfoFnxArgs
DESCRIPTION : Examines arguments for:
class-slots, get-defmessage-handler-list,
class-superclasses and class-subclasses
INPUTS : 1) Name of function
2) A buffer to hold a flag indicating if
the inherit keyword was specified
RETURNS : Pointer to the class on success,
NULL on errors
SIDE EFFECTS : inhp flag set
error flag set
NOTES : None
***********************************************************/
globle void *ClassInfoFnxArgs(
char *fnx,
int *inhp)
{
void *clsptr;
DATA_OBJECT tmp;
*inhp = 0;
if (RtnArgCount() == 0)
{
ExpectedCountError(fnx,AT_LEAST,1);
SetEvaluationError(TRUE);
return(NULL);
}
if (ArgTypeCheck(fnx,1,SYMBOL,&tmp) == FALSE)
return(NULL);
clsptr = (void *) LookupDefclassByMdlOrScope(DOToString(tmp));
if (clsptr == NULL)
{
ClassExistError(fnx,ValueToString(tmp.value));
return(NULL);
}
if (RtnArgCount() == 2)
{
if (ArgTypeCheck(fnx,2,SYMBOL,&tmp) == FALSE)
return(NULL);
if (strcmp(ValueToString(tmp.value),"inherit") == 0)
*inhp = 1;
else
{
SyntaxErrorMessage(fnx);
SetEvaluationError(TRUE);
return(NULL);
}
}
return(clsptr);
}
/*****************************************************************************
NAME : ListDefmessageHandlersCommand
DESCRIPTION : Depending on arguments, does lists handlers which
match restrictions
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : H/L Syntax: (list-defmessage-handlers [<class> [inherit]]))
*****************************************************************************/
globle void ListDefmessageHandlersCommand()
{
int inhp;
void *clsptr;
if (RtnArgCount() == 0)
ListDefmessageHandlers(WDISPLAY,NULL,0);
else
{
clsptr = ClassInfoFnxArgs("list-defmessage-handlers",&inhp);
if (clsptr == NULL)
return;
ListDefmessageHandlers(WDISPLAY,clsptr,inhp);
}
}
/*******************************************************************************
NAME : PPDefmessageHandlerCommand
DESCRIPTION : Displays the pretty-print form (if any) for a handler
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : H/L Syntax: (ppdefmessage-handler <class> <message> [<type>])
*******************************************************************************/
globle void PPDefmessageHandlerCommand()
{
DATA_OBJECT temp;
SYMBOL_HN *csym,*msym;
char *tname;
DEFCLASS *cls = NULL;
int mtype;
HANDLER *hnd;
if (ArgTypeCheck("ppdefmessage-handler",1,SYMBOL,&temp) == FALSE)
return;
csym = FindSymbol(DOToString(temp));
if (ArgTypeCheck("ppdefmessage-handler",2,SYMBOL,&temp) == FALSE)
return;
msym = FindSymbol(DOToString(temp));
if (RtnArgCount() == 3)
{
if (ArgTypeCheck("ppdefmessage-handler",3,SYMBOL,&temp) == FALSE)
return;
tname = DOToString(temp);
}
else
tname = hndquals[MPRIMARY];
mtype = HandlerType("ppdefmessage-handler",tname);
if (mtype == MERROR)
{
SetEvaluationError(TRUE);
return;
}
if (csym != NULL)
cls = LookupDefclassByMdlOrScope(ValueToString(csym));
if (((cls == NULL) || (msym == NULL)) ? TRUE :
((hnd = FindHandlerByAddress(cls,msym,(unsigned) mtype)) == NULL))
{
PrintErrorID("MSGCOM",2,FALSE);
PrintRouter(WERROR,"Unable to find message-handler ");
PrintRouter(WERROR,ValueToString(msym));
PrintRouter(WERROR," ");
PrintRouter(WERROR,tname);
PrintRouter(WERROR," for class ");
PrintRouter(WERROR,ValueToString(csym));
PrintRouter(WERROR," in function ppdefmessage-handler.\n");
SetEvaluationError(TRUE);
return;
}
if (hnd->ppForm != NULL)
PrintInChunks(WDISPLAY,hnd->ppForm);
}
/******************************************************************************
NAME : UndefmessageHandlerCommand
DESCRIPTION : Deletes a handler from a class
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Handler deleted if possible
NOTES : H/L Syntax: (undefmessage-handler <class> <handler> [<type>])
******************************************************************************/
globle void UndefmessageHandlerCommand()
{
#if RUN_TIME || BLOAD_ONLY
PrintErrorID("MSGCOM",3,FALSE);
PrintRouter(WERROR,"Unable to delete message-handlers.\n");
#else
SYMBOL_HN *mname;
char *tname;
DATA_OBJECT tmp;
DEFCLASS *cls;
#if BLOAD || BLOAD_AND_BSAVE
if (Bloaded())
{
PrintErrorID("MSGCOM",3,FALSE);
PrintRouter(WERROR,"Unable to delete message-handlers.\n");
return;
}
#endif
if (ArgTypeCheck("undefmessage-handler",1,SYMBOL,&tmp) == FALSE)
return;
cls = LookupDefclassByMdlOrScope(DOToString(tmp));
if ((cls == NULL) ? (strcmp(DOToString(tmp),"*") != 0) : FALSE)
{
ClassExistError("undefmessage-handler",DOToString(tmp));
return;
}
if (ArgTypeCheck("undefmessage-handler",2,SYMBOL,&tmp) == FALSE)
return;
mname = (SYMBOL_HN *) tmp.value;
if (RtnArgCount() == 3)
{
if (ArgTypeCheck("undefmessage-handler",3,SYMBOL,&tmp) == FALSE)
return;
tname = DOToString(tmp);
if (strcmp(tname,"*") == 0)
tname = NULL;
}
else
tname = hndquals[MPRIMARY];
WildDeleteHandler(cls,mname,tname);
#endif
}
/***********************************************************************
NAME : GetDefmessageHandlersListCmd
DESCRIPTION : Groups message-handlers for a class into a multifield
value for dynamic perusal
INPUTS : Data object buffer to hold the handlers of the class
RETURNS : Nothing useful
SIDE EFFECTS : Creates a multifield storing the names of
the message-handlers of the class
NOTES : Syntax: (get-defmessage-handler-list <class> [inherit])
***********************************************************************/
globle void GetDefmessageHandlersListCmd(
DATA_OBJECT *result)
{
int inhp;
void *clsptr;
if (RtnArgCount () == 0)
GetDefmessageHandlerList(NULL,result,0);
else
{
clsptr = ClassInfoFnxArgs("get-defmessage-handler-list",&inhp);
if (clsptr == NULL)
{
SetMultifieldErrorValue(result);
return;
}
GetDefmessageHandlerList(clsptr,result,inhp);
}
}
/* DefineFunction2("DF2"",'i',PTIF DF2,"DF2","45iskuss"); */
int
DF2()
{
char c1, chr1[9] ,str1[99] ,str2[99] ,str3[99];
/*PTIF fncptr; at the worst might have to give the return type &do a switch*/
int (*fncptr)(); /*might only be wrapping fnc that rtn ints anyway*/
fncptr = PTIF get_ptr(3);
if((int)fncptr < 999) printf("[fncptr=%d]",(int)fncptr); /*return(0);*/
sprintf(str1,"%s",(char *)RtnLexeme(1));
sprintf(chr1,"%s",(char *)RtnLexeme(2));
sprintf(str2,"%s",(char *)RtnLexeme(4));
c1= chr1[0];
printf("[DefineFunction2 for:%s with type=%c]\n",str1,c1);
if(RtnArgCount()>4)
{
sprintf(str3,"%s",(char *)RtnLexeme(5));
DefineFunction2(str1,c1,PTIF fncptr,str2,str3);
}
else DefineFunction(str1,c1,PTIF fncptr,str2);
return(1);
}
/*DefineFunction2("str-cmp",'i',PTIF str-cmp,"str-cmp","24iss"); */
int str_cmp()
{
int cnt,len=0;
char s1[44],s2[44];
sprintf(s1,"%s",(char *)RtnLexeme(1));
sprintf(s2,"%s",(char *)RtnLexeme(2));
cnt= RtnArgCount();
if(cnt>2)
{
len = (int)RtnLong(3);
if(len>0)
{
if(cnt>3) return(strncasecmp(s1,s2,len));
else return(strncmp(s1,s2,len));
} else
{
if(cnt>3) return(strcasecmp(s1,s2));
else return(strcmp(s1,s2));
}
} else return(strcmp(s1,s2));
} /*there is already a str-compare*/
/*-deref or pk_tpn can fill malloced space, then can use this to get to a m.f.*/
VOID tpn_to_mf(DATA_OBJECT_PTR rp)
{
int num=1,stride=1,*pi,offset=0,i;
float *pf;
double *pd;
char tstr[9],type,*pc,t1[2];
VOID *mfp;
t1[1]='\0';
/*get the type*/
sprintf(tstr,"%s",(char *)RtnLexeme(1));
type = tolower(tstr[0]);
if(type!='i' && type!='f' && type!='d' && type!='b')
{
printf("[1st arg=type:i or f or d]");
return;
}
/*get number (& offset & stride) to put to a m.f.*/
if(RtnArgCount() > 2) num=(int)RtnLong(3);
if(RtnArgCount() > 3) offset=(int)RtnLong(4);
if(RtnArgCount() > 4) stride=(int)RtnLong(5);
/*could use SetMultifieldErrorValue(rp); return;*/
mfp = CreateMultifield(num);
/*get the ptr, and set the MF*/
switch(type)
{
case 'i' : pi = (int *)get_ptr(2);
for(i=0; i<num; i++)
{
SetMFType(mfp,i,INTEGER);
SetMFValue(mfp,i,AddLong(pi[offset+i]));
}
break;
case 'f' : pf = (float *)get_ptr(2);
for(i=0; i<num; i++)
{
printf("%f to mf,",pf[offset+i]); fflush(stdout);
SetMFType(mfp,i,FLOAT);
SetMFValue(mfp,i,AddDouble((double)pf[offset+i]));
}
break;
case 'd' : pd = (double *)get_ptr(2);
for(i=0; i<num; i++)
{
SetMFType(mfp,i,FLOAT);
SetMFValue(mfp,i,AddDouble(pd[offset+i]));
}
break;
/*this one could go per char or by stride or by space breaks*/
/*go by char for now*/
case 'b' : pc = (char *)get_ptr(2);
for(i=0; i<num; i++)
{
SetMFType(mfp,i,SYMBOL);
t1[0]=pc[offset+i];
SetMFValue(mfp,i,AddSymbol(t1));
}
break;
} /*gets past this and dies when printing out the result-
-looks liked capped ok though*/
SetpType(rp,MULTIFIELD);
SetpValue(rp,mfp);
SetpDOBegin(rp,1);
SetpDOEnd(rp,num);
return;
}
/*might be dangerous, maybe trasfer to from mf instead*/
VOID tpn_mf_mirror(DATA_OBJECT_PTR rp)
{
int *pi,i,num,offset=0,stride=1;
float *pf;
double *pd;
char tstr[9],type,t1[2];
VOID *mfp;
t1[1]='\0';
/*get the type*/
sprintf(tstr,"%s",(char *)RtnLexeme(1));
type = tolower(tstr[0]);
if(type!='i' && type!='f' && type!='d' && type!='b')
{
printf("[1st arg=type:i or f or d]");
return;
}
/*get number (& offset & stride) to put to a m.f.*/
if(RtnArgCount() > 2) num=(int)RtnLong(3);
if(RtnArgCount() > 3) offset=(int)RtnLong(4);
if(RtnArgCount() > 4) stride=(int)RtnLong(5);
/*could use SetMultifieldErrorValue(rp); return;*/
mfp = CreateMultifield(num);
/*get the ptr, and set the MF*/
switch(type)
{
case 'i' : pi = (int *)get_ptr(2);
for(i=0; i<num; i++)
{
printf(",%d ",
SetMFType(mfp,i,INTEGER));
/*SetMFValue(mfp,i,AddLong(pi[offset+i]));
set the Data_Object ptr to the address*/
}
break;
case 'f' : pf = (float *)get_ptr(2);
for(i=0; i<num; i++)
{
printf("%f to mf,",pf[offset+i]);
fflush(stdout);
printf(",%d ",
SetMFType(mfp,i,FLOAT));
fflush(stdout);
/*SetMFValue(mfp,i,AddDouble((double)pf[offset+i]));
set the Data_Object ptr to the address*/
}
break;
case 'd' : pd = (double *)get_ptr(2);
for(i=0; i<num; i++)
{
SetMFType(mfp,i,FLOAT);
/*SetMFValue(mfp,i,AddDouble(pd[offset+i]));
set the Data_Object ptr to the address*/
}
break;
}
SetpType(rp,MULTIFIELD);
SetpValue(rp,mfp);
SetpDOBegin(rp,1);
SetpDOEnd(rp,num);
return;
}
static void StrOrSymCatFunction(
DATA_OBJECT_PTR returnValue,
unsigned short returnType)
{
DATA_OBJECT theArg;
int numArgs, i, total, j;
char *theString;
SYMBOL_HN **arrayOfStrings;
SYMBOL_HN *hashPtr;
char *functionName;
/*============================================*/
/* Determine the calling function name. */
/* Store the null string or the symbol nil as */
/* the return value in the event of an error. */
/*============================================*/
SetpType(returnValue,returnType);
if (returnType == STRING)
{
functionName = "str-cat";
SetpValue(returnValue,(void *) AddSymbol(""));
}
else
{
functionName = "sym-cat";
SetpValue(returnValue,(void *) AddSymbol("nil"));
}
/*===============================================*/
/* Determine the number of arguments as create a */
/* string array which is large enough to store */
/* the string representation of each argument. */
/*===============================================*/
numArgs = RtnArgCount();
arrayOfStrings = (SYMBOL_HN **) gm1((int) sizeof(SYMBOL_HN *) * numArgs);
for (i = 0; i < numArgs; i++)
{ arrayOfStrings[i] = NULL; }
/*=============================================*/
/* Evaluate each argument and store its string */
/* representation in the string array. */
/*=============================================*/
total = 1;
for (i = 1 ; i <= numArgs ; i++)
{
RtnUnknown(i,&theArg);
switch(GetType(theArg))
{
case STRING:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
#endif
case SYMBOL:
hashPtr = (SYMBOL_HN *) GetValue(theArg);
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
case FLOAT:
hashPtr = (SYMBOL_HN *) AddSymbol(FloatToString(ValueToDouble(GetValue(theArg))));
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
case INTEGER:
hashPtr = (SYMBOL_HN *) AddSymbol(LongIntegerToString(ValueToLong(GetValue(theArg))));
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
default:
ExpectedTypeError1(functionName,i,"string, instance name, symbol, float, or integer");
SetEvaluationError(TRUE);
break;
}
if (EvaluationError)
{
for (i = 0; i < numArgs; i++)
{
if (arrayOfStrings[i] != NULL)
{ DecrementSymbolCount(arrayOfStrings[i]); }
}
rm(arrayOfStrings,sizeof(SYMBOL_HN *) * numArgs);
return;
}
total += strlen(ValueToString(arrayOfStrings[i - 1]));
}
/*=========================================================*/
/* Allocate the memory to store the concatenated string or */
/* symbol, then copy the values in the string array to the */
/* memory just allocated. */
/*=========================================================*/
theString = (char *) gm2 ((sizeof(char) * total));
j = 0;
for (i = 0 ; i < numArgs ; i++)
{
sprintf(&theString[j],"%s",ValueToString(arrayOfStrings[i]));
j += strlen(ValueToString(arrayOfStrings[i]));
}
/*=========================================*/
/* Return the concatenated value and clean */
/* up the temporary memory used. */
/*=========================================*/
SetpValue(returnValue,(void *) AddSymbol(theString));
rm(theString,sizeof(char) * total);
for (i = 0; i < numArgs; i++)
{
if (arrayOfStrings[i] != NULL)
{ DecrementSymbolCount(arrayOfStrings[i]); }
}
rm(arrayOfStrings,sizeof(SYMBOL_HN *) * numArgs);
}
/*return: int version of ptr to the output array*/
int tpppno()
{
int num=1,stride=1,*pi1,*pi2,*piout,offset=0,i,rp=-1;
float *pf1,*pf2,*pfout;
double *pd1,*pd2,*pdout;
char tstr[9],type,t1[2],op;
t1[1]='\0';
/*get the type*/
sprintf(tstr,"%s",(char *)RtnLexeme(1));
type = tolower(tstr[0]);
if(type!='i' && type!='f' && type!='d' && type!='b')
{
printf("[1st arg=type:i or f or d]");
return(-1);
}
sprintf(tstr,"%s",(char *)RtnLexeme(6));
op = tolower(tstr[0]);
if(RtnArgCount() > 4) num=(int)RtnLong(5);
switch(type)
{
case 'i' :
pi1 = (int *)get_ptr(2);
pi2 = (int *)get_ptr(3);
piout = (int *)get_ptr(4);
switch(op)
{
case '+': for(i=0; i<num; i++) piout[i] = pi1[i] + pi2[i]; break;
case '-': for(i=0; i<num; i++) piout[i] = pi1[i] - pi2[i]; break;
case '*': for(i=0; i<num; i++) piout[i] = pi1[i] * pi2[i]; break;
case '/': for(i=0; i<num; i++) piout[i] = pi1[i] / pi2[i]; break;
}
rp = (int)piout;
break;
case 'f' :
pf1 = (float *)get_ptr(2);
pf2 = (float *)get_ptr(3);
pfout = (float *)get_ptr(4);
switch(op)
{
case '+': for(i=0; i<num; i++) pfout[i] = pf1[i] + pf2[i]; break;
case '-': for(i=0; i<num; i++) pfout[i] = pf1[i] - pf2[i]; break;
case '*': for(i=0; i<num; i++) pfout[i] = pf1[i] * pf2[i]; break;
case '/': for(i=0; i<num; i++) pfout[i] = pf1[i] / pf2[i]; break;
}
rp = (int)pfout;
break;
case 'd' :
pd1 = (double *)get_ptr(2);
pd2 = (double *)get_ptr(3);
pdout = (double *)get_ptr(4);
switch(op)
{
case '+': for(i=0; i<num; i++) pdout[i] = pd1[i] + pd2[i]; break;
case '-': for(i=0; i<num; i++) pdout[i] = pd1[i] - pd2[i]; break;
case '*': for(i=0; i<num; i++) pdout[i] = pd1[i] * pd2[i]; break;
case '/': for(i=0; i<num; i++) pdout[i] = pd1[i] / pd2[i]; break;
}
rp = (int)pdout;
break;
}
return(rp);
}