1 /****************************************************************************
2 **
3 ** This file is part of GAP, a system for computational discrete algebra.
4 **
5 ** Copyright of GAP belongs to its developers, whose names are too numerous
6 ** to list here. Please refer to the COPYRIGHT file for details.
7 **
8 ** SPDX-License-Identifier: GPL-2.0-or-later
9 **
10 ** This file contains the functions of the filters, operations, attributes,
11 ** and properties package.
12 */
13
14 #include "opers.h"
15
16 #include "ariths.h"
17 #include "bits_intern.h"
18 #include "blister.h"
19 #include "bool.h"
20 #include "calls.h"
21 #include "error.h"
22 #include "gapstate.h"
23 #ifdef USE_GASMAN
24 #include "gasman_intern.h"
25 #endif
26 #include "gvars.h"
27 #include "io.h"
28 #include "lists.h"
29 #include "modules.h"
30 #include "plist.h"
31 #include "precord.h"
32 #include "range.h"
33 #include "records.h"
34 #include "saveload.h"
35 #include "stringobj.h"
36 #include "sysfiles.h"
37
38 #ifdef HPCGAP
39 #include "hpc/aobjects.h"
40 #include "hpc/guards.h"
41 #include "hpc/thread.h"
42 #include <pthread.h>
43 #endif
44
45 /****************************************************************************
46 **
47 *V TRY_NEXT_METHOD . . . . . . . . . . . . . . . . . 'TRY_NEXT_METHOD' flag
48 */
49 Obj TRY_NEXT_METHOD;
50
51
52 #define CACHE_SIZE 5
53
54
55 static Obj StringFilterSetter;
56 static Obj ArglistObjVal;
57 static Obj ArglistObj;
58
59
60 static Obj SetterAndFilter(Obj getter);
61 static Obj TesterAndFilter(Obj getter);
62
63
64 /****************************************************************************
65 **
66 *F * * * * * * * * * * * * internal flags functions * * * * * * * * * * * * *
67 */
68
69 #define RequireFlags(funcname, op) \
70 RequireArgumentCondition(funcname, op, TNUM_OBJ(op) == T_FLAGS, \
71 "must be a flags list")
72
73 #define RequireFilter(funcname, op, argname) \
74 RequireArgumentConditionEx(funcname, op, argname, \
75 IS_FILTER(op), "must be a filter")
76
77 #define RequireOperation(op) \
78 RequireArgumentCondition(CSTR_STRING(NAME_FUNC(self)), op, \
79 IS_OPERATION(op), "must be an operation")
80
81
82 /****************************************************************************
83 **
84 *F PrintFlags( <flags> ) . . . . . . . . . . . . . . . . print a flags list
85 */
PrintFlags(Obj flags)86 static void PrintFlags(Obj flags)
87 {
88 Pr( "<flag list>", 0L, 0L );
89 }
90
91
92 /****************************************************************************
93 **
94 *F TypeFlags( <flags> ) . . . . . . . . . . . . . . . type of a flags list
95 */
96 static Obj TYPE_FLAGS;
97
TypeFlags(Obj flags)98 static Obj TypeFlags(Obj flags)
99 {
100 return TYPE_FLAGS;
101 }
102
103
104 /****************************************************************************
105 **
106 *F SaveFlags( <flags> ) . . . . . . . . . . . . . . . . . save a flags list
107 **
108 */
SaveFlags(Obj flags)109 static void SaveFlags(Obj flags)
110 {
111 UInt i, len, *ptr;
112
113 SaveSubObj(TRUES_FLAGS(flags));
114 SaveSubObj(HASH_FLAGS(flags));
115 SaveSubObj(AND_CACHE_FLAGS(flags));
116
117 len = NRB_FLAGS(flags);
118 ptr = BLOCKS_FLAGS(flags);
119 for ( i = 1; i <= len; i++ )
120 SaveUInt(*ptr++);
121 }
122
123
124 /****************************************************************************
125 **
126 *F LoadFlags( <flags> ) . . . . . . . . . . . . . . . . . load a flags list
127 **
128 */
LoadFlags(Obj flags)129 static void LoadFlags(Obj flags)
130 {
131 Obj sub;
132 UInt i, len, *ptr;
133
134 sub = LoadSubObj(); SET_TRUES_FLAGS( flags, sub );
135 sub = LoadSubObj(); SET_HASH_FLAGS( flags, sub );
136 sub = LoadSubObj(); SET_AND_CACHE_FLAGS( flags, sub );
137
138 len = NRB_FLAGS(flags);
139 ptr = BLOCKS_FLAGS(flags);
140 for ( i = 1; i <= len; i++ )
141 *ptr++ = LoadUInt();
142 }
143
144
145 /****************************************************************************
146 **
147 *F * * * * * * * * * * * * * GAP flags functions * * * * * * * * * * * * * *
148 */
149
150
151 /****************************************************************************
152 **
153 *F FuncHASH_FLAGS( <self>, <flags> ) . . . . . . hash value of a flags list
154 **
155 ** The hash value is independent of the size of a machine word (32 or 64).
156 **
157 ** The rather peculiar cast in the definition of HASH_FLAGS_SIZE is needed
158 ** to get the calculation to work right on the alpha.
159 **
160 *T The 64 bit version depends on the byte order -- it assumes that
161 ** the lower addressed half-word is the less significant
162 **
163 */
164 #define HASH_FLAGS_SIZE (Int4)67108879L
165
FuncHASH_FLAGS(Obj self,Obj flags)166 static Obj FuncHASH_FLAGS(Obj self, Obj flags)
167 {
168 Int4 hash;
169 Int4 x;
170 Int len;
171 UInt4 * ptr;
172 Int i;
173
174 /* do some trivial checks */
175 RequireFlags("HASH_FLAGS", flags);
176 if ( HASH_FLAGS(flags) != 0 ) {
177 return HASH_FLAGS(flags);
178 }
179
180 /* do the real work*/
181 #if !defined(SYS_IS_64_BIT) || !defined(WORDS_BIGENDIAN)
182
183 // 32 bit case -- this is the "defining" case, others are adjusted to
184 // comply with this. For 64 bit systems in little endian mode, this
185 // amounts to the same code, only the value of NRB_FLAGS has to be
186 // adjusted
187 len = NRB_FLAGS(flags) * (sizeof(UInt) / sizeof(UInt4));
188 ptr = (UInt4 *)BLOCKS_FLAGS(flags);
189 hash = 0;
190 x = 1;
191 for ( i = len; i >= 1; i-- ) {
192 hash = (hash + (*ptr % HASH_FLAGS_SIZE) * x) % HASH_FLAGS_SIZE;
193 x = (31 * x) % HASH_FLAGS_SIZE;
194 ptr++;
195 }
196
197 #else
198
199 /* This is the hardest case: 64 bit big endian */
200 len = NRB_FLAGS(flags);
201 ptr = (UInt4 *)BLOCKS_FLAGS(flags);
202 hash = 0;
203 x = 1;
204 for ( i = len; i >= 1; i-- ) {
205
206 /* least significant 32 bits first */
207 hash = (hash + (ptr[1] % HASH_FLAGS_SIZE) * x) % HASH_FLAGS_SIZE;
208 x = (31 * x) % HASH_FLAGS_SIZE;
209 /* now the more significant */
210 hash = (hash + (*ptr % HASH_FLAGS_SIZE) * x) % HASH_FLAGS_SIZE;
211 x = (31 * x) % HASH_FLAGS_SIZE;
212
213 ptr+= 2;
214 }
215 #endif
216 SET_HASH_FLAGS( flags, INTOBJ_INT((UInt)hash+1) );
217 CHANGED_BAG(flags);
218 return HASH_FLAGS(flags);
219 }
220
221
222 /****************************************************************************
223 **
224 *F FuncTRUES_FLAGS( <self>, <flags> ) . . . true positions of a flags list
225 **
226 ** see 'FuncPositionsTruesBlist' in "blister.c" for information.
227 */
FuncTRUES_FLAGS(Obj self,Obj flags)228 static Obj FuncTRUES_FLAGS(Obj self, Obj flags)
229 {
230 Obj sub; /* handle of the result */
231 Int len; /* logical length of the list */
232 UInt * ptr; /* pointer to flags */
233 UInt nrb; /* number of blocks in flags */
234 UInt n; /* number of bits in flags */
235 UInt nn;
236 UInt i; /* loop variable */
237
238 /* get and check the first argument */
239 RequireFlags("TRUES_FLAGS", flags);
240 if ( TRUES_FLAGS(flags) != 0 ) {
241 return TRUES_FLAGS(flags);
242 }
243
244 /* compute the number of 'true'-s just as in 'FuncSizeBlist' */
245 nrb = NRB_FLAGS(flags);
246 ptr = (UInt*)BLOCKS_FLAGS(flags);
247 n = COUNT_TRUES_BLOCKS(ptr, nrb);
248
249 /* make the sublist (we now know its size exactly) */
250 sub = NEW_PLIST_IMM( T_PLIST, n );
251 SET_LEN_PLIST( sub, n );
252
253 /* loop over the boolean list and stuff elements into <sub> */
254 len = LEN_FLAGS( flags );
255 nn = 1;
256 for ( i = 1; nn <= n && i <= len; i++ ) {
257 if ( C_ELM_FLAGS( flags, i ) ) {
258 SET_ELM_PLIST( sub, nn, INTOBJ_INT(i) );
259 nn++;
260 }
261 }
262 CHANGED_BAG(sub);
263
264 /* return the sublist */
265 SET_TRUES_FLAGS( flags, sub );
266 CHANGED_BAG(flags);
267 return sub;
268 }
269
270
271 /****************************************************************************
272 **
273 *F FuncSIZE_FLAGS( <self>, <flags> ) . . . . number of trues of a flags list
274 **
275 ** see 'FuncSIZE_FLAGS'
276 */
FuncSIZE_FLAGS(Obj self,Obj flags)277 static Obj FuncSIZE_FLAGS(Obj self, Obj flags)
278 {
279 UInt * ptr; /* pointer to flags */
280 UInt nrb; /* number of blocks in flags */
281 UInt n; /* number of bits in flags */
282
283 /* get and check the first argument */
284 RequireFlags("SIZE_FLAGS", flags);
285 if ( TRUES_FLAGS(flags) != 0 ) {
286 return INTOBJ_INT( LEN_PLIST( TRUES_FLAGS(flags) ) );
287 }
288
289 /* get the number of blocks and a pointer */
290 nrb = NRB_FLAGS(flags);
291 ptr = BLOCKS_FLAGS(flags);
292
293 n = COUNT_TRUES_BLOCKS(ptr, nrb);
294
295 /* return the number of bits */
296 return INTOBJ_INT( n );
297 }
298
299
300 /****************************************************************************
301 **
302 *F EqFlags( <flags1>, <flags2> ) . . . . . . . . . . equality of flags lists
303 */
EqFlags(Obj flags1,Obj flags2)304 static Int EqFlags(Obj flags1, Obj flags2)
305 {
306 Int len1;
307 Int len2;
308 UInt * ptr1;
309 UInt * ptr2;
310 Int i;
311
312 if ( flags1 == flags2 ) {
313 return 1;
314 }
315
316 // do the real work
317 len1 = NRB_FLAGS(flags1);
318 len2 = NRB_FLAGS(flags2);
319 ptr1 = BLOCKS_FLAGS(flags1);
320 ptr2 = BLOCKS_FLAGS(flags2);
321 if ( len1 <= len2 ) {
322 for ( i = 1; i <= len1; i++ ) {
323 if ( *ptr1 != *ptr2 )
324 return 0;
325 ptr1++; ptr2++;
326 }
327 for ( ; i <= len2; i++ ) {
328 if ( 0 != *ptr2 )
329 return 0;
330 ptr2++;
331 }
332 }
333 else {
334 for ( i = 1; i <= len2; i++ ) {
335 if ( *ptr1 != *ptr2 )
336 return 0;
337 ptr1++; ptr2++;
338 }
339 for ( ; i <= len1; i++ ) {
340 if ( *ptr1 != 0 )
341 return 0;
342 ptr1++;
343 }
344 }
345 return 1;
346 }
347
348
349 /****************************************************************************
350 **
351 *F FuncIS_EQUAL_FLAGS( <self>, <flags1>, <flags2> ) equality of flags lists
352 */
FuncIS_EQUAL_FLAGS(Obj self,Obj flags1,Obj flags2)353 static Obj FuncIS_EQUAL_FLAGS(Obj self, Obj flags1, Obj flags2)
354 {
355 /* do some trivial checks */
356 RequireFlags("IS_EQUAL_FLAGS", flags1);
357 RequireFlags("IS_EQUAL_FLAGS", flags2);
358
359 return EqFlags(flags1, flags2) ? True : False;
360 }
361
362
363 #ifdef COUNT_OPERS
364 static Int IsSubsetFlagsCalls;
365 #endif
366
367 /****************************************************************************
368 **
369 *F IS_SUBSET_FLAGS( <flags1>, <flags2> ) . subset test with no safety check
370 */
IS_SUBSET_FLAGS(Obj flags1,Obj flags2)371 static Int IS_SUBSET_FLAGS(Obj flags1, Obj flags2)
372 {
373 Int len1;
374 Int len2;
375 UInt * ptr1;
376 UInt * ptr2;
377 Int i;
378
379 #ifdef COUNT_OPERS
380 IsSubsetFlagsCalls++;
381 #endif
382
383 /* compare the bit lists */
384 len1 = NRB_FLAGS(flags1);
385 len2 = NRB_FLAGS(flags2);
386 ptr1 = BLOCKS_FLAGS(flags1);
387 ptr2 = BLOCKS_FLAGS(flags2);
388 if (len1 < len2) {
389 for (i = len2 - 1; i >= len1; i--) {
390 if (ptr2[i] != 0)
391 return 0;
392 }
393 for (i = len1 - 1; i >= 0; i--) {
394 UInt x = ptr2[i];
395 if ((x & ptr1[i]) != x)
396 return 0;
397 }
398 }
399 else {
400 for (i = len2 - 1; i >= 0; i--) {
401 UInt x = ptr2[i];
402 if ((x & ptr1[i]) != x)
403 return 0;
404 }
405 }
406 return 1;
407 }
408
409 /****************************************************************************
410 **
411 *F FuncIS_SUBSET_FLAGS( <self>, <flags1>, <flags2> ) . . . . . . subset test
412 */
FuncIS_SUBSET_FLAGS(Obj self,Obj flags1,Obj flags2)413 Obj FuncIS_SUBSET_FLAGS (
414 Obj self,
415 Obj flags1,
416 Obj flags2 )
417 {
418 /* do some correctness checks */
419 RequireFlags("IS_SUBSET_FLAGS", flags1);
420 RequireFlags("IS_SUBSET_FLAGS", flags2);
421
422 return IS_SUBSET_FLAGS(flags1, flags2) ? True : False;
423 }
424
425 /****************************************************************************
426 **
427 *F FuncSUB_FLAGS( <self>, <flags1>, <flags2> ) . . . substract a flags list
428 */
FuncSUB_FLAGS(Obj self,Obj flags1,Obj flags2)429 static Obj FuncSUB_FLAGS(Obj self, Obj flags1, Obj flags2)
430 {
431 Obj flags;
432 Int len1;
433 Int len2;
434 Int size1;
435 Int size2;
436 UInt * ptr;
437 UInt * ptr1;
438 UInt * ptr2;
439 Int i;
440
441 /* do some trivial checks */
442 RequireFlags("SUB_FLAGS", flags1);
443 RequireFlags("SUB_FLAGS", flags2);
444
445 /* do the real work */
446 len1 = LEN_FLAGS(flags1);
447 size1 = NRB_FLAGS(flags1);
448 len2 = LEN_FLAGS(flags2);
449 size2 = NRB_FLAGS(flags2);
450 if ( len1 < len2 ) {
451 flags = NEW_FLAGS( len1 );
452 ptr1 = BLOCKS_FLAGS(flags1);
453 ptr2 = BLOCKS_FLAGS(flags2);
454 ptr = BLOCKS_FLAGS(flags);
455 for ( i = 1; i <= size1; i++ )
456 *ptr++ = *ptr1++ & ~ *ptr2++;
457 }
458 else {
459 flags = NEW_FLAGS( len1 );
460 ptr1 = BLOCKS_FLAGS(flags1);
461 ptr2 = BLOCKS_FLAGS(flags2);
462 ptr = BLOCKS_FLAGS(flags);
463 for ( i = 1; i <= size2; i++ )
464 *ptr++ = *ptr1++ & ~ *ptr2++;
465 for ( ; i <= size1; i++ )
466 *ptr++ = *ptr1++;
467 }
468
469 return flags;
470 }
471
472
473 /****************************************************************************
474 **
475 *F FuncAND_FLAGS( <self>, <flags1>, <flags2> ) . . . . `and' of flags lists
476 */
477 #define AND_FLAGS_HASH_SIZE 50
478
479 #ifdef COUNT_OPERS
480 static Int AndFlagsCacheHit;
481 static Int AndFlagsCacheMiss;
482 static Int AndFlagsCacheLost;
483 #endif
484
FuncAND_FLAGS(Obj self,Obj flags1,Obj flags2)485 static Obj FuncAND_FLAGS(Obj self, Obj flags1, Obj flags2)
486 {
487 Obj flags;
488 Int len1;
489 Int len2;
490 Int size1;
491 Int size2;
492 UInt * ptr;
493 UInt * ptr1;
494 UInt * ptr2;
495 Int i;
496
497 #ifdef AND_FLAGS_HASH_SIZE
498 Obj cache;
499 Obj entry;
500 #ifdef HPCGAP
501 Obj locked = 0;
502 #endif
503 UInt hash;
504 UInt hash2;
505 static UInt next = 0; // FIXME HPC-GAP: is usage of this static thread-safe?
506 #endif
507
508 /* do some trivial checks */
509 RequireFlags("AND_FLAGS", flags1);
510 RequireFlags("AND_FLAGS", flags2);
511
512 if (flags1 == flags2)
513 return flags1;
514 if (LEN_FLAGS(flags2) == 0)
515 return flags1;
516 if (LEN_FLAGS(flags1) == 0)
517 return flags2;
518
519 // check the cache
520 # ifdef AND_FLAGS_HASH_SIZE
521 // We want to ensure if we calculate 'flags1 and flags2', then
522 // later do 'flags2 and flags1', we will get the value from the cache.
523 // Therefore we just compare the location of the Bag masterpointers
524 // for both flags (which doesn't change), and use the cache of the
525 // smaller. To this end, ensure flags1 is the smaller one.
526 if ( flags1 > flags2 ) {
527 SWAP(Obj, flags1, flags2);
528 }
529
530 # ifdef HPCGAP
531 if (!PreThreadCreation) {
532 locked = flags1;
533 HashLock(locked);
534 }
535 # endif
536 cache = AND_CACHE_FLAGS(flags1);
537 if ( cache == 0 ) {
538 cache = NEW_PLIST( T_PLIST, 2*AND_FLAGS_HASH_SIZE );
539 #ifdef HPCGAP
540 MakeBagPublic(cache);
541 #endif
542 SET_AND_CACHE_FLAGS( flags1, cache );
543 CHANGED_BAG(flags1);
544 }
545 hash = (UInt)flags2;
546 entry = 0;
547 for ( i = 0; i < 24; i++ ) {
548 hash2 = (hash + 97*i) % AND_FLAGS_HASH_SIZE;
549 entry = ELM_PLIST( cache, 2*hash2+1 );
550 if ( entry == 0 ) {
551 hash = hash2;
552 break;
553 }
554 if ( entry == flags2 ) {
555 # ifdef COUNT_OPERS
556 AndFlagsCacheHit++;
557 # endif
558 # if defined(HPCGAP) && defined(AND_FLAGS_HASH_SIZE)
559 if (locked)
560 HashUnlock(locked);
561 # endif
562 return ELM_PLIST( cache, 2*hash2+2 );
563 }
564 }
565 if ( entry != 0 ) {
566 next = (next+1) % 24;
567 hash = (hash + 97*next) % AND_FLAGS_HASH_SIZE;
568 }
569 # ifdef COUNT_OPERS
570 AndFlagsCacheMiss++;
571 # endif
572 # endif
573
574
575 /* do the real work */
576 len1 = LEN_FLAGS(flags1);
577 size1 = NRB_FLAGS(flags1);
578 len2 = LEN_FLAGS(flags2);
579 size2 = NRB_FLAGS(flags2);
580
581 if ( len1 < len2 ) {
582 flags = NEW_FLAGS( len2 );
583 ptr1 = BLOCKS_FLAGS(flags1);
584 ptr2 = BLOCKS_FLAGS(flags2);
585 ptr = BLOCKS_FLAGS(flags);
586 for ( i = 1; i <= size1; i++ )
587 *ptr++ = *ptr1++ | *ptr2++;
588 for ( ; i <= size2; i++ )
589 *ptr++ = *ptr2++;
590 }
591 else {
592 flags = NEW_FLAGS( len1 );
593 ptr1 = BLOCKS_FLAGS(flags1);
594 ptr2 = BLOCKS_FLAGS(flags2);
595 ptr = BLOCKS_FLAGS(flags);
596 for ( i = 1; i <= size2; i++ )
597 *ptr++ = *ptr1++ | *ptr2++;
598 for ( ; i <= size1; i++ )
599 *ptr++ = *ptr1++;
600 }
601
602 /* store result in the cache */
603 # ifdef AND_FLAGS_HASH_SIZE
604 # ifdef COUNT_OPERS
605 if ( ELM_PLIST(cache,2*hash+1) != 0 ) {
606 AndFlagsCacheLost++;
607 }
608 # endif
609 SET_ELM_PLIST( cache, 2*hash+1, flags2 );
610 SET_ELM_PLIST( cache, 2*hash+2, flags );
611 CHANGED_BAG(cache);
612 # ifdef HPCGAP
613 if (locked)
614 HashUnlock(locked);
615 # endif
616 # endif
617
618 /* and return the result */
619 return flags;
620 }
621
622 static Obj HIDDEN_IMPS;
623 static Obj WITH_HIDDEN_IMPS_FLAGS_CACHE;
624 enum { HIDDEN_IMPS_CACHE_LENGTH = 20003 };
625
626 /* Forward declaration of FuncFLAGS_FILTER */
627 static Obj FuncFLAGS_FILTER(Obj self, Obj oper);
628
629 /****************************************************************************
630 **
631 *F FuncInstallHiddenTrueMethod( <filter>, <filters> ) Add a hidden true method
632 */
FuncInstallHiddenTrueMethod(Obj self,Obj filter,Obj filters)633 static Obj FuncInstallHiddenTrueMethod(Obj self, Obj filter, Obj filters)
634 {
635 Obj imp = FuncFLAGS_FILTER(0, filter);
636 Obj imps = FuncFLAGS_FILTER(0, filters);
637 #ifdef HPCGAP
638 RegionWriteLock(REGION(HIDDEN_IMPS));
639 #endif
640 UInt len = LEN_PLIST(HIDDEN_IMPS);
641 GROW_PLIST(HIDDEN_IMPS, len + 2);
642 SET_LEN_PLIST(HIDDEN_IMPS, len + 2);
643 SET_ELM_PLIST(HIDDEN_IMPS, len + 1, imp);
644 SET_ELM_PLIST(HIDDEN_IMPS, len + 2, imps);
645 CHANGED_BAG(HIDDEN_IMPS);
646 #ifdef HPCGAP
647 RegionWriteUnlock(REGION(HIDDEN_IMPS));
648 #endif
649 return 0;
650 }
651
652 /****************************************************************************
653 **
654 *F FuncCLEAR_HIDDEN_IMP_CACHE( <self>, <flags> ) . . . .clear cache of flags
655 */
FuncCLEAR_HIDDEN_IMP_CACHE(Obj self,Obj filter)656 static Obj FuncCLEAR_HIDDEN_IMP_CACHE(Obj self, Obj filter)
657 {
658 Int i;
659 Obj flags = FuncFLAGS_FILTER(0, filter);
660 #ifdef HPCGAP
661 RegionWriteLock(REGION(WITH_HIDDEN_IMPS_FLAGS_CACHE));
662 #endif
663 for(i = 1; i < HIDDEN_IMPS_CACHE_LENGTH * 2 - 1; i += 2)
664 {
665 if(ELM_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, i) &&
666 FuncIS_SUBSET_FLAGS(0, ELM_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, i+1), flags) == True)
667 {
668 SET_ELM_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, i, 0);
669 SET_ELM_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, i + 1, 0);
670 CHANGED_BAG(WITH_HIDDEN_IMPS_FLAGS_CACHE);
671 }
672 }
673 #ifdef HPCGAP
674 RegionWriteUnlock(REGION(WITH_HIDDEN_IMPS_FLAGS_CACHE));
675 #endif
676 return 0;
677 }
678
679 /****************************************************************************
680 **
681 *F FuncWITH_HIDDEN_IMP_FLAGS( <self>, <flags> ) . . add hidden imps to flags
682 */
683 #ifdef COUNT_OPERS
684 static Int WITH_HIDDEN_IMPS_MISS=0;
685 static Int WITH_HIDDEN_IMPS_HIT=0;
686 #endif
FuncWITH_HIDDEN_IMPS_FLAGS(Obj self,Obj flags)687 static Obj FuncWITH_HIDDEN_IMPS_FLAGS(Obj self, Obj flags)
688 {
689 // do some trivial checks, so we can use IS_SUBSET_FLAGS
690 RequireFlags("WITH_HIDDEN_IMPS_FLAGS", flags);
691
692 #ifdef HPCGAP
693 RegionWriteLock(REGION(WITH_HIDDEN_IMPS_FLAGS_CACHE));
694 #endif
695 Int changed, i, lastand, stop;
696 Int hidden_imps_length = LEN_PLIST(HIDDEN_IMPS) / 2;
697 Int base_hash = INT_INTOBJ(FuncHASH_FLAGS(0, flags)) % HIDDEN_IMPS_CACHE_LENGTH;
698 Int hash = base_hash;
699 Int hash_loop = 0;
700 Obj cacheval;
701 Obj old_with, old_flags, new_with, new_flags;
702 Obj with = flags;
703
704 for(hash_loop = 0; hash_loop < 3; ++hash_loop)
705 {
706 cacheval = ELM_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, hash*2+1);
707 if(cacheval && cacheval == flags) {
708 Obj ret = ELM_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, hash*2+2);
709 #ifdef HPCGAP
710 RegionWriteUnlock(REGION(WITH_HIDDEN_IMPS_FLAGS_CACHE));
711 #endif
712 #ifdef COUNT_OPERS
713 WITH_HIDDEN_IMPS_HIT++;
714 #endif
715 return ret;
716 }
717 hash = (hash * 311 + 61) % HIDDEN_IMPS_CACHE_LENGTH;
718 }
719
720 #ifdef COUNT_OPERS
721 WITH_HIDDEN_IMPS_MISS++;
722 #endif
723 changed = 1;
724 lastand = 0;
725 while(changed)
726 {
727 changed = 0;
728 for (i = hidden_imps_length, stop = lastand; i > stop; i--)
729 {
730 if( IS_SUBSET_FLAGS(with, ELM_PLIST(HIDDEN_IMPS, i*2)) &&
731 !IS_SUBSET_FLAGS(with, ELM_PLIST(HIDDEN_IMPS, i*2-1)) )
732 {
733 with = FuncAND_FLAGS(0, with, ELM_PLIST(HIDDEN_IMPS, i*2-1));
734 changed = 1;
735 stop = 0;
736 lastand = i;
737 }
738 }
739 }
740
741 /* add to hash table, shuffling old values along (last one falls off) */
742 hash = base_hash;
743
744 new_with = with;
745 new_flags = flags;
746
747 for (hash_loop = 0; hash_loop < 3; ++hash_loop) {
748 old_flags = ELM_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, hash * 2 + 1);
749 old_with = ELM_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, hash * 2 + 2);
750
751 SET_ELM_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, hash * 2 + 1, new_flags);
752 SET_ELM_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, hash * 2 + 2, new_with);
753
754 if (!old_flags)
755 break;
756
757 new_flags = old_flags;
758 new_with = old_with;
759 hash = (hash * 311 + 61) % HIDDEN_IMPS_CACHE_LENGTH;
760 }
761
762 CHANGED_BAG(WITH_HIDDEN_IMPS_FLAGS_CACHE);
763 #ifdef HPCGAP
764 RegionWriteUnlock(REGION(WITH_HIDDEN_IMPS_FLAGS_CACHE));
765 #endif
766 return with;
767 }
768
769
770 static Obj IMPLICATIONS_SIMPLE;
771 static Obj IMPLICATIONS_COMPOSED;
772 static Obj WITH_IMPS_FLAGS_CACHE;
773 enum { IMPS_CACHE_LENGTH = 21001 };
774
775 /****************************************************************************
776 **
777 *F FuncCLEAR_IMP_CACHE( <self>, <flags> ) . . . . . . . clear cache of flags
778 */
FuncCLEAR_IMP_CACHE(Obj self)779 static Obj FuncCLEAR_IMP_CACHE(Obj self)
780 {
781 Int i;
782 #ifdef HPCGAP
783 RegionWriteLock(REGION(IMPLICATIONS_SIMPLE));
784 #endif
785 for(i = 1; i < IMPS_CACHE_LENGTH * 2 - 1; i += 2)
786 {
787 SET_ELM_PLIST(WITH_IMPS_FLAGS_CACHE, i, 0);
788 SET_ELM_PLIST(WITH_IMPS_FLAGS_CACHE, i + 1, 0);
789 }
790 #ifdef HPCGAP
791 RegionWriteUnlock(REGION(IMPLICATIONS_SIMPLE));
792 #endif
793 return 0;
794 }
795
796 /****************************************************************************
797 **
798 *F FuncWITH_IMPS_FLAGS( <self>, <flags> ) . . . . . . . . add imps to flags
799 */
800 #ifdef COUNT_OPERS
801 static Int WITH_IMPS_FLAGS_MISS=0;
802 static Int WITH_IMPS_FLAGS_HIT=0;
803 #endif
FuncWITH_IMPS_FLAGS(Obj self,Obj flags)804 static Obj FuncWITH_IMPS_FLAGS(Obj self, Obj flags)
805 {
806 // do some trivial checks, so we can use IS_SUBSET_FLAGS
807 RequireFlags("WITH_IMPS_FLAGS", flags);
808
809 Int changed, lastand, i, j, stop, imps_length;
810 Int base_hash = INT_INTOBJ(FuncHASH_FLAGS(0, flags)) % IMPS_CACHE_LENGTH;
811 Int hash = base_hash;
812 Int hash_loop = 0;
813 Obj cacheval;
814 Obj old_with, old_flags, new_with, new_flags;
815 Obj with = flags;
816 Obj imp;
817 Obj trues;
818
819 #ifdef HPCGAP
820 RegionWriteLock(REGION(IMPLICATIONS_SIMPLE));
821 #endif
822 for(hash_loop = 0; hash_loop < 3; ++hash_loop)
823 {
824 cacheval = ELM_PLIST(WITH_IMPS_FLAGS_CACHE, hash*2+1);
825 if(cacheval && cacheval == flags) {
826 Obj ret = ELM_PLIST(WITH_IMPS_FLAGS_CACHE, hash*2+2);
827 #ifdef HPCGAP
828 RegionWriteUnlock(REGION(IMPLICATIONS_SIMPLE));
829 #endif
830 #ifdef COUNT_OPERS
831 WITH_IMPS_FLAGS_HIT++;
832 #endif
833 return ret;
834 }
835 hash = (hash * 311 + 61) % IMPS_CACHE_LENGTH;
836 }
837
838 #ifdef COUNT_OPERS
839 WITH_IMPS_FLAGS_MISS++;
840 #endif
841 /* first implications from simple filters (need only be checked once) */
842 trues = FuncTRUES_FLAGS(0, flags);
843 for (i=1; i<=LEN_PLIST(trues); i++) {
844 j = INT_INTOBJ(ELM_PLIST(trues, i));
845 if (j <= LEN_PLIST(IMPLICATIONS_SIMPLE)
846 && ELM_PLIST(IMPLICATIONS_SIMPLE, j)) {
847 imp = ELM_PLIST(IMPLICATIONS_SIMPLE, j);
848 if( IS_SUBSET_FLAGS(with, ELM_PLIST(imp, 2)) &&
849 !IS_SUBSET_FLAGS(with, ELM_PLIST(imp, 1)) )
850 {
851 with = FuncAND_FLAGS(0, with, ELM_PLIST(imp, 1));
852 }
853 }
854 }
855
856 /* the other implications have to be considered in a loop */
857 imps_length = LEN_PLIST(IMPLICATIONS_COMPOSED);
858 changed = 1;
859 lastand = imps_length+1;
860 while(changed)
861 {
862 changed = 0;
863 for (i = 1, stop = lastand; i < stop; i++)
864 {
865 imp = ELM_PLIST(IMPLICATIONS_COMPOSED, i);
866 if( IS_SUBSET_FLAGS(with, ELM_PLIST(imp, 2)) &&
867 !IS_SUBSET_FLAGS(with, ELM_PLIST(imp, 1)) )
868 {
869 with = FuncAND_FLAGS(0, with, ELM_PLIST(imp, 1));
870 changed = 1;
871 stop = imps_length+1;
872 lastand = i;
873 }
874 }
875 }
876
877 /* add to hash table, shuffling old values along (last one falls off) */
878 hash = base_hash;
879
880 new_with = with;
881 new_flags = flags;
882
883 for (hash_loop = 0; hash_loop < 3; ++hash_loop) {
884 old_flags = ELM_PLIST(WITH_IMPS_FLAGS_CACHE, hash*2+1);
885 old_with = ELM_PLIST(WITH_IMPS_FLAGS_CACHE, hash*2+2);
886
887 SET_ELM_PLIST(WITH_IMPS_FLAGS_CACHE, hash * 2 + 1, new_flags);
888 SET_ELM_PLIST(WITH_IMPS_FLAGS_CACHE, hash * 2 + 2, new_with);
889
890 if (!old_flags)
891 break;
892
893 new_flags = old_flags;
894 new_with = old_with;
895 hash = (hash * 311 + 61) % IMPS_CACHE_LENGTH;
896 }
897
898 CHANGED_BAG(WITH_IMPS_FLAGS_CACHE);
899 #ifdef HPCGAP
900 RegionWriteUnlock(REGION(IMPLICATIONS_SIMPLE));
901 #endif
902 return with;
903 }
904
FuncWITH_IMPS_FLAGS_STAT(Obj self)905 static Obj FuncWITH_IMPS_FLAGS_STAT(Obj self)
906 {
907 Obj res;
908 res = NEW_PLIST(T_PLIST, 3);
909 SET_LEN_PLIST(res, 3);
910 SET_ELM_PLIST(res, 1, WITH_IMPS_FLAGS_CACHE);
911 #ifdef COUNT_OPERS
912 SET_ELM_PLIST(res, 2, INTOBJ_INT(WITH_IMPS_FLAGS_HIT));
913 SET_ELM_PLIST(res, 3, INTOBJ_INT(WITH_IMPS_FLAGS_MISS));
914 #else
915 SET_ELM_PLIST(res, 2, Fail);
916 SET_ELM_PLIST(res, 3, Fail);
917 #endif
918 return res;
919 }
920
921 /****************************************************************************
922 **
923 *F * * * * * * * * * * * internal filter functions * * * * * * * * * * * * *
924 */
925
926
927 /****************************************************************************
928 **
929 *V Countlags . . . . . . . . . . . . . . . . . . . . next free flag number
930 */
931 static Int CountFlags;
932
933
934 /****************************************************************************
935 **
936 *F SetterFilter( <oper> ) . . . . . . . . . . . . . . . setter of a filter
937 */
SetterFilter(Obj oper)938 static Obj SetterFilter(Obj oper)
939 {
940 Obj setter;
941
942 setter = SETTR_FILT( oper );
943 if ( setter == INTOBJ_INT(0xBADBABE) )
944 setter = SetterAndFilter( oper );
945 return setter;
946 }
947
948
949 /****************************************************************************
950 **
951 *F SetterAndFilter( <getter> ) . . . . . . setter of a concatenated filter
952 */
DoSetAndFilter(Obj self,Obj obj,Obj val)953 static Obj DoSetAndFilter(Obj self, Obj obj, Obj val)
954 {
955 Obj op;
956
957 if (val != True)
958 ErrorMayQuit("You cannot set an \"and-filter\" except to true", 0, 0);
959
960 /* call the first 'and'-ed function */
961 op = FLAG1_FILT( self );
962 CALL_2ARGS( op, obj, val );
963
964 /* call the second 'and'-ed function */
965 op = FLAG2_FILT( self );
966 CALL_2ARGS( op, obj, val );
967
968 /* return 'void' */
969 return 0;
970 }
971
972
SetterAndFilter(Obj getter)973 static Obj SetterAndFilter(Obj getter)
974 {
975 Obj setter;
976 Obj obj;
977 if ( SETTR_FILT( getter ) == INTOBJ_INT(0xBADBABE) ) {
978 setter = NewFunctionT( T_FUNCTION, sizeof(OperBag),
979 MakeImmString("<<setter-and-filter>>"), 2, ArglistObjVal,
980 DoSetAndFilter );
981 /* assign via 'obj' to avoid GC issues */
982 obj = SetterFilter( FLAG1_FILT(getter) );
983 SET_FLAG1_FILT(setter, obj);
984 obj = SetterFilter( FLAG2_FILT(getter) );
985 SET_FLAG2_FILT(setter, obj);
986 SET_SETTR_FILT(getter, setter);
987 CHANGED_BAG(getter);
988 }
989
990 return SETTR_FILT(getter);
991 }
992
993
994 /****************************************************************************
995 **
996 *F TesterFilter( <oper> ) . . . . . . . . . . . . . . . tester of a filter
997 */
TesterFilter(Obj oper)998 static Obj TesterFilter(Obj oper)
999 {
1000 Obj tester;
1001
1002 tester = TESTR_FILT( oper );
1003 if ( tester == INTOBJ_INT(0xBADBABE) )
1004 tester = TesterAndFilter( oper );
1005 return tester;
1006 }
1007
1008
1009 /****************************************************************************
1010 **
1011 *F TestAndFilter( <getter> ) . . . . . . . .tester of a concatenated filter
1012 */
TesterAndFilter(Obj getter)1013 static Obj TesterAndFilter(Obj getter)
1014 {
1015 Obj tester;
1016
1017 if ( TESTR_FILT( getter ) == INTOBJ_INT(0xBADBABE) ) {
1018 tester = NewAndFilter( TesterFilter( FLAG1_FILT(getter) ),
1019 TesterFilter( FLAG2_FILT(getter) ) );
1020 SET_TESTR_FILT(getter, tester);
1021 CHANGED_BAG(getter);
1022
1023 }
1024 return TESTR_FILT(getter);
1025 }
1026
1027
1028 /****************************************************************************
1029 **
1030 *F NewFilter( <name>, <nams>, <hdlr> ) . . . . . . . . . . make a new filter
1031 */
DoSetFilter(Obj self,Obj obj,Obj val)1032 static Obj DoSetFilter(Obj self, Obj obj, Obj val)
1033 {
1034 Int flag1;
1035 Obj type;
1036 Obj flags;
1037
1038 /* get the flag for the getter */
1039 flag1 = INT_INTOBJ( FLAG1_FILT( self ) );
1040
1041 /* get the type of the object and its flags */
1042 type = TYPE_OBJ( obj );
1043 flags = FLAGS_TYPE( type );
1044
1045 /* return the value of the feature */
1046 if ( val != SAFE_ELM_FLAGS( flags, flag1 ) ) {
1047 ErrorMayQuit("filter is already set the other way", 0, 0);
1048 }
1049
1050 /* return 'void' */
1051 return 0;
1052 }
1053
NewSetterFilter(Obj getter)1054 static Obj NewSetterFilter(Obj getter)
1055 {
1056 Obj setter;
1057
1058 setter = NewOperation( StringFilterSetter, 2, ArglistObjVal,
1059 DoSetFilter );
1060 SET_FLAG1_FILT(setter, FLAG1_FILT(getter));
1061 SET_FLAG2_FILT(setter, INTOBJ_INT(0));
1062 CHANGED_BAG(setter);
1063
1064 return setter;
1065 }
1066
1067
DoFilter(Obj self,Obj obj)1068 Obj DoFilter (
1069 Obj self,
1070 Obj obj )
1071 {
1072 Obj val;
1073 Int flag1;
1074 Obj type;
1075 Obj flags;
1076
1077 /* get the flag for the getter */
1078 flag1 = INT_INTOBJ( FLAG1_FILT( self ) );
1079
1080 /* get the type of the object and its flags */
1081 type = TYPE_OBJ( obj );
1082 flags = FLAGS_TYPE( type );
1083
1084 /* return the value of the feature */
1085 val = SAFE_ELM_FLAGS( flags, flag1 );
1086
1087 /* return the value */
1088 return val;
1089 }
1090
1091
NewFilter(Obj name,Obj nams,ObjFunc hdlr)1092 Obj NewFilter (
1093 Obj name,
1094 Obj nams,
1095 ObjFunc hdlr )
1096 {
1097 Obj getter;
1098 Obj setter;
1099 Int flag1;
1100 Obj flags;
1101
1102 flag1 = ++CountFlags;
1103
1104 GAP_ASSERT(hdlr);
1105 getter = NewOperation(name, 1, nams, hdlr);
1106 SET_FLAG1_FILT(getter, INTOBJ_INT(flag1));
1107 SET_FLAG2_FILT(getter, INTOBJ_INT(0));
1108 flags = NEW_FLAGS( flag1 );
1109 SET_ELM_FLAGS( flags, flag1 );
1110 SET_FLAGS_FILT(getter, flags);
1111 SET_IS_FILTER(getter);
1112 CHANGED_BAG(getter);
1113
1114 setter = NewSetterFilter( getter );
1115 SET_SETTR_FILT(getter, setter);
1116 SET_TESTR_FILT(getter, ReturnTrueFilter);
1117 CHANGED_BAG(getter);
1118
1119 return getter;
1120 }
1121
FuncIS_FILTER(Obj self,Obj obj)1122 static Obj FuncIS_FILTER(Obj self, Obj obj)
1123 {
1124 return IS_FILTER(obj) ? True : False;
1125 }
1126
1127
1128 /****************************************************************************
1129 **
1130 *F NewAndFilter( <filt1>, <filt2> ) . . . . . make a new concatenated filter
1131 */
DoAndFilter(Obj self,Obj obj)1132 static Obj DoAndFilter(Obj self, Obj obj)
1133 {
1134 Obj val;
1135 Obj op;
1136
1137 /* call the first 'and'-ed function */
1138 op = FLAG1_FILT( self );
1139 val = CALL_1ARGS( op, obj );
1140 if ( val != True ) return False;
1141
1142 /* call the second 'and'-ed function */
1143 op = FLAG2_FILT( self );
1144 val = CALL_1ARGS( op, obj );
1145 if ( val != True ) return False;
1146
1147 /* return 'true' */
1148 return True;
1149 }
1150
NewAndFilter(Obj oper1,Obj oper2)1151 Obj NewAndFilter (
1152 Obj oper1,
1153 Obj oper2 )
1154 {
1155 Obj getter;
1156 Obj flags;
1157
1158 Int str_len;
1159 Obj str;
1160 char* s;
1161
1162 RequireFilter(0, oper1, "<oper1>");
1163 RequireFilter(0, oper2, "<oper2>");
1164
1165 if ( oper1 == ReturnTrueFilter )
1166 return oper2;
1167
1168 if ( oper2 == ReturnTrueFilter )
1169 return oper1;
1170
1171 if ( oper1 == oper2 )
1172 return oper1;
1173
1174 str_len = GET_LEN_STRING(NAME_FUNC(oper1)) + GET_LEN_STRING(NAME_FUNC(oper2)) + 8;
1175 str = NEW_STRING(str_len);
1176 s = CSTR_STRING(str);
1177 s[0] = '(';
1178 s[1] = 0;
1179 strlcat(s, CONST_CSTR_STRING(NAME_FUNC(oper1)), str_len);
1180 strlcat(s, " and ", str_len);
1181 strlcat(s, CONST_CSTR_STRING(NAME_FUNC(oper2)), str_len);
1182 strlcat(s, ")", str_len);
1183 SET_LEN_STRING(str, str_len - 1);
1184
1185 getter = NewFunctionT( T_FUNCTION, sizeof(OperBag), str, 1,
1186 ArglistObj, DoAndFilter );
1187 SET_FLAG1_FILT(getter, oper1);
1188 SET_FLAG2_FILT(getter, oper2);
1189 flags = FuncAND_FLAGS( 0, FLAGS_FILT(oper1), FLAGS_FILT(oper2) );
1190 SET_FLAGS_FILT(getter, flags);
1191 SET_SETTR_FILT(getter, INTOBJ_INT(0xBADBABE));
1192 SET_TESTR_FILT(getter, INTOBJ_INT(0xBADBABE));
1193 SET_IS_FILTER(getter);
1194 CHANGED_BAG(getter);
1195
1196 return getter;
1197 }
1198
FuncIS_AND_FILTER(Obj self,Obj filt)1199 static Obj FuncIS_AND_FILTER(Obj self, Obj filt)
1200 {
1201 return (IS_FUNC(filt) && HDLR_FUNC(filt, 1) == DoAndFilter) ? True : False;
1202 }
1203
1204
1205 /****************************************************************************
1206 **
1207 *V ReturnTrueFilter . . . . . . . . . . . . . . . . the return 'true' filter
1208 */
1209 Obj ReturnTrueFilter;
1210
1211
1212 /****************************************************************************
1213 **
1214 *F NewReturnTrueFilter() . . . . . . . . . . create a new return true filter
1215 */
DoSetReturnTrueFilter(Obj self,Obj obj,Obj val)1216 static Obj DoSetReturnTrueFilter(Obj self, Obj obj, Obj val)
1217 {
1218 if ( val != True ) {
1219 ErrorMayQuit("you cannot set this flag to 'false'", 0, 0);
1220 }
1221 return 0;
1222 }
1223
SetterReturnTrueFilter(Obj getter)1224 static Obj SetterReturnTrueFilter(Obj getter)
1225 {
1226 Obj setter;
1227
1228 setter = NewFunctionT( T_FUNCTION, sizeof(OperBag),
1229 MakeImmString("<<setter-true-filter>>"), 2, ArglistObjVal,
1230 DoSetReturnTrueFilter );
1231 SET_FLAG1_FILT(setter, INTOBJ_INT(0));
1232 SET_FLAG2_FILT(setter, INTOBJ_INT(0));
1233 CHANGED_BAG(setter);
1234
1235 return setter;
1236 }
1237
DoReturnTrueFilter(Obj self,Obj obj)1238 static Obj DoReturnTrueFilter(Obj self, Obj obj)
1239 {
1240 return True;
1241 }
1242
NewReturnTrueFilter(void)1243 static Obj NewReturnTrueFilter(void)
1244 {
1245 Obj getter;
1246 Obj setter;
1247 Obj flags;
1248
1249 getter = NewFunctionT( T_FUNCTION, sizeof(OperBag),
1250 MakeImmString("ReturnTrueFilter"), 1, ArglistObj,
1251 DoReturnTrueFilter );
1252 SET_FLAG1_FILT(getter, INTOBJ_INT(0));
1253 SET_FLAG2_FILT(getter, INTOBJ_INT(0));
1254 flags = NEW_FLAGS( 0 );
1255 SET_FLAGS_FILT(getter, flags);
1256 SET_IS_FILTER(getter);
1257 CHANGED_BAG(getter);
1258
1259 setter = SetterReturnTrueFilter( getter );
1260 SET_SETTR_FILT(getter, setter);
1261 CHANGED_BAG(getter);
1262
1263 // the tester also returns true, so we can reuse the getter
1264 SET_TESTR_FILT(getter, getter);
1265
1266 return getter;
1267 }
1268
1269
1270 /****************************************************************************
1271 **
1272 *F * * * * * * * * * * * * * GAP filter functions * * * * * * * * * * * * * *
1273 */
1274
1275
1276 /****************************************************************************
1277 **
1278 *F FuncNEW_FILTER( <self>, <name> ) . . . . . . . . . . . . . new filter
1279 */
FuncNEW_FILTER(Obj self,Obj name)1280 static Obj FuncNEW_FILTER(Obj self, Obj name)
1281 {
1282 RequireStringRep("NewFilter", name);
1283 return NewFilter(name, 0, DoFilter);
1284 }
1285
1286
1287 /****************************************************************************
1288 **
1289 *F FuncFLAG1_FILTER( <self>, <oper> ) . . . . . . . . . . . . `FLAG1_FILT'
1290 */
FuncFLAG1_FILTER(Obj self,Obj oper)1291 static Obj FuncFLAG1_FILTER(Obj self, Obj oper)
1292 {
1293 Obj flag1;
1294
1295 RequireOperation(oper);
1296 flag1 = FLAG1_FILT( oper );
1297 if ( flag1 == 0 )
1298 flag1 = INTOBJ_INT(0);
1299 return flag1;
1300 }
1301
1302
1303 /****************************************************************************
1304 **
1305 *F FuncFLAG2_FILTER( <self>, <oper> ) . . . . . . . . . . . . `FLAG2_FILT'
1306 */
FuncFLAG2_FILTER(Obj self,Obj oper)1307 static Obj FuncFLAG2_FILTER(Obj self, Obj oper)
1308 {
1309 Obj flag2;
1310
1311 RequireOperation(oper);
1312 flag2 = FLAG2_FILT( oper );
1313 if ( flag2 == 0 )
1314 flag2 = INTOBJ_INT(0);
1315 return flag2;
1316 }
1317
1318
1319 /****************************************************************************
1320 **
1321 *F FuncFLAGS_FILTER( <self>, <oper> ) . . . . . . . . . . . . `FLAGS_FILT'
1322 */
FuncFLAGS_FILTER(Obj self,Obj oper)1323 static Obj FuncFLAGS_FILTER(Obj self, Obj oper)
1324 {
1325 Obj flags;
1326
1327 RequireOperation(oper);
1328 flags = FLAGS_FILT( oper );
1329 if ( flags == 0 )
1330 flags = False;
1331 return flags;
1332 }
1333
1334
1335 /****************************************************************************
1336 **
1337 *F FuncSETTER_FILTER( <self>, <oper> ) . . . . . . . . . setter of a filter
1338 */
FuncSETTER_FILTER(Obj self,Obj oper)1339 static Obj FuncSETTER_FILTER(Obj self, Obj oper)
1340 {
1341 Obj setter;
1342
1343 RequireOperation(oper);
1344 setter = SetterFilter( oper );
1345 if ( setter == 0 ) setter = False;
1346 return setter;
1347 }
1348
1349
1350 /****************************************************************************
1351 **
1352 *F FuncTESTER_FILTER( <self>, <oper> ) . . . . . . . . . tester of a filter
1353 */
FuncTESTER_FILTER(Obj self,Obj oper)1354 static Obj FuncTESTER_FILTER(Obj self, Obj oper)
1355 {
1356 Obj tester;
1357
1358 RequireOperation(oper);
1359 tester = TesterFilter( oper );
1360 if ( tester == 0 ) tester = False;
1361 return tester;
1362 }
1363
1364
1365 /****************************************************************************
1366 **
1367 *F * * * * * * * * * * internal operation functions * * * * * * * * * * * *
1368 */
1369
1370
1371 /****************************************************************************
1372 **
1373 *F HandleMethodNotFound( <oper>, <nargs>, <args>, <verbose>, <constructor>,
1374 ** <precedence> )
1375 **
1376 ** This enables the special error handling for Method Not Found Errors.
1377 ** It assembles all the necessary information into a form where it can be
1378 ** conveniently accessed from GAP.
1379 **
1380 */
1381
1382 static UInt RNamOperation;
1383 static UInt RNamArguments;
1384 static UInt RNamIsVerbose;
1385 static UInt RNamIsConstructor;
1386 static UInt RNamPrecedence;
1387 static Obj HANDLE_METHOD_NOT_FOUND;
1388
HandleMethodNotFound(Obj oper,Int nargs,Obj * args,UInt verbose,UInt constructor,Int precedence)1389 static void HandleMethodNotFound(Obj oper,
1390 Int nargs,
1391 Obj * args,
1392 UInt verbose,
1393 UInt constructor,
1394 Int precedence)
1395 {
1396 Obj r;
1397 Obj arglist;
1398 UInt i;
1399 #ifdef HPCGAP
1400 Region *savedRegion = TLS(currentRegion);
1401 TLS(currentRegion) = TLS(threadRegion);
1402 #endif
1403
1404 r = NEW_PREC(5);
1405 if (RNamOperation == 0)
1406 {
1407 /* we can't do this in initialization because opers
1408 is initialized BEFORE records */
1409 RNamIsConstructor = RNamName("isConstructor");
1410 RNamIsVerbose = RNamName("isVerbose");
1411 RNamOperation = RNamName("Operation");
1412 RNamArguments = RNamName("Arguments");
1413 RNamPrecedence = RNamName("Precedence");
1414 }
1415 AssPRec(r,RNamOperation,oper);
1416 arglist = NEW_PLIST_IMM(nargs ? T_PLIST_DENSE : T_PLIST_EMPTY, nargs);
1417 SET_LEN_PLIST(arglist,nargs);
1418 for (i = 0; i < nargs; i++)
1419 SET_ELM_PLIST( arglist, i+1, args[i]);
1420 CHANGED_BAG(arglist);
1421 AssPRec(r,RNamArguments,arglist);
1422 AssPRec(r,RNamIsVerbose,verbose ? True : False);
1423 AssPRec(r,RNamIsConstructor,constructor ? True : False);
1424 AssPRec(r,RNamPrecedence,INTOBJ_INT(precedence));
1425 SortPRecRNam(r,0);
1426 CALL_1ARGS(HANDLE_METHOD_NOT_FOUND, r);
1427 #ifdef HPCGAP
1428 TLS(currentRegion) = savedRegion;
1429 #endif
1430 ErrorQuit("panic, HANDLE_METHOD_NOT_FOUND should not return", 0, 0);
1431 }
1432
1433 /****************************************************************************
1434 **
1435 *F FuncCOMPACT_TYPE_IDS( <self> ) . . . garbage collect the type IDs
1436 **
1437 */
1438
1439 #ifdef USE_GASMAN
1440
1441 static Obj FLUSH_ALL_METHOD_CACHES;
1442
1443 static Int NextTypeID;
1444 static Obj IsType;
1445
FixTypeIDs(Bag b)1446 static void FixTypeIDs( Bag b ) {
1447 if ( (TNUM_OBJ( b ) == T_POSOBJ) &&
1448 (DoFilter(IsType, b ) == True ))
1449 {
1450 SET_ID_TYPE(b, INTOBJ_INT(NextTypeID));
1451 NextTypeID++;
1452 }
1453 }
1454
1455 #endif
1456
FuncCOMPACT_TYPE_IDS(Obj self)1457 static Obj FuncCOMPACT_TYPE_IDS(Obj self)
1458 {
1459 #ifdef USE_GASMAN
1460 NextTypeID = INT_INTOBJ_MIN;
1461 CallbackForAllBags( FixTypeIDs );
1462 CALL_0ARGS(FLUSH_ALL_METHOD_CACHES);
1463 return INTOBJ_INT(NextTypeID);
1464 #else
1465 // in general garbage collectors, we cannot iterate over
1466 // all bags ever allocated, so we can't implement this function;
1467 // however, with 64 bit versions of GAP, we also should never
1468 // run out of type ids, so this is of little concern
1469 ErrorQuit("panic, COMPACT_TYPE_IDS is not available", 0, 0);
1470 #endif
1471 }
1472
1473 /****************************************************************************
1474 **
1475 *F DoOperation<N>Args( <oper>, ... ) . . . . . . . . . . Operation Handlers
1476 **
1477 ** This section of the file provides handlers for operations. The main ones
1478 ** are DoOperation0Args ... DoOperation6Args and the DoVerboseOperation
1479 ** tracing variants. Then there are variants for constructors. In the
1480 ** following section are handlers for attributes, properties and the
1481 ** operations related to them.
1482 **
1483 ** This code has been refactored to reduce repetition. Its efficiency now
1484 ** depends on the C compiler inlining some quite large functions and then
1485 ** doing constant folding to effectively produce a specialised version of
1486 ** the main function. This is why several functions below have been
1487 ** marked with 'ALWAYS_INLINE'.
1488 */
1489
1490 // Helper function to quickly get the type of an object, avoiding
1491 // indirection in the case of external objects with a stored type I.e.,
1492 // the compiler can inline TYPE_COMOBJ etc., while it cannot inline
1493 // TYPE_OBJ
TYPE_OBJ_FEO(Obj obj)1494 static inline Obj TYPE_OBJ_FEO(Obj obj)
1495 {
1496 #ifdef HPCGAP
1497 /* TODO: We need to be able to automatically derive this. */
1498 ImpliedWriteGuard(obj);
1499 #endif
1500 switch ( TNUM_OBJ( obj ) ) {
1501 case T_COMOBJ:
1502 return TYPE_COMOBJ(obj);
1503 case T_POSOBJ:
1504 return TYPE_POSOBJ(obj);
1505 case T_DATOBJ:
1506 return TYPE_DATOBJ(obj);
1507 default:
1508 return TYPE_OBJ(obj);
1509 }
1510 }
1511
1512 /* Method Cache -- we remember recently selected methods in a cache.
1513 The effectiveness of this cache is vital for GAP's performance */
1514
1515
1516 /* The next few functions deal with finding and allocating if necessary the cache
1517 for a given operation and number of arguments, and some locking in HPC-GAP */
1518
1519
1520 #ifdef HPCGAP
1521
1522 static pthread_mutex_t CacheLock;
1523 static UInt CacheSize;
1524
LockCache(void)1525 static void LockCache(void)
1526 {
1527 if (!PreThreadCreation)
1528 pthread_mutex_lock(&CacheLock);
1529 }
1530
UnlockCache(void)1531 static void UnlockCache(void)
1532 {
1533 if (!PreThreadCreation)
1534 pthread_mutex_unlock(&CacheLock);
1535 }
1536
1537 #endif
1538
CacheOper(Obj oper,UInt i)1539 static inline Obj CacheOper(Obj oper, UInt i)
1540 {
1541 Obj cache = CACHE_OPER(oper, i);
1542 UInt len;
1543
1544 #ifdef HPCGAP
1545 UInt cacheIndex;
1546
1547 if (cache == 0) {
1548 /* This is a safe form of double-checked locking, because
1549 * the cache value is not a reference. */
1550 LockCache();
1551 cache = CACHE_OPER(oper, i);
1552 if (cache == 0) {
1553 CacheSize++;
1554 cacheIndex = CacheSize;
1555 SET_CACHE_OPER(oper, i, INTOBJ_INT(cacheIndex));
1556 }
1557 else
1558 cacheIndex = INT_INTOBJ(cache);
1559 UnlockCache();
1560 }
1561 else {
1562 cacheIndex = INT_INTOBJ(cache);
1563 }
1564
1565 if (cacheIndex > STATE(MethodCacheSize)) {
1566 len = STATE(MethodCacheSize);
1567 while (cacheIndex > len)
1568 len *= 2;
1569 GROW_PLIST(STATE(MethodCache), len);
1570 SET_LEN_PLIST(STATE(MethodCache), len);
1571 STATE(MethodCacheItems) = ADDR_OBJ(STATE(MethodCache));
1572 STATE(MethodCacheSize) = len;
1573 }
1574
1575 cache = ELM_PLIST(STATE(MethodCache), cacheIndex);
1576 #endif
1577
1578 if (cache == 0) {
1579 len = (i < 7 ? CACHE_SIZE * (i + 2) : CACHE_SIZE * (1 + 2));
1580 #ifdef HPCGAP
1581 len++; // reserve one slot for pointer to methods list
1582 #endif
1583 cache = NEW_PLIST(T_PLIST, len);
1584 SET_LEN_PLIST(cache, len);
1585 #ifdef HPCGAP
1586 SET_ELM_PLIST(STATE(MethodCache), cacheIndex, cache);
1587 CHANGED_BAG(STATE(MethodCache));
1588 #else
1589 SET_CACHE_OPER(oper, i, cache);
1590 CHANGED_BAG(oper);
1591 #endif
1592 }
1593
1594 return cache;
1595 }
1596
1597 #ifdef COUNT_OPERS
1598 static UInt CacheHitStatistics[CACHE_SIZE][CACHE_SIZE][7];
1599 static UInt CacheMissStatistics[CACHE_SIZE + 1][7];
1600 #endif
1601
1602
1603 // This function actually searches the cache. Normally it should be
1604 // called with n a compile-time constant to allow the optimiser to tidy
1605 // things up.
1606 // It is also marked with 'ALWAYS_INLINE' for this reason (see above).
GetMethodCached(Obj cacheBag,UInt n,Int prec,Obj ids[])1607 static ALWAYS_INLINE Obj GetMethodCached(Obj cacheBag,
1608 UInt n,
1609 Int prec,
1610 Obj ids[])
1611 {
1612 UInt typematch;
1613 Obj * cache;
1614 Obj method = 0;
1615 UInt i;
1616 const UInt cacheEntrySize = n + 2;
1617
1618 cache = BASE_PTR_PLIST(cacheBag);
1619 #ifdef HPCGAP
1620 cache++; // skip over the pointer to the methods list
1621 #endif
1622
1623 /* Up to CACHE_SIZE methods might be in the cache */
1624 if (prec < CACHE_SIZE) {
1625 /* This loop runs through those */
1626 UInt target =
1627 cacheEntrySize * prec; /* first place to look and also the place
1628 we'll put the result */
1629 for (i = target; i < cacheEntrySize * CACHE_SIZE;
1630 i += cacheEntrySize) {
1631 if (cache[i + 1] == INTOBJ_INT(prec)) {
1632 typematch = 1;
1633 // This loop runs over the arguments, should be compiled away
1634 for (UInt j = 0; j < n; j++) {
1635 if (cache[i + j + 2] != ids[j]) {
1636 typematch = 0;
1637 break;
1638 }
1639 }
1640 if (typematch) {
1641 method = cache[i];
1642 #ifdef COUNT_OPERS
1643 CacheHitStatistics[prec][i / cacheEntrySize][n]++;
1644 #endif
1645 if (i > target) {
1646
1647 /* We found the method, but it was further down the
1648 cache than we would like it to be, so move it up */
1649 Obj buf[cacheEntrySize];
1650 memcpy(buf, cache + i,
1651 sizeof(Obj) * cacheEntrySize);
1652 SyMemmove(cache + target + cacheEntrySize,
1653 cache + target,
1654 sizeof(Obj) * (i - target));
1655 memcpy(cache + target, buf,
1656 sizeof(Obj) * cacheEntrySize);
1657 }
1658 break;
1659 }
1660 }
1661 }
1662 }
1663 return method;
1664 }
1665
1666 /* Add a method to the cache -- called when a method is selected that is not
1667 in the cache */
1668 static inline void
CacheMethod(Obj cacheBag,UInt n,Int prec,Obj * ids,Obj method)1669 CacheMethod(Obj cacheBag, UInt n, Int prec, Obj * ids, Obj method)
1670 {
1671 if (prec >= CACHE_SIZE)
1672 return;
1673 /* We insert this method at position <prec> and move
1674 the older methods down */
1675 UInt cacheEntrySize = n + 2;
1676 Obj * cache = BASE_PTR_PLIST(cacheBag) + prec * cacheEntrySize;
1677 #ifdef HPCGAP
1678 cache++; // skip over the pointer to the methods list
1679 #endif
1680 SyMemmove(cache + cacheEntrySize, cache,
1681 sizeof(Obj) * (CACHE_SIZE - prec - 1) * cacheEntrySize);
1682 cache[0] = method;
1683 cache[1] = INTOBJ_INT(prec);
1684 for (UInt i = 0; i < n; i++)
1685 cache[2 + i] = ids[i];
1686 CHANGED_BAG(cacheBag);
1687 }
1688
1689 static Obj ReturnTrue;
1690 static Obj VMETHOD_PRINT_INFO;
1691 static Obj NEXT_VMETHOD_PRINT_INFO;
1692
1693 // This function searches through the methods of operation <oper> with
1694 // arity <n>, looking for those matching the given <types>. Among these,
1695 // the <prec>-th is selected (<prec> starts at 0).
1696 //
1697 // If <verbose> is non-zero, the matching method are printed by calling
1698 // 'VMETHOD_PRINT_INFO' resp. 'NEXT_VMETHOD_PRINT_INFO'.
1699 //
1700 // If <constructor> is non-zero, then <oper> is a constructor, leading
1701 // to <types[0]> being treated differently.
1702 //
1703 // Use of 'ALWAYS_INLINE' is critical for performance, see discussion
1704 // earlier in this file.
1705 enum {
1706 BASE_SIZE_METHODS_OPER_ENTRY = 6,
1707 };
GetMethodUncached(UInt verbose,UInt constructor,UInt n,Obj methods,Int prec,Obj types[])1708 static ALWAYS_INLINE Obj GetMethodUncached(
1709 UInt verbose, UInt constructor, UInt n, Obj methods, Int prec, Obj types[])
1710 {
1711 if (methods == 0)
1712 return Fail;
1713
1714 const UInt len = LEN_PLIST(methods);
1715 UInt matchCount = 0;
1716 for (UInt pos = 0; pos < len; pos += n + BASE_SIZE_METHODS_OPER_ENTRY) {
1717 // each method comprises n + BASE_SIZE_METHODS_OPER_ENTRY
1718 // entries in the 'methods' list:
1719 // entry 1 is the family predicate;
1720 // entries 2 till n+1 are the n argument filters
1721 // entry n+2 is the actual method
1722 // entry n+3 is the rank
1723 // entry n+4 is the info text
1724 // entry n+5 is, if set, the location where the method was installed
1725 // entry n+6 is, if set, the relative rank that was supplied when
1726 // the method was installed, either as a small integer
1727 // or a function of no arguments
1728
1729 // check argument filters against the given types
1730 Obj filter;
1731 int k = 1;
1732 if (constructor) {
1733 filter = ELM_PLIST(methods, pos + k + 1);
1734 GAP_ASSERT(TNUM_OBJ(filter) == T_FLAGS);
1735 if (!IS_SUBSET_FLAGS(filter, types[0]))
1736 continue;
1737 k++;
1738 }
1739 for (; k <= n; ++k) {
1740 filter = ELM_PLIST(methods, pos + k + 1);
1741 GAP_ASSERT(TNUM_OBJ(filter) == T_FLAGS);
1742 if (!IS_SUBSET_FLAGS(FLAGS_TYPE(types[k - 1]), filter))
1743 break;
1744 }
1745
1746 // if some filter did not match, go to next method
1747 if (k <= n)
1748 continue;
1749
1750 // check family predicate, with a hot path for the very
1751 // common trivial predicate 'ReturnTrue'
1752 Obj fampred = ELM_PLIST(methods, pos + 1);
1753 if (fampred != ReturnTrue) {
1754 Obj res = 0;
1755 switch (n) {
1756 case 0:
1757 res = CALL_0ARGS(fampred);
1758 break;
1759 case 1:
1760 res = CALL_1ARGS(fampred, FAMILY_TYPE(types[0]));
1761 break;
1762 case 2:
1763 res = CALL_2ARGS(fampred, FAMILY_TYPE(types[0]),
1764 FAMILY_TYPE(types[1]));
1765 break;
1766 case 3:
1767 res =
1768 CALL_3ARGS(fampred, FAMILY_TYPE(types[0]),
1769 FAMILY_TYPE(types[1]), FAMILY_TYPE(types[2]));
1770 break;
1771 case 4:
1772 res = CALL_4ARGS(fampred, FAMILY_TYPE(types[0]),
1773 FAMILY_TYPE(types[1]), FAMILY_TYPE(types[2]),
1774 FAMILY_TYPE(types[3]));
1775 break;
1776 case 5:
1777 res =
1778 CALL_5ARGS(fampred, FAMILY_TYPE(types[0]),
1779 FAMILY_TYPE(types[1]), FAMILY_TYPE(types[2]),
1780 FAMILY_TYPE(types[3]), FAMILY_TYPE(types[4]));
1781 break;
1782 case 6:
1783 res = CALL_6ARGS(fampred, FAMILY_TYPE(types[0]),
1784 FAMILY_TYPE(types[1]), FAMILY_TYPE(types[2]),
1785 FAMILY_TYPE(types[3]), FAMILY_TYPE(types[4]),
1786 FAMILY_TYPE(types[5]));
1787 break;
1788 default:
1789 ErrorMayQuit("not supported yet", 0, 0);
1790 }
1791
1792 if (res != True)
1793 continue;
1794 }
1795
1796 // we have a match; is it the right one?
1797 if (prec == matchCount) {
1798 if (verbose) {
1799 CALL_3ARGS(prec == 0 ? VMETHOD_PRINT_INFO : NEXT_VMETHOD_PRINT_INFO, methods,
1800 INTOBJ_INT(pos / (n + BASE_SIZE_METHODS_OPER_ENTRY) + 1),
1801 INTOBJ_INT(n));
1802
1803 }
1804 Obj meth = ELM_PLIST(methods, pos + n + 2);
1805 return meth;
1806 }
1807 matchCount++;
1808 }
1809 return Fail;
1810 }
1811
1812 #ifdef COUNT_OPERS
1813 static Int OperationHit;
1814 static Int OperationMiss;
1815 static Int OperationNext;
1816 #endif
1817
1818
1819 // Use of 'ALWAYS_INLINE' is critical for performance, see discussion
1820 // earlier in this file.
DoOperationNArgs(Obj oper,UInt n,UInt verbose,UInt constructor,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5,Obj arg6)1821 static ALWAYS_INLINE Obj DoOperationNArgs(Obj oper,
1822 UInt n,
1823 UInt verbose,
1824 UInt constructor,
1825 Obj arg1,
1826 Obj arg2,
1827 Obj arg3,
1828 Obj arg4,
1829 Obj arg5,
1830 Obj arg6)
1831 {
1832 Obj types[n];
1833 Obj ids[n];
1834 Int prec;
1835 Obj method;
1836 Obj res;
1837
1838 /* It is intentional that each case in this case statement except 0
1839 drops through */
1840 switch (n) {
1841 case 6:
1842 types[5] = TYPE_OBJ_FEO(arg6);
1843 case 5:
1844 types[4] = TYPE_OBJ_FEO(arg5);
1845 case 4:
1846 types[3] = TYPE_OBJ_FEO(arg4);
1847 case 3:
1848 types[2] = TYPE_OBJ_FEO(arg3);
1849 case 2:
1850 types[1] = TYPE_OBJ_FEO(arg2);
1851 case 1:
1852 if (constructor) {
1853 RequireFilter("Constructor", arg1, "the first argument");
1854 types[0] = FLAGS_FILT(arg1);
1855 }
1856 else
1857 types[0] = TYPE_OBJ_FEO(arg1);
1858 case 0:
1859 break;
1860 default:
1861 GAP_ASSERT(0);
1862 }
1863
1864 if (n > 0) {
1865 if (constructor)
1866 ids[0] = types[0];
1867 else
1868 ids[0] = ID_TYPE(types[0]);
1869 }
1870
1871 for (UInt i = 1; i < n; i++)
1872 ids[i] = ID_TYPE(types[i]);
1873
1874 Obj cacheBag = CacheOper(oper, n);
1875 Obj methods = METHS_OPER(oper, n);
1876
1877 #ifdef HPCGAP
1878 // reset the method cache if necessary
1879 if (ELM_PLIST(cacheBag, 1) != methods) {
1880 Obj * cache = BASE_PTR_PLIST(cacheBag);
1881 cache[0] = methods;
1882 memset(cache + 1, 0, SIZE_OBJ(cacheBag)-2*sizeof(Obj));
1883 }
1884 #endif
1885
1886 /* outer loop deals with TryNextMethod */
1887 prec = -1;
1888 do {
1889 prec++;
1890 /* Is there a method in the cache */
1891 method = verbose ? 0 : GetMethodCached(cacheBag, n, prec, ids);
1892
1893 #ifdef COUNT_OPERS
1894 if (method)
1895 OperationHit++;
1896 else {
1897 OperationMiss++;
1898 CacheMissStatistics[(prec >= CACHE_SIZE) ? CACHE_SIZE : prec]
1899 [n]++;
1900 }
1901 if (prec > 0)
1902 OperationNext++;
1903 #endif
1904
1905 /* otherwise try to find one in the list of methods */
1906 if (!method) {
1907 method = GetMethodUncached(verbose, constructor, n, methods,
1908 prec, types);
1909 /* update the cache */
1910 if (!verbose && method)
1911 CacheMethod(cacheBag, n, prec, ids, method);
1912 }
1913
1914 /* If there was no method found, then pass the information needed
1915 for the error reporting. This function rarely returns */
1916 if (method == Fail) {
1917 Obj args[n];
1918 /* It is intentional that each case in this case statement except
1919 0 drops through */
1920 switch (n) {
1921 case 6:
1922 args[5] = arg6;
1923 case 5:
1924 args[4] = arg5;
1925 case 4:
1926 args[3] = arg4;
1927 case 3:
1928 args[2] = arg3;
1929 case 2:
1930 args[1] = arg2;
1931 case 1:
1932 args[0] = arg1;
1933 case 0:
1934 break;
1935 default:
1936 GAP_ASSERT(0);
1937 }
1938 HandleMethodNotFound(oper, n, args, verbose, constructor, prec);
1939 }
1940
1941 if (!method) {
1942 ErrorQuit("no method returned", 0L, 0L);
1943 }
1944
1945 /* call this method */
1946 switch (n) {
1947 case 0:
1948 res = CALL_0ARGS(method);
1949 break;
1950 case 1:
1951 res = CALL_1ARGS(method, arg1);
1952 break;
1953 case 2:
1954 res = CALL_2ARGS(method, arg1, arg2);
1955 break;
1956 case 3:
1957 res = CALL_3ARGS(method, arg1, arg2, arg3);
1958 break;
1959 case 4:
1960 res = CALL_4ARGS(method, arg1, arg2, arg3, arg4);
1961 break;
1962 case 5:
1963 res = CALL_5ARGS(method, arg1, arg2, arg3, arg4, arg5);
1964 break;
1965 case 6:
1966 res = CALL_6ARGS(method, arg1, arg2, arg3, arg4, arg5, arg6);
1967 break;
1968 default:
1969 res = 0; // redundant, but silences a warning later on
1970 GAP_ASSERT(0);
1971 }
1972 } while (res == TRY_NEXT_METHOD);
1973
1974 /* return the result */
1975 return res;
1976 }
1977
1978
DoOperation0Args(Obj oper)1979 Obj DoOperation0Args(Obj oper)
1980 {
1981 return DoOperationNArgs(oper, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1982 }
1983
DoOperation1Args(Obj oper,Obj arg1)1984 Obj DoOperation1Args(Obj oper, Obj arg1)
1985 {
1986 return DoOperationNArgs(oper, 1, 0, 0, arg1, 0, 0, 0, 0,
1987 0);
1988 }
1989
DoOperation2Args(Obj oper,Obj arg1,Obj arg2)1990 Obj DoOperation2Args(Obj oper, Obj arg1, Obj arg2)
1991 {
1992 return DoOperationNArgs(oper, 2, 0, 0, arg1, arg2, 0, 0,
1993 0, 0);
1994 }
1995
DoOperation3Args(Obj oper,Obj arg1,Obj arg2,Obj arg3)1996 Obj DoOperation3Args(Obj oper, Obj arg1, Obj arg2, Obj arg3)
1997 {
1998 return DoOperationNArgs(oper, 3, 0, 0, arg1, arg2, arg3,
1999 0, 0, 0);
2000 }
2001
DoOperation4Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4)2002 Obj DoOperation4Args(Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4)
2003 {
2004 return DoOperationNArgs(oper, 4, 0, 0, arg1, arg2, arg3,
2005 arg4, 0, 0);
2006 }
2007
DoOperation5Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5)2008 Obj DoOperation5Args(
2009 Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5)
2010 {
2011 return DoOperationNArgs(oper, 5, 0, 0, arg1, arg2, arg3,
2012 arg4, arg5, 0);
2013 }
2014
DoOperation6Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5,Obj arg6)2015 Obj DoOperation6Args(
2016 Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5, Obj arg6)
2017 {
2018 return DoOperationNArgs(oper, 6, 0, 0, arg1, arg2, arg3,
2019 arg4, arg5, arg6);
2020 }
2021
2022
2023 /****************************************************************************
2024 **
2025 ** DoOperationXArgs( <oper>, ... )
2026 */
2027
DoOperationXArgs(Obj self,Obj args)2028 Obj DoOperationXArgs(Obj self, Obj args)
2029 {
2030 ErrorQuit("sorry: cannot yet have X argument operations", 0L, 0L);
2031 return 0;
2032 }
2033
2034
2035 /****************************************************************************
2036 **
2037 ** DoVerboseOperation0Args( <oper> )
2038 */
DoVerboseOperation0Args(Obj oper)2039 Obj DoVerboseOperation0Args(Obj oper)
2040 {
2041 return DoOperationNArgs(oper, 0, 1, 0, 0, 0, 0, 0,
2042 0, 0);
2043 }
2044
DoVerboseOperation1Args(Obj oper,Obj arg1)2045 Obj DoVerboseOperation1Args(Obj oper, Obj arg1)
2046 {
2047 return DoOperationNArgs(oper, 1, 1, 0, arg1, 0, 0,
2048 0, 0, 0);
2049 }
2050
DoVerboseOperation2Args(Obj oper,Obj arg1,Obj arg2)2051 Obj DoVerboseOperation2Args(Obj oper, Obj arg1, Obj arg2)
2052 {
2053 return DoOperationNArgs(oper, 2, 1, 0, arg1, arg2,
2054 0, 0, 0, 0);
2055 }
2056
DoVerboseOperation3Args(Obj oper,Obj arg1,Obj arg2,Obj arg3)2057 Obj DoVerboseOperation3Args(Obj oper, Obj arg1, Obj arg2, Obj arg3)
2058 {
2059 return DoOperationNArgs(oper, 3, 1, 0, arg1, arg2,
2060 arg3, 0, 0, 0);
2061 }
2062
DoVerboseOperation4Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4)2063 Obj DoVerboseOperation4Args(Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4)
2064 {
2065 return DoOperationNArgs(oper, 4, 1, 0, arg1, arg2,
2066 arg3, arg4, 0, 0);
2067 }
2068
DoVerboseOperation5Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5)2069 Obj DoVerboseOperation5Args(
2070 Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5)
2071 {
2072 return DoOperationNArgs(oper, 5, 1, 0, arg1, arg2,
2073 arg3, arg4, arg5, 0);
2074 }
2075
DoVerboseOperation6Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5,Obj arg6)2076 Obj DoVerboseOperation6Args(
2077 Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5, Obj arg6)
2078 {
2079 return DoOperationNArgs(oper, 6, 1, 0, arg1, arg2,
2080 arg3, arg4, arg5, arg6);
2081 }
2082
2083
2084 /****************************************************************************
2085 **
2086 ** DoVerboseOperationXArgs( <oper>, ... )
2087 */
DoVerboseOperationXArgs(Obj self,Obj args)2088 Obj DoVerboseOperationXArgs(Obj self, Obj args)
2089 {
2090 ErrorQuit("sorry: cannot yet have X argument operations", 0L, 0L);
2091 return 0;
2092 }
2093
2094
2095 /****************************************************************************
2096 **
2097 *F NewOperation( <name>, <narg>, <nams>, <hdlr> )
2098 */
NewOperation(Obj name,Int narg,Obj nams,ObjFunc hdlr)2099 Obj NewOperation(Obj name, Int narg, Obj nams, ObjFunc hdlr)
2100 {
2101 Obj oper;
2102
2103 /* create the function */
2104 oper = NewFunctionT(T_FUNCTION, sizeof(OperBag), name, narg, nams, hdlr);
2105
2106 /* enter the handlers */
2107 SET_HDLR_FUNC(oper, 0, DoOperation0Args);
2108 SET_HDLR_FUNC(oper, 1, DoOperation1Args);
2109 SET_HDLR_FUNC(oper, 2, DoOperation2Args);
2110 SET_HDLR_FUNC(oper, 3, DoOperation3Args);
2111 SET_HDLR_FUNC(oper, 4, DoOperation4Args);
2112 SET_HDLR_FUNC(oper, 5, DoOperation5Args);
2113 SET_HDLR_FUNC(oper, 6, DoOperation6Args);
2114 SET_HDLR_FUNC(oper, 7, DoOperationXArgs);
2115
2116 /* reenter the given handler */
2117 if (narg != -1)
2118 SET_HDLR_FUNC(oper, narg, hdlr);
2119
2120 /*N 1996/06/06 mschoene this should not be done here */
2121 SET_FLAG1_FILT(oper, INTOBJ_INT(0));
2122 SET_FLAG2_FILT(oper, INTOBJ_INT(0));
2123 SET_FLAGS_FILT(oper, False);
2124 SET_SETTR_FILT(oper, False);
2125 SET_TESTR_FILT(oper, False);
2126
2127 /* This isn't an attribute (yet) */
2128 SET_ENABLED_ATTR(oper, 0);
2129
2130 /* return operation */
2131 return oper;
2132 }
2133
2134
2135 /****************************************************************************
2136 **
2137 *F DoConstructor0Args( <oper> )
2138 *F DoConstructor1Args( <oper> )
2139 *F DoConstructor2Args( <oper> )
2140 *F DoConstructor3Args( <oper> )
2141 *F DoConstructor4Args( <oper> )
2142 *F DoConstructor5Args( <oper> )
2143 *F DoConstructor6Args( <oper> )
2144 *F DoConstructorXArgs( <oper> )
2145 */
2146
DoConstructor0Args(Obj oper)2147 static Obj DoConstructor0Args(Obj oper)
2148 {
2149 ErrorQuit("constructors must have at least one argument", 0L, 0L);
2150 return 0;
2151 }
2152
DoConstructor1Args(Obj oper,Obj arg1)2153 static Obj DoConstructor1Args(Obj oper, Obj arg1)
2154 {
2155 return DoOperationNArgs(oper, 1, 0, 1, arg1, 0, 0,
2156 0, 0, 0);
2157 }
2158
DoConstructor2Args(Obj oper,Obj arg1,Obj arg2)2159 static Obj DoConstructor2Args(Obj oper, Obj arg1, Obj arg2)
2160 {
2161 return DoOperationNArgs(oper, 2, 0, 1, arg1, arg2,
2162 0, 0, 0, 0);
2163 }
2164
DoConstructor3Args(Obj oper,Obj arg1,Obj arg2,Obj arg3)2165 static Obj DoConstructor3Args(Obj oper, Obj arg1, Obj arg2, Obj arg3)
2166 {
2167 return DoOperationNArgs(oper, 3, 0, 1, arg1, arg2,
2168 arg3, 0, 0, 0);
2169 }
2170
2171 static Obj
DoConstructor4Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4)2172 DoConstructor4Args(Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4)
2173 {
2174 return DoOperationNArgs(oper, 4, 0, 1, arg1, arg2,
2175 arg3, arg4, 0, 0);
2176 }
2177
2178 static Obj
DoConstructor5Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5)2179 DoConstructor5Args(Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5)
2180 {
2181 return DoOperationNArgs(oper, 5, 0, 1, arg1, arg2,
2182 arg3, arg4, arg5, 0);
2183 }
2184
DoConstructor6Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5,Obj arg6)2185 static Obj DoConstructor6Args(
2186 Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5, Obj arg6)
2187 {
2188 return DoOperationNArgs(oper, 6, 0, 1, arg1, arg2,
2189 arg3, arg4, arg5, arg6);
2190 }
2191
DoConstructorXArgs(Obj self,Obj args)2192 static Obj DoConstructorXArgs(Obj self, Obj args)
2193 {
2194 ErrorQuit("sorry: cannot yet have X argument constructors", 0L, 0L);
2195 return 0;
2196 }
2197
2198
2199 /****************************************************************************
2200 **
2201 *F DoVerboseConstructor0Args( <oper> )
2202 *F DoVerboseConstructor1Args( <oper> )
2203 *F DoVerboseConstructor2Args( <oper> )
2204 *F DoVerboseConstructor3Args( <oper> )
2205 *F DoVerboseConstructor4Args( <oper> )
2206 *F DoVerboseConstructor5Args( <oper> )
2207 *F DoVerboseConstructor6Args( <oper> )
2208 *F DoVerboseConstructorXArgs( <oper> )
2209 */
2210
DoVerboseConstructor0Args(Obj oper)2211 static Obj DoVerboseConstructor0Args(Obj oper)
2212 {
2213 ErrorQuit("constructors must have at least one argument", 0L, 0L);
2214 return 0;
2215 }
2216
DoVerboseConstructor1Args(Obj oper,Obj arg1)2217 static Obj DoVerboseConstructor1Args(Obj oper, Obj arg1)
2218 {
2219 return DoOperationNArgs(oper, 1, 1, 1, arg1,
2220 0, 0, 0, 0, 0);
2221 }
2222
DoVerboseConstructor2Args(Obj oper,Obj arg1,Obj arg2)2223 static Obj DoVerboseConstructor2Args(Obj oper, Obj arg1, Obj arg2)
2224 {
2225 return DoOperationNArgs(oper, 2, 1, 1, arg1,
2226 arg2, 0, 0, 0, 0);
2227 }
2228
DoVerboseConstructor3Args(Obj oper,Obj arg1,Obj arg2,Obj arg3)2229 static Obj DoVerboseConstructor3Args(Obj oper, Obj arg1, Obj arg2, Obj arg3)
2230 {
2231 return DoOperationNArgs(oper, 3, 1, 1, arg1,
2232 arg2, arg3, 0, 0, 0);
2233 }
2234
2235 static Obj
DoVerboseConstructor4Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4)2236 DoVerboseConstructor4Args(Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4)
2237 {
2238 return DoOperationNArgs(oper, 4, 1, 1, arg1,
2239 arg2, arg3, arg4, 0, 0);
2240 }
2241
DoVerboseConstructor5Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5)2242 static Obj DoVerboseConstructor5Args(
2243 Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5)
2244 {
2245 return DoOperationNArgs(oper, 5, 1, 1, arg1,
2246 arg2, arg3, arg4, arg5, 0);
2247 }
2248
DoVerboseConstructor6Args(Obj oper,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5,Obj arg6)2249 static Obj DoVerboseConstructor6Args(
2250 Obj oper, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5, Obj arg6)
2251 {
2252 return DoOperationNArgs(oper, 6, 1, 1, arg1,
2253 arg2, arg3, arg4, arg5, arg6);
2254 }
2255
DoVerboseConstructorXArgs(Obj self,Obj args)2256 static Obj DoVerboseConstructorXArgs(Obj self, Obj args)
2257 {
2258 ErrorQuit("sorry: cannot yet have X argument constructors", 0L, 0L);
2259 return 0;
2260 }
2261
2262
2263 /****************************************************************************
2264 **
2265 *F NewConstructor( <name>> )
2266 */
NewConstructor(Obj name)2267 static Obj NewConstructor(Obj name)
2268 {
2269 Obj oper;
2270
2271 /* create the function */
2272 oper = NewFunctionT( T_FUNCTION, sizeof(OperBag), name, -1, 0, 0 );
2273
2274 /* enter the handlers */
2275 SET_HDLR_FUNC(oper, 0, DoConstructor0Args);
2276 SET_HDLR_FUNC(oper, 1, DoConstructor1Args);
2277 SET_HDLR_FUNC(oper, 2, DoConstructor2Args);
2278 SET_HDLR_FUNC(oper, 3, DoConstructor3Args);
2279 SET_HDLR_FUNC(oper, 4, DoConstructor4Args);
2280 SET_HDLR_FUNC(oper, 5, DoConstructor5Args);
2281 SET_HDLR_FUNC(oper, 6, DoConstructor6Args);
2282 SET_HDLR_FUNC(oper, 7, DoConstructorXArgs);
2283
2284 /*N 1996/06/06 mschoene this should not be done here */
2285 SET_FLAG1_FILT(oper, INTOBJ_INT(0));
2286 SET_FLAG2_FILT(oper, INTOBJ_INT(0));
2287 SET_FLAGS_FILT(oper, False);
2288 SET_SETTR_FILT(oper, False);
2289 SET_TESTR_FILT(oper, False);
2290
2291 /* return constructor */
2292 return oper;
2293 }
2294
2295
2296 /****************************************************************************
2297 **
2298 ** DoTestAttribute( <attr>, <obj> )
2299 */
DoTestAttribute(Obj self,Obj obj)2300 Obj DoTestAttribute (
2301 Obj self,
2302 Obj obj )
2303 {
2304 Int flag2;
2305 Obj type;
2306 Obj flags;
2307
2308 /* get the flag for the tester */
2309 flag2 = INT_INTOBJ( FLAG2_FILT( self ) );
2310
2311 /* get type of the object and its flags */
2312 type = TYPE_OBJ_FEO( obj );
2313 flags = FLAGS_TYPE( type );
2314
2315 /* return whether the value of the attribute is already known */
2316 return SAFE_ELM_FLAGS( flags, flag2 );
2317 }
2318
2319
2320 /****************************************************************************
2321 **
2322 ** DoAttribute( <attr>, <obj> )
2323 */
2324 #define DoSetAttribute DoOperation2Args
2325
DoAttribute(Obj self,Obj obj)2326 Obj DoAttribute (
2327 Obj self,
2328 Obj obj )
2329 {
2330 Obj val;
2331 Int flag2;
2332 Obj type;
2333 Obj flags;
2334
2335 /* get the flag for the tester */
2336 flag2 = INT_INTOBJ( FLAG2_FILT( self ) );
2337
2338 /* get type of the object and its flags */
2339 type = TYPE_OBJ_FEO( obj );
2340 flags = FLAGS_TYPE( type );
2341
2342 /* if the value of the attribute is already known, simply return it */
2343 if ( SAFE_C_ELM_FLAGS( flags, flag2 ) ) {
2344 return DoOperation1Args( self, obj );
2345 }
2346
2347 /* call the operation to compute the value */
2348 val = DoOperation1Args( self, obj );
2349 if (val == 0) {
2350 ErrorMayQuit("Method for an attribute must return a value", 0, 0);
2351 }
2352 val = CopyObj( val, 0 );
2353
2354 /* set the value (but not for internal objects) */
2355 if ( ENABLED_ATTR( self ) == 1 && !IS_MUTABLE_OBJ( obj ) ) {
2356 switch ( TNUM_OBJ( obj ) ) {
2357 case T_COMOBJ:
2358 case T_POSOBJ:
2359 case T_DATOBJ:
2360 #ifdef HPCGAP
2361 case T_ACOMOBJ:
2362 case T_APOSOBJ:
2363 #endif
2364 DoSetAttribute( SETTR_FILT(self), obj, val );
2365 }
2366 }
2367
2368 /* return the value */
2369 return val;
2370 }
2371
2372
2373 /****************************************************************************
2374 **
2375 ** DoVerboseAttribute( <attr>, <obj> )
2376 */
2377 #define DoVerboseSetAttribute DoVerboseOperation2Args
2378
DoVerboseAttribute(Obj self,Obj obj)2379 static Obj DoVerboseAttribute(Obj self, Obj obj)
2380 {
2381 Obj val;
2382 Int flag2;
2383 Obj type;
2384 Obj flags;
2385
2386 /* get the flag for the tester */
2387 flag2 = INT_INTOBJ( FLAG2_FILT( self ) );
2388
2389 /* get type of the object and its flags */
2390 type = TYPE_OBJ_FEO( obj );
2391 flags = FLAGS_TYPE( type );
2392
2393 /* if the value of the attribute is already known, simply return it */
2394 if ( SAFE_C_ELM_FLAGS( flags, flag2 ) ) {
2395 return DoVerboseOperation1Args( self, obj );
2396 }
2397
2398 /* call the operation to compute the value */
2399 val = DoVerboseOperation1Args( self, obj );
2400 if (val == (Obj)0) {
2401 ErrorMayQuit("Method for an attribute must return a value", 0, 0);
2402 }
2403 val = CopyObj( val, 0 );
2404
2405 /* set the value (but not for internal objects) */
2406 if ( ENABLED_ATTR( self ) == 1 && !IS_MUTABLE_OBJ( obj ) ) {
2407 switch ( TNUM_OBJ( obj ) ) {
2408 case T_COMOBJ:
2409 case T_POSOBJ:
2410 case T_DATOBJ:
2411 #ifdef HPCGAP
2412 case T_ACOMOBJ:
2413 case T_APOSOBJ:
2414 #endif
2415 DoVerboseSetAttribute( SETTR_FILT(self), obj, val );
2416 }
2417 }
2418
2419 /* return the value */
2420 return val;
2421 }
2422
2423
2424 /****************************************************************************
2425 **
2426 ** DoMutableAttribute( <attr>, <obj> )
2427 */
DoMutableAttribute(Obj self,Obj obj)2428 static Obj DoMutableAttribute(Obj self, Obj obj)
2429 {
2430 Obj val;
2431 Int flag2;
2432 Obj type;
2433 Obj flags;
2434
2435 /* get the flag for the tester */
2436 flag2 = INT_INTOBJ( FLAG2_FILT( self ) );
2437
2438 /* get type of the object and its flags */
2439 type = TYPE_OBJ_FEO( obj );
2440 flags = FLAGS_TYPE( type );
2441
2442 /* if the value of the attribute is already known, simply return it */
2443 if ( SAFE_C_ELM_FLAGS( flags, flag2 ) ) {
2444 return DoOperation1Args( self, obj );
2445 }
2446
2447 /* call the operation to compute the value */
2448 val = DoOperation1Args( self, obj );
2449
2450 /* set the value (but not for internal objects) */
2451 if ( ENABLED_ATTR( self ) == 1 && !IS_MUTABLE_OBJ( obj ) ) {
2452 switch ( TNUM_OBJ( obj ) ) {
2453 case T_COMOBJ:
2454 case T_POSOBJ:
2455 case T_DATOBJ:
2456 #ifdef HPCGAP
2457 case T_ACOMOBJ:
2458 case T_APOSOBJ:
2459 #endif
2460 DoSetAttribute( SETTR_FILT(self), obj, val );
2461 }
2462 }
2463
2464 /* return the value */
2465 return val;
2466 }
2467
2468
2469 /****************************************************************************
2470 **
2471 ** DoVerboseMutableAttribute( <attr>, <obj> )
2472 */
DoVerboseMutableAttribute(Obj self,Obj obj)2473 static Obj DoVerboseMutableAttribute(Obj self, Obj obj)
2474 {
2475 Obj val;
2476 Int flag2;
2477 Obj type;
2478 Obj flags;
2479
2480 /* get the flag for the tester */
2481 flag2 = INT_INTOBJ( FLAG2_FILT( self ) );
2482
2483 /* get type of the object and its flags */
2484 type = TYPE_OBJ_FEO( obj );
2485 flags = FLAGS_TYPE( type );
2486
2487 /* if the value of the attribute is already known, simply return it */
2488 if ( SAFE_C_ELM_FLAGS( flags, flag2 ) ) {
2489 return DoVerboseOperation1Args( self, obj );
2490 }
2491
2492 /* call the operation to compute the value */
2493 val = DoVerboseOperation1Args( self, obj );
2494
2495 /* set the value (but not for internal objects) */
2496 if ( ENABLED_ATTR( self ) == 1 && !IS_MUTABLE_OBJ( obj ) ) {
2497 switch ( TNUM_OBJ( obj ) ) {
2498 case T_COMOBJ:
2499 case T_POSOBJ:
2500 case T_DATOBJ:
2501 #ifdef HPCGAP
2502 case T_ACOMOBJ:
2503 case T_APOSOBJ:
2504 #endif
2505 DoVerboseSetAttribute( SETTR_FILT(self), obj, val );
2506 }
2507 }
2508
2509 /* return the value */
2510 return val;
2511 }
2512
2513
2514 /****************************************************************************
2515 **
2516 *F NewAttribute( <name>, <nams>, <hdlr> )
2517 **
2518 ** MakeSetter, MakeTester and SetupAttribute are support functions
2519 */
2520
2521 #if !defined(HPCGAP)
2522 #define ImpliedWriteGuard(x)
2523 #endif
2524
WRAP_NAME(Obj name,const char * addon)2525 static Obj WRAP_NAME(Obj name, const char *addon)
2526 {
2527 UInt name_len = GET_LEN_STRING(name);
2528 UInt addon_len = strlen(addon);
2529 Obj fname = NEW_STRING( name_len + addon_len + 2 );
2530 ImpliedWriteGuard(fname);
2531
2532 char *ptr = CSTR_STRING(fname);
2533 memcpy( ptr, addon, addon_len );
2534 ptr += addon_len;
2535 *ptr++ = '(';
2536 memcpy( ptr, CONST_CSTR_STRING(name), name_len );
2537 ptr += name_len;
2538 *ptr++ = ')';
2539 *ptr = 0;
2540 MakeImmutable(fname);
2541 return fname;
2542 }
2543
PREFIX_NAME(Obj name,const char * prefix)2544 static Obj PREFIX_NAME(Obj name, const char *prefix)
2545 {
2546 UInt name_len = GET_LEN_STRING(name);
2547 UInt prefix_len = strlen(prefix);
2548 Obj fname = NEW_STRING( name_len + prefix_len );
2549 ImpliedWriteGuard(fname);
2550
2551 char *ptr = CSTR_STRING(fname);
2552 memcpy( ptr, prefix, prefix_len );
2553 ptr += prefix_len;
2554 memcpy( ptr, CONST_CSTR_STRING(name), name_len );
2555 ptr += name_len;
2556 *ptr = 0;
2557 MakeImmutable(fname);
2558 return fname;
2559 }
2560
MakeSetter(Obj name,Int flag1,Int flag2,Obj (* setFunc)(Obj,Obj,Obj))2561 static Obj MakeSetter(Obj name, Int flag1, Int flag2, Obj (*setFunc)(Obj, Obj, Obj))
2562 {
2563 Obj fname;
2564 Obj setter;
2565 fname = PREFIX_NAME(name, "Set");
2566 setter = NewOperation( fname, 2L, 0L, setFunc );
2567 SET_FLAG1_FILT(setter, INTOBJ_INT(flag1));
2568 SET_FLAG2_FILT(setter, INTOBJ_INT(flag2));
2569 CHANGED_BAG(setter);
2570 return setter;
2571 }
2572
MakeTester(Obj name,Int flag1,Int flag2)2573 static Obj MakeTester( Obj name, Int flag1, Int flag2)
2574 {
2575 Obj fname;
2576 Obj tester;
2577 Obj flags;
2578 fname = PREFIX_NAME(name, "Has");
2579 tester = NewFunctionT( T_FUNCTION, sizeof(OperBag), fname, 1L, 0L,
2580 DoTestAttribute );
2581 SET_FLAG1_FILT(tester, INTOBJ_INT(flag1));
2582 SET_FLAG2_FILT(tester, INTOBJ_INT(flag2));
2583 flags = NEW_FLAGS( flag2 );
2584 SET_ELM_FLAGS( flags, flag2 );
2585 SET_FLAGS_FILT(tester, flags);
2586 SET_SETTR_FILT(tester, 0);
2587 SET_TESTR_FILT(tester, ReturnTrueFilter);
2588 SET_IS_FILTER(tester);
2589 CHANGED_BAG(tester);
2590 return tester;
2591 }
2592
2593
SetupAttribute(Obj attr,Obj setter,Obj tester,Int flag2)2594 static void SetupAttribute(Obj attr, Obj setter, Obj tester, Int flag2)
2595 {
2596 // Install additional data
2597 SET_FLAG1_FILT(attr, INTOBJ_INT(0));
2598 SET_FLAG2_FILT(attr, INTOBJ_INT(flag2));
2599
2600 // reuse flags from tester
2601 SET_FLAGS_FILT(attr, FLAGS_FILT(tester));
2602
2603 SET_SETTR_FILT(attr, setter);
2604 SET_TESTR_FILT(attr, tester);
2605 SET_ENABLED_ATTR(attr,1);
2606 CHANGED_BAG(attr);
2607 }
2608
2609
NewAttribute(Obj name,Obj nams,ObjFunc hdlr)2610 Obj NewAttribute (
2611 Obj name,
2612 Obj nams,
2613 ObjFunc hdlr )
2614 {
2615 Obj getter;
2616 Obj setter;
2617 Obj tester;
2618 Int flag2;
2619
2620 flag2 = ++CountFlags;
2621
2622 setter = MakeSetter(name, 0, flag2, DoSetAttribute);
2623 tester = MakeTester(name, 0, flag2);
2624
2625 GAP_ASSERT(hdlr);
2626 getter = NewOperation(name, 1, nams, hdlr);
2627
2628 SetupAttribute(getter, setter, tester, flag2);
2629
2630 return getter;
2631 }
2632
2633
2634 /****************************************************************************
2635 **
2636 *F ConvertOperationIntoAttribute( <oper> ) transform an operation (which
2637 ** should not have any one-argument declarations) into an attribute
2638 */
2639
ConvertOperationIntoAttribute(Obj oper,ObjFunc hdlr)2640 static void ConvertOperationIntoAttribute(Obj oper, ObjFunc hdlr)
2641 {
2642 Obj setter;
2643 Obj tester;
2644 Int flag2;
2645 Obj name;
2646
2647 /* Need to get the name from oper */
2648 name = NAME_FUNC(oper);
2649
2650 flag2 = ++CountFlags;
2651
2652 setter = MakeSetter(name, 0, flag2, DoSetAttribute);
2653 tester = MakeTester(name, 0, flag2);
2654
2655 /* Change the handlers */
2656 GAP_ASSERT(hdlr);
2657 SET_HDLR_FUNC(oper, 1, hdlr);
2658
2659 SetupAttribute( oper, setter, tester, flag2);
2660 }
2661
2662
2663 /****************************************************************************
2664 **
2665 *F DoProperty( <name> ) . . . . . . . . . . . . . . . . make a new property
2666 */
2667 Obj SET_FILTER_OBJ;
2668
2669 Obj RESET_FILTER_OBJ;
2670
2671
2672 /****************************************************************************
2673 **
2674 ** DoSetProperty( <prop>, <obj>, <val> )
2675 */
DoSetProperty(Obj self,Obj obj,Obj val)2676 static Obj DoSetProperty(Obj self, Obj obj, Obj val)
2677 {
2678 Int flag1;
2679 Int flag2;
2680 Obj type;
2681 Obj flags;
2682
2683 /* get the flags for the getter and the tester */
2684 flag1 = INT_INTOBJ( FLAG1_FILT( self ) );
2685 flag2 = INT_INTOBJ( FLAG2_FILT( self ) );
2686
2687 /* get type of the object and its flags */
2688 type = TYPE_OBJ_FEO( obj );
2689 flags = FLAGS_TYPE( type );
2690
2691 /* if the value of the property is already known, compare it */
2692 if ( SAFE_C_ELM_FLAGS( flags, flag2 ) ) {
2693 if ( val == ELM_FLAGS( flags, flag1 ) ) {
2694 return 0;
2695 }
2696 else {
2697 ErrorMayQuit("property is already set the other way", 0, 0);
2698 }
2699 }
2700
2701 /* set the value */
2702 /*N 1996/06/28 mschoene <self> is the <setter> here, not the <getter>! */
2703 /*N 1996/06/28 mschoene see hack below */
2704 switch ( TNUM_OBJ( obj ) ) {
2705 case T_COMOBJ:
2706 case T_POSOBJ:
2707 case T_DATOBJ:
2708 #ifdef HPCGAP
2709 case T_ACOMOBJ:
2710 case T_APOSOBJ:
2711 #endif
2712 flags = (val == True ? self : TESTR_FILT(self));
2713 CALL_2ARGS( SET_FILTER_OBJ, obj, flags );
2714 return 0;
2715 }
2716
2717 if ( IS_PLIST(obj) || IS_RANGE(obj) || IS_STRING_REP(obj)
2718 || IS_BLIST_REP(obj) ) {
2719 if ( val == True ) {
2720 SET_FILTER_LIST( obj, self );
2721 }
2722 }
2723 else {
2724 ErrorMayQuit("property cannot be set for internal objects", 0, 0);
2725 }
2726
2727 return 0;
2728 }
2729
2730
2731 /****************************************************************************
2732 **
2733 ** DoProperty( <prop>, <obj> )
2734 */
DoProperty(Obj self,Obj obj)2735 Obj DoProperty (
2736 Obj self,
2737 Obj obj )
2738 {
2739 Obj val;
2740 Int flag1;
2741 Int flag2;
2742 Obj type;
2743 Obj flags;
2744
2745 /* get the flags for the getter and the tester */
2746 flag1 = INT_INTOBJ( FLAG1_FILT( self ) );
2747 flag2 = INT_INTOBJ( FLAG2_FILT( self ) );
2748
2749 /* get type of the object and its flags */
2750 type = TYPE_OBJ_FEO( obj );
2751 flags = FLAGS_TYPE( type );
2752
2753 /* if the value of the property is already known, simply return it */
2754 if ( SAFE_C_ELM_FLAGS( flags, flag2 ) ) {
2755 return ELM_FLAGS( flags, flag1 );
2756 }
2757
2758 /* call the operation to compute the value */
2759 val = DoOperation1Args( self, obj );
2760 if (val != True && val != False) {
2761 ErrorMayQuit("Method for a property did not return true or false", 0,
2762 0);
2763 }
2764
2765 /* set the value (but not for internal objects) */
2766 if ( ENABLED_ATTR(self) == 1 && ! IS_MUTABLE_OBJ(obj) ) {
2767 switch ( TNUM_OBJ( obj ) ) {
2768 case T_COMOBJ:
2769 case T_POSOBJ:
2770 case T_DATOBJ:
2771 #ifdef HPCGAP
2772 case T_ACOMOBJ:
2773 case T_APOSOBJ:
2774 #endif
2775 flags = (val == True ? self : TESTR_FILT(self));
2776 CALL_2ARGS( SET_FILTER_OBJ, obj, flags );
2777 }
2778 }
2779
2780 /* return the value */
2781 return val;
2782 }
2783
2784
2785 /****************************************************************************
2786 **
2787 ** DoVerboseProperty( <prop>, <obj> )
2788 */
DoVerboseProperty(Obj self,Obj obj)2789 static Obj DoVerboseProperty(Obj self, Obj obj)
2790 {
2791 Obj val;
2792 Int flag1;
2793 Int flag2;
2794 Obj type;
2795 Obj flags;
2796
2797 /* get the flags for the getter and the tester */
2798 flag1 = INT_INTOBJ( FLAG1_FILT( self ) );
2799 flag2 = INT_INTOBJ( FLAG2_FILT( self ) );
2800
2801 /* get type of the object and its flags */
2802 type = TYPE_OBJ_FEO( obj );
2803 flags = FLAGS_TYPE( type );
2804
2805 /* if the value of the property is already known, simply return it */
2806 if ( SAFE_C_ELM_FLAGS( flags, flag2 ) ) {
2807 return ELM_FLAGS( flags, flag1 );
2808 }
2809
2810 /* call the operation to compute the value */
2811 val = DoVerboseOperation1Args( self, obj );
2812 if (val != True && val != False) {
2813 ErrorMayQuit("Method for a property did not return true or false", 0,
2814 0);
2815 }
2816
2817 /* set the value (but not for internal objects) */
2818 if ( ENABLED_ATTR(self) == 1 && ! IS_MUTABLE_OBJ(obj) ) {
2819 switch ( TNUM_OBJ( obj ) ) {
2820 case T_COMOBJ:
2821 case T_POSOBJ:
2822 case T_DATOBJ:
2823 #ifdef HPCGAP
2824 case T_ACOMOBJ:
2825 case T_APOSOBJ:
2826 #endif
2827 flags = (val == True ? self : TESTR_FILT(self));
2828 CALL_2ARGS( SET_FILTER_OBJ, obj, flags );
2829 }
2830 }
2831
2832 /* return the value */
2833 return val;
2834 }
2835
2836
2837 /****************************************************************************
2838 **
2839 *F NewProperty( <name>, <nams>, <hdlr> )
2840 */
NewProperty(Obj name,Obj nams,ObjFunc hdlr)2841 Obj NewProperty (
2842 Obj name,
2843 Obj nams,
2844 ObjFunc hdlr )
2845 {
2846 Obj getter;
2847 Obj setter;
2848 Obj tester;
2849 Int flag1;
2850 Int flag2;
2851 Obj flags;
2852
2853 flag1 = ++CountFlags;
2854 flag2 = ++CountFlags;
2855
2856 setter = MakeSetter(name, flag1, flag2, DoSetProperty);
2857 tester = MakeTester(name, flag1, flag2);
2858
2859 GAP_ASSERT(hdlr);
2860 getter = NewOperation(name, 1, nams, hdlr);
2861
2862 SET_FLAG1_FILT(getter, INTOBJ_INT(flag1));
2863 SET_FLAG2_FILT(getter, INTOBJ_INT(flag2));
2864 flags = NEW_FLAGS( flag2 );
2865 SET_ELM_FLAGS( flags, flag2 );
2866 SET_ELM_FLAGS( flags, flag1 );
2867 SET_FLAGS_FILT(getter, flags);
2868 SET_SETTR_FILT(getter, setter);
2869 SET_TESTR_FILT(getter, tester);
2870 SET_ENABLED_ATTR(getter, 1);
2871 SET_IS_FILTER(getter);
2872 CHANGED_BAG(getter);
2873
2874 /*N 1996/06/28 mschoene bad hack see comment in <setter> */
2875 SET_FLAGS_FILT(setter, flags);
2876 SET_SETTR_FILT(setter, setter);
2877 SET_TESTR_FILT(setter, tester);
2878
2879 /* return the getter */
2880 return getter;
2881 }
2882
2883
2884 /****************************************************************************
2885 **
2886 *F DoGlobalFunction( <name> ) . . . . . . . . . . make a new global function
2887 */
2888
2889
2890 /****************************************************************************
2891 **
2892 ** DoUninstalledGlobalFunction( <oper>, <args> )
2893 */
DoUninstalledGlobalFunction(Obj oper,Obj args)2894 static Obj DoUninstalledGlobalFunction(Obj oper, Obj args)
2895 {
2896 ErrorQuit( "%g: function is not yet defined",
2897 (Int)NAME_FUNC(oper), 0L );
2898 return 0;
2899 }
2900
2901
2902 /****************************************************************************
2903 **
2904 *F NewGlobalFunction( <name>, <nams> )
2905 */
NewGlobalFunction(Obj name,Obj nams)2906 static Obj NewGlobalFunction(Obj name, Obj nams)
2907 {
2908 Obj func;
2909 Obj namobj;
2910
2911 /* create the function */
2912 func = NewFunction( name, -1, nams, DoUninstalledGlobalFunction );
2913 SET_HDLR_FUNC(func, 0, DoUninstalledGlobalFunction);
2914 SET_HDLR_FUNC(func, 1, DoUninstalledGlobalFunction);
2915 SET_HDLR_FUNC(func, 2, DoUninstalledGlobalFunction);
2916 SET_HDLR_FUNC(func, 3, DoUninstalledGlobalFunction);
2917 SET_HDLR_FUNC(func, 4, DoUninstalledGlobalFunction);
2918 SET_HDLR_FUNC(func, 5, DoUninstalledGlobalFunction);
2919 SET_HDLR_FUNC(func, 6, DoUninstalledGlobalFunction);
2920 SET_HDLR_FUNC(func, 7, DoUninstalledGlobalFunction);
2921
2922 /* added the name */
2923 namobj = CopyObj( name, 0 );
2924 SET_NAME_FUNC(func, namobj);
2925 CHANGED_BAG(func);
2926
2927 /* and return */
2928 return func;
2929 }
2930
2931
2932 /****************************************************************************
2933 **
2934 *F InstallGlobalFunction( <oper>, <func> ) . . . . . . . . . clone function
2935 */
InstallGlobalFunction(Obj oper,Obj func)2936 static void InstallGlobalFunction(Obj oper, Obj func)
2937 {
2938 // get the name
2939 Obj name = NAME_FUNC(oper);
2940
2941 // clone the function
2942 ResizeBag(oper, SIZE_OBJ(func));
2943 memcpy(ADDR_OBJ(oper), CONST_ADDR_OBJ(func), SIZE_OBJ(func));
2944
2945 SET_NAME_FUNC(oper, name ? ImmutableString(name) : 0);
2946 CHANGED_BAG(oper);
2947 }
2948
2949
2950 /****************************************************************************
2951 **
2952 *F SaveOperationExtras( <oper> ) . . . additional saving for functions which
2953 **
2954 ** This is called by SaveFunction when the function bag is too large to be
2955 ** a simple function, and so must be an operation
2956 **
2957 */
SaveOperationExtras(Obj oper)2958 void SaveOperationExtras (
2959 Obj oper )
2960 {
2961 const OperBag * header = CONST_OPER(oper);
2962
2963 SaveSubObj(header->flag1);
2964 SaveSubObj(header->flag2);
2965 SaveSubObj(header->flags);
2966 SaveSubObj(header->setter);
2967 SaveSubObj(header->tester);
2968 SaveSubObj(header->extra);
2969 for (UInt i = 0; i <= MAX_OPER_ARGS; i++)
2970 SaveSubObj(header->methods[i]);
2971 #ifdef HPCGAP
2972 // FIXME: We probably don't want to save/restore the cache?
2973 // (and that would include "normal" GAP, too...)
2974 #else
2975 for (UInt i = 0; i <= MAX_OPER_ARGS; i++)
2976 SaveSubObj(header->cache[i]);
2977 #endif
2978 }
2979
2980
2981 /****************************************************************************
2982 **
2983 *F LoadOperationExtras( <oper> ) . . additional loading for functions which
2984 ** are operations
2985 ** This is called by LoadFunction when the function bag is too large to be
2986 ** a simple function, and so must be an operation
2987 **
2988 */
LoadOperationExtras(Obj oper)2989 void LoadOperationExtras (
2990 Obj oper )
2991 {
2992 OperBag * header = OPER(oper);
2993
2994 header->flag1 = LoadSubObj();
2995 header->flag2 = LoadSubObj();
2996 header->flags = LoadSubObj();
2997 header->setter = LoadSubObj();
2998 header->tester = LoadSubObj();
2999 header->extra = LoadSubObj();
3000 for (UInt i = 0; i <= MAX_OPER_ARGS; i++)
3001 header->methods[i] = LoadSubObj();
3002 #ifdef HPCGAP
3003 // FIXME: We probably don't want to save/restore the cache?
3004 // (and that would include "normal" GAP, too...)
3005 #else
3006 for (UInt i = 0; i <= MAX_OPER_ARGS; i++)
3007 header->cache[i] = LoadSubObj();
3008 #endif
3009 }
3010
3011
3012 /****************************************************************************
3013 **
3014 **
3015 *F * * * * * * * * * * * * GAP operation functions * * * * * * * * * * * * *
3016 */
3017
3018
3019 /****************************************************************************
3020 **
3021 *F FuncNEW_OPERATION( <self>, <name> ) . . . . . . . . . . . . new operation
3022 */
FuncNEW_OPERATION(Obj self,Obj name)3023 static Obj FuncNEW_OPERATION(Obj self, Obj name)
3024 {
3025 RequireStringRep("NewOperation", name);
3026 return NewOperation(name, -1, 0, DoOperationXArgs);
3027 }
3028
3029
3030 /****************************************************************************
3031 **
3032 *F FuncNEW_CONSTRUCTOR( <self>, <name> ) . . . . . . . . . . new constructor
3033 */
FuncNEW_CONSTRUCTOR(Obj self,Obj name)3034 static Obj FuncNEW_CONSTRUCTOR(Obj self, Obj name)
3035 {
3036 RequireStringRep("NewConstructor", name);
3037 return NewConstructor( name );
3038 }
3039
FuncIS_CONSTRUCTOR(Obj self,Obj x)3040 static Obj FuncIS_CONSTRUCTOR(Obj self, Obj x)
3041 {
3042 return (IS_FUNC(x) && HDLR_FUNC(x, 1) == DoConstructor1Args) ? True : False;
3043 }
3044
3045 /****************************************************************************
3046 **
3047 *F FuncNEW_ATTRIBUTE( <self>, <name> ) . . . . . . . . . . . . new attribute
3048 */
FuncNEW_ATTRIBUTE(Obj self,Obj name)3049 static Obj FuncNEW_ATTRIBUTE(Obj self, Obj name)
3050 {
3051 RequireStringRep("NewAttribute", name);
3052 return NewAttribute(name, 0, DoAttribute);
3053 }
3054 /****************************************************************************
3055 **
3056 *F FuncOPER_TO_ATTRIBUTE( <self>, oper ) make existing operation into attribute
3057 */
FuncOPER_TO_ATTRIBUTE(Obj self,Obj oper)3058 static Obj FuncOPER_TO_ATTRIBUTE(Obj self, Obj oper)
3059 {
3060 RequireOperation(oper);
3061 ConvertOperationIntoAttribute(oper, DoAttribute);
3062 return 0;
3063 }
3064
3065 /****************************************************************************
3066 **
3067 *F FuncOPER_TO_MUTABLE_ATTRIBUTE( <self>, oper ) make existing operation into attribute
3068 */
FuncOPER_TO_MUTABLE_ATTRIBUTE(Obj self,Obj oper)3069 static Obj FuncOPER_TO_MUTABLE_ATTRIBUTE(Obj self, Obj oper)
3070 {
3071 RequireOperation(oper);
3072 ConvertOperationIntoAttribute(oper, DoMutableAttribute);
3073 return 0;
3074 }
3075
3076
3077 /****************************************************************************
3078 **
3079 *F FuncNEW_MUTABLE_ATTRIBUTE( <self>, <name> ) . . . . new mutable attribute
3080 */
FuncNEW_MUTABLE_ATTRIBUTE(Obj self,Obj name)3081 static Obj FuncNEW_MUTABLE_ATTRIBUTE(Obj self, Obj name)
3082 {
3083 RequireStringRep("NewMutableAttribute", name);
3084 return NewAttribute(name, 0, DoMutableAttribute);
3085 }
3086
3087
3088 /****************************************************************************
3089 **
3090 *F FuncNEW_PROPERTY( <self>, <name> ) . . . . . . . . . . . . new property
3091 */
FuncNEW_PROPERTY(Obj self,Obj name)3092 static Obj FuncNEW_PROPERTY(Obj self, Obj name)
3093 {
3094 RequireStringRep("NewProperty", name);
3095 return NewProperty(name, 0, DoProperty);
3096 }
3097
3098
3099 /****************************************************************************
3100 **
3101 *F FuncNEW_GLOBAL_FUNCTION( <self>, <name> ) . . . . . . new global function
3102 */
FuncNEW_GLOBAL_FUNCTION(Obj self,Obj name)3103 static Obj FuncNEW_GLOBAL_FUNCTION(Obj self, Obj name)
3104 {
3105 Obj args;
3106 Obj list;
3107
3108 RequireStringRep("NewGlobalFunction", name);
3109
3110 args = MakeImmString("args");
3111 list = NEW_PLIST( T_PLIST, 1 );
3112 SET_LEN_PLIST( list, 1 );
3113 SET_ELM_PLIST( list, 1, args );
3114 CHANGED_BAG( list );
3115 return NewGlobalFunction( name, list );
3116 }
3117
3118
3119 /****************************************************************************
3120 **
3121 *F FuncINSTALL_GLOBAL_FUNCTION( <self>, <oper>, <func> )
3122 */
3123 static Obj REREADING;
3124
FuncINSTALL_GLOBAL_FUNCTION(Obj self,Obj oper,Obj func)3125 static Obj FuncINSTALL_GLOBAL_FUNCTION(Obj self, Obj oper, Obj func)
3126 {
3127 /* check the arguments */
3128 RequireFunction("INSTALL_GLOBAL_FUNCTION", oper);
3129 if ( (REREADING != True) &&
3130 (HDLR_FUNC(oper,0) != (ObjFunc)DoUninstalledGlobalFunction) ) {
3131 ErrorQuit( "operation already installed",
3132 0L, 0L );
3133 }
3134 RequireFunction("INSTALL_GLOBAL_FUNCTION", func);
3135 if ( IS_OPERATION(func) ) {
3136 ErrorQuit( "<func> must not be an operation", 0L, 0L );
3137 }
3138
3139 /* install the new method */
3140 InstallGlobalFunction( oper, func );
3141 return 0;
3142 }
3143
3144
3145 /****************************************************************************
3146 **
3147 *F FiltIS_OPERATION( <self>, <obj> ) . . . . . . . . . is <obj> an operation
3148 */
3149 static Obj IsOperationFilt;
3150
FiltIS_OPERATION(Obj self,Obj obj)3151 static Obj FiltIS_OPERATION(Obj self, Obj obj)
3152 {
3153 if ( TNUM_OBJ(obj) == T_FUNCTION && IS_OPERATION(obj) ) {
3154 return True;
3155 }
3156 else if ( TNUM_OBJ(obj) < FIRST_EXTERNAL_TNUM ) {
3157 return False;
3158 }
3159 else {
3160 return DoFilter( self, obj );
3161 }
3162 }
3163
3164
3165 /****************************************************************************
3166 **
3167 *F FuncMETHODS_OPERATION( <self>, <oper>, <narg> ) . . . . . list of method
3168 */
MethsOper(Obj oper,UInt i)3169 static Obj MethsOper(Obj oper, UInt i)
3170 {
3171 Obj methods;
3172 methods = METHS_OPER( oper, i );
3173 if ( methods == 0 ) {
3174 methods = NEW_PLIST( T_PLIST, 0 );
3175 #ifdef HPCGAP
3176 MakeBagReadOnly(methods);
3177 #endif
3178 SET_METHS_OPER(oper, i, methods);
3179 CHANGED_BAG( oper );
3180 }
3181 return methods;
3182 }
3183
FuncMETHODS_OPERATION(Obj self,Obj oper,Obj narg)3184 static Obj FuncMETHODS_OPERATION(Obj self, Obj oper, Obj narg)
3185 {
3186 Int n;
3187 Obj meth;
3188
3189 RequireOperation(oper);
3190 n = IS_INTOBJ(narg) ? INT_INTOBJ(narg) : -1;
3191 if (n < 0 || n > MAX_OPER_ARGS)
3192 RequireArgument("METHODS_OPERATION", narg,
3193 "must be an integer between 0 and 6");
3194 meth = MethsOper( oper, (UInt)n );
3195 #ifdef HPCGAP
3196 MEMBAR_READ();
3197 #endif
3198 return meth == 0 ? Fail : meth;
3199 }
3200
3201
3202 /****************************************************************************
3203 **
3204 *F FuncCHANGED_METHODS_OPERATION( <self>, <oper>, <narg> ) . . . clear cache
3205 */
FuncCHANGED_METHODS_OPERATION(Obj self,Obj oper,Obj narg)3206 static Obj FuncCHANGED_METHODS_OPERATION(Obj self, Obj oper, Obj narg)
3207 {
3208 Obj * cache;
3209 Bag cacheBag;
3210 Int n;
3211 Int i;
3212
3213 RequireOperation(oper);
3214 n = IS_INTOBJ(narg) ? INT_INTOBJ(narg) : -1;
3215 if (n < 0 || n > MAX_OPER_ARGS)
3216 RequireArgument("CHANGED_METHODS_OPERATION", narg,
3217 "must be an integer between 0 and 6");
3218 #ifdef HPCGAP
3219 if (!PreThreadCreation) {
3220 ErrorQuit("Methods may only be changed before thread creation",0L,0L);
3221 }
3222 #endif
3223 cacheBag = CacheOper( oper, (UInt) n );
3224 cache = ADDR_OBJ( cacheBag );
3225 for ( i = 1; i < SIZE_OBJ(cacheBag) / sizeof(Obj); i++ ) {
3226 cache[i] = 0;
3227 }
3228 return 0;
3229 }
3230
3231
3232 /****************************************************************************
3233 **
3234 *F FuncSET_METHODS_OPERATION( <self>, <oper>, <narg>, <list> ) . set methods
3235 */
FuncSET_METHODS_OPERATION(Obj self,Obj oper,Obj narg,Obj meths)3236 static Obj FuncSET_METHODS_OPERATION(Obj self, Obj oper, Obj narg, Obj meths)
3237 {
3238 Int n;
3239
3240 RequireOperation(oper);
3241 n = IS_INTOBJ(narg) ? INT_INTOBJ(narg) : -1;
3242 if (n < 0 || n > MAX_OPER_ARGS)
3243 RequireArgument("SET_METHODS_OPERATION", narg,
3244 "must be an integer between 0 and 6");
3245 #ifdef HPCGAP
3246 MEMBAR_WRITE();
3247 #endif
3248 SET_METHS_OPER(oper, n, meths);
3249 return 0;
3250 }
3251
3252
3253 /****************************************************************************
3254 **
3255 *F FuncSETTER_FUNCTION( <self>, <name>, <filter> ) default attribute setter
3256 */
DoSetterFunction(Obj self,Obj obj,Obj value)3257 static Obj DoSetterFunction(Obj self, Obj obj, Obj value)
3258 {
3259 Obj tmp;
3260 Obj tester;
3261 Obj flags;
3262 UInt flag2;
3263 Obj type;
3264 #ifdef HPCGAP
3265 int atomic = 0;
3266 #endif
3267
3268 switch (TNUM_OBJ(obj)) {
3269 #ifdef HPCGAP
3270 case T_ACOMOBJ:
3271 atomic = 1;
3272 #endif
3273 case T_COMOBJ:
3274 break;
3275 default:
3276 ErrorQuit( "<obj> must be a component object", 0L, 0L );
3277 return 0L;
3278 }
3279
3280 /* if the attribute is already there *do not* chage it */
3281 tmp = ENVI_FUNC(self);
3282 tester = ELM_PLIST( tmp, 2 );
3283 flag2 = INT_INTOBJ( FLAG2_FILT(tester) );
3284 type = TYPE_OBJ_FEO(obj);
3285 flags = FLAGS_TYPE(type);
3286 if ( SAFE_C_ELM_FLAGS(flags,flag2) ) {
3287 return 0;
3288 }
3289
3290 /* set the value */
3291 UInt rnam = (UInt)INT_INTOBJ(ELM_PLIST(tmp,1));
3292 #ifdef HPCGAP
3293 if (atomic)
3294 SetARecordField( obj, rnam, CopyObj(value,0) );
3295 else
3296 #endif
3297 AssPRec( obj, rnam, CopyObj(value,0) );
3298 CALL_2ARGS( SET_FILTER_OBJ, obj, tester );
3299 return 0;
3300 }
3301
3302
FuncSETTER_FUNCTION(Obj self,Obj name,Obj filter)3303 static Obj FuncSETTER_FUNCTION(Obj self, Obj name, Obj filter)
3304 {
3305 Obj func;
3306 Obj fname;
3307 Obj tmp;
3308
3309 fname = WRAP_NAME(name, "SetterFunc");
3310 func = NewFunction( fname, 2, ArglistObjVal, DoSetterFunction );
3311 tmp = NEW_PLIST_IMM( T_PLIST, 2 );
3312 SET_LEN_PLIST( tmp, 2 );
3313 SET_ELM_PLIST( tmp, 1, INTOBJ_INT( RNamObj(name) ) );
3314 SET_ELM_PLIST( tmp, 2, filter );
3315 CHANGED_BAG(tmp);
3316 SET_ENVI_FUNC(func, tmp);
3317 CHANGED_BAG(func);
3318 return func;
3319 }
3320
3321
3322 /****************************************************************************
3323 **
3324 *F FuncGETTER_FUNCTION( <self>, <name> ) . . . . . default attribute getter
3325 */
DoGetterFunction(Obj self,Obj obj)3326 static Obj DoGetterFunction(Obj self, Obj obj)
3327 {
3328 switch (TNUM_OBJ(obj)) {
3329 case T_COMOBJ:
3330 return ElmPRec( obj, (UInt)INT_INTOBJ(ENVI_FUNC(self)) );
3331 #ifdef HPCGAP
3332 case T_ACOMOBJ:
3333 return GetARecordField( obj, (UInt)INT_INTOBJ(ENVI_FUNC(self)) );
3334 #endif
3335 default:
3336 ErrorQuit( "<obj> must be a component object", 0L, 0L );
3337 return 0L;
3338 }
3339 }
3340
3341
FuncGETTER_FUNCTION(Obj self,Obj name)3342 static Obj FuncGETTER_FUNCTION(Obj self, Obj name)
3343 {
3344 Obj func;
3345 Obj fname;
3346
3347 fname = WRAP_NAME(name, "GetterFunc");
3348 func = NewFunction( fname, 1, ArglistObj, DoGetterFunction );
3349 SET_ENVI_FUNC(func, INTOBJ_INT( RNamObj(name) ));
3350 return func;
3351 }
3352
3353
3354 /****************************************************************************
3355 **
3356 *F FuncOPERS_CACHE_INFO( <self> ) . . . . . . . return cache stats as list
3357 */
FuncOPERS_CACHE_INFO(Obj self)3358 static Obj FuncOPERS_CACHE_INFO(Obj self)
3359 {
3360 Obj list;
3361 Int i;
3362
3363 list = NEW_PLIST_IMM(T_PLIST, 13);
3364 SET_LEN_PLIST(list, 13);
3365 #ifdef COUNT_OPERS
3366 SET_ELM_PLIST(list, 1, INTOBJ_INT(AndFlagsCacheHit));
3367 SET_ELM_PLIST(list, 2, INTOBJ_INT(AndFlagsCacheMiss));
3368 SET_ELM_PLIST(list, 3, INTOBJ_INT(AndFlagsCacheLost));
3369 SET_ELM_PLIST(list, 4, INTOBJ_INT(OperationHit));
3370 SET_ELM_PLIST(list, 5, INTOBJ_INT(OperationNext));
3371 SET_ELM_PLIST(list, 6, INTOBJ_INT(OperationMiss));
3372 SET_ELM_PLIST(list, 7, INTOBJ_INT(IsSubsetFlagsCalls));
3373 SET_ELM_PLIST(list, 8, INTOBJ_INT(WITH_HIDDEN_IMPS_HIT));
3374 SET_ELM_PLIST(list, 9, INTOBJ_INT(WITH_HIDDEN_IMPS_MISS));
3375 SET_ELM_PLIST(list, 10, INTOBJ_INT(WITH_IMPS_FLAGS_HIT));
3376 SET_ELM_PLIST(list, 11, INTOBJ_INT(WITH_IMPS_FLAGS_MISS));
3377
3378 /* Now we need to convert the 3d matrix of cache hit counts (by
3379 precedence, location found and number of arguments) into a three
3380 dimensional GAP matrix (tensor) */
3381 Obj tensor = NEW_PLIST_IMM(T_PLIST, CACHE_SIZE);
3382 SET_LEN_PLIST(tensor, CACHE_SIZE);
3383 for (i = 1; i <= CACHE_SIZE; i++) {
3384 Obj mat = NEW_PLIST_IMM(T_PLIST, CACHE_SIZE);
3385 SET_LEN_PLIST(mat, CACHE_SIZE);
3386 SET_ELM_PLIST(tensor, i, mat);
3387 CHANGED_BAG(tensor);
3388 for (Int j = 1; j <= CACHE_SIZE; j++) {
3389 Obj vec = NEW_PLIST_IMM(T_PLIST, 7);
3390 SET_LEN_PLIST(vec, 7);
3391 SET_ELM_PLIST(mat, j, vec);
3392 CHANGED_BAG(mat);
3393 for (Int k = 0; k <= 6; k++)
3394 SET_ELM_PLIST(
3395 vec, k + 1,
3396 INTOBJ_INT(CacheHitStatistics[i - 1][j - 1][k]));
3397 }
3398 }
3399 SET_ELM_PLIST(list, 12, tensor);
3400 CHANGED_BAG(list);
3401
3402 /* and similarly the 2D matrix of cache miss information (by
3403 precedence and number of arguments) */
3404 Obj mat = NEW_PLIST_IMM(T_PLIST, CACHE_SIZE + 1);
3405 SET_LEN_PLIST(mat, CACHE_SIZE + 1);
3406 for (Int j = 1; j <= CACHE_SIZE + 1; j++) {
3407 Obj vec = NEW_PLIST_IMM(T_PLIST, 7);
3408 SET_LEN_PLIST(vec, 7);
3409 SET_ELM_PLIST(mat, j, vec);
3410 CHANGED_BAG(mat);
3411 for (Int k = 0; k <= 6; k++)
3412 SET_ELM_PLIST(vec, k + 1,
3413 INTOBJ_INT(CacheMissStatistics[j - 1][k]));
3414 }
3415 SET_ELM_PLIST(list, 13, mat);
3416 CHANGED_BAG(list);
3417 #else
3418 for (i = 1; i <= 13; i++)
3419 SET_ELM_PLIST(list, i, INTOBJ_INT(0));
3420 #endif
3421 return list;
3422 }
3423
3424
3425 /****************************************************************************
3426 **
3427 *F FuncCLEAR_CACHE_INFO( <self> ) . . . . . . . . . . . . clear cache stats
3428 */
FuncCLEAR_CACHE_INFO(Obj self)3429 static Obj FuncCLEAR_CACHE_INFO(Obj self)
3430 {
3431 #ifdef COUNT_OPERS
3432 AndFlagsCacheHit = 0;
3433 AndFlagsCacheMiss = 0;
3434 AndFlagsCacheLost = 0;
3435 OperationHit = 0;
3436 OperationMiss = 0;
3437 IsSubsetFlagsCalls = 0;
3438 OperationNext = 0;
3439 WITH_HIDDEN_IMPS_HIT = 0;
3440 WITH_HIDDEN_IMPS_MISS = 0;
3441 WITH_IMPS_FLAGS_HIT = 0;
3442 WITH_IMPS_FLAGS_MISS = 0;
3443 memset(CacheHitStatistics, 0, sizeof(CacheHitStatistics));
3444 memset(CacheMissStatistics, 0, sizeof(CacheMissStatistics));
3445 #endif
3446
3447 return 0;
3448 }
3449
3450 /****************************************************************************
3451 **
3452 *F ChangeDoOperations( <oper>, <verb> ) . . . verbose or silent operations
3453 */
3454 static ObjFunc TabSilentVerboseOperations[] =
3455 {
3456 (ObjFunc) DoOperation0Args, (ObjFunc) DoVerboseOperation0Args,
3457 (ObjFunc) DoOperation1Args, (ObjFunc) DoVerboseOperation1Args,
3458 (ObjFunc) DoOperation2Args, (ObjFunc) DoVerboseOperation2Args,
3459 (ObjFunc) DoOperation3Args, (ObjFunc) DoVerboseOperation3Args,
3460 (ObjFunc) DoOperation4Args, (ObjFunc) DoVerboseOperation4Args,
3461 (ObjFunc) DoOperation5Args, (ObjFunc) DoVerboseOperation5Args,
3462 (ObjFunc) DoOperation6Args, (ObjFunc) DoVerboseOperation6Args,
3463 (ObjFunc) DoOperationXArgs, (ObjFunc) DoVerboseOperationXArgs,
3464 (ObjFunc) DoConstructor0Args, (ObjFunc) DoVerboseConstructor0Args,
3465 (ObjFunc) DoConstructor1Args, (ObjFunc) DoVerboseConstructor1Args,
3466 (ObjFunc) DoConstructor2Args, (ObjFunc) DoVerboseConstructor2Args,
3467 (ObjFunc) DoConstructor3Args, (ObjFunc) DoVerboseConstructor3Args,
3468 (ObjFunc) DoConstructor4Args, (ObjFunc) DoVerboseConstructor4Args,
3469 (ObjFunc) DoConstructor5Args, (ObjFunc) DoVerboseConstructor5Args,
3470 (ObjFunc) DoConstructor6Args, (ObjFunc) DoVerboseConstructor6Args,
3471 (ObjFunc) DoConstructorXArgs, (ObjFunc) DoVerboseConstructorXArgs,
3472 (ObjFunc) DoAttribute, (ObjFunc) DoVerboseAttribute,
3473 (ObjFunc) DoMutableAttribute, (ObjFunc) DoVerboseMutableAttribute,
3474 (ObjFunc) DoProperty, (ObjFunc) DoVerboseProperty,
3475 0, 0
3476 };
3477
3478
ChangeDoOperations(Obj oper,Int verb)3479 void ChangeDoOperations (
3480 Obj oper,
3481 Int verb )
3482 {
3483 Int i;
3484 Int j;
3485
3486 ChangeArithDoOperations(oper, verb);
3487
3488 /* be verbose */
3489 if ( verb ) {
3490
3491 /* switch do with do verbose */
3492 for ( j = 0; TabSilentVerboseOperations[j]; j += 2 ) {
3493 for ( i = 0; i <= 7; i++ ) {
3494 if ( HDLR_FUNC(oper,i) == TabSilentVerboseOperations[j] ) {
3495 SET_HDLR_FUNC(oper, i, TabSilentVerboseOperations[j+1]);
3496 }
3497 }
3498 }
3499 }
3500
3501 /* be silent */
3502 else {
3503
3504 /* switch do verbose with do */
3505 for ( j = 1; TabSilentVerboseOperations[j-1]; j += 2 ) {
3506 for ( i = 0; i <= 7; i++ ) {
3507 if ( HDLR_FUNC(oper,i) == TabSilentVerboseOperations[j] ) {
3508 SET_HDLR_FUNC(oper, i, TabSilentVerboseOperations[j-1]);
3509 }
3510 }
3511 }
3512 }
3513 }
3514
3515
3516 /****************************************************************************
3517 **
3518 *F FuncTRACE_METHODS( <oper> ) . . . . . . . . switch tracing of methods on
3519 */
FuncTRACE_METHODS(Obj self,Obj oper)3520 static Obj FuncTRACE_METHODS(Obj self, Obj oper)
3521 {
3522 /* check the argument */
3523 RequireOperation(oper);
3524
3525 /* install trace handler */
3526 ChangeDoOperations( oper, 1 );
3527
3528 /* return nothing */
3529 return 0;
3530 }
3531
3532
3533 /****************************************************************************
3534 **
3535 *F FuncUNTRACE_METHODS( <oper> ) . . . . . . . switch tracing of methods off
3536 */
FuncUNTRACE_METHODS(Obj self,Obj oper)3537 static Obj FuncUNTRACE_METHODS(Obj self, Obj oper)
3538 {
3539
3540 /* check the argument */
3541 RequireOperation(oper);
3542
3543 /* install trace handler */
3544 ChangeDoOperations( oper, 0 );
3545
3546 /* return nothing */
3547 return 0;
3548 }
3549
3550 /****************************************************************************
3551 **
3552 *F FuncSET_ATTRIBUTE_STORING( <self>, <attr>, <val> )
3553 ** switch off or on the setter call of an attribute
3554 */
FuncSET_ATTRIBUTE_STORING(Obj self,Obj attr,Obj val)3555 static Obj FuncSET_ATTRIBUTE_STORING(Obj self, Obj attr, Obj val)
3556 {
3557 SET_ENABLED_ATTR(attr, (val == True) ? 1L : 0L);
3558 return 0;
3559 }
3560
3561 /****************************************************************************
3562 **
3563 *F FuncDO_NOTHING_SETTER(<self> , <obj>, <val> )
3564 **
3565 */
FuncDO_NOTHING_SETTER(Obj self,Obj obj,Obj val)3566 static Obj FuncDO_NOTHING_SETTER(Obj self, Obj obj, Obj val)
3567 {
3568 return 0;
3569 }
3570
3571 /****************************************************************************
3572 **
3573 *F * * * * * * * * * * * * * initialize module * * * * * * * * * * * * * * *
3574 */
3575
3576
3577 /****************************************************************************
3578 **
3579 *V BagNames . . . . . . . . . . . . . . . . . . . . . . . list of bag names
3580 */
3581 static StructBagNames BagNames[] = {
3582 { T_FLAGS, "flags list" },
3583 { -1, "" }
3584 };
3585
3586
3587 /****************************************************************************
3588 **
3589 *V GVarFilts . . . . . . . . . . . . . . . . . . . list of filters to export
3590 */
3591 static StructGVarFilt GVarFilts [] = {
3592
3593 GVAR_FILT(IS_OPERATION, "obj", &IsOperationFilt),
3594 { 0, 0, 0, 0, 0 }
3595
3596 };
3597
3598
3599 /****************************************************************************
3600 **
3601 *V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export
3602 */
3603 static StructGVarFunc GVarFuncs [] = {
3604
3605 GVAR_FUNC(AND_FLAGS, 2, "oper1, oper2"),
3606 GVAR_FUNC(SUB_FLAGS, 2, "oper1, oper2"),
3607 GVAR_FUNC(HASH_FLAGS, 1, "flags"),
3608 GVAR_FUNC(IS_EQUAL_FLAGS, 2, "flags1, flags2"),
3609 GVAR_FUNC(CLEAR_HIDDEN_IMP_CACHE, 1, "flags"),
3610 GVAR_FUNC(WITH_HIDDEN_IMPS_FLAGS, 1, "flags"),
3611 GVAR_FUNC(InstallHiddenTrueMethod, 2, "filter, filters"),
3612 GVAR_FUNC(CLEAR_IMP_CACHE, 0, ""),
3613 GVAR_FUNC(WITH_IMPS_FLAGS, 1, "flags"),
3614 GVAR_FUNC(WITH_IMPS_FLAGS_STAT, 0, ""),
3615 GVAR_FUNC(IS_SUBSET_FLAGS, 2, "flags1, flags2"),
3616 GVAR_FUNC(TRUES_FLAGS, 1, "flags"),
3617 GVAR_FUNC(SIZE_FLAGS, 1, "flags"),
3618 GVAR_FUNC(FLAG1_FILTER, 1, "oper"),
3619 GVAR_FUNC(FLAG2_FILTER, 1, "oper"),
3620 GVAR_FUNC(FLAGS_FILTER, 1, "oper"),
3621 GVAR_FUNC(SETTER_FILTER, 1, "oper"),
3622 GVAR_FUNC(TESTER_FILTER, 1, "oper"),
3623 GVAR_FUNC(METHODS_OPERATION, 2, "oper, narg"),
3624 GVAR_FUNC(SET_METHODS_OPERATION, 3, "oper, narg, meths"),
3625 GVAR_FUNC(CHANGED_METHODS_OPERATION, 2, "oper, narg"),
3626 GVAR_FUNC(NEW_FILTER, 1, "name"),
3627 GVAR_FUNC(NEW_OPERATION, 1, "name"),
3628 GVAR_FUNC(NEW_CONSTRUCTOR, 1, "name"),
3629 GVAR_FUNC(NEW_ATTRIBUTE, 1, "name"),
3630 GVAR_FUNC(NEW_MUTABLE_ATTRIBUTE, 1, "name"),
3631 GVAR_FUNC(NEW_PROPERTY, 1, "name"),
3632 GVAR_FUNC(SETTER_FUNCTION, 2, "name, filter"),
3633 GVAR_FUNC(GETTER_FUNCTION, 1, "name"),
3634 GVAR_FUNC(NEW_GLOBAL_FUNCTION, 1, "name"),
3635 GVAR_FUNC(INSTALL_GLOBAL_FUNCTION, 2, "oper, func"),
3636 GVAR_FUNC(TRACE_METHODS, 1, "oper"),
3637 GVAR_FUNC(UNTRACE_METHODS, 1, "oper"),
3638 GVAR_FUNC(OPERS_CACHE_INFO, 0, ""),
3639 GVAR_FUNC(CLEAR_CACHE_INFO, 0, ""),
3640 GVAR_FUNC(SET_ATTRIBUTE_STORING, 2, "attr, val"),
3641 GVAR_FUNC(DO_NOTHING_SETTER, 2, "obj, val"),
3642 GVAR_FUNC(IS_FILTER, 1, "obj"),
3643 GVAR_FUNC(IS_AND_FILTER, 1, "filter"),
3644 GVAR_FUNC(IS_CONSTRUCTOR, 1, "x"),
3645 GVAR_FUNC(COMPACT_TYPE_IDS, 0, ""),
3646 GVAR_FUNC(OPER_TO_ATTRIBUTE, 1, "oper"),
3647 GVAR_FUNC(OPER_TO_MUTABLE_ATTRIBUTE, 1, "oper"),
3648 { 0, 0, 0, 0, 0 }
3649
3650 };
3651
3652
3653 /****************************************************************************
3654 **
3655 *F InitKernel( <module> ) . . . . . . . . initialise kernel data structures
3656 */
InitKernel(StructInitInfo * module)3657 static Int InitKernel (
3658 StructInitInfo * module )
3659 {
3660
3661 CountFlags = 0;
3662
3663 InitGlobalBag( &StringFilterSetter, "src/opers.c:StringFilterSetter" );
3664 InitGlobalBag( &ArglistObj, "src/opers.c:ArglistObj" );
3665 InitGlobalBag( &ArglistObjVal, "src/opers.c:ArglistObjVal" );
3666
3667 /* share between uncompleted functions */
3668 StringFilterSetter = MakeImmString("<<filter-setter>>");
3669
3670 ArglistObj = NEW_PLIST_IMM( T_PLIST, 1 );
3671 SET_LEN_PLIST( ArglistObj, 1 );
3672 SET_ELM_PLIST( ArglistObj, 1, MakeImmString("obj") );
3673 CHANGED_BAG( ArglistObj );
3674
3675 ArglistObjVal = NEW_PLIST_IMM( T_PLIST, 2 );
3676 SET_LEN_PLIST( ArglistObjVal, 2 );
3677 SET_ELM_PLIST( ArglistObjVal, 1, MakeImmString("obj") );
3678 CHANGED_BAG( ArglistObjVal );
3679 SET_ELM_PLIST( ArglistObjVal, 2, MakeImmString("val") );
3680 CHANGED_BAG( ArglistObjVal );
3681
3682
3683 // Declare the handlers used in various places. Some of the most common
3684 // ones are abbreviated to save space in saved workspace.
3685 InitHandlerFunc( DoFilter, "df" );
3686 InitHandlerFunc( DoSetFilter, "dsf" );
3687 InitHandlerFunc( DoAndFilter, "daf" );
3688 InitHandlerFunc( DoSetAndFilter, "dsaf" );
3689 InitHandlerFunc( DoReturnTrueFilter, "src/opers.c:DoReturnTrueFilter" );
3690 InitHandlerFunc( DoSetReturnTrueFilter, "src/opers.c:DoSetReturnTrueFilter" );
3691
3692 InitHandlerFunc( DoAttribute, "da" );
3693 InitHandlerFunc( DoSetAttribute, "dsa" );
3694 InitHandlerFunc( DoTestAttribute, "src/opers.c:DoTestAttribute" );
3695 InitHandlerFunc( DoVerboseAttribute, "src/opers.c:DoVerboseAttribute" );
3696 InitHandlerFunc( DoMutableAttribute, "src/opers.c:DoMutableAttribute" );
3697 InitHandlerFunc( DoVerboseMutableAttribute, "src/opers.c:DoVerboseMutableAttribute" );
3698
3699 InitHandlerFunc( DoProperty, "src/opers.c:DoProperty" );
3700 InitHandlerFunc( DoSetProperty, "src/opers.c:DoSetProperty" );
3701 InitHandlerFunc( DoVerboseProperty, "src/opers.c:DoVerboseProperty" );
3702
3703 InitHandlerFunc( DoSetterFunction, "dtf" );
3704 InitHandlerFunc( DoGetterFunction, "dgf" );
3705
3706 InitHandlerFunc( DoOperation0Args, "o0" );
3707 InitHandlerFunc( DoOperation1Args, "o1" );
3708 InitHandlerFunc( DoOperation2Args, "o2" );
3709 InitHandlerFunc( DoOperation3Args, "o3" );
3710 InitHandlerFunc( DoOperation4Args, "o4" );
3711 InitHandlerFunc( DoOperation5Args, "o5" );
3712 InitHandlerFunc( DoOperation6Args, "o6" );
3713 InitHandlerFunc( DoOperationXArgs, "o7" );
3714
3715 InitHandlerFunc( DoVerboseOperation0Args, "src/opers.c:DoVerboseOperation0Args" );
3716 InitHandlerFunc( DoVerboseOperation1Args, "src/opers.c:DoVerboseOperation1Args" );
3717 InitHandlerFunc( DoVerboseOperation2Args, "src/opers.c:DoVerboseOperation2Args" );
3718 InitHandlerFunc( DoVerboseOperation3Args, "src/opers.c:DoVerboseOperation3Args" );
3719 InitHandlerFunc( DoVerboseOperation4Args, "src/opers.c:DoVerboseOperation4Args" );
3720 InitHandlerFunc( DoVerboseOperation5Args, "src/opers.c:DoVerboseOperation5Args" );
3721 InitHandlerFunc( DoVerboseOperation6Args, "src/opers.c:DoVerboseOperation6Args" );
3722 InitHandlerFunc( DoVerboseOperationXArgs, "src/opers.c:DoVerboseOperationXArgs" );
3723
3724 InitHandlerFunc( DoConstructor0Args, "src/opers.c:DoConstructor0Args" );
3725 InitHandlerFunc( DoConstructor1Args, "src/opers.c:DoConstructor1Args" );
3726 InitHandlerFunc( DoConstructor2Args, "src/opers.c:DoConstructor2Args" );
3727 InitHandlerFunc( DoConstructor3Args, "src/opers.c:DoConstructor3Args" );
3728 InitHandlerFunc( DoConstructor4Args, "src/opers.c:DoConstructor4Args" );
3729 InitHandlerFunc( DoConstructor5Args, "src/opers.c:DoConstructor5Args" );
3730 InitHandlerFunc( DoConstructor6Args, "src/opers.c:DoConstructor6Args" );
3731 InitHandlerFunc( DoConstructorXArgs, "src/opers.c:DoConstructorXArgs" );
3732
3733 InitHandlerFunc( DoVerboseConstructor0Args, "src/opers.c:DoVerboseConstructor0Args" );
3734 InitHandlerFunc( DoVerboseConstructor1Args, "src/opers.c:DoVerboseConstructor1Args" );
3735 InitHandlerFunc( DoVerboseConstructor2Args, "src/opers.c:DoVerboseConstructor2Args" );
3736 InitHandlerFunc( DoVerboseConstructor3Args, "src/opers.c:DoVerboseConstructor3Args" );
3737 InitHandlerFunc( DoVerboseConstructor4Args, "src/opers.c:DoVerboseConstructor4Args" );
3738 InitHandlerFunc( DoVerboseConstructor5Args, "src/opers.c:DoVerboseConstructor5Args" );
3739 InitHandlerFunc( DoVerboseConstructor6Args, "src/opers.c:DoVerboseConstructor6Args" );
3740 InitHandlerFunc( DoVerboseConstructorXArgs, "src/opers.c:DoVerboseConstructorXArgs" );
3741
3742 InitHandlerFunc( DoUninstalledGlobalFunction, "src/opers.c:DoUninstalledGlobalFunction" );
3743
3744 /* install the type function */
3745 ImportGVarFromLibrary( "TYPE_FLAGS", &TYPE_FLAGS );
3746 TypeObjFuncs[ T_FLAGS ] = TypeFlags;
3747
3748
3749 /* set up hidden implications */
3750 InitGlobalBag( &WITH_HIDDEN_IMPS_FLAGS_CACHE, "src/opers.c:WITH_HIDDEN_IMPS_FLAGS_CACHE");
3751 InitGlobalBag( &HIDDEN_IMPS, "src/opers.c:HIDDEN_IMPS");
3752
3753 /* set up implications */
3754 InitGlobalBag( &WITH_IMPS_FLAGS_CACHE, "src/opers.c:WITH_IMPS_FLAGS_CACHE");
3755 InitGlobalBag( &IMPLICATIONS_SIMPLE, "src/opers.c:IMPLICATIONS_SIMPLE");
3756 InitGlobalBag( &IMPLICATIONS_COMPOSED, "src/opers.c:IMPLICATIONS_COMPOSED");
3757
3758 /* make the 'true' operation */
3759 InitGlobalBag( &ReturnTrueFilter, "src/opers.c:ReturnTrueFilter" );
3760
3761 /* install the (function) copies of global variables */
3762 /*for the inside-out (kernel to library) interface */
3763 InitGlobalBag( &TRY_NEXT_METHOD, "src/opers.c:TRY_NEXT_METHOD" );
3764
3765 ImportFuncFromLibrary("ReturnTrue", &ReturnTrue);
3766 ImportFuncFromLibrary("VMETHOD_PRINT_INFO", &VMETHOD_PRINT_INFO);
3767 ImportFuncFromLibrary("NEXT_VMETHOD_PRINT_INFO", &NEXT_VMETHOD_PRINT_INFO);
3768
3769 ImportFuncFromLibrary( "SetFilterObj", &SET_FILTER_OBJ );
3770 ImportFuncFromLibrary( "ResetFilterObj", &RESET_FILTER_OBJ );
3771
3772 ImportFuncFromLibrary("HANDLE_METHOD_NOT_FOUND",
3773 &HANDLE_METHOD_NOT_FOUND);
3774
3775 #ifdef GASMAN
3776 ImportGVarFromLibrary( "IsType", &IsType );
3777 ImportFuncFromLibrary( "FLUSH_ALL_METHOD_CACHES", &FLUSH_ALL_METHOD_CACHES );
3778 #endif
3779
3780 /* init filters and functions */
3781 InitHdlrFiltsFromTable( GVarFilts );
3782 InitHdlrFuncsFromTable( GVarFuncs );
3783
3784 // set the bag type names (for error messages and debugging)
3785 InitBagNamesFromTable( BagNames );
3786
3787 /* install the marking function */
3788 InitMarkFuncBags( T_FLAGS, MarkThreeSubBags );
3789
3790 /* install the printing function */
3791 PrintObjFuncs[ T_FLAGS ] = PrintFlags;
3792
3793 /* and the saving function */
3794 SaveObjFuncs[ T_FLAGS ] = SaveFlags;
3795 LoadObjFuncs[ T_FLAGS ] = LoadFlags;
3796
3797 #ifdef HPCGAP
3798 /* flags are public objects by default */
3799 MakeBagTypePublic(T_FLAGS);
3800 #endif
3801
3802 /* import copy of REREADING */
3803 ImportGVarFromLibrary( "REREADING", &REREADING );
3804
3805
3806 #ifdef HPCGAP
3807 /* initialize cache mutex */
3808 pthread_mutex_init(&CacheLock, NULL);
3809 #endif
3810
3811 /* return success */
3812 return 0;
3813 }
3814
3815
3816 /****************************************************************************
3817 **
3818 *F postRestore( <module> ) . . . . . . . initialise library data structures
3819 **
3820 */
3821
3822
postRestore(StructInitInfo * module)3823 static Int postRestore (
3824 StructInitInfo * module )
3825 {
3826
3827 CountFlags = LEN_LIST(ValGVar(GVarName("FILTERS")));
3828 return 0;
3829 }
3830
3831 /****************************************************************************
3832 **
3833 *F InitLibrary( <module> ) . . . . . . . initialise library data structures
3834 */
InitLibrary(StructInitInfo * module)3835 static Int InitLibrary (
3836 StructInitInfo * module )
3837 {
3838 // HACK: move this here, instead of InitKernel, to avoid ariths.c overwriting it
3839 EqFuncs[T_FLAGS][T_FLAGS] = EqFlags;
3840
3841 ExportAsConstantGVar(BASE_SIZE_METHODS_OPER_ENTRY);
3842
3843 HIDDEN_IMPS = NEW_PLIST(T_PLIST, 0);
3844 WITH_HIDDEN_IMPS_FLAGS_CACHE = NEW_PLIST(T_PLIST, HIDDEN_IMPS_CACHE_LENGTH * 2);
3845 SET_LEN_PLIST(WITH_HIDDEN_IMPS_FLAGS_CACHE, HIDDEN_IMPS_CACHE_LENGTH * 2);
3846 AssGVar(GVarName("HIDDEN_IMPS"), HIDDEN_IMPS);
3847
3848 #ifdef HPCGAP
3849 SET_REGION(HIDDEN_IMPS, NewRegion());
3850 SET_REGION(WITH_HIDDEN_IMPS_FLAGS_CACHE, REGION(HIDDEN_IMPS));
3851 #endif
3852
3853 IMPLICATIONS_SIMPLE = NEW_PLIST(T_PLIST, 0);
3854 IMPLICATIONS_COMPOSED = NEW_PLIST(T_PLIST, 0);
3855 WITH_IMPS_FLAGS_CACHE = NEW_PLIST(T_PLIST, IMPS_CACHE_LENGTH * 2);
3856 SET_LEN_PLIST(WITH_IMPS_FLAGS_CACHE, IMPS_CACHE_LENGTH * 2);
3857 AssGVar(GVarName("IMPLICATIONS_SIMPLE"), IMPLICATIONS_SIMPLE);
3858 AssGVar(GVarName("IMPLICATIONS_COMPOSED"), IMPLICATIONS_COMPOSED);
3859
3860 #ifdef HPCGAP
3861 SET_REGION(IMPLICATIONS_SIMPLE, NewRegion());
3862 SET_REGION(IMPLICATIONS_COMPOSED, REGION(IMPLICATIONS_SIMPLE));
3863 SET_REGION(WITH_IMPS_FLAGS_CACHE, REGION(IMPLICATIONS_SIMPLE));
3864 #endif
3865
3866 /* make the 'true' operation */
3867 ReturnTrueFilter = NewReturnTrueFilter();
3868 AssReadOnlyGVar( GVarName( "IS_OBJECT" ), ReturnTrueFilter );
3869
3870 /* install the (function) copies of global variables */
3871 /* for the inside-out (kernel to library) interface */
3872 TRY_NEXT_METHOD = MakeImmString("TRY_NEXT_METHOD");
3873 AssReadOnlyGVar( GVarName("TRY_NEXT_METHOD"), TRY_NEXT_METHOD );
3874
3875 /* init filters and functions */
3876 InitGVarFiltsFromTable( GVarFilts );
3877 InitGVarFuncsFromTable( GVarFuncs );
3878
3879 /* return success */
3880 return 0;
3881 }
3882
InitModuleState(void)3883 static Int InitModuleState(void)
3884 {
3885 #ifdef HPCGAP
3886 STATE(MethodCache) = NEW_PLIST(T_PLIST, 1);
3887 STATE(MethodCacheItems) = ADDR_OBJ(STATE(MethodCache));
3888 STATE(MethodCacheSize) = 1;
3889 SET_LEN_PLIST(STATE(MethodCache), 1);
3890 #endif
3891
3892 // return success
3893 return 0;
3894 }
3895
3896 /****************************************************************************
3897 **
3898 *F InitInfoOpers() . . . . . . . . . . . . . . . . . table of init functions
3899 */
3900 static StructInitInfo module = {
3901 // init struct using C99 designated initializers; for a full list of
3902 // fields, please refer to the definition of StructInitInfo
3903 .type = MODULE_BUILTIN,
3904 .name = "opers",
3905 .initKernel = InitKernel,
3906 .initLibrary = InitLibrary,
3907 .postRestore = postRestore,
3908 .initModuleState = InitModuleState,
3909 };
3910
InitInfoOpers(void)3911 StructInitInfo * InitInfoOpers ( void )
3912 {
3913 return &module;
3914 }
3915