1 /*
2 Copyright (C) 2001-2014, Parrot Foundation.
3
4 =head1 NAME
5
6 src/pmc.c
7
8 =head1 DESCRIPTION
9
10 The base vtable calling functions
11
12 =head1 FUNCTIONS
13
14 =over 4
15
16 =cut
17
18 */
19
20 #include "parrot/parrot.h"
21 #include "pmc.str"
22 #include "pmc/pmc_class.h"
23 #include "pmc/pmc_integer.h"
24 #include "pmc/pmc_callcontext.h"
25 #include "pmc/pmc_proxy.h"
26
27 /* HEADERIZER HFILE: include/parrot/pmc.h */
28
29 /* HEADERIZER BEGIN: static */
30 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
31
32 PARROT_WARN_UNUSED_RESULT
33 PARROT_CAN_RETURN_NULL
34 static PMC* check_get_std_props(PARROT_INTERP,
35 ARGIN(const PMC *self),
36 ARGIN(const STRING *key))
37 __attribute__nonnull__(1)
38 __attribute__nonnull__(2)
39 __attribute__nonnull__(3);
40
41 static void check_pmc_reuse_flags(PARROT_INTERP,
42 UINTVAL srcflags,
43 UINTVAL destflags)
44 __attribute__nonnull__(1);
45
46 PARROT_WARN_UNUSED_RESULT
47 static INTVAL check_set_std_props(PARROT_INTERP,
48 ARGMOD(PMC *pmc),
49 ARGIN(const STRING *key),
50 ARGMOD(PMC *value))
51 __attribute__nonnull__(1)
52 __attribute__nonnull__(2)
53 __attribute__nonnull__(3)
54 __attribute__nonnull__(4)
55 FUNC_MODIFIES(*pmc)
56 FUNC_MODIFIES(*value);
57
58 PARROT_WARN_UNUSED_RESULT
59 PARROT_CANNOT_RETURN_NULL
60 static PMC * create_class_pmc(PARROT_INTERP, INTVAL type)
61 __attribute__nonnull__(1);
62
63 PARROT_WARN_UNUSED_RESULT
64 PARROT_CANNOT_RETURN_NULL
65 static PMC * get_new_pmc_header(PARROT_INTERP,
66 INTVAL base_type,
67 UINTVAL flags)
68 __attribute__nonnull__(1);
69
70 PARROT_WARN_UNUSED_RESULT
71 static INTVAL has_pending_std_props(ARGIN(const PMC *self))
72 __attribute__nonnull__(1);
73
74 PARROT_CANNOT_RETURN_NULL
75 PARROT_WARN_UNUSED_RESULT
76 static PMC* make_prop_hash(PARROT_INTERP, ARGMOD(PMC *self))
77 __attribute__nonnull__(1)
78 __attribute__nonnull__(2)
79 FUNC_MODIFIES(*self);
80
81 PARROT_CANNOT_RETURN_NULL
82 PARROT_WARN_UNUSED_RESULT
83 static PMC* Parrot_pmc_reuse_noinit(PARROT_INTERP,
84 ARGMOD(PMC *pmc),
85 INTVAL new_type)
86 __attribute__nonnull__(1)
87 __attribute__nonnull__(2)
88 FUNC_MODIFIES(*pmc);
89
90 static void propagate_std_props(PARROT_INTERP,
91 ARGIN(PMC *self),
92 ARGIN(PMC *prop_hash))
93 __attribute__nonnull__(1)
94 __attribute__nonnull__(2)
95 __attribute__nonnull__(3);
96
97 #define ASSERT_ARGS_check_get_std_props __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
98 PARROT_ASSERT_ARG(interp) \
99 , PARROT_ASSERT_ARG(self) \
100 , PARROT_ASSERT_ARG(key))
101 #define ASSERT_ARGS_check_pmc_reuse_flags __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
102 PARROT_ASSERT_ARG(interp))
103 #define ASSERT_ARGS_check_set_std_props __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
104 PARROT_ASSERT_ARG(interp) \
105 , PARROT_ASSERT_ARG(pmc) \
106 , PARROT_ASSERT_ARG(key) \
107 , PARROT_ASSERT_ARG(value))
108 #define ASSERT_ARGS_create_class_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
109 PARROT_ASSERT_ARG(interp))
110 #define ASSERT_ARGS_get_new_pmc_header __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
111 PARROT_ASSERT_ARG(interp))
112 #define ASSERT_ARGS_has_pending_std_props __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
113 PARROT_ASSERT_ARG(self))
114 #define ASSERT_ARGS_make_prop_hash __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
115 PARROT_ASSERT_ARG(interp) \
116 , PARROT_ASSERT_ARG(self))
117 #define ASSERT_ARGS_Parrot_pmc_reuse_noinit __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
118 PARROT_ASSERT_ARG(interp) \
119 , PARROT_ASSERT_ARG(pmc))
120 #define ASSERT_ARGS_propagate_std_props __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
121 PARROT_ASSERT_ARG(interp) \
122 , PARROT_ASSERT_ARG(self) \
123 , PARROT_ASSERT_ARG(prop_hash))
124 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
125 /* HEADERIZER END: static */
126
127
128 PMC * PMCNULL;
129
130 /*
131
132 =item C<INTVAL Parrot_pmc_is_null(PARROT_INTERP, const PMC *pmc)>
133
134 Tests if the given pmc is null.
135
136 =cut
137
138 */
139
140 PARROT_EXPORT
141 PARROT_PURE_FUNCTION
142 PARROT_WARN_UNUSED_RESULT
143 PARROT_HOT
144 INTVAL
Parrot_pmc_is_null(SHIM_INTERP,ARGIN_NULLOK (const PMC * pmc))145 Parrot_pmc_is_null(SHIM_INTERP, ARGIN_NULLOK(const PMC *pmc))
146 {
147 ASSERT_ARGS(Parrot_pmc_is_null)
148 return (pmc == PMCNULL) || (pmc == NULL);
149 }
150
151 /*
152
153 =item C<void Parrot_pmc_destroy(PARROT_INTERP, PMC *pmc)>
154
155 Destroy a PMC. Call his destroy vtable function if needed, and deallocate
156 his attributes if they are automatically allocated.
157
158 For internal usage of the PMC handling functions and garbage collection
159 subsystem.
160
161 =cut
162
163 */
164
165 PARROT_EXPORT
166 void
Parrot_pmc_destroy(PARROT_INTERP,ARGMOD (PMC * pmc))167 Parrot_pmc_destroy(PARROT_INTERP, ARGMOD(PMC *pmc))
168 {
169 ASSERT_ARGS(Parrot_pmc_destroy)
170
171 if (PObj_custom_destroy_TEST(pmc))
172 VTABLE_destroy(interp, pmc);
173
174 PObj_gc_CLEAR(pmc);
175
176 if (pmc->vtable->attr_size && PMC_data(pmc))
177 Parrot_gc_free_pmc_attributes(interp, pmc);
178 else
179 PMC_data(pmc) = NULL;
180
181 #ifndef NDEBUG
182
183 pmc->data = (DPOINTER *)0xdeadbeef;
184
185 #endif
186
187 }
188
189 /*
190
191 =item C<PMC * Parrot_pmc_new(PARROT_INTERP, INTVAL base_type)>
192
193 Creates a new PMC of type C<base_type> (which is an index into the list of PMC
194 types declared in C<vtables> in F<include/parrot/pmc.h>). Once the PMC has been
195 successfully created and its vtable pointer initialized, we call its C<init>
196 method to perform any other necessary initialization.
197
198 =cut
199
200 */
201
202 PARROT_EXPORT
203 PARROT_CANNOT_RETURN_NULL
204 PARROT_WARN_UNUSED_RESULT
205 PMC *
Parrot_pmc_new(PARROT_INTERP,INTVAL base_type)206 Parrot_pmc_new(PARROT_INTERP, INTVAL base_type)
207 {
208 ASSERT_ARGS(Parrot_pmc_new)
209 PARROT_ASSERT(interp->n_vtable_max > base_type);
210 PARROT_ASSERT(interp->vtables[base_type]);
211 {
212 PMC *const classobj = interp->vtables[base_type]->pmc_class;
213
214 if (!PMC_IS_NULL(classobj) && PObj_is_class_TEST(classobj))
215 return VTABLE_instantiate(interp, classobj, PMCNULL);
216 else {
217 PMC * const pmc = get_new_pmc_header(interp, base_type, 0);
218 VTABLE_init(interp, pmc);
219 return pmc;
220 }
221 }
222 }
223
224 /*
225
226 =item C<PMC * Parrot_pmc_new_from_type(PARROT_INTERP, PMC *key)>
227
228 Creates a new PMC of type C<key>. You probably do not want this function as
229 it is only used by a few experimental opcodes. See C<Parrot_pmc_new()> instead.
230
231 =cut
232
233 */
234
235 PARROT_EXPORT
236 PARROT_CANNOT_RETURN_NULL
237 PARROT_WARN_UNUSED_RESULT
238 PMC *
Parrot_pmc_new_from_type(PARROT_INTERP,ARGIN (PMC * key))239 Parrot_pmc_new_from_type(PARROT_INTERP, ARGIN(PMC *key))
240 {
241 ASSERT_ARGS(Parrot_pmc_new_from_type)
242
243 PMC *pmc;
244 PMC *const classobj = Parrot_oo_get_class(interp, key);
245
246 if (!PMC_IS_NULL(classobj))
247 pmc = VTABLE_instantiate(interp, classobj, PMCNULL);
248 else {
249 const INTVAL type = Parrot_pmc_get_type(interp, key);
250
251 if (type <= 0) {
252 Parrot_ex_throw_from_c_args(interp, NULL,
253 EXCEPTION_NO_CLASS, "Class '%Ss' not found",
254 VTABLE_get_repr(interp, key));
255 }
256
257 pmc = Parrot_pmc_new(interp, type);
258 }
259
260 return pmc;
261 }
262
263 /*
264
265 =item C<PMC * Parrot_pmc_reuse(PARROT_INTERP, PMC *pmc, INTVAL new_type, UINTVAL
266 flags)>
267
268 Reuse an existing PMC, turning it into an empty PMC of the new type. Any
269 required internal structure will be put in place (such as the extension area)
270 and the PMC will be ready to go.
271
272 Cannot currently handle converting a non-Object PMC into an Object. Use
273 C<pmc_reuse_by_class> for that.
274
275
276 =cut
277
278 */
279
280 PARROT_EXPORT
281 PARROT_CANNOT_RETURN_NULL
282 PARROT_IGNORABLE_RESULT
283 PMC *
Parrot_pmc_reuse(PARROT_INTERP,ARGMOD (PMC * pmc),INTVAL new_type,SHIM (UINTVAL flags))284 Parrot_pmc_reuse(PARROT_INTERP, ARGMOD(PMC *pmc), INTVAL new_type, SHIM(UINTVAL flags))
285 {
286 ASSERT_ARGS(Parrot_pmc_reuse)
287 pmc = Parrot_pmc_reuse_noinit(interp, pmc, new_type);
288
289 /* Call the base init for the redone pmc. Warning, this should not
290 be called on Object PMCs. */
291 VTABLE_init(interp, pmc);
292
293 return pmc;
294 }
295
296 /*
297
298 =item C<PMC * Parrot_pmc_reuse_init(PARROT_INTERP, PMC *pmc, INTVAL new_type,
299 PMC *init, UINTVAL flags)>
300
301 Reuse an existing PMC, turning it into an PMC of the new type. Any
302 required internal structure will be put in place (such as the extension area)
303 and the PMC will be inited.
304
305 Cannot currently handle converting a non-Object PMC into an Object. Use
306 C<pmc_reuse_by_class> for that.
307
308
309 =cut
310
311 */
312
313 PARROT_EXPORT
314 PARROT_CANNOT_RETURN_NULL
315 PARROT_IGNORABLE_RESULT
316 PMC *
Parrot_pmc_reuse_init(PARROT_INTERP,ARGMOD (PMC * pmc),INTVAL new_type,ARGIN (PMC * init),SHIM (UINTVAL flags))317 Parrot_pmc_reuse_init(PARROT_INTERP, ARGMOD(PMC *pmc), INTVAL new_type, ARGIN(PMC *init),
318 SHIM(UINTVAL flags))
319 {
320 ASSERT_ARGS(Parrot_pmc_reuse_init)
321 pmc = Parrot_pmc_reuse_noinit(interp, pmc, new_type);
322
323 /* Call the base init for the redone pmc. Warning, this should not
324 be called on Object PMCs. */
325 VTABLE_init_pmc(interp, pmc, init);
326
327 return pmc;
328 }
329
330 /*
331
332 =item C<static PMC* Parrot_pmc_reuse_noinit(PARROT_INTERP, PMC *pmc, INTVAL
333 new_type)>
334
335 Prepare pmc for reuse. Do all scuffolding except initing.
336
337 =cut
338
339 */
340
341 PARROT_CANNOT_RETURN_NULL
342 PARROT_WARN_UNUSED_RESULT
343 static PMC*
Parrot_pmc_reuse_noinit(PARROT_INTERP,ARGMOD (PMC * pmc),INTVAL new_type)344 Parrot_pmc_reuse_noinit(PARROT_INTERP, ARGMOD(PMC *pmc), INTVAL new_type)
345 {
346 ASSERT_ARGS(Parrot_pmc_reuse_noinit)
347
348 if (pmc->vtable->base_type != new_type) {
349 const Parrot_UInt gc_flags = pmc->flags & PObj_GC_all_FLAGS;
350 VTABLE * const new_vtable = interp->vtables[new_type];
351
352 /* Singleton/const PMCs/types are not eligible */
353 check_pmc_reuse_flags(interp, pmc->vtable->flags, new_vtable->flags);
354
355 /* Free the old PMC resources. */
356 Parrot_pmc_destroy(interp, pmc);
357
358 /*
359 * We can reuse PMC from older generation. Preserve and soil it.
360 *
361 * FIXME It's abstraction leak. And it's really strange idea of reusing
362 * PMCs...
363 */
364 PObj_flags_SETTO(pmc, PObj_is_PMC_FLAG | gc_flags);
365 PARROT_GC_WRITE_BARRIER(interp, pmc);
366
367 /* Set the right vtable */
368 pmc->vtable = new_vtable;
369
370 if (new_vtable->attr_size)
371 Parrot_gc_allocate_pmc_attributes(interp, pmc);
372 else
373 PMC_data(pmc) = NULL;
374 }
375
376 return pmc;
377 }
378
379 /*
380
381 =item C<PMC * Parrot_pmc_reuse_by_class(PARROT_INTERP, PMC *pmc, PMC *class_,
382 UINTVAL flags)>
383
384 Reuse an existing PMC. Convert it to the type specified by the given Class
385 PMC. At the moment, this means we can only use this function to reuse PMCs
386 into types with Classes (not built-in PMCs). Use C<pmc_reuse> if you need
387 to convert to a built-in PMC type.
388
389 =cut
390
391 */
392
393 PARROT_EXPORT
394 PARROT_CANNOT_RETURN_NULL
395 PARROT_IGNORABLE_RESULT
396 PMC *
Parrot_pmc_reuse_by_class(PARROT_INTERP,ARGMOD (PMC * pmc),ARGIN (PMC * class_),UINTVAL flags)397 Parrot_pmc_reuse_by_class(PARROT_INTERP, ARGMOD(PMC *pmc), ARGIN(PMC *class_), UINTVAL flags)
398 {
399 ASSERT_ARGS(Parrot_pmc_reuse_by_class)
400 const INTVAL new_type = PARROT_CLASS(class_)->id;
401
402 if (pmc->vtable->base_type != new_type) {
403 VTABLE * const new_vtable = interp->vtables[new_type];
404
405 /* Singleton/const PMCs/types are not eligible */
406 check_pmc_reuse_flags(interp, pmc->vtable->flags, new_vtable->flags);
407
408 Parrot_pmc_destroy(interp, pmc);
409
410 PObj_flags_SETTO(pmc, PObj_is_PMC_FLAG | flags);
411
412 /* Set the right vtable */
413 pmc->vtable = new_vtable;
414
415 if (new_vtable->attr_size)
416 Parrot_gc_allocate_pmc_attributes(interp, pmc);
417 else
418 PMC_data(pmc) = NULL;
419 }
420
421 return pmc;
422 }
423
424 /*
425
426 =item C<Parrot_PMC Parrot_pmc_null(void)>
427
428 Returns the special C<NULL> PMC.
429
430 =cut
431
432 */
433
434 PARROT_EXPORT
435 PARROT_PURE_FUNCTION
436 PARROT_CAN_RETURN_NULL
437 Parrot_PMC
Parrot_pmc_null(void)438 Parrot_pmc_null(void)
439 {
440 ASSERT_ARGS(Parrot_pmc_null)
441 return PMCNULL;
442 }
443
444 /*
445
446 =item C<static void check_pmc_reuse_flags(PARROT_INTERP, UINTVAL srcflags,
447 UINTVAL destflags)>
448
449 We're converting one PMC type to another, either in C<pmc_reuse> or
450 C<pmc_reuse_by_class>. Check to make sure that neither the existing PMC
451 or the intended target PMC type are singletons or constants. We throw an
452 exception if we are attempting an illegal operation.
453
454 =cut
455
456 */
457
458 static void
check_pmc_reuse_flags(PARROT_INTERP,UINTVAL srcflags,UINTVAL destflags)459 check_pmc_reuse_flags(PARROT_INTERP, UINTVAL srcflags, UINTVAL destflags)
460 {
461 ASSERT_ARGS(check_pmc_reuse_flags)
462 if ((srcflags | destflags) & (VTABLE_PMC_IS_SINGLETON | VTABLE_IS_CONST_FLAG))
463 {
464 /* First, is the destination a singleton? No joy for us there */
465 if (destflags & VTABLE_PMC_IS_SINGLETON)
466 Parrot_ex_throw_from_c_noargs(interp,
467 EXCEPTION_ALLOCATION_ERROR,
468 "Can't turn to a singleton type");
469
470 /* Is the destination a constant? No joy for us there */
471 if (destflags & VTABLE_IS_CONST_FLAG)
472 Parrot_ex_throw_from_c_noargs(interp,
473 EXCEPTION_ALLOCATION_ERROR,
474 "Can't turn to a constant type");
475
476 /* Is the source a singleton? */
477 if (srcflags & VTABLE_PMC_IS_SINGLETON)
478 Parrot_ex_throw_from_c_noargs(interp,
479 EXCEPTION_ALLOCATION_ERROR,
480 "Can't modify a singleton");
481
482 /* Is the source constant? */
483 if (srcflags & VTABLE_IS_CONST_FLAG)
484 Parrot_ex_throw_from_c_noargs(interp,
485 EXCEPTION_ALLOCATION_ERROR,
486 "Can't modify a constant");
487 }
488 }
489
490 /*
491
492 =item C<static PMC * get_new_pmc_header(PARROT_INTERP, INTVAL base_type, UINTVAL
493 flags)>
494
495 Gets a new PMC header of the given integer type. Initialize the pmc if
496 necessary. In the case of singleton PMC types, get the existing singleton
497 instead of allocating a new one.
498
499 =cut
500
501 */
502
503 PARROT_WARN_UNUSED_RESULT
504 PARROT_CANNOT_RETURN_NULL
505 static PMC *
get_new_pmc_header(PARROT_INTERP,INTVAL base_type,UINTVAL flags)506 get_new_pmc_header(PARROT_INTERP, INTVAL base_type, UINTVAL flags)
507 {
508 ASSERT_ARGS(get_new_pmc_header)
509 PMC *newpmc = NULL;
510 VTABLE *vtable = interp->vtables[base_type];
511 UINTVAL vtable_flags;
512
513 /* This is usually because you either didn't call init_world early enough,
514 * you added a new PMC class without adding Parrot_(classname)_class_init
515 * to init_world, or you forgot to run 'make realclean' after adding a new
516 * PMC class. */
517 if (!vtable)
518 PANIC(interp, "Null vtable used; did you add a new PMC?");
519
520 /* Biggest L1 data read miss */
521 vtable_flags = vtable->flags;
522
523 /* we only have one global Env object, living in the interp */
524 if (vtable_flags & VTABLE_PMC_IS_SINGLETON) {
525 /*
526 * singletons (monadic objects) exist only once
527 * the interface * with the class is:
528 * - get_pointer: return NULL or a pointer to the single instance
529 * - set_pointer: set the only instance once
530 *
531 * - singletons are created in the constant pmc pool
532 */
533 PMC *pmc = (PMC *)(vtable->get_pointer)(interp, NULL);
534
535 /* LOCK */
536 if (!pmc) {
537 pmc = Parrot_gc_new_pmc_header(interp, PObj_constant_FLAG);
538 PARROT_ASSERT(pmc);
539
540 pmc->vtable = vtable;
541 VTABLE_set_pointer(interp, pmc, pmc);
542 }
543
544 return pmc;
545 }
546
547 if (vtable_flags & VTABLE_IS_CONST_PMC_FLAG)
548 flags |= PObj_constant_FLAG;
549 else if (vtable_flags & VTABLE_IS_CONST_FLAG) {
550 /* put the normal vtable in, so that the pmc can be initialized first
551 * parrot or user code has to set the _ro property then,
552 * to morph the PMC to the const variant
553 * This assumes that a constant PMC enum is one bigger then
554 * the normal one.
555 */
556
557 /*
558 * XXX not yet we can't assure that all contents in the
559 * const PMC is const too
560 * see e.g. t/pmc/sarray_13.pir
561 */
562 --base_type;
563 vtable = interp->vtables[base_type];
564 }
565
566 if (vtable_flags & VTABLE_IS_SHARED_FLAG)
567 flags |= PObj_is_PMC_shared_FLAG;
568
569 if (Interp_flags_TEST(interp, PARROT_THR_FLAG_NEW_PMC))
570 flags |= PObj_is_new_FLAG;
571
572 newpmc = Parrot_gc_new_pmc_header(interp, flags);
573 newpmc->vtable = vtable;
574
575 /* Another big L1 data read miss */
576 if (vtable->attr_size)
577 Parrot_gc_allocate_pmc_attributes(interp, newpmc);
578
579 return newpmc;
580 }
581
582
583 /*
584
585 =item C<PMC * Parrot_pmc_new_noinit(PARROT_INTERP, INTVAL base_type)>
586
587 Creates a new PMC of type C<base_type> (which is an index into the list of PMC
588 types declared in C<vtables> in F<include/parrot/pmc.h>). Unlike C<Parrot_pmc_new()>,
589 C<Parrot_pmc_new_noinit()> does not call its C<init> method. This allows separate
590 allocation and initialization for continuations.
591
592 =cut
593
594 */
595
596 PARROT_EXPORT
597 PARROT_CANNOT_RETURN_NULL
598 PMC *
Parrot_pmc_new_noinit(PARROT_INTERP,INTVAL base_type)599 Parrot_pmc_new_noinit(PARROT_INTERP, INTVAL base_type)
600 {
601 ASSERT_ARGS(Parrot_pmc_new_noinit)
602 PMC *const classobj = interp->vtables[base_type]->pmc_class;
603
604 if (!PMC_IS_NULL(classobj) && PObj_is_class_TEST(classobj))
605 return VTABLE_instantiate(interp, classobj, PMCNULL);
606
607 return get_new_pmc_header(interp, base_type, 0);
608 }
609
610
611 /*
612
613 =item C<PMC * Parrot_pmc_new_init(PARROT_INTERP, INTVAL base_type, PMC *init)>
614
615 As C<Parrot_pmc_new()>, but passes C<init> to the PMC's C<init_pmc()> vtable entry.
616
617 =cut
618
619 */
620
621 PARROT_EXPORT
622 PARROT_CANNOT_RETURN_NULL
623 PMC *
Parrot_pmc_new_init(PARROT_INTERP,INTVAL base_type,ARGOUT (PMC * init))624 Parrot_pmc_new_init(PARROT_INTERP, INTVAL base_type, ARGOUT(PMC *init))
625 {
626 ASSERT_ARGS(Parrot_pmc_new_init)
627 PMC *const classobj = interp->vtables[base_type]->pmc_class;
628
629 if (!PMC_IS_NULL(classobj) && PObj_is_class_TEST(classobj))
630 return VTABLE_instantiate(interp, classobj, init);
631 else {
632 PMC * const pmc = get_new_pmc_header(interp, base_type, 0);
633 VTABLE_init_pmc(interp, pmc, init);
634 return pmc;
635 }
636 }
637
638
639 /*
640
641 =item C<PMC * Parrot_pmc_new_init_int(PARROT_INTERP, INTVAL base_type, INTVAL
642 init)>
643
644 As C<Parrot_pmc_new()>, but passes C<init> to the PMC's C<init_int()> vtable entry.
645
646 =cut
647
648 */
649
650 PARROT_EXPORT
651 PARROT_CANNOT_RETURN_NULL
652 PMC *
Parrot_pmc_new_init_int(PARROT_INTERP,INTVAL base_type,INTVAL init)653 Parrot_pmc_new_init_int(PARROT_INTERP, INTVAL base_type, INTVAL init)
654 {
655 ASSERT_ARGS(Parrot_pmc_new_init_int)
656 PMC *const classobj = interp->vtables[base_type]->pmc_class;
657
658 if (!PMC_IS_NULL(classobj) && PObj_is_class_TEST(classobj)) {
659 PMC * const obj = VTABLE_instantiate(interp, classobj, PMCNULL);
660 VTABLE_set_integer_native(interp, obj, init);
661 return obj;
662 }
663 else {
664 PMC * const pmc = get_new_pmc_header(interp, base_type, 0);
665 VTABLE_init_int(interp, pmc, init);
666 return pmc;
667 }
668 }
669
670
671 /*
672
673 =item C<PMC * Parrot_pmc_new_temporary(PARROT_INTERP, INTVAL base_type)>
674
675 Creates a new temporary PMC of type C<base_type>, then call C<init>. Cannot
676 be used to create PMC Objects which have been defined from PIR.
677
678 B<You> are responsible for freeing this PMC when it goes out of scope with
679 C<Parrot_pmc_free_temporary()>. B<Do not> store this PMC in any other PMCs, or
680 allow it to be stored. B<Do not> store any regular PMC in this PMC, or
681 allow the storage of any regular PMC in this PMC. Temporary PMCs do not
682 participate in garbage collection, and mixing them with PMCs that are
683 garbage-collected will cause bugs.
684
685 If you don't know what this means, or you can't tell if either case
686 will happen as the result of any call you make on or with this PMC,
687 B<DO NOT> use this function, lest you cause weird crashes and memory errors.
688 Use C<Parrot_pmc_new()> instead.
689
690 (Why do these functions even exist? Used judiciously, they can reduce GC
691 pressure in hotspots tremendously. If you haven't audited the code carefully
692 -- including profiling and benchmarking -- then use C<Parrot_pmc_new()> instead, and
693 never B<ever> add C<PARROT_EXPORT> to either function.)
694
695 =cut
696
697 */
698
699 PARROT_CANNOT_RETURN_NULL
700 PMC *
Parrot_pmc_new_temporary(PARROT_INTERP,INTVAL base_type)701 Parrot_pmc_new_temporary(PARROT_INTERP, INTVAL base_type)
702 {
703 ASSERT_ARGS(Parrot_pmc_new_temporary)
704 PMC * const pmc = get_new_pmc_header(interp, base_type, PObj_constant_FLAG);
705 VTABLE_init(interp, pmc);
706 return pmc;
707 }
708
709
710 /*
711
712 =item C<void Parrot_pmc_free_temporary(PARROT_INTERP, PMC *pmc)>
713
714 Frees a new temporary PMC created by C<temporary_Parrot_pmc_new()>. Do not call
715 this with any other type of PMC. Do not forget to call this (or you'll leak
716 PMCs). Read and I<understand> the warnings for C<temporary_Parrot_pmc_new()> before
717 you're tempted to use this.
718
719 =cut
720
721 */
722
723 void
Parrot_pmc_free_temporary(PARROT_INTERP,ARGMOD (PMC * pmc))724 Parrot_pmc_free_temporary(PARROT_INTERP, ARGMOD(PMC *pmc))
725 {
726 ASSERT_ARGS(Parrot_pmc_free_temporary)
727 Parrot_gc_free_pmc_header(interp, pmc);
728 }
729
730
731 /*
732
733 =item C<INTVAL Parrot_pmc_get_new_vtable_index(PARROT_INTERP)>
734
735 Get a new unique identifier number and allocate a new vtable structure for a
736 new PMC type.
737
738 =cut
739
740 */
741
742 INTVAL
Parrot_pmc_get_new_vtable_index(PARROT_INTERP)743 Parrot_pmc_get_new_vtable_index(PARROT_INTERP)
744 {
745 ASSERT_ARGS(Parrot_pmc_get_new_vtable_index)
746 const INTVAL type_id = interp->n_vtable_max++;
747
748 /* Have we overflowed the table? */
749 if (type_id >= interp->n_vtable_alloced)
750 Parrot_vtbl_realloc_vtables(interp);
751
752 return type_id;
753 }
754
755 /*
756
757 =item C<INTVAL Parrot_pmc_register_new_type(PARROT_INTERP, STRING *name)>
758
759 Registers the name of a new PMC type with Parrot, returning the INTVAL
760 representing that type.
761
762 =cut
763
764 */
765
766 PARROT_EXPORT
767 INTVAL
Parrot_pmc_register_new_type(PARROT_INTERP,ARGIN (STRING * name))768 Parrot_pmc_register_new_type(PARROT_INTERP, ARGIN(STRING *name))
769 {
770 ASSERT_ARGS(Parrot_pmc_register_new_type)
771 /* If they're looking to register an existing class, return that
772 class' type number */
773 INTVAL type = Parrot_pmc_get_type_str(interp, name);
774
775 if (type > enum_type_undef)
776 return type;
777
778 if (type < enum_type_undef)
779 Parrot_ex_throw_from_c_noargs(interp, EXCEPTION_INVALID_OPERATION,
780 "undefined type already exists - can't register PMC");
781
782 type = Parrot_pmc_get_new_vtable_index(interp);
783
784 /* set entry in name->type hash */
785 VTABLE_set_integer_keyed_str(interp, interp->class_hash, name, type);
786
787 return type;
788 }
789
790
791 /*
792
793 =item C<INTVAL Parrot_pmc_get_type_str(PARROT_INTERP, STRING *name)>
794
795 Returns the PMC type for C<name>.
796
797 =cut
798
799 */
800
801 PARROT_EXPORT
802 PARROT_WARN_UNUSED_RESULT
803 INTVAL
Parrot_pmc_get_type_str(PARROT_INTERP,ARGIN_NULLOK (STRING * name))804 Parrot_pmc_get_type_str(PARROT_INTERP, ARGIN_NULLOK(STRING *name))
805 {
806 ASSERT_ARGS(Parrot_pmc_get_type_str)
807 if (STRING_IS_NULL(name))
808 return enum_type_undef;
809 else {
810 PMC * const classname_hash = interp->class_hash;
811 PMC * item =
812 (PMC *)VTABLE_get_pointer_keyed_str(interp, classname_hash, name);
813
814 if (!PMC_IS_NULL(item)) {
815 if (PMC_IS_TYPE(item, Proxy))
816 item = PARROT_PROXY(item)->target;
817
818 /* nested namespace with same name */
819 if (PMC_IS_TYPE(item, NameSpace))
820 return enum_type_undef;
821 else
822 return PARROT_INTEGER(item)->iv;
823 }
824 else
825 return -Parrot_dt_get_datatype_enum(interp, name);
826 }
827 }
828
829
830 /*
831
832 =item C<PMC * Parrot_pmc_box_string(PARROT_INTERP, STRING *string)>
833
834 Boxes a STRING C<string> into a String PMC.
835
836 =cut
837
838 */
839
840 PARROT_EXPORT
841 PARROT_HOT
842 PARROT_CANNOT_RETURN_NULL
843 PMC *
Parrot_pmc_box_string(PARROT_INTERP,ARGIN_NULLOK (STRING * string))844 Parrot_pmc_box_string(PARROT_INTERP, ARGIN_NULLOK(STRING *string))
845 {
846 ASSERT_ARGS(Parrot_pmc_box_string)
847 PMC * const ret = Parrot_pmc_new(interp,
848 Parrot_hll_get_ctx_HLL_type(interp, enum_class_String));
849 VTABLE_set_string_native(interp, ret, string);
850
851 return ret;
852 }
853
854
855 /*
856
857 =item C<PMC* Parrot_pmc_box_number(PARROT_INTERP, FLOATVAL value)>
858
859 Lookup the PMC type which is used for floating point numbers.
860
861 =cut
862
863 */
864
865 PARROT_EXPORT
866 PARROT_HOT
867 PARROT_CANNOT_RETURN_NULL
868 PMC*
Parrot_pmc_box_number(PARROT_INTERP,FLOATVAL value)869 Parrot_pmc_box_number(PARROT_INTERP, FLOATVAL value)
870 {
871 ASSERT_ARGS(Parrot_pmc_box_number)
872 PMC * const ret = Parrot_pmc_new(interp,
873 Parrot_hll_get_ctx_HLL_type(interp, enum_class_Float));
874 VTABLE_set_number_native(interp, ret, value);
875 return ret;
876 }
877
878
879 /*
880
881 =item C<PMC* Parrot_pmc_box_integer(PARROT_INTERP, INTVAL value)>
882
883 Lookup the PMC type which is used for storing native integers.
884
885 =cut
886
887 */
888
889 PARROT_EXPORT
890 PARROT_HOT
891 PARROT_CANNOT_RETURN_NULL
892 PMC*
Parrot_pmc_box_integer(PARROT_INTERP,INTVAL value)893 Parrot_pmc_box_integer(PARROT_INTERP, INTVAL value)
894 {
895 ASSERT_ARGS(Parrot_pmc_box_integer)
896 PMC * const ret = Parrot_pmc_new(interp,
897 Parrot_hll_get_ctx_HLL_type(interp, enum_class_Integer));
898 VTABLE_set_integer_native(interp, ret, value);
899 return ret;
900 }
901
902 /*
903
904 =item C<PMC * Parrot_pmc_box_c_string_array(PARROT_INTERP, int count, const char
905 **s)>
906
907 Take a C string array and a count, and box it into a string array PMC
908
909 =cut
910
911 */
912
913 PARROT_EXPORT
914 PARROT_CANNOT_RETURN_NULL
915 PMC *
Parrot_pmc_box_c_string_array(PARROT_INTERP,int count,ARGIN (const char ** s))916 Parrot_pmc_box_c_string_array(PARROT_INTERP, int count, ARGIN(const char **s))
917 {
918 ASSERT_ARGS(Parrot_pmc_box_c_string_array)
919 PMC * const s_pmc = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
920
921 if (s != NULL && count > 0) {
922 Parrot_Int i = 0;
923 for (; i < count; ++i) {
924 /* Run through argv, adding everything to the array */
925 STRING * const item = Parrot_str_from_platform_cstring(interp, s[i]);
926 VTABLE_push_string(interp, s_pmc, item);
927 }
928 }
929 return s_pmc;
930 }
931
932
933 /*
934
935 =item C<INTVAL Parrot_pmc_get_type(PARROT_INTERP, PMC *name)>
936
937 Returns the PMC type for C<name>.
938
939 =cut
940
941 */
942
943 PARROT_EXPORT
944 INTVAL
Parrot_pmc_get_type(PARROT_INTERP,ARGIN (PMC * name))945 Parrot_pmc_get_type(PARROT_INTERP, ARGIN(PMC *name))
946 {
947 ASSERT_ARGS(Parrot_pmc_get_type)
948 PMC * const classname_hash = interp->class_hash;
949 PMC * const item = (PMC *)VTABLE_get_pointer_keyed(interp, classname_hash, name);
950
951 if (!PMC_IS_NULL(item))
952 return VTABLE_get_integer(interp, item);
953
954 return 0;
955 }
956
957
958 /*
959
960 =item C<static PMC * create_class_pmc(PARROT_INTERP, INTVAL type)>
961
962 Create a class object for this interpreter. Takes an interpreter name and type
963 as arguments. Returns a pointer to the class object.
964
965 =cut
966
967 */
968
969 PARROT_WARN_UNUSED_RESULT
970 PARROT_CANNOT_RETURN_NULL
971 static PMC *
create_class_pmc(PARROT_INTERP,INTVAL type)972 create_class_pmc(PARROT_INTERP, INTVAL type)
973 {
974 ASSERT_ARGS(create_class_pmc)
975 /*
976 * class interface - a PMC is its own class
977 * put an instance of this PMC into class
978 *
979 * create a constant PMC
980 */
981 PMC * const _class = get_new_pmc_header(interp, type,
982 PObj_constant_FLAG);
983
984 /* If we are a second thread, we may get the same object as the
985 * original because we have a singleton. Just set the singleton to
986 * be our class object, but don't mess with its vtable. */
987 if ((interp->vtables[type]->flags & VTABLE_PMC_IS_SINGLETON)
988 && (_class == _class->vtable->pmc_class))
989 interp->vtables[type]->pmc_class = _class;
990 else {
991 PObj_is_PMC_shared_CLEAR(_class);
992 interp->vtables[type]->pmc_class = _class;
993 }
994
995 return _class;
996 }
997
998
999 /*
1000
1001 =item C<void Parrot_pmc_create_mro(PARROT_INTERP, INTVAL type)>
1002
1003 Create the MRO (method resolution order) array for this type.
1004
1005 =cut
1006
1007 */
1008
1009 PARROT_EXPORT
1010 void
Parrot_pmc_create_mro(PARROT_INTERP,INTVAL type)1011 Parrot_pmc_create_mro(PARROT_INTERP, INTVAL type)
1012 {
1013 ASSERT_ARGS(Parrot_pmc_create_mro)
1014 PMC *mro;
1015 VTABLE *vtable = interp->vtables[type];
1016 PMC * const mro_list = vtable->mro;
1017 INTVAL i, count;
1018
1019 /* this should never be PMCNULL */
1020 PARROT_ASSERT(!PMC_IS_NULL(mro_list));
1021
1022 /* multithreaded: has already mro */
1023 if (mro_list->vtable->base_type != enum_class_ResizableStringArray)
1024 return;
1025
1026 mro = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
1027 vtable->mro = mro;
1028
1029 if (vtable->ro_variant_vtable)
1030 vtable->ro_variant_vtable->mro = mro;
1031
1032 count = VTABLE_elements(interp, mro_list);
1033
1034 for (i = 0; i < count; ++i) {
1035 STRING * const class_name = VTABLE_get_string_keyed_int(interp, mro_list, i);
1036 const INTVAL parent_type = Parrot_pmc_get_type_str(interp, class_name);
1037 PMC *_class;
1038
1039 /* abstract classes don't have a vtable */
1040 if (!parent_type)
1041 break;
1042
1043 vtable = interp->vtables[parent_type];
1044
1045 if (!vtable->_namespace) {
1046 /* need a namespace Hash, anchor at parent, name it */
1047 PMC * const ns = Parrot_pmc_new(interp,
1048 Parrot_hll_get_ctx_HLL_type(interp, enum_class_NameSpace));
1049 vtable->_namespace = ns;
1050
1051 /* anchor at parent, aka current_namespace, that is 'parrot' */
1052 VTABLE_set_pmc_keyed_str(interp,
1053 Parrot_pcc_get_namespace(interp, CURRENT_CONTEXT(interp)), class_name, ns);
1054 }
1055
1056 _class = vtable->pmc_class;
1057 if (!_class)
1058 _class = create_class_pmc(interp, parent_type);
1059
1060 VTABLE_push_pmc(interp, mro, _class);
1061 }
1062 }
1063
1064
1065 /*
1066
1067 =back
1068
1069 =head2 GC registry interface
1070
1071 =over 4
1072
1073 =item C<void Parrot_pmc_gc_register(PARROT_INTERP, PMC *pmc)>
1074
1075 Registers the PMC with the interpreter's GC registry.
1076
1077 =cut
1078
1079 */
1080
1081 PARROT_EXPORT
1082 void
Parrot_pmc_gc_register(PARROT_INTERP,ARGIN (PMC * pmc))1083 Parrot_pmc_gc_register(PARROT_INTERP, ARGIN(PMC *pmc))
1084 {
1085 ASSERT_ARGS(Parrot_pmc_gc_register)
1086 /* Better not trigger a GC run with a potentially unanchored PMC */
1087 Parrot_block_GC_mark(interp);
1088
1089 PARROT_ASSERT(interp->gc_registry);
1090
1091 VTABLE_set_pmc_keyed(interp, interp->gc_registry, pmc, PMCNULL);
1092 Parrot_unblock_GC_mark(interp);
1093 }
1094
1095 /*
1096
1097 =item C<void Parrot_pmc_gc_unregister(PARROT_INTERP, PMC *pmc)>
1098
1099 Unregisters the PMC from the interpreter's GC registry.
1100
1101 =cut
1102
1103 */
1104
1105 PARROT_EXPORT
1106 void
Parrot_pmc_gc_unregister(PARROT_INTERP,ARGIN (PMC * pmc))1107 Parrot_pmc_gc_unregister(PARROT_INTERP, ARGIN(PMC *pmc))
1108 {
1109 ASSERT_ARGS(Parrot_pmc_gc_unregister)
1110 PARROT_ASSERT(interp->gc_registry);
1111
1112 VTABLE_delete_keyed(interp, interp->gc_registry, pmc);
1113 }
1114
1115 /*
1116
1117 =item C<INTVAL Parrot_pmc_type_does(PARROT_INTERP, const STRING *role, INTVAL
1118 type)>
1119
1120 Checks to see if PMCs of the given type does the given role. Checks
1121 C<<vtable->provides_str>> to find a match.
1122 Returns true (1) if B<role> is found, false (0) otherwise.
1123
1124 =cut
1125
1126 */
1127
1128 INTVAL
Parrot_pmc_type_does(PARROT_INTERP,ARGIN (const STRING * role),INTVAL type)1129 Parrot_pmc_type_does(PARROT_INTERP, ARGIN(const STRING *role), INTVAL type)
1130 {
1131 ASSERT_ARGS(Parrot_pmc_type_does)
1132
1133 INTVAL pos = 0;
1134 STRING * const what = interp->vtables[type]->provides_str;
1135 INTVAL length = Parrot_str_byte_length(interp, what);
1136
1137 do {
1138 INTVAL len;
1139 const INTVAL idx = STRING_index(interp, what, role, pos);
1140
1141 if ((idx < 0) || (idx >= length))
1142 return 0;
1143
1144 pos = idx;
1145 len = Parrot_str_byte_length(interp, role);
1146
1147 if (pos && (STRING_ord(interp, what, pos - 1) != 32)) {
1148 pos += len;
1149 continue;
1150 }
1151
1152 if (pos + len < length) {
1153 pos += len;
1154 if (STRING_ord(interp, what, pos) != 32)
1155 continue;
1156 }
1157
1158 return 1;
1159 } while (1);
1160 }
1161
1162
1163 /*
1164
1165 =item C<PMC * Parrot_pmc_getprop(PARROT_INTERP, PMC *pmc, STRING *key)>
1166
1167 Returns the property for C<*key>. If no property is defined then the
1168 NULL PMC is returned.
1169
1170 =cut
1171
1172 */
1173
1174 PARROT_EXPORT
1175 PARROT_CAN_RETURN_NULL
1176 PMC *
Parrot_pmc_getprop(PARROT_INTERP,ARGIN (PMC * pmc),ARGIN (STRING * key))1177 Parrot_pmc_getprop(PARROT_INTERP, ARGIN(PMC *pmc), ARGIN(STRING *key))
1178 {
1179 ASSERT_ARGS(Parrot_pmc_getprop)
1180 if (PMC_IS_NULL(PMC_metadata(pmc)))
1181 return check_get_std_props(interp, pmc, key);
1182 else
1183 return VTABLE_get_pmc_keyed_str(interp, PMC_metadata(pmc), key);
1184 }
1185
1186 /*
1187
1188 =item C<void Parrot_pmc_setprop(PARROT_INTERP, PMC *pmc, STRING *key, PMC
1189 *value)>
1190
1191 Sets the property for C<*key> to C<*value>.
1192
1193 =cut
1194
1195 */
1196
1197 PARROT_EXPORT
1198 void
Parrot_pmc_setprop(PARROT_INTERP,ARGIN (PMC * pmc),ARGIN (STRING * key),ARGIN (PMC * value))1199 Parrot_pmc_setprop(PARROT_INTERP, ARGIN(PMC *pmc), ARGIN(STRING *key), ARGIN(PMC *value))
1200 {
1201 ASSERT_ARGS(Parrot_pmc_setprop)
1202 if (check_set_std_props(interp, pmc, key, value))
1203 return;
1204
1205 if (PMC_IS_NULL(PMC_metadata(pmc)))
1206 PMC_metadata(pmc) = make_prop_hash(interp, pmc);
1207
1208 VTABLE_set_pmc_keyed_str(interp, PMC_metadata(pmc), key, value);
1209 }
1210
1211 /*
1212
1213 =item C<void Parrot_pmc_delprop(PARROT_INTERP, PMC *pmc, STRING *key)>
1214
1215 Deletes the property for C<*key>.
1216
1217 =cut
1218
1219 */
1220
1221 PARROT_EXPORT
1222 void
Parrot_pmc_delprop(PARROT_INTERP,ARGIN (PMC * pmc),ARGIN (STRING * key))1223 Parrot_pmc_delprop(PARROT_INTERP, ARGIN(PMC *pmc), ARGIN(STRING *key))
1224 {
1225 ASSERT_ARGS(Parrot_pmc_delprop)
1226 if (!PMC_IS_NULL(PMC_metadata(pmc)))
1227 VTABLE_delete_keyed_str(interp, PMC_metadata(pmc), key);
1228 }
1229
1230 /*
1231
1232 =item C<PMC * Parrot_pmc_getprops(PARROT_INTERP, PMC *pmc)>
1233
1234 Returns the PMC's properties or the NULL PMC if no properties exist.
1235
1236 =cut
1237
1238 */
1239
1240 PARROT_EXPORT
1241 PARROT_CAN_RETURN_NULL
1242 PMC *
Parrot_pmc_getprops(PARROT_INTERP,ARGIN (PMC * pmc))1243 Parrot_pmc_getprops(PARROT_INTERP, ARGIN(PMC *pmc))
1244 {
1245 ASSERT_ARGS(Parrot_pmc_getprops)
1246 if (PMC_IS_NULL(PMC_metadata(pmc))) {
1247 if (has_pending_std_props(pmc))
1248 PMC_metadata(pmc) = make_prop_hash(interp, pmc);
1249 else
1250 return PMCNULL;
1251 }
1252
1253 return PMC_metadata(pmc);
1254 }
1255
1256 /*
1257
1258 =item C<static INTVAL check_set_std_props(PARROT_INTERP, PMC *pmc, const STRING
1259 *key, PMC *value)>
1260
1261 Called from C<setprop()>.
1262
1263 Returns a true value if C<setprop()> can avoid actually setting a property
1264 in the prophash. If it returns true, the property setting will be reflected
1265 in a future call to C<propagate_std_props()>
1266
1267 =cut
1268
1269 */
1270
1271 PARROT_WARN_UNUSED_RESULT
1272 static INTVAL
check_set_std_props(PARROT_INTERP,ARGMOD (PMC * pmc),ARGIN (const STRING * key),ARGMOD (PMC * value))1273 check_set_std_props(PARROT_INTERP, ARGMOD(PMC *pmc), ARGIN(const STRING *key), ARGMOD(PMC *value))
1274 {
1275 ASSERT_ARGS(check_set_std_props)
1276
1277 /*
1278 * s2 in STRING_equal is freed here
1279 */
1280 if (STRING_equal(interp, key, CONST_STRING(interp, "_ro"))) {
1281 /* pmc should set/clear readonly */
1282 const INTVAL on = VTABLE_get_bool(interp, value);
1283
1284 /* morph to Const/normal class or readonly class */
1285 if (on && (pmc->vtable->flags & VTABLE_HAS_CONST_TOO))
1286 pmc->vtable = interp->vtables[pmc->vtable->base_type + 1];
1287 else if (!on && (pmc->vtable->flags & (VTABLE_IS_CONST_FLAG)))
1288 VTABLE_morph(interp, pmc, interp->vtables[pmc->vtable->base_type - 1]->pmc_class);
1289 else if (on && (pmc->vtable->flags & VTABLE_HAS_READONLY_FLAG))
1290 pmc->vtable = pmc->vtable->ro_variant_vtable;
1291 else if (!on && (pmc->vtable->flags & VTABLE_IS_READONLY_FLAG)
1292 && pmc->vtable->ro_variant_vtable)
1293 pmc->vtable = pmc->vtable->ro_variant_vtable;
1294 else
1295 return 0;
1296
1297 return 1;
1298 }
1299
1300 return 0;
1301 }
1302
1303 /*
1304
1305 =item C<static void propagate_std_props(PARROT_INTERP, PMC *self, PMC
1306 *prop_hash)>
1307
1308 Set pending standard properties in C<prop_hash>.
1309
1310 =cut
1311
1312 */
1313
1314 static void
propagate_std_props(PARROT_INTERP,ARGIN (PMC * self),ARGIN (PMC * prop_hash))1315 propagate_std_props(PARROT_INTERP, ARGIN(PMC *self), ARGIN(PMC *prop_hash))
1316 {
1317 ASSERT_ARGS(propagate_std_props)
1318
1319 if (self->vtable->flags & (VTABLE_IS_CONST_FLAG | VTABLE_IS_READONLY_FLAG)){
1320 PMC * const pmc_true = Parrot_pmc_new_init_int(interp,
1321 enum_class_Integer, 1);
1322 VTABLE_set_pmc_keyed_str(interp, prop_hash, CONST_STRING(interp, "_ro"), pmc_true);
1323 }
1324 }
1325
1326 /*
1327
1328 =item C<static INTVAL has_pending_std_props(const PMC *self)>
1329
1330 Returns true if propagate_std_props() would create a non-empty prophash.
1331
1332 =cut
1333
1334 */
1335
1336 PARROT_WARN_UNUSED_RESULT
1337 static INTVAL
has_pending_std_props(ARGIN (const PMC * self))1338 has_pending_std_props(ARGIN(const PMC *self))
1339 {
1340 ASSERT_ARGS(has_pending_std_props)
1341
1342 if (self->vtable->flags & (VTABLE_IS_CONST_FLAG | VTABLE_IS_READONLY_FLAG))
1343 return 1;
1344 else
1345 return 0;
1346 }
1347
1348
1349 /*
1350
1351 =item C<static PMC* check_get_std_props(PARROT_INTERP, const PMC *self, const
1352 STRING *key)>
1353
1354 Checks if we can infer the value of C<key> property from C<self> without
1355 looking at its prophash. Returns C<PMCNULL> if not, returns the value otherwise.
1356
1357 =cut
1358
1359 */
1360
1361 PARROT_WARN_UNUSED_RESULT
1362 PARROT_CAN_RETURN_NULL
1363 static PMC*
check_get_std_props(PARROT_INTERP,ARGIN (const PMC * self),ARGIN (const STRING * key))1364 check_get_std_props(PARROT_INTERP, ARGIN(const PMC *self), ARGIN(const STRING *key))
1365 {
1366 ASSERT_ARGS(check_get_std_props)
1367
1368 if ((self->vtable->flags & (VTABLE_IS_CONST_FLAG | VTABLE_IS_READONLY_FLAG))
1369 && STRING_equal(interp, key, CONST_STRING(interp, "_ro"))) {
1370 PMC * const ret_val = Parrot_pmc_new_init_int(interp,
1371 enum_class_Integer, 1);
1372 return ret_val;
1373 }
1374 else
1375 return PMCNULL;
1376 }
1377
1378 /*
1379
1380 =item C<static PMC* make_prop_hash(PARROT_INTERP, PMC *self)>
1381
1382 Create a property hash for C<self>. Returns the created hash. Inferred
1383 properties will be added to the hash.
1384
1385 =cut
1386
1387 */
1388
1389 PARROT_CANNOT_RETURN_NULL
1390 PARROT_WARN_UNUSED_RESULT
1391 static PMC*
make_prop_hash(PARROT_INTERP,ARGMOD (PMC * self))1392 make_prop_hash(PARROT_INTERP, ARGMOD(PMC *self))
1393 {
1394 ASSERT_ARGS(make_prop_hash)
1395
1396 PMC * const prop = Parrot_pmc_new(interp, enum_class_Hash);
1397
1398 propagate_std_props(interp, self, prop);
1399 PARROT_GC_WRITE_BARRIER(interp, self);
1400 return prop;
1401 }
1402
1403 /*
1404
1405 =back
1406
1407 =head1 SEE ALSO
1408
1409 F<include/parrot/pmc.h>, F<include/parrot/vtable.h>,
1410 L<http://www.nntp.perl.org/group/perl.perl6.internals/2001/10/msg5516.html>
1411
1412 =cut
1413
1414 */
1415
1416 /*
1417 * Local variables:
1418 * c-file-style: "parrot"
1419 * End:
1420 * vim: expandtab shiftwidth=4 cinoptions='\:2=2' :
1421 */
1422