languages/tcl/src/grammar/expr/past2pir.tg

   1 grammar TclExpr::PIR::Grammar is TGE::Grammar;
   2
   3 transform result (ROOT)  {
   4     $S0 = typeof node
   5     .return tree.get('pir', node, $S0)
   6 }
   7
   8 transform pir (PAST::Expr) {
   9     .local pmc pir
  10     pir = new 'CodeString'
  11
  12     .local pmc value
  13     value = node['value']
  14     $P0 = tree.get('pir', value)
  15     pir .= $P0
  16     $S0 = value['ret']
  17     node['ret'] = $S0
  18
  19     .local pmc ret, label
  20     ret   = node['ret']
  21     label = pir.unique('expr_is_string')
  22
  23     pir.emit(<<'END_PIR', ret, label)
  24   .local pmc toNumber
  25   toNumber = get_root_global ['_tcl'], 'toNumber'
  26   push_eh %1
  27     %0 = toNumber(%0)
  28   pop_eh
  29 %1:
  30 END_PIR
  31
  32     .return(pir)
  33 }
  34
  35 transform pir (PAST::Program) {
  36     .local pmc pir
  37     pir = new 'CodeString'
  38
  39     pir.emit(<<'END_PIR')
  40     .local pmc colons, split, epoch
  41     colons = get_root_global ['_tcl'], 'colons'
  42     split  = get_root_global ['parrot'; 'PGE::Util'], 'split'
  43     epoch = get_root_global ['_tcl'], 'epoch'
  44 END_PIR
  45
  46     .local pmc iter, child
  47     iter = node.'child_iter'()
  48 loop:
  49     unless iter goto end
  50     child = shift iter
  51     $P0 = tree.'get'('pir', child)
  52     $S0 = $P0
  53     pir .= $S0
  54     goto loop
  55 end:
  56     $S0 = child['ret']
  57     node['ret'] = $S0
  58     .return(pir)
  59 }
  60
  61 transform pir (PAST::Val) {
  62     .local pmc pir
  63     .local pmc ret
  64     .local pmc class
  65
  66     pir = new 'CodeString'
  67     ret = pir.unique('$P')
  68     class = node['class']
  69     pir.emit("    %0 = new '%1'", ret, class)
  70     $S0 = node['value']
  71     if class == "TclFloat"  goto assign_float
  72     if class == "TclString" goto assign_string
  73     goto assign_val
  74   assign_float:
  75     $I0 = index $S0, '.'                     # RT#40690: '.' hack due to
  76     if $I0 >= 0 goto assign_val              # parrotbug #38896
  77     $I0 = index $S0, 'E'
  78     if $I0 >= 0 goto assign_val
  79     $I0 = index $S0, 'e'
  80     if $I0 >= 0 goto assign_val
  81     concat $S0, '.'
  82     goto assign_val
  83   assign_string:
  84     $S0 = pir.escape($S0)
  85   assign_val:
  86     pir.emit('    assign %0, %1', ret, $S0)
  87   end:
  88     node['ret'] = ret
  89     node['istemp'] = 1
  90     .return (pir)
  91 }
  92
  93 transform pir (PAST::Var) {
  94     .local pmc pir, ret
  95     pir = new 'CodeString'
  96     ret = pir.unique('$P')
  97     node['ret']    = ret
  98     node['istemp'] = 1
  99
 100     .local string name
 101     name = node['name']
 102
 103     $I0 = exists node['index']
 104     if $I0 goto array
 105
 106     pir.emit(<<'END_PIR', ret, name)
 107   .local pmc readVar
 108   readVar = get_root_global ['_tcl'], 'readVar'
 109   %0 = readVar('%1')
 110 END_PIR
 111     .return(pir)
 112
 113 array:
 114     .local pmc    index
 115     index = node['index']
 116
 117     $P0 = tree.get('pir', index)
 118     pir .= $P0
 119     $S0 = index['ret']
 120     pir.emit(<<'END_PIR', ret, name, $S0)
 121   .local pmc readVar
 122   readVar = get_root_global ['_tcl'], 'readVar'
 123   $S0 = %2
 124   $S0 = '%1(' . $S0
 125   $S0 = $S0 . ')'
 126   %0 = readVar($S0)
 127 END_PIR
 128     .return(pir)
 129 }
 130
 131 transform pir (PAST::Op) {
 132     .local pmc args,iter,pir
 133     .local pmc return_register
 134
 135     pir = new 'CodeString'
 136     args = new 'TclList'
 137     iter = node.'child_iter'()
 138   iter_loop:
 139     unless iter goto iter_done
 140     $P1 = shift iter
 141     $P0 = tree.get('pir', $P1)
 142     return_register = $P1['ret']
 143     push args, return_register
 144     pir .= $P0
 145     goto iter_loop
 146   iter_done:
 147     # get a result PMC
 148     .local pmc retval
 149     retval = pir.unique('$P')
 150     pir .= retval
 151     pir .= " = get_hll_global '"
 152     $S0 = node['opfunc']
 153     pir .= $S0
 154     pir .= "'\n"
 155     pir .= retval
 156     pir .= " = "
 157     pir .= retval
 158     pir .= "("
 159     $S0 = join ", ", args
 160     pir .= $S0
 161     pir .= ")\n"
 162     node['ret'] = retval
 163     .return (pir)
 164 }
 165
 166 transform pir (PAST::MathFunc) {
 167     .local pmc args,iter,pir
 168     .local pmc return_register
 169
 170     pir  = new 'CodeString'
 171     args = new 'TclList'
 172     iter = node.'child_iter'()
 173   iter_loop:
 174     unless iter goto iter_done
 175     $P1 = shift iter
 176     $P0 = tree.get('pir', $P1)
 177     return_register = $P1['ret']
 178     push args, return_register
 179     pir .= $P0
 180     goto iter_loop
 181   iter_done:
 182     # get a result PMC
 183     .local pmc retval
 184     retval = pir.unique('$P')
 185     $S0    = node['mathfunc']
 186     pir.emit("%0 = get_hll_global ['tcl'; 'mathfunc'], '&%1'", retval, $S0)
 187     pir .= retval
 188     pir .= " = "
 189     pir .= retval
 190     pir .= "("
 191     $S0 = join ", ", args
 192     pir .= $S0
 193     pir .= ")\n"
 194     node['ret'] = retval
 195     .return (pir)
 196 }
 197
 198 transform pir (PAST::StaticCommand) {
 199     .local pmc args, children, iter, pir
 200     .local string reg
 201
 202     pir  = new 'CodeString'
 203     args = new 'TclList'
 204     children = node.'get_children'()
 205     iter = new 'Iterator', children
 206
 207     .local string name
 208     $P0  = shift iter
 209     name = $P0['value']
 210
 211   iter_loop:
 212     unless iter goto iter_done
 213     $P1 = shift iter
 214     $P0 = tree.get('pir', $P1)
 215     reg = $P1['ret']
 216     push args, reg
 217     pir .= $P0
 218     $S0 = typeof $P1
 219     if $S0 == 'PAST::Expand' goto iter_loop
 220     unless $S0 == 'PAST::Var' goto iter_loop
 221     pir.emit("    %0 = clone %0", reg)
 222     goto iter_loop
 223   iter_done:
 224     .local string retval
 225     retval = pir.unique('$P')
 226
 227     .local string invalid_, done_, exec_
 228     invalid_ = pir.unique('invalid_')
 229     done_    = pir.unique('done_')
 230     exec_    = pir.unique('exec_')
 231
 232     $P0 = shift children
 233     $S0 = $P0['value']
 234
 235     .local string ns
 236     ns  = ''
 237     $S0 = join ", ", args
 238     $I0 = index name, "::"
 239     if $I0 == -1 goto no_ns
 240
 241     .local pmc split, colons
 242     split  = get_root_global ['parrot'; 'PGE::Util'], 'split'
 243     colons = get_root_global ['_tcl'], 'colons'
 244     $P0    = split(colons, name)
 245     $S1    = pop $P0
 246
 247     $S1 = '&' . $S1
 248     $S1 = pir.escape($S1)
 249
 250     $S2 = $P0[0]
 251     if $S2 == "" goto root_ns
 252
 253     ns = join "'; '", $P0
 254     ns = "['" . ns
 255     ns = ns . "'], "
 256
 257     .local string root_
 258     root_ = pir.unique('root_')
 259     pir.emit(<<'END_PIR', retval, ns, $S1, root_, exec_)
 260     %0 = get_global %1 %2
 261     if null %0 goto %3
 262     goto %4
 263 %3:
 264 END_PIR
 265     unshift $P0, ""
 266
 267   root_ns:
 268     $S2 = shift $P0
 269     $I0 = elements $P0
 270     if $I0 == 0 goto root_ns_emit
 271
 272     ns = join "'; '", $P0
 273     ns = "['" . ns
 274     ns = ns . "'], "
 275
 276   root_ns_emit:
 277     pir.emit(<<'END_PIR', retval, ns, $S1, invalid_, exec_)
 278     %0 = get_hll_global %1 %2
 279     if null %0 goto %3
 280 %4:
 281 END_PIR
 282     goto emit
 283
 284   no_ns:
 285     $S1 = '&' . name
 286     $S1 = pir.escape($S1)
 287     pir.emit(<<'END_PIR', retval, $S1, invalid_)
 288     %0 = find_name %1
 289     if null %0 goto %2
 290 END_PIR
 291
 292   emit:
 293     $S3  = pir.escape(name)
 294     pir.emit(<<'END_PIR', retval, $S3, $S0, invalid_, done_)
 295     %0 = %0(%2)
 296     goto %4
 297 %3:
 298     die 'invalid command name %1'
 299 %4:
 300 END_PIR
 301     node['ret'] = retval
 302     .return(pir)
 303 }
 304
 305 transform pir (PAST::DynamicCommand) {
 306     .local pmc args, children, iter, pir, reg
 307
 308     pir  = new 'CodeString'
 309     args = new 'TclList'
 310     children = node.'get_children'()
 311     iter = new 'Iterator', children
 312   iter_loop:
 313     unless iter goto iter_done
 314     $P1 = shift iter
 315     $P0 = tree.get('pir', $P1)
 316     reg = $P1['ret']
 317     push args, reg
 318     pir .= $P0
 319     pir.emit("%0 = clone %0", reg)
 320     goto iter_loop
 321   iter_done:
 322     .local pmc retval, name
 323     retval = pir.unique('$P')
 324     name = shift args
 325
 326     $S1 = pir.unique('invalid_')
 327     $S2 = pir.unique('done_')
 328
 329     $P0 = shift children
 330     $S0 = $P0['value']
 331     $S0 = join ", ", args
 332     $S4 = pir.unique('curr_namespace')
 333     $S5 = pir.unique('root_namespace')
 334     pir.emit(<<'END_PIR', retval, name, $S0, $S1, $S2, $S4, $S5)
 335   $S0 = %1
 336   $P0 = split(colons, $S0)
 337   $S0 = ""
 338   $I0 = elements $P0
 339   if $I0 == 0 goto %5
 340   $S0 = pop $P0
 341   if $I0 == 1 goto %5
 342   $S1 = $P0[0]
 343   if $S1 != "" goto %5
 344   $S1 = shift $P0
 345 %6:
 346   %0 = get_hll_namespace $P0
 347   if null %0 goto %3
 348   $S1 = '&' . $S0
 349   %0  = %0[$S1]
 350   if null %0 goto %3
 351   %0  = %0(%2)
 352   goto %4
 353 %5:
 354   %0 = get_namespace $P0
 355   if null %0 goto %6
 356   $S1 = '&' . $S0
 357   %0  = %0[$S1]
 358   if null %0 goto %6 # try the root namespace if it's not in the current
 359   %0  = %0(%2)
 360   goto %4
 361 %3:
 362   die 'invalid command name %1'
 363 %4:
 364 END_PIR
 365     node['ret'] = retval
 366     .return(pir)
 367 }
 368
 369 transform pir (PAST::Expand) {
 370     .local pmc pir, value
 371     pir   = new 'CodeString'
 372     value = node['value']
 373
 374     $S0 = tree.get('pir', value)
 375     pir .= $S0
 376
 377     $S0 = value['ret']
 378     $S1 = pir.'unique'('$P')
 379     $S2 = pir.'unique'('loop_')
 380     $S3 = pir.'unique'('end_')
 381     pir.emit(<<'END_PIR', $S0)
 382   .local pmc toList
 383   toList = get_root_global ['_tcl'], 'toList'
 384   %0 = toList(%0)
 385 END_PIR
 386
 387     $S0 .= ' :flat'
 388     node['ret'] = $S0
 389     .return(pir)
 390 }
 391
 392 transform pir (PAST::Cond) {
 393     .local pmc args, pir, ret, label
 394     .local pmc children, cond, then, else
 395     .local string cond_result, then_result, else_result
 396
 397     pir = new 'CodeString'
 398     pir.emit('  .local pmc toBoolean')
 399     pir.emit('  toBoolean = get_root_global ["_tcl"], "toBoolean"')
 400
 401     # This node has 3 children. generate PIR so that:
 402     # if node1 then node2 else node3
 403
 404     # pick a unique register to store our result in.
 405     ret = pir.unique('$P')
 406
 407     #  pick a unique number for our labels..
 408     label = pir.unique('label_')
 409
 410     children = node.'get_children'()
 411
 412     cond = children[0]
 413     $S0 = tree.get('pir', cond)
 414     pir .= $S0
 415     cond_result = cond['ret']
 416
 417     pir.emit("  %0 = toBoolean(%0)",    cond_result)
 418     pir.emit("  unless %0 goto else_%1", cond_result, label)
 419
 420     then = children[1]
 421     $S0 = tree.get('pir', then)
 422     pir .= $S0
 423     then_result = then['ret']
 424
 425     pir.emit('    %0 = %1', ret, then_result)
 426     pir.emit("  goto end_if_%0", label)
 427
 428     #set the result register to the answer from this section
 429
 430    #then jump to custom end label..
 431
 432     pir.emit("  else_%0:",label)
 433
 434     else = children[2]
 435     $S0 = tree.get('pir', else)
 436     pir .= $S0
 437     else_result = else['ret']
 438
 439     pir.emit('    %0 = %1', ret, else_result)
 440
 441     #set the result register to the answer from this section
 442
 443     pir.emit("  end_if_%0:",label)
 444
 445     node['ret'] = ret
 446
 447     .return (pir)
 448 }
 449