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_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     PMC  *entry, *type_hash;
 333     PMC  *hll_info = interp->HLL_info;
 334     const INTVAL n = VTABLE_elements(interp, hll_info);
 335
 336     if (hll_id >= n)
 337         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
 338             "no such HLL ID (%vd)", hll_id);
 339
 340     entry     = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id);
 341     PARROT_ASSERT(!PMC_IS_NULL(entry));
 342
 343     type_hash = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
 344     PARROT_ASSERT(!PMC_IS_NULL(type_hash));
 345
 346     VTABLE_set_integer_keyed_int(interp, type_hash, core_type, hll_type);
 347 }
 348
 349 /*
 350
 351 =item C<INTVAL Parrot_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL
 352 core_type)>
 353
 354 Get an equivalent HLL type number for the language C<hll_id>.  If the given HLL
 355 doesn't remap the given type, or if C<hll_id> is the special value
 356 C<PARROT_HLL_NONE>, returns C<core_type> unchanged.
 357
 358 =cut
 359
 360 */
 361
 362 PARROT_EXPORT
 363 INTVAL
 364 Parrot_get_HLL_type(PARROT_INTERP, INTVAL hll_id, INTVAL core_type)
 365 {
 366     ASSERT_ARGS(Parrot_get_HLL_type)
 367     PMC    *entry, *type_hash, *hll_info;
 368     INTVAL  n, id;
 369
 370     if (hll_id == PARROT_HLL_NONE || hll_id == 0)
 371         return core_type;
 372
 373     if (hll_id < 0)
 374         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
 375             "no such HLL ID (%vd)", hll_id);
 376
 377     hll_info = interp->HLL_info;
 378     n        = VTABLE_elements(interp, hll_info);
 379
 380     if (hll_id >= n)
 381         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
 382             "no such HLL ID (%vd)", hll_id);
 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     type_hash = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
 389
 390     if (PMC_IS_NULL(type_hash))
 391         return core_type;
 392
 393     id = VTABLE_get_integer_keyed_int(interp, type_hash, core_type);
 394
 395     return id ? id : core_type;
 396 }
 397
 398 /*
 399
 400 =item C<INTVAL Parrot_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type)>
 401
 402 Return an equivalent PMC type number according to the HLL settings in
 403 the current context.  If no type is registered, returns C<core_type>.
 404
 405 =cut
 406
 407 */
 408
 409 PARROT_EXPORT
 410 INTVAL
 411 Parrot_get_ctx_HLL_type(PARROT_INTERP, INTVAL core_type)
 412 {
 413     ASSERT_ARGS(Parrot_get_ctx_HLL_type)
 414     const INTVAL hll_id = Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp));
 415
 416     return Parrot_get_HLL_type(interp, hll_id, core_type);
 417 }
 418
 419 /*
 420
 421 =item C<PMC* Parrot_get_ctx_HLL_namespace(PARROT_INTERP)>
 422
 423 Return root namespace of the current HLL.
 424
 425 =cut
 426
 427 */
 428
 429 PARROT_EXPORT
 430 PARROT_WARN_UNUSED_RESULT
 431 PARROT_CAN_RETURN_NULL
 432 PMC*
 433 Parrot_get_ctx_HLL_namespace(PARROT_INTERP)
 434 {
 435     ASSERT_ARGS(Parrot_get_ctx_HLL_namespace)
 436     return Parrot_get_HLL_namespace(interp, Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp)));
 437 }
 438
 439 /*
 440
 441 =item C<PMC* Parrot_get_HLL_namespace(PARROT_INTERP, int hll_id)>
 442
 443 Return root namespace of the HLL with the ID of I<hll_id>.  If C<hll_id> is the
 444 special value C<PARROT_HLL_NONE>, return the global root namespace.
 445
 446 =cut
 447
 448 */
 449
 450 PARROT_EXPORT
 451 PARROT_WARN_UNUSED_RESULT
 452 PARROT_CAN_RETURN_NULL
 453 PMC*
 454 Parrot_get_HLL_namespace(PARROT_INTERP, int hll_id)
 455 {
 456     ASSERT_ARGS(Parrot_get_HLL_namespace)
 457     if (hll_id == PARROT_HLL_NONE)
 458         return interp->root_namespace;
 459
 460     return VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
 461 }
 462
 463 /*
 464
 465 =item C<void Parrot_regenerate_HLL_namespaces(PARROT_INTERP)>
 466
 467 Create all HLL namespaces that don't already exist. This is necessary when
 468 creating a new interpreter which shares an old interpreter's HLL_info.
 469
 470 =cut
 471
 472 */
 473
 474 PARROT_EXPORT
 475 void
 476 Parrot_regenerate_HLL_namespaces(PARROT_INTERP)
 477 {
 478     ASSERT_ARGS(Parrot_regenerate_HLL_namespaces)
 479     const INTVAL n = VTABLE_elements(interp, interp->HLL_info);
 480     INTVAL       hll_id;
 481
 482     /* start at one since the 'parrot' namespace should already have been
 483      * created */
 484
 485     for (hll_id = 1; hll_id < n; ++hll_id) {
 486         PMC *ns_hash =
 487             VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
 488
 489         if (PMC_IS_NULL(ns_hash) ||
 490                 ns_hash->vtable->base_type == enum_class_Undef)
 491         {
 492             STRING * hll_name = Parrot_get_HLL_name(interp, hll_id);
 493             if (!hll_name)
 494                 continue;
 495
 496             hll_name = Parrot_str_downcase(interp, hll_name);
 497
 498             /* XXX as in Parrot_register_HLL() this needs to be fixed to use
 499              * the correct type of namespace. It's relatively easy to do that
 500              * here because the typemap already exists, but it is not currently
 501              * done for consistency.
 502              */
 503             ns_hash = Parrot_make_namespace_keyed_str(interp,
 504                 interp->root_namespace, hll_name);
 505
 506             VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace,
 507                                      hll_id, ns_hash);
 508         }
 509     }
 510 }
 511
 512 /*
 513
 514 =back
 515
 516 =head1 AUTHOR
 517
 518 Leopold Toetsch
 519
 520 =cut
 521
 522
 523 */
 524
 525 /*
 526  * Local variables:
 527  *   c-file-style: "parrot"
 528  * End:
 529  * vim: expandtab shiftwidth=4:
 530  */