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 objects package.
11 */
12
13 #include "objects.h"
14
15 #include "bool.h"
16 #include "calls.h"
17 #include "error.h"
18 #include "gapstate.h"
19 #include "gvars.h"
20 #include "io.h"
21 #include "lists.h"
22 #include "modules.h"
23 #include "opers.h"
24 #include "plist.h"
25 #include "precord.h"
26 #include "records.h"
27 #include "saveload.h"
28 #include "stringobj.h"
29
30 #ifdef HPCGAP
31 #include "hpc/aobjects.h"
32 #include "hpc/guards.h"
33 #include "hpc/thread.h"
34 #include "hpc/traverse.h"
35 #endif
36
37 #if defined(USE_THREADSAFE_COPYING)
38 #include "hpc/traverse.h"
39 #endif
40
41
42 enum {
43 MAXPRINTDEPTH = 1024,
44 };
45
46 static ModuleStateOffset ObjectsStateOffset = -1;
47
48 typedef struct {
49 UInt PrintObjDepth;
50 Obj PrintObjThis;
51 Int PrintObjIndex;
52 #if defined(HPCGAP)
53 Obj PrintObjThissObj;
54 Obj * PrintObjThiss;
55 Obj PrintObjIndicesObj;
56 Int * PrintObjIndices;
57 #else
58 Obj PrintObjThiss[MAXPRINTDEPTH];
59 Int PrintObjIndices[MAXPRINTDEPTH];
60 #endif
61
62 // This variable is used to allow a ViewObj method to call PrintObj on the
63 // same object without triggering use of '~'. It contains one of the
64 // values 0, 1 and 2 according to whether ...
65 // 0: there is no enclosing call to PrintObj or ViewObj still open, or
66 // 1: the innermost such is PrintObj, or
67 // 2: the innermost such is ViewObj.
68 UInt LastPV;
69
70 } ObjectsModuleState;
71
72
73 static Int lastFreePackageTNUM = FIRST_PACKAGE_TNUM;
74
75
76 /****************************************************************************
77 **
78 *V NameOfType[<type>] . . . . . . . . . . . . . . . . . . . . names of types
79 **
80 ** 'NameOfType[<type>]' is the name of the type <type>.
81 */
82 static const char * NameOfType[NUM_TYPES];
83
84
85 /****************************************************************************
86 **
87 *F RegisterPackageTNUM( <name>, <typeObjFunc> )
88 **
89 ** Allocates a TNUM for use by a package. The parameters <name> and
90 ** <typeObjFunc> are used to initialize the relevant entries in the
91 ** InfoBags and TypeObjFuncs arrays.
92 **
93 ** If allocation fails (e.g. because no more TNUMs are available),
94 ** a negative value is returned.
95 */
RegisterPackageTNUM(const char * name,Obj (* typeObjFunc)(Obj obj))96 Int RegisterPackageTNUM( const char *name, Obj (*typeObjFunc)(Obj obj) )
97 {
98 #ifdef HPCGAP
99 HashLock(0);
100 #endif
101
102 if (lastFreePackageTNUM > LAST_PACKAGE_TNUM)
103 return -1;
104
105 Int tnum = lastFreePackageTNUM++;
106 #ifdef HPCGAP
107 HashUnlock(0);
108 #endif
109
110 SET_TNAM_TNUM(tnum, name);
111 TypeObjFuncs[tnum] = typeObjFunc;
112
113 return tnum;
114 }
115
TNAM_TNUM(UInt tnum)116 const Char * TNAM_TNUM(UInt tnum)
117 {
118 return NameOfType[tnum];
119 }
120
SET_TNAM_TNUM(UInt tnum,const Char * name)121 void SET_TNAM_TNUM(UInt tnum, const Char *name)
122 {
123 GAP_ASSERT(NameOfType[tnum] == 0);
124 NameOfType[tnum] = name;
125 }
126
127
128 /****************************************************************************
129 **
130 *F FuncFAMILY_TYPE( <self>, <type> ) . . . . . . handler for 'FAMILY_TYPE'
131 */
FuncFAMILY_TYPE(Obj self,Obj type)132 static Obj FuncFAMILY_TYPE(Obj self, Obj type)
133 {
134 return FAMILY_TYPE( type );
135 }
136
137
138 /****************************************************************************
139 **
140 *F FuncFAMILY_OBJ( <self>, <obj> ) . . . . . . . handler for 'FAMILY_OBJ'
141 */
FuncFAMILY_OBJ(Obj self,Obj obj)142 static Obj FuncFAMILY_OBJ(Obj self, Obj obj)
143 {
144 return FAMILY_OBJ( obj );
145 }
146
147
148 /****************************************************************************
149 **
150 *F TYPE_OBJ( <obj> ) . . . . . . . . . . . . . . . . . . . type of an object
151 **
152 ** 'TYPE_OBJ' returns the type of the object <obj>.
153 **
154 ** 'TYPE_OBJ' is defined in the declaration part of this package.
155 */
156 Obj (*TypeObjFuncs[LAST_REAL_TNUM+1]) ( Obj obj );
157
TypeObjError(Obj obj)158 static Obj TypeObjError(Obj obj)
159 {
160 ErrorQuit( "Panic: basic object of type '%s' is unkind",
161 (Int)TNAM_OBJ(obj), 0L );
162 return 0;
163 }
164
165 /****************************************************************************
166 **
167 *F SET_TYPE_OBJ( <obj> ) . . . . . . . . . . . . . . set type of an object
168 **
169 ** 'SET_TYPE_OBJ' sets the type of the object <obj>.
170 */
171
172 void (*SetTypeObjFuncs[ LAST_REAL_TNUM+1 ]) ( Obj obj, Obj type );
173
SetTypeObjError(Obj obj,Obj type)174 static void SetTypeObjError(Obj obj, Obj type)
175 {
176 ErrorQuit( "Panic: cannot change type of object of type '%s'",
177 (Int)TNAM_OBJ(obj), 0L );
178 }
179
180
181 /****************************************************************************
182 **
183 *F FuncTYPE_OBJ( <self>, <obj> ) . . . . . . . . . handler for 'TYPE_OBJ'
184 */
185 #ifndef WARD_ENABLED
FuncTYPE_OBJ(Obj self,Obj obj)186 static Obj FuncTYPE_OBJ(Obj self, Obj obj)
187 {
188 return TYPE_OBJ( obj );
189 }
190 #endif
191
192 /****************************************************************************
193 **
194 *F FuncSET_TYPE_OBJ( <self>, <obj>, <type> ) . . handler for 'SET_TYPE_OBJ'
195 */
FuncSET_TYPE_OBJ(Obj self,Obj obj,Obj type)196 static Obj FuncSET_TYPE_OBJ(Obj self, Obj obj, Obj type)
197 {
198 SET_TYPE_OBJ( obj, type );
199 return (Obj) 0;
200 }
201
202
203
204 /****************************************************************************
205 **
206 *F IS_MUTABLE_OBJ( <obj> ) . . . . . . . . . . . . . . is an object mutable
207 **
208 ** 'IS_MUTABLE_OBJ' returns 1 if the object <obj> is mutable (i.e., can
209 ** change due to assignments), and 0 otherwise.
210 **
211 ** 'IS_MUTABLE_OBJ' is defined in the declaration part of this package.
212 */
213 Int (*IsMutableObjFuncs[LAST_REAL_TNUM+1]) ( Obj obj );
214
215 static Obj IsMutableObjFilt;
216
IsMutableObjError(Obj obj)217 static Int IsMutableObjError(Obj obj)
218 {
219 ErrorQuit(
220 "Panic: tried to test mutability of unsupported type '%s'",
221 (Int)TNAM_OBJ(obj), 0L );
222 return 0;
223 }
224
IsMutableObjObject(Obj obj)225 static Int IsMutableObjObject(Obj obj)
226 {
227 #ifdef HPCGAP
228 if (RegionBag(obj) == ReadOnlyRegion)
229 return 0;
230 #endif
231 return (DoFilter( IsMutableObjFilt, obj ) == True);
232 }
233
234
235 /****************************************************************************
236 **
237 *F FiltIS_MUTABLE_OBJ( <self>, <obj> ) . . . handler for 'IS_MUTABLE_OBJ'
238 */
FiltIS_MUTABLE_OBJ(Obj self,Obj obj)239 static Obj FiltIS_MUTABLE_OBJ(Obj self, Obj obj)
240 {
241 return (IS_MUTABLE_OBJ( obj ) ? True : False);
242 }
243
244 /****************************************************************************
245 **
246 *F FiltIS_INTERNALLY_MUTABLE_OBJ(<self>, <obj>)
247 */
248
249 #ifdef HPCGAP
250
251 static Obj IsInternallyMutableObjFilt;
252
FiltIS_INTERNALLY_MUTABLE_OBJ(Obj self,Obj obj)253 static Obj FiltIS_INTERNALLY_MUTABLE_OBJ(Obj self, Obj obj)
254 {
255 return (TNUM_OBJ(obj) == T_DATOBJ &&
256 RegionBag(obj) != ReadOnlyRegion &&
257 DoFilter( IsInternallyMutableObjFilt, obj) == True) ? True : False;
258 }
259
IsInternallyMutableObj(Obj obj)260 Int IsInternallyMutableObj(Obj obj) {
261 return TNUM_OBJ(obj) == T_DATOBJ &&
262 RegionBag(obj) != ReadOnlyRegion &&
263 DoFilter( IsInternallyMutableObjFilt, obj) == True;
264 }
265
266 #endif
267
268
269 /****************************************************************************
270 **
271 *F IS_COPYABLE_OBJ(<obj>) . . . . . . . . . . . . . . is an object copyable
272 **
273 ** 'IS_COPYABLE_OBJ' returns 1 if the object <obj> is copyable (i.e., can be
274 ** copied into a mutable object), and 0 otherwise.
275 **
276 ** 'IS_COPYABLE_OBJ' is defined in the declaration part of this package.
277 */
278 Int (*IsCopyableObjFuncs[LAST_REAL_TNUM+1]) ( Obj obj );
279
280 static Obj IsCopyableObjFilt;
281
IsCopyableObjError(Obj obj)282 static Int IsCopyableObjError(Obj obj)
283 {
284 ErrorQuit(
285 "Panic: tried to test copyability of unsupported type '%s'",
286 (Int)TNAM_OBJ(obj), 0L );
287 return 0L;
288 }
289
IsCopyableObjObject(Obj obj)290 static Int IsCopyableObjObject(Obj obj)
291 {
292 return (DoFilter( IsCopyableObjFilt, obj ) == True);
293 }
294
295
296 /****************************************************************************
297 **
298 *F FiltIS_COPYABLE_OBJ( <self>, <obj> ) . . . handler for 'IS_COPYABLE_OBJ'
299 */
FiltIS_COPYABLE_OBJ(Obj self,Obj obj)300 static Obj FiltIS_COPYABLE_OBJ(Obj self, Obj obj)
301 {
302 return (IS_COPYABLE_OBJ( obj ) ? True : False);
303 }
304
305
306 /****************************************************************************
307 **
308 *V ShallowCopyObjFuncs[<type>] . . . . . . . . . . shallow copier functions
309 */
310 Obj (*ShallowCopyObjFuncs[LAST_REAL_TNUM+1]) ( Obj obj );
311
312 static Obj ShallowCopyObjOper;
313
314
315 /****************************************************************************
316 **
317 *F ShallowCopyObjError( <obj> ) . . . . . . . . . . . . . . . unknown type
318 */
ShallowCopyObjError(Obj obj)319 static Obj ShallowCopyObjError(Obj obj)
320 {
321 ErrorQuit(
322 "Panic: tried to shallow copy object of unsupported type '%s'",
323 (Int)TNAM_OBJ(obj), 0L );
324 return (Obj)0;
325 }
326
327
328 /****************************************************************************
329 **
330 *F ShallowCopyObjConstant( <obj> ) . . . . . . . . . . . . . . . do nothing
331 */
ShallowCopyObjConstant(Obj obj)332 static Obj ShallowCopyObjConstant(Obj obj)
333 {
334 return obj;
335 }
336
337
338 /****************************************************************************
339 **
340 *F ShallowCopyObjObject( <obj> ) . . . . . . . . . . . . . . . . call method
341 */
ShallowCopyObjObject(Obj obj)342 static Obj ShallowCopyObjObject(Obj obj)
343 {
344 return DoOperation1Args( ShallowCopyObjOper, obj );
345 }
346
347
348 /****************************************************************************
349 **
350 *F ShallowCopyObjDefault( <obj> ) . . . . . . . . . . default shallow copy
351 */
ShallowCopyObjDefault(Obj obj)352 static Obj ShallowCopyObjDefault(Obj obj)
353 {
354 Obj new;
355 const Obj * o;
356 Obj * n;
357
358 /* make the new object and copy the contents */
359 new = NewBag( MUTABLE_TNUM(TNUM_OBJ(obj)), SIZE_OBJ(obj) );
360 o = CONST_ADDR_OBJ(obj);
361 n = ADDR_OBJ( new );
362 memcpy(n, o, SIZE_OBJ(obj) );
363
364 /* 'CHANGED_BAG(new);' not needed, <new> is newest object */
365 return new;
366 }
367
368
369 /****************************************************************************
370 **
371 *F ShallowCopyObjHandler( <self>, <obj> ) . handler for 'SHALLOW_COPY_OBJ'
372 */
ShallowCopyObjHandler(Obj self,Obj obj)373 static Obj ShallowCopyObjHandler(Obj self, Obj obj)
374 {
375 return SHALLOW_COPY_OBJ( obj );
376 }
377
378
379 /****************************************************************************
380 **
381 *F CopyObj( <obj>, <mut> ) . . . . . . . make a structural copy of an object
382 **
383 ** 'CopyObj' only calls 'COPY_OBJ' and then 'CLEAN_OBJ'.
384 */
CopyObj(Obj obj,Int mut)385 Obj CopyObj (
386 Obj obj,
387 Int mut )
388 {
389 #ifdef USE_THREADSAFE_COPYING
390 return CopyReachableObjectsFrom(obj, 0, 0, !mut);
391 #else
392 Obj new; /* copy of <obj> */
393
394 /* make a copy */
395 new = COPY_OBJ( obj, mut );
396
397 /* clean up the marks */
398 CLEAN_OBJ( obj );
399
400 /* return the copy */
401 return new;
402 #endif
403 }
404
405
406 #if !defined(USE_THREADSAFE_COPYING)
407
408 /****************************************************************************
409 **
410 *V CopyObjFuncs[<type>] . . . . . . . . . . . . table of copying functions
411 */
412 Obj (*CopyObjFuncs[ LAST_REAL_TNUM+1 ]) ( Obj obj, Int mut );
413
414
415 /****************************************************************************
416 **
417 *V CleanObjFuncs[<type>] . . . . . . . . . . . . table of cleaning functions
418 */
419 void (*CleanObjFuncs[ LAST_REAL_TNUM+1 ]) ( Obj obj );
420
421
422 /****************************************************************************
423 **
424 *F PrepareCopy(<obj>,<copy>) . . . helper for use in CopyObjFuncs functions
425 **
426 */
PrepareCopy(Obj obj,Obj copy)427 void PrepareCopy(Obj obj, Obj copy)
428 {
429 // insert a forwarding pointer into <obj> which contains...
430 // - the value overwritten by this forwarding pointer,
431 // - a pointer to <copy>,
432 // - the TNUM of <obj>.
433 // Note that we cannot simply restore the overwritten value by copying
434 // the corresponding value from <copy>, as they may actually differ
435 // between original and copy (e.g. for objects, they point to the type;
436 // if making an immutable copy of a mutable object, the types will
437 // differ).
438 // Likewise, the TNUM of the copy and the original can and will differ;
439 // e.g. for a weak pointer list, the copy can be a plist.
440 Obj tmp = NEW_PLIST(T_PLIST, 3);
441 SET_LEN_PLIST(tmp, 3);
442 SET_ELM_PLIST(tmp, 1, CONST_ADDR_OBJ(obj)[0]);
443 SET_ELM_PLIST(tmp, 2, copy);
444 SET_ELM_PLIST(tmp, 3, INTOBJ_INT(TNUM_OBJ(obj)));
445
446 // insert the forwarding pointer
447 GAP_ASSERT(SIZE_OBJ(obj) >= sizeof(Obj));
448 ADDR_OBJ(obj)[0] = tmp;
449 CHANGED_BAG(obj);
450
451 // update the TNUM to indicate the object is being copied
452 RetypeBag(obj, T_COPYING);
453 }
454
455
456 /****************************************************************************
457 **
458 *F COPY_OBJ(<obj>) . . . . . . . . . . . make a structural copy of an object
459 **
460 ** 'COPY_OBJ' implements the first pass of 'CopyObj', i.e., it makes the
461 ** structural copy of <obj> and marks <obj> as already copied.
462 */
COPY_OBJ(Obj obj,Int mut)463 Obj COPY_OBJ(Obj obj, Int mut)
464 {
465 UInt tnum = TNUM_OBJ(obj);
466 Obj copy;
467
468 if (tnum == T_COPYING) {
469 // get the plist reference by the forwarding pointer
470 Obj fpl = CONST_ADDR_OBJ(obj)[0];
471
472 // return pointer to the copy
473 copy = ELM_PLIST(fpl, 2);
474 }
475 else if (!IS_MUTABLE_OBJ(obj)) {
476 copy = obj;
477 }
478 else {
479 copy = (*CopyObjFuncs[tnum])(obj, mut);
480 }
481 return copy;
482 }
483
484
485 /****************************************************************************
486 **
487 *F CLEAN_OBJ(<obj>) . . . . . . . . . . . . . clean up object after copying
488 **
489 ** 'CLEAN_OBJ' implements the second pass of 'CopyObj', i.e., it removes the
490 ** mark from <obj>.
491 */
CLEAN_OBJ(Obj obj)492 void CLEAN_OBJ(Obj obj)
493 {
494 if (TNUM_OBJ(obj) != T_COPYING)
495 return;
496
497 // get the plist reference by the forwarding pointer
498 Obj fpl = CONST_ADDR_OBJ(obj)[0];
499
500 // remove the forwarding pointer
501 ADDR_OBJ(obj)[0] = ELM_PLIST(fpl, 1);
502 CHANGED_BAG(obj);
503
504 // restore the tnum
505 UInt tnum = INT_INTOBJ(ELM_PLIST(fpl, 3));
506 RetypeBag(obj, tnum);
507
508 // invoke type specific cleanup, if any
509 if (CleanObjFuncs[tnum])
510 CleanObjFuncs[tnum](obj);
511 }
512
513 #if !defined(USE_THREADSAFE_COPYING) && !defined(USE_BOEHM_GC)
514
MarkCopyingSubBags(Obj obj)515 static void MarkCopyingSubBags(Obj obj)
516 {
517 Obj fpl = CONST_ADDR_OBJ(obj)[0];
518
519 // mark the forwarding pointer
520 MarkBag(fpl);
521
522 // mark the rest as in the non-copied case
523 UInt tnum = INT_INTOBJ(ELM_PLIST(fpl, 3));
524 TabMarkFuncBags[tnum](obj);
525 }
526
527 #endif
528
529
530 /****************************************************************************
531 **
532 *F CopyObjError( <obj> ) . . . . . . . . . . . . . . . . . . . unknown type
533 */
CopyObjError(Obj obj,Int mut)534 static Obj CopyObjError(Obj obj, Int mut)
535 {
536 ErrorQuit(
537 "Panic: tried to copy object of unsupported type '%s'",
538 (Int)TNAM_OBJ(obj), 0L );
539 return (Obj)0;
540 }
541
542
543 /****************************************************************************
544 **
545 *F CleanObjError( <obj> ) . . . . . . . . . . . . . . . . . . unknown type
546 */
CleanObjError(Obj obj)547 static void CleanObjError(Obj obj)
548 {
549 ErrorQuit(
550 "Panic: tried to clean object of unsupported type '%s'",
551 (Int)TNAM_OBJ(obj), 0L );
552 }
553
554
555 /****************************************************************************
556 **
557 *F CopyObjConstant( <obj> ) . . . . . . . . . . . . copy a constant object
558 */
CopyObjConstant(Obj obj,Int mut)559 static Obj CopyObjConstant(Obj obj, Int mut)
560 {
561 return obj;
562 }
563
564
565 /****************************************************************************
566 **
567 *F CopyObjPosObj( <obj>, <mut> ) . . . . . . . . . copy a positional object
568 */
CopyObjPosObj(Obj obj,Int mut)569 static Obj CopyObjPosObj(Obj obj, Int mut)
570 {
571 Obj copy; /* copy, result */
572 Obj tmp; /* temporary variable */
573 UInt i; /* loop variable */
574
575 // immutable input is handled by COPY_OBJ
576 GAP_ASSERT(IS_MUTABLE_OBJ(obj));
577
578 /* if the object is not copyable return */
579 if ( ! IS_COPYABLE_OBJ(obj) ) {
580 ErrorQuit("Panic: encountered mutable, non-copyable object",0L,0L);
581 }
582
583 /* make a copy */
584 copy = NewBag( TNUM_OBJ(obj), SIZE_OBJ(obj) );
585 ADDR_OBJ(copy)[0] = CONST_ADDR_OBJ(obj)[0];
586 if ( !mut ) {
587 CALL_2ARGS( RESET_FILTER_OBJ, copy, IsMutableObjFilt );
588 }
589
590 /* leave a forwarding pointer */
591 PrepareCopy(obj, copy);
592
593 /* copy the subvalues */
594 for ( i = 1; i < SIZE_OBJ(obj)/sizeof(Obj); i++ ) {
595 if (CONST_ADDR_OBJ(obj)[i] != 0) {
596 tmp = COPY_OBJ(CONST_ADDR_OBJ(obj)[i], mut);
597 ADDR_OBJ(copy)[i] = tmp;
598 CHANGED_BAG( copy );
599 }
600 }
601
602 /* return the copy */
603 return copy;
604 }
605
606
607 /****************************************************************************
608 **
609 *F CleanObjPosObj( <obj> ) . . . . . . . . . . . . . . . . . . clean posobj
610 */
CleanObjPosObj(Obj obj)611 static void CleanObjPosObj(Obj obj)
612 {
613 UInt i; /* loop variable */
614
615 /* clean the subvalues */
616 for ( i = 1; i < SIZE_OBJ(obj)/sizeof(Obj); i++ ) {
617 if (CONST_ADDR_OBJ(obj)[i] != 0)
618 CLEAN_OBJ(CONST_ADDR_OBJ(obj)[i]);
619 }
620
621 }
622
623
624 /****************************************************************************
625 **
626 *F CopyObjComObj( <obj>, <mut> ) . . . . . . . . . . . . . . . copy a comobj
627 */
CopyObjComObj(Obj obj,Int mut)628 static Obj CopyObjComObj(Obj obj, Int mut)
629 {
630 Obj copy; /* copy, result */
631 Obj tmp; /* temporary variable */
632
633 // immutable input is handled by COPY_OBJ
634 GAP_ASSERT(IS_MUTABLE_OBJ(obj));
635
636 /* if the object is not copyable return */
637 if ( ! IS_COPYABLE_OBJ(obj) ) {
638 ErrorQuit("Panic: encountered mutable, non-copyable object",0L,0L);
639 }
640
641 /* make a copy */
642 copy = NewBag( TNUM_OBJ(obj), SIZE_OBJ(obj) );
643 memcpy(ADDR_OBJ(copy), CONST_ADDR_OBJ(obj), SIZE_OBJ(obj));
644 if ( !mut ) {
645 CALL_2ARGS( RESET_FILTER_OBJ, copy, IsMutableObjFilt );
646 }
647
648 /* leave a forwarding pointer */
649 PrepareCopy(obj, copy);
650
651 // copy the subvalues; since we used memcpy above, we don't need to worry
652 // about copying the length or RNAMs; and by working solely inside the
653 // copy, we avoid triggering tnum assertions in GET_ELM_PREC and
654 // SET_ELM_PREC
655 const UInt len = LEN_PREC(copy);
656 for (UInt i = 1; i <= len; i++) {
657 tmp = COPY_OBJ(GET_ELM_PREC(copy, i), mut);
658 SET_ELM_PREC(copy, i, tmp);
659 CHANGED_BAG(copy);
660 }
661
662 /* return the copy */
663 return copy;
664 }
665
666
667 /****************************************************************************
668 **
669 *F CleanObjComObj( <obj> ) . . . . . . . . . . . . . . . . . clean a comobj
670 */
CleanObjComObj(Obj obj)671 static void CleanObjComObj(Obj obj)
672 {
673 UInt i; /* loop variable */
674
675 /* clean the subvalues */
676 for ( i = 1; i <= LEN_PREC(obj); i++ ) {
677 CLEAN_OBJ( GET_ELM_PREC(obj,i) );
678 }
679
680 }
681
682
683 /****************************************************************************
684 **
685 *F CopyObjDatObj( <obj>, <mut> ) . . . . . . . . . . . . . . . copy a datobj
686 */
CopyObjDatObj(Obj obj,Int mut)687 static Obj CopyObjDatObj(Obj obj, Int mut)
688 {
689 Obj copy; /* copy, result */
690
691 // immutable input is handled by COPY_OBJ
692 GAP_ASSERT(IS_MUTABLE_OBJ(obj));
693
694 /* if the object is not copyable return */
695 if ( ! IS_COPYABLE_OBJ(obj) ) {
696 ErrorQuit("Panic: encountered mutable, non-copyable object",0L,0L);
697 }
698
699 /* make a copy */
700 copy = NewBag( TNUM_OBJ(obj), SIZE_OBJ(obj) );
701 memcpy(ADDR_OBJ(copy), CONST_ADDR_OBJ(obj), SIZE_OBJ(obj));
702 if ( !mut ) {
703 CALL_2ARGS( RESET_FILTER_OBJ, copy, IsMutableObjFilt );
704 }
705
706 /* leave a forwarding pointer */
707 PrepareCopy(obj, copy);
708
709 /* return the copy */
710 return copy;
711 }
712
713
714 /****************************************************************************
715 **
716 *F CleanObjDatObj( <obj> ) . . . . . . . . . . . . . . . . . clean a datobj
717 */
CleanObjDatObj(Obj obj)718 static void CleanObjDatObj(Obj obj)
719 {
720 }
721
722 #endif // !defined(USE_THREADSAFE_COPYING)
723
724 /****************************************************************************
725 **
726 *F FuncIMMUTABLE_COPY_OBJ( <self>, <obj> ) . . . . immutable copy of <obj>
727 */
FuncIMMUTABLE_COPY_OBJ(Obj self,Obj obj)728 static Obj FuncIMMUTABLE_COPY_OBJ(Obj self, Obj obj)
729 {
730 return CopyObj( obj, 0 );
731 }
732
733
734 /****************************************************************************
735 **
736 *F FuncDEEP_COPY_OBJ( <self>, <obj> ) . . . . . . mutable copy of <obj>
737 */
FuncDEEP_COPY_OBJ(Obj self,Obj obj)738 static Obj FuncDEEP_COPY_OBJ(Obj self, Obj obj)
739 {
740 return CopyObj( obj, 1 );
741 }
742
743 /****************************************************************************
744 **
745 *F MakeImmutable( <obj> . . . . . . . . . . make an object immutable inplace
746 **
747 ** Mark an object and all subobjects immutable in-place.
748 ** May cause confusion if there are shared subobjects
749 **
750 */
751
752 static Obj PostMakeImmutableOp = 0;
753
754 void (*MakeImmutableObjFuncs[LAST_REAL_TNUM+1])( Obj );
755
756
MakeImmutable(Obj obj)757 void MakeImmutable( Obj obj )
758 {
759 if (IS_MUTABLE_OBJ( obj ))
760 {
761 (*(MakeImmutableObjFuncs[TNUM_OBJ(obj)]))(obj);
762 }
763 }
764
765 #ifdef HPCGAP
CheckedMakeImmutable(Obj obj)766 void CheckedMakeImmutable( Obj obj )
767 {
768 if (!PreMakeImmutableCheck(obj))
769 ErrorMayQuit("MakeImmutable: Argument has inaccessible subobjects", 0, 0);
770 MakeImmutable(obj);
771 }
772 #endif
773
MakeImmutableError(Obj obj)774 static void MakeImmutableError(Obj obj)
775 {
776 ErrorQuit("No make immutable function installed for a %s",
777 (Int)TNAM_OBJ(obj), 0L);
778 }
779
780
MakeImmutableComObj(Obj obj)781 static void MakeImmutableComObj(Obj obj)
782 {
783 CALL_2ARGS( RESET_FILTER_OBJ, obj, IsMutableObjFilt );
784 CALL_1ARGS( PostMakeImmutableOp, obj);
785 }
786
MakeImmutablePosObj(Obj obj)787 static void MakeImmutablePosObj(Obj obj)
788 {
789 CALL_2ARGS( RESET_FILTER_OBJ, obj, IsMutableObjFilt );
790 CALL_1ARGS( PostMakeImmutableOp, obj);
791
792 }
793
794 #ifdef HPCGAP
795 // HPCGAP-HACK:
796 // There is a considerable amount of library code that currently
797 // relies on being able to modify immutable data objects; in order
798 // to not break all of that, MakeImmutableDatObj() makes immutable
799 // data objects public, not read-only if they are not internally
800 // mutable. Note that this is potentially unsafe if these objects
801 // are shared between threads and then modified by kernel code.
802 //
803 // By setting the environment variable GAP_READONLY_DATOBJS, one
804 // can restore the old behavior in order to find and debug the
805 // offending code.
806 static int ReadOnlyDatObjs = 0;
807 #endif
808
MakeImmutableDatObj(Obj obj)809 static void MakeImmutableDatObj(Obj obj)
810 {
811 CALL_2ARGS( RESET_FILTER_OBJ, obj, IsMutableObjFilt );
812 #ifdef HPCGAP
813 if (!IsInternallyMutableObj(obj)) {
814 if (ReadOnlyDatObjs)
815 MakeBagReadOnly(obj);
816 else
817 MakeBagPublic(obj);
818 }
819 #endif
820 }
821
FuncMakeImmutable(Obj self,Obj obj)822 static Obj FuncMakeImmutable(Obj self, Obj obj)
823 {
824 #ifdef HPCGAP
825 CheckedMakeImmutable(obj);
826 #else
827 MakeImmutable(obj);
828 #endif
829 return obj;
830 }
831
832
833
834 // This function is used to keep track of which objects are already
835 // being printed or viewed to trigger the use of ~ when needed.
IS_ON_PRINT_STACK(const ObjectsModuleState * os,Obj obj)836 static inline UInt IS_ON_PRINT_STACK(const ObjectsModuleState * os, Obj obj)
837 {
838 UInt i;
839 if (!(FIRST_RECORD_TNUM <= TNUM_OBJ(obj)
840 && TNUM_OBJ(obj) <= LAST_LIST_TNUM))
841 return 0;
842 for (i = 1; i < os->PrintObjDepth; i++)
843 if (os->PrintObjThiss[i-1] == obj)
844 return 1;
845 return 0;
846 }
847
848 #ifdef HPCGAP
PrintInaccessibleObject(Obj obj)849 static void PrintInaccessibleObject(Obj obj)
850 {
851 Char buffer[20];
852 Char *name;
853 Region *region;
854 Obj nameobj;
855
856 region = REGION(obj);
857 if (!region)
858 nameobj = PublicRegionName; /* this should not happen, but let's be safe */
859 else
860 nameobj = GetRegionName(region);
861 if (nameobj) {
862 name = CSTR_STRING(nameobj);
863 } else {
864 sprintf(buffer, "%p", (void *)region);
865 name = buffer;
866 Pr("<protected object in shared region %s (id: %d)>", (Int) name, (Int) obj);
867 return;
868 }
869 Pr("<protected '%s' object (id: %d)>", (Int) name, (Int) obj);
870 }
871 #endif
872
873 #ifdef HPCGAP
874 /* On-demand creation of the PrintObj stack */
InitPrintObjStack(ObjectsModuleState * os)875 static void InitPrintObjStack(ObjectsModuleState * os)
876 {
877 if (!os->PrintObjThiss) {
878 os->PrintObjThissObj = NewBag(T_DATOBJ, MAXPRINTDEPTH*sizeof(Obj)+sizeof(Obj));
879 os->PrintObjThiss = ADDR_OBJ(os->PrintObjThissObj)+1;
880 os->PrintObjIndicesObj = NewBag(T_DATOBJ, MAXPRINTDEPTH*sizeof(Int)+sizeof(Obj));
881 os->PrintObjIndices = (Int *)(ADDR_OBJ(os->PrintObjIndicesObj)+1);
882 }
883 }
884 #endif
885
886 /****************************************************************************
887 **
888 *F PrintObj( <obj> ) . . . . . . . . . . . . . . . . . . . . print an object
889 **
890 ** 'PrintObj' prints the object <obj>.
891 */
PrintObj(Obj obj)892 void PrintObj (
893 Obj obj )
894 {
895 Int i; /* loop variable */
896 UInt lastPV; /* save LastPV */
897 UInt fromview; /* non-zero when we were called
898 from viewObj of the SAME object */
899
900 #if defined(HPCGAP) && !defined(WARD_ENABLED)
901 if (IS_BAG_REF(obj) && !CheckReadAccess(obj)) {
902 PrintInaccessibleObject(obj);
903 return;
904 }
905 #endif
906
907 ObjectsModuleState * os = &MODULE_STATE(Objects);
908
909 /* First check if <obj> is actually the current object being Viewed
910 Since ViewObj(<obj>) may result in a call to PrintObj(<obj>) */
911
912 lastPV = os->LastPV;
913 os->LastPV = 1;
914 fromview = (lastPV == 2) && (obj == os->PrintObjThis);
915
916 /* if <obj> is a subobject, then mark and remember the superobject
917 unless ViewObj has done that job already */
918
919 #ifdef HPCGAP
920 InitPrintObjStack(os);
921 #endif
922
923 if ( !fromview && 0 < os->PrintObjDepth ) {
924 os->PrintObjThiss[os->PrintObjDepth-1] = os->PrintObjThis;
925 os->PrintObjIndices[os->PrintObjDepth-1] = os->PrintObjIndex;
926 }
927
928 /* handle the <obj> */
929 if (!fromview) {
930 os->PrintObjDepth += 1;
931 os->PrintObjThis = obj;
932 os->PrintObjIndex = 0;
933 }
934
935 /* dispatch to the appropriate printing function */
936 if ( (! IS_ON_PRINT_STACK(os, os->PrintObjThis)) ) {
937 if (os->PrintObjDepth < MAXPRINTDEPTH) {
938 (*PrintObjFuncs[ TNUM_OBJ(os->PrintObjThis) ])( os->PrintObjThis );
939 }
940 else {
941 /* don't recurse if depth too high */
942 Pr("\nprinting stopped, too many recursion levels!\n", 0L, 0L);
943 }
944 }
945
946 /* or print the path */
947 else {
948 Pr( "~", 0L, 0L );
949 for ( i = 0; os->PrintObjThis != os->PrintObjThiss[i]; i++ ) {
950 (*PrintPathFuncs[ TNUM_OBJ(os->PrintObjThiss[i])])
951 ( os->PrintObjThiss[i], os->PrintObjIndices[i] );
952 }
953 }
954
955
956 /* done with <obj> */
957 if (!fromview) {
958 os->PrintObjDepth -= 1;
959
960 /* if <obj> is a subobject, then restore and unmark the superobject*/
961 if ( 0 < os->PrintObjDepth ) {
962 os->PrintObjThis = os->PrintObjThiss[os->PrintObjDepth-1];
963 os->PrintObjIndex = os->PrintObjIndices[os->PrintObjDepth-1];
964 }
965 }
966 os->LastPV = lastPV;
967 }
968
969
970 /****************************************************************************
971 **
972 *V PrintObjFuncs[<type>] . . . . . . . . printer for objects of type <type>
973 **
974 ** 'PrintObjFuncs' is the dispatch table that contains for every type of
975 ** objects a pointer to the printer for objects of this type. The printer
976 ** is the function '<func>(<obj>)' that should be called to print the object
977 ** <obj> of this type.
978 */
979 void (* PrintObjFuncs [ LAST_REAL_TNUM +1 ])( Obj obj );
980
981
982 /****************************************************************************
983 **
984 *F PrintObjObject( <obj> ) . . . . . . . . . . . . . . . . . print an object
985 */
986 Obj PrintObjOper;
987
PrintObjObject(Obj obj)988 static void PrintObjObject(Obj obj)
989 {
990 DoOperation1Args( PrintObjOper, obj );
991 }
992
993
994 /****************************************************************************
995 **
996 *F PrintObjHandler( <self>, <obj> ) . . . . . . . . handler for 'PrintObj'
997 */
PrintObjHandler(Obj self,Obj obj)998 static Obj PrintObjHandler(Obj self, Obj obj)
999 {
1000 PrintObj( obj );
1001 return 0L;
1002 }
1003
SetPrintObjState(UInt state)1004 UInt SetPrintObjState(UInt state)
1005 {
1006 UInt oldDepth = MODULE_STATE(Objects).PrintObjDepth;
1007 UInt oldLastPV = MODULE_STATE(Objects).LastPV;
1008 MODULE_STATE(Objects).PrintObjDepth = state >> 2;
1009 MODULE_STATE(Objects).LastPV = state & 3;
1010 return (oldDepth << 2) | oldLastPV;
1011 }
1012
SetPrintObjIndex(Int index)1013 void SetPrintObjIndex(Int index)
1014 {
1015 MODULE_STATE(Objects).PrintObjIndex = index;
1016 }
1017
FuncSET_PRINT_OBJ_INDEX(Obj self,Obj index)1018 static Obj FuncSET_PRINT_OBJ_INDEX(Obj self, Obj index)
1019 {
1020 SetPrintObjIndex(GetSmallInt("SET_PRINT_OBJ_INDEX", index));
1021 return 0;
1022 }
1023
1024
1025 /****************************************************************************
1026 **
1027 *F ViewObj( <obj> ) . . . . . . . . . . . . . . . . . . . . . view an object
1028 **
1029 ** 'ViewObj' views the object <obj>.
1030 **
1031 ** ViewObj shares all the associated variables with PrintObj, so that
1032 ** recursion works nicely.
1033 */
1034
1035 static Obj ViewObjOper;
1036
ViewObj(Obj obj)1037 void ViewObj (
1038 Obj obj )
1039 {
1040 Int i; /* loop variable */
1041 UInt lastPV;
1042
1043 /* No check for interrupts here, viewing should not take so long that
1044 it is necessary */
1045
1046 #if defined(HPCGAP) && !defined(WARD_ENABLED)
1047 if (IS_BAG_REF(obj) && !CheckReadAccess(obj)) {
1048 PrintInaccessibleObject(obj);
1049 return;
1050 }
1051 #endif
1052
1053 ObjectsModuleState * os = &MODULE_STATE(Objects);
1054
1055 lastPV = os->LastPV;
1056 os->LastPV = 2;
1057
1058 /* if <obj> is a subobject, then mark and remember the superobject */
1059
1060 #ifdef HPCGAP
1061 InitPrintObjStack(os);
1062 #endif
1063
1064 if ( 0 < os->PrintObjDepth ) {
1065 os->PrintObjThiss[os->PrintObjDepth-1] = os->PrintObjThis;
1066 os->PrintObjIndices[os->PrintObjDepth-1] = os->PrintObjIndex;
1067 }
1068
1069 /* handle the <obj> */
1070 os->PrintObjDepth += 1;
1071 os->PrintObjThis = obj;
1072 os->PrintObjIndex = 0;
1073
1074 /* dispatch to the appropriate viewing function */
1075
1076 if ( ! IS_ON_PRINT_STACK(os, os->PrintObjThis) ) {
1077 if (os->PrintObjDepth < MAXPRINTDEPTH) {
1078 DoOperation1Args( ViewObjOper, obj );
1079 }
1080 else {
1081 /* don't recurse any more */
1082 Pr("\nviewing stopped, too many recursion levels!\n", 0L, 0L);
1083 }
1084 }
1085
1086 /* or view the path */
1087 else {
1088 Pr( "~", 0L, 0L );
1089 for ( i = 0; os->PrintObjThis != os->PrintObjThiss[i]; i++ ) {
1090 (*PrintPathFuncs[ TNUM_OBJ(os->PrintObjThiss[i]) ])
1091 ( os->PrintObjThiss[i], os->PrintObjIndices[i] );
1092 }
1093 }
1094
1095 /* done with <obj> */
1096 os->PrintObjDepth -= 1;
1097
1098 /* if <obj> is a subobject, then restore and unmark the superobject */
1099 if ( 0 < os->PrintObjDepth ) {
1100 os->PrintObjThis = os->PrintObjThiss[os->PrintObjDepth-1];
1101 os->PrintObjIndex = os->PrintObjIndices[os->PrintObjDepth-1];
1102 }
1103
1104 os->LastPV = lastPV;
1105 }
1106
1107
1108 /****************************************************************************
1109 **
1110 *F FuncViewObj( <self>, <obj> ) . . . . . . . . handler for 'ViewObj'
1111 */
FuncViewObj(Obj self,Obj obj)1112 static Obj FuncViewObj(Obj self, Obj obj)
1113 {
1114 ViewObj( obj );
1115 return 0L;
1116 }
1117
1118
1119 /****************************************************************************
1120 **
1121 *V PrintPathFuncs[<type>] . . . . . . printer for subobjects of type <type>
1122 **
1123 ** 'PrintPathFuncs' is the dispatch table that contains for every
1124 ** appropriate type of objects a pointer to the path printer for objects of
1125 ** that type. The path printer is the function '<func>(<obj>,<indx>)' that
1126 ** should be called to print the selector that selects the <indx>-th
1127 ** subobject of the object <obj> of this type.
1128 */
1129 void (* PrintPathFuncs [ LAST_REAL_TNUM /* +PRINTING */+1 ])( Obj obj, Int indx );
1130
PrintPathError(Obj obj,Int indx)1131 static void PrintPathError(Obj obj, Int indx)
1132 {
1133 ErrorQuit(
1134 "Panic: tried to print a path of unsupported type '%s'",
1135 (Int)TNAM_OBJ(obj), 0L );
1136 }
1137
1138
1139 /****************************************************************************
1140 **
1141 *F TypeComObj( <obj> ) . . . . . . . . . . function version of 'TYPE_COMOBJ'
1142 */
1143 #ifndef WARD_ENABLED
TypeComObj(Obj obj)1144 static Obj TypeComObj(Obj obj)
1145 {
1146 Obj result = TYPE_COMOBJ( obj );
1147 #ifdef HPCGAP
1148 MEMBAR_READ();
1149 #endif
1150 return result;
1151 }
1152
SetTypeComObj(Obj obj,Obj type)1153 static void SetTypeComObj(Obj obj, Obj type)
1154 {
1155 #ifdef HPCGAP
1156 ReadGuard(obj);
1157 MEMBAR_WRITE();
1158 #endif
1159 SET_TYPE_COMOBJ(obj, type);
1160 CHANGED_BAG(obj);
1161 }
1162 #endif
1163
1164
1165 /*****************************************************************************
1166 **
1167 *F FuncIS_COMOBJ( <self>, <obj> ) . . . . . . . . handler for 'IS_COMOBJ'
1168 */
FuncIS_COMOBJ(Obj self,Obj obj)1169 static Obj FuncIS_COMOBJ(Obj self, Obj obj)
1170 {
1171 #ifdef HPCGAP
1172 switch (TNUM_OBJ(obj)) {
1173 case T_COMOBJ:
1174 case T_ACOMOBJ:
1175 return True;
1176 default:
1177 return False;
1178 }
1179 #else
1180 return (TNUM_OBJ(obj) == T_COMOBJ ? True : False);
1181 #endif
1182 }
1183
1184
1185 /****************************************************************************
1186 **
1187 *F FuncSET_TYPE_COMOBJ( <self>, <obj>, <type> ) . . . 'SET_TYPE_COMOBJ'
1188 */
FuncSET_TYPE_COMOBJ(Obj self,Obj obj,Obj type)1189 static Obj FuncSET_TYPE_COMOBJ(Obj self, Obj obj, Obj type)
1190 {
1191 #ifdef HPCGAP
1192 switch (TNUM_OBJ(obj)) {
1193 case T_PREC:
1194 MEMBAR_WRITE();
1195 SET_TYPE_COMOBJ(obj, type);
1196 RetypeBag( obj, T_COMOBJ );
1197 CHANGED_BAG( obj );
1198 break;
1199 case T_COMOBJ:
1200 SetTypeComObj(obj, type);
1201 break;
1202 case T_AREC:
1203 case T_ACOMOBJ:
1204 SET_TYPE_OBJ( obj, type );
1205 RetypeBag( obj, T_ACOMOBJ );
1206 CHANGED_BAG( obj );
1207 break;
1208 default:
1209 ErrorMayQuit("You can't make component object from a %s.",
1210 (Int)TNAM_OBJ(obj), 0L);
1211 }
1212 #else
1213 if (TNUM_OBJ(obj) == T_PREC+IMMUTABLE)
1214 ErrorMayQuit(
1215 "You can't make a component object from an immutable object", 0L,
1216 0L);
1217 SET_TYPE_COMOBJ(obj, type);
1218 RetypeBag( obj, T_COMOBJ );
1219 CHANGED_BAG( obj );
1220 #endif
1221 return obj;
1222 }
1223
1224
1225 /****************************************************************************
1226 **
1227 *F AssComObj( <obj>, <rnam>, <val> )
1228 *F UnbComObj( <obj>, <rnam> )
1229 *F ElmComObj( <obj>, <rnam> )
1230 *F IsbComObj( <obj>, <rnam> )
1231 */
AssComObj(Obj obj,UInt rnam,Obj val)1232 void AssComObj(Obj obj, UInt rnam, Obj val)
1233 {
1234 switch (TNUM_OBJ(obj)) {
1235 case T_COMOBJ:
1236 AssPRec(obj, rnam, val);
1237 break;
1238 #ifdef HPCGAP
1239 case T_ACOMOBJ:
1240 SetARecordField(obj, rnam, val);
1241 break;
1242 #endif
1243 default:
1244 ASS_REC(obj, rnam, val);
1245 break;
1246 }
1247 }
1248
UnbComObj(Obj obj,UInt rnam)1249 void UnbComObj(Obj obj, UInt rnam)
1250 {
1251 switch (TNUM_OBJ(obj)) {
1252 case T_COMOBJ:
1253 UnbPRec(obj, rnam);
1254 break;
1255 #ifdef HPCGAP
1256 case T_ACOMOBJ:
1257 UnbARecord(obj, rnam);
1258 break;
1259 #endif
1260 default:
1261 UNB_REC(obj, rnam);
1262 break;
1263 }
1264 }
1265
ElmComObj(Obj obj,UInt rnam)1266 Obj ElmComObj(Obj obj, UInt rnam)
1267 {
1268 switch (TNUM_OBJ(obj)) {
1269 case T_COMOBJ:
1270 return ElmPRec(obj, rnam);
1271 #ifdef HPCGAP
1272 case T_ACOMOBJ:
1273 return ElmARecord(obj, rnam);
1274 #endif
1275 default:
1276 return ELM_REC(obj, rnam);
1277 }
1278 }
1279
IsbComObj(Obj obj,UInt rnam)1280 Int IsbComObj(Obj obj, UInt rnam)
1281 {
1282 switch (TNUM_OBJ(obj)) {
1283 case T_COMOBJ:
1284 return IsbPRec(obj, rnam);
1285 #ifdef HPCGAP
1286 case T_ACOMOBJ:
1287 return IsbARecord(obj, rnam);
1288 #endif
1289 default:
1290 return ISB_REC(obj, rnam);
1291 }
1292 }
1293
1294
1295 /****************************************************************************
1296 **
1297 *F TypePosObj( <obj> ) . . . . . . . . . . function version of 'TYPE_POSOBJ'
1298 */
1299 #ifndef WARD_ENABLED
TypePosObj(Obj obj)1300 static Obj TypePosObj(Obj obj)
1301 {
1302 Obj result = TYPE_POSOBJ( obj );
1303 #ifdef HPCGAP
1304 MEMBAR_READ();
1305 #endif
1306 return result;
1307 }
1308
SetTypePosObj(Obj obj,Obj type)1309 static void SetTypePosObj(Obj obj, Obj type)
1310 {
1311 #ifdef HPCGAP
1312 ReadGuard(obj);
1313 MEMBAR_WRITE();
1314 #endif
1315 SET_TYPE_POSOBJ(obj, type);
1316 CHANGED_BAG(obj);
1317 }
1318 #endif
1319
1320
1321 /****************************************************************************
1322 **
1323 *F FuncIS_POSOBJ( <self>, <obj> ) . . . . . . . handler for 'IS_POSOBJ'
1324 */
FuncIS_POSOBJ(Obj self,Obj obj)1325 static Obj FuncIS_POSOBJ(Obj self, Obj obj)
1326 {
1327 switch (TNUM_OBJ(obj)) {
1328 case T_POSOBJ:
1329 #ifdef HPCGAP
1330 case T_APOSOBJ:
1331 #endif
1332 return True;
1333 default:
1334 return False;
1335 }
1336 }
1337
1338
1339 /****************************************************************************
1340 **
1341 *F FuncSET_TYPE_POSOBJ( <self>, <obj>, <type> ) . . . 'SET_TYPE_POSOB'
1342 */
FuncSET_TYPE_POSOBJ(Obj self,Obj obj,Obj type)1343 static Obj FuncSET_TYPE_POSOBJ(Obj self, Obj obj, Obj type)
1344 {
1345 #ifdef HPCGAP
1346 switch (TNUM_OBJ(obj)) {
1347 case T_APOSOBJ:
1348 case T_ALIST:
1349 case T_FIXALIST:
1350 SET_TYPE_OBJ( obj, type );
1351 RetypeBag( obj, T_APOSOBJ );
1352 CHANGED_BAG( obj );
1353 break;
1354 case T_POSOBJ:
1355 SetTypePosObj( obj, type );
1356 break;
1357 default:
1358 MEMBAR_WRITE();
1359 SET_TYPE_POSOBJ(obj, type);
1360 RetypeBag( obj, T_POSOBJ );
1361 CHANGED_BAG( obj );
1362 break;
1363 }
1364 #else
1365 RetypeBag( obj, T_POSOBJ );
1366 SET_TYPE_POSOBJ(obj, type);
1367 CHANGED_BAG( obj );
1368 #endif
1369 return obj;
1370 }
1371
1372
1373 /****************************************************************************
1374 **
1375 *F FuncLEN_POSOBJ( <self>, <obj> ) . . . . . . handler for 'LEN_POSOBJ'
1376 */
FuncLEN_POSOBJ(Obj self,Obj obj)1377 static Obj FuncLEN_POSOBJ(Obj self, Obj obj)
1378 {
1379 #ifdef HPCGAP
1380 switch (TNUM_OBJ(obj)) {
1381 case T_APOSOBJ:
1382 case T_ALIST:
1383 case T_FIXALIST:
1384 return LengthAList( obj );
1385 }
1386 #endif
1387 return INTOBJ_INT( SIZE_OBJ(obj) / sizeof(Obj) - 1 );
1388 }
1389
1390
1391 /****************************************************************************
1392 **
1393 *F AssPosbj( <obj>, <rnam>, <val> )
1394 *F UnbPosbj( <obj>, <rnam> )
1395 *F ElmPosbj( <obj>, <rnam> )
1396 *F IsbPosbj( <obj>, <rnam> )
1397 */
AssPosObj(Obj obj,Int idx,Obj val)1398 void AssPosObj(Obj obj, Int idx, Obj val)
1399 {
1400 if (TNUM_OBJ(obj) == T_POSOBJ) {
1401 #ifdef HPCGAP
1402 // Because BindOnce() functions can reallocate the list even if they
1403 // only have read-only access, we have to be careful when accessing
1404 // positional objects. Hence the explicit WriteGuard().
1405 WriteGuard(obj);
1406 #endif
1407 if (SIZE_OBJ(obj) / sizeof(Obj) - 1 < idx) {
1408 ResizeBag(obj, (idx + 1) * sizeof(Obj));
1409 }
1410 SET_ELM_PLIST(obj, idx, val);
1411 CHANGED_BAG(obj);
1412 }
1413 #ifdef HPCGAP
1414 else if (TNUM_OBJ(obj) == T_APOSOBJ) {
1415 AssListFuncs[T_FIXALIST](obj, idx, val);
1416 }
1417 #endif
1418 else {
1419 ASS_LIST(obj, idx, val);
1420 }
1421 }
1422
UnbPosObj(Obj obj,Int idx)1423 void UnbPosObj(Obj obj, Int idx)
1424 {
1425 if (TNUM_OBJ(obj) == T_POSOBJ) {
1426 #ifdef HPCGAP
1427 // Because BindOnce() functions can reallocate the list even if they
1428 // only have read-only access, we have to be careful when accessing
1429 // positional objects. Hence the explicit WriteGuard().
1430 WriteGuard(obj);
1431 #endif
1432 if (idx <= SIZE_OBJ(obj) / sizeof(Obj) - 1) {
1433 SET_ELM_PLIST(obj, idx, 0);
1434 }
1435 }
1436 #ifdef HPCGAP
1437 else if (TNUM_OBJ(obj) == T_APOSOBJ) {
1438 UnbListFuncs[T_FIXALIST](obj, idx);
1439 }
1440 #endif
1441 else {
1442 UNB_LIST(obj, idx);
1443 }
1444 }
1445
ElmPosObj(Obj obj,Int idx)1446 Obj ElmPosObj(Obj obj, Int idx)
1447 {
1448 Obj elm;
1449 if (TNUM_OBJ(obj) == T_POSOBJ) {
1450 #ifdef HPCGAP
1451 // Because BindOnce() functions can reallocate the list even if they
1452 // only have read-only access, we have to be careful when accessing
1453 // positional objects.
1454 const Bag * contents = CONST_PTR_BAG(obj);
1455 MEMBAR_READ(); /* essential memory barrier */
1456 if (SIZE_BAG_CONTENTS(contents) / sizeof(Obj) - 1 < idx) {
1457 ErrorMayQuit(
1458 "PosObj Element: <PosObj>![%d] must have an assigned value",
1459 (Int)idx, 0);
1460 }
1461 elm = contents[idx];
1462 #else
1463 if (SIZE_OBJ(obj) / sizeof(Obj) - 1 < idx) {
1464 ErrorMayQuit(
1465 "PosObj Element: <PosObj>![%d] must have an assigned value",
1466 (Int)idx, 0);
1467 }
1468 elm = ELM_PLIST(obj, idx);
1469 #endif
1470 if (elm == 0) {
1471 ErrorMayQuit(
1472 "PosObj Element: <PosObj>![%d] must have an assigned value",
1473 (Int)idx, 0);
1474 }
1475 }
1476 #ifdef HPCGAP
1477 else if (TNUM_OBJ(obj) == T_APOSOBJ) {
1478 elm = ElmListFuncs[T_FIXALIST](obj, idx);
1479 }
1480 #endif
1481 else {
1482 elm = ELM_LIST(obj, idx);
1483 }
1484 return elm;
1485 }
1486
IsbPosObj(Obj obj,Int idx)1487 Int IsbPosObj(Obj obj, Int idx)
1488 {
1489 Int isb;
1490 if (TNUM_OBJ(obj) == T_POSOBJ) {
1491 #ifdef HPCGAP
1492 // Because BindOnce() functions can reallocate the list even if they
1493 // only have read-only access, we have to be careful when accessing
1494 // positional objects.
1495 const Bag * contents = CONST_PTR_BAG(obj);
1496 if (idx > SIZE_BAG_CONTENTS(contents) / sizeof(Obj) - 1)
1497 isb = 0;
1498 else
1499 isb = contents[idx] != 0;
1500 #else
1501 isb = (idx <= SIZE_OBJ(obj) / sizeof(Obj) - 1 &&
1502 ELM_PLIST(obj, idx) != 0);
1503 #endif
1504 }
1505 #ifdef HPCGAP
1506 else if (TNUM_OBJ(obj) == T_APOSOBJ) {
1507 isb = IsbListFuncs[T_FIXALIST](obj, idx);
1508 }
1509 #endif
1510 else {
1511 isb = ISB_LIST(obj, idx);
1512 }
1513 return isb;
1514 }
1515
1516
1517 /****************************************************************************
1518 **
1519 *F TypeDatObj( <obj> ) . . . . . . . . . . function version of 'TYPE_DATOBJ'
1520 */
TypeDatObj(Obj obj)1521 static Obj TypeDatObj(Obj obj)
1522 {
1523 return TYPE_DATOBJ( obj );
1524 }
1525
SetTypeDatObj(Obj obj,Obj type)1526 void SetTypeDatObj( Obj obj, Obj type)
1527 {
1528 SET_TYPE_DATOBJ(obj, type);
1529 #ifdef HPCGAP
1530 if (TNUM_OBJ(obj) == T_DATOBJ &&
1531 !IsMutableObjObject(obj) && !IsInternallyMutableObj(obj)) {
1532 if (ReadOnlyDatObjs)
1533 MakeBagReadOnly(obj);
1534 else
1535 MakeBagPublic(obj);
1536 }
1537 #endif
1538 CHANGED_BAG(obj);
1539 }
1540
1541
1542 /*****************************************************************************
1543 **
1544 *F FuncIS_DATOBJ( <self>, <obj> ) . . . . . . . . handler for 'IS_DATOBJ'
1545 */
FuncIS_DATOBJ(Obj self,Obj obj)1546 static Obj FuncIS_DATOBJ(Obj self, Obj obj)
1547 {
1548 return (TNUM_OBJ(obj) == T_DATOBJ ? True : False);
1549 }
1550
1551
1552 /****************************************************************************
1553 **
1554 *F FuncSET_TYPE_DATOBJ( <self>, <obj>, <type> ) . . . 'SET_TYPE_DATOBJ'
1555 */
FuncSET_TYPE_DATOBJ(Obj self,Obj obj,Obj type)1556 static Obj FuncSET_TYPE_DATOBJ(Obj self, Obj obj, Obj type)
1557 {
1558 #ifndef WARD_ENABLED
1559 #ifdef HPCGAP
1560 ReadGuard( obj );
1561 #endif
1562 SET_TYPE_DATOBJ(obj, type);
1563 #ifdef HPCGAP
1564 if (TNUM_OBJ(obj) != T_DATOBJ)
1565 #endif
1566 RetypeBag( obj, T_DATOBJ );
1567 CHANGED_BAG( obj );
1568 return obj;
1569 #endif
1570 }
1571
1572
1573 /****************************************************************************
1574 **
1575 *F NewKernelBuffer( <size> ) . . . . . . . . . . return a new kernel buffer
1576 */
1577 static Obj TYPE_KERNEL_OBJECT;
1578
NewKernelBuffer(UInt size)1579 Obj NewKernelBuffer(UInt size)
1580 {
1581 Obj obj = NewBag(T_DATOBJ, size);
1582 SET_TYPE_DATOBJ(obj, TYPE_KERNEL_OBJECT);
1583 return obj;
1584 }
1585
1586
1587 /****************************************************************************
1588 **
1589 *F FuncIS_IDENTICAL_OBJ( <self>, <obj1>, <obj2> ) . . . . . handler for '=='
1590 **
1591 ** 'FuncIS_IDENTICAL_OBJ' implements 'IsIdentical'
1592 */
FuncIS_IDENTICAL_OBJ(Obj self,Obj obj1,Obj obj2)1593 static Obj FuncIS_IDENTICAL_OBJ(Obj self, Obj obj1, Obj obj2)
1594 {
1595 return (obj1 == obj2 ? True : False);
1596 }
1597
1598 /****************************************************************************
1599 **
1600 *V SaveObjFuncs (<type>) . . . . . . . . . . . . . functions to save objects
1601 **
1602 ** 'SaveObjFuncs' is the dispatch table that contains, for every type
1603 ** of objects, a pointer to the saving function for objects of that type
1604 ** These should not handle the file directly, but should work via the
1605 ** functions 'SaveSubObj', 'SaveUInt<n>' (<n> = 1,2,4 or 8), and others
1606 ** to be determined. Their role is to identify the C types of the various
1607 ** parts of the bag, and perhaps to leave out some information that does
1608 ** not need to be saved. By the time this function is called, the bag
1609 ** size and type have already been saved
1610 ** No saving function may allocate any bag
1611 */
1612
1613 void (*SaveObjFuncs[LAST_REAL_TNUM+1]) ( Obj obj );
1614
SaveObjError(Obj obj)1615 void SaveObjError( Obj obj )
1616 {
1617 ErrorQuit(
1618 "Panic: tried to save an object of unsupported type '%s'",
1619 (Int)TNAM_OBJ(obj), 0L );
1620 }
1621
1622
1623 /****************************************************************************
1624 **
1625 *V LoadObjFuncs (<type>) . . . . . . . . . . . . . functions to load objects
1626 **
1627 ** 'LoadObjFuncs' is the dispatch table that contains, for every type
1628 ** of objects, a pointer to the loading function for objects of that type
1629 ** These should not handle the file directly, but should work via the
1630 ** functions 'LoadObjRef', 'LoadUInt<n>' (<n> = 1,2,4 or 8), and others
1631 ** to be determined. Their role is to reinstall the information in the bag
1632 ** and reconstruct anything that was left out. By the time this function is
1633 ** called, the bag size and type have already been loaded and the bag argument
1634 ** contains the bag in question
1635 ** No loading function may allocate any bag
1636 */
1637
1638 void (*LoadObjFuncs[LAST_REAL_TNUM+1]) ( Obj obj );
1639
LoadObjError(Obj obj)1640 void LoadObjError( Obj obj )
1641 {
1642 ErrorQuit(
1643 "Panic: tried to load an object of unsupported type '%s'",
1644 (Int)TNAM_OBJ(obj), 0L );
1645 }
1646
1647 /****************************************************************************
1648 **
1649 *F SaveComObj( Obj comobj)
1650 **
1651 */
1652
SaveComObj(Obj comobj)1653 static void SaveComObj(Obj comobj)
1654 {
1655 UInt len,i;
1656 SaveSubObj(TYPE_COMOBJ( comobj ));
1657 len = LEN_PREC(comobj);
1658 SaveUInt(len);
1659 for (i = 1; i <= len; i++)
1660 {
1661 SaveUInt(GET_RNAM_PREC(comobj, i));
1662 SaveSubObj(GET_ELM_PREC(comobj, i));
1663 }
1664 }
1665
1666 /****************************************************************************
1667 **
1668 *F SavePosObj( Obj posobj)
1669 **
1670 */
1671
SavePosObj(Obj posobj)1672 static void SavePosObj(Obj posobj)
1673 {
1674 UInt len,i;
1675 SaveSubObj(TYPE_POSOBJ( posobj ));
1676 len = (SIZE_OBJ(posobj)/sizeof(Obj) - 1);
1677 for (i = 1; i <= len; i++)
1678 {
1679 SaveSubObj(CONST_ADDR_OBJ(posobj)[i]);
1680 }
1681 }
1682
1683 /****************************************************************************
1684 **
1685 *F SaveDatObj( Obj datobj)
1686 **
1687 ** Here we lose endianness protection, because we don't know if this is really
1688 ** UInts, or if it might be smaller data
1689 */
1690
SaveDatObj(Obj datobj)1691 static void SaveDatObj(Obj datobj)
1692 {
1693 UInt len,i;
1694 const UInt * ptr;
1695 SaveSubObj(TYPE_DATOBJ( datobj ));
1696 len = ((SIZE_OBJ(datobj)+sizeof(UInt)-1)/sizeof(UInt) - 1);
1697 ptr = (const UInt *)CONST_ADDR_OBJ(datobj) + 1;
1698 for (i = 1; i <= len; i++)
1699 {
1700 SaveUInt(*ptr++);
1701 }
1702 }
1703
1704 /****************************************************************************
1705 **
1706 *F LoadComObj( Obj comobj)
1707 **
1708 */
1709
LoadComObj(Obj comobj)1710 static void LoadComObj(Obj comobj)
1711 {
1712 UInt len,i;
1713 SET_TYPE_COMOBJ(comobj, LoadSubObj());
1714 len = LoadUInt();
1715 SET_LEN_PREC(comobj,len);
1716 for (i = 1; i <= len; i++)
1717 {
1718 SET_RNAM_PREC(comobj, i, LoadUInt());
1719 SET_ELM_PREC(comobj, i, LoadSubObj());
1720 }
1721 }
1722
1723 /****************************************************************************
1724 **
1725 *F LoadPosObj( Obj posobj)
1726 **
1727 */
1728
LoadPosObj(Obj posobj)1729 static void LoadPosObj(Obj posobj)
1730 {
1731 UInt len,i;
1732 SET_TYPE_POSOBJ(posobj, LoadSubObj());
1733 len = (SIZE_OBJ(posobj)/sizeof(Obj) - 1);
1734 for (i = 1; i <= len; i++)
1735 {
1736 ADDR_OBJ(posobj)[i] = LoadSubObj();
1737 }
1738 }
1739
1740 /****************************************************************************
1741 **
1742 *F LoadDatObj( Obj datobj)
1743 **
1744 ** Here we lose endianness protection, because we don't know if this is really
1745 ** UInts, or if it might be smaller data
1746 */
1747
LoadDatObj(Obj datobj)1748 static void LoadDatObj(Obj datobj)
1749 {
1750 UInt len,i;
1751 UInt *ptr;
1752 SET_TYPE_DATOBJ(datobj, LoadSubObj());
1753 len = ((SIZE_OBJ(datobj)+sizeof(UInt)-1)/sizeof(UInt) - 1);
1754 ptr = (UInt *)ADDR_OBJ(datobj)+1;
1755 for (i = 1; i <= len; i++)
1756 {
1757 *ptr ++ = LoadUInt();
1758 }
1759 }
1760
1761
1762 /****************************************************************************
1763 **
1764 *F * * * * * * * * GAP functions for "to be defined" objects * * * * * * * *
1765 */
1766
1767
1768 /****************************************************************************
1769 **
1770 *F FuncCLONE_OBJ( <self>, <dst>, <src> ) . . . . . . . clone <src> to <dst>
1771 **
1772 ** `CLONE_OBJ' clones the source <src> into <dst>. It is not allowed to
1773 ** clone small integers or finite field elements.
1774 **
1775 ** If <src> is a constant, than a "shallow" copy, that is to say, a bit-copy
1776 ** of the bag of <src> is created. If <src> is mutable than a "structural
1777 ** copy is created, which is then in turn "shallow" cloned into <dst>.
1778 **
1779 ** WARNING: at the moment the functions breaks on cloning `[1,~]'. This can
1780 ** be fixed if necessary.
1781 */
1782 static Obj IsToBeDefinedObj;
1783
1784 static Obj REREADING;
1785
FuncCLONE_OBJ(Obj self,Obj dst,Obj src)1786 static Obj FuncCLONE_OBJ(Obj self, Obj dst, Obj src)
1787 {
1788 const Obj * psrc;
1789 Obj * pdst;
1790
1791 /* check <src> */
1792 if ( IS_INTOBJ(src) ) {
1793 ErrorMayQuit("small integers cannot be cloned", 0, 0);
1794 }
1795 if ( IS_FFE(src) ) {
1796 ErrorMayQuit("finite field elements cannot be cloned", 0, 0);
1797 }
1798
1799 #ifdef HPCGAP
1800 switch (TNUM_OBJ(src)) {
1801 case T_AREC:
1802 case T_ACOMOBJ:
1803 case T_TLREC:
1804 ErrorMayQuit("cannot clone %ss", (Int)TNAM_OBJ(src), 0);
1805 }
1806 if (!REGION(dst)) {
1807 ErrorMayQuit("CLONE_OBJ() cannot overwrite public objects", 0, 0);
1808 }
1809 if (REGION(src) != REGION(dst) && REGION(src)) {
1810 ErrorMayQuit("objects can only be cloned to replace objects within"
1811 "the same region or if the object is public",
1812 0, 0);
1813 }
1814 #endif
1815
1816 /* if object is mutable, produce a structural copy */
1817 if ( IS_MUTABLE_OBJ(src) ) {
1818 src = CopyObj( src, 1 );
1819 }
1820
1821 /* now shallow clone the object */
1822 #ifdef HPCGAP
1823 Obj tmp = NewBag(TNUM_OBJ(src), SIZE_OBJ(src));
1824 pdst = ADDR_OBJ(tmp);
1825 #else
1826 ResizeBag( dst, SIZE_OBJ(src) );
1827 RetypeBag( dst, TNUM_OBJ(src) );
1828 pdst = ADDR_OBJ(dst);
1829 #endif
1830 psrc = CONST_ADDR_OBJ(src);
1831 memcpy(pdst, psrc, SIZE_OBJ(src));
1832 CHANGED_BAG(dst);
1833 #ifdef HPCGAP
1834 SET_REGION(dst, REGION(src));
1835 MEMBAR_WRITE();
1836 /* The following is a no-op unless the region is public */
1837 SET_PTR_BAG(dst, PTR_BAG(tmp));
1838 #endif
1839
1840 return 0;
1841 }
1842
1843 /****************************************************************************
1844 **
1845 *F FuncSWITCH_OBJ( <self>, <obj1>, <obj2> ) . . . switch <obj1> and <obj2>
1846 **
1847 ** `SWITCH_OBJ' exchanges the objects referenced by its two arguments. It
1848 ** is not allowed to switch clone small integers or finite field elements.
1849 **
1850 ** This is inspired by the Smalltalk 'become:' operation.
1851 */
1852
FuncSWITCH_OBJ(Obj self,Obj obj1,Obj obj2)1853 static Obj FuncSWITCH_OBJ(Obj self, Obj obj1, Obj obj2)
1854 {
1855 if ( IS_INTOBJ(obj1) || IS_INTOBJ(obj2) ) {
1856 ErrorMayQuit("small integer objects cannot be switched", 0, 0);
1857 }
1858 if ( IS_FFE(obj1) || IS_FFE(obj2) ) {
1859 ErrorMayQuit("finite field elements cannot be switched", 0, 0);
1860 }
1861 #ifdef HPCGAP
1862 Region * ds1 = REGION(obj1);
1863 Region * ds2 = REGION(obj2);
1864 if (!ds1 || ds1->owner != GetTLS())
1865 ErrorQuit("SWITCH_OBJ: Cannot write to first object's region.", 0, 0);
1866 if (!ds2 || ds2->owner != GetTLS())
1867 ErrorQuit("SWITCH_OBJ: Cannot write to second object's region.", 0, 0);
1868 SET_REGION(obj2, ds1);
1869 SET_REGION(obj1, ds2);
1870 #endif
1871 SwapMasterPoint(obj1, obj2);
1872 return 0;
1873 }
1874
1875
1876 /****************************************************************************
1877 **
1878 *F FuncFORCE_SWITCH_OBJ( <self>, <obj1>, <obj2> ) . switch <obj1> and <obj2>
1879 **
1880 ** `FORCE_SWITCH_OBJ' exchanges the objects referenced by its two arguments.
1881 ** It is not allowed to switch clone small integers or finite field
1882 ** elements.
1883 **
1884 ** In GAP, FORCE_SWITCH_OBJ does the same thing as SWITCH_OBJ. In HPC_GAP
1885 ** it allows public objects to be exchanged.
1886 */
1887
FuncFORCE_SWITCH_OBJ(Obj self,Obj obj1,Obj obj2)1888 static Obj FuncFORCE_SWITCH_OBJ(Obj self, Obj obj1, Obj obj2)
1889 {
1890 if ( IS_INTOBJ(obj1) || IS_INTOBJ(obj2) ) {
1891 ErrorMayQuit("small integer objects cannot be switched", 0, 0);
1892 }
1893 if ( IS_FFE(obj1) || IS_FFE(obj2) ) {
1894 ErrorMayQuit("finite field elements cannot be switched", 0, 0);
1895 }
1896 #ifdef HPCGAP
1897 Region * ds1 = REGION(obj1);
1898 Region * ds2 = REGION(obj2);
1899 if (ds1 && ds1->owner != GetTLS())
1900 ErrorQuit("FORCE_SWITCH_OBJ: Cannot write to first object's region.", 0, 0);
1901 if (ds2 && ds2->owner != GetTLS())
1902 ErrorQuit("FORCE_SWITCH_OBJ: Cannot write to second object's region.", 0, 0);
1903 SET_REGION(obj2, ds1);
1904 SET_REGION(obj1, ds2);
1905 #endif
1906 SwapMasterPoint(obj1, obj2);
1907 return 0;
1908 }
1909
1910
1911 /****************************************************************************
1912 **
1913 *F FuncDEBUG_TNUM_NAMES
1914 **
1915 ** Print all defined TNUM values and names
1916 */
1917 #define START_SYMBOLIC_TNUM(name) \
1918 if (k == name) { \
1919 Pr("%3d: %s", k, (Int)indentStr); \
1920 Pr("%s" #name "\n", (Int)indentStr, 0); \
1921 assert(indentLvl + 1 < sizeof(indentStr)); \
1922 indentStr[indentLvl++] = ' '; \
1923 indentStr[indentLvl] = 0; \
1924 }
1925
1926 #define STOP_SYMBOLIC_TNUM(name) \
1927 if (k == name) { \
1928 assert(indentLvl > 0); \
1929 indentStr[--indentLvl] = 0; \
1930 Pr("%3d: %s", k, (Int)indentStr); \
1931 Pr("%s" #name "\n", (Int)indentStr, 0); \
1932 }
1933
FuncDEBUG_TNUM_NAMES(Obj self)1934 static Obj FuncDEBUG_TNUM_NAMES(Obj self)
1935 {
1936 UInt indentLvl = 0;
1937 Char indentStr[20] = "";
1938 for (UInt k = 0; k < NUM_TYPES; k++) {
1939 START_SYMBOLIC_TNUM(FIRST_REAL_TNUM);
1940 START_SYMBOLIC_TNUM(FIRST_CONSTANT_TNUM);
1941 START_SYMBOLIC_TNUM(FIRST_MULT_TNUM);
1942 START_SYMBOLIC_TNUM(FIRST_IMM_MUT_TNUM);
1943 START_SYMBOLIC_TNUM(FIRST_RECORD_TNUM);
1944 START_SYMBOLIC_TNUM(FIRST_LIST_TNUM);
1945 START_SYMBOLIC_TNUM(FIRST_PLIST_TNUM);
1946 START_SYMBOLIC_TNUM(FIRST_OBJSET_TNUM);
1947 START_SYMBOLIC_TNUM(FIRST_EXTERNAL_TNUM);
1948 START_SYMBOLIC_TNUM(FIRST_PACKAGE_TNUM);
1949 #ifdef HPCGAP
1950 START_SYMBOLIC_TNUM(FIRST_SHARED_TNUM);
1951 #endif
1952 const char *name = TNAM_TNUM(k);
1953 Pr("%3d: %s", k, (Int)indentStr);
1954 Pr("%s%s\n", (Int)indentStr, (Int)(name ? name : "."));
1955 STOP_SYMBOLIC_TNUM(LAST_MULT_TNUM);
1956 STOP_SYMBOLIC_TNUM(LAST_CONSTANT_TNUM);
1957 STOP_SYMBOLIC_TNUM(LAST_RECORD_TNUM);
1958 STOP_SYMBOLIC_TNUM(LAST_PLIST_TNUM);
1959 STOP_SYMBOLIC_TNUM(LAST_LIST_TNUM);
1960 STOP_SYMBOLIC_TNUM(LAST_OBJSET_TNUM);
1961 STOP_SYMBOLIC_TNUM(LAST_IMM_MUT_TNUM);
1962 STOP_SYMBOLIC_TNUM(LAST_EXTERNAL_TNUM);
1963 STOP_SYMBOLIC_TNUM(LAST_PACKAGE_TNUM);
1964 #ifdef HPCGAP
1965 STOP_SYMBOLIC_TNUM(LAST_SHARED_TNUM);
1966 #endif
1967 STOP_SYMBOLIC_TNUM(LAST_REAL_TNUM);
1968 }
1969 return 0;
1970 }
1971 #undef START_SYMBOLIC_TNUM
1972 #undef STOP_SYMBOLIC_TNUM
1973
1974
1975 /****************************************************************************
1976 **
1977 *F * * * * * * * * * * * * * initialize module * * * * * * * * * * * * * * *
1978 */
1979
1980
1981 /****************************************************************************
1982 **
1983 *V BagNames . . . . . . . . . . . . . . . . . . . . . . . list of bag names
1984 */
1985 static StructBagNames BagNames[] = {
1986 { T_COMOBJ, "component object" },
1987 { T_POSOBJ, "positional object" },
1988 { T_DATOBJ, "data object" },
1989 #if !defined(USE_THREADSAFE_COPYING)
1990 { T_COPYING, "copy in progress" },
1991 #endif
1992 { -1, "" }
1993 };
1994
1995
1996 /****************************************************************************
1997 **
1998 *V GVarFilts . . . . . . . . . . . . . . . . . . . list of filters to export
1999 */
2000 static StructGVarFilt GVarFilts [] = {
2001
2002 GVAR_FILT(IS_MUTABLE_OBJ, "obj", &IsMutableObjFilt),
2003 GVAR_FILT(IS_COPYABLE_OBJ, "obj", &IsCopyableObjFilt),
2004 #ifdef HPCGAP
2005 GVAR_FILT(IS_INTERNALLY_MUTABLE_OBJ, "obj", &IsInternallyMutableObjFilt),
2006 #endif
2007 { 0, 0, 0, 0, 0 }
2008
2009 };
2010
2011
2012 /****************************************************************************
2013 **
2014 *V GVarOpers . . . . . . . . . . . . . . . . . list of operations to export
2015 */
2016 static StructGVarOper GVarOpers [] = {
2017
2018 { "SHALLOW_COPY_OBJ", 1, "obj", &ShallowCopyObjOper,
2019 ShallowCopyObjHandler, "src/objects.c:SHALLOW_COPY_OBJ" },
2020
2021 { "PRINT_OBJ", 1, "obj", &PrintObjOper,
2022 PrintObjHandler, "src/objects.c:PRINT_OBJ" },
2023
2024 { "VIEW_OBJ", 1, "obj", &ViewObjOper,
2025 FuncViewObj, "src/objects.c:VIEW_OBJ" },
2026
2027 { 0, 0, 0, 0, 0, 0 }
2028
2029 };
2030
2031
2032 /****************************************************************************
2033 **
2034 *V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export
2035 */
2036 static StructGVarFunc GVarFuncs[] = {
2037
2038 GVAR_FUNC(FAMILY_TYPE, 1, "type"),
2039 GVAR_FUNC(TYPE_OBJ, 1, "obj"),
2040 GVAR_FUNC(SET_TYPE_OBJ, 2, "obj, type"),
2041 GVAR_FUNC(FAMILY_OBJ, 1, "obj"),
2042 GVAR_FUNC(IMMUTABLE_COPY_OBJ, 1, "obj"),
2043 GVAR_FUNC(DEEP_COPY_OBJ, 1, "obj"),
2044 GVAR_FUNC(IS_IDENTICAL_OBJ, 2, "obj1, obj2"),
2045 GVAR_FUNC(IS_COMOBJ, 1, "obj"),
2046 GVAR_FUNC(SET_TYPE_COMOBJ, 2, "obj, type"),
2047 GVAR_FUNC(IS_POSOBJ, 1, "obj"),
2048 GVAR_FUNC(SET_TYPE_POSOBJ, 2, "obj, type"),
2049 GVAR_FUNC(LEN_POSOBJ, 1, "obj"),
2050 GVAR_FUNC(IS_DATOBJ, 1, "obj"),
2051 GVAR_FUNC(SET_TYPE_DATOBJ, 2, "obj, type"),
2052 GVAR_FUNC(CLONE_OBJ, 2, "dst, src"),
2053 GVAR_FUNC(SWITCH_OBJ, 2, "obj1, obj2"),
2054 GVAR_FUNC(FORCE_SWITCH_OBJ, 2, "obj1, obj2"),
2055 GVAR_FUNC(SET_PRINT_OBJ_INDEX, 1, "index"),
2056 GVAR_FUNC(MakeImmutable, 1, "obj"),
2057
2058 GVAR_FUNC(DEBUG_TNUM_NAMES, 0, ""),
2059
2060 { 0, 0, 0, 0, 0 }
2061
2062 };
2063
2064
2065 /****************************************************************************
2066 **
2067 *F InitKernel( <module> ) . . . . . . . . initialise kernel data structures
2068 */
InitKernel(StructInitInfo * module)2069 static Int InitKernel (
2070 StructInitInfo * module )
2071 {
2072 Int t; /* loop variable */
2073
2074 // set the bag type names (for error messages and debugging)
2075 InitBagNamesFromTable( BagNames );
2076
2077 /* install the marking methods */
2078 InitMarkFuncBags( T_COMOBJ , MarkPRecSubBags );
2079 InitMarkFuncBags( T_POSOBJ , MarkAllSubBags );
2080 InitMarkFuncBags( T_DATOBJ , MarkOneSubBags );
2081 #if !defined(USE_THREADSAFE_COPYING) && !defined(USE_BOEHM_GC)
2082 InitMarkFuncBags(T_COPYING, MarkCopyingSubBags);
2083 #endif
2084
2085 for ( t = FIRST_REAL_TNUM; t <= LAST_REAL_TNUM; t++ ) {
2086 assert(TypeObjFuncs[ t ] == 0);
2087 TypeObjFuncs[ t ] = TypeObjError;
2088 SetTypeObjFuncs [ t] = SetTypeObjError;
2089 }
2090
2091 TypeObjFuncs[ T_COMOBJ ] = TypeComObj;
2092 TypeObjFuncs[ T_POSOBJ ] = TypePosObj;
2093 TypeObjFuncs[ T_DATOBJ ] = TypeDatObj;
2094
2095 SetTypeObjFuncs [ T_COMOBJ ] = SetTypeComObj;
2096 SetTypeObjFuncs [ T_POSOBJ ] = SetTypePosObj;
2097 SetTypeObjFuncs [ T_DATOBJ ] = SetTypeDatObj;
2098
2099 /* functions for 'to-be-defined' objects */
2100 ImportFuncFromLibrary( "IsToBeDefinedObj", &IsToBeDefinedObj );
2101 ImportFuncFromLibrary( "PostMakeImmutable", &PostMakeImmutableOp );
2102 ImportGVarFromLibrary( "REREADING", &REREADING );
2103 ImportGVarFromLibrary( "TYPE_KERNEL_OBJECT", &TYPE_KERNEL_OBJECT );
2104
2105 /* init filters and functions */
2106 InitHdlrFiltsFromTable( GVarFilts );
2107 InitHdlrOpersFromTable( GVarOpers );
2108 InitHdlrFuncsFromTable( GVarFuncs );
2109
2110 /* make and install the 'IS_MUTABLE_OBJ' filter */
2111 for ( t = FIRST_REAL_TNUM; t <= LAST_REAL_TNUM; t++ ) {
2112 assert(IsMutableObjFuncs[ t ] == 0);
2113 IsMutableObjFuncs[ t ] = IsMutableObjError;
2114 }
2115 for ( t = FIRST_CONSTANT_TNUM; t <= LAST_CONSTANT_TNUM; t++ )
2116 IsMutableObjFuncs[ t ] = AlwaysNo;
2117 for ( t = FIRST_EXTERNAL_TNUM; t <= LAST_EXTERNAL_TNUM; t++ )
2118 IsMutableObjFuncs[ t ] = IsMutableObjObject;
2119
2120 /* make and install the 'IS_COPYABLE_OBJ' filter */
2121 for ( t = FIRST_REAL_TNUM; t <= LAST_REAL_TNUM; t++ ) {
2122 assert(IsCopyableObjFuncs[ t ] == 0);
2123 IsCopyableObjFuncs[ t ] = IsCopyableObjError;
2124 }
2125 for ( t = FIRST_CONSTANT_TNUM; t <= LAST_CONSTANT_TNUM; t++ )
2126 IsCopyableObjFuncs[ t ] = AlwaysNo;
2127 for ( t = FIRST_EXTERNAL_TNUM; t <= LAST_EXTERNAL_TNUM; t++ )
2128 IsCopyableObjFuncs[ t ] = IsCopyableObjObject;
2129
2130 /* make and install the 'SHALLOW_COPY_OBJ' operation */
2131 for ( t = FIRST_REAL_TNUM; t <= LAST_REAL_TNUM; t++ ) {
2132 assert(ShallowCopyObjFuncs[ t ] == 0);
2133 ShallowCopyObjFuncs[ t ] = ShallowCopyObjError;
2134 }
2135 for ( t = FIRST_CONSTANT_TNUM; t <= LAST_CONSTANT_TNUM; t++ )
2136 ShallowCopyObjFuncs[ t ] = ShallowCopyObjConstant;
2137 for ( t = FIRST_RECORD_TNUM; t <= LAST_RECORD_TNUM; t++ )
2138 ShallowCopyObjFuncs[ t ] = ShallowCopyObjDefault;
2139 for ( t = FIRST_LIST_TNUM; t <= LAST_LIST_TNUM; t++ )
2140 ShallowCopyObjFuncs[ t ] = ShallowCopyObjDefault;
2141 for ( t = FIRST_EXTERNAL_TNUM; t <= LAST_EXTERNAL_TNUM; t++ )
2142 ShallowCopyObjFuncs[ t ] = ShallowCopyObjObject;
2143
2144 #ifdef USE_THREADSAFE_COPYING
2145 SetTraversalMethod(T_POSOBJ, TRAVERSE_ALL_BUT_FIRST, 0, 0);
2146 SetTraversalMethod(T_COMOBJ, TRAVERSE_BY_FUNCTION, TraversePRecord, CopyPRecord);
2147 SetTraversalMethod(T_DATOBJ, TRAVERSE_NONE, 0, 0);
2148 #else
2149 /* make and install the 'COPY_OBJ' function */
2150 for ( t = FIRST_REAL_TNUM; t <= LAST_REAL_TNUM; t++ ) {
2151 assert(CopyObjFuncs [ t ] == 0);
2152 CopyObjFuncs [ t ] = CopyObjError;
2153 assert(CleanObjFuncs[ t ] == 0);
2154 CleanObjFuncs[ t ] = CleanObjError;
2155 }
2156 for ( t = FIRST_CONSTANT_TNUM; t <= LAST_CONSTANT_TNUM; t++ ) {
2157 CopyObjFuncs [ t ] = CopyObjConstant;
2158 CleanObjFuncs[ t ] = 0;
2159 }
2160 CopyObjFuncs[ T_POSOBJ ] = CopyObjPosObj;
2161 CleanObjFuncs[ T_POSOBJ ] = CleanObjPosObj;
2162 CopyObjFuncs[ T_COMOBJ ] = CopyObjComObj;
2163 CleanObjFuncs[ T_COMOBJ ] = CleanObjComObj;
2164 CopyObjFuncs[ T_DATOBJ ] = CopyObjDatObj;
2165 CleanObjFuncs[ T_DATOBJ ] = CleanObjDatObj;
2166 #endif
2167
2168 /* make and install the 'PRINT_OBJ' operation */
2169 for ( t = FIRST_REAL_TNUM; t <= LAST_REAL_TNUM; t++ ) {
2170 assert(PrintObjFuncs[ t ] == 0);
2171 PrintObjFuncs[ t ] = PrintObjObject;
2172 }
2173
2174 /* enter 'PrintUnknownObj' in the dispatching tables */
2175 for ( t = FIRST_REAL_TNUM; t <= LAST_REAL_TNUM; t++ ) {
2176 assert(PrintPathFuncs[ t ] == 0);
2177 PrintPathFuncs[ t ] = PrintPathError;
2178 }
2179
2180 /* enter 'SaveObjError' and 'LoadObjError' for all types initially */
2181 for ( t = FIRST_REAL_TNUM; t <= LAST_REAL_TNUM; t++ ) {
2182 assert(SaveObjFuncs[ t ] == 0);
2183 SaveObjFuncs[ t ] = SaveObjError;
2184 assert(LoadObjFuncs[ t ] == 0);
2185 LoadObjFuncs[ t ] = LoadObjError;
2186 }
2187
2188 /* install the saving functions */
2189 SaveObjFuncs[ T_COMOBJ ] = SaveComObj;
2190 SaveObjFuncs[ T_POSOBJ ] = SavePosObj;
2191 SaveObjFuncs[ T_DATOBJ ] = SaveDatObj;
2192
2193 /* install the loading functions */
2194 LoadObjFuncs[ T_COMOBJ ] = LoadComObj;
2195 LoadObjFuncs[ T_POSOBJ ] = LoadPosObj;
2196 LoadObjFuncs[ T_DATOBJ ] = LoadDatObj;
2197
2198 for (t = FIRST_REAL_TNUM; t <= LAST_REAL_TNUM; t++ ) {
2199 assert(MakeImmutableObjFuncs[ t ] == 0);
2200 MakeImmutableObjFuncs[t] = MakeImmutableError;
2201 }
2202
2203 /* install the makeimmutableing functions */
2204 MakeImmutableObjFuncs[ T_COMOBJ ] = MakeImmutableComObj;
2205 MakeImmutableObjFuncs[ T_POSOBJ ] = MakeImmutablePosObj;
2206 MakeImmutableObjFuncs[ T_DATOBJ ] = MakeImmutableDatObj;
2207
2208 #ifdef HPCGAP
2209 ReadOnlyDatObjs = (getenv("GAP_READONLY_DATOBJS") != 0);
2210 #endif
2211
2212 /* return success */
2213 return 0;
2214 }
2215
2216
2217 /****************************************************************************
2218 **
2219 *F InitLibrary( <module> ) . . . . . . . initialise library data structures
2220 */
InitLibrary(StructInitInfo * module)2221 static Int InitLibrary (
2222 StructInitInfo * module )
2223 {
2224 /* init filters and functions */
2225 InitGVarFiltsFromTable( GVarFilts );
2226 InitGVarOpersFromTable( GVarOpers );
2227 InitGVarFuncsFromTable( GVarFuncs );
2228
2229 /* export certain TNUM values as global variable */
2230 ExportAsConstantGVar(FIRST_REAL_TNUM);
2231 ExportAsConstantGVar(LAST_REAL_TNUM);
2232
2233 ExportAsConstantGVar(FIRST_CONSTANT_TNUM);
2234 ExportAsConstantGVar(LAST_CONSTANT_TNUM);
2235
2236 ExportAsConstantGVar(FIRST_MULT_TNUM);
2237 ExportAsConstantGVar(LAST_MULT_TNUM);
2238
2239 ExportAsConstantGVar(FIRST_IMM_MUT_TNUM);
2240 ExportAsConstantGVar(LAST_IMM_MUT_TNUM);
2241
2242 ExportAsConstantGVar(FIRST_RECORD_TNUM);
2243 ExportAsConstantGVar(LAST_RECORD_TNUM);
2244
2245 ExportAsConstantGVar(FIRST_LIST_TNUM);
2246 ExportAsConstantGVar(LAST_LIST_TNUM);
2247
2248 ExportAsConstantGVar(FIRST_PLIST_TNUM);
2249 ExportAsConstantGVar(LAST_PLIST_TNUM);
2250
2251 ExportAsConstantGVar(FIRST_OBJSET_TNUM);
2252 ExportAsConstantGVar(LAST_OBJSET_TNUM);
2253
2254 ExportAsConstantGVar(FIRST_EXTERNAL_TNUM);
2255 ExportAsConstantGVar(LAST_EXTERNAL_TNUM);
2256
2257 ExportAsConstantGVar(FIRST_PACKAGE_TNUM);
2258 ExportAsConstantGVar(LAST_PACKAGE_TNUM);
2259
2260 #ifdef HPCGAP
2261 ExportAsConstantGVar(FIRST_SHARED_TNUM);
2262 ExportAsConstantGVar(LAST_SHARED_TNUM);
2263 #endif
2264
2265 ExportAsConstantGVar(T_INT);
2266 ExportAsConstantGVar(T_INTPOS);
2267 ExportAsConstantGVar(T_INTNEG);
2268 ExportAsConstantGVar(T_RAT);
2269 ExportAsConstantGVar(T_CYC);
2270 ExportAsConstantGVar(T_FFE);
2271 ExportAsConstantGVar(T_PERM2);
2272 ExportAsConstantGVar(T_PERM4);
2273 ExportAsConstantGVar(T_TRANS2);
2274 ExportAsConstantGVar(T_TRANS4);
2275 ExportAsConstantGVar(T_PPERM2);
2276 ExportAsConstantGVar(T_PPERM4);
2277 ExportAsConstantGVar(T_BOOL);
2278 ExportAsConstantGVar(T_CHAR);
2279 ExportAsConstantGVar(T_FUNCTION);
2280 ExportAsConstantGVar(T_BODY);
2281 ExportAsConstantGVar(T_FLAGS);
2282 ExportAsConstantGVar(T_MACFLOAT);
2283 ExportAsConstantGVar(T_LVARS);
2284 ExportAsConstantGVar(T_HVARS);
2285
2286 ExportAsConstantGVar(T_PREC);
2287
2288 ExportAsConstantGVar(T_PLIST);
2289 ExportAsConstantGVar(T_PLIST_NDENSE);
2290 ExportAsConstantGVar(T_PLIST_DENSE);
2291 ExportAsConstantGVar(T_PLIST_DENSE_NHOM);
2292 ExportAsConstantGVar(T_PLIST_DENSE_NHOM_SSORT);
2293 ExportAsConstantGVar(T_PLIST_DENSE_NHOM_NSORT);
2294 ExportAsConstantGVar(T_PLIST_EMPTY);
2295 ExportAsConstantGVar(T_PLIST_HOM);
2296 ExportAsConstantGVar(T_PLIST_HOM_NSORT);
2297 ExportAsConstantGVar(T_PLIST_HOM_SSORT);
2298 ExportAsConstantGVar(T_PLIST_TAB);
2299 ExportAsConstantGVar(T_PLIST_TAB_NSORT);
2300 ExportAsConstantGVar(T_PLIST_TAB_SSORT);
2301 ExportAsConstantGVar(T_PLIST_TAB_RECT);
2302 ExportAsConstantGVar(T_PLIST_TAB_RECT_NSORT);
2303 ExportAsConstantGVar(T_PLIST_TAB_RECT_SSORT);
2304 ExportAsConstantGVar(T_PLIST_CYC);
2305 ExportAsConstantGVar(T_PLIST_CYC_NSORT);
2306 ExportAsConstantGVar(T_PLIST_CYC_SSORT);
2307 ExportAsConstantGVar(T_PLIST_FFE);
2308
2309 ExportAsConstantGVar(T_RANGE_NSORT);
2310 ExportAsConstantGVar(T_RANGE_SSORT);
2311 ExportAsConstantGVar(T_BLIST);
2312 ExportAsConstantGVar(T_BLIST_NSORT);
2313 ExportAsConstantGVar(T_BLIST_SSORT);
2314 ExportAsConstantGVar(T_STRING);
2315 ExportAsConstantGVar(T_STRING_NSORT);
2316 ExportAsConstantGVar(T_STRING_SSORT);
2317
2318 ExportAsConstantGVar(T_OBJSET);
2319 ExportAsConstantGVar(T_OBJMAP);
2320
2321 ExportAsConstantGVar(T_COMOBJ);
2322 ExportAsConstantGVar(T_POSOBJ);
2323 ExportAsConstantGVar(T_DATOBJ);
2324 ExportAsConstantGVar(T_WPOBJ);
2325 #ifdef HPCGAP
2326 ExportAsConstantGVar(T_APOSOBJ);
2327 ExportAsConstantGVar(T_ACOMOBJ);
2328
2329 ExportAsConstantGVar(T_THREAD);
2330 ExportAsConstantGVar(T_MONITOR);
2331 ExportAsConstantGVar(T_REGION);
2332 ExportAsConstantGVar(T_SEMAPHORE);
2333 ExportAsConstantGVar(T_CHANNEL);
2334 ExportAsConstantGVar(T_BARRIER);
2335 ExportAsConstantGVar(T_SYNCVAR);
2336 ExportAsConstantGVar(T_FIXALIST);
2337 ExportAsConstantGVar(T_ALIST);
2338 ExportAsConstantGVar(T_AREC);
2339 ExportAsConstantGVar(T_AREC_INNER);
2340 ExportAsConstantGVar(T_TLREC);
2341 ExportAsConstantGVar(T_TLREC_INNER);
2342 #endif
2343
2344 #if !defined(USE_THREADSAFE_COPYING)
2345 ExportAsConstantGVar(T_COPYING);
2346 #endif
2347
2348 // export positions of data in type objects
2349 ExportAsConstantGVar(POS_FAMILY_TYPE);
2350 ExportAsConstantGVar(POS_FLAGS_TYPE);
2351 ExportAsConstantGVar(POS_DATA_TYPE);
2352 ExportAsConstantGVar(POS_NUMB_TYPE);
2353 ExportAsConstantGVar(POS_FIRST_FREE_TYPE);
2354
2355 // export small integer limits
2356 AssConstantGVar(GVarName("INTOBJ_MIN"), INTOBJ_MIN);
2357 AssConstantGVar(GVarName("INTOBJ_MAX"), INTOBJ_MAX);
2358
2359 /* return success */
2360 return 0;
2361 }
2362
2363
2364 /****************************************************************************
2365 **
2366 *F InitInfoObjects() . . . . . . . . . . . . . . . . table of init functions
2367 */
2368 static StructInitInfo module = {
2369 // init struct using C99 designated initializers; for a full list of
2370 // fields, please refer to the definition of StructInitInfo
2371 .type = MODULE_BUILTIN,
2372 .name = "objects",
2373 .initKernel = InitKernel,
2374 .initLibrary = InitLibrary,
2375
2376 .moduleStateSize = sizeof(ObjectsModuleState),
2377 .moduleStateOffsetPtr = &ObjectsStateOffset,
2378 };
2379
InitInfoObjects(void)2380 StructInitInfo * InitInfoObjects ( void )
2381 {
2382 return &module;
2383 }
2384