tools/dev/create_language.pl

   1 #! perl
   2 # Copyright (C) 2007-2009, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 create_language.pl -- create initial files for a new language
   8
   9 =head1 SYNOPSIS
  10
  11 % perl tools/dev/create_language.pl Xyz [path]
  12
  13 =head1 DESCRIPTION
  14
  15 This script populates a directory with files for building a
  16 new language translator in Parrot.  The first argument is the
  17 name of the language to be built.  The C<path> argument
  18 says where to populate the directory, if not given then the
  19 lowercase version of the language name is used.
  20
  21 For a language 'Xyz', this script will create the following
  22 files and directories in C<path>:
  23
  24     README
  25     Configure.pl
  26     xyz.pir
  27     build/Makefile.in
  28     build/gen_builtins_pir.pl
  29     build/gen_parrot.pl
  30     src/pct/grammar.pg
  31     src/pct/grammar-oper.pg
  32     src/pct/actions.pm
  33     src/builtins/say.pir
  34     t/harness
  35     t/00-sanity.t
  36
  37 Any files that already exist are skipped, so this script can
  38 be used to repopulate a language directory with omitted files.
  39
  40 If all goes well, after creating the language shell one can simply
  41 change to the language directory and type
  42
  43     $ make test
  44
  45 to verify that the new language compiles and configures properly.
  46
  47 =cut
  48
  49 use strict;
  50 use warnings;
  51 use lib 'lib';
  52 use File::Path;
  53 use File::Spec;
  54
  55 unless (@ARGV) {
  56     die "usage: $0 language [path]\n";
  57 }
  58
  59 ##  determine the language we're trying to build
  60 my $lang = $ARGV[0];
  61 my $lclang = lc $lang;
  62 my $uclang = uc $lang;
  63
  64 ## the name and revision of the script, for use in the generated README
  65 my $script = $0;
  66 my $rev = '$Revision$';
  67 $rev =~ s/^\D*(\d+)\D*$/r$1/;
  68
  69 ##  get the path from the command line, or if not supplied then
  70 ##  use languages/$lclang.
  71 my $path = $ARGV[1] || $lclang;
  72
  73 ##  now loop through the file information (see below), substituting
  74 ##  any instances of @lang@, @lclang@, @UCLANG@, and @Id@ with
  75 ##  the language name or the svn id tag.  If the line has the form
  76 ##  __filepath__, then start a new file.
  77 my $fh;
  78 while (<DATA>) {
  79     last if /^__DATA__$/;
  80     s{\@lang\@}   {$lang}g;
  81     s{\@lclang\@} {$lclang}ig;
  82     s{\@UCLANG\@} {$uclang}ig;
  83     s{\@Id\@}     {\$Id\$}ig;
  84     s{\@script\@} {$script}ig;
  85     s{\@rev\@}    {$rev}ig;
  86     if (/^__(.*)__$/) { start_new_file("$path/$1"); }
  87     elsif ($fh) { print $fh $_; }
  88 }
  89 ##  close the last file
  90 close($fh) if $fh;
  91
  92 print <<"END";
  93
  94 Your new language has been created in the $path directory.
  95 To do an initial build and test of the language:
  96
  97     cd $path
  98     perl Configure.pl
  99     make
 100     make test
 101
 102 END
 103
 104 ##  we're done
 105 1;
 106
 107
 108 ##  this function closes any previous opened file, and determines
 109 ##  if we're creating a new file.  It also calls C<mkpath> to
 110 ##  create any needed parent subdirectories.
 111 sub start_new_file {
 112     my ($filepath) = @_;
 113     if ($fh) { close $fh; undef $fh; }
 114     if (-e $filepath) { print "skipping $filepath\n"; return; }
 115     my ($volume, $dir, $base) = File::Spec->splitpath($filepath);
 116     my $filedir = File::Spec->catpath($volume, $dir);
 117     unless (-d $filedir) {
 118         print "creating $filedir\n";
 119         mkpath( [ $filedir ], 0, 0777 );
 120     }
 121     print "creating $filepath\n";
 122     open $fh, '>', $filepath;
 123 }
 124
 125
 126
 127 ###  The section below contains the text of the files to be created.
 128 ###  The name of the file to be created is given as C<__filepath__>,
 129 ###  and all subsequent lines up to the next C<__filepath__> are
 130 ###  placed in the file (performing substitutions on @lang@, @lclang@,
 131 ###  @UCLANG@, and @Id@ as appropriate).
 132
 133 __DATA__
 134 __README__
 135 Language '@lang@' was created with @script@, @rev@.
 136
 137 __Configure.pl__
 138 #! perl
 139 use 5.008;
 140 use strict;
 141 use warnings;
 142 use Getopt::Long;
 143
 144 MAIN: {
 145     my %options;
 146     GetOptions(\%options, 'help!', 'parrot-config=s',
 147                'gen-parrot!', 'gen-parrot-option=s@');
 148
 149     # Print help if it's requested
 150     if ($options{'help'}) {
 151         print_help();
 152         exit(0);
 153     }
 154
 155     # Update/generate parrot build if needed
 156     if ($options{'gen-parrot'}) {
 157         my @opts    = @{ $options{'gen-parrot-option'} || [] };
 158         my @command = ($^X, "build/gen_parrot.pl", @opts);
 159
 160         print "Generating Parrot ...\n";
 161         print "@command\n\n";
 162         system @command;
 163     }
 164
 165     # Get a list of parrot-configs to invoke.
 166     my @parrot_config_exe = qw(
 167         parrot/parrot_config
 168         ../../parrot_config
 169         parrot_config
 170     );
 171
 172     if ($options{'parrot-config'} && $options{'parrot-config'} ne '1') {
 173         @parrot_config_exe = ($options{'parrot-config'});
 174     }
 175
 176     #  Get configuration information from parrot_config
 177     my %config = read_parrot_config(@parrot_config_exe);
 178     unless (%config) {
 179         die <<'END';
 180 Unable to locate parrot_config.
 181 To automatically checkout (svn) and build a copy of parrot,
 182 try re-running Configure.pl with the '--gen-parrot' option.
 183 Or, use the '--parrot-config' option to explicitly specify
 184 the location of parrot_config.
 185 END
 186     }
 187
 188 #  Create the Makefile using the information we just got
 189     create_makefile(%config);
 190
 191     my $make = $config{'make'};
 192     print <<"END";
 193
 194 You can now use '$make' to build @lang@.
 195 After that, you can use '$make test' to run some local tests.
 196
 197 END
 198     exit 0;
 199
 200 }
 201
 202
 203 sub read_parrot_config {
 204     my @parrot_config_exe = @_;
 205     my %config = ();
 206     for my $exe (@parrot_config_exe) {
 207         no warnings;
 208         if (open my $PARROT_CONFIG, '-|', "$exe --dump") {
 209             print "\nReading configuration information from $exe ...\n";
 210             while (<$PARROT_CONFIG>) {
 211                 if (/(\w+) => '(.*)'/) { $config{$1} = $2 }
 212             }
 213             close $PARROT_CONFIG;
 214             last if %config;
 215         }
 216     }
 217     return %config;
 218 }
 219
 220
 221 #  Generate a Makefile from a configuration
 222 sub create_makefile {
 223     my %config = @_;
 224
 225     my $maketext = slurp( 'build/Makefile.in' );
 226
 227     $config{'win32_libparrot_copy'} = $^O eq 'MSWin32' ? 'copy $(BUILD_DIR)\libparrot.dll .' : '';
 228     $maketext =~ s/@(\w+)@/$config{$1}/g;
 229     if ($^O eq 'MSWin32') {
 230         # use backslashes.
 231         $maketext =~ s{/}{\\}g;
 232         # wildcards (for clean rules) need an additional backslash, see Rakudo RT #65006
 233         $maketext =~ s{\\\*}{\\\\*}g;
 234         # use forward slashes again for HTTP URLs
 235         $maketext =~ s{http:\S+}{ do {my $t = $&; $t =~ s'\\'/'g; $t} }eg;
 236     }
 237
 238     my $outfile = 'Makefile';
 239     print "\nCreating $outfile ...\n";
 240     open(my $MAKEOUT, '>', $outfile) ||
 241         die "Unable to write $outfile\n";
 242     print {$MAKEOUT} $maketext;
 243     close $MAKEOUT or die $!;
 244
 245     return;
 246 }
 247
 248 sub slurp {
 249     my $filename = shift;
 250
 251     open my $fh, '<', $filename or die "Unable to read $filename\n";
 252     local $/ = undef;
 253     my $maketext = <$fh>;
 254     close $fh or die $!;
 255
 256     return $maketext;
 257 }
 258
 259
 260 #  Print some help text.
 261 sub print_help {
 262     print <<'END';
 263 Configure.pl - @lang@ Configure
 264
 265 General Options:
 266     --help             Show this text
 267     --parrot-config=(config)
 268                        Use configuration information from config
 269     --gen-parrot       Download and build a copy of Parrot to use
 270     --gen-parrot-option='--option=value'
 271                        Set parrot config option when using --gen-parrot
 272 END
 273
 274     return;
 275 }
 276
 277 # Local Variables:
 278 #   mode: cperl
 279 #   cperl-indent-level: 4
 280 #   fill-column: 100
 281 # End:
 282 # vim: expandtab shiftwidth=4:
 283
 284 __build/PARROT_REVISION__
 285 @rev@
 286 __build/Makefile.in__
 287 # $Id$
 288
 289 # arguments we want to run parrot with
 290 PARROT_ARGS =
 291
 292 # values from parrot_config
 293 BUILD_DIR     = @build_dir@
 294 LOAD_EXT      = @load_ext@
 295 O             = @o@
 296 EXE           = @exe@
 297 MAKE          = @make_c@
 298 PERL          = @perl@
 299 RM_F          = @rm_f@
 300 HAS_ICU       = @has_icu@
 301
 302 # Various paths
 303 PARROT_DYNEXT = $(BUILD_DIR)/runtime/parrot/dynext
 304 PERL6GRAMMAR  = $(BUILD_DIR)/runtime/parrot/library/PGE/Perl6Grammar.pbc
 305 NQP           = $(BUILD_DIR)/compilers/nqp/nqp.pbc
 306 PCT           = $(BUILD_DIR)/runtime/parrot/library/PCT.pbc
 307 PMC_DIR       = src/pmc
 308 OPSDIR        = src/ops
 309 OPSLIB        = @lclang@
 310 OPS_FILE      = src/ops/@lclang@.ops
 311
 312 # Setup some commands
 313 PARROT        = $(BUILD_DIR)/parrot$(EXE)
 314 CAT           = $(PERL) -MExtUtils::Command -e cat
 315 BUILD_DYNPMC  = $(PERL) $(BUILD_DIR)/tools/build/dynpmc.pl
 316 BUILD_DYNOPS  = $(PERL) $(BUILD_DIR)/tools/build/dynoplibs.pl
 317 PBC_TO_EXE    = $(BUILD_DIR)/pbc_to_exe$(EXE)
 318
 319 SOURCES = @lclang@.pir \
 320   src/gen_grammar.pir \
 321   src/gen_actions.pir \
 322   src/gen_builtins.pir \
 323   $(@uclang@_GROUP)
 324
 325 BUILTINS_PIR = \
 326   src/builtins/say.pir \
 327
 328 # PMCS        = @lclang@
 329 # PMC_SOURCES = $(PMC_DIR)/@lclang@.pmc
 330 # @uclang@_GROUP  = $(PMC_DIR)/@lclang@_group$(LOAD_EXT)
 331
 332 CLEANUPS = \
 333   @lclang@.pbc \
 334   @lclang@.c \
 335   *.manifest \
 336   *.pdb \
 337   @lclang@$(O) \
 338   @lclang@$(EXE) \
 339   src/gen_*.pir \
 340   src/gen_*.pm \
 341   $(PMC_DIR)/*.h \
 342   $(PMC_DIR)/*.c \
 343   $(PMC_DIR)/*.dump \
 344   $(PMC_DIR)/*$(O) \
 345   $(PMC_DIR)/*$(LOAD_EXT) \
 346   $(PMC_DIR)/*.exp \
 347   $(PMC_DIR)/*.ilk \
 348   $(PMC_DIR)/*.manifest \
 349   $(PMC_DIR)/*.pdb \
 350   $(PMC_DIR)/*.lib \
 351   $(PMC_DIR)/objectref.pmc \
 352   $(OPSDIR)/*.h \
 353   $(OPSDIR)/*.c \
 354   $(OPSDIR)/*$(O) \
 355   $(OPSDIR)/*$(LOAD_EXT) \
 356
 357 HARNESS = $(PERL) t/harness --keep-exit-code --icu=$(HAS_ICU)
 358 HARNESS_JOBS = $(HARNESS) --jobs
 359
 360 # the default target
 361 all: @lclang@$(EXE)
 362
 363 installable: installable_@lclang@$(EXE)
 364
 365 ##  targets for building a standalone executable
 366 @lclang@$(EXE): @lclang@.pbc
 367         $(PBC_TO_EXE) @lclang@.pbc
 368         @win32_libparrot_copy@
 369
 370 installable_@lclang@$(EXE): @lclang@.pbc
 371         $(PBC_TO_EXE) @lclang@.pbc --install
 372
 373 # the compiler .pbc
 374 @lclang@.pbc: Makefile $(PARROT) $(SOURCES) $(BUILTINS_PIR)
 375         $(PARROT) $(PARROT_ARGS) -o @lclang@.pbc @lclang@.pir
 376
 377 src/gen_grammar.pir: $(PARROT) $(PERL6GRAMMAR) src/pct/grammar.pg src/pct/grammar-oper.pg
 378         $(PARROT) $(PARROT_ARGS) $(PERL6GRAMMAR) \
 379             --output=src/gen_grammar.pir \
 380             src/pct/grammar.pg src/pct/grammar-oper.pg
 381
 382 src/gen_actions.pir: $(PARROT) $(NQP) $(PCT) src/pct/actions.pm
 383         $(PARROT) $(PARROT_ARGS) $(NQP) --output=src/gen_actions.pir \
 384             --encoding=fixed_8 --target=pir src/pct/actions.pm
 385
 386 src/gen_builtins.pir: Makefile build/gen_builtins_pir.pl
 387         $(PERL) build/gen_builtins_pir.pl $(BUILTINS_PIR) > src/gen_builtins.pir
 388
 389 $(@uclang@_GROUP): Makefile $(PARROT) $(PMC_SOURCES)
 390         cd $(PMC_DIR) && $(BUILD_DYNPMC) generate $(PMCS)
 391         cd $(PMC_DIR) && $(BUILD_DYNPMC) compile $(PMCS)
 392         cd $(PMC_DIR) && $(BUILD_DYNPMC) linklibs $(PMCS)
 393         cd $(PMC_DIR) && $(BUILD_DYNPMC) copy --destination=$(PARROT_DYNEXT) $(PMCS)
 394
 395 src/ops/@lclang@_ops$(LOAD_EXT) : $(PARROT) $(OPS_FILE)
 396         @cd $(OPSDIR) && $(BUILD_DYNOPS) generate $(OPSLIB)
 397         @cd $(OPSDIR) && $(BUILD_DYNOPS) compile $(OPSLIB)
 398         @cd $(OPSDIR) && $(BUILD_DYNOPS) linklibs $(OPSLIB)
 399         @cd $(OPSDIR) && $(BUILD_DYNOPS) copy "--destination=$(PARROT_DYNEXT)" $(OPSLIB)
 400
 401 ##  local copy of Parrot
 402 parrot: parrot/parrot_config build/PARROT_REVISION
 403         $(PERL) build/gen_parrot.pl
 404
 405 parrot/parrot_config:
 406         @echo "Don't see parrot/parrot_config."
 407
 408 test: @lclang@$(EXE)
 409         $(PERL) t/harness t/
 410
 411 # Run a single test
 412 t/*.t t/*/*.t t/*/*/*.t: all Test.pir
 413         @$(HARNESS_WITH_FUDGE) --verbosity=1 $@
 414
 415 ##  cleaning
 416 clean:
 417         $(RM_F) $(CLEANUPS)
 418
 419 distclean: realclean
 420
 421 realclean: clean
 422         $(RM_F) src/utils/Makefile Makefile
 423
 424 testclean:
 425
 426
 427 ##  miscellaneous targets
 428 # a listing of all targets meant to be called by users
 429 help:
 430         @echo ""
 431         @echo "Following targets are available for the user:"
 432         @echo ""
 433         @echo "  all:               @lclang@.exe"
 434         @echo "                     This is the default."
 435         @echo ""
 436         @echo "Testing:"
 437         @echo "  test:              Run Rakudo's sanity tests."
 438         @echo ""
 439         @echo "Cleaning:"
 440         @echo "  clean:             Basic cleaning up."
 441         @echo "  distclean:         Removes also anything built, in theory."
 442         @echo "  realclean:         Removes also files generated by 'Configure.pl'."
 443         @echo "  testclean:         Clean up test results."
 444         @echo ""
 445         @echo "Misc:"
 446         @echo "  help:              Print this help message."
 447         @echo ""
 448
 449 Makefile: build/Makefile.in
 450         @echo ""
 451         @echo "warning: Makefile is out of date... re-run Configure.pl"
 452         @echo ""
 453
 454 manifest:
 455         echo MANIFEST >MANIFEST
 456         git ls-files | $(PERL) -ne '/^\./ || print' >>MANIFEST
 457
 458 release: manifest
 459         [ -n "$(VERSION)" ] || ( echo "\nTry 'make release VERSION=yyyymm'\n\n"; exit 1 )
 460         [ -d @lclang@-$(VERSION) ] || ln -s . @lclang@-$(VERSION)
 461         $(PERL) -ne 'print "@lclang@-$(VERSION)/$$_"' MANIFEST | \
 462             tar -zcv -T - -f @lclang@-$(VERSION).tar.gz
 463         rm @lclang@-$(VERSION)
 464
 465 __build/gen_builtins_pir.pl__
 466 #!/usr/bin/perl
 467 # $Id$
 468
 469 use strict;
 470 use warnings;
 471
 472 my @files = @ARGV;
 473
 474 print <<"END_PRELUDE";
 475 # This file automatically generated by $0.
 476
 477 END_PRELUDE
 478
 479 foreach my $file (@files) {
 480     print ".include '$file'\n";
 481 }
 482
 483
 484 __build/gen_parrot.pl__
 485 #! perl
 486
 487 =head1 TITLE
 488
 489 gen_parrot.pl - script to obtain and build Parrot
 490
 491 =head2 SYNOPSIS
 492
 493     perl gen_parrot.pl [--parrot --configure=options]
 494
 495 =head2 DESCRIPTION
 496
 497 Maintains an appropriate copy of Parrot in the parrot/ subdirectory.
 498 The revision of Parrot to be used in the build is given by the
 499 build/PARROT_REVISION file.
 500
 501 =cut
 502
 503 use strict;
 504 use warnings;
 505 use 5.008;
 506
 507 #  Work out slash character to use.
 508 my $slash = $^O eq 'MSWin32' ? '\\' : '/';
 509
 510 ##  determine what revision of Parrot we require
 511 open my $REQ, "build/PARROT_REVISION"
 512   || die "cannot open build/PARROT_REVISION\n";
 513 my $required = 0+<$REQ>;
 514 close $REQ;
 515
 516 {
 517     no warnings;
 518     if (open my $REV, '-|', "parrot${slash}parrot_config revision") {
 519         my $revision = 0+<$REV>;
 520         close $REV;
 521         if ($revision >= $required) {
 522             print "Parrot r$revision already available (r$required required)\n";
 523             exit(0);
 524         }
 525     }
 526 }
 527
 528 print "Checking out Parrot r$required via svn...\n";
 529 system(qw(svn checkout -r),  $required , qw(https://svn.parrot.org/parrot/trunk parrot));
 530
 531 chdir('parrot');
 532
 533
 534 ##  If we have a Makefile from a previous build, do a 'make realclean'
 535 if (-f 'Makefile') {
 536     my %config = read_parrot_config();
 537     my $make = $config{'make'};
 538     if ($make) {
 539         print "\nPerforming '$make realclean' ...\n";
 540         system($make, "realclean");
 541     }
 542 }
 543
 544 print "\nConfiguring Parrot ...\n";
 545 my @config_command = ($^X, 'Configure.pl', @ARGV);
 546 print "@config_command\n";
 547 system @config_command;
 548
 549 print "\nBuilding Parrot ...\n";
 550 my %config = read_parrot_config();
 551 my $make = $config{'make'} or exit(1);
 552 system($make);
 553
 554 sub read_parrot_config {
 555     my %config = ();
 556     if (open my $CFG, "config_lib.pasm") {
 557         while (<$CFG>) {
 558             if (/P0\["(.*?)"], "(.*?)"/) { $config{$1} = $2 }
 559         }
 560         close $CFG;
 561     }
 562     %config;
 563 }
 564
 565 __@lclang@.pir__
 566 =head1 TITLE
 567
 568 @lclang@.pir - A @lang@ compiler.
 569
 570 =head2 Description
 571
 572 This is the base file for the @lang@ compiler.
 573
 574 This file includes the parsing and grammar rules from
 575 the src/ directory, loads the relevant PGE libraries,
 576 and registers the compiler under the name '@lang@'.
 577
 578 =head2 Functions
 579
 580 =over 4
 581
 582 =item onload()
 583
 584 Creates the @lang@ compiler using a C<PCT::HLLCompiler>
 585 object.
 586
 587 =cut
 588
 589 .HLL '@lclang@'
 590
 591 .namespace [ '@lang@';'Compiler' ]
 592
 593 .loadlib '@lclang@_group'
 594
 595 .sub '' :anon :load :init
 596     load_bytecode 'PCT.pbc'
 597     .local pmc parrotns, hllns, exports
 598     parrotns = get_root_namespace ['parrot']
 599     hllns = get_hll_namespace
 600     exports = split ' ', 'PAST PCT PGE'
 601     parrotns.'export_to'(hllns, exports)
 602 .end
 603
 604 .include 'src/gen_grammar.pir'
 605 .include 'src/gen_actions.pir'
 606
 607 .sub 'onload' :anon :load :init
 608     $P0 = get_hll_global ['PCT'], 'HLLCompiler'
 609     $P1 = $P0.'new'()
 610     $P1.'language'('@lclang@')
 611     $P0 = get_hll_namespace ['@lang@';'Grammar']
 612     $P1.'parsegrammar'($P0)
 613     $P0 = get_hll_namespace ['@lang@';'Grammar';'Actions']
 614     $P1.'parseactions'($P0)
 615 .end
 616
 617 =item main(args :slurpy)  :main
 618
 619 Start compilation by passing any command line C<args>
 620 to the @lang@ compiler.
 621
 622 =cut
 623
 624 .sub 'main' :main
 625     .param pmc args
 626
 627     $P0 = compreg '@lclang@'
 628     $P1 = $P0.'command_line'(args)
 629 .end
 630
 631 .include 'src/gen_builtins.pir'
 632
 633 =back
 634
 635 =cut
 636
 637 # Local Variables:
 638 #   mode: pir
 639 #   fill-column: 100
 640 # End:
 641 # vim: expandtab shiftwidth=4 ft=pir:
 642
 643 __src/pct/grammar.pg__
 644 # @Id@
 645
 646 =begin overview
 647
 648 This is the grammar for @lang@ written as a sequence of Perl 6 rules.
 649
 650 =end overview
 651
 652 grammar @lang@::Grammar is PCT::Grammar;
 653
 654 rule TOP {
 655     <statement>*
 656     [ $ || <panic: 'Syntax error'> ]
 657     {*}
 658 }
 659
 660 ##  this <ws> rule treats # as "comment to eol"
 661 ##  you may want to replace it with something appropriate
 662 token ws {
 663     <!ww>
 664     [ '#' \N* \n? | \s+ ]*
 665 }
 666
 667 rule statement {
 668     'say' <expression> [ ',' <expression> ]* ';'
 669     {*}
 670 }
 671
 672 rule value {
 673     | <integer> {*}                              #= integer
 674     | <quote> {*}                                #= quote
 675 }
 676
 677 token integer { \d+ {*} }
 678
 679 token quote {
 680     [ \' <string_literal: '\'' > \' | \" <string_literal: '"' > \" ]
 681     {*}
 682 }
 683
 684 ##  terms
 685 token term {
 686     | <value> {*}                                #= value
 687 }
 688
 689 rule expression is optable { ... }
 690
 691 __src/pct/grammar-oper.pg__
 692 # @Id@
 693
 694 ##  expressions and operators
 695 proto 'term:'     is precedence('=')     is parsed(&term)      { ... }
 696
 697 ## multiplicative operators
 698 proto infix:<*>   is looser(term:)       is pirop('mul')     { ... }
 699 proto infix:</>   is equiv(infix:<*>)    is pirop('div')     { ... }
 700
 701 ## additive operators
 702 proto infix:<+>   is looser(infix:<*>)   is pirop('add')     { ... }
 703 proto infix:<->   is equiv(infix:<+>)    is pirop('sub')     { ... }
 704
 705 __src/pct/actions.pm__
 706 # @Id@
 707
 708 =begin comments
 709
 710 @lang@::Grammar::Actions - ast transformations for @lang@
 711
 712 This file contains the methods that are used by the parse grammar
 713 to build the PAST representation of an @lang@ program.
 714 Each method below corresponds to a rule in F<src/parser/grammar.pg>,
 715 and is invoked at the point where C<{*}> appears in the rule,
 716 with the current match object as the first argument.  If the
 717 line containing C<{*}> also has a C<#= key> comment, then the
 718 value of the comment is passed as the second argument to the method.
 719
 720 =end comments
 721
 722 class @lang@::Grammar::Actions;
 723
 724 method TOP($/) {
 725     my $past := PAST::Block.new( :blocktype('declaration'), :node( $/ ), :hll('@lang@') );
 726     for $<statement> {
 727         $past.push( $_.ast );
 728     }
 729     make $past;
 730 }
 731
 732
 733 method statement($/) {
 734     my $past := PAST::Op.new( :name('say'), :pasttype('call'), :node( $/ ) );
 735     for $<expression> {
 736         $past.push( $_.ast );
 737     }
 738     make $past;
 739 }
 740
 741 ##  expression:
 742 ##    This is one of the more complex transformations, because
 743 ##    our grammar is using the operator precedence parser here.
 744 ##    As each node in the expression tree is reduced by the
 745 ##    parser, it invokes this method with the operator node as
 746 ##    the match object and a $key of 'reduce'.  We then build
 747 ##    a PAST::Op node using the information provided by the
 748 ##    operator node.  (Any traits for the node are held in $<top>.)
 749 ##    Finally, when the entire expression is parsed, this method
 750 ##    is invoked with the expression in $<expr> and a $key of 'end'.
 751 method expression($/, $key) {
 752     if ($key eq 'end') {
 753         make $<expr>.ast;
 754     }
 755     else {
 756         my $past := PAST::Op.new( :name($<type>),
 757                                   :pasttype($<top><pasttype>),
 758                                   :pirop($<top><pirop>),
 759                                   :lvalue($<top><lvalue>),
 760                                   :node($/)
 761                                 );
 762         for @($/) {
 763             $past.push( $_.ast );
 764         }
 765         make $past;
 766     }
 767 }
 768
 769
 770 ##  term:
 771 ##    Like 'statement' above, the $key has been set to let us know
 772 ##    which term subrule was matched.
 773 method term($/, $key) {
 774     make $/{$key}.ast;
 775 }
 776
 777
 778 method value($/, $key) {
 779     make $/{$key}.ast;
 780 }
 781
 782
 783 method integer($/) {
 784     make PAST::Val.new( :value( ~$/ ), :returns('Integer'), :node($/) );
 785 }
 786
 787
 788 method quote($/) {
 789     make PAST::Val.new( :value( $<string_literal>.ast ), :node($/) );
 790 }
 791
 792
 793 # Local Variables:
 794 #   mode: cperl
 795 #   cperl-indent-level: 4
 796 #   fill-column: 100
 797 # End:
 798 # vim: expandtab shiftwidth=4:
 799
 800 __src/builtins/say.pir__
 801 # @Id@
 802
 803 =head1
 804
 805 say.pir -- simple implementation of a say function
 806
 807 =cut
 808
 809 .namespace []
 810
 811 .sub 'say'
 812     .param pmc args            :slurpy
 813     .local pmc it
 814     it = iter args
 815   iter_loop:
 816     unless it goto iter_end
 817     $P0 = shift it
 818     print $P0
 819     goto iter_loop
 820   iter_end:
 821     print "\n"
 822     .return ()
 823 .end
 824
 825
 826 # Local Variables:
 827 #   mode: pir
 828 #   fill-column: 100
 829 # End:
 830 # vim: expandtab shiftwidth=4 ft=pir:
 831
 832 __t/harness__
 833 #! perl
 834
 835 # $Id$
 836
 837 use strict;
 838 use warnings;
 839
 840 use FindBin;
 841 use File::Spec;
 842 use Getopt::Long qw(:config pass_through);
 843
 844 $ENV{'HARNESS_PERL'} = './@lclang@';
 845 use Test::Harness;
 846 $Test::Harness::switches = '';
 847
 848 GetOptions(
 849     'tests-from-file=s' => \my $list_file,
 850     'verbosity=i'       => \$Test::Harness::verbose,
 851     'jobs:3'            => \my $jobs,
 852     'icu:1'             => \my $do_icu,
 853 );
 854
 855 my @pass_through_options = grep m/^--?[^-]/, @ARGV;
 856 my @files = grep m/^[^-]/, @ARGV;
 857
 858 my $slash = $^O eq 'MSWin32' ? '\\' : '/';
 859
 860 if ($list_file) {
 861     open(my $f, '<', $list_file)
 862         or die "Can't open file '$list_file' for reading: $!";
 863     while (<$f>) {
 864         next if m/^\s*#/;
 865         next unless m/\S/;
 866         chomp;
 867         my ($fn, $flags) = split /\s+#\s*/;
 868         next if ($flags && ($flags =~ m/icu/) && !$do_icu);
 869         $fn = "t/spec/$fn" unless $fn =~ m/^t\Q$slash\Espec\Q$slash\E/;
 870         $fn =~ s{/}{$slash}g;
 871         if ( -r $fn ) {
 872             push @files, $fn;
 873         }
 874         else {
 875             warn "Missing test file: $fn\n";
 876         }
 877     }
 878     close $f or die $!;
 879 }
 880
 881 my @tfiles = map { all_in($_) } sort @files;
 882
 883 if (eval { require TAP::Harness; 1 }) {
 884     my %harness_options = (
 885         exec      => ['./@lclang@'],
 886         verbosity => 0+$Test::Harness::verbose,
 887         jobs      => $jobs || 1,
 888     );
 889     TAP::Harness->new( \%harness_options )->runtests(@tfiles);
 890 }
 891 else {
 892     runtests(@tfiles);
 893 }
 894
 895 # adapted to return only files ending in '.t'
 896 sub all_in {
 897     my $start = shift;
 898
 899     return $start unless -d $start;
 900
 901     my @skip = ( File::Spec->updir, File::Spec->curdir, qw( .svn CVS .git ) );
 902     my %skip = map {($_,1)} @skip;
 903
 904     my @hits = ();
 905
 906     if ( opendir( my $dh, $start ) ) {
 907         my @files = sort readdir $dh;
 908         closedir $dh or die $!;
 909         for my $file ( @files ) {
 910             next if $skip{$file};
 911
 912             my $currfile = File::Spec->catfile( $start, $file );
 913             if ( -d $currfile ) {
 914                 push( @hits, all_in( $currfile ) );
 915             }
 916             else {
 917                 push( @hits, $currfile ) if $currfile =~ /\.t$/;
 918             }
 919         }
 920     }
 921     else {
 922         warn "$start: $!\n";
 923     }
 924
 925     return @hits;
 926 }
 927
 928 __t/00-sanity.t__
 929 # This just checks that the basic parsing and call to builtin say() works.
 930 say '1..4';
 931 say 'ok 1';
 932 say 'ok ', 2;
 933 say 'ok ', 2 + 1;
 934 say 'ok', ' ', 4;
 935
 936 __DATA__
 937
 938
 939 # Local Variables:
 940 # mode: cperl
 941 # cperl-indent-level: 4
 942 # fill-column: 100
 943 # End:
 944 # vim: expandtab shiftwidth=4:
 945