globle void AssertCommand(
void *theEnv,
DATA_OBJECT_PTR rv)
{
struct deftemplate *theDeftemplate;
struct field *theField;
DATA_OBJECT theValue;
struct expr *theExpression;
struct templateSlot *slotPtr;
struct fact *newFact;
int error = FALSE;
int i;
struct fact *theFact;
/*===================================================*/
/* Set the default return value to the symbol FALSE. */
/*===================================================*/
SetpType(rv,SYMBOL);
SetpValue(rv,EnvFalseSymbol(theEnv));
/*================================*/
/* Get the deftemplate associated */
/* with the fact being asserted. */
/*================================*/
theExpression = GetFirstArgument();
theDeftemplate = (struct deftemplate *) theExpression->value;
/*=======================================*/
/* Create the fact and store the name of */
/* the deftemplate as the 1st field. */
/*=======================================*/
if (theDeftemplate->implied == FALSE)
{
newFact = CreateFactBySize(theEnv,theDeftemplate->numberOfSlots);
slotPtr = theDeftemplate->slotList;
}
else
{
newFact = CreateFactBySize(theEnv,1);
if (theExpression->nextArg == NULL)
{
newFact->theProposition.theFields[0].type = MULTIFIELD;
newFact->theProposition.theFields[0].value = CreateMultifield2(theEnv,0L);
}
slotPtr = NULL;
}
newFact->whichDeftemplate = theDeftemplate;
/*===================================================*/
/* Evaluate the expression associated with each slot */
/* and store the result in the appropriate slot of */
/* the newly created fact. */
/*===================================================*/
theField = newFact->theProposition.theFields;
for (theExpression = theExpression->nextArg, i = 0;
theExpression != NULL;
theExpression = theExpression->nextArg, i++)
{
/*===================================================*/
/* Evaluate the expression to be stored in the slot. */
/*===================================================*/
EvaluateExpression(theEnv,theExpression,&theValue);
/*============================================================*/
/* A multifield value can't be stored in a single field slot. */
/*============================================================*/
if ((slotPtr != NULL) ?
(slotPtr->multislot == FALSE) && (theValue.type == MULTIFIELD) :
FALSE)
{
MultiIntoSingleFieldSlotError(theEnv,slotPtr,theDeftemplate);
theValue.type = SYMBOL;
theValue.value = EnvFalseSymbol(theEnv);
error = TRUE;
}
/*==============================*/
/* Store the value in the slot. */
/*==============================*/
theField[i].type = theValue.type;
theField[i].value = theValue.value;
/*========================================*/
/* Get the information for the next slot. */
/*========================================*/
if (slotPtr != NULL) slotPtr = slotPtr->next;
}
/*============================================*/
/* If an error occured while generating the */
/* fact's slot values, then abort the assert. */
/*============================================*/
if (error)
{
ReturnFact(theEnv,newFact);
return;
}
/*================================*/
/* Add the fact to the fact-list. */
/*================================*/
theFact = (struct fact *) EnvAssert(theEnv,(void *) newFact);
/*========================================*/
/* The asserted fact is the return value. */
/*========================================*/
if (theFact != NULL)
{
SetpType(rv,FACT_ADDRESS);
SetpValue(rv,(void *) theFact);
}
return;
}
globle int CheckSyntax(
void *theEnv,
char *theString,
DATA_OBJECT_PTR returnValue)
{
char *name;
struct token theToken;
struct expr *top;
short rv;
/*==============================*/
/* Set the default return value */
/* (TRUE for problems found). */
/*==============================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvTrueSymbol(theEnv));
/*===========================================*/
/* Create a string source router so that the */
/* string can be used as an input source. */
/*===========================================*/
if (OpenStringSource(theEnv,"check-syntax",theString,0) == 0)
{ return(TRUE); }
/*=================================*/
/* Only expressions and constructs */
/* can have their syntax checked. */
/*=================================*/
GetToken(theEnv,"check-syntax",&theToken);
if (theToken.type != LPAREN)
{
CloseStringSource(theEnv,"check-syntax");
SetpValue(returnValue,EnvAddSymbol(theEnv,"MISSING-LEFT-PARENTHESIS"));
return(TRUE);
}
/*========================================*/
/* The next token should be the construct */
/* type or function name. */
/*========================================*/
GetToken(theEnv,"check-syntax",&theToken);
if (theToken.type != SYMBOL)
{
CloseStringSource(theEnv,"check-syntax");
SetpValue(returnValue,EnvAddSymbol(theEnv,"EXPECTED-SYMBOL-AFTER-LEFT-PARENTHESIS"));
return(TRUE);
}
name = ValueToString(theToken.value);
/*==============================================*/
/* Set up a router to capture the error output. */
/*==============================================*/
EnvAddRouter(theEnv,"error-capture",40,
FindErrorCapture, PrintErrorCapture,
NULL, NULL, NULL);
/*================================*/
/* Determine if it's a construct. */
/*================================*/
if (FindConstruct(theEnv,name))
{
ConstructData(theEnv)->CheckSyntaxMode = TRUE;
rv = (short) ParseConstruct(theEnv,name,"check-syntax");
GetToken(theEnv,"check-syntax",&theToken);
ConstructData(theEnv)->CheckSyntaxMode = FALSE;
if (rv)
{
EnvPrintRouter(theEnv,WERROR,"\nERROR:\n");
PrintInChunks(theEnv,WERROR,GetPPBuffer(theEnv));
EnvPrintRouter(theEnv,WERROR,"\n");
}
DestroyPPBuffer(theEnv);
CloseStringSource(theEnv,"check-syntax");
if ((rv != FALSE) || (ParseFunctionData(theEnv)->WarningString != NULL))
{
SetErrorCaptureValues(theEnv,returnValue);
DeactivateErrorCapture(theEnv);
return(TRUE);
}
if (theToken.type != STOP)
{
SetpValue(returnValue,EnvAddSymbol(theEnv,"EXTRANEOUS-INPUT-AFTER-LAST-PARENTHESIS"));
DeactivateErrorCapture(theEnv);
return(TRUE);
}
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
DeactivateErrorCapture(theEnv);
return(FALSE);
}
/*=======================*/
/* Parse the expression. */
/*=======================*/
top = Function2Parse(theEnv,"check-syntax",name);
GetToken(theEnv,"check-syntax",&theToken);
ClearParsedBindNames(theEnv);
CloseStringSource(theEnv,"check-syntax");
if (top == NULL)
{
SetErrorCaptureValues(theEnv,returnValue);
DeactivateErrorCapture(theEnv);
return(TRUE);
}
if (theToken.type != STOP)
{
SetpValue(returnValue,EnvAddSymbol(theEnv,"EXTRANEOUS-INPUT-AFTER-LAST-PARENTHESIS"));
DeactivateErrorCapture(theEnv);
ReturnExpression(theEnv,top);
return(TRUE);
}
DeactivateErrorCapture(theEnv);
ReturnExpression(theEnv,top);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
return(FALSE);
}
globle void SortFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
long argumentCount, i, j, k = 0;
DATA_OBJECT *theArguments, *theArguments2;
DATA_OBJECT theArg;
struct multifield *theMultifield, *tempMultifield;
char *functionName;
struct expr *functionReference;
int argumentSize = 0;
struct FunctionDefinition *fptr;
#if DEFFUNCTION_CONSTRUCT
DEFFUNCTION *dptr;
#endif
/*==================================*/
/* Set up the default return value. */
/*==================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,SymbolData(theEnv)->FalseSymbol);
/*=============================================*/
/* The function expects at least one argument. */
/*=============================================*/
if ((argumentCount = EnvArgCountCheck(theEnv,"sort",AT_LEAST,1)) == -1)
{ return; }
/*=============================================*/
/* Verify that the comparison function exists. */
/*=============================================*/
if (EnvArgTypeCheck(theEnv,"sort",1,SYMBOL,&theArg) == FALSE)
{ return; }
functionName = DOToString(theArg);
functionReference = FunctionReferenceExpression(theEnv,functionName);
if (functionReference == NULL)
{
ExpectedTypeError1(theEnv,"sort",1,"function name, deffunction name, or defgeneric name");
return;
}
/*======================================*/
/* For an external function, verify the */
/* correct number of arguments. */
/*======================================*/
if (functionReference->type == FCALL)
{
fptr = (struct FunctionDefinition *) functionReference->value;
if ((GetMinimumArgs(fptr) > 2) ||
(GetMaximumArgs(fptr) == 0) ||
(GetMaximumArgs(fptr) == 1))
{
ExpectedTypeError1(theEnv,"sort",1,"function name expecting two arguments");
ReturnExpression(theEnv,functionReference);
return;
}
}
/*=======================================*/
/* For a deffunction, verify the correct */
/* number of arguments. */
/*=======================================*/
#if DEFFUNCTION_CONSTRUCT
if (functionReference->type == PCALL)
{
dptr = (DEFFUNCTION *) functionReference->value;
if ((dptr->minNumberOfParameters > 2) ||
(dptr->maxNumberOfParameters == 0) ||
(dptr->maxNumberOfParameters == 1))
{
ExpectedTypeError1(theEnv,"sort",1,"deffunction name expecting two arguments");
ReturnExpression(theEnv,functionReference);
return;
}
}
#endif
/*=====================================*/
/* If there are no items to be sorted, */
/* then return an empty multifield. */
/*=====================================*/
if (argumentCount == 1)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
ReturnExpression(theEnv,functionReference);
return;
}
/*=====================================*/
/* Retrieve the arguments to be sorted */
/* and determine how many there are. */
/*=====================================*/
theArguments = (DATA_OBJECT *) genalloc(theEnv,(argumentCount - 1) * sizeof(DATA_OBJECT));
for (i = 2; i <= argumentCount; i++)
{
EnvRtnUnknown(theEnv,i,&theArguments[i-2]);
if (GetType(theArguments[i-2]) == MULTIFIELD)
{ argumentSize += GetpDOLength(&theArguments[i-2]); }
else
{ argumentSize++; }
}
if (argumentSize == 0)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
ReturnExpression(theEnv,functionReference);
return;
}
/*====================================*/
/* Pack all of the items to be sorted */
/* into a data object array. */
/*====================================*/
theArguments2 = (DATA_OBJECT *) genalloc(theEnv,argumentSize * sizeof(DATA_OBJECT));
for (i = 2; i <= argumentCount; i++)
{
if (GetType(theArguments[i-2]) == MULTIFIELD)
{
tempMultifield = (struct multifield *) GetValue(theArguments[i-2]);
for (j = GetDOBegin(theArguments[i-2]); j <= GetDOEnd(theArguments[i-2]); j++, k++)
{
SetType(theArguments2[k],GetMFType(tempMultifield,j));
SetValue(theArguments2[k],GetMFValue(tempMultifield,j));
}
}
else
{
SetType(theArguments2[k],GetType(theArguments[i-2]));
SetValue(theArguments2[k],GetValue(theArguments[i-2]));
k++;
}
}
genfree(theEnv,theArguments,(argumentCount - 1) * sizeof(DATA_OBJECT));
functionReference->nextArg = SortFunctionData(theEnv)->SortComparisonFunction;
SortFunctionData(theEnv)->SortComparisonFunction = functionReference;
for (i = 0; i < argumentSize; i++)
{ ValueInstall(theEnv,&theArguments2[i]); }
MergeSort(theEnv,(unsigned long) argumentSize,theArguments2,DefaultCompareSwapFunction);
for (i = 0; i < argumentSize; i++)
{ ValueDeinstall(theEnv,&theArguments2[i]); }
SortFunctionData(theEnv)->SortComparisonFunction = SortFunctionData(theEnv)->SortComparisonFunction->nextArg;
functionReference->nextArg = NULL;
ReturnExpression(theEnv,functionReference);
theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,(unsigned long) argumentSize);
for (i = 0; i < argumentSize; i++)
{
SetMFType(theMultifield,i+1,GetType(theArguments2[i]));
SetMFValue(theMultifield,i+1,GetValue(theArguments2[i]));
}
genfree(theEnv,theArguments2,argumentSize * sizeof(DATA_OBJECT));
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,argumentSize);
SetpValue(returnValue,(void *) theMultifield);
}
void C_leer_ficha(void *environment, DATA_OBJECT_PTR returnValuePtr)
{
SDL_Event evento;
int x, y, pos, head=1;
void *retorno;
char fin=0, fin2=0;
if (n == 0) {
x=-1;
y=-1;
fin = 1;
}
leyendo=1;
while (!fin) {
while (SDL_PollEvent(&evento)) {
switch (evento.type) {
case SDL_QUIT:
SDL_Quit();
fin = 1;
break;
case SDL_MOUSEBUTTONDOWN:
if (evento.button.button == SDL_BUTTON_RIGHT) {
x=-1; y=-1;
fin = 1;
break;
}
if (evento.button.y >= FICHAS_Y &&
evento.button.y <= FICHAS_Y + fichaH) {
for (pos=0; pos<n; ++pos) {
if (evento.button.y >= FICHAS_Y &&
evento.button.y <= FICHAS_Y + fichaH) {
if (evento.button.x >= (30 + pos*(fichaW + 10)) &&
evento.button.x <= (30 + pos*(fichaW + 10) + fichaW)) {
if (evento.button.y > FICHAS_Y + fichaH/2) {
x = fichas[jugador[pos]].y;
y = fichas[jugador[pos]].x;
}
else {
x = fichas[jugador[pos]].x;
y = fichas[jugador[pos]].y;
}
fin2=0;
while (!fin2) {
SDL_PollEvent(&evento);
switch (evento.type) {
case SDL_MOUSEBUTTONDOWN:
if (evento.button.button == SDL_BUTTON_RIGHT) fin2=1;
else {
if (is_head (evento.button.x, evento.button.y))
fin=1, fin2=1;
else if (is_tail (evento.button.x, evento.button.y)) {
fin = x;
x = y;
y = fin;
fin = 1;
head = 0;
fin2=1;
}
}
break;
}
}
}
}
}
}
break;
}
}
C_flip(environment);
}
retorno = EnvCreateMultifield(environment,3);
SetMFType(retorno, 1, INTEGER);
SetMFValue(retorno, 1, EnvAddLong(environment,x));
SetMFType(retorno, 2, INTEGER);
SetMFValue(retorno, 2, EnvAddLong(environment,y));
SetMFType(retorno, 3, INTEGER);
SetMFValue(retorno, 3, EnvAddLong(environment,head));
SetpType(returnValuePtr, MULTIFIELD);
SetpValue(returnValuePtr, retorno);
SetpDOBegin(returnValuePtr, 1);
SetpDOEnd(returnValuePtr, 3);
n=0;
while (SDL_PollEvent(&evento));
}
globle void DeriveDefaultFromConstraints(
void *theEnv,
CONSTRAINT_RECORD *constraints,
DATA_OBJECT *theDefault,
int multifield,
int garbageMultifield)
{
unsigned short theType;
unsigned long minFields;
void *theValue;
/*=============================================================*/
/* If no constraints are specified, then use the symbol nil as */
/* a default for single field slots and a multifield of length */
/* 0 as a default for multifield slots. */
/*=============================================================*/
if (constraints == NULL)
{
if (multifield)
{
SetpType(theDefault,MULTIFIELD);
SetpDOBegin(theDefault,1);
SetpDOEnd(theDefault,0);
if (garbageMultifield) SetpValue(theDefault,(void *) EnvCreateMultifield(theEnv,0L));
else SetpValue(theDefault,(void *) CreateMultifield2(theEnv,0L));
}
else
{
theDefault->type = SYMBOL;
theDefault->value = EnvAddSymbol(theEnv,(char*)"nil");
}
return;
}
/*=========================================*/
/* Determine the default's type and value. */
/*=========================================*/
if (constraints->anyAllowed || constraints->symbolsAllowed)
{
theType = SYMBOL;
theValue = FindDefaultValue(theEnv,SYMBOL,constraints,EnvAddSymbol(theEnv,(char*)"nil"));
}
else if (constraints->stringsAllowed)
{
theType = STRING;
theValue = FindDefaultValue(theEnv,STRING,constraints,EnvAddSymbol(theEnv,(char*)""));
}
else if (constraints->integersAllowed)
{
theType = INTEGER;
theValue = FindDefaultValue(theEnv,INTEGER,constraints,EnvAddLong(theEnv,0LL));
}
else if (constraints->floatsAllowed)
{
theType = FLOAT;
theValue = FindDefaultValue(theEnv,FLOAT,constraints,EnvAddDouble(theEnv,0.0));
}
#if OBJECT_SYSTEM
else if (constraints->instanceNamesAllowed)
{
theType = INSTANCE_NAME;
theValue = FindDefaultValue(theEnv,INSTANCE_NAME,constraints,EnvAddSymbol(theEnv,(char*)"nil"));
}
else if (constraints->instanceAddressesAllowed)
{
theType = INSTANCE_ADDRESS;
theValue = (void *) &InstanceData(theEnv)->DummyInstance;
}
#endif
#if DEFTEMPLATE_CONSTRUCT
else if (constraints->factAddressesAllowed)
{
theType = FACT_ADDRESS;
theValue = (void *) &FactData(theEnv)->DummyFact;
}
#endif
else if (constraints->externalAddressesAllowed)
{
theType = EXTERNAL_ADDRESS;
theValue = EnvAddExternalAddress(theEnv,NULL,0);
}
else
{
theType = SYMBOL;
theValue = EnvAddSymbol(theEnv,(char*)"nil");
}
/*=========================================================*/
/* If the default is for a multifield slot, then create a */
/* multifield default value that satisfies the cardinality */
/* constraints for the slot. The default value for a */
/* multifield slot is a multifield of length 0. */
/*=========================================================*/
if (multifield)
{
if (constraints->minFields == NULL) minFields = 0;
else if (constraints->minFields->value == SymbolData(theEnv)->NegativeInfinity) minFields = 0;
else minFields = (unsigned long) ValueToLong(constraints->minFields->value);
SetpType(theDefault,MULTIFIELD);
SetpDOBegin(theDefault,1);
SetpDOEnd(theDefault,(long) minFields);
if (garbageMultifield) SetpValue(theDefault,(void *) EnvCreateMultifield(theEnv,minFields));
else SetpValue(theDefault,(void *) CreateMultifield2(theEnv,minFields));
for (; minFields > 0; minFields--)
{
SetMFType(GetpValue(theDefault),minFields,theType);
SetMFValue(GetpValue(theDefault),minFields,theValue);
}
}
else
{
theDefault->type = theType;
theDefault->value = theValue;
}
}