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     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
 368     if (hll_id == PARROT_HLL_NONE || hll_id == 0)
 369         return core_type;
 370
 371     if (hll_id < 0)
 372         Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_GLOBAL_NOT_FOUND,
 373             "no such HLL ID (%vd)", hll_id);
 374     else {
 375         PMC * const hll_info = interp->HLL_info;
 376         INTVAL  id;
 377         PMC    *entry, *type_hash;
 378
 379         START_READ_HLL_INFO(interp, hll_info);
 380         entry     = VTABLE_get_pmc_keyed_int(interp, hll_info, hll_id);
 381         END_READ_HLL_INFO(interp, hll_info);
 382
 383         if (PMC_IS_NULL(entry))
 384             Parrot_ex_throw_from_c_args(interp, NULL,
 385                 EXCEPTION_GLOBAL_NOT_FOUND, "no such HLL ID (%vd)", hll_id);
 386
 387         type_hash = VTABLE_get_pmc_keyed_int(interp, entry, e_HLL_typemap);
 388
 389         if (PMC_IS_NULL(type_hash))
 390             return core_type;
 391
 392         id = VTABLE_get_integer_keyed_int(interp, type_hash, core_type);
 393
 394         return id ? id : core_type;
 395     }
 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     if (!hll_id || hll_id == PARROT_HLL_NONE)
 416         return core_type;
 417
 418     return Parrot_get_HLL_type(interp, hll_id, core_type);
 419 }
 420
 421 /*
 422
 423 =item C<PMC* Parrot_get_ctx_HLL_namespace(PARROT_INTERP)>
 424
 425 Return root namespace of the current HLL.
 426
 427 =cut
 428
 429 */
 430
 431 PARROT_EXPORT
 432 PARROT_WARN_UNUSED_RESULT
 433 PARROT_CAN_RETURN_NULL
 434 PMC*
 435 Parrot_get_ctx_HLL_namespace(PARROT_INTERP)
 436 {
 437     ASSERT_ARGS(Parrot_get_ctx_HLL_namespace)
 438     return Parrot_get_HLL_namespace(interp, Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp)));
 439 }
 440
 441 /*
 442
 443 =item C<PMC* Parrot_get_HLL_namespace(PARROT_INTERP, int hll_id)>
 444
 445 Return root namespace of the HLL with the ID of I<hll_id>.  If C<hll_id> is the
 446 special value C<PARROT_HLL_NONE>, return the global root namespace.
 447
 448 =cut
 449
 450 */
 451
 452 PARROT_EXPORT
 453 PARROT_WARN_UNUSED_RESULT
 454 PARROT_CAN_RETURN_NULL
 455 PMC*
 456 Parrot_get_HLL_namespace(PARROT_INTERP, int hll_id)
 457 {
 458     ASSERT_ARGS(Parrot_get_HLL_namespace)
 459     if (hll_id == PARROT_HLL_NONE)
 460         return interp->root_namespace;
 461
 462     return VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
 463 }
 464
 465 /*
 466
 467 =item C<void Parrot_regenerate_HLL_namespaces(PARROT_INTERP)>
 468
 469 Create all HLL namespaces that don't already exist. This is necessary when
 470 creating a new interpreter which shares an old interpreter's HLL_info.
 471
 472 =cut
 473
 474 */
 475
 476 PARROT_EXPORT
 477 void
 478 Parrot_regenerate_HLL_namespaces(PARROT_INTERP)
 479 {
 480     ASSERT_ARGS(Parrot_regenerate_HLL_namespaces)
 481     const INTVAL n = VTABLE_elements(interp, interp->HLL_info);
 482     INTVAL       hll_id;
 483
 484     /* start at one since the 'parrot' namespace should already have been
 485      * created */
 486
 487     for (hll_id = 1; hll_id < n; ++hll_id) {
 488         PMC *ns_hash =
 489             VTABLE_get_pmc_keyed_int(interp, interp->HLL_namespace, hll_id);
 490
 491         if (PMC_IS_NULL(ns_hash) ||
 492                 ns_hash->vtable->base_type == enum_class_Undef)
 493         {
 494             STRING * hll_name = Parrot_get_HLL_name(interp, hll_id);
 495             if (!hll_name)
 496                 continue;
 497
 498             hll_name = Parrot_str_downcase(interp, hll_name);
 499
 500             /* XXX as in Parrot_register_HLL() this needs to be fixed to use
 501              * the correct type of namespace. It's relatively easy to do that
 502              * here because the typemap already exists, but it is not currently
 503              * done for consistency.
 504              */
 505             ns_hash = Parrot_ns_make_namespace_keyed_str(interp,
 506                 interp->root_namespace, hll_name);
 507
 508             VTABLE_set_pmc_keyed_int(interp, interp->HLL_namespace,
 509                                      hll_id, ns_hash);
 510         }
 511     }
 512 }
 513
 514 /*
 515
 516 =back
 517
 518 =head1 AUTHOR
 519
 520 Leopold Toetsch
 521
 522 =cut
 523
 524
 525 */
 526
 527 /*
 528  * Local variables:
 529  *   c-file-style: "parrot"
 530  * End:
 531  * vim: expandtab shiftwidth=4:
 532  */