1 /*******************************************************/
2 /* "C" Language Integrated Production System */
3 /* */
4 /* CLIPS Version 6.30 08/22/14 */
5 /* */
6 /* INSTANCE COMMAND MODULE */
7 /*******************************************************/
8
9 /*************************************************************/
10 /* Purpose: Kernel Interface Commands for Instances */
11 /* */
12 /* Principal Programmer(s): */
13 /* Brian L. Dantes */
14 /* */
15 /* Contributing Programmer(s): */
16 /* */
17 /* Revision History: */
18 /* */
19 /* 6.23: Correction for FalseSymbol/TrueSymbol. DR0859 */
20 /* */
21 /* Corrected compilation errors for files */
22 /* generated by constructs-to-c. DR0861 */
23 /* */
24 /* 6.24: Loading a binary instance file from a run-time */
25 /* program caused a bus error. DR0866 */
26 /* */
27 /* Removed LOGICAL_DEPENDENCIES compilation flag. */
28 /* */
29 /* Converted INSTANCE_PATTERN_MATCHING to */
30 /* DEFRULE_CONSTRUCT. */
31 /* */
32 /* Renamed BOOLEAN macro type to intBool. */
33 /* */
34 /* 6.30: Removed conditional code for unsupported */
35 /* compilers/operating systems (IBM_MCW, */
36 /* MAC_MCW, and IBM_TBC). */
37 /* */
38 /* Changed integer type/precision. */
39 /* */
40 /* Changed garbage collection algorithm. */
41 /* */
42 /* Added const qualifiers to remove C++ */
43 /* deprecation warnings. */
44 /* */
45 /* Converted API macros to function calls. */
46 /* */
47 /*************************************************************/
48
49 /* =========================================
50 *****************************************
51 EXTERNAL DEFINITIONS
52 =========================================
53 ***************************************** */
54 #include "setup.h"
55
56 #if OBJECT_SYSTEM
57
58 #include "argacces.h"
59 #include "classcom.h"
60 #include "classfun.h"
61 #include "classinf.h"
62 #include "envrnmnt.h"
63 #include "exprnpsr.h"
64 #include "evaluatn.h"
65 #include "insfile.h"
66 #include "insfun.h"
67 #include "insmngr.h"
68 #include "insmoddp.h"
69 #include "insmult.h"
70 #include "inspsr.h"
71 #include "lgcldpnd.h"
72 #include "memalloc.h"
73 #include "msgcom.h"
74 #include "msgfun.h"
75 #include "router.h"
76 #include "strngrtr.h"
77 #include "sysdep.h"
78 #include "utility.h"
79 #include "commline.h"
80
81 #define _INSCOM_SOURCE_
82 #include "inscom.h"
83
84 /* =========================================
85 *****************************************
86 CONSTANTS
87 =========================================
88 ***************************************** */
89 #define ALL_QUALIFIER "inherit"
90
91 /* =========================================
92 *****************************************
93 INTERNALLY VISIBLE FUNCTION HEADERS
94 =========================================
95 ***************************************** */
96
97 #if DEBUGGING_FUNCTIONS
98 static long ListInstancesInModule(void *,int,const char *,const char *,intBool,intBool);
99 static long TabulateInstances(void *,int,const char *,DEFCLASS *,intBool,intBool);
100 #endif
101
102 static void PrintInstance(void *,const char *,INSTANCE_TYPE *,const char *);
103 static INSTANCE_SLOT *FindISlotByName(void *,INSTANCE_TYPE *,const char *);
104 static void DeallocateInstanceData(void *);
105
106 /* =========================================
107 *****************************************
108 EXTERNALLY VISIBLE FUNCTIONS
109 =========================================
110 ***************************************** */
111
112 /*********************************************************
113 NAME : SetupInstances
114 DESCRIPTION : Initializes instance Hash Table,
115 Function Parsers, and Data Structures
116 INPUTS : None
117 RETURNS : Nothing useful
118 SIDE EFFECTS : None
119 NOTES : None
120 *********************************************************/
SetupInstances(void * theEnv)121 globle void SetupInstances(
122 void *theEnv)
123 {
124 struct patternEntityRecord instanceInfo = { { "INSTANCE_ADDRESS",
125 INSTANCE_ADDRESS,0,0,0,
126 PrintInstanceName,
127 PrintInstanceLongForm,
128 EnvUnmakeInstance,
129 NULL,
130 EnvGetNextInstance,
131 EnvDecrementInstanceCount,
132 EnvIncrementInstanceCount,
133 NULL,NULL,NULL,NULL,NULL
134 },
135 #if DEFRULE_CONSTRUCT && OBJECT_SYSTEM
136 DecrementObjectBasisCount,
137 IncrementObjectBasisCount,
138 MatchObjectFunction,
139 NetworkSynchronized,
140 InstanceIsDeleted
141 #else
142 NULL,NULL,NULL,NULL,NULL
143 #endif
144 };
145
146 INSTANCE_TYPE dummyInstance = { { NULL, NULL, 0, 0L },
147 NULL, NULL, 0, 1, 0, 0, 0,
148 NULL, 0, 0, NULL, NULL, NULL, NULL,
149 NULL, NULL, NULL, NULL, NULL };
150
151 AllocateEnvironmentData(theEnv,INSTANCE_DATA,sizeof(struct instanceData),DeallocateInstanceData);
152
153 InstanceData(theEnv)->MkInsMsgPass = TRUE;
154 memcpy(&InstanceData(theEnv)->InstanceInfo,&instanceInfo,sizeof(struct patternEntityRecord));
155 dummyInstance.header.theInfo = &InstanceData(theEnv)->InstanceInfo;
156 memcpy(&InstanceData(theEnv)->DummyInstance,&dummyInstance,sizeof(INSTANCE_TYPE));
157
158 InitializeInstanceTable(theEnv);
159 InstallPrimitive(theEnv,(struct entityRecord *) &InstanceData(theEnv)->InstanceInfo,INSTANCE_ADDRESS);
160
161 #if ! RUN_TIME
162
163 #if DEFRULE_CONSTRUCT && OBJECT_SYSTEM
164 EnvDefineFunction2(theEnv,"initialize-instance",'u',
165 PTIEF InactiveInitializeInstance,"InactiveInitializeInstance",NULL);
166 EnvDefineFunction2(theEnv,"active-initialize-instance",'u',
167 PTIEF InitializeInstanceCommand,"InitializeInstanceCommand",NULL);
168 AddFunctionParser(theEnv,"active-initialize-instance",ParseInitializeInstance);
169
170 EnvDefineFunction2(theEnv,"make-instance",'u',PTIEF InactiveMakeInstance,"InactiveMakeInstance",NULL);
171 EnvDefineFunction2(theEnv,"active-make-instance",'u',PTIEF MakeInstanceCommand,"MakeInstanceCommand",NULL);
172 AddFunctionParser(theEnv,"active-make-instance",ParseInitializeInstance);
173
174 #else
175 EnvDefineFunction2(theEnv,"initialize-instance",'u',
176 PTIEF InitializeInstanceCommand,"InitializeInstanceCommand",NULL);
177 EnvDefineFunction2(theEnv,"make-instance",'u',PTIEF MakeInstanceCommand,"MakeInstanceCommand",NULL);
178 #endif
179 AddFunctionParser(theEnv,"initialize-instance",ParseInitializeInstance);
180 AddFunctionParser(theEnv,"make-instance",ParseInitializeInstance);
181
182 EnvDefineFunction2(theEnv,"init-slots",'u',PTIEF InitSlotsCommand,"InitSlotsCommand","00");
183
184 EnvDefineFunction2(theEnv,"delete-instance",'b',PTIEF DeleteInstanceCommand,
185 "DeleteInstanceCommand","00");
186 EnvDefineFunction2(theEnv,"(create-instance)",'b',PTIEF CreateInstanceHandler,
187 "CreateInstanceHandler","00");
188 EnvDefineFunction2(theEnv,"unmake-instance",'b',PTIEF UnmakeInstanceCommand,
189 "UnmakeInstanceCommand","1*e");
190
191 #if DEBUGGING_FUNCTIONS
192 EnvDefineFunction2(theEnv,"instances",'v',PTIEF InstancesCommand,"InstancesCommand","*3w");
193 EnvDefineFunction2(theEnv,"ppinstance",'v',PTIEF PPInstanceCommand,"PPInstanceCommand","00");
194 #endif
195
196 EnvDefineFunction2(theEnv,"symbol-to-instance-name",'u',
197 PTIEF SymbolToInstanceName,"SymbolToInstanceName","11w");
198 EnvDefineFunction2(theEnv,"instance-name-to-symbol",'w',
199 PTIEF InstanceNameToSymbol,"InstanceNameToSymbol","11p");
200 EnvDefineFunction2(theEnv,"instance-address",'u',PTIEF InstanceAddressCommand,
201 "InstanceAddressCommand","12eep");
202 EnvDefineFunction2(theEnv,"instance-addressp",'b',PTIEF InstanceAddressPCommand,
203 "InstanceAddressPCommand","11");
204 EnvDefineFunction2(theEnv,"instance-namep",'b',PTIEF InstanceNamePCommand,
205 "InstanceNamePCommand","11");
206 EnvDefineFunction2(theEnv,"instance-name",'u',PTIEF InstanceNameCommand,
207 "InstanceNameCommand","11e");
208 EnvDefineFunction2(theEnv,"instancep",'b',PTIEF InstancePCommand,"InstancePCommand","11");
209 EnvDefineFunction2(theEnv,"instance-existp",'b',PTIEF InstanceExistPCommand,
210 "InstanceExistPCommand","11e");
211 EnvDefineFunction2(theEnv,"class",'u',PTIEF ClassCommand,"ClassCommand","11");
212
213 SetupInstanceModDupCommands(theEnv);
214 /* SetupInstanceFileCommands(theEnv); DR0866 */
215 SetupInstanceMultifieldCommands(theEnv);
216
217 #endif
218
219 SetupInstanceFileCommands(theEnv); /* DR0866 */
220
221 AddCleanupFunction(theEnv,"instances",CleanupInstances,0);
222 EnvAddResetFunction(theEnv,"instances",DestroyAllInstances,60);
223 }
224
225 /***************************************/
226 /* DeallocateInstanceData: Deallocates */
227 /* environment data for instances. */
228 /***************************************/
DeallocateInstanceData(void * theEnv)229 static void DeallocateInstanceData(
230 void *theEnv)
231 {
232 INSTANCE_TYPE *tmpIPtr, *nextIPtr;
233 long i;
234 INSTANCE_SLOT *sp;
235 IGARBAGE *tmpGPtr, *nextGPtr;
236 struct patternMatch *theMatch, *tmpMatch;
237
238 /*=================================*/
239 /* Remove the instance hash table. */
240 /*=================================*/
241
242 rm(theEnv,InstanceData(theEnv)->InstanceTable,
243 (int) (sizeof(INSTANCE_TYPE *) * INSTANCE_TABLE_HASH_SIZE));
244
245 /*=======================*/
246 /* Return all instances. */
247 /*=======================*/
248
249 tmpIPtr = InstanceData(theEnv)->InstanceList;
250 while (tmpIPtr != NULL)
251 {
252 nextIPtr = tmpIPtr->nxtList;
253
254 theMatch = (struct patternMatch *) tmpIPtr->partialMatchList;
255 while (theMatch != NULL)
256 {
257 tmpMatch = theMatch->next;
258 rtn_struct(theEnv,patternMatch,theMatch);
259 theMatch = tmpMatch;
260 }
261
262 #if DEFRULE_CONSTRUCT
263 ReturnEntityDependencies(theEnv,(struct patternEntity *) tmpIPtr);
264 #endif
265
266 for (i = 0 ; i < tmpIPtr->cls->instanceSlotCount ; i++)
267 {
268 sp = tmpIPtr->slotAddresses[i];
269 if ((sp == &sp->desc->sharedValue) ?
270 (--sp->desc->sharedCount == 0) : TRUE)
271 {
272 if (sp->desc->multiple)
273 { ReturnMultifield(theEnv,(MULTIFIELD_PTR) sp->value); }
274 }
275 }
276
277 if (tmpIPtr->cls->instanceSlotCount != 0)
278 {
279 rm(theEnv,(void *) tmpIPtr->slotAddresses,
280 (tmpIPtr->cls->instanceSlotCount * sizeof(INSTANCE_SLOT *)));
281 if (tmpIPtr->cls->localInstanceSlotCount != 0)
282 {
283 rm(theEnv,(void *) tmpIPtr->slots,
284 (tmpIPtr->cls->localInstanceSlotCount * sizeof(INSTANCE_SLOT)));
285 }
286 }
287
288 rtn_struct(theEnv,instance,tmpIPtr);
289
290 tmpIPtr = nextIPtr;
291 }
292
293 /*===============================*/
294 /* Get rid of garbage instances. */
295 /*===============================*/
296
297 tmpGPtr = InstanceData(theEnv)->InstanceGarbageList;
298 while (tmpGPtr != NULL)
299 {
300 nextGPtr = tmpGPtr->nxt;
301 rtn_struct(theEnv,instance,tmpGPtr->ins);
302 rtn_struct(theEnv,igarbage,tmpGPtr);
303 tmpGPtr = nextGPtr;
304 }
305 }
306
307 /*******************************************************************
308 NAME : EnvDeleteInstance
309 DESCRIPTION : DIRECTLY removes a named instance from the
310 hash table and its class's
311 instance list
312 INPUTS : The instance address (NULL to delete all instances)
313 RETURNS : 1 if successful, 0 otherwise
314 SIDE EFFECTS : Instance is deallocated
315 NOTES : C interface for deleting instances
316 *******************************************************************/
EnvDeleteInstance(void * theEnv,void * iptr)317 globle intBool EnvDeleteInstance(
318 void *theEnv,
319 void *iptr)
320 {
321 INSTANCE_TYPE *ins,*itmp;
322 int success = 1;
323
324 if (iptr != NULL)
325 return(QuashInstance(theEnv,(INSTANCE_TYPE *) iptr));
326 ins = InstanceData(theEnv)->InstanceList;
327 while (ins != NULL)
328 {
329 itmp = ins;
330 ins = ins->nxtList;
331 if (QuashInstance(theEnv,(INSTANCE_TYPE *) itmp) == 0)
332 success = 0;
333 }
334
335 if ((UtilityData(theEnv)->CurrentGarbageFrame->topLevel) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
336 (EvaluationData(theEnv)->CurrentExpression == NULL) && (UtilityData(theEnv)->GarbageCollectionLocks == 0))
337 {
338 CleanCurrentGarbageFrame(theEnv,NULL);
339 CallPeriodicTasks(theEnv);
340 }
341
342 return(success);
343 }
344
345 /*******************************************************************
346 NAME : EnvUnmakeInstance
347 DESCRIPTION : Removes a named instance via message-passing
348 INPUTS : The instance address (NULL to delete all instances)
349 RETURNS : 1 if successful, 0 otherwise
350 SIDE EFFECTS : Instance is deallocated
351 NOTES : C interface for deleting instances
352 *******************************************************************/
EnvUnmakeInstance(void * theEnv,void * iptr)353 globle intBool EnvUnmakeInstance(
354 void *theEnv,
355 void *iptr)
356 {
357 INSTANCE_TYPE *ins;
358 int success = 1,svmaintain;
359
360 svmaintain = InstanceData(theEnv)->MaintainGarbageInstances;
361 InstanceData(theEnv)->MaintainGarbageInstances = TRUE;
362 ins = (INSTANCE_TYPE *) iptr;
363 if (ins != NULL)
364 {
365 if (ins->garbage)
366 success = 0;
367 else
368 {
369 DirectMessage(theEnv,MessageHandlerData(theEnv)->DELETE_SYMBOL,ins,NULL,NULL);
370 if (ins->garbage == 0)
371 success = 0;
372 }
373 }
374 else
375 {
376 ins = InstanceData(theEnv)->InstanceList;
377 while (ins != NULL)
378 {
379 DirectMessage(theEnv,MessageHandlerData(theEnv)->DELETE_SYMBOL,ins,NULL,NULL);
380 if (ins->garbage == 0)
381 success = 0;
382 ins = ins->nxtList;
383 while ((ins != NULL) ? ins->garbage : FALSE)
384 ins = ins->nxtList;
385 }
386 }
387 InstanceData(theEnv)->MaintainGarbageInstances = svmaintain;
388 CleanupInstances(theEnv);
389
390 if ((UtilityData(theEnv)->CurrentGarbageFrame->topLevel) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
391 (EvaluationData(theEnv)->CurrentExpression == NULL) && (UtilityData(theEnv)->GarbageCollectionLocks == 0))
392 {
393 CleanCurrentGarbageFrame(theEnv,NULL);
394 CallPeriodicTasks(theEnv);
395 }
396
397 return(success);
398 }
399
400 #if DEBUGGING_FUNCTIONS
401
402 /*******************************************************************
403 NAME : InstancesCommand
404 DESCRIPTION : Lists all instances associated
405 with a particular class
406 INPUTS : None
407 RETURNS : Nothing useful
408 SIDE EFFECTS : None
409 NOTES : H/L Syntax : (instances [<class-name> [inherit]])
410 *******************************************************************/
InstancesCommand(void * theEnv)411 globle void InstancesCommand(
412 void *theEnv)
413 {
414 int argno, inheritFlag = FALSE;
415 void *theDefmodule;
416 const char *className = NULL;
417 DATA_OBJECT temp;
418
419 theDefmodule = (void *) EnvGetCurrentModule(theEnv);
420
421 argno = EnvRtnArgCount(theEnv);
422 if (argno > 0)
423 {
424 if (EnvArgTypeCheck(theEnv,"instances",1,SYMBOL,&temp) == FALSE)
425 return;
426 theDefmodule = EnvFindDefmodule(theEnv,DOToString(temp));
427 if ((theDefmodule != NULL) ? FALSE :
428 (strcmp(DOToString(temp),"*") != 0))
429 {
430 SetEvaluationError(theEnv,TRUE);
431 ExpectedTypeError1(theEnv,"instances",1,"defmodule name");
432 return;
433 }
434 if (argno > 1)
435 {
436 if (EnvArgTypeCheck(theEnv,"instances",2,SYMBOL,&temp) == FALSE)
437 return;
438 className = DOToString(temp);
439 if (LookupDefclassAnywhere(theEnv,(struct defmodule *) theDefmodule,className) == NULL)
440 {
441 if (strcmp(className,"*") == 0)
442 className = NULL;
443 else
444 {
445 ClassExistError(theEnv,"instances",className);
446 return;
447 }
448 }
449 if (argno > 2)
450 {
451 if (EnvArgTypeCheck(theEnv,"instances",3,SYMBOL,&temp) == FALSE)
452 return;
453 if (strcmp(DOToString(temp),ALL_QUALIFIER) != 0)
454 {
455 SetEvaluationError(theEnv,TRUE);
456 ExpectedTypeError1(theEnv,"instances",3,"keyword \"inherit\"");
457 return;
458 }
459 inheritFlag = TRUE;
460 }
461 }
462 }
463 EnvInstances(theEnv,WDISPLAY,theDefmodule,className,inheritFlag);
464 }
465
466 /********************************************************
467 NAME : PPInstanceCommand
468 DESCRIPTION : Displays the current slot-values
469 of an instance
470 INPUTS : None
471 RETURNS : Nothing useful
472 SIDE EFFECTS : None
473 NOTES : H/L Syntax : (ppinstance <instance>)
474 ********************************************************/
PPInstanceCommand(void * theEnv)475 globle void PPInstanceCommand(
476 void *theEnv)
477 {
478 INSTANCE_TYPE *ins;
479
480 if (CheckCurrentMessage(theEnv,"ppinstance",TRUE) == FALSE)
481 return;
482 ins = GetActiveInstance(theEnv);
483 if (ins->garbage == 1)
484 return;
485 PrintInstance(theEnv,WDISPLAY,ins,"\n");
486 EnvPrintRouter(theEnv,WDISPLAY,"\n");
487 }
488
489 /***************************************************************
490 NAME : EnvInstances
491 DESCRIPTION : Lists instances of classes
492 INPUTS : 1) The logical name for the output
493 2) Address of the module (NULL for all classes)
494 3) Name of the class
495 (NULL for all classes in specified module)
496 4) A flag indicating whether to print instances
497 of subclasses or not
498 RETURNS : Nothing useful
499 SIDE EFFECTS : None
500 NOTES : None
501 **************************************************************/
EnvInstances(void * theEnv,const char * logicalName,void * theVModule,const char * className,int inheritFlag)502 globle void EnvInstances(
503 void *theEnv,
504 const char *logicalName,
505 void *theVModule,
506 const char *className,
507 int inheritFlag)
508 {
509 int id;
510 struct defmodule *theModule;
511 long count = 0L;
512
513 /* ===========================================
514 Grab a traversal id to avoid printing out
515 instances twice due to multiple inheritance
516 =========================================== */
517 if ((id = GetTraversalID(theEnv)) == -1)
518 return;
519 SaveCurrentModule(theEnv);
520
521 /* ====================================
522 For all modules, print out instances
523 of specified class(es)
524 ==================================== */
525 if (theVModule == NULL)
526 {
527 theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,NULL);
528 while (theModule != NULL)
529 {
530 if (GetHaltExecution(theEnv) == TRUE)
531 {
532 RestoreCurrentModule(theEnv);
533 ReleaseTraversalID(theEnv);
534 return;
535 }
536
537 EnvPrintRouter(theEnv,logicalName,EnvGetDefmoduleName(theEnv,(void *) theModule));
538 EnvPrintRouter(theEnv,logicalName,":\n");
539 EnvSetCurrentModule(theEnv,(void *) theModule);
540 count += ListInstancesInModule(theEnv,id,logicalName,className,inheritFlag,TRUE);
541 theModule = (struct defmodule *) EnvGetNextDefmodule(theEnv,(void *) theModule);
542 }
543 }
544
545 /* ====================================
546 For the specified module, print out
547 instances of the specified class(es)
548 ==================================== */
549 else
550 {
551 EnvSetCurrentModule(theEnv,(void *) theVModule);
552 count = ListInstancesInModule(theEnv,id,logicalName,className,inheritFlag,FALSE);
553 }
554
555 RestoreCurrentModule(theEnv);
556 ReleaseTraversalID(theEnv);
557 if (EvaluationData(theEnv)->HaltExecution == FALSE)
558 PrintTally(theEnv,logicalName,count,"instance","instances");
559 }
560
561 #endif /* DEBUGGING_FUNCTIONS */
562
563 /*********************************************************
564 NAME : EnvMakeInstance
565 DESCRIPTION : C Interface for creating and
566 initializing a class instance
567 INPUTS : The make-instance call string,
568 e.g. "([bill] of man (age 34))"
569 RETURNS : The instance address if instance created,
570 NULL otherwise
571 SIDE EFFECTS : Creates the instance and returns
572 the result in caller's buffer
573 NOTES : None
574 *********************************************************/
EnvMakeInstance(void * theEnv,const char * mkstr)575 globle void *EnvMakeInstance(
576 void *theEnv,
577 const char *mkstr)
578 {
579 const char *router = "***MKINS***";
580 struct token tkn;
581 EXPRESSION *top;
582 DATA_OBJECT result;
583
584 result.type = SYMBOL;
585 result.value = EnvFalseSymbol(theEnv);
586 if (OpenStringSource(theEnv,router,mkstr,0) == 0)
587 return(NULL);
588 GetToken(theEnv,router,&tkn);
589 if (tkn.type == LPAREN)
590 {
591 top = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"make-instance"));
592 if (ParseSimpleInstance(theEnv,top,router) != NULL)
593 {
594 GetToken(theEnv,router,&tkn);
595 if (tkn.type == STOP)
596 {
597 ExpressionInstall(theEnv,top);
598 EvaluateExpression(theEnv,top,&result);
599 ExpressionDeinstall(theEnv,top);
600 }
601 else
602 SyntaxErrorMessage(theEnv,"instance definition");
603 ReturnExpression(theEnv,top);
604 }
605 }
606 else
607 SyntaxErrorMessage(theEnv,"instance definition");
608 CloseStringSource(theEnv,router);
609
610 if ((UtilityData(theEnv)->CurrentGarbageFrame->topLevel) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
611 (EvaluationData(theEnv)->CurrentExpression == NULL) && (UtilityData(theEnv)->GarbageCollectionLocks == 0))
612 {
613 CleanCurrentGarbageFrame(theEnv,NULL);
614 CallPeriodicTasks(theEnv);
615 }
616
617 if ((result.type == SYMBOL) && (result.value == EnvFalseSymbol(theEnv)))
618 return(NULL);
619
620 return((void *) FindInstanceBySymbol(theEnv,(SYMBOL_HN *) result.value));
621 }
622
623 /***************************************************************
624 NAME : EnvCreateRawInstance
625 DESCRIPTION : Creates an empty of instance of the specified
626 class. No slot-overrides or class defaults
627 are applied.
628 INPUTS : 1) Address of class
629 2) Name of the new instance
630 RETURNS : The instance address if instance created,
631 NULL otherwise
632 SIDE EFFECTS : Old instance of same name deleted (if possible)
633 NOTES : None
634 ***************************************************************/
EnvCreateRawInstance(void * theEnv,void * cptr,const char * iname)635 globle void *EnvCreateRawInstance(
636 void *theEnv,
637 void *cptr,
638 const char *iname)
639 {
640 return((void *) BuildInstance(theEnv,(SYMBOL_HN *) EnvAddSymbol(theEnv,iname),(DEFCLASS *) cptr,FALSE));
641 }
642
643 /***************************************************************************
644 NAME : EnvFindInstance
645 DESCRIPTION : Looks up a specified instance in the instance hash table
646 INPUTS : Name-string of the instance
647 RETURNS : The address of the found instance, NULL otherwise
648 SIDE EFFECTS : None
649 NOTES : None
650 ***************************************************************************/
EnvFindInstance(void * theEnv,void * theModule,const char * iname,unsigned searchImports)651 globle void *EnvFindInstance(
652 void *theEnv,
653 void *theModule,
654 const char *iname,
655 unsigned searchImports)
656 {
657 SYMBOL_HN *isym;
658
659 isym = FindSymbolHN(theEnv,iname);
660 if (isym == NULL)
661 return(NULL);
662 if (theModule == NULL)
663 theModule = (void *) EnvGetCurrentModule(theEnv);
664 return((void *) FindInstanceInModule(theEnv,isym,(struct defmodule *) theModule,
665 ((struct defmodule *) EnvGetCurrentModule(theEnv)),searchImports));
666 }
667
668 /***************************************************************************
669 NAME : EnvValidInstanceAddress
670 DESCRIPTION : Determines if an instance address is still valid
671 INPUTS : Instance address
672 RETURNS : 1 if the address is still valid, 0 otherwise
673 SIDE EFFECTS : None
674 NOTES : None
675 ***************************************************************************/
EnvValidInstanceAddress(void * theEnv,void * iptr)676 globle int EnvValidInstanceAddress(
677 void *theEnv,
678 void *iptr)
679 {
680 #if MAC_XCD
681 #pragma unused(theEnv)
682 #endif
683
684 return((((INSTANCE_TYPE *) iptr)->garbage == 0) ? 1 : 0);
685 }
686
687 /***************************************************
688 NAME : EnvDirectGetSlot
689 DESCRIPTION : Gets a slot value
690 INPUTS : 1) Instance address
691 2) Slot name
692 3) Caller's result buffer
693 RETURNS : Nothing useful
694 SIDE EFFECTS : None
695 NOTES : None
696 ***************************************************/
EnvDirectGetSlot(void * theEnv,void * ins,const char * sname,DATA_OBJECT * result)697 globle void EnvDirectGetSlot(
698 void *theEnv,
699 void *ins,
700 const char *sname,
701 DATA_OBJECT *result)
702 {
703 INSTANCE_SLOT *sp;
704
705 if (((INSTANCE_TYPE *) ins)->garbage == 1)
706 {
707 SetEvaluationError(theEnv,TRUE);
708 result->type = SYMBOL;
709 result->value = EnvFalseSymbol(theEnv);
710 return;
711 }
712 sp = FindISlotByName(theEnv,(INSTANCE_TYPE *) ins,sname);
713 if (sp == NULL)
714 {
715 SetEvaluationError(theEnv,TRUE);
716 result->type = SYMBOL;
717 result->value = EnvFalseSymbol(theEnv);
718 return;
719 }
720 result->type = (unsigned short) sp->type;
721 result->value = sp->value;
722 if (sp->type == MULTIFIELD)
723 {
724 result->begin = 0;
725 SetpDOEnd(result,GetInstanceSlotLength(sp));
726 }
727 if ((UtilityData(theEnv)->CurrentGarbageFrame->topLevel) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
728 (EvaluationData(theEnv)->CurrentExpression == NULL) && (UtilityData(theEnv)->GarbageCollectionLocks == 0))
729 {
730 CleanCurrentGarbageFrame(theEnv,result);
731 CallPeriodicTasks(theEnv);
732 }
733 }
734
735 /*********************************************************
736 NAME : EnvDirectPutSlot
737 DESCRIPTION : Gets a slot value
738 INPUTS : 1) Instance address
739 2) Slot name
740 3) Caller's new value buffer
741 RETURNS : TRUE if put successful, FALSE otherwise
742 SIDE EFFECTS : None
743 NOTES : None
744 *********************************************************/
EnvDirectPutSlot(void * theEnv,void * ins,const char * sname,DATA_OBJECT * val)745 globle int EnvDirectPutSlot(
746 void *theEnv,
747 void *ins,
748 const char *sname,
749 DATA_OBJECT *val)
750 {
751 INSTANCE_SLOT *sp;
752 DATA_OBJECT junk;
753
754 if ((((INSTANCE_TYPE *) ins)->garbage == 1) || (val == NULL))
755 {
756 SetEvaluationError(theEnv,TRUE);
757 return(FALSE);
758 }
759 sp = FindISlotByName(theEnv,(INSTANCE_TYPE *) ins,sname);
760 if (sp == NULL)
761 {
762 SetEvaluationError(theEnv,TRUE);
763 return(FALSE);
764 }
765
766 if (PutSlotValue(theEnv,(INSTANCE_TYPE *) ins,sp,val,&junk,"external put"))
767 {
768 if ((UtilityData(theEnv)->CurrentGarbageFrame->topLevel) && (! CommandLineData(theEnv)->EvaluatingTopLevelCommand) &&
769 (EvaluationData(theEnv)->CurrentExpression == NULL) && (UtilityData(theEnv)->GarbageCollectionLocks == 0))
770 {
771 CleanCurrentGarbageFrame(theEnv,NULL);
772 CallPeriodicTasks(theEnv);
773 }
774 return(TRUE);
775 }
776 return(FALSE);
777 }
778
779 /***************************************************
780 NAME : GetInstanceName
781 DESCRIPTION : Returns name of instance
782 INPUTS : Pointer to instance
783 RETURNS : Name of instance
784 SIDE EFFECTS : None
785 NOTES : None
786 ***************************************************/
EnvGetInstanceName(void * theEnv,void * iptr)787 globle const char *EnvGetInstanceName(
788 void *theEnv,
789 void *iptr)
790 {
791 #if MAC_XCD
792 #pragma unused(theEnv)
793 #endif
794
795 if (((INSTANCE_TYPE *) iptr)->garbage == 1)
796 return(NULL);
797 return(ValueToString(((INSTANCE_TYPE *) iptr)->name));
798 }
799
800 /***************************************************
801 NAME : EnvGetInstanceClass
802 DESCRIPTION : Returns class of instance
803 INPUTS : Pointer to instance
804 RETURNS : Pointer to class of instance
805 SIDE EFFECTS : None
806 NOTES : None
807 ***************************************************/
EnvGetInstanceClass(void * theEnv,void * iptr)808 globle void *EnvGetInstanceClass(
809 void *theEnv,
810 void *iptr)
811 {
812 #if MAC_XCD
813 #pragma unused(theEnv)
814 #endif
815
816 if (((INSTANCE_TYPE *) iptr)->garbage == 1)
817 return(NULL);
818 return((void *) ((INSTANCE_TYPE *) iptr)->cls);
819 }
820
821 /***************************************************
822 NAME : GetGlobalNumberOfInstances
823 DESCRIPTION : Returns the total number of
824 instances in all modules
825 INPUTS : None
826 RETURNS : The instance count
827 SIDE EFFECTS : None
828 NOTES : None
829 ***************************************************/
GetGlobalNumberOfInstances(void * theEnv)830 globle unsigned long GetGlobalNumberOfInstances(
831 void *theEnv)
832 {
833 return(InstanceData(theEnv)->GlobalNumberOfInstances);
834 }
835
836 /***************************************************
837 NAME : EnvGetNextInstance
838 DESCRIPTION : Returns next instance in list
839 (or first instance in list)
840 INPUTS : Pointer to previous instance
841 (or NULL to get first instance)
842 RETURNS : The next instance or first instance
843 SIDE EFFECTS : None
844 NOTES : None
845 ***************************************************/
EnvGetNextInstance(void * theEnv,void * iptr)846 globle void *EnvGetNextInstance(
847 void *theEnv,
848 void *iptr)
849 {
850 if (iptr == NULL)
851 return((void *) InstanceData(theEnv)->InstanceList);
852 if (((INSTANCE_TYPE *) iptr)->garbage == 1)
853 return(NULL);
854 return((void *) ((INSTANCE_TYPE *) iptr)->nxtList);
855 }
856
857 /***************************************************
858 NAME : GetNextInstanceInScope
859 DESCRIPTION : Returns next instance in list
860 (or first instance in list)
861 which class is in scope
862 INPUTS : Pointer to previous instance
863 (or NULL to get first instance)
864 RETURNS : The next instance or first instance
865 which class is in scope of the
866 current module
867 SIDE EFFECTS : None
868 NOTES : None
869 ***************************************************/
GetNextInstanceInScope(void * theEnv,void * iptr)870 globle void *GetNextInstanceInScope(
871 void *theEnv,
872 void *iptr)
873 {
874 INSTANCE_TYPE *ins = (INSTANCE_TYPE *) iptr;
875
876 if (ins == NULL)
877 ins = InstanceData(theEnv)->InstanceList;
878 else if (ins->garbage)
879 return(NULL);
880 else
881 ins = ins->nxtList;
882 while (ins != NULL)
883 {
884 if (DefclassInScope(theEnv,ins->cls,NULL))
885 return((void *) ins);
886 ins = ins->nxtList;
887 }
888 return(NULL);
889 }
890
891 /***************************************************
892 NAME : EnvGetNextInstanceInClass
893 DESCRIPTION : Finds next instance of class
894 (or first instance of class)
895 INPUTS : 1) Class address
896 2) Instance address
897 (NULL to get first instance)
898 RETURNS : The next or first class instance
899 SIDE EFFECTS : None
900 NOTES : None
901 ***************************************************/
EnvGetNextInstanceInClass(void * theEnv,void * cptr,void * iptr)902 globle void *EnvGetNextInstanceInClass(
903 void *theEnv,
904 void *cptr,
905 void *iptr)
906 {
907 #if MAC_XCD
908 #pragma unused(theEnv)
909 #endif
910
911 if (iptr == NULL)
912 return((void *) ((DEFCLASS *) cptr)->instanceList);
913 if (((INSTANCE_TYPE *) iptr)->garbage == 1)
914 return(NULL);
915 return((void *) ((INSTANCE_TYPE *) iptr)->nxtClass);
916 }
917
918 /***************************************************
919 NAME : EnvGetNextInstanceInClassAndSubclasses
920 DESCRIPTION : Finds next instance of class
921 (or first instance of class) and
922 all of its subclasses
923 INPUTS : 1) Class address
924 2) Instance address
925 (NULL to get first instance)
926 RETURNS : The next or first class instance
927 SIDE EFFECTS : None
928 NOTES : None
929 ***************************************************/
EnvGetNextInstanceInClassAndSubclasses(void * theEnv,void ** cptr,void * iptr,DATA_OBJECT * iterationInfo)930 globle void *EnvGetNextInstanceInClassAndSubclasses(
931 void *theEnv,
932 void **cptr,
933 void *iptr,
934 DATA_OBJECT *iterationInfo)
935 {
936 INSTANCE_TYPE *nextInstance;
937 DEFCLASS *theClass;
938
939 theClass = (DEFCLASS *) *cptr;
940
941 if (iptr == NULL)
942 {
943 ClassSubclassAddresses(theEnv,theClass,iterationInfo,TRUE);
944 nextInstance = theClass->instanceList;
945 }
946 else if (((INSTANCE_TYPE *) iptr)->garbage == 1)
947 { nextInstance = NULL; }
948 else
949 { nextInstance = ((INSTANCE_TYPE *) iptr)->nxtClass; }
950
951 while ((nextInstance == NULL) &&
952 (GetpDOBegin(iterationInfo) <= GetpDOEnd(iterationInfo)))
953 {
954 theClass = (struct defclass *) GetMFValue(DOPToPointer(iterationInfo),
955 GetpDOBegin(iterationInfo));
956 *cptr = theClass;
957 SetpDOBegin(iterationInfo,GetpDOBegin(iterationInfo) + 1);
958 nextInstance = theClass->instanceList;
959 }
960
961 return(nextInstance);
962 }
963
964 /***************************************************
965 NAME : EnvGetInstancePPForm
966 DESCRIPTION : Writes slot names and values to
967 caller's buffer
968 INPUTS : 1) Caller's buffer
969 2) Size of buffer (not including
970 space for terminating '\0')
971 3) Instance address
972 RETURNS : Nothing useful
973 SIDE EFFECTS : Caller's buffer written
974 NOTES : None
975 ***************************************************/
EnvGetInstancePPForm(void * theEnv,char * buf,size_t buflen,void * iptr)976 globle void EnvGetInstancePPForm(
977 void *theEnv,
978 char *buf,
979 size_t buflen,
980 void *iptr)
981 {
982 const char *pbuf = "***InstancePPForm***";
983
984 if (((INSTANCE_TYPE *) iptr)->garbage == 1)
985 return;
986 if (OpenStringDestination(theEnv,pbuf,buf,buflen+1) == 0)
987 return;
988 PrintInstance(theEnv,pbuf,(INSTANCE_TYPE *) iptr," ");
989 CloseStringDestination(theEnv,pbuf);
990 }
991
992 /*********************************************************
993 NAME : ClassCommand
994 DESCRIPTION : Returns the class of an instance
995 INPUTS : Caller's result buffer
996 RETURNS : Nothing useful
997 SIDE EFFECTS : None
998 NOTES : H/L Syntax : (class <object>)
999 Can also be called by (type <object>)
1000 if you have generic functions installed
1001 *********************************************************/
ClassCommand(void * theEnv,DATA_OBJECT * result)1002 globle void ClassCommand(
1003 void *theEnv,
1004 DATA_OBJECT *result)
1005 {
1006 INSTANCE_TYPE *ins;
1007 const char *func;
1008 DATA_OBJECT temp;
1009
1010 func = ValueToString(((struct FunctionDefinition *)
1011 EvaluationData(theEnv)->CurrentExpression->value)->callFunctionName);
1012 result->type = SYMBOL;
1013 result->value = EnvFalseSymbol(theEnv);
1014 EvaluateExpression(theEnv,GetFirstArgument(),&temp);
1015 if (temp.type == INSTANCE_ADDRESS)
1016 {
1017 ins = (INSTANCE_TYPE *) temp.value;
1018 if (ins->garbage == 1)
1019 {
1020 StaleInstanceAddress(theEnv,func,0);
1021 SetEvaluationError(theEnv,TRUE);
1022 return;
1023 }
1024 result->value = (void *) GetDefclassNamePointer((void *) ins->cls);
1025 }
1026 else if (temp.type == INSTANCE_NAME)
1027 {
1028 ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) temp.value);
1029 if (ins == NULL)
1030 {
1031 NoInstanceError(theEnv,ValueToString(temp.value),func);
1032 return;
1033 }
1034 result->value = (void *) GetDefclassNamePointer((void *) ins->cls);
1035 }
1036 else
1037 {
1038 switch (temp.type)
1039 {
1040 case INTEGER :
1041 case FLOAT :
1042 case SYMBOL :
1043 case STRING :
1044 case MULTIFIELD :
1045 case EXTERNAL_ADDRESS :
1046 case FACT_ADDRESS :
1047 result->value = (void *)
1048 GetDefclassNamePointer((void *)
1049 DefclassData(theEnv)->PrimitiveClassMap[temp.type]);
1050 return;
1051
1052 default : PrintErrorID(theEnv,"INSCOM",1,FALSE);
1053 EnvPrintRouter(theEnv,WERROR,"Undefined type in function ");
1054 EnvPrintRouter(theEnv,WERROR,func);
1055 EnvPrintRouter(theEnv,WERROR,".\n");
1056 SetEvaluationError(theEnv,TRUE);
1057 }
1058 }
1059 }
1060
1061 /******************************************************
1062 NAME : CreateInstanceHandler
1063 DESCRIPTION : Message handler called after instance creation
1064 INPUTS : None
1065 RETURNS : TRUE if successful,
1066 FALSE otherwise
1067 SIDE EFFECTS : None
1068 NOTES : Does nothing. Provided so it can be overridden.
1069 ******************************************************/
CreateInstanceHandler(void * theEnv)1070 globle intBool CreateInstanceHandler(
1071 void *theEnv)
1072 {
1073 #if MAC_XCD
1074 #pragma unused(theEnv)
1075 #endif
1076
1077 return(TRUE);
1078 }
1079
1080 /******************************************************
1081 NAME : DeleteInstanceCommand
1082 DESCRIPTION : Removes a named instance from the
1083 hash table and its class's
1084 instance list
1085 INPUTS : None
1086 RETURNS : TRUE if successful,
1087 FALSE otherwise
1088 SIDE EFFECTS : Instance is deallocated
1089 NOTES : This is an internal function that
1090 only be called by a handler
1091 ******************************************************/
DeleteInstanceCommand(void * theEnv)1092 globle intBool DeleteInstanceCommand(
1093 void *theEnv)
1094 {
1095 if (CheckCurrentMessage(theEnv,"delete-instance",TRUE))
1096 return(QuashInstance(theEnv,GetActiveInstance(theEnv)));
1097 return(FALSE);
1098 }
1099
1100 /********************************************************************
1101 NAME : UnmakeInstanceCommand
1102 DESCRIPTION : Uses message-passing to delete the
1103 specified instance
1104 INPUTS : None
1105 RETURNS : TRUE if successful, FALSE otherwise
1106 SIDE EFFECTS : Instance is deallocated
1107 NOTES : Syntax: (unmake-instance <instance-expression>+ | *)
1108 ********************************************************************/
UnmakeInstanceCommand(void * theEnv)1109 globle intBool UnmakeInstanceCommand(
1110 void *theEnv)
1111 {
1112 EXPRESSION *theArgument;
1113 DATA_OBJECT theResult;
1114 INSTANCE_TYPE *ins;
1115 int argNumber = 1,rtn = TRUE;
1116
1117 theArgument = GetFirstArgument();
1118 while (theArgument != NULL)
1119 {
1120 EvaluateExpression(theEnv,theArgument,&theResult);
1121 if ((theResult.type == INSTANCE_NAME) || (theResult.type == SYMBOL))
1122 {
1123 ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) theResult.value);
1124 if ((ins == NULL) ? (strcmp(DOToString(theResult),"*") != 0) : FALSE)
1125 {
1126 NoInstanceError(theEnv,DOToString(theResult),"unmake-instance");
1127 return(FALSE);
1128 }
1129 }
1130 else if (theResult.type == INSTANCE_ADDRESS)
1131 {
1132 ins = (INSTANCE_TYPE *) theResult.value;
1133 if (ins->garbage)
1134 {
1135 StaleInstanceAddress(theEnv,"unmake-instance",0);
1136 SetEvaluationError(theEnv,TRUE);
1137 return(FALSE);
1138 }
1139 }
1140 else
1141 {
1142 ExpectedTypeError1(theEnv,"unmake-instance",argNumber,"instance-address, instance-name, or the symbol *");
1143 SetEvaluationError(theEnv,TRUE);
1144 return(FALSE);
1145 }
1146 if (EnvUnmakeInstance(theEnv,ins) == FALSE)
1147 rtn = FALSE;
1148 if (ins == NULL)
1149 return(rtn);
1150 argNumber++;
1151 theArgument = GetNextArgument(theArgument);
1152 }
1153 return(rtn);
1154 }
1155
1156 /*****************************************************************
1157 NAME : SymbolToInstanceName
1158 DESCRIPTION : Converts a symbol from type SYMBOL
1159 to type INSTANCE_NAME
1160 INPUTS : The address of the value buffer
1161 RETURNS : The new INSTANCE_NAME symbol
1162 SIDE EFFECTS : None
1163 NOTES : H/L Syntax : (symbol-to-instance-name <symbol>)
1164 *****************************************************************/
SymbolToInstanceName(void * theEnv,DATA_OBJECT * result)1165 globle void SymbolToInstanceName(
1166 void *theEnv,
1167 DATA_OBJECT *result)
1168 {
1169 if (EnvArgTypeCheck(theEnv,"symbol-to-instance-name",1,SYMBOL,result) == FALSE)
1170 {
1171 SetpType(result,SYMBOL);
1172 SetpValue(result,EnvFalseSymbol(theEnv));
1173 return;
1174 }
1175 SetpType(result,INSTANCE_NAME);
1176 }
1177
1178 /*****************************************************************
1179 NAME : InstanceNameToSymbol
1180 DESCRIPTION : Converts a symbol from type INSTANCE_NAME
1181 to type SYMBOL
1182 INPUTS : None
1183 RETURNS : Symbol FALSE on errors - or converted instance name
1184 SIDE EFFECTS : None
1185 NOTES : H/L Syntax : (instance-name-to-symbol <iname>)
1186 *****************************************************************/
InstanceNameToSymbol(void * theEnv)1187 globle void *InstanceNameToSymbol(
1188 void *theEnv)
1189 {
1190 DATA_OBJECT result;
1191
1192 if (EnvArgTypeCheck(theEnv,"instance-name-to-symbol",1,INSTANCE_NAME,&result) == FALSE)
1193 return((SYMBOL_HN *) EnvFalseSymbol(theEnv));
1194 return((SYMBOL_HN *) result.value);
1195 }
1196
1197 /*********************************************************************************
1198 NAME : InstanceAddressCommand
1199 DESCRIPTION : Returns the address of an instance
1200 INPUTS : The address of the value buffer
1201 RETURNS : Nothing useful
1202 SIDE EFFECTS : Stores instance address in caller's buffer
1203 NOTES : H/L Syntax : (instance-address [<module-name>] <instance-name>)
1204 *********************************************************************************/
InstanceAddressCommand(void * theEnv,DATA_OBJECT * result)1205 globle void InstanceAddressCommand(
1206 void *theEnv,
1207 DATA_OBJECT *result)
1208 {
1209 INSTANCE_TYPE *ins;
1210 DATA_OBJECT temp;
1211 struct defmodule *theModule;
1212 unsigned searchImports;
1213
1214 result->type = SYMBOL;
1215 result->value = EnvFalseSymbol(theEnv);
1216 if (EnvRtnArgCount(theEnv) > 1)
1217 {
1218 if (EnvArgTypeCheck(theEnv,"instance-address",1,SYMBOL,&temp) == FALSE)
1219 return;
1220 theModule = (struct defmodule *) EnvFindDefmodule(theEnv,DOToString(temp));
1221 if ((theModule == NULL) ? (strcmp(DOToString(temp),"*") != 0) : FALSE)
1222 {
1223 ExpectedTypeError1(theEnv,"instance-address",1,"module name");
1224 SetEvaluationError(theEnv,TRUE);
1225 return;
1226 }
1227 if (theModule == NULL)
1228 {
1229 searchImports = TRUE;
1230 theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv));
1231 }
1232 else
1233 searchImports = FALSE;
1234 if (EnvArgTypeCheck(theEnv,"instance-address",2,INSTANCE_NAME,&temp)
1235 == FALSE)
1236 return;
1237 ins = FindInstanceInModule(theEnv,(SYMBOL_HN *) temp.value,theModule,
1238 ((struct defmodule *) EnvGetCurrentModule(theEnv)),searchImports);
1239 if (ins != NULL)
1240 {
1241 result->type = INSTANCE_ADDRESS;
1242 result->value = (void *) ins;
1243 }
1244 else
1245 NoInstanceError(theEnv,ValueToString(temp.value),"instance-address");
1246 }
1247 else if (EnvArgTypeCheck(theEnv,"instance-address",1,INSTANCE_OR_INSTANCE_NAME,&temp))
1248 {
1249 if (temp.type == INSTANCE_ADDRESS)
1250 {
1251 ins = (INSTANCE_TYPE *) temp.value;
1252 if (ins->garbage == 0)
1253 {
1254 result->type = INSTANCE_ADDRESS;
1255 result->value = temp.value;
1256 }
1257 else
1258 {
1259 StaleInstanceAddress(theEnv,"instance-address",0);
1260 SetEvaluationError(theEnv,TRUE);
1261 }
1262 }
1263 else
1264 {
1265 ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) temp.value);
1266 if (ins != NULL)
1267 {
1268 result->type = INSTANCE_ADDRESS;
1269 result->value = (void *) ins;
1270 }
1271 else
1272 NoInstanceError(theEnv,ValueToString(temp.value),"instance-address");
1273 }
1274 }
1275 }
1276
1277 /***************************************************************
1278 NAME : InstanceNameCommand
1279 DESCRIPTION : Gets the name of an INSTANCE
1280 INPUTS : The address of the value buffer
1281 RETURNS : The INSTANCE_NAME symbol
1282 SIDE EFFECTS : None
1283 NOTES : H/L Syntax : (instance-name <instance>)
1284 ***************************************************************/
InstanceNameCommand(void * theEnv,DATA_OBJECT * result)1285 globle void InstanceNameCommand(
1286 void *theEnv,
1287 DATA_OBJECT *result)
1288 {
1289 INSTANCE_TYPE *ins;
1290 DATA_OBJECT temp;
1291
1292 result->type = SYMBOL;
1293 result->value = EnvFalseSymbol(theEnv);
1294 if (EnvArgTypeCheck(theEnv,"instance-name",1,INSTANCE_OR_INSTANCE_NAME,&temp) == FALSE)
1295 return;
1296 if (temp.type == INSTANCE_ADDRESS)
1297 {
1298 ins = (INSTANCE_TYPE *) temp.value;
1299 if (ins->garbage == 1)
1300 {
1301 StaleInstanceAddress(theEnv,"instance-name",0);
1302 SetEvaluationError(theEnv,TRUE);
1303 return;
1304 }
1305 }
1306 else
1307 {
1308 ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) temp.value);
1309 if (ins == NULL)
1310 {
1311 NoInstanceError(theEnv,ValueToString(temp.value),"instance-name");
1312 return;
1313 }
1314 }
1315 result->type = INSTANCE_NAME;
1316 result->value = (void *) ins->name;
1317 }
1318
1319 /**************************************************************
1320 NAME : InstanceAddressPCommand
1321 DESCRIPTION : Determines if a value is of type INSTANCE
1322 INPUTS : None
1323 RETURNS : TRUE if type INSTANCE_ADDRESS, FALSE otherwise
1324 SIDE EFFECTS : None
1325 NOTES : H/L Syntax : (instance-addressp <arg>)
1326 **************************************************************/
InstanceAddressPCommand(void * theEnv)1327 globle intBool InstanceAddressPCommand(
1328 void *theEnv)
1329 {
1330 DATA_OBJECT temp;
1331
1332 EvaluateExpression(theEnv,GetFirstArgument(),&temp);
1333 return((GetType(temp) == INSTANCE_ADDRESS) ? TRUE : FALSE);
1334 }
1335
1336 /**************************************************************
1337 NAME : InstanceNamePCommand
1338 DESCRIPTION : Determines if a value is of type INSTANCE_NAME
1339 INPUTS : None
1340 RETURNS : TRUE if type INSTANCE_NAME, FALSE otherwise
1341 SIDE EFFECTS : None
1342 NOTES : H/L Syntax : (instance-namep <arg>)
1343 **************************************************************/
InstanceNamePCommand(void * theEnv)1344 globle intBool InstanceNamePCommand(
1345 void *theEnv)
1346 {
1347 DATA_OBJECT temp;
1348
1349 EvaluateExpression(theEnv,GetFirstArgument(),&temp);
1350 return((GetType(temp) == INSTANCE_NAME) ? TRUE : FALSE);
1351 }
1352
1353 /*****************************************************************
1354 NAME : InstancePCommand
1355 DESCRIPTION : Determines if a value is of type INSTANCE_ADDRESS
1356 or INSTANCE_NAME
1357 INPUTS : None
1358 RETURNS : TRUE if type INSTANCE_NAME or INSTANCE_ADDRESS,
1359 FALSE otherwise
1360 SIDE EFFECTS : None
1361 NOTES : H/L Syntax : (instancep <arg>)
1362 *****************************************************************/
InstancePCommand(void * theEnv)1363 globle intBool InstancePCommand(
1364 void *theEnv)
1365 {
1366 DATA_OBJECT temp;
1367
1368 EvaluateExpression(theEnv,GetFirstArgument(),&temp);
1369 if ((GetType(temp) == INSTANCE_NAME) || (GetType(temp) == INSTANCE_ADDRESS))
1370 return(TRUE);
1371 return(FALSE);
1372 }
1373
1374 /********************************************************
1375 NAME : InstanceExistPCommand
1376 DESCRIPTION : Determines if an instance exists
1377 INPUTS : None
1378 RETURNS : TRUE if instance exists, FALSE otherwise
1379 SIDE EFFECTS : None
1380 NOTES : H/L Syntax : (instance-existp <arg>)
1381 ********************************************************/
InstanceExistPCommand(void * theEnv)1382 globle intBool InstanceExistPCommand(
1383 void *theEnv)
1384 {
1385 DATA_OBJECT temp;
1386
1387 EvaluateExpression(theEnv,GetFirstArgument(),&temp);
1388 if (temp.type == INSTANCE_ADDRESS)
1389 return((((INSTANCE_TYPE *) temp.value)->garbage == 0) ? TRUE : FALSE);
1390 if ((temp.type == INSTANCE_NAME) || (temp.type == SYMBOL))
1391 return((FindInstanceBySymbol(theEnv,(SYMBOL_HN *) temp.value) != NULL) ?
1392 TRUE : FALSE);
1393 ExpectedTypeError1(theEnv,"instance-existp",1,"instance name, instance address or symbol");
1394 SetEvaluationError(theEnv,TRUE);
1395 return(FALSE);
1396 }
1397
1398 /* =========================================
1399 *****************************************
1400 INTERNALLY VISIBLE FUNCTIONS
1401 =========================================
1402 ***************************************** */
1403
1404 #if DEBUGGING_FUNCTIONS
1405
1406 /***************************************************
1407 NAME : ListInstancesInModule
1408 DESCRIPTION : List instances of specified
1409 class(es) in a module
1410 INPUTS : 1) Traversal id to avoid multiple
1411 passes over same class
1412 2) Logical name of output
1413 3) The name of the class
1414 (NULL for all classes)
1415 4) Flag indicating whether to
1416 include instances of subclasses
1417 5) A flag indicating whether to
1418 indent because of module name
1419 RETURNS : The number of instances listed
1420 SIDE EFFECTS : Instances listed to logical output
1421 NOTES : Assumes defclass scope flags
1422 are up to date
1423 ***************************************************/
ListInstancesInModule(void * theEnv,int id,const char * logicalName,const char * className,intBool inheritFlag,intBool allModulesFlag)1424 static long ListInstancesInModule(
1425 void *theEnv,
1426 int id,
1427 const char *logicalName,
1428 const char *className,
1429 intBool inheritFlag,
1430 intBool allModulesFlag)
1431 {
1432 void *theDefclass,*theInstance;
1433 long count = 0L;
1434
1435 /* ===================================
1436 For the specified module, print out
1437 instances of all the classes
1438 =================================== */
1439 if (className == NULL)
1440 {
1441 /* ==============================================
1442 If instances are being listed for all modules,
1443 only list the instances of classes in this
1444 module (to avoid listing instances twice)
1445 ============================================== */
1446 if (allModulesFlag)
1447 {
1448 for (theDefclass = EnvGetNextDefclass(theEnv,NULL) ;
1449 theDefclass != NULL ;
1450 theDefclass = EnvGetNextDefclass(theEnv,theDefclass))
1451 count += TabulateInstances(theEnv,id,logicalName,
1452 (DEFCLASS *) theDefclass,FALSE,allModulesFlag);
1453 }
1454
1455 /* ===================================================
1456 If instances are only be listed for one module,
1457 list all instances visible to the module (including
1458 ones belonging to classes in other modules)
1459 =================================================== */
1460 else
1461 {
1462 theInstance = GetNextInstanceInScope(theEnv,NULL);
1463 while (theInstance != NULL)
1464 {
1465 if (GetHaltExecution(theEnv) == TRUE)
1466 { return(count); }
1467
1468 count++;
1469 PrintInstanceNameAndClass(theEnv,logicalName,(INSTANCE_TYPE *) theInstance,TRUE);
1470 theInstance = GetNextInstanceInScope(theEnv,theInstance);
1471 }
1472 }
1473 }
1474
1475 /* ===================================
1476 For the specified module, print out
1477 instances of the specified class
1478 =================================== */
1479 else
1480 {
1481 theDefclass = (void *) LookupDefclassAnywhere(theEnv,((struct defmodule *) EnvGetCurrentModule(theEnv)),className);
1482 if (theDefclass != NULL)
1483 {
1484 count += TabulateInstances(theEnv,id,logicalName,
1485 (DEFCLASS *) theDefclass,inheritFlag,allModulesFlag);
1486 }
1487 else if (! allModulesFlag)
1488 ClassExistError(theEnv,"instances",className);
1489 }
1490 return(count);
1491 }
1492
1493 /******************************************************
1494 NAME : TabulateInstances
1495 DESCRIPTION : Displays all instances for a class
1496 INPUTS : 1) The traversal id for the classes
1497 2) The logical name of the output
1498 3) The class address
1499 4) A flag indicating whether to
1500 print out instances of subclasses
1501 or not.
1502 5) A flag indicating whether to
1503 indent because of module name
1504 RETURNS : The number of instances (including
1505 subclasses' instances)
1506 SIDE EFFECTS : None
1507 NOTES : None
1508 ******************************************************/
TabulateInstances(void * theEnv,int id,const char * logicalName,DEFCLASS * cls,intBool inheritFlag,intBool allModulesFlag)1509 static long TabulateInstances(
1510 void *theEnv,
1511 int id,
1512 const char *logicalName,
1513 DEFCLASS *cls,
1514 intBool inheritFlag,
1515 intBool allModulesFlag)
1516 {
1517 INSTANCE_TYPE *ins;
1518 long i;
1519 long count = 0;
1520
1521 if (TestTraversalID(cls->traversalRecord,id))
1522 return(0L);
1523 SetTraversalID(cls->traversalRecord,id);
1524 for (ins = cls->instanceList ; ins != NULL ; ins = ins->nxtClass)
1525 {
1526 if (EvaluationData(theEnv)->HaltExecution)
1527 return(count);
1528 if (allModulesFlag)
1529 EnvPrintRouter(theEnv,logicalName," ");
1530 PrintInstanceNameAndClass(theEnv,logicalName,ins,TRUE);
1531 count++;
1532 }
1533 if (inheritFlag)
1534 {
1535 for (i = 0 ; i < cls->directSubclasses.classCount ; i++)
1536 {
1537 if (EvaluationData(theEnv)->HaltExecution)
1538 return(count);
1539 count += TabulateInstances(theEnv,id,logicalName,
1540 cls->directSubclasses.classArray[i],inheritFlag,allModulesFlag);
1541 }
1542 }
1543 return(count);
1544 }
1545
1546 #endif
1547
1548 /***************************************************
1549 NAME : PrintInstance
1550 DESCRIPTION : Displays an instance's slots
1551 INPUTS : 1) Logical name for output
1552 2) Instance address
1553 3) String used to separate
1554 slot printouts
1555 RETURNS : Nothing useful
1556 SIDE EFFECTS : None
1557 NOTES : Assumes instance is valid
1558 ***************************************************/
PrintInstance(void * theEnv,const char * logicalName,INSTANCE_TYPE * ins,const char * separator)1559 static void PrintInstance(
1560 void *theEnv,
1561 const char *logicalName,
1562 INSTANCE_TYPE *ins,
1563 const char *separator)
1564 {
1565 long i;
1566 register INSTANCE_SLOT *sp;
1567
1568 PrintInstanceNameAndClass(theEnv,logicalName,ins,FALSE);
1569 for (i = 0 ; i < ins->cls->instanceSlotCount ; i++)
1570 {
1571 EnvPrintRouter(theEnv,logicalName,separator);
1572 sp = ins->slotAddresses[i];
1573 EnvPrintRouter(theEnv,logicalName,"(");
1574 EnvPrintRouter(theEnv,logicalName,ValueToString(sp->desc->slotName->name));
1575 if (sp->type != MULTIFIELD)
1576 {
1577 EnvPrintRouter(theEnv,logicalName," ");
1578 PrintAtom(theEnv,logicalName,(int) sp->type,sp->value);
1579 }
1580 else if (GetInstanceSlotLength(sp) != 0)
1581 {
1582 EnvPrintRouter(theEnv,logicalName," ");
1583 PrintMultifield(theEnv,logicalName,(MULTIFIELD_PTR) sp->value,0,
1584 (long) (GetInstanceSlotLength(sp) - 1),FALSE);
1585 }
1586 EnvPrintRouter(theEnv,logicalName,")");
1587 }
1588 }
1589
1590 /***************************************************
1591 NAME : FindISlotByName
1592 DESCRIPTION : Looks up an instance slot by
1593 instance name and slot name
1594 INPUTS : 1) Instance address
1595 2) Instance name-string
1596 RETURNS : The instance slot address, NULL if
1597 does not exist
1598 SIDE EFFECTS : None
1599 NOTES : None
1600 ***************************************************/
FindISlotByName(void * theEnv,INSTANCE_TYPE * ins,const char * sname)1601 static INSTANCE_SLOT *FindISlotByName(
1602 void *theEnv,
1603 INSTANCE_TYPE *ins,
1604 const char *sname)
1605 {
1606 SYMBOL_HN *ssym;
1607
1608 ssym = FindSymbolHN(theEnv,sname);
1609 if (ssym == NULL)
1610 return(NULL);
1611 return(FindInstanceSlot(theEnv,ins,ssym));
1612 }
1613
1614 /*#####################################*/
1615 /* ALLOW_ENVIRONMENT_GLOBALS Functions */
1616 /*#####################################*/
1617
1618 #if ALLOW_ENVIRONMENT_GLOBALS
1619
GetInstanceName(void * iptr)1620 globle const char *GetInstanceName(
1621 void *iptr)
1622 {
1623 return EnvGetInstanceName(GetCurrentEnvironment(),iptr);
1624 }
1625
CreateRawInstance(void * cptr,const char * iname)1626 globle void *CreateRawInstance(
1627 void *cptr,
1628 const char *iname)
1629 {
1630 return EnvCreateRawInstance(GetCurrentEnvironment(),cptr,iname);
1631 }
1632
DeleteInstance(void * iptr)1633 globle intBool DeleteInstance(
1634 void *iptr)
1635 {
1636 return EnvDeleteInstance(GetCurrentEnvironment(),iptr);
1637 }
1638
DirectGetSlot(void * ins,const char * sname,DATA_OBJECT * result)1639 globle void DirectGetSlot(
1640 void *ins,
1641 const char *sname,
1642 DATA_OBJECT *result)
1643 {
1644 EnvDirectGetSlot(GetCurrentEnvironment(),ins,sname,result);
1645 }
1646
DirectPutSlot(void * ins,const char * sname,DATA_OBJECT * val)1647 globle int DirectPutSlot(
1648 void *ins,
1649 const char *sname,
1650 DATA_OBJECT *val)
1651 {
1652 return EnvDirectPutSlot(GetCurrentEnvironment(),ins,sname,val);
1653 }
1654
FindInstance(void * theModule,const char * iname,unsigned searchImports)1655 globle void *FindInstance(
1656 void *theModule,
1657 const char *iname,
1658 unsigned searchImports)
1659 {
1660 return EnvFindInstance(GetCurrentEnvironment(),theModule,iname,searchImports);
1661 }
1662
GetInstanceClass(void * iptr)1663 globle void *GetInstanceClass(
1664 void *iptr)
1665 {
1666 return EnvGetInstanceClass(GetCurrentEnvironment(),iptr);
1667 }
1668
GetInstancePPForm(char * buf,unsigned buflen,void * iptr)1669 globle void GetInstancePPForm(
1670 char *buf,
1671 unsigned buflen,
1672 void *iptr)
1673 {
1674 EnvGetInstancePPForm(GetCurrentEnvironment(),buf,buflen,iptr);
1675 }
1676
GetNextInstance(void * iptr)1677 globle void *GetNextInstance(
1678 void *iptr)
1679 {
1680 return EnvGetNextInstance(GetCurrentEnvironment(),iptr);
1681 }
1682
GetNextInstanceInClass(void * cptr,void * iptr)1683 globle void *GetNextInstanceInClass(
1684 void *cptr,
1685 void *iptr)
1686 {
1687 return EnvGetNextInstanceInClass(GetCurrentEnvironment(),cptr,iptr);
1688 }
1689
GetNextInstanceInClassAndSubclasses(void ** cptr,void * iptr,DATA_OBJECT * iterationInfo)1690 globle void *GetNextInstanceInClassAndSubclasses(
1691 void **cptr,
1692 void *iptr,
1693 DATA_OBJECT *iterationInfo)
1694 {
1695 return EnvGetNextInstanceInClassAndSubclasses(GetCurrentEnvironment(),cptr,iptr,iterationInfo);
1696 }
1697
1698 #if DEBUGGING_FUNCTIONS
Instances(const char * logicalName,void * theVModule,const char * className,int inheritFlag)1699 globle void Instances(
1700 const char *logicalName,
1701 void *theVModule,
1702 const char *className,
1703 int inheritFlag)
1704 {
1705 EnvInstances(GetCurrentEnvironment(),logicalName,theVModule,className,inheritFlag);
1706 }
1707 #endif
1708
MakeInstance(const char * mkstr)1709 globle void *MakeInstance(
1710 const char *mkstr)
1711 {
1712 return EnvMakeInstance(GetCurrentEnvironment(),mkstr);
1713 }
1714
UnmakeInstance(void * iptr)1715 globle intBool UnmakeInstance(
1716 void *iptr)
1717 {
1718 return EnvUnmakeInstance(GetCurrentEnvironment(),iptr);
1719 }
1720
ValidInstanceAddress(void * iptr)1721 globle int ValidInstanceAddress(
1722 void *iptr)
1723 {
1724 return EnvValidInstanceAddress(GetCurrentEnvironment(),iptr);
1725 }
1726
1727 #endif /* ALLOW_ENVIRONMENT_GLOBALS */
1728
1729 #endif /* OBJECT_SYSTEM */
1730
1731