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_context.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 = constant_pmc_new(interp, enum_class_FixedPMCArray);
  92
  93     if (entry_name && !STRING_IS_EMPTY(entry_name)) {
  94         VTABLE_set_pmc_keyed_str(interp, hll_info, entry_name, entry);
  95     }
  96     else
  97         VTABLE_push_pmc(interp, hll_info, entry);
  98
  99     VTABLE_set_integer_native(interp, entry, e_HLL_MAX);
 100
 101     entry_id = constant_pmc_new(interp, enum_class_Integer);
 102     VTABLE_set_integer_native(interp, entry_id, id);
 103     VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_id, entry_id);
 104
 105     return entry;
 106 }
 107
 108
 109 /*
 110
 111 =item C<void Parrot_init_HLL(PARROT_INTERP)>
 112
 113 Initialises the HLL_info and HLL_namespace fields of the interpreter structure.
 114 Registers the default HLL namespace "parrot".
 115
 116 =cut
 117
 118 */
 119
 120 void
 121 Parrot_init_HLL(PARROT_INTERP)
 122 {
 123     ASSERT_ARGS(Parrot_init_HLL)
 124     interp->HLL_info      =
 125         pmc_new(interp, enum_class_OrderedHash);
 126     interp->HLL_namespace =
 127         constant_pmc_new(interp, enum_class_ResizablePMCArray);
 128
 129     Parrot_register_HLL(interp, CONST_STRING(interp, "parrot"));
 130 }
 131
 132 /*
 133
 134 =item C<INTVAL Parrot_register_HLL(PARROT_INTERP, STRING *hll_name)>
 135
 136 Register the HLL with the given STRING name C<hll_name> in the interpreter.
 137
 138 If the HLL has already been registered, the ID of the HLL is returned.
 139 Otherwise the HLL is registered, a corresponding HLL namespace is created,
 140 and the HLL ID is returned.
 141
 142 If there is an error, C<-1> is returned.
 143
 144 =cut
 145
 146 */
 147
 148 PARROT_EXPORT
 149 INTVAL
 150 Parrot_register_HLL(PARROT_INTERP, ARGIN(STRING *hll_name))
 151 {
 152     ASSERT_ARGS(Parrot_register_HLL)
 153     PMC   *entry, *name, *type_hash, *ns_hash, *hll_info;
 154     INTVAL idx;
 155
 156     /* TODO LOCK or disallow in threads */
 157
 158     idx = Parrot_get_HLL_id(interp, hll_name);
 159
 160     if (idx >= 0)
 161         return idx;
 162
 163     hll_info = interp->HLL_info;
 164
 165     START_WRITE_HLL_INFO(interp, hll_info);
 166
 167     idx      = VTABLE_elements(interp, hll_info);
 168     entry    = new_hll_entry(interp, hll_name);
 169
 170     /* register HLL name */
 171     name     = constant_pmc_new(interp, enum_class_String);
 172
 173     VTABLE_set_string_native(interp, name, hll_name);
 174     VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_name, name);
 175
 176     /* create HLL namespace using the *constant* name */
 177     hll_name = Parrot_str_downcase(interp, VTABLE_get_string(interp, name));
 178
 179     /* HLL type mappings aren't yet created, we can't create
 180      * a namespace in HLL's flavor yet - maybe promote the
 181      * ns_hash to another type, if mappings provide one
 182      * XXX - FIXME
 183      */
 184     ns_hash = Parrot_make_namespace_keyed_str(interp, interp->root_namespace,
 185                                               hll_name);
 186
 187     /* cache HLL's toplevel namespace */
 188     VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace, idx, ns_hash);
 189
 190     /* create HLL typemap hash */
 191     type_hash = constant_pmc_new(interp, enum_class_Hash);
 192     VTABLE_set_pointer(interp, type_hash, parrot_new_intval_hash(interp));
 193     VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_typemap, type_hash);
 194
 195     /* UNLOCK */
 196     END_WRITE_HLL_INFO(interp, hll_info);
 197
 198     return idx;
 199 }
 200
 201 /*
 202
 203 =item C<INTVAL Parrot_register_HLL_lib(PARROT_INTERP, STRING *hll_lib)>
 204
 205 Register an HLL library.
 206 Takes a pointer to a library name STRING to add. If the name has already
 207 been registered the list position of the library in the HLL Info list is
 208 returned. Otherwise, the library is added to the list and 0 is returned.
 209
 210 =cut
 211
 212 */
 213
 214 PARROT_EXPORT
 215 INTVAL
 216 Parrot_register_HLL_lib(PARROT_INTERP, ARGIN(STRING *hll_lib))
 217 {
 218     ASSERT_ARGS(Parrot_register_HLL_lib)
 219     PMC   *hll_info = interp->HLL_info;
 220     PMC   *entry, *name;
 221     INTVAL nelements, i;
 222
 223     START_WRITE_HLL_INFO(interp, hll_info);
 224
 225     nelements = VTABLE_elements(interp, hll_info);
 226
 227     for (i = 0; i < nelements; ++i) {
 228         PMC * const entry    = VTABLE_get_pmc_keyed_int(interp, hll_info, i);
 229         PMC * const lib_name = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_lib);
 230
 231         if (!PMC_IS_NULL(lib_name)) {
 232             const STRING * const name = VTABLE_get_string(interp, lib_name);
 233             if (Parrot_str_equal(interp, name, hll_lib))
 234                 break;
 235         }
 236     }
 237
 238     if (i < nelements)
 239         return i;
 240
 241     entry    = new_hll_entry(interp, NULL);
 242
 243     VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_name, PMCNULL);
 244
 245     /* register dynlib */
 246     name    = constant_pmc_new(interp, enum_class_String);
 247
 248     VTABLE_set_string_native(interp, name, hll_lib);
 249     VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_lib, name);
 250
 251     END_WRITE_HLL_INFO(interp, hll_info);
 252
 253     return 0;
 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 * const hll_info = interp->HLL_info;
 275     INTVAL      i;
 276
 277     START_READ_HLL_INFO(interp, hll_info);
 278
 279     if (!hll_name || !VTABLE_exists_keyed_str(interp, hll_info, hll_name))
 280         i = -1;
 281     else {
 282         PMC * const entry    = VTABLE_get_pmc_keyed_str(interp, hll_info, hll_name);
 283         PMC * const entry_id = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_id);
 284         i = VTABLE_get_integer(interp, entry_id);
 285     }
 286
 287     END_READ_HLL_INFO(interp, hll_info);
 288
 289     return i;
 290 }
 291
 292 /*
 293
 294 =item C<STRING * Parrot_get_HLL_name(PARROT_INTERP, INTVAL id)>
 295
 296 Returns the STRING name of the HLL with the given C<id> number. If the id
 297 is out of range or does not exist, the NULL value is returned instead. Note
 298 that some HLLs are anonymous and so might also return NULL.
 299
 300 =cut
 301
 302 */
 303
 304 PARROT_EXPORT
 305 PARROT_WARN_UNUSED_RESULT
 306 PARROT_CAN_RETURN_NULL
 307 STRING *
 308 Parrot_get_HLL_name(PARROT_INTERP, INTVAL id)
 309 {
 310     ASSERT_ARGS(Parrot_get_HLL_name)
 311     PMC * const  hll_info  = interp->HLL_info;
 312     const INTVAL nelements = VTABLE_elements(interp, hll_info);
 313
 314     PMC         *entry, *name_pmc;
 315
 316     if (id < 0 || id >= nelements)
 317         return NULL;
 318
 319     START_READ_HLL_INFO(interp, hll_info);
 320
 321     entry    = VTABLE_get_pmc_keyed_int(interp, hll_info, id);
 322     name_pmc = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_name);
 323
 324     END_READ_HLL_INFO(interp, hll_info);
 325
 326     /* loadlib-created 'HLL's are nameless */
 327     if (PMC_IS_NULL(name_pmc))
 328         return NULL;
 329     else
 330         return VTABLE_get_string(interp, name_pmc);
 331 }
 332
 333 /*
 334
 335 =item C<void Parrot_register_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL
 336 core_type, INTVAL hll_type)>
 337
 338 Register a type mapping of C<< core_type => hll_type >> for the given HLL.
 339
 340 =cut
 341
 342 */
 343
 344 PARROT_EXPORT
 345 void
 346 Parrot_register_HLL_type(PARROT_INTERP, INTVAL hll_id,
 347         INTVAL core_type, INTVAL hll_type)
 348 {
 349     ASSERT_ARGS(Parrot_register_HLL_type)
 350     PMC  *entry, *type_hash;
 351     PMC  *hll_info = interp->HLL_info;
 352     const INTVAL n = VTABLE_elements(interp, hll_info);
 353
 354     if (hll_id >= n)
 355         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
 356             "no such HLL ID (%vd)", hll_id);
 357
 358     /* the type might already be registered in a non-conflicting way, in which
 359      * ca se we can avoid copying */
 360     if (PObj_is_PMC_shared_TEST(hll_info) && PMC_sync(hll_info)) {
 361         if (hll_type == Parrot_get_HLL_type(interp, hll_id, core_type))
 362             return;
 363     }
 364
 365     START_WRITE_HLL_INFO(interp, hll_info);
 366
 367     entry     = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id);
 368     PARROT_ASSERT(!PMC_IS_NULL(entry));
 369
 370     type_hash = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
 371     PARROT_ASSERT(!PMC_IS_NULL(type_hash));
 372
 373     VTABLE_set_integer_keyed_int(interp, type_hash, core_type, hll_type);
 374
 375     END_WRITE_HLL_INFO(interp, hll_info);
 376 }
 377
 378 /*
 379
 380 =item C<INTVAL Parrot_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL
 381 core_type)>
 382
 383 Get an equivalent HLL type number for the language C<hll_id>.  If the given HLL
 384 doesn't remap the given type, or if C<hll_id> is the special value
 385 C<PARROT_HLL_NONE>, returns C<core_type> unchanged.
 386
 387 =cut
 388
 389 */
 390
 391 PARROT_EXPORT
 392 INTVAL
 393 Parrot_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL core_type)
 394 {
 395     ASSERT_ARGS(Parrot_get_HLL_type)
 396     PMC    *entry, *type_hash, *hll_info;
 397     INTVAL  n, id;
 398
 399     if (hll_id == PARROT_HLL_NONE || hll_id == 0)
 400         return core_type;
 401
 402     if (hll_id < 0)
 403         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
 404             "no such HLL ID (%vd)", hll_id);
 405
 406     hll_info = interp->HLL_info;
 407     n        = VTABLE_elements(interp, hll_info);
 408
 409     if (hll_id >= n)
 410         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
 411             "no such HLL ID (%vd)", hll_id);
 412
 413     START_READ_HLL_INFO(interp, hll_info);
 414     entry     = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id);
 415     END_READ_HLL_INFO(interp, hll_info);
 416
 417     type_hash = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
 418
 419     if (PMC_IS_NULL(type_hash))
 420         return core_type;
 421
 422     id = VTABLE_get_integer_keyed_int(interp, type_hash, core_type);
 423
 424     return id ? id : core_type;
 425 }
 426
 427 /*
 428
 429 =item C<INTVAL Parrot_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type)>
 430
 431 Return an equivalent PMC type number according to the HLL settings in
 432 the current context.  If no type is registered, returns C<core_type>.
 433
 434 =cut
 435
 436 */
 437
 438 PARROT_EXPORT
 439 INTVAL
 440 Parrot_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type)
 441 {
 442     ASSERT_ARGS(Parrot_get_ctx_HLL_type)
 443     const INTVAL hll_id = Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp));
 444
 445     return Parrot_get_HLL_type(interp, hll_id, core_type);
 446 }
 447
 448 /*
 449
 450 =item C<PMC* Parrot_get_ctx_HLL_namespace(PARROT_INTERP)>
 451
 452 Return root namespace of the current HLL.
 453
 454 =cut
 455
 456 */
 457
 458 PARROT_EXPORT
 459 PARROT_WARN_UNUSED_RESULT
 460 PARROT_CAN_RETURN_NULL
 461 PMC*
 462 Parrot_get_ctx_HLL_namespace(PARROT_INTERP)
 463 {
 464     ASSERT_ARGS(Parrot_get_ctx_HLL_namespace)
 465     return Parrot_get_HLL_namespace(interp, Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp)));
 466 }
 467
 468 /*
 469
 470 =item C<PMC* Parrot_get_HLL_namespace(PARROT_INTERP, int hll_id)>
 471
 472 Return root namespace of the HLL with the ID of I<hll_id>.  If C<hll_id> is the
 473 special value C<PARROT_HLL_NONE>, return the global root namespace.
 474
 475 =cut
 476
 477 */
 478
 479 PARROT_EXPORT
 480 PARROT_WARN_UNUSED_RESULT
 481 PARROT_CAN_RETURN_NULL
 482 PMC*
 483 Parrot_get_HLL_namespace(PARROT_INTERP, int hll_id)
 484 {
 485     ASSERT_ARGS(Parrot_get_HLL_namespace)
 486     if (hll_id == PARROT_HLL_NONE)
 487         return interp->root_namespace;
 488
 489     return VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
 490 }
 491
 492 /*
 493
 494 =item C<void Parrot_regenerate_HLL_namespaces(PARROT_INTERP)>
 495
 496 Create all HLL namespaces that don't already exist. This is necessary when
 497 creating a new interpreter which shares an old interpreter's HLL_info.
 498
 499 =cut
 500
 501 */
 502
 503 PARROT_EXPORT
 504 void
 505 Parrot_regenerate_HLL_namespaces(PARROT_INTERP)
 506 {
 507     ASSERT_ARGS(Parrot_regenerate_HLL_namespaces)
 508     const INTVAL n = VTABLE_elements(interp, interp->HLL_info);
 509     INTVAL       hll_id;
 510
 511     /* start at one since the 'parrot' namespace should already have been
 512      * created */
 513
 514     for (hll_id = 1; hll_id < n; ++hll_id) {
 515         PMC *ns_hash =
 516             VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
 517
 518         if (PMC_IS_NULL(ns_hash) ||
 519                 ns_hash->vtable->base_type == enum_class_Undef)
 520         {
 521             STRING * const hll_name = Parrot_get_HLL_name(interp, hll_id);
 522             if (!hll_name)
 523                 continue;
 524
 525             Parrot_str_downcase_inplace(interp, hll_name);
 526
 527             /* XXX as in Parrot_register_HLL() this needs to be fixed to use
 528              * the correct type of namespace. It's relatively easy to do that
 529              * here because the typemap already exists, but it is not currently
 530              * done for consistency.
 531              */
 532             ns_hash = Parrot_make_namespace_keyed_str(interp,
 533                 interp->root_namespace, hll_name);
 534
 535             VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace,
 536                                      hll_id, ns_hash);
 537         }
 538     }
 539 }
 540
 541 /*
 542
 543 =back
 544
 545 =head1 AUTHOR
 546
 547 Leopold Toetsch
 548
 549 =cut
 550
 551
 552 */
 553
 554 /*
 555  * Local variables:
 556  *   c-file-style: "parrot"
 557  * End:
 558  * vim: expandtab shiftwidth=4:
 559  */