globle void StrIndexFunction(
DATA_OBJECT_PTR result)
{
DATA_OBJECT theArgument1, theArgument2;
char *strg1, *strg2;
int i, j;
result->type = SYMBOL;
result->value = FalseSymbol;
/*===================================*/
/* Check and retrieve the arguments. */
/*===================================*/
if (ArgCountCheck("str-index",EXACTLY,2) == -1) return;
if (ArgTypeCheck("str-index",1,SYMBOL_OR_STRING,&theArgument1) == FALSE) return;
if (ArgTypeCheck("str-index",2,SYMBOL_OR_STRING,&theArgument2) == FALSE) return;
strg1 = DOToString(theArgument1);
strg2 = DOToString(theArgument2);
/*=================================*/
/* Find the position in string2 of */
/* string1 (counting from 1). */
/*=================================*/
if (strlen(strg1) == 0)
{
result->type = INTEGER;
result->value = (void *) AddLong((long) strlen(strg2) + 1L);
return;
}
for (i=1; *strg2; i++, strg2++)
{
for (j=0; *(strg1+j) && *(strg1+j) == *(strg2+j); j++)
{ /* Do Nothing */ }
if (*(strg1+j) == '\0')
{
result->type = INTEGER;
result->value = (void *) AddLong((long) i);
return;
}
}
return;
}
globle long int StrCompareFunction()
{
int numArgs, length;
DATA_OBJECT arg1, arg2, arg3;
long returnValue;
/*=======================================================*/
/* Function str-compare expects either 2 or 3 arguments. */
/*=======================================================*/
if ((numArgs = ArgRangeCheck("str-compare",2,3)) == -1) return(0L);
/*=============================================================*/
/* The first two arguments should be of type symbol or string. */
/*=============================================================*/
if (ArgTypeCheck("str-compare",1,SYMBOL_OR_STRING,&arg1) == FALSE)
{ return(0L); }
if (ArgTypeCheck("str-compare",2,SYMBOL_OR_STRING,&arg2) == FALSE)
{ return(0L); }
/*===================================================*/
/* Compare the strings. Use the 3rd argument for the */
/* maximum length of comparison, if it is provided. */
/*===================================================*/
if (numArgs == 3)
{
if (ArgTypeCheck("str-compare",3,INTEGER,&arg3) == FALSE)
{ return(0L); }
length = CoerceToInteger(GetType(arg3),GetValue(arg3));
returnValue = strncmp(DOToString(arg1),DOToString(arg2),
(STD_SIZE) length);
}
else
{ returnValue = strcmp(DOToString(arg1),DOToString(arg2)); }
/*========================================================*/
/* Return Values are as follows: */
/* -1 is returned if <string-1> is less than <string-2>. */
/* 1 is return if <string-1> is greater than <string-2>. */
/* 0 is returned if <string-1> is equal to <string-2>. */
/*========================================================*/
if (returnValue < 0) returnValue = -1;
else if (returnValue > 0) returnValue = 1;
return(returnValue);
}
/*******************************************************************************
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);
}
globle void EvalFunction(
DATA_OBJECT_PTR returnValue)
{
DATA_OBJECT theArg;
/*=============================================*/
/* Function eval expects exactly one argument. */
/*=============================================*/
if (ArgCountCheck("eval",EXACTLY,1) == -1)
{
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
return;
}
/*==================================================*/
/* The argument should be of type SYMBOL or STRING. */
/*==================================================*/
if (ArgTypeCheck("eval",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
return;
}
/*======================*/
/* Evaluate the string. */
/*======================*/
Eval(DOToString(theArg),returnValue);
}
globle void CheckSyntaxFunction(
DATA_OBJECT *returnValue)
{
DATA_OBJECT theArg;
/*===============================*/
/* Set up a default return value */
/* (TRUE for problems found). */
/*===============================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,TrueSymbol);
/*=====================================================*/
/* Function check-syntax expects exactly one argument. */
/*=====================================================*/
if (ArgCountCheck("check-syntax",EXACTLY,1) == -1) return;
/*========================================*/
/* The argument should be of type STRING. */
/*========================================*/
if (ArgTypeCheck("check-syntax",1,STRING,&theArg) == FALSE)
{ return; }
/*===================*/
/* Check the syntax. */
/*===================*/
CheckSyntax(DOToString(theArg),returnValue);
}
globle void LowcaseFunction(
DATA_OBJECT_PTR returnValue)
{
DATA_OBJECT theArg;
int i, slen;
char *osptr, *nsptr;
/*================================================*/
/* Function lowcase expects exactly one argument. */
/*================================================*/
if (ArgCountCheck("lowcase",EXACTLY,1) == -1)
{
SetpType(returnValue,STRING);
SetpValue(returnValue,(void *) AddSymbol(""));
return;
}
/*==================================================*/
/* The argument should be of type symbol or string. */
/*==================================================*/
if (ArgTypeCheck("lowcase",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{
SetpType(returnValue,STRING);
SetpValue(returnValue,(void *) AddSymbol(""));
return;
}
/*======================================================*/
/* Allocate temporary memory and then copy the original */
/* string or symbol to that memory, while lowercasing */
/* upper case alphabetic characters. */
/*======================================================*/
osptr = DOToString(theArg);
slen = strlen(osptr) + 1;
nsptr = (char *) gm2(slen);
for (i = 0 ; i < slen ; i++)
{
if (isupper(osptr[i]))
{ nsptr[i] = (char) tolower(osptr[i]); }
else
{ nsptr[i] = osptr[i]; }
}
/*========================================*/
/* Return the lowercased string and clean */
/* up the temporary memory used. */
/*========================================*/
SetpType(returnValue,GetType(theArg));
SetpValue(returnValue,(void *) AddSymbol(nsptr));
rm(nsptr,slen);
}
/******************************************************************************
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 : PreviewSendCommand
DESCRIPTION : Displays a list of the core for a message describing
shadows,etc.
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Temporary core created and destroyed
NOTES : H/L Syntax: (preview-send <class> <msg>)
********************************************************************/
globle void PreviewSendCommand()
{
DEFCLASS *cls;
DATA_OBJECT temp;
/* =============================
Get the class for the message
============================= */
if (ArgTypeCheck("preview-send",1,SYMBOL,&temp) == FALSE)
return;
cls = LookupDefclassByMdlOrScope(DOToString(temp));
if (cls == NULL)
{
ClassExistError("preview-send",ValueToString(temp.value));
return;
}
if (ArgTypeCheck("preview-send",2,SYMBOL,&temp) == FALSE)
return;
PreviewSend(WDISPLAY,(void *) cls,DOToString(temp));
}
/***********************************************************
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);
}
globle SYMBOL_HN *SetStrategyCommand()
{
DATA_OBJECT argPtr;
char *argument;
int oldStrategy = Strategy;
/*=====================================================*/
/* Check for the correct number and type of arguments. */
/*=====================================================*/
if (ArgCountCheck("set-strategy",EXACTLY,1) == -1)
{ return((SYMBOL_HN *) AddSymbol(GetStrategyName(GetStrategy()))); }
if (ArgTypeCheck("set-strategy",1,SYMBOL,&argPtr) == FALSE)
{ return((SYMBOL_HN *) AddSymbol(GetStrategyName(GetStrategy()))); }
argument = DOToString(argPtr);
/*=============================================*/
/* Set the strategy to the specified strategy. */
/*=============================================*/
if (strcmp(argument,"depth") == 0)
{ SetStrategy(DEPTH_STRATEGY); }
else if (strcmp(argument,"breadth") == 0)
{ SetStrategy(BREADTH_STRATEGY); }
else if (strcmp(argument,"lex") == 0)
{ SetStrategy(LEX_STRATEGY); }
else if (strcmp(argument,"mea") == 0)
{ SetStrategy(MEA_STRATEGY); }
else if (strcmp(argument,"complexity") == 0)
{ SetStrategy(COMPLEXITY_STRATEGY); }
else if (strcmp(argument,"simplicity") == 0)
{ SetStrategy(SIMPLICITY_STRATEGY); }
else if (strcmp(argument,"random") == 0)
{ SetStrategy(RANDOM_STRATEGY); }
else
{
ExpectedTypeError1("set-strategy",1,
"symbol with value depth, breadth, lex, mea, complexity, simplicity, or random");
return((SYMBOL_HN *) AddSymbol(GetStrategyName(GetStrategy())));
}
/*=======================================*/
/* Return the old value of the strategy. */
/*=======================================*/
return((SYMBOL_HN *) AddSymbol(GetStrategyName(oldStrategy)));
}
/*********************************************************************
NAME : ClassAbstractPCommand
DESCRIPTION : Determines if direct instances of a class can be made
INPUTS : None
RETURNS : TRUE (1) if class is abstract, FALSE (0) if concrete
SIDE EFFECTS : None
NOTES : Syntax: (class-abstractp <class>)
*********************************************************************/
globle int ClassAbstractPCommand()
{
DATA_OBJECT tmp;
DEFCLASS *cls;
if (ArgTypeCheck("class-abstractp",1,SYMBOL,&tmp) == FALSE)
return(FALSE);
cls = LookupDefclassByMdlOrScope(DOToString(tmp));
if (cls == NULL)
{
ClassExistError("class-abstractp",ValueToString(tmp.value));
return(FALSE);
}
return(ClassAbstractP((void *) cls));
}
/*************************************************************
NAME : PreviewGeneric
DESCRIPTION : Allows the user to see a printout of all the
applicable methods for a particular generic
function call
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of evaluating the generic
function arguments
and evaluating query-functions to determine
the set of applicable methods
NOTES : H/L Syntax: (preview-generic <func> <args>)
*************************************************************/
globle void PreviewGeneric()
{
DEFGENERIC *gfunc;
DEFGENERIC *previousGeneric;
int oldce;
DATA_OBJECT temp;
EvaluationError = FALSE;
if (ArgTypeCheck("preview-generic",1,SYMBOL,&temp) == FALSE)
return;
gfunc = LookupDefgenericByMdlOrScope(DOToString(temp));
if (gfunc == NULL)
{
PrintErrorID("GENRCFUN",3,FALSE);
PrintRouter(WERROR,"Unable to find generic function ");
PrintRouter(WERROR,DOToString(temp));
PrintRouter(WERROR," in function preview-generic.\n");
return;
}
oldce = ExecutingConstruct();
SetExecutingConstruct(TRUE);
previousGeneric = CurrentGeneric;
CurrentGeneric = gfunc;
CurrentEvaluationDepth++;
PushProcParameters(GetFirstArgument()->nextArg,
CountArguments(GetFirstArgument()->nextArg),
GetDefgenericName((void *) gfunc),"generic function",
UnboundMethodErr);
if (EvaluationError)
{
PopProcParameters();
CurrentGeneric = previousGeneric;
CurrentEvaluationDepth--;
SetExecutingConstruct(oldce);
return;
}
gfunc->busy++;
DisplayGenericCore(gfunc);
gfunc->busy--;
PopProcParameters();
CurrentGeneric = previousGeneric;
CurrentEvaluationDepth--;
SetExecutingConstruct(oldce);
}
globle void UnwatchCommand()
{
DATA_OBJECT theValue;
char *argument;
int recognized;
struct watchItem *wPtr;
/*==========================================*/
/* Determine which item is to be unwatched. */
/*==========================================*/
if (ArgTypeCheck("unwatch",1,SYMBOL,&theValue) == FALSE) return;
argument = DOToString(theValue);
wPtr = ValidWatchItem(argument,&recognized);
if (recognized == FALSE)
{
SetEvaluationError(TRUE);
ExpectedTypeError1("unwatch",1,"watchable symbol");
return;
}
/*=================================================*/
/* Check to make sure extra arguments are allowed. */
/*=================================================*/
if (GetNextArgument(GetFirstArgument()) != NULL)
{
if ((wPtr == NULL) ? TRUE : (wPtr->accessFunc == NULL))
{
SetEvaluationError(TRUE);
ExpectedCountError("unwatch",EXACTLY,1);
return;
}
}
/*=====================*/
/* Set the watch item. */
/*=====================*/
SetWatchItem(argument,OFF,GetNextArgument(GetFirstArgument()));
}
globle int GetWatchItemCommand()
{
DATA_OBJECT theValue;
char *argument;
int recognized;
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (ArgCountCheck("get-watch-item",EXACTLY,1) == -1)
{ return(FALSE); }
/*========================================*/
/* Determine which item is to be watched. */
/*========================================*/
if (ArgTypeCheck("get-watch-item",1,SYMBOL,&theValue) == FALSE)
{ return(FALSE); }
argument = DOToString(theValue);
ValidWatchItem(argument,&recognized);
if (recognized == FALSE)
{
SetEvaluationError(TRUE);
ExpectedTypeError1("get-watch-item",1,"watchable symbol");
return(FALSE);
}
/*===========================*/
/* Get the watch item value. */
/*===========================*/
if (GetWatchItem(argument) == 1)
{ return(TRUE); }
return(FALSE);
}
/***********************************************************************
NAME : SendCommand
DESCRIPTION : Determines the applicable handler(s) and sets up the
core calling frame. Then calls the core frame.
INPUTS : Caller's space for storing the result of the handler(s)
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects caused by the execution of handlers in
the core framework
NOTES : H/L Syntax : (send <instance> <hnd> <args>*)
***********************************************************************/
globle void SendCommand(
DATA_OBJECT *result)
{
EXPRESSION args;
SYMBOL_HN *msg;
DATA_OBJECT temp;
result->type = SYMBOL;
result->value = FalseSymbol;
if (ArgTypeCheck("send",2,SYMBOL,&temp) == FALSE)
return;
msg = (SYMBOL_HN *) temp.value;
/* =============================================
Get the instance or primitive for the message
============================================= */
args.type = GetFirstArgument()->type;
args.value = GetFirstArgument()->value;
args.argList = GetFirstArgument()->argList;
args.nextArg = GetFirstArgument()->nextArg->nextArg;
PerformMessage(result,&args,msg);
}
globle int BuildFunction()
{
DATA_OBJECT theArg;
/*==============================================*/
/* Function build expects exactly one argument. */
/*==============================================*/
if (ArgCountCheck("build",EXACTLY,1) == -1) return(FALSE);
/*==================================================*/
/* The argument should be of type SYMBOL or STRING. */
/*==================================================*/
if (ArgTypeCheck("build",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{ return(FALSE); }
/*======================*/
/* Build the construct. */
/*======================*/
return(Build(DOToString(theArg)));
}
globle long int StrLengthFunction()
{
DATA_OBJECT theArg;
/*===================================================*/
/* Function str-length expects exactly one argument. */
/*===================================================*/
if (ArgCountCheck("str-length",EXACTLY,1) == -1)
{ return(-1L); }
/*==================================================*/
/* The argument should be of type symbol or string. */
/*==================================================*/
if (ArgTypeCheck("str-length",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{ return(-1L); }
/*============================================*/
/* Return the length of the string or symbol. */
/*============================================*/
return( (long) strlen(DOToString(theArg)));
}
int gdbm_lookup_p(char *dbm,char *word)
{
GDBM_FILE dbf;
datum key,value;
// int flag;
char abs_db_path[1000];
int len=0,len1=0;
char *dbm1;
DATA_OBJECT temp;
/*=================================*/
/* Check for exactly two argument. */
/*=================================*/
if (ArgCountCheck("gdbm_lookup_p",EXACTLY,2) == -1)
{ return(FALSE); }
/*=================================*/
/* Check the datatype of 2nd argument. */
/*=================================*/
if (ArgTypeCheck("gdbm_lookup_p",2,SYMBOL_OR_STRING,&temp) == 0)
{ return(1L);}
/*==========================================================================================*/
/*RtnLexeme returns a character pointer from either a symbol, string, or instance name data type */
/*=========================================================================================*/
len=(strlen(RtnLexeme(1)));
dbm=malloc(sizeof(char)*len+1);
strcpy(dbm,RtnLexeme(1));
strcpy(abs_db_path,ABS_ANU_PATH);
strcat(abs_db_path,dbm);
free(dbm);
len1=(strlen(abs_db_path));
dbm1=malloc(sizeof(char)*len1+1);
strcpy(dbm1,abs_db_path);
word = RtnLexeme(2);
//PrintRouter(WDISPLAY,"Database: ");PrintRouter(WDISPLAY,RtnLexeme(1));PrintRouter(WDISPLAY," word :");PrintRouter(WDISPLAY,RtnLexeme(2));PrintRouter(WDISPLAY,"\n");
/*=================================*/
/* To open the gdbm file. */
/*=================================*/
dbf = gdbm_open(dbm1,512,GDBM_READER,0644,0);
/*=================================*/
/* Check whether databse is empty. */
/*=================================*/
if (dbf == NULL)
{ PrintRouter(WDISPLAY,"Warning :: Database Not Found ------ OR ----- Database Is Empty.\n");
// PrintRouter(WDISPLAY,"\n");
// PrintRouter(WDISPLAY,RtnLexeme(2));
// PrintRouter(WDISPLAY,"\n");
return(1L); }
key.dptr=word;
key.dsize=strlen(key.dptr);
value = gdbm_fetch(dbf,key);
gdbm_close (dbf);
if(value.dptr!=NULL)
return(TRUE);
else
return(FALSE);
}
globle void ListWatchItemsCommand()
{
struct watchItem *wPtr;
DATA_OBJECT theValue;
int recognized;
/*=======================*/
/* List the watch items. */
/*=======================*/
if (GetFirstArgument() == NULL)
{
for (wPtr = ListOfWatchItems; wPtr != NULL; wPtr = wPtr->next)
{
PrintRouter(WDISPLAY,wPtr->name);
if (*(wPtr->flag)) PrintRouter(WDISPLAY," = on\n");
else PrintRouter(WDISPLAY," = off\n");
}
return;
}
/*=======================================*/
/* Determine which item is to be listed. */
/*=======================================*/
if (ArgTypeCheck("list-watch-items",1,SYMBOL,&theValue) == FALSE) return;
wPtr = ValidWatchItem(DOToString(theValue),&recognized);
if ((recognized == FALSE) || (wPtr == NULL))
{
SetEvaluationError(TRUE);
ExpectedTypeError1("list-watch-items",1,"watchable symbol");
return;
}
/*=================================================*/
/* Check to make sure extra arguments are allowed. */
/*=================================================*/
if ((wPtr->printFunc == NULL) &&
(GetNextArgument(GetFirstArgument()) != NULL))
{
SetEvaluationError(TRUE);
ExpectedCountError("list-watch-items",EXACTLY,1);
return;
}
/*====================================*/
/* List the status of the watch item. */
/*====================================*/
PrintRouter(WDISPLAY,wPtr->name);
if (*(wPtr->flag)) PrintRouter(WDISPLAY," = on\n");
else PrintRouter(WDISPLAY," = off\n");
/*============================================*/
/* List the status of individual watch items. */
/*============================================*/
if (wPtr->printFunc != NULL)
{
if ((*wPtr->printFunc)(WDISPLAY,wPtr->code,
GetNextArgument(GetFirstArgument())) == FALSE)
{ SetEvaluationError(TRUE); }
}
}
globle void *SubStringFunction()
{
DATA_OBJECT theArgument;
char *tempString, *returnString;
int start, end, i, j;
void *returnValue;
/*===================================*/
/* Check and retrieve the arguments. */
/*===================================*/
if (ArgCountCheck("sub-string",EXACTLY,3) == -1)
{ return((void *) AddSymbol("")); }
if (ArgTypeCheck("sub-string",1,INTEGER,&theArgument) == FALSE)
{ return((void *) AddSymbol("")); }
start = CoerceToInteger(theArgument.type,theArgument.value) - 1;
if (ArgTypeCheck("sub-string",2,INTEGER,&theArgument) == FALSE)
{ return((void *) AddSymbol("")); }
end = CoerceToInteger(theArgument.type,theArgument.value) - 1;
if (ArgTypeCheck("sub-string",3,SYMBOL_OR_STRING,&theArgument) == FALSE)
{ return((void *) AddSymbol("")); }
/*================================================*/
/* If parameters are out of range return an error */
/*================================================*/
if (start < 0) start = 0;
if (end > (int) strlen(DOToString(theArgument)))
{ end = strlen(DOToString(theArgument)); }
/*==================================*/
/* If the start is greater than the */
/* end, return a null string. */
/*==================================*/
if (start > end)
{ return((void *) AddSymbol("")); }
/*=============================================*/
/* Otherwise, allocate the string and copy the */
/* designated portion of the old string to the */
/* new string. */
/*=============================================*/
else
{
returnString = (char *) gm2(end - start +2); /* (end - start) inclusive + EOS */
tempString = DOToString(theArgument);
for(j=0, i=start;i <= end; i++, j++)
{ *(returnString+j) = *(tempString+i); }
*(returnString+j) = '\0';
}
/*========================*/
/* Return the new string. */
/*========================*/
returnValue = (void *) AddSymbol(returnString);
rm(returnString,end - start + 2);
return(returnValue);
}
globle void LoopForCountFunction(
DATA_OBJECT_PTR loopResult)
{
DATA_OBJECT arg_ptr;
long iterationEnd;
LOOP_COUNTER_STACK *tmpCounter;
tmpCounter = get_struct(loopCounterStack);
tmpCounter->loopCounter = 0L;
tmpCounter->nxt = LoopCounterStack;
LoopCounterStack = tmpCounter;
if (ArgTypeCheck("loop-for-count",1,INTEGER,&arg_ptr) == FALSE)
{
loopResult->type = SYMBOL;
loopResult->value = FalseSymbol;
LoopCounterStack = tmpCounter->nxt;
rtn_struct(loopCounterStack,tmpCounter);
return;
}
tmpCounter->loopCounter = DOToLong(arg_ptr);
if (ArgTypeCheck("loop-for-count",2,INTEGER,&arg_ptr) == FALSE)
{
loopResult->type = SYMBOL;
loopResult->value = FalseSymbol;
LoopCounterStack = tmpCounter->nxt;
rtn_struct(loopCounterStack,tmpCounter);
return;
}
iterationEnd = DOToLong(arg_ptr);
while ((tmpCounter->loopCounter <= iterationEnd) &&
(HaltExecution != TRUE))
{
if ((BreakFlag == TRUE) || (ReturnFlag == TRUE))
break;
CurrentEvaluationDepth++;
RtnUnknown(3,&arg_ptr);
CurrentEvaluationDepth--;
if (ReturnFlag == TRUE)
{ PropagateReturnValue(&arg_ptr); }
PeriodicCleanup(FALSE,TRUE);
if ((BreakFlag == TRUE) || (ReturnFlag == TRUE))
break;
tmpCounter->loopCounter++;
}
BreakFlag = FALSE;
if (ReturnFlag == TRUE)
{
loopResult->type = arg_ptr.type;
loopResult->value = arg_ptr.value;
loopResult->begin = arg_ptr.begin;
loopResult->end = arg_ptr.end;
}
else
{
loopResult->type = SYMBOL;
loopResult->value = FalseSymbol;
}
LoopCounterStack = tmpCounter->nxt;
rtn_struct(loopCounterStack,tmpCounter);
}
globle void ConstructsToCCommand()
{
char *fileName;
DATA_OBJECT theArg;
int argCount;
int id, max;
#if VAX_VMS || IBM_MSC || IBM_TBC || IBM_ICB || IBM_ZTC || IBM_SC
int i;
#endif
/*============================================*/
/* Check for appropriate number of arguments. */
/*============================================*/
if ((argCount = ArgRangeCheck("constructs-to-c",2,3)) == -1) return;
/*====================================================*/
/* Get the name of the file in which to place C code. */
/*====================================================*/
if (ArgTypeCheck("constructs-to-c",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{ return; }
fileName = DOToString(theArg);
/*================================*/
/* File names for the VAX and IBM */
/* PCs can't contain a period. */
/*================================*/
#if VAX_VMS || IBM_MSC || IBM_TBC || IBM_ICB || IBM_ZTC || IBM_SC
for (i = 0 ; *(fileName+i) ; i++)
{
if (*(fileName+i) == '.')
{
PrintErrorID("CONSCOMP",1,FALSE);
PrintRouter(WERROR,"Invalid file name ");
PrintRouter(WERROR,fileName);
PrintRouter(WERROR," contains \'.\'\n");
return;
}
}
#endif
/*===========================================*/
/* If the base file name is greater than 3 */
/* characters, issue a warning that the file */
/* name lengths may exceed what is allowed */
/* under some operating systems. */
/*===========================================*/
if (((int) strlen(fileName)) > 3)
{
PrintWarningID("CONSCOMP",1,FALSE);
PrintRouter(WWARNING,"Base file name exceeds 3 characters.\n");
PrintRouter(WWARNING," This may cause files to be overwritten if file name length\n");
PrintRouter(WWARNING," is limited on your platform.\n");
}
/*====================================*/
/* Get the runtime image ID argument. */
/*====================================*/
if (ArgTypeCheck("constructs-to-c",2,INTEGER,&theArg) == FALSE)
{ return; }
id = DOToInteger(theArg);
if (id < 0)
{
ExpectedTypeError1("constructs-to-c",2,"positive integer");
return;
}
/*===========================================*/
/* Get the maximum number of data structures */
/* to store per file argument (if supplied). */
/*===========================================*/
if (argCount == 3)
{
if (ArgTypeCheck("constructs-to-c",3,INTEGER,&theArg) == FALSE)
{ return; }
max = DOToInteger(theArg);
if (max < 0)
{
ExpectedTypeError1("constructs-to-c",3,"positive integer");
return;
}
}
else
{ max = 10000; }
/*============================*/
/* Call the driver routine to */
/* generate the C code. */
/*============================*/
ConstructsToC(fileName,id,max);
}
