languages/tcl/runtime/conversions.pir

   1 .HLL '_Tcl', ''
   2 .namespace []
   3
   4 =head2 _Tcl::__list
   5
   6 Given a PMC, get a list from it. If the PMC is a TclList,
   7 this is as simple as returning the list.
   8
   9 =cut
  10
  11 .sub __list :multi(TclList)
  12   .param pmc list
  13   .return(list)
  14 .end
  15
  16 .sub __list :multi(_)
  17   .param pmc value
  18
  19   $P0 = new 'TclString'
  20   $S0 = value
  21
  22   push_eh convert_to_tcl_error
  23     $P0 = $P0.'get_list'($S0)
  24   pop_eh
  25
  26   copy value, $P0
  27
  28   .return(value)
  29
  30   # The PMC method only throws a regular exception, we need to tcl-ify it.
  31   convert_to_tcl_error:
  32     get_results '0,0', $P0, $S0
  33     tcl_error $S0
  34
  35 .end
  36
  37 =head2 _Tcl::__dict
  38
  39 Given a PMC, get a TclDict from it, converting as needed.
  40
  41 =cut
  42
  43 .sub __dict :multi(TclDict)
  44   .param pmc dict
  45   .return(dict)
  46 .end
  47
  48 .sub __dict :multi(TclList)
  49   .param pmc list
  50
  51   $P0 = __listToDict(list)
  52   copy list, $P0
  53
  54   .return(list)
  55 .end
  56
  57 .sub __dict :multi(_)
  58   .param pmc value
  59
  60   $P0 = __stringToDict(value)
  61   copy value, $P0
  62
  63   .return(value)
  64 .end
  65
  66
  67 =head2 _Tcl::__number
  68
  69 Given a PMC, get a number from it.
  70
  71 =cut
  72
  73 .sub __number :multi(TclInt)
  74   .param pmc n
  75   .return(n)
  76 .end
  77
  78 .sub __number :multi(TclFloat)
  79   .param pmc n
  80   .return(n)
  81 .end
  82
  83 .sub __number :multi(_)
  84   .param pmc number
  85
  86   .local string str
  87   .local int    len
  88   str = number
  89   len = length str
  90   .include 'cclass.pasm'
  91
  92   .local pmc parse
  93   .local pmc match
  94
  95   parse = get_root_global ['parrot'; 'TclExpr::Grammar'], 'number'
  96   $I0 = find_not_cclass .CCLASS_WHITESPACE, str, 0, len
  97   match = parse(str, 'pos'=>$I0, 'grammar'=>'TclExpr::Grammar')
  98
  99   $I0 = match.'to'()
 100   $I1 = len - $I0
 101   $I0 = find_not_cclass .CCLASS_WHITESPACE, str, $I0, $I1
 102   if $I0 < len goto NaN
 103
 104   unless match goto NaN
 105
 106   .local pmc astgrammar, astbuilder, ast
 107   astgrammar = new 'TclExpr::PAST::Grammar'
 108   astbuilder = astgrammar.apply(match)
 109   ast = astbuilder.get('past')
 110
 111   .local string className
 112   .local pmc    value
 113
 114   className = ast['class']
 115   value     = ast['value']
 116
 117   # XXX We probably shouldn't have to invoke the PIR compiler here.
 118
 119   $P0 = new 'CodeString'
 120   $P0.emit(".sub 'anon' :anon")
 121   $P0.emit('$P0 = new "%0"', className)
 122   $P0.emit("$P0 = %0", value)
 123   $P0.emit(".return($P0)")
 124   $P0.emit(".end")
 125
 126   $P1 = compreg 'PIR'
 127   $P2 = $P1($P0)
 128   number = $P2()
 129
 130   .return(number)
 131
 132 NaN:
 133   $S1 = 'expected floating-point number but got "'
 134   $S0 = number
 135   $S1 .= $S0
 136   $S1 .= '"'
 137   tcl_error $S1
 138 .end
 139
 140 =head2 _Tcl::__integer
 141
 142 Given a PMC, get an integer from it.
 143
 144 =cut
 145
 146 .sub __integer :multi(TclInt)
 147   .param pmc n
 148   .return(n)
 149 .end
 150
 151 .sub __integer :multi(_)
 152   .param pmc value
 153   .param pmc rawhex :named ('rawhex') :optional
 154   .param int has_rawhex               :opt_flag
 155
 156   unless has_rawhex goto normal
 157   $S0 = value
 158   $S0 =  '0x' . $S0
 159   value = $S0
 160
 161 normal:
 162   .local pmc integer
 163
 164   push_eh not_integer_eh
 165     integer = __number(value)
 166   pop_eh
 167   $S0 = typeof integer
 168   if $S0 != 'TclInt' goto not_integer
 169
 170   copy value, integer
 171
 172   .return(value)
 173
 174 not_integer:
 175   $S1 = value
 176   $S0 = 'expected integer but got "'
 177   $S0 .= $S1
 178   $S0 .= '"'
 179   tcl_error $S0
 180
 181 not_integer_eh:
 182   get_results '0,0', $P99, $S99
 183   $I0 = index $S99, 'expected integer'
 184   if $I0 == -1 goto not_integer # got some other exception, rewrap it.
 185   rethrow $P99 # preserves the invalid octal message.
 186 .end
 187
 188 =head2 _Tcl::__index
 189
 190 =cut
 191
 192 .sub __index
 193   .param string idx
 194   .param pmc    list
 195
 196   if idx == 'end' goto end
 197
 198   $S0 = substr idx, 0, 4
 199   if $S0 == 'end-' goto before_end
 200   if $S0 == 'end+' goto after_end
 201
 202   push_eh bad_index
 203     $I0 = __integer(idx)
 204   pop_eh
 205   .return($I0)
 206
 207 before_end:
 208   $S0 = substr idx, 4
 209   push_eh bad_index
 210     $I0 = __integer($S0)
 211   pop_eh
 212
 213   $I1 = elements list
 214   dec $I1
 215   $I0 = $I1 - $I0
 216   .return($I0)
 217
 218 after_end:
 219   $S0 = substr idx, 4
 220   push_eh bad_index
 221     $I0 = __integer($S0)
 222   pop_eh
 223
 224   $I1 = elements list
 225   dec $I1
 226   $I0 = $I1 + $I0
 227   .return($I0)
 228
 229 end:
 230   $I0 = elements list
 231   dec $I0
 232   .return($I0)
 233
 234 bad_index:
 235   get_results '0,0', $P99, $S99
 236   $S0 = 'bad index "'
 237   $S0 .= idx
 238   $S0 .= '": must be integer?[+-]integer? or end?[+-]integer?'
 239   $S1 = ' (looks like invalid octal number)'
 240   $I0 = index $S99, $S1
 241   if $I0 == -1 goto bad_index_done
 242   $I0 = index idx, '--'
 243   if $I0 != -1 goto bad_index_done # don't squawk on negative indices..
 244   $S0 .= $S1
 245 bad_index_done:
 246   tcl_error $S0
 247 .end
 248
 249 =head2 _Tcl::__channel
 250
 251 Given a string, return the appropriate channel.
 252
 253 =cut
 254
 255 .sub __channel
 256   .param string channelID
 257
 258   .local pmc channels
 259   channels = find_global 'channels'
 260
 261   .local pmc io_obj
 262   io_obj = channels[channelID]
 263   if null io_obj goto bad_channel
 264
 265   $S0 = typeof io_obj
 266   if $S0 == 'ParrotIO' goto done
 267   if $S0 == 'TCPStream' goto done
 268
 269   # should never happen
 270   goto bad_channel
 271
 272 done:
 273   .return (io_obj)
 274
 275 bad_channel:
 276   $S0 = 'can not find channel named "'
 277   $S0 .= channelID
 278   $S0 .= '"'
 279   tcl_error $S0
 280
 281 .end
 282
 283 =head2 _Tcl::__expr
 284
 285 Given an expression, return a subroutine, or optionally, the raw PIR
 286
 287 =cut
 288
 289 .sub __expr
 290     .param string expression
 291     .param int    pir_only :named('pir_only') :optional
 292     .param pmc    ns       :named('ns')       :optional
 293     .param int    has_ns   :opt_flag
 294
 295     .local pmc parse
 296     .local pmc match
 297
 298     if expression == '' goto empty
 299
 300     parse = get_root_global ['parrot'; 'TclExpr::Grammar'], 'expression'
 301     match = parse(expression, 'pos'=>0, 'grammar'=>'TclExpr::Grammar')
 302
 303     unless match goto premature_end
 304     $I0 = length expression
 305     $I1 = match.to()
 306     .include 'cclass.pasm'
 307     $I1 = find_not_cclass .CCLASS_WHITESPACE, expression, $I1, $I0
 308     unless $I0 == $I1 goto extra_tokens
 309
 310     .local pmc astgrammar, astbuilder, ast
 311     astgrammar = new 'TclExpr::PAST::Grammar'
 312     astbuilder = astgrammar.apply(match)
 313     ast = astbuilder.get('past')
 314
 315     .local string namespace
 316     namespace = ''
 317     unless has_ns goto build_pir
 318
 319     $P0 = ns.'get_name'()
 320     $S0 = shift $P0
 321     $I0 = elements $P0
 322     if $I0 == 0 goto build_pir
 323     $S0 = join "'; '", $P0
 324     $S0 = "['" . $S0
 325     $S0 = $S0 . "']"
 326     namespace = $S0
 327
 328   build_pir:
 329     .local pmc pirgrammar, pirbuilder
 330     .local string result
 331     pirgrammar = new 'TclExpr::PIR::Grammar'
 332     pirbuilder = pirgrammar.'apply'(ast)
 333     result = pirbuilder.get('result')
 334
 335     .local string ret
 336     ret = ast['ret']
 337     if pir_only goto only_pir
 338
 339     .local pmc pir
 340     pir = new 'CodeString'
 341
 342     pir.emit(".HLL 'Tcl', ''")
 343     pir.emit('.namespace %0', namespace)
 344     pir.emit(".sub '_anon' :anon")
 345     pir .= result
 346     pir.emit("  .return(%0)", ret)
 347     pir.emit(".end")
 348
 349     $P1 = compreg 'PIR'
 350     $P2 = $P1(pir)
 351     .return ($P2)
 352
 353   only_pir:
 354     .return(result, ret)
 355
 356   premature_end:
 357     $S0 = expression
 358     $S0 = 'syntax error in expression "' . $S0
 359     $S0 = $S0 . '": premature end of expression'
 360     tcl_error $S0
 361
 362   extra_tokens:
 363     $S0 = expression
 364     $S0 = 'syntax error in expression "' . $S0
 365     $S0 = $S0 . '": extra tokens at end of expression'
 366     tcl_error $S0
 367
 368   empty:
 369     tcl_error "empty expression\nin expression \"\""
 370 .end
 371
 372 =head2 _Tcl::__script
 373
 374 Given a chunk of tcl code, return a subroutine.
 375
 376 =cut
 377
 378 .sub __script
 379     .param string code
 380     .param int    pir_only    :named('pir_only') :optional
 381     .param pmc    ns          :named('ns')       :optional
 382     .param int    has_ns      :opt_flag
 383     .param int    bsnl        :named('bsnl')     :optional
 384     .param int    has_bsnl    :opt_flag
 385     .param int    wrapper     :named('wrapper')  :optional
 386     .param int    has_wrapper :opt_flag
 387
 388     .local pmc parse
 389     .local pmc match
 390
 391     unless has_bsnl goto end_preamble
 392     unless bsnl     goto end_preamble
 393     code = 'backslash_newline_subst'( code )
 394
 395 end_preamble:
 396     parse = get_root_global ['parrot'; 'TclExpr::Grammar'], 'program'
 397     match = parse(code, 'pos'=>0, 'grammar'=>'TclExpr::Grammar')
 398
 399     unless match goto premature_end
 400     $I0 = length code
 401     $I1 = match.to()
 402     .include 'cclass.pasm'
 403     $I1 = find_not_cclass .CCLASS_WHITESPACE, code, $I1, $I0
 404     unless $I0 == $I1 goto extra_tokens
 405
 406     .local pmc astgrammar, astbuilder, ast
 407     astgrammar = new 'TclExpr::PAST::Grammar'
 408     astbuilder = astgrammar.apply(match)
 409     ast = astbuilder.get('past')
 410
 411     .local string namespace
 412     namespace = ''
 413     unless has_ns goto build_pir
 414
 415     $P0 = ns.'get_name'()
 416     $S0 = shift $P0
 417     $I0 = elements $P0
 418     if $I0 == 0 goto build_pir
 419     $S0 = join "'; '", $P0
 420     $S0 = "['" . $S0
 421     $S0 = $S0 . "']"
 422     namespace = $S0
 423
 424   build_pir:
 425     .local pmc pirgrammar, pirbuilder
 426     .local string result
 427     pirgrammar = new 'TclExpr::PIR::Grammar'
 428     pirbuilder = pirgrammar.'apply'(ast)
 429     result = pirbuilder.get('result')
 430
 431     .local string ret
 432     ret = ast['ret']
 433
 434     .local pmc pir
 435     pir = new 'CodeString'
 436     unless pir_only goto do_wrapper
 437     if has_wrapper  goto do_wrapper
 438     pir = result
 439     goto only_pir
 440
 441 do_wrapper:
 442     pir.emit(".HLL 'Tcl', ''")
 443     pir.emit(".loadlib 'tcl_ops'")
 444     pir.emit('.namespace %0', namespace)
 445     pir.emit(".include 'languages/tcl/src/returncodes.pasm'")
 446     pir.emit(".sub '_anon' :anon")
 447     pir .= result
 448     pir.emit('  .return(%0)', ret)
 449     pir.emit('.end')
 450     pir.emit(<<"END_PIR")
 451
 452 .sub '_init' :init
 453     load_bytecode 'languages/tcl/runtime/tcllib.pir'
 454 .end
 455 END_PIR
 456
 457     if pir_only goto only_pir
 458     $P1 = compreg 'PIR'
 459     $P2 = $P1(pir)
 460     .return ($P2)
 461
 462   only_pir:
 463     .return(pir, ret)
 464
 465   premature_end:
 466     say code
 467     tcl_error "program doesn't match grammar"
 468
 469   extra_tokens:
 470     $S0 = substr code, $I1
 471     $S0 = 'extra tokens at end of program: ' . $S0
 472     tcl_error $S0
 473 .end
 474
 475 =head2 _Tcl::__namespace
 476
 477 Given a string namespace, return an array of names.
 478
 479 =cut
 480
 481 .sub __namespace
 482   .param string name
 483   .param int    depth     :optional
 484   .param int    has_depth :opt_flag
 485
 486   if has_depth goto depth_set
 487   depth = 0
 488
 489 depth_set:
 490   .local pmc colons, split
 491   colons = get_root_global ['_tcl'], 'colons'
 492   split  = get_root_global ['parrot'; 'PGE::Util'], 'split'
 493
 494   .local pmc ns_name
 495   ns_name = split(colons, name)
 496   $I0 = elements ns_name
 497   if $I0 == 0 goto relative
 498   $S0 = ns_name[0]
 499   if $S0 != '' goto relative
 500
 501 absolute:
 502   $P1 = shift ns_name
 503   goto return
 504
 505 relative:
 506   .local pmc interp
 507   interp = getinterp
 508 relative_loop:
 509   inc depth
 510   $P0 = interp['sub'; depth]
 511   $P0 = $P0.'get_namespace'()
 512   $P0 = $P0.'get_name'()
 513   $S0 = $P0[0]
 514   if $S0 == '_tcl' goto relative_loop
 515
 516   $I0 = elements $P0
 517 combine_loop:
 518   dec $I0
 519   if $I0 == 0 goto return
 520   $P1 = $P0[$I0]
 521   unshift ns_name, $P1
 522   goto combine_loop
 523
 524 return:
 525   .return(ns_name)
 526 .end
 527
 528 =head2 _Tcl::__boolean
 529
 530 Given a string, return its boolean value if it's a valid boolean. Otherwise,
 531 throw an exception.
 532
 533 =cut
 534
 535 .sub __boolean
 536     .param pmc value
 537
 538     .local string lc
 539     $S0 = value
 540     lc = downcase $S0
 541
 542     if lc == '1' goto true
 543     if lc == '0' goto false
 544     if lc == 'true'  goto true
 545     if lc == 'tru'   goto true
 546     if lc == 'tr'    goto true
 547     if lc == 't'     goto true
 548     if lc == 'false' goto false
 549     if lc == 'fals'  goto false
 550     if lc == 'fal'   goto false
 551     if lc == 'fa'    goto false
 552     if lc == 'f'     goto false
 553     if lc == 'yes'   goto true
 554     if lc == 'ye'    goto true
 555     if lc == 'y'     goto true
 556     if lc == 'no'    goto false
 557     if lc == 'n'     goto false
 558     if lc == 'on'    goto true
 559     if lc == 'off'   goto false
 560     if lc == 'of'    goto false
 561
 562     .local pmc __number
 563     __number = get_hll_global '__number'
 564
 565     push_eh error
 566       value = __number(value)
 567     pop_eh
 568     if value goto true
 569     goto false
 570
 571 error:
 572     $S0 = value
 573     $S0 = 'expected boolean value but got "' . $S0
 574     $S0 = $S0 . '"'
 575     tcl_error $S0
 576
 577 number:
 578
 579 true:
 580     .return(1)
 581
 582 false:
 583     .return(0)
 584 .end
 585
 586 =head2 _Tcl::__call_level
 587
 588 Given a pmc containing the tcl-style call level, return an int-like pmc
 589 indicating the parrot-style level, and an integer with a boolean 0/1 -
 590 was this a valid tcl-style level, or did we get this value as a default?
 591
 592 =cut
 593
 594 .sub __call_level
 595   .param pmc tcl_level
 596   .local pmc parrot_level, defaulted, orig_level
 597   defaulted = new 'Integer'
 598   defaulted = 0
 599
 600   .local pmc call_chain, __number
 601   .local int call_level
 602   call_chain = get_root_global ['_tcl'], 'call_chain'
 603   call_level = elements call_chain
 604   __number   = get_root_global ['_tcl'], '__number'
 605   orig_level = new 'Integer'
 606   orig_level = call_level
 607
 608   .local int num_length
 609
 610 get_absolute:
 611   # Is this an absolute?
 612   $S0 = tcl_level
 613   $S1 = substr $S0, 0, 1, ''
 614   if $S1 != '#' goto get_integer
 615   push_eh default
 616     parrot_level = __number($S0)
 617   pop_eh
 618   goto bounds_check
 619
 620 get_integer:
 621   push_eh default
 622     parrot_level = __number(tcl_level)
 623   pop_eh
 624
 625   if parrot_level < 0 goto default
 626   parrot_level = orig_level - parrot_level
 627   goto bounds_check
 628
 629 default:
 630   defaulted = 1
 631   parrot_level = new 'Integer'
 632   parrot_level = orig_level - 1
 633   # fallthrough.
 634
 635 bounds_check:
 636   # Are we < 0 ?
 637   if parrot_level < 0          goto bad_level
 638   if parrot_level > orig_level goto bad_level
 639
 640   $I1 = defaulted
 641   .return(parrot_level,$I1)
 642
 643 bad_level:
 644   $S0 = tcl_level
 645   $S0 = 'bad level "' . $S0
 646   $S0 = $S0 . '"'
 647   tcl_error $S0
 648 .end
 649
 650 =head2 _Tcl::backslash_newline_subst
 651
 652 Given a string of tcl code, perform the backslash/newline subsitution.
 653
 654 =cut
 655
 656 .sub 'backslash_newline_subst'
 657   .param string contents
 658
 659   .local int len
 660   len = length contents
 661
 662   # perform the backslash-newline substitution
 663   $I0 = -1
 664 backslash_loop:
 665   inc $I0
 666   if $I0 >= len goto done
 667   $I1 = ord contents, $I0
 668   if $I1 != 92 goto backslash_loop # \\
 669   inc $I0
 670   $I2 = $I0
 671   $I1 = ord contents, $I2
 672   if $I1 == 10 goto space # \n
 673   if $I1 == 13 goto space # \r
 674   goto backslash_loop
 675 space:
 676   inc $I2
 677   if $I0 >= len goto done
 678   $I1 = is_cclass .CCLASS_WHITESPACE, contents, $I2
 679   if $I1 == 0 goto not_space
 680   goto space
 681 not_space:
 682   dec $I0
 683   $I1 = $I2 - $I0
 684   substr contents, $I0, $I1, ' '
 685   dec $I1
 686   len -= $I1
 687   goto backslash_loop
 688
 689 done:
 690   .return (contents)
 691 .end
 692
 693 # Given a list, reverse the elements in the list.
 694 # Might make sense to make this a method on one of the parrot types we
 695 # inherit from.
 696 .sub 'reverse'
 697   .param pmc value
 698
 699   .local int high
 700   .local int low
 701   .local pmc swap_one
 702   .local pmc swap_two
 703
 704   high = value
 705   dec high # need index, not count
 706   low = 0
 707
 708  loop:
 709   if high <= low goto loop_end
 710   swap_one    = value[low]
 711   swap_two    = value[high]
 712   value[low]  = swap_two
 713   value[high] = swap_one
 714   inc low
 715   dec high
 716   goto loop
 717  loop_end:
 718
 719  .return()
 720 .end
 721
 722 # Local Variables:
 723 #   mode: pir
 724 #   fill-column: 100
 725 # End:
 726 # vim: expandtab shiftwidth=4 ft=pir: