compilers/pct/src/PCT/HLLCompiler.pir

   1 # Copyright (C) 2006-2010, Parrot Foundation.
   2 # $Id$
   3
   4 =head1 NAME
   5
   6 PCT::HLLCompiler - base class for compiler objects
   7
   8 =head1 DESCRIPTION
   9
  10 This file implements a C<HLLCompiler> class of objects used for
  11 creating HLL compilers.  It provides the standard methods required
  12 for all compilers, as well as some standard scaffolding for
  13 running compilers from a command line.
  14
  15 =cut
  16
  17 .sub 'onload' :anon :load :init
  18     load_bytecode 'P6object.pbc'
  19     load_bytecode 'Parrot/Exception.pbc'
  20     $P0 = new 'P6metaclass'
  21     $S0 = '@stages $parsegrammar $parseactions $astgrammar $commandline_banner $commandline_prompt @cmdoptions $usage $version'
  22     $P0.'new_class'('PCT::HLLCompiler', 'attr'=>$S0)
  23 .end
  24
  25 .namespace [ 'PCT';'HLLCompiler' ]
  26
  27 .include 'cclass.pasm'
  28 .include 'stdio.pasm'
  29 .include 'iglobals.pasm'
  30
  31 .sub 'init' :vtable :method
  32     $P0 = split ' ', 'parse past post pir evalpmc'
  33     setattribute self, '@stages', $P0
  34
  35     $P0 = split ' ', 'e=s help|h target=s dumper=s trace|t=s encoding=s output|o=s combine version|v stagestats'
  36     setattribute self, '@cmdoptions', $P0
  37
  38     $P1 = box <<'    USAGE'
  39   This compiler is based on PCT::HLLCompiler.
  40
  41   Options:
  42     USAGE
  43
  44     .local pmc it
  45     it = iter $P0
  46   options_loop:
  47     unless it goto options_end
  48     $P3  = shift it
  49     $P1 .= "    "
  50     $P1 .= $P3
  51     $P1 .= "\n"
  52     goto options_loop
  53   options_end:
  54     setattribute self, '$usage', $P1
  55
  56     $S0  = '???'
  57     push_eh _handler
  58     $P0 = getinterp
  59     $P0 = $P0[.IGLOBALS_CONFIG_HASH]
  60     $S0  = $P0['revision']   # also $I0 = P0['installed'] could be used
  61   _handler:
  62     pop_eh
  63     $P2  = box 'This compiler is built with the Parrot Compiler Toolkit, parrot '
  64     if $S0 goto _revision_lab
  65     $P2 .= 'version '
  66     $S0 = $P0['VERSION']
  67     goto _is_version
  68   _revision_lab:
  69     $P2 .= 'revision '
  70   _is_version:
  71     $P2 .= $S0
  72     $P2 .= '.'
  73     setattribute self, '$version', $P2
  74 .end
  75
  76
  77 =head2 Methods
  78
  79 =over 4
  80
  81 =item attr(string attrname, pmc value, int has_value)
  82
  83 Helper method for accessors -- gets/sets an attribute given
  84 by C<attrname> based on C<has_value>.
  85
  86 =cut
  87
  88 .sub 'attr' :method
  89     .param string attrname
  90     .param pmc value
  91     .param int has_value
  92     if has_value goto set_value
  93     value = getattribute self, attrname
  94     unless null value goto end
  95     value = new 'Undef'
  96     goto end
  97   set_value:
  98     setattribute self, attrname, value
  99   end:
 100     .return (value)
 101 .end
 102
 103
 104 =item panic(message :slurpy)
 105
 106 Helper method to throw an exception (with a message).
 107
 108 =cut
 109
 110 .sub 'panic' :method
 111     .param pmc args            :slurpy
 112     $S0 = join '', args
 113     die $S0
 114 .end
 115
 116
 117 =item language(string name)
 118
 119 Register this object as the compiler for C<name> using the
 120 C<compreg> opcode.
 121
 122 =cut
 123
 124 .sub 'language' :method
 125     .param string name
 126     compreg name, self
 127     .return ()
 128 .end
 129
 130 =item stages([stages])
 131
 132 Accessor for the C<stages> attribute.
 133
 134 =item parsegrammar([string grammar])
 135
 136 Accessor for the C<parsegrammar> attribute.
 137
 138 =item parseactions([actions])
 139
 140 Accessor for the C<parseactions> attribute.
 141
 142 =item astgrammar([grammar])
 143
 144 Accessor for the C<astgrammar> attribute.
 145
 146 =item commandline_banner([string value])
 147
 148 Set the command-line banner for this compiler to C<value>.
 149 The banner is displayed at the beginning of interactive mode.
 150
 151 =item commandline_prompt([string value])
 152
 153 Set the command-line prompt for this compiler to C<value>.
 154 The prompt is displayed in interactive mode at each point where
 155 the compiler is ready for code to be compiled and executed.
 156
 157 =cut
 158
 159 .sub 'stages' :method
 160     .param pmc value           :optional
 161     .param int has_value       :opt_flag
 162     .tailcall self.'attr'('@stages', value, has_value)
 163 .end
 164
 165 .sub 'parsegrammar' :method
 166     .param pmc value        :optional
 167     .param int has_value       :opt_flag
 168     .tailcall self.'attr'('$parsegrammar', value, has_value)
 169 .end
 170
 171 .sub 'parseactions' :method
 172     .param pmc value           :optional
 173     .param int has_value       :opt_flag
 174     .tailcall self.'attr'('$parseactions', value, has_value)
 175 .end
 176
 177 .sub 'astgrammar' :method
 178     .param pmc value        :optional
 179     .param int has_value       :opt_flag
 180     .tailcall self.'attr'('$astgrammar', value, has_value)
 181 .end
 182
 183 .sub 'commandline_banner' :method
 184     .param string value        :optional
 185     .param int has_value       :opt_flag
 186     .tailcall self.'attr'('$commandline_banner', value, has_value)
 187 .end
 188
 189 .sub 'commandline_prompt' :method
 190     .param string value        :optional
 191     .param int has_value       :opt_flag
 192     .tailcall self.'attr'('$commandline_prompt', value, has_value)
 193 .end
 194
 195 =item removestage(string stagename)
 196
 197 Delete a stage from the compilation process queue.
 198
 199 =cut
 200
 201 .sub 'removestage' :method
 202     .param string stagename
 203
 204     .local pmc stages, it, newstages
 205     stages = getattribute self, '@stages'
 206     newstages = new 'ResizableStringArray'
 207
 208     it = iter stages
 209   iter_loop:
 210     unless it goto iter_end
 211     .local pmc current
 212     current = shift it
 213     if current == stagename goto iter_loop
 214       push newstages, current
 215     goto iter_loop
 216   iter_end:
 217     setattribute self, '@stages', newstages
 218 .end
 219
 220 =item addstage(string stagename [, "option" => value, ... ])
 221
 222 Add a stage to the compilation process queue. Takes either a "before" or
 223 "after" named argument, which gives the relative ordering of the stage
 224 to be added. If "before" and "after" aren't specified, the new stage is
 225 inserted at the end of the queue.
 226
 227 It's possible to add multiple stages of the same name: for example, you
 228 might repeat a stage like "optimize_tree" or "display_benchmarks" after
 229 each transformation. If you have multiple stages of the same name, and
 230 add a new stage before or after that repeated stage, the new stage will
 231 be added at every instance of the repeated stage.
 232
 233 =cut
 234
 235 .sub 'addstage' :method
 236     .param string stagename
 237     .param pmc adverbs         :slurpy :named
 238
 239     .local string position, target
 240     .local pmc stages
 241     stages = getattribute self, '@stages'
 242
 243     $I0 = exists adverbs['before']
 244     unless $I0 goto next_test
 245       position = 'before'
 246       target = adverbs['before']
 247     goto positional_insert
 248
 249   next_test:
 250     $I0 = exists adverbs['after']
 251     unless $I0 goto simple_insert
 252       position = 'after'
 253       target = adverbs['after']
 254
 255   positional_insert:
 256     .local pmc it, newstages
 257     newstages = new 'ResizableStringArray'
 258
 259     it = iter stages
 260   iter_loop:
 261     unless it goto iter_end
 262     .local pmc current
 263     current = shift it
 264     unless current == target goto no_insert_before
 265       unless position == 'before' goto no_insert_before
 266         push newstages, stagename
 267     no_insert_before:
 268
 269     push newstages, current
 270
 271     unless current == target goto no_insert_after
 272       unless position == 'after' goto no_insert_after
 273         push newstages, stagename
 274     no_insert_after:
 275
 276     goto iter_loop
 277   iter_end:
 278     setattribute self, '@stages', newstages
 279     goto done
 280
 281   simple_insert:
 282     push stages, stagename
 283   done:
 284
 285 .end
 286
 287 =item compile(pmc code [, "option" => value, ... ])
 288
 289 Compile C<source> (possibly modified by any provided options)
 290 by iterating through any stages identified for this compiler.
 291 If a C<target> option is provided, then halt the iteration
 292 when the stage corresponding to target has been reached.
 293
 294 =cut
 295
 296 .sub 'compile' :method
 297     .param pmc source
 298     .param pmc adverbs         :slurpy :named
 299
 300     .local pmc compiling, options
 301     compiling = new ['Hash']
 302     .lex '%*COMPILING', compiling
 303     compiling['%?OPTIONS'] = adverbs
 304
 305     .local string target
 306     target = adverbs['target']
 307     target = downcase target
 308
 309     .local int stagestats
 310     stagestats = adverbs['stagestats']
 311
 312     .local pmc stages, result, it
 313     result = source
 314     stages = getattribute self, '@stages'
 315     it = iter stages
 316     if stagestats goto stagestats_loop
 317
 318   iter_loop:
 319     unless it goto have_result
 320     .local string stagename
 321     stagename = shift it
 322     result = self.stagename(result, adverbs :flat :named)
 323     if target == stagename goto have_result
 324     goto iter_loop
 325
 326   stagestats_loop:
 327     unless it goto have_result
 328     stagename = shift it
 329     $N0 = time
 330     result = self.stagename(result, adverbs :flat :named)
 331     $N1 = time
 332     $N2 = $N1 - $N0
 333     $P0 = getinterp
 334     $P1 = $P0.'stdhandle'(.PIO_STDERR_FILENO)
 335     $P1.'print'("Stage '")
 336     $P1.'print'(stagename)
 337     $P1.'print'("': ")
 338     $P2 = new ['ResizablePMCArray']
 339     push $P2, $N2
 340     $S0 = sprintf "%.3f", $P2
 341     $P1.'print'($S0)
 342     $P1.'print'(" sec\n")
 343     if target == stagename goto have_result
 344     goto stagestats_loop
 345
 346   have_result:
 347     .return (result)
 348 .end
 349
 350
 351 =item parse(source [, "option" => value, ...])
 352
 353 Parse C<source> using the compiler's C<parsegrammar> according
 354 to any options and return the resulting parse tree.
 355
 356 =cut
 357
 358 .sub 'parse' :method
 359     .param pmc source
 360     .param pmc adverbs         :slurpy :named
 361     .local pmc parsegrammar, top
 362
 363     .local string tcode
 364     tcode = adverbs['transcode']
 365     unless tcode goto transcode_done
 366     .local pmc tcode_it
 367     $P0 = split ' ', tcode
 368     tcode_it = iter $P0
 369   tcode_loop:
 370     unless tcode_it goto transcode_done
 371     tcode = shift tcode_it
 372     push_eh tcode_enc
 373     $I0 = find_charset tcode
 374     $S0 = source
 375     $S0 = trans_charset $S0, $I0
 376     assign source, $S0
 377     pop_eh
 378     goto transcode_done
 379   tcode_enc:
 380     pop_eh
 381     push_eh tcode_fail
 382     $I0 = find_encoding tcode
 383     $S0 = source
 384     $S0 = trans_encoding $S0, $I0
 385     assign source, $S0
 386     pop_eh
 387     goto transcode_done
 388   tcode_fail:
 389     pop_eh
 390     goto tcode_loop
 391   transcode_done:
 392
 393     .local string target
 394     target = adverbs['target']
 395     target = downcase target
 396
 397     parsegrammar = self.'parsegrammar'()
 398     $I0 = can parsegrammar, 'TOP'
 399     unless $I0 goto parsegrammar_string
 400     top = find_method parsegrammar, 'TOP'
 401     goto have_top
 402   parsegrammar_string:
 403     $S0 = typeof parsegrammar
 404     eq $S0, 'NameSpace', parsegrammar_ns
 405     $P0 = self.'parse_name'(parsegrammar)
 406     $S0 = pop $P0
 407     $P1 = get_hll_global $P0, $S0
 408     $I0 = can $P1, 'TOP'
 409     unless $I0 goto parsegrammar_ns_string
 410     top = find_method $P1, 'TOP'
 411     goto have_top
 412   parsegrammar_ns_string:
 413     $P0 = self.'parse_name'(parsegrammar)
 414     top = get_hll_global $P0, 'TOP'
 415     unless null top goto have_top
 416     goto err_notop
 417   parsegrammar_ns:
 418     top = parsegrammar['TOP']
 419     unless null top goto have_top
 420   err_notop:
 421     self.'panic'('Cannot find TOP regex in ', parsegrammar)
 422   have_top:
 423     .local pmc parseactions, action
 424     null action
 425     if target == 'parse' goto have_action
 426     parseactions = self.'parseactions'()
 427     $I0 = isa parseactions, ['Undef']
 428     if $I0 goto have_action
 429     ##  if parseactions is a protoobject, use it directly
 430     $I0 = isa parseactions, 'P6protoobject'
 431     if $I0 goto action_exact
 432     ##  if parseactions is a Class or array, make action directly from that
 433     $I0 = isa parseactions, 'Class'
 434     if $I0 goto action_make
 435     $I0 = isa parseactions, 'NameSpace'
 436     if $I0 goto action_namespace
 437     $I0 = does parseactions, 'array'
 438     if $I0 goto action_make
 439     ##  if parseactions is not a String, use it directly.
 440     $I0 = isa parseactions, 'String'
 441     if $I0 goto action_string
 442   action_exact:
 443     action = parseactions
 444     goto have_action
 445   action_namespace:
 446     $P0 = get_class parseactions
 447     action = new $P0
 448     goto have_action
 449   action_string:
 450     ##  Try the string itself, if that fails try splitting on '::'
 451     $P0 = get_class parseactions
 452     unless null $P0 goto action_make
 453     $S0 = parseactions
 454     parseactions = split '::', $S0
 455     push_eh err_bad_parseactions
 456     $P0 = get_class parseactions
 457     if null $P0 goto err_bad_parseactions
 458     pop_eh
 459   action_make:
 460     action = new parseactions
 461   have_action:
 462     .local pmc match
 463     match = top(source, 'grammar' => parsegrammar, 'action' => action)
 464     unless match goto err_failedparse
 465     .return (match)
 466
 467   err_no_parsegrammar:
 468     self.'panic'('Missing parsegrammar in compiler')
 469     .return ()
 470   err_failedparse:
 471     self.'panic'('Failed to parse source')
 472     .return ()
 473   err_bad_parseactions:
 474     pop_eh
 475     $P0 = self.'parseactions'()
 476     self.'panic'('Unable to find action grammar ', $P0)
 477     .return ()
 478 .end
 479
 480
 481 =item past(source [, "option" => value, ...])
 482
 483 Transform C<source> into PAST using the compiler's
 484 C<astgrammar> according to any options, and return the
 485 resulting ast.
 486
 487 =cut
 488
 489 .sub 'past' :method
 490     .param pmc source
 491     .param pmc adverbs         :slurpy :named
 492
 493   compile_astgrammar:
 494     .local pmc astgrammar_name
 495     astgrammar_name = self.'astgrammar'()
 496     $S0 = typeof astgrammar_name
 497     eq $S0, 'NameSpace', astgrammar_ns
 498     unless astgrammar_name goto compile_match
 499
 500     .local pmc astgrammar_namelist
 501     .local pmc astgrammar, astbuilder
 502     astgrammar_namelist = self.'parse_name'(astgrammar_name)
 503     unless astgrammar_namelist goto err_past
 504     astgrammar = new astgrammar_namelist
 505     astbuilder = astgrammar.'apply'(source)
 506     .tailcall astbuilder.'get'('past')
 507   astgrammar_ns:
 508     $P0 = get_class astgrammar_name
 509     astgrammar = new $P0
 510     astbuilder = astgrammar.'apply'(source)
 511     .tailcall astbuilder.'get'('past')
 512
 513   compile_match:
 514     #push_eh err_past
 515     .local pmc ast
 516     ast = source.'ast'()
 517     #pop_eh
 518     $I0 = isa ast, ['PAST';'Node']
 519     unless $I0 goto err_past
 520     .return (ast)
 521
 522   err_past:
 523     #pop_eh
 524     $S0 = typeof source
 525     .tailcall self.'panic'('Unable to obtain PAST from ', $S0)
 526 .end
 527
 528
 529 =item post(source [, adverbs :slurpy :named])
 530
 531 Transform PAST C<source> into POST.
 532
 533 =cut
 534
 535 .sub 'post' :method
 536     .param pmc source
 537     .param pmc adverbs         :slurpy :named
 538     $P0 = compreg 'PAST'
 539     .tailcall $P0.'to_post'(source, adverbs :flat :named)
 540 .end
 541
 542
 543 .sub 'pir' :method
 544     .param pmc source
 545     .param pmc adverbs         :slurpy :named
 546
 547     $P0 = compreg 'POST'
 548     .tailcall $P0.'to_pir'(source, adverbs :flat :named)
 549 .end
 550
 551
 552 .sub 'evalpmc' :method
 553     .param pmc source
 554     .param pmc adverbs         :slurpy :named
 555
 556     $P0 = compreg 'PIR'
 557     $P1 = $P0(source)
 558     .return ($P1)
 559 .end
 560
 561
 562
 563 =item eval(code [, "option" => value, ...])
 564
 565 Compile and execute the given C<code> taking into account any
 566 options provided.
 567
 568 =cut
 569
 570 .sub 'eval' :method
 571     .param pmc code
 572     .param pmc args            :slurpy
 573     .param pmc adverbs         :slurpy :named
 574
 575     unless null args goto have_args
 576     args = new 'ResizablePMCArray'
 577   have_args:
 578     unless null adverbs goto have_adverbs
 579     adverbs = new 'Hash'
 580   have_adverbs:
 581
 582     $P0 = self.'compile'(code, adverbs :flat :named)
 583     $I0 = isa $P0, 'String'
 584     if $I0 goto end
 585     .local string target
 586     target = adverbs['target']
 587     if target != '' goto end
 588     .local pmc outer_ctx, outer
 589     outer_ctx = adverbs['outer_ctx']
 590     if null outer_ctx goto outer_done
 591     outer = outer_ctx['current_sub']
 592     $P1 = $P0[0]
 593     $P1.'set_outer'(outer)
 594   outer_done:
 595     $I0 = adverbs['trace']
 596     trace $I0
 597     $P0 = $P0(args :flat)
 598     trace 0
 599   end:
 600     .return ($P0)
 601 .end
 602
 603
 604 =item interactive(["encoding" => encoding] [, "option" => value, ...])
 605
 606 Runs an interactive compilation session -- reads lines of input
 607 from the standard input and evaluates each.  The C<encoding> option
 608 specifies the encoding to use for the input (e.g., "utf8").
 609
 610 =cut
 611
 612 .sub 'interactive' :method
 613     .param pmc adverbs         :slurpy :named
 614     .local string target, encoding
 615     target = adverbs['target']
 616     target = downcase target
 617
 618     # on startup show the welcome message
 619     $P0 = self.'commandline_banner'()
 620     $P1 = getinterp
 621     $P2 = $P1.'stdhandle'(.PIO_STDERR_FILENO)
 622     $P2.'print'($P0)
 623
 624     .local pmc stdin
 625     .local int has_readline
 626     $P0 = getinterp
 627     stdin = $P0.'stdhandle'(.PIO_STDIN_FILENO)
 628     encoding = adverbs['encoding']
 629     if encoding == 'fixed_8' goto interactive_loop
 630     unless encoding goto interactive_loop
 631     stdin.'encoding'(encoding)
 632   interactive_loop:
 633     .local pmc code
 634     unless stdin goto interactive_end
 635
 636     .local string prompt
 637     prompt = '> '
 638     $P0 = self.'commandline_prompt'()
 639     $I0 = defined $P0
 640     unless $I0 goto have_prompt
 641     prompt = $P0
 642   have_prompt:
 643
 644     ##  display a prompt ourselves if readline isn't present
 645   interactive_read:
 646     code = stdin.'readline_interactive'(prompt)
 647     if null code goto interactive_end
 648     unless code goto interactive_loop
 649     concat code, "\n"
 650     push_eh interactive_trap
 651     $P0 = self.'eval'(code, adverbs :flat :named)
 652     pop_eh
 653     if null $P0 goto interactive_loop
 654     unless target goto interactive_loop
 655     if target == 'pir' goto target_pir
 656     self.'dumper'($P0, target, adverbs :flat :named)
 657     goto interactive_loop
 658   target_pir:
 659     say $P0
 660     goto interactive_loop
 661   interactive_trap:
 662     get_results '0', $P0
 663     pop_eh
 664     $S0 = $P0
 665     if $S0 == '' goto have_newline
 666     $S1 = substr $S0, -1, 1
 667     $I0 = is_cclass .CCLASS_NEWLINE, $S1, 0
 668     if $I0 goto have_newline
 669     $S0 = concat $S0, "\n"
 670   have_newline:
 671     print $S0
 672     goto interactive_loop
 673   interactive_end:
 674     .return ()
 675 .end
 676
 677
 678 =item EXPORTALL(source, destination)
 679
 680 Export all namespace entries from the default export namespace for source
 681 (source::EXPORT::ALL) to the destination namespace.
 682
 683 =cut
 684
 685 .sub 'EXPORTALL' :method
 686     .param pmc source
 687     .param pmc dest
 688     .local pmc ns_iter, item, export_list
 689
 690     source = source['EXPORT']
 691     unless source, no_namespace_error
 692     source = source['ALL']
 693     unless source, no_namespace_error
 694
 695     ns_iter = iter source
 696     export_list = new 'ResizablePMCArray'
 697   export_loop:
 698     unless ns_iter, export_loop_end
 699     item = shift ns_iter
 700     push export_list, item
 701     goto export_loop
 702   export_loop_end:
 703
 704     source.'export_to'(dest,export_list)
 705     .return ()
 706
 707   no_namespace_error:
 708     $P0 = new 'Exception'
 709     $P0 = 'Missing EXPORT::ALL NameSpace'
 710     throw $P0
 711     .return ()
 712 .end
 713
 714 =item evalfiles(files [, args] [, "encoding" => encoding] [, "option" => value, ...])
 715
 716 Compile and evaluate a file or files.  The C<files> argument may
 717 be either a single filename or an array of files to be processed
 718 as a single compilation unit.  The C<encoding> option specifies
 719 the encoding to use when reading the files, and any remaining
 720 options are passed to the evaluator.
 721
 722 =cut
 723
 724 .sub 'evalfiles' :method
 725     .param pmc files
 726     .param pmc args            :slurpy
 727     .param pmc adverbs         :slurpy :named
 728
 729     unless null adverbs goto have_adverbs
 730     adverbs = new 'Hash'
 731   have_adverbs:
 732     .local string target
 733     target = adverbs['target']
 734     target = downcase target
 735     .local string encoding
 736     encoding = adverbs['encoding']
 737     $I0 = does files, 'array'
 738     if $I0 goto have_files_array
 739     $P0 = new 'ResizablePMCArray'
 740     push $P0, files
 741     files = $P0
 742   have_files_array:
 743     .local string code
 744     code = ''
 745     .local pmc it
 746     it = iter files
 747   iter_loop:
 748     unless it goto iter_end
 749     .local string iname
 750     .local pmc ifh
 751     iname = shift it
 752     ifh = new 'FileHandle'
 753     unless encoding == 'utf8' goto iter_loop_1
 754     ifh.'encoding'(encoding)
 755   iter_loop_1:
 756     $S0 = ifh.'readall'(iname)
 757     code .= $S0
 758     ifh.'close'()
 759     goto iter_loop
 760   iter_end:
 761     $S0 = join ' ', files
 762     $P1 = box $S0
 763     .lex '$?FILES', $P1
 764     $P0 = self.'eval'(code, args :flat, adverbs :flat :named)
 765     if target == '' goto end
 766     if target == 'pir' goto end
 767     self.'dumper'($P0, target, adverbs :flat :named)
 768   end:
 769     .return ($P0)
 770
 771   err_infile:
 772     .tailcall self.'panic'('Error: file cannot be read: ', iname)
 773 .end
 774
 775
 776 =item process_args(PMC args)
 777
 778 Performs option processing of command-line args
 779
 780 =cut
 781
 782 .sub 'process_args' :method
 783     .param pmc args
 784
 785     load_bytecode 'Getopt/Obj.pbc'
 786
 787     .local string arg0
 788     arg0 = shift args
 789     .local pmc getopts
 790     getopts = new ['Getopt';'Obj']
 791     getopts.'notOptStop'(1)
 792     $P0 = getattribute self, '@cmdoptions'
 793     .local pmc it
 794     it = iter $P0
 795   getopts_loop:
 796     unless it goto getopts_end
 797     $S0 = shift it
 798     push getopts, $S0
 799     goto getopts_loop
 800   getopts_end:
 801     .tailcall getopts.'get_options'(args)
 802 .end
 803
 804
 805 =item command_line(PMC args)
 806
 807 Generic method for compilers invoked from a shell command line.
 808
 809 =cut
 810
 811 .include 'except_severity.pasm'
 812 .sub 'command_line' :method
 813     .param pmc args
 814     .param pmc adverbs         :slurpy :named
 815
 816     ## this bizarre piece of code causes the compiler to
 817     ## immediately abort if it looks like it's being run
 818     ## from Perl's Test::Harness.  (Test::Harness versions 2.64
 819     ## and earlier have a hardwired commandline option that is
 820     ## always passed to an initial run of the interpreter binary,
 821     ## whether you want it or not.)  We expect to remove this
 822     ## check eventually (or make it a lot smarter than it is here).
 823     $S0 = args[2]
 824     $I0 = index $S0, '@INC'
 825     if $I0 < 0 goto not_harness
 826     exit 0
 827   not_harness:
 828
 829     load_bytecode 'dumper.pbc'
 830     load_bytecode 'PGE/Dumper.pbc'
 831
 832     ##  get the name of the program
 833     .local string arg0
 834     arg0 = args[0]
 835
 836     ##   perform option processing of command-line args
 837     .local pmc opts
 838     opts = self.'process_args'(args)
 839
 840     ##   merge command-line args with defaults passed in from caller
 841     .local pmc it
 842     it = iter opts
 843   mergeopts_loop:
 844     unless it goto mergeopts_end
 845     $S0 = shift it
 846     $P0 = opts[$S0]
 847     adverbs[$S0] = $P0
 848     goto mergeopts_loop
 849   mergeopts_end:
 850
 851     $I0 = adverbs['help']
 852     if $I0 goto usage
 853
 854     $I0 = adverbs['version']
 855     if $I0 goto version
 856
 857     .local int can_backtrace
 858     can_backtrace = can self, 'backtrace'
 859     unless can_backtrace goto no_push_eh
 860     push_eh uncaught_exception
 861   no_push_eh:
 862
 863     $S0 = adverbs['e']
 864     $I0 = exists adverbs['e']
 865     if $I0 goto eval_line
 866     .local pmc result
 867     result = box ''
 868     unless args goto interactive
 869     $I0 = adverbs['combine']
 870     if $I0 goto combine
 871     $S0 = args[0]
 872     result = self.'evalfiles'($S0, args :flat, adverbs :flat :named)
 873     goto save_output
 874   combine:
 875     result = self.'evalfiles'(args, adverbs :flat :named)
 876     goto save_output
 877   interactive:
 878     self.'interactive'(args :flat, adverbs :flat :named)
 879     goto save_output
 880   eval_line:
 881     result = self.'eval'($S0, '-e', args :flat, adverbs :flat :named)
 882
 883   save_output:
 884     unless can_backtrace goto no_pop_eh
 885     pop_eh
 886   no_pop_eh:
 887     if null result goto end
 888     $I0 = defined result
 889     unless $I0 goto end
 890     .local string target
 891     target = adverbs['target']
 892     target = downcase target
 893     if target != 'pir' goto end
 894     .local string output
 895     .local pmc ofh
 896     $P0 = getinterp
 897     ofh = $P0.'stdhandle'(.PIO_STDOUT_FILENO)
 898     output = adverbs['output']
 899     if output == '' goto save_output_1
 900     if output == '-' goto save_output_1
 901     ofh = new ['FileHandle']
 902     ofh.'open'(output, 'w')
 903     unless ofh goto err_output
 904   save_output_1:
 905     print ofh, result
 906     ofh.'close'()
 907   end:
 908     .return ()
 909
 910   err_output:
 911     .tailcall self.'panic'('Error: file cannot be written: ', output)
 912   usage:
 913     self.'usage'(arg0)
 914     goto end
 915   version:
 916     self.'version'()
 917     goto end
 918
 919     # If we get an uncaught exception in the program and the HLL provides
 920     # a backtrace method, we end up here. We pass it the exception object
 921     # so it can render a backtrace, unless the severity is exit or warning
 922     # in which case it needs special handling.
 923   uncaught_exception:
 924     .get_results ($P0)
 925     pop_eh
 926     $P1 = getinterp
 927     $P1 = $P1.'stdhandle'(.PIO_STDERR_FILENO)
 928     $I0 = $P0['severity']
 929     if $I0 == .EXCEPT_EXIT goto do_exit
 930     $S0 = self.'backtrace'($P0)
 931     print $P1, $S0
 932     if $I0 <= .EXCEPT_WARNING goto do_warning
 933     exit 1
 934   do_exit:
 935     $I0 = $P0['exit_code']
 936     exit $I0
 937   do_warning:
 938     $P0 = $P0["resume"]
 939     push_eh uncaught_exception # Otherwise we get errors about no handler to delete
 940     $P0()
 941 .end
 942
 943
 944 =item parse_name(string name)
 945
 946 Split C<name> into its component namespace parts, as
 947 required by pdd21.  The default is simply to split the name
 948 based on double-colon separators.
 949
 950 =cut
 951
 952 .sub 'parse_name' :method
 953     .param string name
 954     $P0 = split '::', name
 955     .return ($P0)
 956 .end
 957
 958 =item lineof(target, pos [, cache :named('cache')])
 959
 960 Return the line number of offset C<pos> within C<target>.  The return
 961 value uses zero for the first line.  If C<cache> is true, then
 962 memoize the line offsets as a C<!lineof> property on C<target>.
 963
 964 =cut
 965
 966 .sub 'lineof' :method
 967     .param pmc target
 968     .param int pos
 969     .param int cache           :optional :named('cache')
 970     .local pmc linepos
 971
 972     # If we've previously cached C<linepos> for target, we use it.
 973     unless cache goto linepos_build
 974     linepos = getprop '!linepos', target
 975     unless null linepos goto linepos_done
 976
 977     # calculate a new linepos array.
 978   linepos_build:
 979     linepos = new ['ResizableIntegerArray']
 980     unless cache goto linepos_build_1
 981     setprop target, '!linepos', linepos
 982   linepos_build_1:
 983     .local string s
 984     .local int jpos, eos
 985     s = target
 986     eos = length s
 987     jpos = 0
 988     # Search for all of the newline markers in C<target>.  When we
 989     # find one, mark the ending offset of the line in C<linepos>.
 990   linepos_loop:
 991     jpos = find_cclass .CCLASS_NEWLINE, s, jpos, eos
 992     unless jpos < eos goto linepos_done
 993     $I0 = ord s, jpos
 994     inc jpos
 995     push linepos, jpos
 996     # Treat \r\n as a single logical newline.
 997     if $I0 != 13 goto linepos_loop
 998     $I0 = ord s, jpos
 999     if $I0 != 10 goto linepos_loop
1000     inc jpos
1001     goto linepos_loop
1002   linepos_done:
1003
1004     # We have C<linepos>, so now we search the array for the largest
1005     # element that is not greater than C<pos>.  The index of that
1006     # element is the line number to be returned.
1007     # (Potential optimization: use a binary search.)
1008     .local int line, count
1009     count = elements linepos
1010     line = 0
1011   line_loop:
1012     if line >= count goto line_done
1013     $I0 = linepos[line]
1014     if $I0 > pos goto line_done
1015     inc line
1016     goto line_loop
1017   line_done:
1018     .return (line)
1019 .end
1020
1021
1022 =item dumper(obj, name, options)
1023
1024 Dump C<obj> with C<name> according to C<options>.
1025
1026 =cut
1027
1028 .sub 'dumper' :method
1029     .param pmc obj
1030     .param string name
1031     .param pmc options         :slurpy :named
1032
1033     $S0 = options['dumper']
1034     if $S0 goto load_dumper
1035     .tailcall '_dumper'(obj, name)
1036
1037   load_dumper:
1038     load_bytecode 'PCT/Dumper.pbc'
1039     $S0 = downcase $S0
1040     $P0 = get_hll_global ['PCT';'Dumper'], $S0
1041     .tailcall $P0(obj, name)
1042 .end
1043
1044
1045 =item usage()
1046
1047 A usage method.
1048
1049 =cut
1050
1051 .sub 'usage' :method
1052     .param string name     :optional
1053     .param int    has_name :opt_flag
1054
1055     unless has_name goto no_name
1056     say name
1057   no_name:
1058     $P0 = getattribute self, '$usage'
1059     say $P0
1060     exit 0
1061 .end
1062
1063
1064 =item version()
1065
1066 Display compiler version information.
1067
1068 =cut
1069
1070 .sub 'version' :method
1071     $P0 = getattribute self, '$version'
1072     say $P0
1073     exit 0
1074 .end
1075
1076
1077 =back
1078
1079 =head1 AUTHOR
1080
1081 Patrick R. Michaud <pmichaud@pobox.com>
1082
1083 =cut
1084
1085
1086 # Local Variables:
1087 #   mode: pir
1088 #   fill-column: 100
1089 # End:
1090 # vim: expandtab shiftwidth=4 ft=pir: