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