src/hll.c

   1 /*
   2 Copyright (C) 2005-2009, Parrot Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/hll.c - High Level Language support
   8
   9 =head1 DESCRIPTION
  10
  11 The Parrot core sometimes has to create new PMCs which should map to the
  12 current HLL's defaults. The current language and a typemap provides this
  13 feature.
  14
  15 =head1 DATA
  16
  17    interp->HLL_info
  18
  19    @HLL_info = [
  20      [ hll_name, hll_lib, { core_type => HLL_type, ... }, namespace, hll_id ],
  21      ...
  22      ]
  23
  24 =head2 Functions
  25
  26 =over 4
  27
  28 =cut
  29
  30 */
  31
  32 #include "parrot/parrot.h"
  33 #include "parrot/dynext.h"
  34 #include "pmc/pmc_callcontext.h"
  35 #include "hll.str"
  36
  37 /* HEADERIZER HFILE: include/parrot/hll.h */
  38
  39 /* HEADERIZER BEGIN: static */
  40 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
  41
  42 PARROT_CANNOT_RETURN_NULL
  43 PARROT_WARN_UNUSED_RESULT
  44 static PMC* new_hll_entry(PARROT_INTERP, ARGIN_NULLOK(STRING *entry_name))
  45         __attribute__nonnull__(1);
  46
  47 #define ASSERT_ARGS_new_hll_entry __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
  48        PARROT_ASSERT_ARG(interp))
  49 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
  50 /* HEADERIZER END: static */
  51
  52 /* for shared HLL data, do COW stuff */
  53 #define START_READ_HLL_INFO(interp, hll_info)
  54 #define END_READ_HLL_INFO(interp, hll_info)
  55 #define START_WRITE_HLL_INFO(interp, hll_info) \
  56     do { \
  57         if (PObj_is_PMC_shared_TEST(hll_info) && PMC_sync((interp)->HLL_info)) { \
  58             (hll_info) = (interp)->HLL_info = \
  59                 Parrot_clone((interp), (interp)->HLL_info); \
  60             if (PMC_sync((interp)->HLL_info)) \
  61                 mem_internal_free(PMC_sync((interp)->HLL_info)); \
  62         } \
  63     } while (0)
  64 #define END_WRITE_HLL_INFO(interp, hll_info)
  65
  66
  67 /*
  68
  69 =item C<static PMC* new_hll_entry(PARROT_INTERP, STRING *entry_name)>
  70
  71 Create a new HLL information table entry.
  72 Takes an interpreter name and (optional) entry name.
  73 Returns a pointer to the new entry.
  74 Used by Parrot_register_HLL and Parrot_register_HLL_lib.
  75
  76 =cut
  77
  78 */
  79
  80 PARROT_CANNOT_RETURN_NULL
  81 PARROT_WARN_UNUSED_RESULT
  82 static PMC*
  83 new_hll_entry(PARROT_INTERP, ARGIN_NULLOK(STRING *entry_name))
  84 {
  85     ASSERT_ARGS(new_hll_entry)
  86     PMC * const hll_info = interp->HLL_info;
  87     const INTVAL id      = VTABLE_elements(interp, hll_info);
  88
  89     PMC *entry_id;
  90
  91     PMC * const entry = Parrot_pmc_new_constant_init_int(interp,
  92             enum_class_FixedPMCArray, e_HLL_MAX);
  93
  94     if (entry_name && !STRING_IS_EMPTY(entry_name)) {
  95         VTABLE_set_pmc_keyed_str(interp, hll_info, entry_name, entry);
  96     }
  97     else
  98         VTABLE_push_pmc(interp, hll_info, entry);
  99
 100     entry_id = Parrot_pmc_new_constant(interp, enum_class_Integer);
 101     VTABLE_set_integer_native(interp, entry_id, id);
 102     VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_id, entry_id);
 103
 104     return entry;
 105 }
 106
 107
 108 /*
 109
 110 =item C<void Parrot_init_HLL(PARROT_INTERP)>
 111
 112 Initialises the HLL_info and HLL_namespace fields of the interpreter structure.
 113 Registers the default HLL namespace "parrot".
 114
 115 =cut
 116
 117 */
 118
 119 void
 120 Parrot_init_HLL(PARROT_INTERP)
 121 {
 122     ASSERT_ARGS(Parrot_init_HLL)
 123     interp->HLL_info      =
 124         Parrot_pmc_new(interp, enum_class_OrderedHash);
 125     interp->HLL_namespace =
 126         Parrot_pmc_new_constant(interp, enum_class_ResizablePMCArray);
 127
 128     Parrot_register_HLL(interp, CONST_STRING(interp, "parrot"));
 129 }
 130
 131 /*
 132
 133 =item C<INTVAL Parrot_register_HLL(PARROT_INTERP, STRING *hll_name)>
 134
 135 Register the HLL with the given STRING name C<hll_name> in the interpreter.
 136
 137 If the HLL has already been registered, the ID of the HLL is returned.
 138 Otherwise the HLL is registered, a corresponding HLL namespace is created,
 139 and the HLL ID is returned.
 140
 141 If there is an error, C<-1> is returned.
 142
 143 =cut
 144
 145 */
 146
 147 PARROT_EXPORT
 148 INTVAL
 149 Parrot_register_HLL(PARROT_INTERP, ARGIN(STRING *hll_name))
 150 {
 151     ASSERT_ARGS(Parrot_register_HLL)
 152     PMC   *entry, *name, *type_hash, *ns_hash, *hll_info;
 153     INTVAL idx;
 154
 155     /* TODO LOCK or disallow in threads */
 156
 157     idx = Parrot_get_HLL_id(interp, hll_name);
 158
 159     if (idx >= 0)
 160         return idx;
 161
 162     hll_info = interp->HLL_info;
 163
 164     START_WRITE_HLL_INFO(interp, hll_info);
 165
 166     idx      = VTABLE_elements(interp, hll_info);
 167     entry    = new_hll_entry(interp, hll_name);
 168
 169     /* register HLL name */
 170     name     = Parrot_pmc_new_constant(interp, enum_class_String);
 171
 172     VTABLE_set_string_native(interp, name, hll_name);
 173     VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_name, name);
 174
 175     /* create HLL namespace using the *constant* name */
 176     hll_name = Parrot_str_downcase(interp, VTABLE_get_string(interp, name));
 177
 178     /* HLL type mappings aren't yet created, we can't create
 179      * a namespace in HLL's flavor yet - maybe promote the
 180      * ns_hash to another type, if mappings provide one
 181      * XXX - FIXME
 182      */
 183     ns_hash = Parrot_make_namespace_keyed_str(interp, interp->root_namespace,
 184                                               hll_name);
 185
 186     /* cache HLL's toplevel namespace */
 187     VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace, idx, ns_hash);
 188
 189     /* create HLL typemap hash */
 190     type_hash = Parrot_pmc_new_constant(interp, enum_class_Hash);
 191     VTABLE_set_pointer(interp, type_hash, parrot_new_intval_hash(interp));
 192     VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_typemap, type_hash);
 193
 194     /* UNLOCK */
 195     END_WRITE_HLL_INFO(interp, hll_info);
 196
 197     return idx;
 198 }
 199
 200 /*
 201
 202 =item C<INTVAL Parrot_register_HLL_lib(PARROT_INTERP, STRING *hll_lib)>
 203
 204 Register an HLL library.
 205 Takes a pointer to a library name STRING to add. If the name has already
 206 been registered the list position of the library in the HLL Info list is
 207 returned. Otherwise, the library is added to the list and 0 is returned.
 208
 209 =cut
 210
 211 */
 212
 213 PARROT_EXPORT
 214 INTVAL
 215 Parrot_register_HLL_lib(PARROT_INTERP, ARGIN(STRING *hll_lib))
 216 {
 217     ASSERT_ARGS(Parrot_register_HLL_lib)
 218     PMC   *hll_info = interp->HLL_info;
 219     INTVAL nelements, i;
 220
 221     START_WRITE_HLL_INFO(interp, hll_info);
 222
 223     nelements = VTABLE_elements(interp, hll_info);
 224
 225     for (i = 0; i < nelements; ++i) {
 226         PMC * const entry    = VTABLE_get_pmc_keyed_int(interp, hll_info, i);
 227         PMC * const lib_name = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_lib);
 228
 229         if (!PMC_IS_NULL(lib_name)) {
 230             const STRING * const lib_name_str = VTABLE_get_string(interp, lib_name);
 231             if (Parrot_str_equal(interp, lib_name_str, hll_lib))
 232                 break;
 233         }
 234     }
 235
 236     if (i < nelements)
 237         return i;
 238     else {
 239         PMC * const new_entry = new_hll_entry(interp, NULL);
 240         PMC *name;
 241
 242         VTABLE_set_pmc_keyed_int(interp, new_entry, e_HLL_name, PMCNULL);
 243
 244         /* register dynlib */
 245         name    = Parrot_pmc_new_constant(interp, enum_class_String);
 246
 247         VTABLE_set_string_native(interp, name, hll_lib);
 248         VTABLE_set_pmc_keyed_int(interp, new_entry, e_HLL_lib, name);
 249
 250         END_WRITE_HLL_INFO(interp, hll_info);
 251
 252         return 0;
 253     }
 254 }
 255
 256 /*
 257
 258 =item C<INTVAL Parrot_get_HLL_id(PARROT_INTERP, STRING *hll_name)>
 259
 260 Returns the ID number of the HLL with the given name. The default HLL namespace
 261 C<parrot> has an ID number of 0. On error, or if an HLL with the given name
 262 does not exist, returns -1.
 263
 264 =cut
 265
 266 */
 267
 268 PARROT_EXPORT
 269 PARROT_WARN_UNUSED_RESULT
 270 INTVAL
 271 Parrot_get_HLL_id(PARROT_INTERP, ARGIN_NULLOK(STRING *hll_name))
 272 {
 273     ASSERT_ARGS(Parrot_get_HLL_id)
 274     PMC *       entry;
 275     PMC * const hll_info = interp->HLL_info;
 276     INTVAL      i        = -1;
 277
 278     if (!hll_name)
 279         return i;
 280
 281     START_READ_HLL_INFO(interp, hll_info);
 282
 283     entry = VTABLE_get_pmc_keyed_str(interp, hll_info, hll_name);
 284
 285     if (!PMC_IS_NULL(entry)) {
 286         PMC * const entry_id = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_id);
 287         i = VTABLE_get_integer(interp, entry_id);
 288     }
 289
 290     END_READ_HLL_INFO(interp, hll_info);
 291
 292     return i;
 293 }
 294
 295 /*
 296
 297 =item C<STRING * Parrot_get_HLL_name(PARROT_INTERP, INTVAL id)>
 298
 299 Returns the STRING name of the HLL with the given C<id> number. If the id
 300 is out of range or does not exist, the NULL value is returned instead. Note
 301 that some HLLs are anonymous and so might also return NULL.
 302
 303 =cut
 304
 305 */
 306
 307 PARROT_EXPORT
 308 PARROT_WARN_UNUSED_RESULT
 309 PARROT_CAN_RETURN_NULL
 310 STRING *
 311 Parrot_get_HLL_name(PARROT_INTERP, INTVAL id)
 312 {
 313     ASSERT_ARGS(Parrot_get_HLL_name)
 314     PMC * const  hll_info  = interp->HLL_info;
 315     const INTVAL nelements = VTABLE_elements(interp, hll_info);
 316
 317     PMC         *entry, *name_pmc;
 318
 319     if (id < 0 || id >= nelements)
 320         return NULL;
 321
 322     START_READ_HLL_INFO(interp, hll_info);
 323
 324     entry    = VTABLE_get_pmc_keyed_int(interp, hll_info, id);
 325     name_pmc = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_name);
 326
 327     END_READ_HLL_INFO(interp, hll_info);
 328
 329     /* loadlib-created 'HLL's are nameless */
 330     if (PMC_IS_NULL(name_pmc))
 331         return NULL;
 332     else
 333         return VTABLE_get_string(interp, name_pmc);
 334 }
 335
 336 /*
 337
 338 =item C<void Parrot_register_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL
 339 core_type, INTVAL hll_type)>
 340
 341 Register a type mapping of C<< core_type => hll_type >> for the given HLL.
 342
 343 =cut
 344
 345 */
 346
 347 PARROT_EXPORT
 348 void
 349 Parrot_register_HLL_type(PARROT_INTERP, INTVAL hll_id,
 350         INTVAL core_type, INTVAL hll_type)
 351 {
 352     ASSERT_ARGS(Parrot_register_HLL_type)
 353     PMC  *entry, *type_hash;
 354     PMC  *hll_info = interp->HLL_info;
 355     const INTVAL n = VTABLE_elements(interp, hll_info);
 356
 357     if (hll_id >= n)
 358         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
 359             "no such HLL ID (%vd)", hll_id);
 360
 361     /* the type might already be registered in a non-conflicting way, in which
 362      * ca se we can avoid copying */
 363     if (PObj_is_PMC_shared_TEST(hll_info) && PMC_sync(hll_info)) {
 364         if (hll_type == Parrot_get_HLL_type(interp, hll_id, core_type))
 365             return;
 366     }
 367
 368     START_WRITE_HLL_INFO(interp, hll_info);
 369
 370     entry     = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id);
 371     PARROT_ASSERT(!PMC_IS_NULL(entry));
 372
 373     type_hash = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
 374     PARROT_ASSERT(!PMC_IS_NULL(type_hash));
 375
 376     VTABLE_set_integer_keyed_int(interp, type_hash, core_type, hll_type);
 377
 378     END_WRITE_HLL_INFO(interp, hll_info);
 379 }
 380
 381 /*
 382
 383 =item C<INTVAL Parrot_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL
 384 core_type)>
 385
 386 Get an equivalent HLL type number for the language C<hll_id>.  If the given HLL
 387 doesn't remap the given type, or if C<hll_id> is the special value
 388 C<PARROT_HLL_NONE>, returns C<core_type> unchanged.
 389
 390 =cut
 391
 392 */
 393
 394 PARROT_EXPORT
 395 INTVAL
 396 Parrot_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL core_type)
 397 {
 398     ASSERT_ARGS(Parrot_get_HLL_type)
 399     PMC    *entry, *type_hash, *hll_info;
 400     INTVAL  n, id;
 401
 402     if (hll_id == PARROT_HLL_NONE || hll_id == 0)
 403         return core_type;
 404
 405     if (hll_id < 0)
 406         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
 407             "no such HLL ID (%vd)", hll_id);
 408
 409     hll_info = interp->HLL_info;
 410     n        = VTABLE_elements(interp, hll_info);
 411
 412     if (hll_id >= n)
 413         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
 414             "no such HLL ID (%vd)", hll_id);
 415
 416     START_READ_HLL_INFO(interp, hll_info);
 417     entry     = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id);
 418     END_READ_HLL_INFO(interp, hll_info);
 419
 420     type_hash = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
 421
 422     if (PMC_IS_NULL(type_hash))
 423         return core_type;
 424
 425     id = VTABLE_get_integer_keyed_int(interp, type_hash, core_type);
 426
 427     return id ? id : core_type;
 428 }
 429
 430 /*
 431
 432 =item C<INTVAL Parrot_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type)>
 433
 434 Return an equivalent PMC type number according to the HLL settings in
 435 the current context.  If no type is registered, returns C<core_type>.
 436
 437 =cut
 438
 439 */
 440
 441 PARROT_EXPORT
 442 INTVAL
 443 Parrot_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type)
 444 {
 445     ASSERT_ARGS(Parrot_get_ctx_HLL_type)
 446     const INTVAL hll_id = Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp));
 447
 448     return Parrot_get_HLL_type(interp, hll_id, core_type);
 449 }
 450
 451 /*
 452
 453 =item C<PMC* Parrot_get_ctx_HLL_namespace(PARROT_INTERP)>
 454
 455 Return root namespace of the current HLL.
 456
 457 =cut
 458
 459 */
 460
 461 PARROT_EXPORT
 462 PARROT_WARN_UNUSED_RESULT
 463 PARROT_CAN_RETURN_NULL
 464 PMC*
 465 Parrot_get_ctx_HLL_namespace(PARROT_INTERP)
 466 {
 467     ASSERT_ARGS(Parrot_get_ctx_HLL_namespace)
 468     return Parrot_get_HLL_namespace(interp, Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp)));
 469 }
 470
 471 /*
 472
 473 =item C<PMC* Parrot_get_HLL_namespace(PARROT_INTERP, int hll_id)>
 474
 475 Return root namespace of the HLL with the ID of I<hll_id>.  If C<hll_id> is the
 476 special value C<PARROT_HLL_NONE>, return the global root namespace.
 477
 478 =cut
 479
 480 */
 481
 482 PARROT_EXPORT
 483 PARROT_WARN_UNUSED_RESULT
 484 PARROT_CAN_RETURN_NULL
 485 PMC*
 486 Parrot_get_HLL_namespace(PARROT_INTERP, int hll_id)
 487 {
 488     ASSERT_ARGS(Parrot_get_HLL_namespace)
 489     if (hll_id == PARROT_HLL_NONE)
 490         return interp->root_namespace;
 491
 492     return VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
 493 }
 494
 495 /*
 496
 497 =item C<void Parrot_regenerate_HLL_namespaces(PARROT_INTERP)>
 498
 499 Create all HLL namespaces that don't already exist. This is necessary when
 500 creating a new interpreter which shares an old interpreter's HLL_info.
 501
 502 =cut
 503
 504 */
 505
 506 PARROT_EXPORT
 507 void
 508 Parrot_regenerate_HLL_namespaces(PARROT_INTERP)
 509 {
 510     ASSERT_ARGS(Parrot_regenerate_HLL_namespaces)
 511     const INTVAL n = VTABLE_elements(interp, interp->HLL_info);
 512     INTVAL       hll_id;
 513
 514     /* start at one since the 'parrot' namespace should already have been
 515      * created */
 516
 517     for (hll_id = 1; hll_id < n; ++hll_id) {
 518         PMC *ns_hash =
 519             VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
 520
 521         if (PMC_IS_NULL(ns_hash) ||
 522                 ns_hash->vtable->base_type == enum_class_Undef)
 523         {
 524             STRING * hll_name = Parrot_get_HLL_name(interp, hll_id);
 525             if (!hll_name)
 526                 continue;
 527
 528             hll_name = Parrot_str_downcase(interp, hll_name);
 529
 530             /* XXX as in Parrot_register_HLL() this needs to be fixed to use
 531              * the correct type of namespace. It's relatively easy to do that
 532              * here because the typemap already exists, but it is not currently
 533              * done for consistency.
 534              */
 535             ns_hash = Parrot_make_namespace_keyed_str(interp,
 536                 interp->root_namespace, hll_name);
 537
 538             VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace,
 539                                      hll_id, ns_hash);
 540         }
 541     }
 542 }
 543
 544 /*
 545
 546 =back
 547
 548 =head1 AUTHOR
 549
 550 Leopold Toetsch
 551
 552 =cut
 553
 554
 555 */
 556
 557 /*
 558  * Local variables:
 559  *   c-file-style: "parrot"
 560  * End:
 561  * vim: expandtab shiftwidth=4:
 562  */