languages/perl6/src/builtins/guts.pir

   1 ## $Id$
   2
   3 =head1 NAME
   4
   5 src/builtins/guts.pir - subs that are part of the internals, not for users
   6
   7 =head1 SUBS
   8
   9 =over 4
  10
  11 =item !EXPORT(symbols, from :named('from') [, to :named('to')] )
  12
  13 Export symbols in namespace C<from> to the namespace given by C<to>.
  14 If C<to> isn't given, then exports into the HLL global namespace.
  15 This function differs somewhat from Parrot's C<Exporter> PMC in that
  16 it understands how to properly merge C<MultiSub> PMCs.
  17
  18 =cut
  19
  20 .namespace []
  21 .sub '!EXPORT'
  22     .param string symbols
  23     .param pmc from            :named('from')
  24     .param pmc to              :named('to') :optional
  25     .param int has_to          :opt_flag
  26
  27     if has_to goto have_to
  28     to = get_hll_namespace
  29   have_to:
  30
  31     .local pmc list
  32     list = split ' ', symbols
  33   list_loop:
  34     unless list goto list_end
  35     .local string symbol
  36     .local pmc value
  37     symbol = shift list
  38     value = from[symbol]
  39     $I0 = isa value, 'MultiSub'
  40     unless $I0 goto store_value
  41     $P0 = to[symbol]
  42     if null $P0 goto store_value
  43     $I0 = isa $P0, 'MultiSub'
  44     unless $I0 goto err_type_conflict
  45     $I0 = elements $P0
  46     splice $P0, value, $I0, 0
  47     goto list_loop
  48   store_value:
  49     to[symbol] = value
  50     goto list_loop
  51   list_end:
  52     .return ()
  53
  54   err_type_conflict:
  55     $S0 = concat "Unable to add Multisub '", symbol
  56     $S0 .= "' to existing value"
  57     die $S0
  58 .end
  59
  60
  61 =item !OUTER(name [,'max'=>max])
  62
  63 Helper function to obtain the lexical C<name> from the
  64 caller's outer scope.  (Note that it never finds a lexical
  65 in the caller's lexpad -- use C<find_lex> for that.)  The
  66 C<max> parameter specifies the maximum outer to search --
  67 the default value of 1 will search the caller's immediate
  68 outer scope and no farther.  If the requested lexical is
  69 not found, C<!OUTER> returns null.
  70
  71 =cut
  72
  73 .sub '!OUTER'
  74     .param string name
  75     .param int max             :named('max') :optional
  76     .param int has_max         :opt_flag
  77
  78     if has_max goto have_max
  79     max = 1
  80   have_max:
  81
  82     .local int min
  83     min = 1
  84
  85     ##  the depth we use here is one more than the minimum,
  86     ##  because we want min/max to be relative to the caller's
  87     ##  context, not !OUTER itself.
  88     .local int depth
  89     depth = min + 1
  90     .local pmc lexpad, value
  91     push_eh outer_err
  92     null value
  93   loop:
  94     unless max >= min goto done
  95     $P0 = getinterp
  96     lexpad = $P0['outer', depth]
  97     unless lexpad goto next
  98     value = lexpad[name]
  99     unless null value goto done
 100   next:
 101     inc depth
 102     dec max
 103     goto loop
 104   done:
 105     pop_eh
 106   outer_err:
 107     .return (value)
 108 .end
 109
 110
 111 =item !VAR
 112
 113 Helper function for implementing the VAR and .VAR macros.
 114
 115 =cut
 116
 117 .sub '!VAR'
 118     .param pmc variable
 119     $I0 = isa variable, 'Perl6Scalar'
 120     unless $I0 goto nothing
 121     $P0 = new 'MutableVAR', variable
 122     .return ($P0)
 123   nothing:
 124     .return (variable)
 125 .end
 126
 127
 128 =item !DOTYPECHECK
 129
 130 Checks that the value and the assignee are type-compatible and does the
 131 assignment.
 132
 133 =cut
 134
 135 .sub '!DOTYPECHECK'
 136     .param pmc type
 137     .param pmc value
 138     .param pmc result
 139     $I0 = type.'ACCEPTS'(value)
 140     result = $I0
 141 .end
 142
 143
 144 =item !TYPECHECKPARAM
 145
 146 Checks the type of a parameter.
 147
 148 =cut
 149
 150 .sub '!TYPECHECKPARAM'
 151     .param pmc type
 152     .param pmc value
 153     $P0 = getinterp
 154     $P0 = $P0['lexpad';1]
 155     if null $P0 goto no_match_to_copy
 156     $P0 = $P0['$/']
 157     .lex "$/", $P0
 158   no_match_to_copy:
 159
 160     $I0 = type.ACCEPTS(value)
 161     if $I0 goto ok
 162     'die'('Parameter type check failed')
 163 ok:
 164 .end
 165
 166
 167 =item !SAMETYPE_EXACT
 168
 169 Takes two types and returns true if they match exactly (not accounting for any
 170 subtyping relations, etc).
 171
 172 =cut
 173
 174 .sub '!SAMETYPE_EXACT'
 175     .param pmc t1
 176     .param pmc t2
 177
 178     # If they have equal address, obviously the same.
 179     .local pmc t1meta, t2meta
 180     t1meta = t1.'HOW'()
 181     t2meta = t2.'HOW'()
 182     eq_addr t1meta, t2meta, same
 183
 184     # If they are junctions, compare inside them recursively.
 185     $I0 = isa t1, 'Junction'
 186     unless $I0 goto not_junc
 187     $I1 = isa t2, 'Junction'
 188     unless $I0 == $I1 goto not_junc
 189     .local pmc j1, j2
 190     .local int max, i
 191     j1 = t1.'values'()
 192     j2 = t1.'values'()
 193     max = elements j1
 194     i = 0
 195   junc_loop:
 196     if i >= max goto junc_loop_end
 197     $P0 = j1[i]
 198     $P1 = j2[i]
 199     $I0 = '!SAMETYPE_EXACT'($P0, $P1)
 200     unless $I0 goto not_same
 201     inc i
 202     goto junc_loop
 203   junc_loop_end:
 204   not_junc:
 205
 206   not_same:
 207     .return(0)
 208   same:
 209     .return (1)
 210 .end
 211
 212
 213 =item !keyword_class(name)
 214
 215 Internal helper method to create a class.
 216
 217 =cut
 218
 219 .sub '!keyword_class'
 220     .param string name
 221     .local pmc class, resolve_list, methods, iter
 222
 223     # Create class.
 224     class = newclass name
 225
 226     # Set resolve list to include all methods of the class.
 227     methods = inspect class, 'methods'
 228     iter = new 'Iterator', methods
 229     resolve_list = new 'ResizableStringArray'
 230   resolve_loop:
 231     unless iter goto resolve_loop_end
 232     $P0 = shift iter
 233     push resolve_list, $P0
 234     goto resolve_loop
 235   resolve_loop_end:
 236     class.resolve_method(resolve_list)
 237
 238     .return(class)
 239 .end
 240
 241 =item !keyword_role(name)
 242
 243 Internal helper method to create a role.
 244
 245 =cut
 246
 247 .sub '!keyword_role'
 248     .param string name
 249     .local pmc info, role
 250
 251     # Need to make sure it ends up attached to the right
 252     # namespace.
 253     info = new 'Hash'
 254     info['name'] = name
 255     $P0 = new 'ResizablePMCArray'
 256     $P0[0] = name
 257     info['namespace'] = $P0
 258
 259     # Create role.
 260     role = new 'Role', info
 261
 262     # Stash in namespace.
 263     $P0 = new 'ResizableStringArray'
 264     set_hll_global $P0, name, role
 265
 266     .return(role)
 267 .end
 268
 269 =item !keyword_grammar(name)
 270
 271 Internal helper method to create a grammar.
 272
 273 =cut
 274
 275 .sub '!keyword_grammar'
 276     .param string name
 277     .local pmc info, grammar
 278
 279     # Need to make sure it ends up attached to the right
 280     # namespace.
 281     info = new 'Hash'
 282     info['name'] = name
 283     $P0 = new 'ResizablePMCArray'
 284     $P0[0] = name
 285     info['namespace'] = $P0
 286
 287     # Create grammar class..
 288     grammar = new 'Class', info
 289
 290     .return(grammar)
 291 .end
 292
 293 =item !keyword_enum(name)
 294
 295 Internal helper method to create an enum class.
 296
 297 =cut
 298
 299 .sub '!keyword_enum'
 300     .param pmc role
 301     .local pmc class
 302
 303     # Create an anonymous class and attach the role.
 304     class = new 'Class'
 305     $P0 = get_class 'Any'
 306     addparent class, $P0
 307     "!keyword_does"(class, role)
 308     .return(class)
 309 .end
 310
 311 =item !keyword_does(class, role)
 312
 313 Internal helper method to implement the functionality of the does keyword.
 314
 315 =cut
 316
 317 .sub '!keyword_does'
 318     .param pmc class
 319     .param pmc role
 320
 321     # Get Parrot to compose the role for us (handles the methods).
 322     addrole class, role
 323
 324     # Parrot doesn't handle composing the attributes; we do that here for now.
 325     .local pmc role_attrs, class_attrs, ra_iter
 326     .local string cur_attr
 327     role_attrs = inspect role, "attributes"
 328     class_attrs = inspect class, "attributes"
 329     ra_iter = iter role_attrs
 330   ra_iter_loop:
 331     unless ra_iter goto ra_iter_loop_end
 332     cur_attr = shift ra_iter
 333
 334     # Check that this attribute doesn't conflict with one already in the class.
 335     $I0 = exists class_attrs[cur_attr]
 336     unless $I0 goto no_conflict
 337
 338     # We have a name conflict. Let's compare the types. If they match, then we
 339     # can merge the attributes.
 340     .local pmc class_attr_type, role_attr_type
 341     $P0 = class_attrs[cur_attr]
 342     if null $P0 goto conflict
 343     class_attr_type = $P0['type']
 344     if null class_attr_type goto conflict
 345     $P0 = role_attrs[cur_attr]
 346     if null $P0 goto conflict
 347     role_attr_type = $P0['type']
 348     if null role_attr_type goto conflict
 349     $I0 = '!SAMETYPE_EXACT'(class_attr_type, role_attr_type)
 350     if $I0 goto merge
 351
 352   conflict:
 353     $S0 = "Conflict of attribute '"
 354     $S0 = concat cur_attr
 355     $S0 = concat "' in composition of role '"
 356     $S1 = role
 357     $S0 = concat $S1
 358     $S0 = concat "'"
 359     'die'($S0)
 360
 361   no_conflict:
 362     addattribute class, cur_attr
 363   merge:
 364     goto ra_iter_loop
 365   ra_iter_loop_end:
 366 .end
 367
 368 =item !keyword_has(class, attr_name, type)
 369
 370 Adds an attribute with the given name to the class or role.
 371
 372 =cut
 373
 374 .sub '!keyword_has'
 375     .param pmc class
 376     .param string attr_name
 377     .param pmc type
 378     class.'add_attribute'(attr_name, type)
 379 .end
 380
 381
 382 =item !anon_enum(value_list)
 383
 384 Constructs a Mapping, based upon the values list.
 385
 386 =cut
 387
 388 .sub '!anon_enum'
 389     .param pmc values
 390
 391     # For now, we assume integer type, unless we have a first pair that says
 392     # otherwise.
 393     .local pmc cur_val
 394     cur_val = new 'Int'
 395     cur_val = 0
 396
 397     # Iterate over values and make mapping.
 398     .local pmc result, values_it, cur_item
 399     result = new 'Mapping'
 400     values_it = iter values
 401   values_loop:
 402     unless values_it goto values_loop_end
 403     cur_item = shift values_it
 404     $I0 = isa cur_item, 'Perl6Pair'
 405     if $I0 goto pair
 406
 407   nonpair:
 408     $P0 = 'postfix:++'(cur_val)
 409     result[cur_item] = $P0
 410     goto values_loop
 411
 412   pair:
 413     cur_val = cur_item.'value'()
 414     $P0 = cur_item.'key'()
 415     result[$P0] = cur_val
 416     cur_val = clone cur_val
 417     'postfix:++'(cur_val)
 418     goto values_loop
 419
 420   values_loop_end:
 421     .return (result)
 422 .end
 423
 424
 425 =back
 426
 427 =cut
 428
 429 # Local Variables:
 430 #   mode: pir
 431 #   fill-column: 100
 432 # End:
 433 # vim: expandtab shiftwidth=4 ft=pir: