src/interp/inter_misc.c

   1 /*
   2 Copyright (C) 2001-2009, Parrot Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/interp/inter_misc.c - Parrot Interpreter miscellaneous functions
   8
   9 =head1 DESCRIPTION
  10
  11 NCI function setup, compiler registration, C<interpinfo>, and C<sysinfo> opcodes.
  12
  13 =head2 Functions
  14
  15 =over 4
  16
  17 =cut
  18
  19 */
  20
  21
  22 #include "parrot/parrot.h"
  23 #include "inter_misc.str"
  24 #include "../compilers/imcc/imc.h"
  25 #include "parrot/runcore_api.h"
  26 #include "pmc/pmc_context.h"
  27
  28 #include "parrot/has_header.h"
  29
  30 #ifdef PARROT_HAS_HEADER_SYSUTSNAME
  31 #  include <sys/utsname.h>
  32 #endif
  33
  34 /* HEADERIZER HFILE: include/parrot/interpreter.h */
  35
  36 /*
  37
  38 =item C<void register_nci_method(PARROT_INTERP, const int type, void *func,
  39 const char *name, const char *proto)>
  40
  41 Create an entry in the C<nci_method_table> for the given NCI method of PMC
  42 class C<type>.
  43
  44 =cut
  45
  46 */
  47
  48 PARROT_EXPORT
  49 void
  50 register_nci_method(PARROT_INTERP, const int type, ARGIN(void *func),
  51                     ARGIN(const char *name), ARGIN(const char *proto))
  52 {
  53     ASSERT_ARGS(register_nci_method)
  54     PMC    * const method      = pmc_new(interp, enum_class_NCI);
  55     STRING * const method_name = string_make(interp, name, strlen(name),
  56         NULL, PObj_constant_FLAG|PObj_external_FLAG);
  57
  58     /* create call func */
  59     VTABLE_set_pointer_keyed_str(interp, method,
  60             string_make(interp, proto, strlen(proto), NULL,
  61                 PObj_constant_FLAG|PObj_external_FLAG),
  62             func);
  63
  64     /* insert it into namespace */
  65     VTABLE_set_pmc_keyed_str(interp, interp->vtables[type]->_namespace,
  66             method_name, method);
  67 }
  68
  69 /*
  70
  71 =item C<void register_raw_nci_method_in_ns(PARROT_INTERP, const int type, void
  72 *func, STRING *name)>
  73
  74 Create an entry in the C<nci_method_table> for the given raw NCI method
  75 of PMC class C<type>.
  76
  77 =cut
  78
  79 */
  80
  81 PARROT_EXPORT
  82 void
  83 register_raw_nci_method_in_ns(PARROT_INTERP, const int type, ARGIN(void *func),
  84         ARGIN(STRING *name))
  85 {
  86     ASSERT_ARGS(register_raw_nci_method_in_ns)
  87     PMC    * const method      = pmc_new(interp, enum_class_NCI);
  88
  89     /* setup call func */
  90     VTABLE_set_pointer(interp, method, func);
  91
  92     /* insert it into namespace */
  93     VTABLE_set_pmc_keyed_str(interp, interp->vtables[type]->_namespace,
  94             name, method);
  95 }
  96
  97 /*
  98
  99 =item C<void Parrot_mark_method_writes(PARROT_INTERP, int type, const char
 100 *name)>
 101
 102 Mark the method C<name> on PMC type C<type> as one that modifies the PMC.
 103
 104 =cut
 105
 106 */
 107
 108 PARROT_EXPORT
 109 void
 110 Parrot_mark_method_writes(PARROT_INTERP, int type, ARGIN(const char *name))
 111 {
 112     ASSERT_ARGS(Parrot_mark_method_writes)
 113     STRING *const str_name = Parrot_str_new_constant(interp, name);
 114     PMC    *const pmc_true = pmc_new(interp, enum_class_Integer);
 115     PMC    *const method   = VTABLE_get_pmc_keyed_str(
 116         interp, interp->vtables[type]->_namespace, str_name);
 117     VTABLE_set_integer_native(interp, pmc_true, 1);
 118     VTABLE_setprop(interp, method, CONST_STRING(interp, "write"), pmc_true);
 119 }
 120
 121 /*
 122
 123 =item C<void Parrot_compreg(PARROT_INTERP, STRING *type, Parrot_compiler_func_t
 124 func)>
 125
 126 Register a parser/compiler function.
 127
 128 =cut
 129
 130 */
 131
 132 PARROT_EXPORT
 133 void
 134 Parrot_compreg(PARROT_INTERP, ARGIN(STRING *type),
 135                     NOTNULL(Parrot_compiler_func_t func))
 136 {
 137     ASSERT_ARGS(Parrot_compreg)
 138     PMC* const iglobals = interp->iglobals;
 139     PMC        *nci     = pmc_new(interp, enum_class_NCI);
 140     STRING     *sc      = CONST_STRING(interp, "PJt");
 141     PMC        *hash    = VTABLE_get_pmc_keyed_int(interp, interp->iglobals,
 142                               IGLOBALS_COMPREG_HASH);
 143
 144     if (!hash) {
 145         hash = pmc_new_noinit(interp, enum_class_Hash);
 146         VTABLE_init(interp, hash);
 147         VTABLE_set_pmc_keyed_int(interp, iglobals,
 148                 (INTVAL)IGLOBALS_COMPREG_HASH, hash);
 149     }
 150
 151     VTABLE_set_pmc_keyed_str(interp, hash, type, nci);
 152
 153     /* build native call interface for the C sub in "func" */
 154     VTABLE_set_pointer_keyed_str(interp, nci, sc, (void *)func);
 155 }
 156
 157 /*
 158
 159 =item C<void * Parrot_compile_file(PARROT_INTERP, const char *fullname, STRING
 160 **error)>
 161
 162 Compile code file.
 163
 164 =cut
 165
 166 */
 167
 168 PARROT_EXPORT
 169 PARROT_CANNOT_RETURN_NULL
 170 void *
 171 Parrot_compile_file(PARROT_INTERP, ARGIN(const char *fullname), ARGOUT(STRING **error))
 172 {
 173     ASSERT_ARGS(Parrot_compile_file)
 174     return IMCC_compile_file_s(interp, fullname, error);
 175 }
 176
 177 /*
 178
 179 =item C<INTVAL interpinfo(PARROT_INTERP, INTVAL what)>
 180
 181 C<what> specifies the type of information you want about the interpreter.
 182
 183 =cut
 184
 185 */
 186
 187 PARROT_EXPORT
 188 PARROT_WARN_UNUSED_RESULT
 189 INTVAL
 190 interpinfo(PARROT_INTERP, INTVAL what)
 191 {
 192     ASSERT_ARGS(interpinfo)
 193     INTVAL ret;
 194
 195     switch (what) {
 196         case TOTAL_MEM_ALLOC:
 197             ret = Parrot_gc_total_memory_allocated(interp);
 198             break;
 199         case GC_MARK_RUNS:
 200             ret = Parrot_gc_count_mark_runs(interp);
 201             break;
 202         case GC_LAZY_MARK_RUNS:
 203             ret = Parrot_gc_count_lazy_mark_runs(interp);
 204             break;
 205         case GC_COLLECT_RUNS:
 206             ret = Parrot_gc_count_collect_runs(interp);
 207             break;
 208         case ACTIVE_PMCS:
 209             ret = Parrot_gc_active_pmcs(interp);
 210             break;
 211         case ACTIVE_BUFFERS:
 212             ret = Parrot_gc_active_sized_buffers(interp);
 213             break;
 214         case TOTAL_PMCS:
 215             ret = Parrot_gc_total_pmcs(interp);
 216             break;
 217         case TOTAL_BUFFERS:
 218             ret = Parrot_gc_total_sized_buffers(interp);
 219             break;
 220         case HEADER_ALLOCS_SINCE_COLLECT:
 221             ret = Parrot_gc_headers_alloc_since_last_collect(interp);
 222             break;
 223         case MEM_ALLOCS_SINCE_COLLECT:
 224             ret = Parrot_gc_mem_alloc_since_last_collect(interp);
 225             break;
 226         case TOTAL_COPIED:
 227             ret = Parrot_gc_total_copied(interp);
 228             break;
 229         case IMPATIENT_PMCS:
 230             ret = Parrot_gc_impatient_pmcs(interp);
 231             break;
 232         case CURRENT_RUNCORE:
 233         {
 234             STRING *name = interp->run_core->name;
 235
 236             if (Parrot_str_equal(interp, name, CONST_STRING(interp, "slow")))
 237                 return PARROT_SLOW_CORE;
 238             else if (Parrot_str_equal(interp, name, CONST_STRING(interp, "fast")))
 239                 return PARROT_FAST_CORE;
 240             else if (Parrot_str_equal(interp, name, CONST_STRING(interp, "switch")))
 241                 return PARROT_SWITCH_CORE;
 242             else if (Parrot_str_equal(interp, name, CONST_STRING(interp, "cgp")))
 243                 return PARROT_CGP_CORE;
 244             else if (Parrot_str_equal(interp, name, CONST_STRING(interp, "cgoto")))
 245                 return PARROT_CGOTO_CORE;
 246             else if (Parrot_str_equal(interp, name, CONST_STRING(interp, "exec")))
 247                 return PARROT_EXEC_CORE;
 248             else if (Parrot_str_equal(interp, name, CONST_STRING(interp, "gc_debug")))
 249                 return PARROT_GC_DEBUG_CORE;
 250             else if (Parrot_str_equal(interp, name, CONST_STRING(interp, "debugger")))
 251                 return PARROT_DEBUGGER_CORE;
 252             else if (Parrot_str_equal(interp, name, CONST_STRING(interp, "profiling")))
 253                 return PARROT_PROFILING_CORE;
 254         }
 255         default:        /* or a warning only? */
 256             ret = -1;
 257             Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED,
 258                 "illegal argument in interpinfo");
 259     }
 260     return ret;
 261 }
 262
 263 /*
 264
 265 =item C<PMC* interpinfo_p(PARROT_INTERP, INTVAL what)>
 266
 267 C<what> specifies the type of information you want about the
 268 interpreter.
 269
 270 =cut
 271
 272 */
 273
 274 PARROT_EXPORT
 275 PARROT_WARN_UNUSED_RESULT
 276 PARROT_CAN_RETURN_NULL
 277 PMC*
 278 interpinfo_p(PARROT_INTERP, INTVAL what)
 279 {
 280     ASSERT_ARGS(interpinfo_p)
 281     switch (what) {
 282         case CURRENT_SUB:
 283             return Parrot_pcc_get_sub(interp, CURRENT_CONTEXT(interp));
 284         case CURRENT_CONT:
 285             {
 286             PMC * const cont = Parrot_pcc_get_continuation(interp, CURRENT_CONTEXT(interp));
 287             if (!PMC_IS_NULL(cont) && cont->vtable->base_type ==
 288                     enum_class_RetContinuation)
 289                 return VTABLE_clone(interp, cont);
 290             return cont;
 291             }
 292         case CURRENT_OBJECT:
 293             return Parrot_pcc_get_object(interp, CURRENT_CONTEXT(interp));
 294         case CURRENT_LEXPAD:
 295             return Parrot_pcc_get_lex_pad(interp, CURRENT_CONTEXT(interp));
 296         default:        /* or a warning only? */
 297             Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED,
 298                 "illegal argument in interpinfo");
 299     }
 300 }
 301
 302 /*
 303
 304 =item C<STRING* interpinfo_s(PARROT_INTERP, INTVAL what)>
 305
 306 Takes an interpreter name and an information type as arguments.
 307 Returns corresponding information strings about the interpreter:
 308 the full pathname, executable name, or the file stem,
 309 (or throws an error exception, if the type is not recognised).
 310 Valid types are EXECUTABLE_FULLNAME, EXECUTABLE_BASENAME,
 311 and RUNTIME_PREFIX.
 312
 313 =cut
 314
 315 */
 316
 317 PARROT_EXPORT
 318 PARROT_WARN_UNUSED_RESULT
 319 PARROT_CANNOT_RETURN_NULL
 320 STRING*
 321 interpinfo_s(PARROT_INTERP, INTVAL what)
 322 {
 323     ASSERT_ARGS(interpinfo_s)
 324     switch (what) {
 325         case EXECUTABLE_FULLNAME:
 326         {
 327             PMC *exe_name = VTABLE_get_pmc_keyed_int(interp, interp->iglobals,
 328                     IGLOBALS_EXECUTABLE);
 329             if (PMC_IS_NULL(exe_name))
 330                 return string_from_literal(interp, "");
 331             return VTABLE_get_string(interp, exe_name);
 332         }
 333         case EXECUTABLE_BASENAME:
 334         {
 335             STRING *basename;
 336             PMC    *exe_name = VTABLE_get_pmc_keyed_int(interp,
 337                                 interp->iglobals, IGLOBALS_EXECUTABLE);
 338
 339             if (PMC_IS_NULL(exe_name))
 340                 return string_from_literal(interp, "");
 341
 342             else {
 343                 /* Need to strip back to what follows the final / or \. */
 344                 STRING *fullname   = VTABLE_get_string(interp, exe_name);
 345                 char   *fullname_c = Parrot_str_to_cstring(interp, fullname);
 346                 int     pos        = strlen(fullname_c) - 1;
 347
 348                 while (pos              >  0
 349                 &&     fullname_c[pos] != '/'
 350                 &&     fullname_c[pos] != '\\')
 351                     pos--;
 352
 353                 if (pos > 0)
 354                     pos++;
 355
 356                 basename = Parrot_str_new(interp, fullname_c + pos, 0);
 357                 mem_sys_free(fullname_c);
 358
 359                 return basename;
 360             }
 361         }
 362         case RUNTIME_PREFIX:
 363             return Parrot_get_runtime_path(interp);
 364         default:
 365             Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_UNIMPLEMENTED,
 366                 "illegal argument in interpinfo");
 367     }
 368 }
 369
 370 /*
 371
 372 =item C<INTVAL sysinfo_i(PARROT_INTERP, INTVAL info_wanted)>
 373
 374 Returns the system info.
 375
 376 C<info_wanted> is one of:
 377
 378     PARROT_INTSIZE
 379     PARROT_FLOATSIZE
 380     PARROT_POINTERSIZE
 381     PARROT_INTMAX
 382     PARROT_INTMIN
 383
 384 In unknown info is requested then -1 is returned.
 385
 386 =cut
 387
 388 */
 389
 390 PARROT_WARN_UNUSED_RESULT
 391 INTVAL
 392 sysinfo_i(SHIM_INTERP, INTVAL info_wanted)
 393 {
 394     ASSERT_ARGS(sysinfo_i)
 395     switch (info_wanted) {
 396         case PARROT_INTSIZE:
 397             return sizeof (INTVAL);
 398         case PARROT_FLOATSIZE:
 399             return sizeof (FLOATVAL);
 400         case PARROT_POINTERSIZE:
 401             return sizeof (void *);
 402         case PARROT_INTMIN:
 403             return PARROT_INTVAL_MIN;
 404         case PARROT_INTMAX:
 405             return PARROT_INTVAL_MAX;
 406         default:
 407             return -1;
 408     }
 409 }
 410
 411 /*
 412
 413 =item C<STRING * sysinfo_s(PARROT_INTERP, INTVAL info_wanted)>
 414
 415 Returns the system info string.
 416
 417 C<info_wanted> is one of:
 418
 419     PARROT_OS
 420     PARROT_OS_VERSION
 421     PARROT_OS_VERSION_NUMBER
 422     CPU_ARCH
 423     CPU_TYPE
 424
 425 If unknown info is requested then an empty string is returned.
 426
 427 =cut
 428
 429 */
 430
 431 PARROT_CANNOT_RETURN_NULL
 432 PARROT_WARN_UNUSED_RESULT
 433 STRING *
 434 sysinfo_s(PARROT_INTERP, INTVAL info_wanted)
 435 {
 436     ASSERT_ARGS(sysinfo_s)
 437     switch (info_wanted) {
 438         case PARROT_OS:
 439             return Parrot_str_new_constant(interp, BUILD_OS_NAME);
 440         case PARROT_OS_VERSION:
 441 #ifdef PARROT_HAS_HEADER_SYSUTSNAME
 442             {
 443                 struct utsname info;
 444                 if (uname(&info) == 0) {
 445                     return string_make(interp, info.version, strlen(info.version), "ascii", 0);
 446                 }
 447             }
 448 #endif
 449             break;
 450         case PARROT_OS_VERSION_NUMBER:
 451 #ifdef PARROT_HAS_HEADER_SYSUTSNAME
 452             {
 453                 struct utsname info;
 454                 if (uname(&info) == 0) {
 455                     return string_make(interp, info.release, strlen(info.version), "ascii", 0);
 456                 }
 457             }
 458 #endif
 459             break;
 460         case CPU_ARCH:
 461             return string_make(interp, PARROT_CPU_ARCH, sizeof (PARROT_CPU_ARCH) - 1, "ascii", 0);
 462         case CPU_TYPE:
 463         default:
 464             break;
 465     }
 466     return string_from_literal(interp, "");
 467 }
 468
 469 /*
 470  * Local variables:
 471  *   c-file-style: "parrot"
 472  * End:
 473  * vim: expandtab shiftwidth=4:
 474  */