├── .gitignore ├── CREDITS ├── Configure.pl ├── LICENSE ├── README.pod ├── STATUS ├── build ├── Makefile.in ├── PARROT_REVISION ├── gen_bootstrap.pl ├── gen_parrot.pl ├── gen_setting.pl └── lib │ └── Rakudo │ └── CompareRevisions.pm ├── docs └── bootstrapping.pod ├── examples ├── fib.nqp ├── hello_world.nqp ├── json.nqp ├── load_bytecode.nqp └── loops.nqp ├── src ├── HLL.pir ├── HLL │ ├── Actions.pm │ ├── Compiler.pm │ └── Grammar.pm ├── NQP │ ├── Actions.pm │ ├── Compiler.pir │ └── Grammar.pm ├── PAST │ ├── Compiler-Regex.pir │ └── Regex.pir ├── Regex.pir ├── Regex │ ├── Cursor-builtins.pir │ ├── Cursor-protoregex-peek.pir │ ├── Cursor.pir │ ├── Dumper.pir │ ├── Match.pir │ ├── Method.pir │ ├── P6Regex.pir │ ├── P6Regex │ │ ├── Actions.pm │ │ └── Grammar.pm │ └── constants.pir ├── cheats │ ├── hll-compiler.pir │ ├── hll-grammar.pir │ ├── nqp-builtins.pir │ └── parrot-callcontext.pir ├── gen │ └── IGNOREME ├── setting │ ├── Hash.pm │ ├── IO.pm │ ├── Regex.pm │ └── ResizablePMCArray.pm └── stage0 │ ├── HLL-s0.pir │ ├── NQP-s0.pir │ ├── P6Regex-s0.pir │ ├── Regex-s0.pir │ └── nqp-setting.nqp ├── t ├── hll │ ├── 01-language.t │ ├── 02-modules.t │ ├── 03-exports.t │ └── 04-import.t ├── nqp │ ├── 01-literals.t │ ├── 02-if.t │ ├── 03-if-else.t │ ├── 04-unless.t │ ├── 05-comments.t │ ├── 06-args-pos.t │ ├── 07-boolean.t │ ├── 08-blocks.t │ ├── 09-var.t │ ├── 10-cmp.t │ ├── 11-sub.t │ ├── 12-logical.t │ ├── 13-op.t │ ├── 14-while.t │ ├── 15-list.t │ ├── 16-ternary.t │ ├── 17-positional.t │ ├── 18-associative.t │ ├── 19-inline.t │ ├── 20-return.t │ ├── 21-contextual.t │ ├── 22-optional-args.t │ ├── 23-named-args.t │ ├── 24-module.t │ ├── 25-class.t │ ├── 26-methodops.t │ ├── 27-self.t │ ├── 28-subclass.t │ ├── 29-make.t │ ├── 30-pirop.t │ ├── 31-grammar.t │ ├── 32-protoregex.t │ ├── 33-init.t │ ├── 34-rxcodeblock.t │ ├── 35-prefix-sigil.t │ ├── 36-callable.t │ ├── 37-slurpy.t │ ├── 38-quotes.t │ ├── 39-pointy.t │ ├── 40-lists.t │ ├── 41-flat.t │ ├── 42-cond-loop.t │ ├── 43-package-var.t │ ├── 44-try-catch.t │ ├── 45-smartmatch.t │ ├── 46-charspec.t │ ├── 47-loop-control.t │ ├── 48-closure.t │ ├── 49-regex-interpolation.t │ ├── 50-regex.t │ ├── 51-multi.t │ ├── 52-vtable.t │ └── 67-threads.t ├── p6regex │ ├── 01-regex.t │ ├── rx_backtrack │ ├── rx_basic │ ├── rx_captures │ ├── rx_charclass │ ├── rx_goal │ ├── rx_lookarounds │ ├── rx_metachars │ ├── rx_modifiers │ ├── rx_quantifiers │ ├── rx_subrules │ └── rx_syntax └── setting │ ├── 01-resizablepmcarray.t │ ├── 02-hash.t │ ├── 03-io.t │ ├── 04-regex.t │ └── 05-subst.t └── tools └── analyze-parse /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | /parrot 3 | /parrot_install 4 | .*.swp 5 | *.c 6 | *.o 7 | Regex.pbc 8 | HLL.pbc 9 | P6Regex 10 | P6Regex.pbc 11 | nqp 12 | nqp.pbc 13 | nqp-setting.pbc 14 | src/gen/*.pir 15 | src/gen/*.nqp 16 | src/stage1 17 | src/stage2 18 | -------------------------------------------------------------------------------- /CREDITS: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | Following in the steps of other open source projects that 4 | eventually take over the world, here is the partial list 5 | of people who have contributed to Rakudo and its supporting 6 | works. It is sorted by name and formatted to allow easy 7 | grepping and beautification by scripts. 8 | The fields are: name (N), email (E), web-address (W), 9 | description (D), subversion username (U) and snail-mail 10 | address (S). 11 | 12 | Thanks, 13 | 14 | The NQP Team 15 | PS: Yes, this looks remarkably like the Linux CREDITS format 16 | PPS: This file is encoded in UTF-8 17 | 18 | ---------- 19 | N: Daniel Arbelo Arrocha 20 | U: darbelo 21 | E: arbelo@gmail.com 22 | D: Minor code contributions (plumage) 23 | 24 | N: Geoff Broadwell 25 | U: japhb 26 | E: geoff@broadwell.org 27 | D: Initial design and implementation of Plumage. 28 | 29 | N: Jonathan "Duke" Leto 30 | U: leto 31 | D: Perl 6 (Rakudo Perl) developer 32 | E: jonathan@leto.net 33 | 34 | N: Jonathan Scott Duff 35 | U: perlpilot 36 | D: Perl 6 (Rakudo Perl) developer 37 | E: duff@pobox.com 38 | 39 | N: Patrick R. Michaud 40 | U: pmichaud 41 | D: Perl 6 (Rakudo Perl) lead developer, pumpking 42 | E: pmichaud@pobox.com 43 | 44 | N: Stefan O'Rear 45 | U: sorear 46 | D: Lexical persistance, POD, and other miscellaneous contributions 47 | E: stefanor@cox.net 48 | 49 | N: Stephen Weeks 50 | U: tene 51 | E: tene@allalone.org 52 | D: Assorted contributions (plumage) 53 | 54 | N: Vasily Chekalkin 55 | U: bacek 56 | D: Work on bringing Settings to NQP based on Plumage's NQPUtils. 57 | E: bacek@bacek.com 58 | 59 | =cut 60 | -------------------------------------------------------------------------------- /Configure.pl: -------------------------------------------------------------------------------- 1 | #! perl 2 | # Copyright (C) 2009 The Perl Foundation 3 | 4 | use 5.008; 5 | use strict; 6 | use warnings; 7 | use Getopt::Long; 8 | use Cwd; 9 | use lib "build/lib"; 10 | use Rakudo::CompareRevisions qw(compare_parrot_revs); 11 | 12 | MAIN: { 13 | my %options; 14 | GetOptions(\%options, 'help!', 'parrot-config=s', 15 | 'gen-parrot!', 'gen-parrot-prefix=s', 'gen-parrot-option=s@'); 16 | 17 | # Print help if it's requested 18 | if ($options{'help'}) { 19 | print_help(); 20 | exit(0); 21 | } 22 | 23 | # Determine the revision of Parrot we require 24 | open my $REQ, "build/PARROT_REVISION" 25 | || die "cannot open build/PARROT_REVISION\n"; 26 | my ($reqsvn, $reqpar) = split(' ', <$REQ>); 27 | close $REQ; 28 | 29 | # Update/generate parrot build if needed 30 | if ($options{'gen-parrot'}) { 31 | my @opts = @{ $options{'gen-parrot-option'} || [] }; 32 | my $prefix = $options{'gen-parrot-prefix'} || cwd()."/parrot_install"; 33 | # parrot's Configure.pl mishandles win32 backslashes in --prefix 34 | $prefix =~ s{\\}{/}g; 35 | my @command = ($^X, "build/gen_parrot.pl", "--prefix=$prefix", ($^O !~ /win32/i ? "--optimize" : ()), @opts); 36 | 37 | print "Generating Parrot ...\n"; 38 | print "@command\n\n"; 39 | system @command; 40 | } 41 | 42 | # Get a list of parrot-configs to invoke. 43 | my @parrot_config_exe = qw( 44 | parrot_install/bin/parrot_config 45 | ../../parrot_config 46 | parrot_config 47 | ); 48 | if (exists $options{'gen-parrot-prefix'}) { 49 | unshift @parrot_config_exe, 50 | $options{'gen-parrot-prefix'} . '/bin/parrot_config'; 51 | } 52 | 53 | if ($options{'parrot-config'} && $options{'parrot-config'} ne '1') { 54 | @parrot_config_exe = ($options{'parrot-config'}); 55 | } 56 | 57 | # Get configuration information from parrot_config 58 | my %config = read_parrot_config(@parrot_config_exe); 59 | 60 | my $parrot_errors = ''; 61 | if (!%config) { 62 | $parrot_errors .= "Unable to locate parrot_config\n"; 63 | } 64 | elsif (compare_parrot_revs($reqsvn, $config{'git_describe'}) > 0 && 65 | 66 | ($reqpar eq '' || version_int($reqpar) > version_int($config{'VERSION'}))) { 67 | $parrot_errors .= "Parrot revision $reqsvn required (currently $config{'git_describe'})\n"; 68 | } 69 | 70 | if ($parrot_errors) { 71 | die <<"END"; 72 | ===SORRY!=== 73 | $parrot_errors 74 | To automatically checkout (git) and build a copy of parrot $reqsvn, 75 | try re-running Configure.pl with the '--gen-parrot' option. 76 | Or, use the '--parrot-config' option to explicitly specify 77 | the location of parrot_config to be used to build NQP. 78 | 79 | END 80 | } 81 | 82 | # Verify the Parrot installation is sufficient for building NQP 83 | verify_parrot(%config); 84 | 85 | # Create the Makefile using the information we just got 86 | create_makefile(%config); 87 | my $make = $config{'make'}; 88 | 89 | { 90 | no warnings; 91 | print "Cleaning up ...\n"; 92 | if (open my $CLEAN, '-|', "$make clean") { 93 | my @slurp = <$CLEAN>; 94 | close $CLEAN; 95 | } 96 | } 97 | 98 | print <<"END"; 99 | 100 | You can now use '$make' to build NQP. 101 | After that, you can use '$make test' to run some local tests. 102 | 103 | END 104 | exit 0; 105 | 106 | } 107 | 108 | 109 | sub read_parrot_config { 110 | my @parrot_config_exe = @_; 111 | my %config = (); 112 | for my $exe (@parrot_config_exe) { 113 | no warnings; 114 | if (open my $PARROT_CONFIG, '-|', "$exe --dump") { 115 | print "\nReading configuration information from $exe ...\n"; 116 | while (<$PARROT_CONFIG>) { 117 | if (/(\w+) => '(.*)'/) { $config{$1} = $2 } 118 | } 119 | close $PARROT_CONFIG or die $!; 120 | last if %config; 121 | } 122 | } 123 | return %config; 124 | } 125 | 126 | 127 | sub verify_parrot { 128 | print "Verifying Parrot installation...\n"; 129 | my %config = @_; 130 | my $PARROT_VERSION = $config{'versiondir'}; 131 | my $PARROT_LIB_DIR = $config{'libdir'}.$PARROT_VERSION; 132 | my $PARROT_SRC_DIR = $config{'srcdir'}.$PARROT_VERSION; 133 | my $PARROT_INCLUDE_DIR = $config{'includedir'}.$PARROT_VERSION; 134 | my $PARROT_TOOLS_DIR = "$PARROT_LIB_DIR/tools"; 135 | my @required_files = ( 136 | "$PARROT_LIB_DIR/library/PGE/Perl6Grammar.pbc", 137 | "$PARROT_LIB_DIR/library/PCT/HLLCompiler.pbc", 138 | "$PARROT_TOOLS_DIR/build/ops2c.pl", 139 | "$PARROT_TOOLS_DIR/build/pmc2c.pl", 140 | "$PARROT_SRC_DIR", 141 | "$PARROT_SRC_DIR/pmc", 142 | "$PARROT_INCLUDE_DIR", 143 | "$PARROT_INCLUDE_DIR/pmc", 144 | ); 145 | my @missing; 146 | for my $reqfile (@required_files) { 147 | push @missing, " $reqfile" unless -e $reqfile; 148 | } 149 | if (@missing) { 150 | my $missing = join("\n", @missing); 151 | die <<"END"; 152 | 153 | ===SORRY!=== 154 | I'm missing some needed files from the Parrot installation: 155 | $missing 156 | (Perhaps you need to use Parrot's "make install-dev" or 157 | install the "parrot-devel" package for your system?) 158 | 159 | END 160 | } 161 | } 162 | 163 | # Generate a Makefile from a configuration 164 | sub create_makefile { 165 | my %config = @_; 166 | 167 | my $maketext = slurp( 'build/Makefile.in' ); 168 | 169 | $config{'win32_libparrot_copy'} = $^O eq 'MSWin32' ? 'copy $(PARROT_BIN_DIR)\libparrot.dll .' : ''; 170 | $maketext =~ s/@(\w+)@/$config{$1}/g; 171 | if ($^O eq 'MSWin32') { 172 | $maketext =~ s{/}{\\}g; 173 | $maketext =~ s{\\\*}{\\\\*}g; 174 | $maketext =~ s{http:\S+}{ do {my $t = $&; $t =~ s'\\'/'g; $t} }eg; 175 | } 176 | 177 | my $outfile = 'Makefile'; 178 | print "\nCreating $outfile ...\n"; 179 | open(my $MAKEOUT, '>', $outfile) || 180 | die "Unable to write $outfile\n"; 181 | print {$MAKEOUT} $maketext; 182 | close $MAKEOUT or die $!; 183 | 184 | return; 185 | } 186 | 187 | sub slurp { 188 | my $filename = shift; 189 | 190 | open my $fh, '<', $filename or die "Unable to read $filename\n"; 191 | local $/ = undef; 192 | my $maketext = <$fh>; 193 | close $fh or die $!; 194 | 195 | return $maketext; 196 | } 197 | 198 | sub version_int { 199 | sprintf('%d%03d%03d', split(/\./, $_[0])) 200 | } 201 | 202 | 203 | # Print some help text. 204 | sub print_help { 205 | print <<'END'; 206 | Configure.pl - NQP Configure 207 | 208 | General Options: 209 | --help Show this text 210 | --gen-parrot Download and build a copy of Parrot to use 211 | --gen-parrot-option='--option=value' 212 | Set parrot config option when using --gen-parrot 213 | --parrot-config=(config) 214 | Use configuration information from config 215 | END 216 | 217 | return; 218 | } 219 | 220 | # Local Variables: 221 | # mode: cperl 222 | # cperl-indent-level: 4 223 | # fill-column: 100 224 | # End: 225 | # vim: expandtab shiftwidth=4: 226 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Artistic License 2.0 2 | 3 | Copyright (c) 2000-2006, The Perl Foundation. 4 | 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | This license establishes the terms under which a given free software 11 | Package may be copied, modified, distributed, and/or redistributed. 12 | The intent is that the Copyright Holder maintains some artistic 13 | control over the development of that Package while still keeping the 14 | Package available as open source and free software. 15 | 16 | You are always permitted to make arrangements wholly outside of this 17 | license directly with the Copyright Holder of a given Package. If the 18 | terms of this license do not permit the full use that you propose to 19 | make of the Package, you should contact the Copyright Holder and seek 20 | a different licensing arrangement. 21 | 22 | Definitions 23 | 24 | "Copyright Holder" means the individual(s) or organization(s) 25 | named in the copyright notice for the entire Package. 26 | 27 | "Contributor" means any party that has contributed code or other 28 | material to the Package, in accordance with the Copyright Holder's 29 | procedures. 30 | 31 | "You" and "your" means any person who would like to copy, 32 | distribute, or modify the Package. 33 | 34 | "Package" means the collection of files distributed by the 35 | Copyright Holder, and derivatives of that collection and/or of 36 | those files. A given Package may consist of either the Standard 37 | Version, or a Modified Version. 38 | 39 | "Distribute" means providing a copy of the Package or making it 40 | accessible to anyone else, or in the case of a company or 41 | organization, to others outside of your company or organization. 42 | 43 | "Distributor Fee" means any fee that you charge for Distributing 44 | this Package or providing support for this Package to another 45 | party. It does not mean licensing fees. 46 | 47 | "Standard Version" refers to the Package if it has not been 48 | modified, or has been modified only in ways explicitly requested 49 | by the Copyright Holder. 50 | 51 | "Modified Version" means the Package, if it has been changed, and 52 | such changes were not explicitly requested by the Copyright 53 | Holder. 54 | 55 | "Original License" means this Artistic License as Distributed with 56 | the Standard Version of the Package, in its current version or as 57 | it may be modified by The Perl Foundation in the future. 58 | 59 | "Source" form means the source code, documentation source, and 60 | configuration files for the Package. 61 | 62 | "Compiled" form means the compiled bytecode, object code, binary, 63 | or any other form resulting from mechanical transformation or 64 | translation of the Source form. 65 | 66 | 67 | Permission for Use and Modification Without Distribution 68 | 69 | (1) You are permitted to use the Standard Version and create and use 70 | Modified Versions for any purpose without restriction, provided that 71 | you do not Distribute the Modified Version. 72 | 73 | 74 | Permissions for Redistribution of the Standard Version 75 | 76 | (2) You may Distribute verbatim copies of the Source form of the 77 | Standard Version of this Package in any medium without restriction, 78 | either gratis or for a Distributor Fee, provided that you duplicate 79 | all of the original copyright notices and associated disclaimers. At 80 | your discretion, such verbatim copies may or may not include a 81 | Compiled form of the Package. 82 | 83 | (3) You may apply any bug fixes, portability changes, and other 84 | modifications made available from the Copyright Holder. The resulting 85 | Package will still be considered the Standard Version, and as such 86 | will be subject to the Original License. 87 | 88 | 89 | Distribution of Modified Versions of the Package as Source 90 | 91 | (4) You may Distribute your Modified Version as Source (either gratis 92 | or for a Distributor Fee, and with or without a Compiled form of the 93 | Modified Version) provided that you clearly document how it differs 94 | from the Standard Version, including, but not limited to, documenting 95 | any non-standard features, executables, or modules, and provided that 96 | you do at least ONE of the following: 97 | 98 | (a) make the Modified Version available to the Copyright Holder 99 | of the Standard Version, under the Original License, so that the 100 | Copyright Holder may include your modifications in the Standard 101 | Version. 102 | 103 | (b) ensure that installation of your Modified Version does not 104 | prevent the user installing or running the Standard Version. In 105 | addition, the Modified Version must bear a name that is different 106 | from the name of the Standard Version. 107 | 108 | (c) allow anyone who receives a copy of the Modified Version to 109 | make the Source form of the Modified Version available to others 110 | under 111 | 112 | (i) the Original License or 113 | 114 | (ii) a license that permits the licensee to freely copy, 115 | modify and redistribute the Modified Version using the same 116 | licensing terms that apply to the copy that the licensee 117 | received, and requires that the Source form of the Modified 118 | Version, and of any works derived from it, be made freely 119 | available in that license fees are prohibited but Distributor 120 | Fees are allowed. 121 | 122 | 123 | Distribution of Compiled Forms of the Standard Version 124 | or Modified Versions without the Source 125 | 126 | (5) You may Distribute Compiled forms of the Standard Version without 127 | the Source, provided that you include complete instructions on how to 128 | get the Source of the Standard Version. Such instructions must be 129 | valid at the time of your distribution. If these instructions, at any 130 | time while you are carrying out such distribution, become invalid, you 131 | must provide new instructions on demand or cease further distribution. 132 | If you provide valid instructions or cease distribution within thirty 133 | days after you become aware that the instructions are invalid, then 134 | you do not forfeit any of your rights under this license. 135 | 136 | (6) You may Distribute a Modified Version in Compiled form without 137 | the Source, provided that you comply with Section 4 with respect to 138 | the Source of the Modified Version. 139 | 140 | 141 | Aggregating or Linking the Package 142 | 143 | (7) You may aggregate the Package (either the Standard Version or 144 | Modified Version) with other packages and Distribute the resulting 145 | aggregation provided that you do not charge a licensing fee for the 146 | Package. Distributor Fees are permitted, and licensing fees for other 147 | components in the aggregation are permitted. The terms of this license 148 | apply to the use and Distribution of the Standard or Modified Versions 149 | as included in the aggregation. 150 | 151 | (8) You are permitted to link Modified and Standard Versions with 152 | other works, to embed the Package in a larger work of your own, or to 153 | build stand-alone binary or bytecode versions of applications that 154 | include the Package, and Distribute the result without restriction, 155 | provided the result does not expose a direct interface to the Package. 156 | 157 | 158 | Items That are Not Considered Part of a Modified Version 159 | 160 | (9) Works (including, but not limited to, modules and scripts) that 161 | merely extend or make use of the Package, do not, by themselves, cause 162 | the Package to be a Modified Version. In addition, such works are not 163 | considered parts of the Package itself, and are not subject to the 164 | terms of this license. 165 | 166 | 167 | General Provisions 168 | 169 | (10) Any use, modification, and distribution of the Standard or 170 | Modified Versions is governed by this Artistic License. By using, 171 | modifying or distributing the Package, you accept this license. Do not 172 | use, modify, or distribute the Package, if you do not accept this 173 | license. 174 | 175 | (11) If your Modified Version has been derived from a Modified 176 | Version made by someone other than you, you are nevertheless required 177 | to ensure that your Modified Version complies with the requirements of 178 | this license. 179 | 180 | (12) This license does not grant you the right to use any trademark, 181 | service mark, tradename, or logo of the Copyright Holder. 182 | 183 | (13) This license includes the non-exclusive, worldwide, 184 | free-of-charge patent license to make, have made, use, offer to sell, 185 | sell, import and otherwise transfer the Package with respect to any 186 | patent claims licensable by the Copyright Holder that are necessarily 187 | infringed by the Package. If you institute patent litigation 188 | (including a cross-claim or counterclaim) against any party alleging 189 | that the Package constitutes direct or contributory patent 190 | infringement, then this Artistic License to you shall terminate on the 191 | date that such litigation is filed. 192 | 193 | (14) Disclaimer of Warranty: 194 | THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS 195 | IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED 196 | WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR 197 | NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL 198 | LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL 199 | BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 200 | DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF 201 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 202 | -------------------------------------------------------------------------------- /README.pod: -------------------------------------------------------------------------------- 1 | =head1 DEPRECATION NOTICE 2 | 3 | These days, NQP-rx is unmaintained; active development happens in 4 | nqp at L. This repository only serves 5 | as a historical document, and/or an implicit lesson in compiler design. 6 | 7 | =head1 NQP-rx - Not Quite Perl (6) 8 | 9 | NQP-rx is Copyright (C) 2009 by The Perl Foundation. See F 10 | for licensing details. 11 | 12 | This is "Not Quite Perl" -- a compiler for quickly generating PIR 13 | routines from Perl6-like code. The key feature of NQP-rx is that it's 14 | designed to be a very small compiler (as compared with, say, perl6 15 | or Rakudo) and is focused on being a high-level way to create 16 | transformers for Parrot (especially hll compilers). In addition, 17 | unlike Rakudo, NQP-rx attempts to restrict itself to generating code 18 | that can run in Parrot without the existence of any NQP-specific 19 | runtime libraries. 20 | 21 | =head2 Building from source 22 | 23 | NQP-rx comes bundled with Parrot, so if you have a recent Parrot 24 | distribution you likely also have a copy of NQP-rx. Inside of a 25 | Parrot installation NQP-rx is known as C. 26 | 27 | To build NQP-rx from source, you'll just need a C utility 28 | and Perl 5.8 or newer. To automatically obtain and build Parrot 29 | you may also need a subversion (svn) client. 30 | 31 | To obtain NQP-rx directly from its repository: 32 | 33 | $ git clone git://github.com/perl6/nqp-rx.git 34 | 35 | If you don't have git installed, you can get a tarball or zip 36 | of NQP from github by visiting http://github.com/perl6/nqp-rx/tree/master 37 | and clicking "Download". Then unpack the tarball or zip. 38 | 39 | Once you have a copy of NQP-rx, build it as follows: 40 | 41 | $ cd nqp-rx 42 | $ perl Configure.pl --gen-parrot 43 | $ make 44 | 45 | This will create a "nqp" or "nqp.exe" executable in the 46 | current (nqp-rx) directory. Programs can then be run from 47 | the build directory using a command like: 48 | 49 | $ ./nqp hello.pl 50 | 51 | The C<--gen-parrot> option above tells Configure.pl to automatically 52 | download and build the most appropriate version of Parrot into a 53 | local "parrot/" subdirectory, install that Parrot into the 54 | "parrot_install/" subdirectory, and use that for building NQP-rx. 55 | It's okay to use the C<--gen-parrot> option on later invocations 56 | of Configure.pl; the configure system will re-build Parrot only 57 | if a newer version is needed for whatever version of Rakudo you're 58 | working with. 59 | 60 | You can use C<--parrot-config=/path/to/parrot_config> instead 61 | of C<--gen-parrot> to use an already installed Parrot for building 62 | NQP. This installed Parrot must include its development 63 | environment; typically this is done via Parrot's C 64 | target or by installing prebuilt C and/or C 65 | packages. The version of the already installed Parrot must satisfy a 66 | minimum specified by the NQP-rx being built -- Configure.pl will 67 | verify this for you. Released versions of NQP-rx always build 68 | against the latest release of Parrot; checkouts of the HEAD revision 69 | from github often require a version of Parrot that is newer than 70 | the most recent Parrot monthly release. 71 | 72 | Once built, NQP-rx's C target will install NQP-rx 73 | and its libraries into the Parrot installation that was used to 74 | create it. Until this step is performed, the "nqp" executable 75 | created by C above can only be reliably run from the root of 76 | NQP-rx's build directory. After C is performed 77 | the executable can be run from any directory (as long as the 78 | Parrot installation that was used to create it remains intact). 79 | 80 | If the NQP-rx compiler is invoked without an explicit script to 81 | run, it enters a small interactive mode that allows statements 82 | to be executed from the command line. 83 | 84 | =head2 Differences from previous version of NQP 85 | 86 | * Sub declarations are now lexical ("my") by default, use 87 | "our sub xyz() { ... }" if you want package-scoped subroutines. 88 | 89 | * The PIR q<...>; construct is gone. Use Q:PIR or pir::opcode(...) 90 | instead. 91 | 92 | * The mainline code of modules is no longer tagged as ":load :init" 93 | by default. Use INIT { ... } for any code that you want to be 94 | run automatically at startup. 95 | 96 | * Cuddled else's are no longer valid Perl 6, 'else' requires a 97 | space after it. 98 | 99 | * Double-quoted strings now interpolate $-variables. 100 | 101 | 102 | -------------------------------------------------------------------------------- /STATUS: -------------------------------------------------------------------------------- 1 | 2009-10-09: 2 | 3 | At the moment, nqp-rx is configured to build an executable called 4 | "p6regex", which is a Perl 6 regular expression compiler for Parrot. 5 | Yes, Parrot already has a Perl 6 regular expression compiler (PGE); 6 | this one is different in that it will be self-hosting and based on 7 | PAST/POST generation. 8 | 9 | Building the system is similar to building Rakudo: 10 | 11 | $ perl Configure.pl --gen-parrot 12 | $ make 13 | 14 | This builds a "p6regex" executable, which can be used to view 15 | the results of compiling various regular expressions. Like Rakudo, 16 | p6regex accepts --target=parse, --target=past, and --target=pir, to 17 | see the results of compiling various regular expressions. For example, 18 | 19 | $ ./p6regex --target=parse 20 | > abcde*f 21 | 22 | will display the parse tree for the regular expression "abcde*f". Similarly, 23 | 24 | $ ./p6regex --target=pir 25 | > abcde*f 26 | 27 | will display the PIR subroutine generated to match the regular 28 | expression "abcde*f". 29 | 30 | At the moment there's not an easy command-line tool for doing matches 31 | against the compiled regular expression; that should be coming soon 32 | as nqp-rx gets a little farther along. 33 | 34 | The test suite can be run via "make test" -- because the new regex 35 | engine is incomplete, we expect quite a few failures (which should 36 | diminish as we add new features to the project). 37 | 38 | The key files for the p6regex compiler are: 39 | 40 | src/Regex/P6Regex/Grammar.pm # regular expression parse grammar 41 | src/Regex/P6Regex/Actions.pm # actions to create PAST from parse 42 | 43 | 44 | Things that work (2009-10-15, 06h16 UTC): 45 | 46 | * bare literal strings 47 | * quantifiers *, +, ?, *:, +:, ?:, *?, +?, ??, *!, +!, ?! 48 | * dot 49 | * \d, \s, \w, \n, \D, \S, \W, \N 50 | * brackets for grouping 51 | * alternation (|| works, | cheats) 52 | * anchors ^, ^^, $, $$, <<, >> 53 | * backslash-quoted punctuation 54 | * #-comments (mostly) 55 | * obsolete backslash sequences \A \Z \z \Q 56 | * \b, \B, \e, \E, \f, \F, \h, \H, \r, \R, \t, \T, \v, \V 57 | * enumerated character lists <[ab0..9]> 58 | * character class compositions <+foo-bar+[xyz]> 59 | * quantified by numeric range 60 | * quantified by separator 61 | * capturing subrules 62 | * capturing subpatterns 63 | * capture aliases 64 | * cut rule 65 | * Match objects created lazily 66 | * built-in methods etc. 67 | * :ignorecase 68 | * :sigspace 69 | * :ratchet 70 | * single-quoted literals (without quotes) 71 | -------------------------------------------------------------------------------- /build/Makefile.in: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2006-2009, The Perl Foundation. 2 | # 3 | 4 | PARROT_ARGS = 5 | 6 | # values from parrot_config 7 | PARROT_BIN_DIR = @bindir@ 8 | PARROT_VERSION = @versiondir@ 9 | PARROT_INCLUDE_DIR = @includedir@$(PARROT_VERSION) 10 | PARROT_LIB_DIR = @libdir@$(PARROT_VERSION) 11 | PARROT_SRC_DIR = @srcdir@$(PARROT_VERSION) 12 | PARROT_LIBRARY_DIR = $(PARROT_LIB_DIR)/library 13 | HAS_ICU = @has_icu@ 14 | 15 | CC = @cc@ 16 | CFLAGS = @ccflags@ @cc_shared@ @cc_debug@ @ccwarn@ @cc_hasjit@ @gc_flag@ 17 | EXE = @exe@ 18 | LD = @ld@ 19 | LDFLAGS = @ldflags@ @ld_debug@ 20 | LD_LOAD_FLAGS = @ld_load_flags@ 21 | LIBPARROT = @inst_libparrot_ldflags@ 22 | O = @o@ 23 | LOAD_EXT = @load_ext@ 24 | PERL = @perl@ 25 | CP = @cp@ 26 | MV = @mv@ 27 | RM_F = @rm_f@ 28 | MKPATH = $(PERL) -MExtUtils::Command -e mkpath 29 | CHMOD = $(PERL) -MExtUtils::Command -e chmod 30 | 31 | # locations of parrot resources 32 | PARROT = $(PARROT_BIN_DIR)/parrot$(EXE) 33 | PARROT_NQP = $(PARROT_BIN_DIR)/parrot_nqp$(EXE) 34 | PBC_TO_EXE = $(PARROT_BIN_DIR)/pbc_to_exe$(EXE) 35 | PARROT_TOOLS_DIR = $(PARROT_LIB_DIR)/tools 36 | PARROT_PERL_LIB = $(PARROT_TOOLS_DIR)/lib 37 | 38 | NQP_LANG_DIR = $(PARROT_LIB_DIR)/languages/nqp 39 | 40 | REGEX_SOURCES = \ 41 | src/Regex.pir \ 42 | src/Regex/constants.pir \ 43 | src/Regex/Cursor.pir \ 44 | src/Regex/Cursor-builtins.pir \ 45 | src/Regex/Cursor-protoregex-peek.pir \ 46 | src/Regex/Match.pir \ 47 | src/Regex/Method.pir \ 48 | src/Regex/Dumper.pir \ 49 | src/PAST/Regex.pir \ 50 | src/PAST/Compiler-Regex.pir \ 51 | 52 | HLL_SOURCES = \ 53 | src/HLL.pir \ 54 | src/cheats/hll-compiler.pir \ 55 | src/cheats/hll-grammar.pir \ 56 | src/cheats/parrot-callcontext.pir \ 57 | src/HLL/Grammar.pm \ 58 | src/HLL/Actions.pm \ 59 | src/HLL/Compiler.pm \ 60 | 61 | P6REGEX_SOURCES = \ 62 | src/Regex/P6Regex.pir \ 63 | src/Regex/P6Regex/Grammar.pm \ 64 | src/Regex/P6Regex/Actions.pm \ 65 | 66 | HLLGRAMMAR_SOURCES = \ 67 | src/HLL/Grammar.pm \ 68 | src/HLL/Actions.pm \ 69 | src/cheats/hll-grammar.pir \ 70 | 71 | NQP_SOURCES = \ 72 | src/NQP/Grammar.pm \ 73 | src/NQP/Actions.pm \ 74 | src/NQP/Compiler.pir \ 75 | 76 | SETTING_SOURCES = \ 77 | src/setting/ResizablePMCArray.pm \ 78 | src/setting/Hash.pm \ 79 | src/setting/Regex.pm \ 80 | src/setting/IO.pm \ 81 | 82 | SETTING_NQP = src/gen/nqp-setting.nqp 83 | SETTING_PIR = src/gen/nqp-setting.pir 84 | SETTING_PBC = nqp-setting.pbc 85 | 86 | STAGE0_SOURCES = \ 87 | src/stage0/Regex-s0.pir \ 88 | src/stage0/HLL-s0.pir \ 89 | src/stage0/P6Regex-s0.pir \ 90 | src/stage0/NQP-s0.pir 91 | 92 | STAGE0 = src/stage0 93 | STAGE1 = src/stage1 94 | STAGE2 = src/stage2 95 | 96 | REGEX_PBC = Regex.pbc 97 | 98 | HLL_PBC = HLL.pbc 99 | HLLGRAMMAR_G = gen/hllgrammar-grammar.pir 100 | HLLGRAMMAR_A = gen/hllgrammar-actions.pir 101 | 102 | HLLCOMPILER_PIR = gen/hllcompiler.pir 103 | 104 | P6REGEX_PBC = P6Regex.pbc 105 | P6REGEX_G = gen/p6regex-grammar.pir 106 | P6REGEX_A = gen/p6regex-actions.pir 107 | 108 | P6GRAMMAR_PBC = P6Grammar.pbc 109 | P6GRAMMAR_G = gen/p6grammar-grammar.pir 110 | P6GRAMMAR_A = gen/p6grammar-actions.pir 111 | 112 | NQP_PBC = nqp.pbc 113 | NQP_G = gen/nqp-grammar.pir 114 | NQP_A = gen/nqp-actions.pir 115 | NQP_EXE = nqp$(EXE) 116 | 117 | STAGE0_PBCS = $(STAGE0)/$(HLL_PBC) $(STAGE0)/$(P6REGEX_PBC) $(STAGE0)/$(NQP_PBC) $(STAGE0)/$(REGEX_PBC) 118 | STAGE1_PBCS = $(STAGE1)/$(HLL_PBC) $(STAGE1)/$(P6REGEX_PBC) $(STAGE1)/$(NQP_PBC) $(REGEX_PBC) 119 | STAGE2_PBCS = $(STAGE2)/$(HLL_PBC) $(STAGE2)/$(P6REGEX_PBC) $(STAGE2)/$(NQP_PBC) $(REGEX_PBC) 120 | ALL_PBCS = $(HLL_PBC) $(P6REGEX_PBC) $(NQP_PBC) 121 | 122 | CLEANUPS = \ 123 | *.manifest \ 124 | *.pdb \ 125 | $(REGEX_PBC) \ 126 | $(HLL_PBC) \ 127 | $(P6REGEX_PBC) \ 128 | P6Regex$(EXE) \ 129 | $(P6GRAMMAR_PBC) \ 130 | P6Grammar$(EXE) \ 131 | nqp.pbc \ 132 | nqp$(EXE) \ 133 | *.c\ 134 | *.o\ 135 | src/stage0/*.pbc \ 136 | src/stage1/gen/* \ 137 | src/stage1/*.pbc \ 138 | src/stage2/gen/* \ 139 | src/stage2/*.pbc \ 140 | src/gen/*.pir \ 141 | src/gen/*.nqp \ 142 | 143 | all: $(NQP_EXE) $(SETTING_PBC) 144 | 145 | install: all 146 | $(MKPATH) $(DESTDIR)$(NQP_LANG_DIR) 147 | $(CP) nqp.pbc $(DESTDIR)$(NQP_LANG_DIR)/nqprx.pbc 148 | $(CP) $(P6REGEX_PBC) $(DESTDIR)$(PARROT_LIBRARY_DIR)/$(P6REGEX_PBC) 149 | $(CP) $(REGEX_PBC) $(DESTDIR)$(PARROT_LIBRARY_DIR)/$(REGEX_PBC) 150 | $(CP) $(HLL_PBC) $(DESTDIR)$(PARROT_LIBRARY_DIR)/$(HLL_PBC) 151 | $(MKPATH) $(DESTDIR)$(PARROT_BIN_DIR) 152 | $(CP) $(NQP_EXE) $(DESTDIR)$(PARROT_BIN_DIR)/nqp$(EXE) 153 | $(CHMOD) 755 $(DESTDIR)$(PARROT_BIN_DIR)/nqp$(EXE) 154 | 155 | stage0: $(STAGE0) 156 | stage1: $(STAGE1) 157 | stage2: $(STAGE2) 158 | 159 | $(REGEX_PBC): $(REGEX_SOURCES) 160 | $(PARROT) -o $(REGEX_PBC) $(REGEX_SOURCES) 161 | 162 | $(STAGE0): $(STAGE0_PBCS) 163 | 164 | $(STAGE0_PBCS): $(STAGE0_SOURCES) 165 | $(PARROT) -o $(STAGE0)/$(REGEX_PBC) src/stage0/Regex-s0.pir 166 | $(PARROT) -o $(STAGE0)/$(HLL_PBC) src/stage0/HLL-s0.pir 167 | $(PARROT) -o $(STAGE0)/$(P6REGEX_PBC) src/stage0/P6Regex-s0.pir 168 | $(PARROT) -o $(STAGE0)/$(NQP_PBC) src/stage0/NQP-s0.pir 169 | 170 | $(STAGE1): $(STAGE1_PBCS) 171 | 172 | $(STAGE1)/$(HLL_PBC): $(STAGE0_PBCS) $(HLL_SOURCES) 173 | $(MKPATH) $(STAGE1)/gen 174 | $(PARROT) --library=$(STAGE0) $(STAGE0)/$(NQP_PBC) \ 175 | --target=pir --output=$(STAGE1)/$(HLLGRAMMAR_G) \ 176 | src/HLL/Grammar.pm 177 | $(PARROT) --library=$(STAGE0) $(STAGE0)/$(NQP_PBC) \ 178 | --target=pir --output=$(STAGE1)/$(HLLGRAMMAR_A) \ 179 | src/HLL/Actions.pm 180 | $(PARROT) --library=$(STAGE0) $(STAGE0)/$(NQP_PBC) \ 181 | --target=pir --output=$(STAGE1)/$(HLLCOMPILER_PIR) \ 182 | src/HLL/Compiler.pm 183 | $(PARROT) --include=$(STAGE1) -o $(STAGE1)/$(HLL_PBC) \ 184 | src/HLL.pir 185 | 186 | $(STAGE1)/$(P6REGEX_PBC): $(STAGE0_PBCS) $(P6REGEX_SOURCES) 187 | $(MKPATH) $(STAGE1)/gen 188 | $(PARROT) --library=$(STAGE0) $(STAGE0)/$(NQP_PBC) \ 189 | --target=pir --output=$(STAGE1)/$(P6REGEX_G) \ 190 | src/Regex/P6Regex/Grammar.pm 191 | $(PARROT) --library=$(STAGE0) $(STAGE0)/$(NQP_PBC) \ 192 | --target=pir --output=$(STAGE1)/$(P6REGEX_A) \ 193 | src/Regex/P6Regex/Actions.pm 194 | $(PARROT) --include=$(STAGE1) -o $(STAGE1)/$(P6REGEX_PBC) \ 195 | src/Regex/P6Regex.pir 196 | 197 | $(STAGE1)/$(NQP_PBC): $(STAGE0_PBCS) $(NQP_SOURCES) 198 | $(MKPATH) $(STAGE1)/gen 199 | $(PARROT) --library=$(STAGE0) $(STAGE0)/$(NQP_PBC) \ 200 | --target=pir --output=$(STAGE1)/$(NQP_G) \ 201 | src/NQP/Grammar.pm 202 | $(PARROT) --library=$(STAGE0) $(STAGE0)/$(NQP_PBC) \ 203 | --target=pir --output=$(STAGE1)/$(NQP_A) \ 204 | src/NQP/Actions.pm 205 | $(PARROT) --include=$(STAGE1) -o $(STAGE1)/$(NQP_PBC) \ 206 | src/NQP/Compiler.pir 207 | 208 | $(STAGE2): $(STAGE2_PBCS) 209 | 210 | $(STAGE2)/$(HLL_PBC): $(STAGE1_PBCS) $(HLL_SOURCES) 211 | $(MKPATH) $(STAGE2)/gen 212 | $(PARROT) --library=$(STAGE1) $(STAGE1)/$(NQP_PBC) \ 213 | --target=pir --output=$(STAGE2)/$(HLLGRAMMAR_G) \ 214 | src/HLL/Grammar.pm 215 | $(PARROT) --library=$(STAGE1) $(STAGE1)/$(NQP_PBC) \ 216 | --target=pir --output=$(STAGE2)/$(HLLGRAMMAR_A) \ 217 | src/HLL/Actions.pm 218 | $(PARROT) --library=$(STAGE1) $(STAGE1)/$(NQP_PBC) \ 219 | --target=pir --output=$(STAGE2)/$(HLLCOMPILER_PIR) \ 220 | src/HLL/Compiler.pm 221 | $(PARROT) --include=$(STAGE2) -o $(STAGE2)/$(HLL_PBC) \ 222 | src/HLL.pir 223 | 224 | $(STAGE2)/$(P6REGEX_PBC): $(STAGE1_PBCS) $(P6REGEX_SOURCES) 225 | $(MKPATH) $(STAGE2)/gen 226 | $(PARROT) --library=$(STAGE1) $(STAGE1)/$(NQP_PBC) \ 227 | --target=pir --output=$(STAGE2)/$(P6REGEX_G) \ 228 | src/Regex/P6Regex/Grammar.pm 229 | $(PARROT) --library=$(STAGE1) $(STAGE1)/$(NQP_PBC) \ 230 | --target=pir --output=$(STAGE2)/$(P6REGEX_A) \ 231 | src/Regex/P6Regex/Actions.pm 232 | $(PARROT) --include=$(STAGE2) -o $(STAGE2)/$(P6REGEX_PBC) \ 233 | src/Regex/P6Regex.pir 234 | 235 | $(STAGE2)/$(NQP_PBC): $(STAGE1_PBCS) $(NQP_SOURCES) 236 | $(MKPATH) $(STAGE2)/gen 237 | $(PARROT) --library=$(STAGE1) $(STAGE1)/$(NQP_PBC) \ 238 | --target=pir --output=$(STAGE2)/$(NQP_G) \ 239 | src/NQP/Grammar.pm 240 | $(PARROT) --library=$(STAGE1) $(STAGE1)/$(NQP_PBC) \ 241 | --target=pir --output=$(STAGE2)/$(NQP_A) \ 242 | src/NQP/Actions.pm 243 | $(PARROT) --include=$(STAGE2) -o $(STAGE2)/$(NQP_PBC) \ 244 | src/NQP/Compiler.pir 245 | 246 | $(ALL_PBCS): $(REGEX_PBC) $(STAGE2_PBCS) 247 | $(CP) $(STAGE2)/$(HLL_PBC) . 248 | $(CP) $(STAGE2)/$(P6REGEX_PBC) . 249 | $(CP) $(STAGE2)/$(NQP_PBC) . 250 | 251 | $(NQP_EXE): $(NQP_PBC) 252 | $(PBC_TO_EXE) $(NQP_PBC) 253 | 254 | $(SETTING_NQP): $(SETTING_SOURCES) 255 | $(PERL) build/gen_setting.pl $(SETTING_SOURCES) > $(SETTING_NQP) 256 | $(SETTING_PIR): $(SETTING_NQP) $(NQP_PBC) 257 | $(PARROT) $(NQP_PBC) --target=pir -o $(SETTING_PIR) $(SETTING_NQP) 258 | $(SETTING_PBC): $(SETTING_PIR) 259 | $(PARROT) -o $(SETTING_PBC) $(SETTING_PIR) 260 | 261 | 262 | bootstrap-files: $(STAGE2_PBCS) $(SETTING_NQP) 263 | $(PERL) build/gen_bootstrap.pl src/Regex.pir >src/stage0/Regex-s0.pir 264 | $(PERL) build/gen_bootstrap.pl src/HLL.pir >src/stage0/HLL-s0.pir 265 | $(PERL) build/gen_bootstrap.pl src/Regex/P6Regex.pir >src/stage0/P6Regex-s0.pir 266 | $(PERL) build/gen_bootstrap.pl src/NQP/Compiler.pir >src/stage0/NQP-s0.pir 267 | $(PERL) build/gen_bootstrap.pl $(SETTING_NQP) >src/stage0/nqp-setting.nqp 268 | 269 | 270 | ## testing 271 | 272 | test: all core-test setting-test p6regex-test 273 | 274 | test-loud: all core-test-loud setting-test-loud p6regex-test-loud 275 | 276 | core-test: $(NQP_EXE) 277 | prove -r --exec ./$(NQP_EXE) t/nqp t/hll 278 | 279 | core-test-loud: $(NQP_EXE) 280 | prove -r -v --exec ./$(NQP_EXE) t/nqp t/hll 281 | 282 | p6regex-test: $(P6REGEX_PBC) 283 | prove -r --exec $(PARROT) t/p6regex 284 | 285 | p6regex-test-loud: $(P6REGEX_PBC) 286 | prove -r -v --exec $(PARROT) t/p6regex 287 | 288 | setting-test: $(NQP_EXE) $(SETTING_PBC) 289 | prove -r --exec ./$(NQP_EXE) t/setting 290 | 291 | setting-test-loud: $(NQP_EXE) $(SETTING_PBC) 292 | prove -r -v --exec ./$(NQP_EXE) t/setting 293 | 294 | ## cleaning 295 | 296 | clean: 297 | $(RM_F) $(CLEANUPS) 298 | 299 | distclean: realclean 300 | 301 | realclean: clean 302 | $(RM_F) Makefile 303 | 304 | testclean: 305 | -------------------------------------------------------------------------------- /build/PARROT_REVISION: -------------------------------------------------------------------------------- 1 | RELEASE_3_4_0-266-gfb77d3c 2 | -------------------------------------------------------------------------------- /build/gen_bootstrap.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # Copyright (C) 2009, Patrick R. Michaud. 3 | 4 | use strict; 5 | use warnings; 6 | 7 | 8 | foreach my $file (@ARGV) { 9 | make_bootstrap($file); 10 | } 11 | 12 | 0; 13 | 14 | sub make_bootstrap { 15 | my $filename = shift; 16 | open my $fh, '<', $filename or die "Unable to read $filename\n"; 17 | 18 | while (<$fh>) { 19 | if (m{^\.include '(src/[^']*)'}) { 20 | print "### $_"; 21 | make_bootstrap($1); 22 | } 23 | elsif (m{^\.include '(gen/[^']*)'}) { 24 | print "### $_"; 25 | make_bootstrap("src/stage2/$1"); 26 | } 27 | else { print; } 28 | } 29 | } 30 | 31 | 32 | -------------------------------------------------------------------------------- /build/gen_parrot.pl: -------------------------------------------------------------------------------- 1 | #! perl 2 | # Copyright (C) 2009 The Perl Foundation 3 | 4 | =head1 TITLE 5 | 6 | gen_parrot.pl - script to obtain and build Parrot for Rakudo 7 | 8 | =head2 SYNOPSIS 9 | 10 | perl gen_parrot.pl [--parrot --configure=options] 11 | 12 | =head2 DESCRIPTION 13 | 14 | Maintains an appropriate copy of Parrot in the parrot/ subdirectory. 15 | The revision of Parrot to be used in the build is given by the 16 | build/PARROT_REVISION file. 17 | 18 | =cut 19 | 20 | use strict; 21 | use warnings; 22 | use 5.008; 23 | 24 | use lib "build/lib"; 25 | use Rakudo::CompareRevisions qw(compare_parrot_revs); 26 | 27 | # Work out slash character to use. 28 | my $slash = $^O eq 'MSWin32' ? '\\' : '/'; 29 | 30 | ## determine what revision of Parrot we require 31 | open my $REQ, "build/PARROT_REVISION" 32 | || die "cannot open build/PARROT_REVISION\n"; 33 | my ($req, $reqpar) = split(' ', <$REQ>); 34 | close $REQ; 35 | 36 | { 37 | no warnings; 38 | if (open my $REV, '-|', "parrot_install${slash}bin${slash}parrot_config git_describe") { 39 | my $revision = <$REV>; 40 | close $REV; 41 | $revision =~ s/\s.*//s; 42 | if (compare_parrot_revs($revision, $req) >= 0) { 43 | print "Parrot $revision already available ($req required)\n"; 44 | exit(0); 45 | } 46 | } 47 | } 48 | 49 | print "Checking out Parrot $req via git...\n"; 50 | if (-d 'parrot') { 51 | if (-d 'parrot/.svn') { 52 | die "===SORRY===\n" 53 | ."Your 'parrot' directory is still an SVN repository.\n" 54 | ."Parrot switched to git recently; in order to replace your\n" 55 | ."repository by a git repository, please manually delete\n" 56 | ."the 'parrot' directory, and then re-run the command that caused\n" 57 | ."this error message\n"; 58 | } 59 | system_or_die(qw(git fetch)); 60 | } else { 61 | system_or_die(qw(git clone git://github.com/parrot/parrot.git parrot)); 62 | } 63 | 64 | chdir('parrot') || die "Can't chdir to 'parrot': $!"; 65 | 66 | system_or_die(qw(git checkout), $req); 67 | 68 | ## If we have a Makefile from a previous build, do a 'make realclean' 69 | if (-f 'Makefile') { 70 | my %config = read_parrot_config(); 71 | my $make = $config{'make'}; 72 | if ($make) { 73 | print "\nPerforming '$make realclean' ...\n"; 74 | system_or_die($make, "realclean"); 75 | } 76 | } 77 | 78 | print "\nConfiguring Parrot ...\n"; 79 | my @config_command = ($^X, 'Configure.pl', @ARGV); 80 | print "@config_command\n"; 81 | system_or_die( @config_command ); 82 | 83 | print "\nBuilding Parrot ...\n"; 84 | my %config = read_parrot_config(); 85 | my $make = $config{'make'} or exit(1); 86 | system_or_die($make, 'install-dev'); 87 | 88 | sub read_parrot_config { 89 | my %config = (); 90 | if (open my $CFG, "config_lib.pir") { 91 | while (<$CFG>) { 92 | if (/P0\["(.*?)"], "(.*?)"/) { $config{$1} = $2 } 93 | } 94 | close $CFG; 95 | } 96 | %config; 97 | } 98 | 99 | sub system_or_die { 100 | my @cmd = @_; 101 | 102 | system( @cmd ) == 0 103 | or die "Command failed (status $?): @cmd\n"; 104 | } 105 | -------------------------------------------------------------------------------- /build/gen_setting.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # Copyright (C) 2008, The Perl Foundation. 3 | # 4 | 5 | use strict; 6 | use warnings; 7 | 8 | my @files = @ARGV; 9 | 10 | print <<"END_SETTING"; 11 | #! nqp 12 | 13 | # This file automatically generated by $0 in the nqp-rx project. 14 | 15 | END_SETTING 16 | 17 | my %classnames; 18 | foreach my $file (@files) { 19 | print "# From $file\n\n"; 20 | open(my $fh, "<", $file) or die $!; 21 | local $/; 22 | my $x = <$fh>; 23 | close $fh; 24 | print $x; 25 | } 26 | 27 | print "\n# vim: set ft=perl6 nomodifiable :\n"; 28 | -------------------------------------------------------------------------------- /build/lib/Rakudo/CompareRevisions.pm: -------------------------------------------------------------------------------- 1 | package Rakudo::CompareRevisions; 2 | use strict; 3 | use warnings; 4 | 5 | use base qw(Exporter); 6 | our @EXPORT_OK = qw(compare_parrot_revs parse_parrot_git_describe); 7 | 8 | sub parse_parrot_git_describe { 9 | my $g = shift; 10 | my $sep = qr/[_\W]/; 11 | $g =~ /^REL(?:EASE)?$sep(\d+)$sep(\d+)$sep(\d+)(?:-(\d+)-g[a-f0-9]*)?$/ 12 | or die "Invalid revision specifier: '$g' " 13 | ."(expected something of format RELEASE_1_2_3-123-gdeadbee)\n"; 14 | my @c = ($1, $2, $3, $4 || 0); 15 | return @c; 16 | } 17 | 18 | sub compare_parrot_revs { 19 | my ($aa, $bb) = @_; 20 | return 1 if $bb =~ /^r?\d+$/; 21 | return -1 if $aa =~ /^r?\d+$/; 22 | my @a = parse_parrot_git_describe($aa); 23 | my @b = parse_parrot_git_describe($bb); 24 | for (0..3) { 25 | my $cmp = $a[$_] <=> $b[$_]; 26 | return $cmp if $cmp; 27 | } 28 | return 0; 29 | } 30 | 31 | 1; 32 | -------------------------------------------------------------------------------- /docs/bootstrapping.pod: -------------------------------------------------------------------------------- 1 | =head1 Bootstrapping procedure for nqp-rx 2 | 3 | NPQ-rx is a bootstrapped compiler, which means that it uses itself to compile 4 | itself. 5 | 6 | To make the first compilation possible, a compiled version of the compiler is 7 | stored in F and included in the source code repository. 8 | Also the parrot virtual machine ships the same 9 | C files. 10 | 11 | When you make changes to the compiler, eventually you need to update these 12 | I files. 13 | 14 | Here is how you proceed to update the bootstrapping files nqp-rx and parrot. 15 | At any stage, if C fails, don't go ahead with the following steps, 16 | but fix the problem first. 17 | 18 | =over 19 | 20 | =item * 21 | 22 | Make your changes, run C 23 | 24 | =item * 25 | 26 | Run C and C 27 | 28 | =item * 29 | 30 | Commit the non-bootstrap files that you modified yourself 31 | 32 | =item * 33 | 34 | Commit the bootstrap files 35 | 36 | =item * 37 | 38 | Copy the I files over to parrot: 39 | 40 | cp src/stage0/*.pir $PARROT_SRC/ext/nqp-rx/src/stage0 41 | 42 | =item * 43 | 44 | In the parrot source, run C and commit 45 | 46 | =back 47 | 48 | References: L 49 | -------------------------------------------------------------------------------- /examples/fib.nqp: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | sub fib($n) { 4 | $n < 2 ?? $n !! fib($n-1) + fib($n - 2); 5 | } 6 | 7 | my $N := 29; 8 | 9 | my $t0 := pir::time__N(); 10 | my $z := fib($N); 11 | my $t1 := pir::time__N(); 12 | 13 | pir::say("fib($N) = " ~ fib($N)); 14 | pir::say("time = " ~ ($t1-$t0)); 15 | -------------------------------------------------------------------------------- /examples/hello_world.nqp: -------------------------------------------------------------------------------- 1 | #!nqp 2 | 3 | say("Hello, awesome Not Quite Perl 6 World!"); 4 | -------------------------------------------------------------------------------- /examples/json.nqp: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # A JSON compiler written in NQP. To use this compiler, first 4 | # precompile the code to PIR, then run that: 5 | # 6 | # $ nqp --target=pir json.nqp >json.pir 7 | # $ parrot json.pir 8 | # 9 | # It can then be turned into a .pbc to be available as load_language: 10 | # 11 | # $ parrot -o json.pbc json.pir 12 | # $ cp json.pbc /lib//languages 13 | # 14 | 15 | INIT { 16 | pir::load_bytecode('P6Regex.pbc'); 17 | pir::load_bytecode('dumper.pbc'); 18 | } 19 | 20 | grammar JSON::Grammar is HLL::Grammar { 21 | rule TOP { } 22 | 23 | proto token value { <...> } 24 | 25 | token value:sym { } 26 | 27 | token value:sym { 28 | '-'? 29 | [ <[1..9]> <[0..9]>+ | <[0..9]> ] 30 | [ '.' <[0..9]>+ ]? 31 | [ <[Ee]> <[+\-]>? <[0..9]>+ ]? 32 | } 33 | 34 | rule value:sym { 35 | '[' [ ** ',' ]? ']' 36 | } 37 | 38 | rule value:sym { 39 | '{' 40 | [ [ ':' ] ** ',' ]? 41 | '}' 42 | } 43 | 44 | token string { 45 | 46 | } 47 | } 48 | 49 | 50 | class JSON::Actions is HLL::Actions { 51 | method TOP($/) { 52 | make PAST::Block.new($.ast, :node($/)); 53 | }; 54 | 55 | method value:sym($/) { make $.ast; } 56 | 57 | method value:sym($/) { make +$/; } 58 | 59 | method value:sym($/) { 60 | my $past := PAST::Op.new(:pasttype, :node($/)); 61 | if $ { 62 | for $ { $past.push($_.ast); } 63 | } 64 | make $past; 65 | } 66 | 67 | method value:sym($/) { 68 | my $past := PAST::Stmts.new( :node($/) ); 69 | my $hashname := PAST::Compiler.unique('hash'); 70 | my $hash := PAST::Var.new( :scope, :name($hashname), 71 | :viviself('Hash'), :isdecl ); 72 | my $hashreg := PAST::Var.new( :scope, :name($hashname) ); 73 | $past.'push'($hash); 74 | # loop through all string/value pairs, add set opcodes for each pair. 75 | my $n := 0; 76 | while $n < +$ { 77 | $past.'push'(PAST::Op.new( :pirop, $hashreg, 78 | $[$n].ast, $[$n].ast ) ); 79 | $n++; 80 | } 81 | # return the Hash as the result of this node 82 | $past.'push'($hashreg); 83 | make $past; 84 | } 85 | 86 | method string($/) { make $.ast; } 87 | } 88 | 89 | 90 | class JSON::Compiler is HLL::Compiler { 91 | INIT { 92 | JSON::Compiler.language('json'); 93 | JSON::Compiler.parsegrammar(JSON::Grammar); 94 | JSON::Compiler.parseactions(JSON::Actions); 95 | } 96 | 97 | method autoprint($value) { 98 | _dumper($value, 'JSON') 99 | unless (pir::getinterp__P()).stdhandle(1).tell > $*AUTOPRINTPOS; 100 | } 101 | 102 | our sub MAIN(@ARGS) is pirflags<:main> { 103 | JSON::Compiler.command_line(@ARGS); 104 | } 105 | } 106 | 107 | -------------------------------------------------------------------------------- /examples/load_bytecode.nqp: -------------------------------------------------------------------------------- 1 | #!nqp 2 | 3 | pir::load_bytecode('PGE.pbc'); 4 | say("Loaded Parrot Grammar Engine"); 5 | -------------------------------------------------------------------------------- /examples/loops.nqp: -------------------------------------------------------------------------------- 1 | #! nqp 2 | # Example of a while loop 3 | 4 | my $i := 0; 5 | while $i < 10 { 6 | say("i=$i"); 7 | $i++; 8 | } 9 | -------------------------------------------------------------------------------- /src/HLL.pir: -------------------------------------------------------------------------------- 1 | # 2 | 3 | =head1 NAME 4 | 5 | HLL - Parrot HLL library 6 | 7 | =head1 DESCRIPTION 8 | 9 | This file brings together the various modules needed for HLL::Compiler 10 | and HLL::Grammar. 11 | 12 | =over 4 13 | 14 | =cut 15 | 16 | .sub '' :anon :load :init 17 | load_bytecode 'Regex.pbc' 18 | .end 19 | 20 | .include 'src/cheats/hll-compiler.pir' 21 | .include 'src/cheats/hll-grammar.pir' 22 | .include 'src/cheats/parrot-callcontext.pir' 23 | .include 'gen/hllgrammar-grammar.pir' 24 | .include 'gen/hllgrammar-actions.pir' 25 | .include 'gen/hllcompiler.pir' 26 | 27 | =back 28 | 29 | =head1 AUTHOR 30 | 31 | Patrick Michaud is the author and maintainer. 32 | 33 | =head1 COPYRIGHT 34 | 35 | Copyright (C) 2009, The Perl Foundation. 36 | 37 | =cut 38 | 39 | # Local Variables: 40 | # mode: pir 41 | # fill-column: 100 42 | # End: 43 | # vim: expandtab shiftwidth=4 ft=pir: 44 | -------------------------------------------------------------------------------- /src/HLL/Actions.pm: -------------------------------------------------------------------------------- 1 | class HLL::Actions; 2 | 3 | our sub string_to_int($src, $base) { 4 | Q:PIR { 5 | .local pmc src 6 | .local string src_s 7 | src = find_lex '$src' 8 | src_s = src 9 | .local int base, pos, eos, result 10 | $P0 = find_lex '$base' 11 | base = $P0 12 | pos = 0 13 | eos = length src_s 14 | result = 0 15 | str_loop: 16 | unless pos < eos goto str_done 17 | .local string char 18 | char = substr src_s, pos, 1 19 | if char == '_' goto str_next 20 | .local int digitval 21 | digitval = index "00112233445566778899AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz", char 22 | if digitval < 0 goto err_base 23 | digitval >>= 1 24 | if digitval >= base goto err_base 25 | result *= base 26 | result += digitval 27 | str_next: 28 | inc pos 29 | goto str_loop 30 | err_base: 31 | src.'panic'('Invalid radix conversion of "', char, '"') 32 | str_done: 33 | %r = box result 34 | }; 35 | } 36 | 37 | our sub ints_to_string($ints) { 38 | Q:PIR { 39 | .local string result 40 | result = '' 41 | .local pmc ints, ints_it 42 | ints = find_lex '$ints' 43 | $I0 = does ints, 'array' 44 | unless $I0 goto ints_1 45 | ints_it = iter ints 46 | ints_loop: 47 | unless ints_it goto ints_done 48 | $P0 = shift ints_it 49 | $I0 = $P0.'ast'() 50 | $S0 = chr $I0 51 | result = concat result, $S0 52 | goto ints_loop 53 | ints_1: 54 | $I0 = ints.'ast'() 55 | result = chr $I0 56 | ints_done: 57 | %r = box result 58 | }; 59 | } 60 | 61 | 62 | method CTXSAVE() { 63 | PAST::Op.new( 64 | :inline( 65 | ' $P0 = find_dynamic_lex "$*CTXSAVE"', 66 | ' if null $P0 goto ctxsave_done', 67 | ' $I0 = can $P0, "ctxsave"', 68 | ' unless $I0 goto ctxsave_done', 69 | ' $P0."ctxsave"()', 70 | ' ctxsave_done:' 71 | ) 72 | ); 73 | } 74 | 75 | 76 | method SET_BLOCK_OUTER_CTX($block) { 77 | my $outer_ctx := %*COMPILING<%?OPTIONS>; 78 | if pir::defined($outer_ctx) { 79 | my @ns := pir::getattribute__PPs($outer_ctx, 'current_namespace').get_name; 80 | @ns.shift; 81 | $block.namespace(@ns); 82 | for $outer_ctx.lexpad_full { 83 | $block.symbol($_.key, :scope); 84 | } 85 | } 86 | } 87 | 88 | 89 | method EXPR($/, $key?) { 90 | unless $key { return 0; } 91 | my $past := $/.ast // $.ast; 92 | unless $past { 93 | $past := PAST::Op.new( :node($/) ); 94 | if $ { $past.pasttype( ~$ ); } 95 | elsif $ { $past.pirop( ~$ ); } 96 | unless $past.name { 97 | if $key eq 'LIST' { $key := 'infix'; } 98 | my $name := Q:PIR { 99 | $P0 = find_lex '$key' 100 | $S0 = $P0 101 | $S0 = downcase $S0 102 | %r = box $S0 103 | } ~ ':<' ~ $ ~ '>'; 104 | $past.name('&' ~ $name); 105 | } 106 | } 107 | if $key eq 'POSTFIX' { $past.unshift($/[0].ast); } 108 | else { 109 | for $/.list { if pir::defined__IP($_.ast) { $past.push($_.ast); } } 110 | } 111 | make $past; 112 | } 113 | 114 | method term:sym($/) { make $.ast } 115 | 116 | method termish($/) { make $.ast; } 117 | method nullterm($/) { make Q:PIR { %r = new ['Undef'] }; } 118 | method nullterm_alt($/) { make $.ast; } 119 | 120 | method integer($/) { make $.ast; } 121 | 122 | method dec_number($/) { make +$/; } 123 | 124 | method decint($/) { make string_to_int( $/, 10); } 125 | method hexint($/) { make string_to_int( $/, 16); } 126 | method octint($/) { make string_to_int( $/, 8 ); } 127 | method binint($/) { make string_to_int( $/, 2 ); } 128 | 129 | method quote_EXPR($/) { 130 | my $past := $.ast; 131 | if $/.CURSOR.quotemod_check('w') { 132 | if PAST::Node.ACCEPTS($past) { 133 | $/.CURSOR.panic("Can't form :w list from non-constant strings (yet)"); 134 | } 135 | else { 136 | my @words := HLL::Grammar::split_words($/, $past); 137 | if +@words != 1 { 138 | $past := PAST::Op.new( :pasttype('list'), :node($/) ); 139 | for @words { $past.push($_); } 140 | } 141 | else { 142 | $past := ~@words[0]; 143 | } 144 | } 145 | } 146 | if !PAST::Node.ACCEPTS($past) { 147 | $past := PAST::Val.new( :value(~$past) ); 148 | } 149 | make $past; 150 | } 151 | 152 | method quote_delimited($/) { 153 | my @parts; 154 | my $lastlit := ''; 155 | for $ { 156 | my $ast := $_.ast; 157 | if !PAST::Node.ACCEPTS($ast) { 158 | $lastlit := $lastlit ~ $ast; 159 | } 160 | elsif $ast.isa(PAST::Val) { 161 | $lastlit := $lastlit ~ $ast.value; 162 | } 163 | else { 164 | if $lastlit gt '' { @parts.push($lastlit); } 165 | @parts.push($ast); 166 | $lastlit := ''; 167 | } 168 | } 169 | if $lastlit gt '' { @parts.push($lastlit); } 170 | my $past := @parts ?? @parts.shift !! ''; 171 | while @parts { 172 | $past := PAST::Op.new( $past, @parts.shift, :pirop('concat') ); 173 | } 174 | make $past; 175 | } 176 | 177 | method quote_atom($/) { 178 | make $ ?? $.ast !! ~$/; 179 | } 180 | 181 | method quote_escape:sym($/) { make "\\"; } 182 | method quote_escape:sym($/) { make ~$ } 183 | 184 | method quote_escape:sym($/) { make "\b"; } 185 | method quote_escape:sym($/) { make "\n"; } 186 | method quote_escape:sym($/) { make "\r"; } 187 | method quote_escape:sym($/) { make "\t"; } 188 | method quote_escape:sym($/) { make "\c[12]"; } 189 | method quote_escape:sym($/) { make "\c[27]"; } 190 | 191 | method quote_escape:sym($/) { 192 | make ints_to_string( $ ?? $ !! $ ); 193 | } 194 | 195 | method quote_escape:sym($/) { 196 | make ints_to_string( $ ?? $ !! $ ); 197 | } 198 | 199 | method quote_escape:sym($/) { 200 | make $.ast; 201 | } 202 | 203 | method quote_escape:sym<0>($/) { 204 | make "\c[0]"; 205 | } 206 | 207 | method quote_escape:sym($/) { 208 | make $ ?? '\\' ~ $.Str !! $.Str; 209 | } 210 | 211 | method charname($/) { 212 | my $codepoint := $ 213 | ?? $.ast 214 | !! pir::find_codepoint__Is( ~$/ ); 215 | $/.CURSOR.panic("Unrecognized character name $/") if $codepoint < 0; 216 | make pir::chr($codepoint); 217 | } 218 | 219 | method charnames($/) { 220 | my $str := ''; 221 | for $ { $str := $str ~ $_.ast; } 222 | make $str; 223 | } 224 | 225 | method charspec($/) { 226 | make $ ?? $.ast !! pir::chr(string_to_int( $/, 10 )); 227 | } 228 | -------------------------------------------------------------------------------- /src/HLL/Compiler.pm: -------------------------------------------------------------------------------- 1 | INIT { 2 | pir::load_bytecode('PCT/HLLCompiler.pbc'); 3 | } 4 | 5 | 6 | class HLL::Compiler is PCT::HLLCompiler { 7 | 8 | has $!language; 9 | 10 | INIT { 11 | HLL::Compiler.language('parrot'); 12 | } 13 | 14 | my sub value_type($value) { 15 | pir::isa($value, 'NameSpace') 16 | ?? 'namespace' 17 | !! (pir::isa($value, 'Sub') ?? 'sub' !! 'var') 18 | } 19 | 20 | method get_exports($module, :$tagset, *@symbols) { 21 | # convert a module name to something hash-like, if needed 22 | if (!pir::does($module, 'hash')) { 23 | $module := self.get_module($module); 24 | } 25 | 26 | $tagset := $tagset // (@symbols ?? 'ALL' !! 'DEFAULT'); 27 | my %exports; 28 | my %source := $module{'EXPORT'}{~$tagset}; 29 | if !pir::defined(%source) { 30 | %source := $tagset eq 'ALL' ?? $module !! {}; 31 | } 32 | if @symbols { 33 | for @symbols { 34 | my $value := %source{~$_}; 35 | %exports{value_type($value)}{$_} := $value; 36 | } 37 | } 38 | else { 39 | for %source { 40 | my $value := $_.value; 41 | %exports{value_type($value)}{$_.key} := $value; 42 | } 43 | } 44 | %exports; 45 | } 46 | 47 | method get_module($name) { 48 | my @name := self.parse_name($name); 49 | @name.unshift(pir::downcase($!language)); 50 | pir::get_root_namespace__PP(@name); 51 | } 52 | 53 | method language($name?) { 54 | if $name { 55 | $!language := $name; 56 | pir::compreg__0sP($name, self); 57 | } 58 | $!language; 59 | } 60 | 61 | method load_module($name) { 62 | my $base := pir::join('/', self.parse_name($name)); 63 | my $loaded := 0; 64 | try { pir::load_bytecode("$base.pbc"); $loaded := 1 }; 65 | unless $loaded { pir::load_bytecode("$base.pir"); $loaded := 1 } 66 | self.get_module($name); 67 | } 68 | 69 | method import($target, %exports) { 70 | for %exports { 71 | my $type := $_.key; 72 | my %items := $_.value; 73 | if pir::can(self, "import_$type") { 74 | for %items { self."import_$type"($target, $_.key, $_.value); } 75 | } 76 | elsif pir::can($target, "add_$type") { 77 | for %items { $target."add_$type"($_.key, $_.value); } 78 | } 79 | else { 80 | for %items { $target{~$_.key} := $_.value; } 81 | } 82 | } 83 | } 84 | 85 | method autoprint($value) { 86 | pir::say(~$value) 87 | unless (pir::getinterp__P()).stdout_handle().tell() > $*AUTOPRINTPOS; 88 | } 89 | 90 | method interactive(*%adverbs) { 91 | my $target := pir::downcase(%adverbs); 92 | 93 | pir::print__vPS( pir::getinterp__P().stderr_handle(), self.commandline_banner ); 94 | 95 | my $stdin := pir::getinterp__P().stdin_handle(); 96 | my $encoding := ~%adverbs; 97 | if $encoding && $encoding ne 'fixed_8' { 98 | $stdin.encoding($encoding); 99 | } 100 | 101 | my $save_ctx; 102 | while 1 { 103 | last unless $stdin; 104 | 105 | my $prompt := self.commandline_prompt // '> '; 106 | my $code := $stdin.readline_interactive(~$prompt); 107 | 108 | last if pir::isnull($code); 109 | 110 | # Set the current position of stdout for autoprinting control 111 | my $*AUTOPRINTPOS := (pir::getinterp__P()).stdout_handle().tell(); 112 | my $*CTXSAVE := self; 113 | my $*MAIN_CTX; 114 | 115 | if $code { 116 | $code := $code ~ "\n"; 117 | my $output; 118 | { 119 | $output := self.eval($code, :outer_ctx($save_ctx), |%adverbs); 120 | CATCH { 121 | pir::print(~$! ~ "\n"); 122 | next; 123 | } 124 | }; 125 | if pir::defined($*MAIN_CTX) { 126 | our $interactive_ctx; 127 | our %interactive_pad; 128 | for $*MAIN_CTX.lexpad_full() { 129 | %interactive_pad{$_.key} := $_.value; 130 | } 131 | $save_ctx := $interactive_ctx; 132 | } 133 | next if pir::isnull($output); 134 | 135 | if !$target { 136 | self.autoprint($output); 137 | } elsif $target eq 'pir' { 138 | pir::say($output); 139 | } else { 140 | self.dumper($output, $target, |%adverbs); 141 | } 142 | } 143 | } 144 | } 145 | 146 | method eval($code, *@args, *%adverbs) { 147 | my $output; 148 | $output := self.compile($code, |%adverbs); 149 | 150 | if !pir::isa($output, 'String') 151 | && %adverbs eq '' { 152 | my $outer_ctx := %adverbs; 153 | if pir::defined($outer_ctx) { 154 | $output[0].set_outer_ctx($outer_ctx); 155 | } 156 | 157 | pir::trace(%adverbs); 158 | $output := $output(|@args); 159 | pir::trace(0); 160 | } 161 | 162 | $output; 163 | } 164 | 165 | method ctxsave() { 166 | $*MAIN_CTX := 167 | Q:PIR { 168 | $P0 = getinterp 169 | %r = $P0['context';1] 170 | }; 171 | $*CTXSAVE := 0; 172 | } 173 | } 174 | -------------------------------------------------------------------------------- /src/HLL/Grammar.pm: -------------------------------------------------------------------------------- 1 | grammar HLL::Grammar; 2 | 3 | # method EXPR is in src/cheats/hll-grammar.pir 4 | 5 | token ws { [ \s+ | '#' \N* ]* } 6 | 7 | token termish { 8 | * 9 | 10 | * 11 | } 12 | 13 | proto token term { <...> } 14 | proto token infix { <...> } 15 | proto token prefix { <...> } 16 | proto token postfix { <...> } 17 | proto token circumfix { <...> } 18 | proto token postcircumfix { <...> } 19 | 20 | token term:sym { } 21 | 22 | token infixish { } 23 | token prefixish { <.ws> } 24 | token postfixish { 25 | | 26 | | 27 | } 28 | 29 | token nullterm { } 30 | token nullterm_alt { } 31 | 32 | # Return if it matches, otherwise. 33 | method nulltermish() { self.termish || self.nullterm_alt } 34 | 35 | # token quote_EXPR is in src/cheats/hll-grammar.pir 36 | token quote_delimited { 37 | * 38 | } 39 | 40 | token quote_atom { 41 | 42 | [ 43 | | 44 | | [ <-quote_escape-stopper> ]+ 45 | ] 46 | } 47 | 48 | token decint { [\d+] ** '_' } 49 | token decints { [<.ws><.ws>] ** ',' } 50 | 51 | token hexint { [<[ 0..9 a..f A..F ]>+] ** '_' } 52 | token hexints { [<.ws><.ws>] ** ',' } 53 | 54 | token octint { [<[ 0..7 ]>+] ** '_' } 55 | token octints { [<.ws><.ws>] ** ',' } 56 | 57 | token binint { [<[ 0..1 ]>+] ** '_' } 58 | token binints { [<.ws><.ws>] ** ',' } 59 | 60 | token integer { 61 | [ 62 | | 0 [ b 63 | | o 64 | | x 65 | | d 66 | ] 67 | | 68 | ] 69 | } 70 | 71 | token dec_number { 72 | | $=[ '.' \d+ ] ? 73 | | $=[ \d+ '.' \d+ ] ? 74 | | $=[ \d+ ] 75 | } 76 | 77 | token escale { <[Ee]> <[+\-]>? \d+ } 78 | 79 | proto token quote_escape { <...> } 80 | token quote_escape:sym { \\ \\ } 81 | token quote_escape:sym { \\ } 82 | 83 | token quote_escape:sym { \\ b } 84 | token quote_escape:sym { \\ n } 85 | token quote_escape:sym { \\ r } 86 | token quote_escape:sym { \\ t } 87 | token quote_escape:sym { \\ f } 88 | token quote_escape:sym { \\ e } 89 | token quote_escape:sym { 90 | \\ x 91 | [ | '[' ']' ] 92 | } 93 | token quote_escape:sym { 94 | \\ o 95 | [ | '[' ']' ] 96 | } 97 | token quote_escape:sym { \\ c } 98 | token quote_escape:sym<0> { \\ } 99 | token quote_escape:sym { 100 | {} \\ 101 | [ 102 | || 103 | [ 104 | | $=(\W) 105 | | $=[\w] { $/.CURSOR.panic("Unrecognized backslash sequence: '\\" ~ $.Str ~ "'") } 106 | ] 107 | || $=[.] 108 | ] 109 | } 110 | 111 | token charname { 112 | || 113 | || <[a..z A..Z]> <-[ \] , # ]>*? <[a..z A..Z ) ]> 114 | > 115 | } 116 | token charnames { [<.ws><.ws>] ** ',' } 117 | token charspec { 118 | [ 119 | | '[' ']' 120 | | \d+ [ _ \d+]* 121 | | <[ ?..Z ]> 122 | | { $/.CURSOR.panic('Unrecognized \\c character') } 123 | ] 124 | } 125 | 126 | -------------------------------------------------------------------------------- /src/NQP/Compiler.pir: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2009, The Perl Foundation. 2 | 3 | =head1 NAME 4 | 5 | NQP::Compiler - NQP compiler 6 | 7 | =head1 DESCRIPTION 8 | 9 | =cut 10 | 11 | .sub '' :anon :load :init 12 | load_bytecode 'P6Regex.pbc' 13 | .end 14 | 15 | .include 'gen/nqp-grammar.pir' 16 | .include 'gen/nqp-actions.pir' 17 | .include 'src/cheats/nqp-builtins.pir' 18 | 19 | .namespace ['NQP';'Compiler'] 20 | 21 | .sub '' :anon :load :init 22 | .local pmc p6meta, nqpproto 23 | p6meta = get_hll_global 'P6metaclass' 24 | nqpproto = p6meta.'new_class'('NQP::Compiler', 'parent'=>'HLL::Compiler') 25 | nqpproto.'language'('NQP-rx') 26 | $P0 = get_hll_global ['NQP'], 'Grammar' 27 | nqpproto.'parsegrammar'($P0) 28 | $P0 = get_hll_global ['NQP'], 'Actions' 29 | nqpproto.'parseactions'($P0) 30 | $P0 = getattribute nqpproto, '@cmdoptions' 31 | push $P0, 'parsetrace' 32 | .end 33 | 34 | .sub 'main' :main 35 | .param pmc args_str 36 | 37 | $P0 = compreg 'NQP-rx' 38 | $P1 = $P0.'command_line'(args_str, 'encoding'=>'utf8', 'transcode'=>'ascii iso-8859-1') 39 | exit 0 40 | .end 41 | 42 | # Local Variables: 43 | # mode: pir 44 | # fill-column: 100 45 | # End: 46 | # vim: expandtab shiftwidth=4 ft=pir: 47 | -------------------------------------------------------------------------------- /src/PAST/Regex.pir: -------------------------------------------------------------------------------- 1 | # $Id: Regex.pir 41578 2009-09-30 14:45:23Z pmichaud $ 2 | 3 | =head1 NAME 4 | 5 | PAST::Regex - Regex nodes for PAST 6 | 7 | =head1 DESCRIPTION 8 | 9 | This file implements the various abstract syntax tree nodes 10 | for regular expressions. 11 | 12 | =over 4 13 | 14 | =cut 15 | 16 | .namespace ['PAST';'Regex'] 17 | 18 | .sub '' :init :load 19 | load_bytecode 'PCT/PAST.pbc' 20 | .local pmc p6meta 21 | p6meta = get_hll_global 'P6metaclass' 22 | p6meta.'new_class'('PAST::Regex', 'parent'=>'PAST::Node') 23 | .end 24 | 25 | 26 | .sub 'backtrack' :method 27 | .param pmc value :optional 28 | .param int has_value :opt_flag 29 | .tailcall self.'attr'('backtrack', value, has_value) 30 | .end 31 | 32 | 33 | .sub 'capnames' :method 34 | .param pmc value :optional 35 | .param int has_value :opt_flag 36 | .tailcall self.'attr'('capnames', value, has_value) 37 | .end 38 | 39 | 40 | .sub 'negate' :method 41 | .param pmc value :optional 42 | .param int has_value :opt_flag 43 | .tailcall self.'attr'('negate', value, has_value) 44 | .end 45 | 46 | 47 | .sub 'min' :method 48 | .param pmc value :optional 49 | .param int has_value :opt_flag 50 | .tailcall self.'attr'('min', value, has_value) 51 | .end 52 | 53 | 54 | .sub 'max' :method 55 | .param pmc value :optional 56 | .param int has_value :opt_flag 57 | .tailcall self.'attr'('max', value, has_value) 58 | .end 59 | 60 | 61 | .sub 'pasttype' :method 62 | .param pmc value :optional 63 | .param int has_value :opt_flag 64 | .tailcall self.'attr'('pasttype', value, has_value) 65 | .end 66 | 67 | 68 | .sub 'sep' :method 69 | .param pmc value :optional 70 | .param int has_value :opt_flag 71 | .tailcall self.'attr'('sep', value, has_value) 72 | .end 73 | 74 | 75 | .sub 'subtype' :method 76 | .param pmc value :optional 77 | .param int has_value :opt_flag 78 | .tailcall self.'attr'('subtype', value, has_value) 79 | .end 80 | 81 | 82 | .sub 'zerowidth' :method 83 | .param pmc value :optional 84 | .param int has_value :opt_flag 85 | .tailcall self.'attr'('zerowidth', value, has_value) 86 | .end 87 | 88 | 89 | =item prefix() 90 | 91 | Returns the prefixes associated with the regex tree rooted 92 | at this node. 93 | 94 | =cut 95 | 96 | .sub 'prefix' :method 97 | .param string prefix 98 | .param pmc tail :slurpy 99 | 100 | .local string pasttype 101 | pasttype = self.'pasttype'() 102 | if pasttype goto have_pasttype 103 | pasttype = 'concat' 104 | have_pasttype: 105 | 106 | if pasttype == 'scan' goto prefix_skip 107 | 108 | $S0 = concat 'prefix_', pasttype 109 | $I0 = can self, $S0 110 | unless $I0 goto prefix_done 111 | .tailcall self.$S0(prefix, tail) 112 | 113 | prefix_skip: 114 | unless tail goto prefix_done 115 | .local pmc head 116 | head = shift tail 117 | .tailcall head.'prefix'(prefix, tail :flat) 118 | 119 | prefix_done: 120 | .return (prefix) 121 | .end 122 | 123 | 124 | .sub 'prefix_alt' :method 125 | .param string prefix 126 | .param pmc tail 127 | 128 | .local pmc child_it, results 129 | child_it = self.'iterator'() 130 | results = new ['ResizablePMCArray'] 131 | child_loop: 132 | unless child_it goto child_done 133 | $P0 = shift child_it 134 | ($P1 :slurpy) = $P0.'prefix'(prefix, tail :flat) 135 | splice results, $P1, 0, 0 136 | goto child_loop 137 | child_done: 138 | .return (results :flat) 139 | .end 140 | 141 | 142 | .sub 'prefix_alt_longest' :method 143 | .param string prefix 144 | .param pmc tail 145 | .tailcall self.'prefix_alt'(prefix, tail :flat) 146 | .end 147 | 148 | 149 | .sub 'prefix_anchor' :method 150 | .param string prefix 151 | .param pmc tail 152 | 153 | unless tail goto anchor_done 154 | .local pmc head 155 | head = shift tail 156 | .tailcall head.'prefix'(prefix, tail :flat) 157 | anchor_done: 158 | .return (prefix) 159 | .end 160 | 161 | 162 | .sub 'prefix_concat' :method 163 | .param string prefix 164 | .param pmc tail 165 | 166 | $P0 = self.'list'() 167 | splice tail, $P0, 0, 0 168 | unless tail goto done 169 | $P1 = shift tail 170 | .tailcall $P1.'prefix'(prefix, tail :flat) 171 | done: 172 | .return (prefix) 173 | .end 174 | 175 | 176 | .sub 'prefix_literal' :method 177 | .param string prefix 178 | .param pmc tail 179 | 180 | .local pmc lpast 181 | lpast = self[0] 182 | $I0 = isa lpast, ['String'] 183 | unless $I0 goto done 184 | 185 | .local string subtype 186 | subtype = self.'subtype'() 187 | if subtype == 'ignorecase' goto done 188 | 189 | $S0 = lpast 190 | prefix = concat prefix, $S0 191 | unless tail goto done 192 | $P0 = shift tail 193 | .tailcall $P0.'prefix'(prefix, tail :flat) 194 | 195 | done: 196 | .return (prefix) 197 | .end 198 | 199 | 200 | .sub 'prefix_enumcharlist' :method 201 | .param string prefix 202 | .param pmc tail 203 | 204 | .local pmc negate 205 | negate = self.'negate'() 206 | .local string subtype, charlist 207 | subtype = self.'subtype'() 208 | charlist = self[0] 209 | 210 | if negate goto charlist_negate 211 | 212 | unless tail goto charlist_notail 213 | if subtype == 'zerowidth' goto charlist_notail 214 | 215 | .local pmc result, head 216 | result = new ['ResizablePMCArray'] 217 | head = shift tail 218 | 219 | .local int pos, eos 220 | eos = length charlist 221 | pos = 0 222 | charlist_loop: 223 | unless pos < eos goto charlist_done 224 | .local string char 225 | char = substr charlist, pos, 1 226 | $S0 = concat prefix, char 227 | ($P0 :slurpy) = head.'prefix'($S0, tail :flat) 228 | splice result, $P0, 0, 0 229 | inc pos 230 | goto charlist_loop 231 | charlist_done: 232 | .return (result :flat) 233 | 234 | charlist_notail: 235 | $P0 = split '', charlist 236 | .return ($P0 :flat) 237 | 238 | charlist_negate: 239 | if subtype == 'zerowidth' goto charlist_negate_0 240 | unless tail goto charlist_negate_0 241 | .return (prefix) 242 | charlist_negate_0: 243 | head = shift tail 244 | .tailcall head.'prefix'(prefix, tail :flat) 245 | .end 246 | 247 | .sub 'prefix_pastnode' :method 248 | .param string prefix 249 | .param pmc tail 250 | 251 | unless tail goto pastnode_none 252 | .local string subtype 253 | subtype = self.'subtype'() 254 | if subtype != 'declarative' goto pastnode_none 255 | 256 | .local pmc head 257 | head = shift tail 258 | .tailcall head.'prefix'(prefix, tail :flat) 259 | 260 | pastnode_none: 261 | .return (prefix) 262 | .end 263 | 264 | .sub 'prefix_subcapture' :method 265 | .param string prefix 266 | .param pmc tail 267 | 268 | .tailcall self.'prefix_concat'(prefix, tail) 269 | .end 270 | 271 | .sub 'prefix_subrule' :method 272 | .param string prefix 273 | .param pmc tail 274 | 275 | .local pmc name, negate, subtype 276 | name = self[0] 277 | negate = self.'negate'() 278 | subtype = self.'subtype'() 279 | $I0 = does name, 'string' 280 | unless $I0 goto subrule_none 281 | if negate goto subrule_none 282 | if subtype == 'zerowidth' goto subrule_none 283 | 284 | .local pmc selfpast, spast 285 | $P99 = get_hll_global ['PAST'], 'Var' 286 | selfpast = $P99.'new'( 'name'=>'self', 'scope'=>'register') 287 | $P99 = get_hll_global ['PAST'], 'Op' 288 | spast = $P99.'new'( selfpast, name, prefix, 'name'=>'!PREFIX__!subrule', 'pasttype'=>'callmethod') 289 | .return (spast) 290 | 291 | subrule_none: 292 | .return (prefix) 293 | .end 294 | 295 | =back 296 | 297 | =head1 AUTHOR 298 | 299 | Patrick Michaud is the author and maintainer. 300 | Please send patches and suggestions to the Parrot porters or 301 | Perl 6 compilers mailing lists. 302 | 303 | =head1 COPYRIGHT 304 | 305 | Copyright (C) 2009, The Perl Foundation. 306 | 307 | =cut 308 | 309 | # Local Variables: 310 | # mode: pir 311 | # fill-column: 100 312 | # End: 313 | # vim: expandtab shiftwidth=4 ft=pir: 314 | -------------------------------------------------------------------------------- /src/Regex.pir: -------------------------------------------------------------------------------- 1 | # 2 | 3 | =head1 NAME 4 | 5 | Regex - Regex library 6 | 7 | =head1 DESCRIPTION 8 | 9 | This file brings together the various Regex modules needed for Regex.pbc . 10 | 11 | =cut 12 | 13 | .include 'src/Regex/Cursor.pir' 14 | .include 'src/Regex/Cursor-builtins.pir' 15 | .include 'src/Regex/Cursor-protoregex-peek.pir' 16 | .include 'src/Regex/Match.pir' 17 | .include 'src/Regex/Method.pir' 18 | .include 'src/Regex/Dumper.pir' 19 | 20 | .include 'src/PAST/Regex.pir' 21 | .include 'src/PAST/Compiler-Regex.pir' 22 | 23 | =head1 AUTHOR 24 | 25 | Patrick Michaud is the author and maintainer. 26 | 27 | =head1 COPYRIGHT 28 | 29 | Copyright (C) 2009, The Perl Foundation. 30 | 31 | =cut 32 | 33 | # Local Variables: 34 | # mode: pir 35 | # fill-column: 100 36 | # End: 37 | # vim: expandtab shiftwidth=4 ft=pir: 38 | -------------------------------------------------------------------------------- /src/Regex/Cursor-builtins.pir: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2009, The Perl Foundation. 2 | # 3 | 4 | =head1 NAME 5 | 6 | Regex::Cursor-builtins - builtin regexes for Cursor objects 7 | 8 | =cut 9 | 10 | .include 'cclass.pasm' 11 | 12 | .namespace ['Regex';'Cursor'] 13 | 14 | .sub 'before' :method 15 | .param pmc regex :optional 16 | .local pmc cur 17 | .local int pos 18 | (cur, pos) = self.'!cursor_start'() 19 | if null regex goto fail 20 | $P0 = cur.regex() 21 | unless $P0 goto fail 22 | cur.'!cursor_pass'(pos, 'before') 23 | fail: 24 | .return (cur) 25 | .end 26 | 27 | 28 | .sub 'ident' :method 29 | .local pmc cur 30 | .local int pos, eos 31 | .local string tgt 32 | (cur, pos, tgt) = self.'!cursor_start'() 33 | eos = length tgt 34 | $S0 = substr tgt, pos, 1 35 | if $S0 == '_' goto ident_1 36 | $I0 = is_cclass .CCLASS_ALPHABETIC, tgt, pos 37 | unless $I0 goto fail 38 | ident_1: 39 | pos = find_not_cclass .CCLASS_WORD, tgt, pos, eos 40 | cur.'!cursor_pass'(pos, 'ident') 41 | fail: 42 | .return (cur) 43 | .end 44 | 45 | .sub 'wb' :method 46 | .local pmc cur 47 | .local int pos, eos 48 | .local string tgt 49 | (cur, pos, tgt) = self.'!cursor_start'() 50 | if pos == 0 goto pass 51 | eos = length tgt 52 | if pos == eos goto pass 53 | $I0 = pos - 1 54 | $I1 = is_cclass .CCLASS_WORD, tgt, $I0 55 | $I2 = is_cclass .CCLASS_WORD, tgt, pos 56 | if $I1 == $I2 goto fail 57 | pass: 58 | cur.'!cursor_pass'(pos, 'wb') 59 | fail: 60 | .return (cur) 61 | .end 62 | 63 | .sub 'ww' :method 64 | .local pmc cur 65 | .local int pos, eos 66 | .local string tgt 67 | (cur, pos, tgt) = self.'!cursor_start'() 68 | .local pmc debug 69 | debug = getattribute cur, '$!debug' 70 | if null debug goto debug_1 71 | cur.'!cursor_debug'('START', 'ww') 72 | debug_1: 73 | if pos == 0 goto fail 74 | eos = length tgt 75 | if pos == eos goto fail 76 | $I0 = is_cclass .CCLASS_WORD, tgt, pos 77 | unless $I0 goto fail 78 | $I1 = pos - 1 79 | $I0 = is_cclass .CCLASS_WORD, tgt, $I1 80 | unless $I0 goto fail 81 | pass: 82 | cur.'!cursor_pass'(pos, 'ww') 83 | if null debug goto done 84 | cur.'!cursor_debug'('PASS', 'ww') 85 | goto done 86 | fail: 87 | if null debug goto done 88 | cur.'!cursor_debug'('FAIL', 'ww') 89 | done: 90 | .return (cur) 91 | .end 92 | 93 | .sub 'ws' :method 94 | .local pmc cur 95 | .local int pos, eos 96 | .local string tgt 97 | (cur, pos, tgt) = self.'!cursor_start'() 98 | eos = length tgt 99 | if pos >= eos goto pass 100 | if pos == 0 goto ws_scan 101 | $I0 = is_cclass .CCLASS_WORD, tgt, pos 102 | unless $I0 goto ws_scan 103 | $I1 = pos - 1 104 | $I0 = is_cclass .CCLASS_WORD, tgt, $I1 105 | if $I0 goto fail 106 | ws_scan: 107 | pos = find_not_cclass .CCLASS_WHITESPACE, tgt, pos, eos 108 | pass: 109 | cur.'!cursor_pass'(pos, 'ws') 110 | fail: 111 | .return (cur) 112 | .end 113 | 114 | .sub '!cclass' :anon 115 | .param pmc self 116 | .param string name 117 | .param int cclass 118 | .local pmc cur 119 | .local int pos 120 | .local string tgt 121 | (cur, pos, tgt) = self.'!cursor_start'() 122 | .local pmc debug 123 | debug = getattribute cur, '$!debug' 124 | if null debug goto debug_1 125 | cur.'!cursor_debug'('START', name) 126 | debug_1: 127 | $I0 = is_cclass cclass, tgt, pos 128 | unless $I0 goto fail 129 | inc pos 130 | pass: 131 | cur.'!cursor_pass'(pos, name) 132 | if null debug goto done 133 | cur.'!cursor_debug'('PASS', name) 134 | goto done 135 | fail: 136 | if null debug goto done 137 | cur.'!cursor_debug'('FAIL', name) 138 | done: 139 | .return (cur) 140 | .end 141 | 142 | .sub 'alpha' :method 143 | .local pmc cur 144 | .local int pos 145 | .local string tgt 146 | (cur, pos, tgt) = self.'!cursor_start'() 147 | .local pmc debug 148 | debug = getattribute cur, '$!debug' 149 | if null debug goto debug_1 150 | cur.'!cursor_debug'('START', 'alpha') 151 | debug_1: 152 | $I0 = is_cclass .CCLASS_ALPHABETIC, tgt, pos 153 | if $I0 goto pass 154 | 155 | $I0 = length tgt 156 | if pos >= $I0 goto fail 157 | 158 | $S0 = substr tgt, pos, 1 159 | if $S0 != '_' goto fail 160 | pass: 161 | inc pos 162 | cur.'!cursor_pass'(pos, 'alpha') 163 | if null debug goto done 164 | cur.'!cursor_debug'('PASS', 'alpha') 165 | goto done 166 | fail: 167 | if null debug goto done 168 | cur.'!cursor_debug'('FAIL', 'alpha') 169 | done: 170 | .return (cur) 171 | .end 172 | 173 | .sub 'upper' :method 174 | .tailcall '!cclass'(self, 'upper', .CCLASS_UPPERCASE) 175 | .end 176 | 177 | .sub 'lower' :method 178 | .tailcall '!cclass'(self, 'lower', .CCLASS_LOWERCASE) 179 | .end 180 | 181 | .sub 'digit' :method 182 | .tailcall '!cclass'(self, 'digit', .CCLASS_NUMERIC) 183 | .end 184 | 185 | .sub 'xdigit' :method 186 | .tailcall '!cclass'(self, 'xdigit', .CCLASS_HEXADECIMAL) 187 | .end 188 | 189 | .sub 'print' :method 190 | .tailcall '!cclass'(self, 'print', .CCLASS_PRINTING) 191 | .end 192 | 193 | .sub 'graph' :method 194 | .tailcall '!cclass'(self, 'graph', .CCLASS_GRAPHICAL) 195 | .end 196 | 197 | .sub 'cntrl' :method 198 | .tailcall '!cclass'(self, 'cntrl', .CCLASS_CONTROL) 199 | .end 200 | 201 | .sub 'punct' :method 202 | .tailcall '!cclass'(self, 'punct', .CCLASS_PUNCTUATION) 203 | .end 204 | 205 | .sub 'alnum' :method 206 | .tailcall '!cclass'(self, 'alnum', .CCLASS_ALPHANUMERIC) 207 | .end 208 | 209 | .sub 'space' :method 210 | .tailcall '!cclass'(self, 'space', .CCLASS_WHITESPACE) 211 | .end 212 | 213 | .sub 'blank' :method 214 | .tailcall '!cclass'(self, 'blank', .CCLASS_BLANK) 215 | .end 216 | 217 | .sub 'FAILGOAL' :method 218 | .param string goal 219 | .local string dba 220 | $P0 = getinterp 221 | $P0 = $P0['sub';1] 222 | dba = $P0 223 | have_dba: 224 | .local string message 225 | message = concat "Unable to parse ", dba 226 | message .= ", couldn't find final " 227 | message .= goal 228 | message .= ' at line ' 229 | $P0 = getattribute self, '$!target' 230 | $P1 = get_hll_global ['HLL'], 'Compiler' 231 | $I0 = self.'pos'() 232 | $I0 = $P1.'lineof'($P0, $I0) 233 | inc $I0 234 | $S0 = $I0 235 | message .= $S0 236 | have_line: 237 | die message 238 | .end 239 | 240 | .sub 'DEBUG' :method 241 | .param pmc arg :optional 242 | .param int has_arg :opt_flag 243 | 244 | if has_arg goto have_arg 245 | arg = get_global '$!TRUE' 246 | have_arg: 247 | 248 | setattribute self, '$!debug', arg 249 | .return (1) 250 | .end 251 | 252 | =head1 AUTHORS 253 | 254 | Patrick Michaud is the author and maintainer. 255 | 256 | =cut 257 | 258 | # Local Variables: 259 | # mode: pir 260 | # fill-column: 100 261 | # End: 262 | # vim: expandtab shiftwidth=4 ft=pir: 263 | -------------------------------------------------------------------------------- /src/Regex/Dumper.pir: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2005-2009, Parrot Foundation. 2 | # Copyright (C) 2009, The Perl Foundation. 3 | # 4 | 5 | =head1 TITLE 6 | 7 | Regex::Dumper - various methods for displaying Match structures 8 | 9 | =head2 C Methods 10 | 11 | =over 4 12 | 13 | =item C<__dump(PMC dumper, STR label)> 14 | 15 | This method enables Data::Dumper to work on Regex::Match objects. 16 | 17 | =cut 18 | 19 | .namespace ['Regex';'Match'] 20 | 21 | .sub "__dump" :method 22 | .param pmc dumper 23 | .param string label 24 | .local string indent, subindent 25 | .local pmc it, val 26 | .local string key 27 | .local pmc hash, array 28 | .local int hascapts 29 | 30 | (subindent, indent) = dumper."newIndent"() 31 | print "=> " 32 | $S0 = self 33 | dumper."genericString"("", $S0) 34 | print " @ " 35 | $I0 = self.'from'() 36 | print $I0 37 | hascapts = 0 38 | hash = self.'hash'() 39 | if_null hash, dump_array 40 | it = iter hash 41 | dump_hash_1: 42 | unless it goto dump_array 43 | if hascapts goto dump_hash_2 44 | print " {" 45 | hascapts = 1 46 | dump_hash_2: 47 | print "\n" 48 | print subindent 49 | key = shift it 50 | val = hash[key] 51 | print "<" 52 | print key 53 | print "> => " 54 | dumper."dump"(label, val) 55 | goto dump_hash_1 56 | dump_array: 57 | array = self.'list'() 58 | if_null array, dump_end 59 | $I1 = elements array 60 | $I0 = 0 61 | dump_array_1: 62 | if $I0 >= $I1 goto dump_end 63 | if hascapts goto dump_array_2 64 | print " {" 65 | hascapts = 1 66 | dump_array_2: 67 | print "\n" 68 | print subindent 69 | val = array[$I0] 70 | print "[" 71 | print $I0 72 | print "] => " 73 | dumper."dump"(label, val) 74 | inc $I0 75 | goto dump_array_1 76 | dump_end: 77 | unless hascapts goto end 78 | print "\n" 79 | print indent 80 | print "}" 81 | end: 82 | dumper."deleteIndent"() 83 | .end 84 | 85 | 86 | =item C 87 | 88 | An alternate dump output for a Match object and all of its subcaptures. 89 | 90 | =cut 91 | 92 | .sub "dump_str" :method 93 | .param string prefix :optional # name of match variable 94 | .param int has_prefix :opt_flag 95 | .param string b1 :optional # bracket open 96 | .param int has_b1 :opt_flag 97 | .param string b2 :optional # bracket close 98 | .param int has_b2 :opt_flag 99 | 100 | .local pmc capt 101 | .local int spi, spc 102 | .local pmc it 103 | .local string prefix1, prefix2 104 | .local pmc jmpstack 105 | jmpstack = new 'ResizableIntegerArray' 106 | 107 | if has_b2 goto start 108 | b2 = "]" 109 | if has_b1 goto start 110 | b1 = "[" 111 | start: 112 | .local string out 113 | out = concat prefix, ':' 114 | unless self goto subpats 115 | out .= ' <' 116 | $S0 = self 117 | out .= $S0 118 | out .= ' @ ' 119 | $S0 = self.'from'() 120 | out .= $S0 121 | out .= '> ' 122 | 123 | subpats: 124 | $I0 = self 125 | $S0 = $I0 126 | out .= $S0 127 | out .= "\n" 128 | capt = self.'list'() 129 | if_null capt, subrules 130 | spi = 0 131 | spc = elements capt 132 | subpats_1: 133 | unless spi < spc goto subrules 134 | prefix1 = concat prefix, b1 135 | $S0 = spi 136 | prefix1 = concat prefix1, $S0 137 | prefix1 = concat prefix1, b2 138 | $I0 = defined capt[spi] 139 | unless $I0 goto subpats_2 140 | $P0 = capt[spi] 141 | local_branch jmpstack, dumper 142 | subpats_2: 143 | inc spi 144 | goto subpats_1 145 | 146 | subrules: 147 | capt = self.'hash'() 148 | if_null capt, end 149 | it = iter capt 150 | subrules_1: 151 | unless it goto end 152 | $S0 = shift it 153 | prefix1 = concat prefix, '<' 154 | prefix1 = concat prefix1, $S0 155 | prefix1 = concat prefix1, ">" 156 | $I0 = defined capt[$S0] 157 | unless $I0 goto subrules_1 158 | $P0 = capt[$S0] 159 | local_branch jmpstack, dumper 160 | goto subrules_1 161 | 162 | dumper: 163 | $I0 = isa $P0, ['Regex';'Match'] 164 | unless $I0 goto dumper_0 165 | $S0 = $P0.'dump_str'(prefix1, b1, b2) 166 | out .= $S0 167 | local_return jmpstack 168 | dumper_0: 169 | $I0 = does $P0, 'array' 170 | unless $I0 goto dumper_3 171 | $I0 = 0 172 | $I1 = elements $P0 173 | dumper_1: 174 | if $I0 >= $I1 goto dumper_2 175 | $P1 = $P0[$I0] 176 | prefix2 = concat prefix1, b1 177 | $S0 = $I0 178 | prefix2 = concat prefix2, $S0 179 | prefix2 = concat prefix2, b2 180 | $S0 = $P1.'dump_str'(prefix2, b1, b2) 181 | out .= $S0 182 | inc $I0 183 | goto dumper_1 184 | dumper_2: 185 | local_return jmpstack 186 | dumper_3: 187 | out .= prefix1 188 | out .= ': ' 189 | $S0 = $P0 190 | out .= $S0 191 | out .= "\n" 192 | local_return jmpstack 193 | 194 | end: 195 | .return (out) 196 | .end 197 | 198 | 199 | =back 200 | 201 | =cut 202 | 203 | # Local Variables: 204 | # mode: pir 205 | # fill-column: 100 206 | # End: 207 | # vim: expandtab shiftwidth=4 ft=pir: 208 | -------------------------------------------------------------------------------- /src/Regex/Match.pir: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2009, The Perl Foundation. 2 | # 3 | 4 | =head1 NAME 5 | 6 | Regex::Match - Regex Match objects 7 | 8 | =head1 DESCRIPTION 9 | 10 | This file implements Match objects for the regex engine. 11 | 12 | =cut 13 | 14 | .namespace ['Regex';'Match'] 15 | 16 | .sub '' :anon :load :init 17 | load_bytecode 'P6object.pbc' 18 | .local pmc p6meta 19 | p6meta = new 'P6metaclass' 20 | $P0 = p6meta.'new_class'('Regex::Match', 'parent'=>'Capture', 'attr'=>'$!cursor $!target $!from $!to $!ast') 21 | .return () 22 | .end 23 | 24 | =head2 Methods 25 | 26 | =over 4 27 | 28 | =item CURSOR() 29 | 30 | Returns the Cursor associated with this match object. 31 | 32 | =cut 33 | 34 | .sub 'CURSOR' :method 35 | $P0 = getattribute self, '$!cursor' 36 | .return ($P0) 37 | .end 38 | 39 | =item from() 40 | 41 | Returns the offset in the target string of the beginning of the match. 42 | 43 | =cut 44 | 45 | .sub 'from' :method 46 | $P0 = getattribute self, '$!from' 47 | .return ($P0) 48 | .end 49 | 50 | 51 | =item to() 52 | 53 | Returns the offset in the target string of the end of the match. 54 | 55 | =cut 56 | 57 | .sub 'to' :method 58 | $P0 = getattribute self, '$!to' 59 | .return ($P0) 60 | .end 61 | 62 | 63 | =item chars() 64 | 65 | Returns C<.to() - .from()> 66 | 67 | =cut 68 | 69 | .sub 'chars' :method 70 | $I0 = self.'to'() 71 | $I1 = self.'from'() 72 | $I2 = $I0 - $I1 73 | if $I2 >= 0 goto done 74 | .return (0) 75 | done: 76 | .return ($I2) 77 | .end 78 | 79 | 80 | =item orig() 81 | 82 | Return the original item that was matched against. 83 | 84 | =cut 85 | 86 | .sub 'orig' :method 87 | $P0 = getattribute self, '$!target' 88 | .return ($P0) 89 | .end 90 | 91 | 92 | =item Str() 93 | 94 | Returns the portion of the target corresponding to this match. 95 | 96 | =cut 97 | 98 | .sub 'Str' :method 99 | $S0 = self.'orig'() 100 | $I0 = self.'from'() 101 | $I1 = self.'to'() 102 | $I1 -= $I0 103 | $S1 = substr $S0, $I0, $I1 104 | .return ($S1) 105 | .end 106 | 107 | 108 | =item ast() 109 | 110 | Returns the "abstract object" for the Match; if no abstract object 111 | has been set then returns C above. 112 | 113 | =cut 114 | 115 | .sub 'ast' :method 116 | .local pmc ast 117 | ast = getattribute self, '$!ast' 118 | unless null ast goto have_ast 119 | ast = new ['Undef'] 120 | setattribute self, '$!ast', ast 121 | have_ast: 122 | .return (ast) 123 | .end 124 | 125 | =back 126 | 127 | =head2 Vtable functions 128 | 129 | =over 4 130 | 131 | =item get_bool() 132 | 133 | Returns 1 (true) if this is the result of a successful match, 134 | otherwise returns 0 (false). 135 | 136 | =cut 137 | 138 | .sub '' :vtable('get_bool') :method 139 | $P0 = getattribute self, '$!from' 140 | $P1 = getattribute self, '$!to' 141 | $I0 = isge $P1, $P0 142 | .return ($I0) 143 | .end 144 | 145 | 146 | =item get_integer() 147 | 148 | Returns the integer value of the matched text. 149 | 150 | =cut 151 | 152 | .sub '' :vtable('get_integer') :method 153 | $I0 = self.'Str'() 154 | .return ($I0) 155 | .end 156 | 157 | 158 | =item get_number() 159 | 160 | Returns the numeric value of this match 161 | 162 | =cut 163 | 164 | .sub '' :vtable('get_number') :method 165 | $N0 = self.'Str'() 166 | .return ($N0) 167 | .end 168 | 169 | 170 | =item get_string() 171 | 172 | Returns the string value of the match 173 | 174 | =cut 175 | 176 | .sub '' :vtable('get_string') :method 177 | $S0 = self.'Str'() 178 | .return ($S0) 179 | .end 180 | 181 | 182 | =item !make(obj) 183 | 184 | Set the "ast object" for the invocant. 185 | 186 | =cut 187 | 188 | .sub '!make' :method 189 | .param pmc obj 190 | setattribute self, '$!ast', obj 191 | .return (obj) 192 | .end 193 | 194 | 195 | =back 196 | 197 | =head1 AUTHORS 198 | 199 | Patrick Michaud is the author and maintainer. 200 | 201 | =cut 202 | 203 | # Local Variables: 204 | # mode: pir 205 | # fill-column: 100 206 | # End: 207 | # vim: expandtab shiftwidth=4 ft=pir: 208 | -------------------------------------------------------------------------------- /src/Regex/Method.pir: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2009, The Perl Foundation. 2 | # 3 | 4 | =head1 NAME 5 | 6 | Regex::Regex, Regex::Method - Regex subs 7 | 8 | =head1 DESCRIPTION 9 | 10 | This file implements the Regex::Method and Regex::Regex types, used as 11 | containers for Regex subs that need .ACCEPTS and other regex attributes. 12 | 13 | =cut 14 | 15 | .namespace ['Regex';'Method'] 16 | 17 | .sub '' :anon :load :init 18 | load_bytecode 'P6object.pbc' 19 | .local pmc p6meta, mproto, rproto 20 | p6meta = new 'P6metaclass' 21 | mproto = p6meta.'new_class'('Regex::Method', 'parent'=>'parrot;Sub') 22 | rproto = p6meta.'new_class'('Regex::Regex', 'parent'=>mproto) 23 | .end 24 | 25 | =head2 Methods 26 | 27 | =over 4 28 | 29 | =item new(sub) 30 | 31 | Create a new Regex::Regex object from C. 32 | 33 | =cut 34 | 35 | .sub 'new' :method 36 | .param pmc parrotsub 37 | $P0 = self.'WHO'() 38 | $P0 = new $P0 39 | assign $P0, parrotsub 40 | .return ($P0) 41 | .end 42 | 43 | 44 | =item ACCEPTS(target) 45 | 46 | Perform a match against target, return the result. 47 | 48 | =cut 49 | 50 | .sub 'ACCEPTS' :method 51 | .param pmc target 52 | 53 | .local pmc curproto, match 54 | curproto = get_hll_global ['Regex'], 'Cursor' 55 | match = curproto.'parse'(target, 'rule'=>self) 56 | .return (match) 57 | .end 58 | 59 | .namespace ['Regex';'Regex'] 60 | 61 | .sub 'ACCEPTS' :method 62 | .param pmc target 63 | 64 | .local pmc curproto, match 65 | curproto = get_hll_global ['Regex'], 'Cursor' 66 | match = curproto.'parse'(target, 'rule'=>self, 'c'=>0) 67 | .return (match) 68 | .end 69 | 70 | 71 | =back 72 | 73 | =head1 AUTHORS 74 | 75 | Patrick Michaud is the author and maintainer. 76 | 77 | =cut 78 | 79 | # Local Variables: 80 | # mode: pir 81 | # fill-column: 100 82 | # End: 83 | # vim: expandtab shiftwidth=4 ft=pir: 84 | -------------------------------------------------------------------------------- /src/Regex/P6Regex.pir: -------------------------------------------------------------------------------- 1 | # Copyright (C) 2009, The Perl Foundation. 2 | # 3 | 4 | =head1 NAME 5 | 6 | Regex::P6Regex - Parser/compiler for Perl 6 regexes 7 | 8 | =head1 DESCRIPTION 9 | 10 | =cut 11 | 12 | .sub '' :anon :load :init 13 | load_bytecode 'HLL.pbc' 14 | .end 15 | 16 | .include 'gen/p6regex-grammar.pir' 17 | .include 'gen/p6regex-actions.pir' 18 | # .include 'src/cheats/p6regex-grammar.pir' 19 | 20 | .namespace ['Regex';'P6Regex';'Compiler'] 21 | 22 | .sub '' :anon :load :init 23 | .local pmc p6meta, p6regex 24 | p6meta = get_hll_global 'P6metaclass' 25 | p6regex = p6meta.'new_class'('Regex::P6Regex::Compiler', 'parent'=>'HLL::Compiler') 26 | p6regex.'language'('Regex::P6Regex') 27 | $P0 = get_hll_global ['Regex';'P6Regex'], 'Grammar' 28 | p6regex.'parsegrammar'($P0) 29 | $P0 = get_hll_global ['Regex';'P6Regex'], 'Actions' 30 | p6regex.'parseactions'($P0) 31 | .end 32 | 33 | 34 | .sub 'main' :main 35 | .param pmc args_str 36 | 37 | $P0 = compreg 'Regex::P6Regex' 38 | $P1 = $P0.'command_line'(args_str, 'encoding'=>'utf8', 'transcode'=>'ascii iso-8859-1') 39 | exit 0 40 | .end 41 | 42 | 43 | # Local Variables: 44 | # mode: pir 45 | # fill-column: 100 46 | # End: 47 | # vim: expandtab shiftwidth=4 ft=pir: 48 | -------------------------------------------------------------------------------- /src/Regex/P6Regex/Grammar.pm: -------------------------------------------------------------------------------- 1 | grammar Regex::P6Regex::Grammar is HLL::Grammar; 2 | 3 | method obs ($old, $new, $when = ' in Perl 6') { 4 | self.panic('Unsupported use of ' ~ ~$old ~ ';' 5 | ~ ~$when ~ ' please use ' ~ ~$new); 6 | } 7 | 8 | token ws { [ \s+ | '#' \N* ]* } 9 | 10 | token normspace { <.ws> } 11 | 12 | token identifier { <.ident> [ <[\-']> <.ident> ]* } 13 | 14 | token arg { 15 | [ 16 | | 17 | | 18 | | $=[\d+] 19 | ] 20 | } 21 | 22 | rule arglist { [ ',' ]* } 23 | 24 | token TOP { 25 | 26 | [ $ || <.panic: 'Confused'> ] 27 | } 28 | 29 | token nibbler { 30 | {*} #= open 31 | [ <.ws> ['||'|'|'|'&&'|'&'] ]? 32 | 33 | [ ['||'|'|'] 34 | [ || <.panic: 'Null pattern not allowed'> ] 35 | ]* 36 | } 37 | 38 | token termconj { 39 | 40 | [ ['&&'|'&'] 41 | [ || <.panic: 'Null pattern not allowed'> ] 42 | ]* 43 | } 44 | 45 | token termish { 46 | + 47 | } 48 | 49 | token quantified_atom { 50 | [ <.ws> [ | ] ]? 51 | } 52 | 53 | token atom { 54 | # :dba('regex atom') 55 | [ 56 | | \w [ \w+! ]? 57 | | 58 | ] 59 | } 60 | 61 | proto token quantifier { <...> } 62 | token quantifier:sym<*> { } 63 | token quantifier:sym<+> { } 64 | token quantifier:sym { } 65 | token quantifier:sym<{N,M}> { {} '{' (\d+) (','?) (\d*) '}' 66 | <.obs: '{N,M} as general quantifier', '** N..M (or ** N..*)'> 67 | } 68 | token quantifier:sym<**> { 69 | ? ? 70 | [ 71 | || $=[\d+] 72 | [ '..' 73 | $=[ 74 | || \d+ 75 | || '*' 76 | || <.panic: "Only integers or '*' allowed as range quantifier endpoint"> 77 | ] 78 | ]? 79 | || 80 | ] 81 | } 82 | 83 | token backmod { ':'? [ '?' | '!' | ] } 84 | 85 | proto token metachar { <...> } 86 | token metachar:sym { <.normspace> } 87 | token metachar:sym<[ ]> { '[' ']' } 88 | token metachar:sym<( )> { '(' ')' } 89 | token metachar:sym<'> { } 90 | token metachar:sym<"> { } 91 | token metachar:sym<.> { } 92 | token metachar:sym<^> { } 93 | token metachar:sym<^^> { } 94 | token metachar:sym<$> { } 95 | token metachar:sym<$$> { } 96 | token metachar:sym<:::> { <.panic: '::: not yet implemented'> } 97 | token metachar:sym<::> { <.panic: ':: not yet implemented'> } 98 | token metachar:sym { $=['<<'|'«'] } 99 | token metachar:sym { $=['>>'|'»'] } 100 | token metachar:sym { \\ } 101 | token metachar:sym { } 102 | token metachar:sym { 103 | <.panic: 'Quantifier quantifies nothing'> 104 | } 105 | 106 | ## we cheat here, really should be regex_infix:sym<~> 107 | token metachar:sym<~> { 108 | 109 | <.ws> 110 | <.ws> 111 | } 112 | 113 | token metachar:sym<{*}> { 114 | 115 | [ \h* '#= ' \h* $=[\S+ [\h+ \S+]*] ]? 116 | } 117 | token metachar:sym { 118 | '<' 119 | [ '>' || <.panic: 'regex assertion not terminated by angle bracket'> ] 120 | } 121 | 122 | token metachar:sym { 123 | [ 124 | | '$<' $=[<-[>]>+] '>' 125 | | '$' $=[\d+] 126 | ] 127 | 128 | [ <.ws> '=' <.ws> ]? 129 | } 130 | 131 | token metachar:sym { 132 | ':PIR{{' $=[.*?] '}}' 133 | } 134 | 135 | proto token backslash { <...> } 136 | token backslash:sym { $=[<[dswnDSWN]>] } 137 | token backslash:sym { $=[<[bB]>] } 138 | token backslash:sym { $=[<[eE]>] } 139 | token backslash:sym { $=[<[fF]>] } 140 | token backslash:sym { $=[<[hH]>] } 141 | token backslash:sym { $=[<[rR]>] } 142 | token backslash:sym { $=[<[tT]>] } 143 | token backslash:sym { $=[<[vV]>] } 144 | token backslash:sym { $=[<[oO]>] [ | '[' ']' ] } 145 | token backslash:sym { $=[<[xX]>] [ | '[' ']' ] } 146 | token backslash:sym { $=[<[cC]>] } 147 | token backslash:sym { 'A' <.obs: '\\A as beginning-of-string matcher', '^'> } 148 | token backslash:sym { 'z' <.obs: '\\z as end-of-string matcher', '$'> } 149 | token backslash:sym { 'Z' <.obs: '\\Z as end-of-string matcher', '\\n?$'> } 150 | token backslash:sym { 'Q' <.obs: '\\Q as quotemeta', 'quotes or literal variable match'> } 151 | token backslash:sym { {} \w <.panic: 'Unrecognized backslash sequence'> } 152 | token backslash:sym { \W } 153 | 154 | proto token assertion { <...> } 155 | 156 | token assertion:sym { '?' [ ' > | ] } 157 | token assertion:sym { '!' [ ' > | ] } 158 | 159 | token assertion:sym { 160 | '.' 161 | } 162 | 163 | token assertion:sym { 164 | 165 | [ 166 | | '> 167 | | '=' 168 | | ':' 169 | | '(' ')' 170 | | <.normspace> 171 | ]? 172 | } 173 | 174 | token assertion:sym<[> { + } 175 | 176 | token cclass_elem { 177 | $=['+'|'-'|] 178 | <.normspace>? 179 | [ 180 | | '[' $=( 181 | | \s* '-' <.obs: '- as character range','..'> 182 | | \s* [ \\ (.) | (<-[\]\\]>) ] [ \s* '..' \s* (.) ]? 183 | )* 184 | \s* ']' 185 | | $=[\w+] 186 | ] 187 | <.normspace>? 188 | } 189 | 190 | token mod_internal { 191 | [ 192 | | ':' $=('!' | \d+)**1 » 193 | | ':' [ '(' $=[\d+] ')' ]? 194 | ] 195 | } 196 | 197 | proto token mod_ident { <...> } 198 | token mod_ident:sym { $=[i] 'gnorecase'? } 199 | token mod_ident:sym { $=[r] 'atchet'? } 200 | token mod_ident:sym { $=[s] 'igspace'? } 201 | -------------------------------------------------------------------------------- /src/Regex/constants.pir: -------------------------------------------------------------------------------- 1 | .const int CURSOR_FAIL = -1 2 | .const int CURSOR_FAIL_GROUP = -2 3 | .const int CURSOR_FAIL_RULE = -3 4 | .const int CURSOR_FAIL_MATCH = -4 5 | 6 | .const int CURSOR_TYPE_SCAN = 1 7 | .const int CURSOR_TYPE_PEEK = 2 8 | -------------------------------------------------------------------------------- /src/cheats/hll-compiler.pir: -------------------------------------------------------------------------------- 1 | # we have to overload PCT::HLLCompiler's parse method to support P6Regex grammars 2 | 3 | .include 'cclass.pasm' 4 | 5 | .namespace ['HLL';'Compiler'] 6 | 7 | .sub 'parse' :method 8 | .param pmc source 9 | .param pmc options :slurpy :named 10 | 11 | .local string tcode 12 | tcode = options['transcode'] 13 | unless tcode goto transcode_done 14 | .local pmc tcode_it 15 | $P0 = split ' ', tcode 16 | tcode_it = iter $P0 17 | tcode_loop: 18 | unless tcode_it goto transcode_done 19 | tcode = shift tcode_it 20 | push_eh tcode_fail 21 | $I0 = find_encoding tcode 22 | $S0 = source 23 | $S0 = trans_encoding $S0, $I0 24 | assign source, $S0 25 | pop_eh 26 | goto transcode_done 27 | tcode_fail: 28 | pop_eh 29 | goto tcode_loop 30 | transcode_done: 31 | 32 | .local pmc parsegrammar, parseactions, match 33 | parsegrammar = self.'parsegrammar'() 34 | 35 | null parseactions 36 | $S0 = options['target'] 37 | if $S0 == 'parse' goto have_parseactions 38 | parseactions = self.'parseactions'() 39 | have_parseactions: 40 | 41 | .local int rxtrace 42 | rxtrace = options['parsetrace'] 43 | match = parsegrammar.'parse'(source, 'p'=>0, 'actions'=>parseactions, 'rxtrace'=>rxtrace) 44 | unless match goto err_parsefail 45 | .return (match) 46 | 47 | err_parsefail: 48 | self.'panic'('Unable to parse source') 49 | .return (match) 50 | .end 51 | 52 | 53 | .sub 'pir' :method 54 | .param pmc source 55 | .param pmc adverbs :slurpy :named 56 | 57 | $P0 = compreg 'POST' 58 | $S0 = $P0.'to_pir'(source, adverbs :flat :named) 59 | .return ($S0) 60 | .end 61 | 62 | 63 | .sub 'parse_name' :method 64 | .param string name 65 | 66 | # split name on :: 67 | .local pmc ns 68 | ns = split '::', name 69 | 70 | # move any leading sigil to the last item 71 | .local string sigil 72 | $S0 = ns[0] 73 | sigil = substr $S0, 0, 1 74 | $I0 = index '$@%&', sigil 75 | if $I0 < 0 goto sigil_done 76 | $S0 = replace $S0, 0, 1, '' 77 | ns[0] = $S0 78 | $S0 = ns[-1] 79 | $S0 = concat sigil, $S0 80 | ns[-1] = $S0 81 | sigil_done: 82 | 83 | # remove any empty items from the list 84 | .local pmc ns_it 85 | ns_it = iter ns 86 | ns = new ['ResizablePMCArray'] 87 | ns_loop: 88 | unless ns_it goto ns_done 89 | $S0 = shift ns_it 90 | unless $S0 > '' goto ns_loop 91 | push ns, $S0 92 | goto ns_loop 93 | ns_done: 94 | 95 | # return the result 96 | .return (ns) 97 | .end 98 | 99 | 100 | # Temporarily backport PCT::HLLCompiler's 'lineof' method 101 | # from Parrot r48866 into HLL::Compiler, so that nqp-rx can 102 | # continue to build from an older Parrot until parrot's trunk 103 | # is working again. When we're able to bump PARROT_REVISION, 104 | # this code can go away to fall back to Parrot's version (DRY). 105 | =item lineof(target, pos [, cache :named('cache')]) 106 | 107 | Return the line number of offset C within C. The return 108 | value uses zero for the first line. If C is true, then 109 | memoize the line offsets as a C property on C. 110 | 111 | =cut 112 | 113 | .sub 'lineof' :method 114 | .param pmc target 115 | .param int pos 116 | .param int cache :optional :named('cache') 117 | .local pmc linepos 118 | 119 | # If we've previously cached C for target, we use it. 120 | unless cache goto linepos_build 121 | linepos = getprop '!linepos', target 122 | unless null linepos goto linepos_done 123 | 124 | # calculate a new linepos array. 125 | linepos_build: 126 | linepos = new ['ResizableIntegerArray'] 127 | unless cache goto linepos_build_1 128 | setprop target, '!linepos', linepos 129 | linepos_build_1: 130 | .local string s 131 | .local int jpos, eos 132 | s = target 133 | eos = length s 134 | jpos = 0 135 | # Search for all of the newline markers in C. When we 136 | # find one, mark the ending offset of the line in C. 137 | linepos_loop: 138 | jpos = find_cclass .CCLASS_NEWLINE, s, jpos, eos 139 | unless jpos < eos goto linepos_done 140 | $I0 = ord s, jpos 141 | inc jpos 142 | push linepos, jpos 143 | # Treat \r\n as a single logical newline. 144 | if $I0 != 13 goto linepos_loop 145 | $I0 = ord s, jpos 146 | if $I0 != 10 goto linepos_loop 147 | inc jpos 148 | goto linepos_loop 149 | linepos_done: 150 | 151 | # We have C, so now we search the array for the largest 152 | # element that is not greater than C. The index of that 153 | # element is the line number to be returned. 154 | # (Potential optimization: use a binary search.) 155 | .local int line, count 156 | count = elements linepos 157 | line = 0 158 | line_loop: 159 | if line >= count goto line_done 160 | $I0 = linepos[line] 161 | if $I0 > pos goto line_done 162 | inc line 163 | goto line_loop 164 | line_done: 165 | .return (line) 166 | .end 167 | 168 | 169 | # This sub serves as a cumulative "outer context" for code 170 | # executed in HLL::Compiler's interactive REPL. It's invoked 171 | # exactly once upon load/init to obtain a context, and its 172 | # default LexPad is replaced with a Hash that we can use to 173 | # cumulatively store outer context information. Both the 174 | # context and hash are then made available via package 175 | # variables. 176 | .namespace [] 177 | .sub '&interactive_outer' :lex :init :load 178 | .local pmc ctx, pad 179 | $P0 = getinterp 180 | ctx = $P0['context'] 181 | set_global ['HLL';'Compiler'], '$interactive_ctx', ctx 182 | pad = getattribute ctx, 'lex_pad' 183 | $P1 = new ['Hash'] 184 | copy pad, $P1 185 | set_global ['HLL';'Compiler'], '%interactive_pad', pad 186 | .end 187 | 188 | -------------------------------------------------------------------------------- /src/cheats/nqp-builtins.pir: -------------------------------------------------------------------------------- 1 | .namespace [] 2 | 3 | .sub 'print' 4 | .param pmc list :slurpy 5 | .local pmc list_it 6 | list_it = iter list 7 | list_loop: 8 | unless list_it goto list_done 9 | $P0 = shift list_it 10 | print $P0 11 | goto list_loop 12 | list_done: 13 | .return (1) 14 | .end 15 | 16 | .sub 'say' 17 | .param pmc list :slurpy 18 | .tailcall 'print'(list :flat, "\n") 19 | .end 20 | 21 | .sub 'ok' 22 | .param pmc condition 23 | .param string description :optional 24 | .param int has_desc :opt_flag 25 | if condition goto it_was_ok 26 | print "not " 27 | it_was_ok: 28 | print "ok " 29 | $P0 = get_global "$test_counter" 30 | $P0 += 1 31 | print $P0 32 | unless has_desc goto no_description 33 | print " # " 34 | print description 35 | no_description: 36 | print "\n" 37 | .return (1) 38 | .end 39 | 40 | .sub 'plan' 41 | .param int quantity 42 | print "1.." 43 | print quantity 44 | print "\n" 45 | .end 46 | 47 | .sub '' :anon :init :load 48 | $P0 = box 0 49 | set_global '$test_counter', $P0 50 | .end 51 | 52 | 53 | -------------------------------------------------------------------------------- /src/cheats/parrot-callcontext.pir: -------------------------------------------------------------------------------- 1 | .namespace ['CallContext'] 2 | .sub 'lexpad_full' :method 3 | .local pmc ctx, lexall, lexpad, lexpad_it 4 | ctx = self 5 | lexall = root_new ['parrot';'Hash'] 6 | 7 | context_loop: 8 | if null ctx goto context_done 9 | lexpad = getattribute ctx, 'lex_pad' 10 | if null lexpad goto lexpad_done 11 | lexpad_it = iter lexpad 12 | lexpad_loop: 13 | unless lexpad_it goto lexpad_done 14 | $S0 = shift lexpad_it 15 | $I0 = exists lexall[$S0] 16 | if $I0 goto lexpad_loop 17 | $P0 = lexpad[$S0] 18 | lexall[$S0] = $P0 19 | goto lexpad_loop 20 | lexpad_done: 21 | ctx = getattribute ctx, 'outer_ctx' 22 | goto context_loop 23 | context_done: 24 | .return (lexall) 25 | .end 26 | 27 | -------------------------------------------------------------------------------- /src/gen/IGNOREME: -------------------------------------------------------------------------------- 1 | This file intentionally left blank. 2 | -------------------------------------------------------------------------------- /src/setting/Hash.pm: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | =begin 4 | 5 | Hash methods and functions 6 | 7 | These methods extend Parrot's Hash type to include more 8 | methods typical of Perl 6 hashes. 9 | 10 | =end 11 | 12 | module Hash { 13 | 14 | =begin item delete 15 | Delete C<$key> from the hash. 16 | =end item 17 | 18 | method delete($key) { 19 | Q:PIR { 20 | $P1 = find_lex '$key' 21 | delete self[$P1] 22 | } 23 | } 24 | 25 | 26 | =begin item exists 27 | Returns true if C<$key> exists in the hash. 28 | =end item 29 | 30 | method exists($key) { 31 | Q:PIR { 32 | $P1 = find_lex '$key' 33 | $I0 = exists self[$P1] 34 | %r = box $I0 35 | } 36 | } 37 | 38 | 39 | =begin item keys 40 | Returns a list of all of the keys in the hash. 41 | =end item 42 | 43 | method keys () { 44 | my @keys; 45 | for self { @keys.push($_.key); } 46 | @keys; 47 | } 48 | 49 | 50 | =begin item kv 51 | Return a list of key, value, key, value, ... 52 | =end item 53 | 54 | method kv () { 55 | my @kv; 56 | for self { @kv.push($_.key); @kv.push($_.value); } 57 | @kv; 58 | } 59 | 60 | 61 | =begin item values 62 | Returns a list of all of the values in the hash. 63 | =end item 64 | 65 | method values () { 66 | my @values; 67 | for self { @values.push($_.value); } 68 | @values; 69 | } 70 | 71 | } 72 | 73 | 74 | =begin item hash 75 | Construct a hash from named arguments. 76 | =end item 77 | 78 | our sub hash(*%h) { %h } 79 | 80 | # vim: ft=perl6 81 | -------------------------------------------------------------------------------- /src/setting/IO.pm: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | =begin 4 | 5 | IO Methods and Functions 6 | 7 | =end 8 | 9 | =begin item open 10 | Open file. 11 | =end item 12 | 13 | sub open($filename, :$r, :$w, :$a, :$bin) { 14 | my $mode := $w ?? 'w' !! ($a ?? 'wa' !! 'r'); 15 | my $handle := pir::new__Ps('FileHandle'); 16 | $handle.open($filename, $mode); 17 | $handle.encoding($bin ?? 'binary' !! 'utf8'); 18 | $handle; 19 | } 20 | 21 | =begin item close 22 | Close handle 23 | =end item 24 | 25 | sub close($handle) { 26 | $handle.close(); 27 | } 28 | 29 | =begin item slurp 30 | Returns the contents of C<$filename> as a single string. 31 | =end item 32 | 33 | our sub slurp ($filename) { 34 | my $handle := open($filename, :r); 35 | my $contents := $handle.readall; 36 | $handle.close(); 37 | $contents; 38 | } 39 | 40 | 41 | =begin item spew 42 | Write the string value of C<$contents> to C<$filename>. 43 | =end item 44 | 45 | our sub spew($filename, $contents) { 46 | my $handle := pir::new__Ps('FileHandle'); 47 | $handle.open($filename, 'w'); 48 | $handle.print($contents); 49 | $handle.close(); 50 | } 51 | 52 | # vim: ft=perl6 53 | -------------------------------------------------------------------------------- /src/setting/Regex.pm: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | =begin 4 | 5 | Regex methods and functions 6 | 7 | =end 8 | 9 | =begin item match 10 | Match C<$text> against C<$regex>. If the C<$global> flag is 11 | given, then return an array of all non-overlapping matches. 12 | =end item 13 | 14 | our sub match ($text, $regex, :$global?) { 15 | my $match := $text ~~ $regex; 16 | if $global { 17 | my @matches; 18 | while $match { 19 | @matches.push($match); 20 | $match := $match.CURSOR.parse($text, :rule($regex), :c($match.to)); 21 | } 22 | @matches; 23 | } 24 | else { 25 | $match; 26 | } 27 | } 28 | 29 | 30 | =begin item subst 31 | Substitute an match of C<$regex> in C<$text> with C<$replacement>, 32 | returning the substituted string. If C<$global> is given, then 33 | perform the replacement on all matches of C<$text>. 34 | =end item 35 | 36 | our sub subst ($text, $regex, $repl, :$global?) { 37 | my @matches := $global ?? match($text, $regex, :global) 38 | !! [ $text ~~ $regex ]; 39 | my $is_code := pir::isa($repl, 'Sub'); 40 | my $offset := 0; 41 | my $result := pir::new__Ps('StringBuilder'); 42 | 43 | for @matches -> $match { 44 | if $match { 45 | pir::push($result, pir::substr($text, $offset, $match.from - $offset)) 46 | if $match.from > $offset; 47 | pir::push($result, $is_code ?? $repl($match) !! $repl); 48 | $offset := $match.to; 49 | } 50 | } 51 | 52 | my $chars := pir::length($text); 53 | pir::push($result, pir::substr($text, $offset, $chars)) 54 | if $chars > $offset; 55 | 56 | ~$result; 57 | } 58 | 59 | =begin item split 60 | Splits C<$text> on occurences of C<$regex> 61 | =end item 62 | 63 | our multi sub split (Regex::Regex $regex, $text) { 64 | my $pos := 0; 65 | my @result; 66 | my $looking := 1; 67 | while $looking { 68 | my $match := 69 | Regex::Cursor.parse($text, :rule($regex), :c($pos)) ; 70 | 71 | if ?$match { 72 | my $from := $match.from(); 73 | my $to := $match.to(); 74 | my $prefix := pir::substr__sPii($text, $pos, $from-$pos); 75 | @result.push($prefix); 76 | $pos := $match.to(); 77 | } else { 78 | my $len := pir::length($text); 79 | if $pos < $len { 80 | @result.push(pir::substr__ssi($text, $pos) ); 81 | } 82 | $looking := 0; 83 | } 84 | } 85 | return @result; 86 | } 87 | 88 | # Use parrot's split for plain strings. 89 | our multi sub split($string, $text) { 90 | # op split produces RSA. So, convert it to RPA. 91 | my @res; 92 | @res.push($_) for pir::split($string, $text); 93 | @res; 94 | } 95 | 96 | # vim: ft=perl6 97 | -------------------------------------------------------------------------------- /src/setting/ResizablePMCArray.pm: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | =begin 4 | 5 | ResizablePMCArray Methods 6 | 7 | These methods extend Parrot's ResizablePMCArray type to include 8 | more methods typical of Perl 6 lists and arrays. 9 | 10 | =end 11 | 12 | module ResizablePMCArray { 13 | 14 | =begin item delete 15 | Remove item at C<$pos> 16 | =end item 17 | 18 | method delete($pos) { 19 | pir::delete(self, $pos); 20 | } 21 | 22 | =begin item exists 23 | Return true if item exists at C<$pos> 24 | =end item 25 | 26 | method exists($pos) { 27 | pir::exists(self, $pos); 28 | } 29 | 30 | =begin item join 31 | Return all elements joined by $sep. 32 | =end item 33 | 34 | method join ($separator = '') { 35 | pir::join($separator, self); 36 | } 37 | 38 | =begin item map 39 | Return an array with the results of applying C<&code> to 40 | each element of the invocant. Note that NQP doesn't have 41 | a flattening list context, so the number of elements returned 42 | is exactly the same as the original. 43 | =end item 44 | 45 | method map (&code) { 46 | my @mapped; 47 | for self { @mapped.push( &code($_) ); } 48 | @mapped; 49 | } 50 | 51 | =begin item grep 52 | Return an array with elements matching code. 53 | =end item 54 | 55 | method grep (&code) { 56 | my @grepped; 57 | for self { @grepped.push($_) if &code($_) }; 58 | @grepped; 59 | } 60 | 61 | =begin item reverse 62 | Return a reversed copy of the invocant. 63 | =end item 64 | 65 | method reverse () { 66 | my @reversed; 67 | for self { @reversed.unshift($_); } 68 | @reversed; 69 | } 70 | } 71 | 72 | 73 | our sub join ($separator, *@values) { @values.join($separator); } 74 | our sub map (&code, *@values) { @values.map(&code); } 75 | our sub grep (&code, *@values) { @values.grep(&code); } 76 | our sub list (*@values) { @values; } 77 | 78 | # vim: ft=perl6 79 | -------------------------------------------------------------------------------- /src/stage0/nqp-setting.nqp: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # This file automatically generated by build/gen_setting.pl in the nqp-rx project. 4 | 5 | # From src/setting/ResizablePMCArray.pm 6 | 7 | #! nqp 8 | 9 | =begin 10 | 11 | ResizablePMCArray Methods 12 | 13 | These methods extend Parrot's ResizablePMCArray type to include 14 | more methods typical of Perl 6 lists and arrays. 15 | 16 | =end 17 | 18 | module ResizablePMCArray { 19 | 20 | =begin item delete 21 | Remove item at C<$pos> 22 | =end item 23 | 24 | method delete($pos) { 25 | pir::delete(self, $pos); 26 | } 27 | 28 | =begin item exists 29 | Return true if item exists at C<$pos> 30 | =end item 31 | 32 | method exists($pos) { 33 | pir::exists(self, $pos); 34 | } 35 | 36 | =begin item join 37 | Return all elements joined by $sep. 38 | =end item 39 | 40 | method join ($separator = '') { 41 | pir::join($separator, self); 42 | } 43 | 44 | =begin item map 45 | Return an array with the results of applying C<&code> to 46 | each element of the invocant. Note that NQP doesn't have 47 | a flattening list context, so the number of elements returned 48 | is exactly the same as the original. 49 | =end item 50 | 51 | method map (&code) { 52 | my @mapped; 53 | for self { @mapped.push( &code($_) ); } 54 | @mapped; 55 | } 56 | 57 | =begin item grep 58 | Return an array with elements matching code. 59 | =end item 60 | 61 | method grep (&code) { 62 | my @grepped; 63 | for self { @grepped.push($_) if &code($_) }; 64 | @grepped; 65 | } 66 | 67 | =begin item reverse 68 | Return a reversed copy of the invocant. 69 | =end item 70 | 71 | method reverse () { 72 | my @reversed; 73 | for self { @reversed.unshift($_); } 74 | @reversed; 75 | } 76 | } 77 | 78 | 79 | our sub join ($separator, *@values) { @values.join($separator); } 80 | our sub map (&code, *@values) { @values.map(&code); } 81 | our sub grep (&code, *@values) { @values.grep(&code); } 82 | our sub list (*@values) { @values; } 83 | 84 | # vim: ft=perl6 85 | # From src/setting/Hash.pm 86 | 87 | #! nqp 88 | 89 | =begin 90 | 91 | Hash methods and functions 92 | 93 | These methods extend Parrot's Hash type to include more 94 | methods typical of Perl 6 hashes. 95 | 96 | =end 97 | 98 | module Hash { 99 | 100 | =begin item delete 101 | Delete C<$key> from the hash. 102 | =end item 103 | 104 | method delete($key) { 105 | Q:PIR { 106 | $P1 = find_lex '$key' 107 | delete self[$P1] 108 | } 109 | } 110 | 111 | 112 | =begin item exists 113 | Returns true if C<$key> exists in the hash. 114 | =end item 115 | 116 | method exists($key) { 117 | Q:PIR { 118 | $P1 = find_lex '$key' 119 | $I0 = exists self[$P1] 120 | %r = box $I0 121 | } 122 | } 123 | 124 | 125 | =begin item keys 126 | Returns a list of all of the keys in the hash. 127 | =end item 128 | 129 | method keys () { 130 | my @keys; 131 | for self { @keys.push($_.key); } 132 | @keys; 133 | } 134 | 135 | 136 | =begin item kv 137 | Return a list of key, value, key, value, ... 138 | =end item 139 | 140 | method kv () { 141 | my @kv; 142 | for self { @kv.push($_.key); @kv.push($_.value); } 143 | @kv; 144 | } 145 | 146 | 147 | =begin item values 148 | Returns a list of all of the values in the hash. 149 | =end item 150 | 151 | method values () { 152 | my @values; 153 | for self { @values.push($_.value); } 154 | @values; 155 | } 156 | 157 | } 158 | 159 | 160 | =begin item hash 161 | Construct a hash from named arguments. 162 | =end item 163 | 164 | our sub hash(*%h) { %h } 165 | 166 | # vim: ft=perl6 167 | # From src/setting/Regex.pm 168 | 169 | #! nqp 170 | 171 | =begin 172 | 173 | Regex methods and functions 174 | 175 | =end 176 | 177 | =begin item match 178 | Match C<$text> against C<$regex>. If the C<$global> flag is 179 | given, then return an array of all non-overlapping matches. 180 | =end item 181 | 182 | our sub match ($text, $regex, :$global?) { 183 | my $match := $text ~~ $regex; 184 | if $global { 185 | my @matches; 186 | while $match { 187 | @matches.push($match); 188 | $match := $match.CURSOR.parse($text, :rule($regex), :c($match.to)); 189 | } 190 | @matches; 191 | } 192 | else { 193 | $match; 194 | } 195 | } 196 | 197 | 198 | =begin item subst 199 | Substitute an match of C<$regex> in C<$text> with C<$replacement>, 200 | returning the substituted string. If C<$global> is given, then 201 | perform the replacement on all matches of C<$text>. 202 | =end item 203 | 204 | our sub subst ($text, $regex, $repl, :$global?) { 205 | my @matches := $global ?? match($text, $regex, :global) 206 | !! [ $text ~~ $regex ]; 207 | my $is_code := pir::isa($repl, 'Sub'); 208 | my $offset := 0; 209 | my $result := pir::new__Ps('StringBuilder'); 210 | 211 | for @matches -> $match { 212 | if $match { 213 | pir::push($result, pir::substr($text, $offset, $match.from - $offset)) 214 | if $match.from > $offset; 215 | pir::push($result, $is_code ?? $repl($match) !! $repl); 216 | $offset := $match.to; 217 | } 218 | } 219 | 220 | my $chars := pir::length($text); 221 | pir::push($result, pir::substr($text, $offset, $chars)) 222 | if $chars > $offset; 223 | 224 | ~$result; 225 | } 226 | 227 | =begin item split 228 | Splits C<$text> on occurences of C<$regex> 229 | =end item 230 | 231 | our multi sub split (Regex::Regex $regex, $text) { 232 | my $pos := 0; 233 | my @result; 234 | my $looking := 1; 235 | while $looking { 236 | my $match := 237 | Regex::Cursor.parse($text, :rule($regex), :c($pos)) ; 238 | 239 | if ?$match { 240 | my $from := $match.from(); 241 | my $to := $match.to(); 242 | my $prefix := pir::substr__sPii($text, $pos, $from-$pos); 243 | @result.push($prefix); 244 | $pos := $match.to(); 245 | } else { 246 | my $len := pir::length($text); 247 | if $pos < $len { 248 | @result.push(pir::substr__ssi($text, $pos) ); 249 | } 250 | $looking := 0; 251 | } 252 | } 253 | return @result; 254 | } 255 | 256 | # Use parrot's split for plain strings. 257 | our multi sub split($string, $text) { 258 | # op split produces RSA. So, convert it to RPA. 259 | my @res; 260 | @res.push($_) for pir::split($string, $text); 261 | @res; 262 | } 263 | 264 | # vim: ft=perl6 265 | # From src/setting/IO.pm 266 | 267 | #! nqp 268 | 269 | =begin 270 | 271 | IO Methods and Functions 272 | 273 | =end 274 | 275 | =begin item open 276 | Open file. 277 | =end item 278 | 279 | sub open($filename, :$r, :$w, :$a, :$bin) { 280 | my $mode := $w ?? 'w' !! ($a ?? 'wa' !! 'r'); 281 | my $handle := pir::new__Ps('FileHandle'); 282 | $handle.open($filename, $mode); 283 | $handle.encoding($bin ?? 'binary' !! 'utf8'); 284 | $handle; 285 | } 286 | 287 | =begin item close 288 | Close handle 289 | =end item 290 | 291 | sub close($handle) { 292 | $handle.close(); 293 | } 294 | 295 | =begin item slurp 296 | Returns the contents of C<$filename> as a single string. 297 | =end item 298 | 299 | our sub slurp ($filename) { 300 | my $handle := open($filename, :r); 301 | my $contents := $handle.readall; 302 | $handle.close(); 303 | $contents; 304 | } 305 | 306 | 307 | =begin item spew 308 | Write the string value of C<$contents> to C<$filename>. 309 | =end item 310 | 311 | our sub spew($filename, $contents) { 312 | my $handle := pir::new__Ps('FileHandle'); 313 | $handle.open($filename, 'w'); 314 | $handle.print($contents); 315 | $handle.close(); 316 | } 317 | 318 | # vim: ft=perl6 319 | 320 | # vim: set ft=perl6 nomodifiable : 321 | -------------------------------------------------------------------------------- /t/hll/01-language.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(2); 4 | 5 | ok( HLL::Compiler.language eq 'parrot', 'HLL::Compiler reports parrot'); 6 | 7 | ok( pir::compreg__Ps('parrot') =:= HLL::Compiler, 'compreg "parrot"' ); 8 | 9 | -------------------------------------------------------------------------------- /t/hll/02-modules.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(4); 4 | 5 | my $comp := HLL::Compiler.get_module('HLL::Compiler'); 6 | ok($comp =:= HLL::Compiler.WHO, "correctly retrieved namespace"); 7 | 8 | my $crow := HLL::Compiler.load_module('Crow'); 9 | ok( pir::isa(Crow::help, 'Sub'), "successfully loaded Crow::help"); 10 | ok( $crow =:= pir::get_hll_namespace__PP(['Crow']), "Crow ns correct"); 11 | 12 | my $getopt := HLL::Compiler.load_module('Getopt::Obj'); 13 | ok( $getopt =:= pir::get_hll_namespace__PP(['Getopt','Obj']), "Getopt::Obj ns"); 14 | 15 | 16 | -------------------------------------------------------------------------------- /t/hll/03-exports.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(8); 4 | 5 | module ABC { 6 | sub &alpha() { 'alpha' } 7 | sub &beta() { 'beta' } 8 | our $gamma := 'gamma'; 9 | } 10 | 11 | &ABC::EXPORT::DEFAULT::alpha := &ABC::alpha; 12 | $ABC::EXPORT::DEFAULT::gamma := $ABC::gamma; 13 | 14 | my $module := HLL::Compiler.get_module('ABC'); 15 | my %exports := HLL::Compiler.get_exports($module); 16 | 17 | ok( %exports<&alpha> =:= &ABC::alpha, 'DEFAULT sub alpha export' ); 18 | ok( !%exports<&beta>, 'DEFAULT sub beta export'); 19 | ok( %exports<$gamma> eq 'gamma', 'DEFAULT var gamma export'); 20 | 21 | %exports := HLL::Compiler.get_exports($module, :tagset); 22 | 23 | ok( %exports<&alpha> =:= &ABC::alpha, 'ALL sub alpha export' ); 24 | ok( %exports<&beta> =:= &ABC::beta, 'ALL sub beta export'); 25 | ok( %exports<$gamma> eq 'gamma', 'ALL var gamma export'); 26 | 27 | %exports := HLL::Compiler.get_exports($module, '&beta', '$gamma'); 28 | 29 | ok( %exports<&beta> =:= &ABC::beta, 'named sub beta export'); 30 | ok( %exports<$gamma> eq 'gamma', 'named var gamma export'); 31 | 32 | -------------------------------------------------------------------------------- /t/hll/04-import.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(3); 4 | 5 | module ABC { 6 | sub alpha() { 'alpha' } 7 | sub &beta() { 'beta' } 8 | our $gamma := 'gamma'; 9 | } 10 | 11 | ABC::EXPORT::DEFAULT::alpha := ABC::alpha; 12 | $ABC::EXPORT::DEFAULT::gamma := $ABC::gamma; 13 | 14 | my $module := HLL::Compiler.get_module('ABC'); 15 | my %exports := HLL::Compiler.get_exports($module); 16 | HLL::Compiler.import(pir::get_namespace__P, %exports); 17 | 18 | ok( alpha() eq 'alpha', "imported 'alpha' sub into current namespace" ); 19 | 20 | our β 21 | ok( !pir::defined(&beta), "didn't import &beta"); 22 | 23 | our $gamma; 24 | ok( $gamma eq 'gamma', 'did import $gamma'); 25 | 26 | -------------------------------------------------------------------------------- /t/nqp/01-literals.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check literals 4 | 5 | say('1..8'); 6 | 7 | print("ok "); 8 | print(1); 9 | print("\n"); 10 | 11 | print('ok '); 12 | say(2); 13 | 14 | print("ok 3\n"); 15 | say('ok 4'); 16 | say("ok 5"); 17 | say(q); 18 | say(q ); 19 | 20 | say("\x6f\x6b 8"); 21 | -------------------------------------------------------------------------------- /t/nqp/02-if.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check control structure 'if' 4 | 5 | say('1..6'); 6 | 7 | if 1 { say("ok 1 # on one line"); } 8 | 9 | say("ok 2 # statements following if are okay"); 10 | 11 | if 1 { 12 | say("ok 3 # multi-line if"); 13 | } 14 | 15 | if 0 { 16 | print("not "); 17 | } 18 | 19 | say("ok 4 # multi-line if, false condition causes block not to execute"); 20 | 21 | say("ok 5 # postfix statement modifier form (true)") if 1; 22 | 23 | print("not ") if 0; 24 | 25 | say("ok 6 # postfix statement modifier form (false)"); 26 | -------------------------------------------------------------------------------- /t/nqp/03-if-else.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check control structure 'if ... else' 4 | 5 | say('1..14'); 6 | 7 | if 1 { say("ok 1 # on one line with else"); } else { say("not ok 1 # on one line with else")} 8 | 9 | say("ok 2 # statements following if with else are okay"); 10 | 11 | if 1 { 12 | print("ok 3"); 13 | } 14 | else { 15 | print("not ok 3"); 16 | } 17 | say(" # multi-line if with else"); 18 | 19 | if 0 { 20 | print("not ok 4"); 21 | } 22 | else { 23 | print("ok 4"); 24 | } 25 | say(" # multi-line if, else branch"); 26 | 27 | if 0 { 28 | } 29 | else { 30 | print("ok 5"); 31 | } 32 | say(" # empty if-block"); 33 | 34 | if 0 { 35 | print("not ok 6"); 36 | } 37 | else { 38 | } 39 | print("ok 6"); 40 | say(" # empty else-block"); 41 | 42 | if 0 { 43 | } 44 | else { 45 | } 46 | print("ok 7"); 47 | say(" # empty if- and else-block"); 48 | 49 | if 0 { 50 | } 51 | elsif 0 { 52 | } 53 | elsif 0 { 54 | } 55 | else { 56 | } 57 | print("ok 8"); 58 | say(" # empty if-, elsif-, and else-block"); 59 | 60 | if 1 { 61 | print("ok 9"); 62 | } 63 | elsif 0 { 64 | print("not ok 9 # elsif 1"); 65 | } 66 | elsif 0 { 67 | print("not ok 9 # elsif 2"); 68 | } 69 | else { 70 | print("not ok 9 # else"); 71 | } 72 | say(" # if expr true in if/elsif/elsif/else"); 73 | 74 | if 0 { 75 | print("not ok 10 # if"); 76 | } 77 | elsif 1 { 78 | print("ok 10"); 79 | } 80 | elsif 0 { 81 | print("not ok 10 # elsif 2"); 82 | } 83 | else { 84 | print("not ok 10 # else"); 85 | } 86 | say(" # first elsif expr true in if/elsif/elsif/else"); 87 | 88 | if 0 { 89 | print("not ok 11 # if"); 90 | } 91 | elsif 0 { 92 | print("not ok 11 # elsif 1"); 93 | } 94 | elsif 1 { 95 | print("ok 11"); 96 | } 97 | else { 98 | print("not ok 11 # else"); 99 | } 100 | say(" # second elsif expr true in if/elsif/elsif/else"); 101 | 102 | if 0 { 103 | print("not ok 12 # if"); 104 | } 105 | elsif 1 { 106 | print("ok 12"); 107 | } 108 | elsif 1 { 109 | print("not ok 12 # elsif 2"); 110 | } 111 | else { 112 | print("not ok 12 # else"); 113 | } 114 | say(" # first and second elsif expr true in if/elsif/elsif/else"); 115 | 116 | if 0 { 117 | print("not ok 13 # if"); 118 | } 119 | elsif 0 { 120 | print("not ok 13 # elsif 1"); 121 | } 122 | elsif 0 { 123 | print("not ok 13 # elsif 2"); 124 | } 125 | else { 126 | print("ok 13"); 127 | } 128 | say(" # else expr true in if/elsif/elsif/else"); 129 | 130 | if 0 { } elsif 0 { } 131 | print("ok 14"); 132 | say(" # no else block in if/elsif") 133 | -------------------------------------------------------------------------------- /t/nqp/04-unless.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check control structure 'unless' 4 | 5 | say('1..6'); 6 | 7 | unless 0 { say("ok 1 # on one line"); } 8 | 9 | say("ok 2 # statements following unless are okay"); 10 | 11 | unless 0 { 12 | say("ok 3 # multi-line unless"); 13 | } 14 | 15 | unless 1 { 16 | print("not "); 17 | } 18 | say("ok 4 # testing conditional"); 19 | 20 | say("ok 5 # postfix statement modifier form (false)") unless 0; 21 | 22 | print("not ") unless 1; 23 | 24 | say("ok 6 # postfix statement modifier form (true)"); 25 | 26 | -------------------------------------------------------------------------------- /t/nqp/05-comments.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check comments 4 | 5 | say('1..8'); 6 | 7 | #Comment preceding 8 | say("ok 1"); 9 | 10 | say("ok 2"); #Comment following 11 | 12 | #say("not ok 3"); 13 | # say("not ok 4"); 14 | 15 | { say('ok 3'); } # comment 16 | { say('ok 4'); } 17 | 18 | =for comment 19 | say("not ok 5"); 20 | 21 | =for comment say("not ok 6"); 22 | 23 | =begin comment 24 | say("not ok 7"); 25 | 26 | say("not ok 8"); 27 | =end comment 28 | 29 | =comment say("not ok 9"); 30 | say("not ok 10"); 31 | 32 | =for comment blah 33 | 34 | say("ok 5"); 35 | 36 | =begin comment 37 | =end comment 38 | say("ok 6"); 39 | 40 | # This doesn't quite work right... but it doesn't work in STD either 41 | #=for comment 42 | #=begin comment 43 | #=end comment 44 | #=say("ok 7"); 45 | 46 | =comment 47 | 48 | say("ok 7"); 49 | 50 | =begin comment indented pod 51 | this is indented pod 52 | say("not ok 8"); 53 | =end comment 54 | 55 | say("ok 8"); 56 | 57 | 58 | -------------------------------------------------------------------------------- /t/nqp/06-args-pos.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # positional arguments 4 | 5 | say('1..2'); 6 | 7 | say("ok ", 1); 8 | 9 | print('o', 'k', ' ', 2, "\n"); 10 | -------------------------------------------------------------------------------- /t/nqp/07-boolean.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # Testing boolean context operators, ! and ? 4 | 5 | plan(8); 6 | 7 | ##Negation 8 | ok(!0, 'prefix negation on integer 0'); 9 | ok(!"0", 'prefix negation on string 0'); 10 | 11 | if !1 { 12 | print("not"); 13 | } 14 | ok(1, "negating integer 1"); 15 | 16 | ok(!!1, 'double negation on 1'); 17 | 18 | ##Boolean context 19 | ok(?1, 'prefix negation on integer 1'); 20 | ok(?"10", 'prefix negation on string 10'); 21 | 22 | if ?0 { 23 | print("not"); 24 | } 25 | ok(1, "boolean integer 0"); 26 | 27 | ok(!?!?1, 'spaghetti chaining'); 28 | -------------------------------------------------------------------------------- /t/nqp/08-blocks.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check blocks and statement enders 4 | 5 | say('1..7'); 6 | 7 | { 8 | say("ok 1 # blocks are okay"); 9 | } 10 | 11 | { 12 | print("ok "); 13 | say("2 # last statement in a block does not need a semi-colon") 14 | } 15 | 16 | 17 | { 18 | say("ok 3 # statements can precede blocks"); 19 | { 20 | say("ok 4 # blocks can nest"); 21 | } 22 | say("ok 5 # statements can follow blocks"); 23 | } 24 | 25 | 26 | { print("ok ") }; { say("6 # multiple blocks on one line need a semi-colon") } 27 | 28 | { 29 | print("ok ") 30 | }; { 31 | say("7 # blocks following an end brace must be separated by a semicolon") 32 | } 33 | 34 | -------------------------------------------------------------------------------- /t/nqp/09-var.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # check variables 4 | 5 | say('1..13'); 6 | 7 | my $o1 := 'ok 1'; print($o1); say(" # direct binding and scoping"); 8 | 9 | my $o2; $o2 := 'ok 2'; print($o2); say(" # first scope and declare, then bind"); 10 | 11 | my $o3 := 'ok 3'; 12 | my $p3 := $o3; 13 | print($p3); say(" # bind to another variable"); 14 | 15 | my $o4 := 'ok 4'; 16 | my $p4 := $o4; 17 | $o4 := 'not ok 4'; 18 | print($p4); say(" # rebind the original, the bound one does not change"); 19 | 20 | my $r1 := 'not ok 5'; 21 | my $r2 := 'ok 5'; 22 | my $r3; 23 | $r3 := $r1; 24 | $r3 := $r2; 25 | print($r3); say(' # variables can be rebound'); 26 | 27 | my $b1 := 'ok 7'; 28 | 29 | { 30 | my $b1 := 'ok 6'; 31 | print($b1); say(' # my scoping works inside a block'); 32 | } 33 | 34 | print($b1); say(' # block does not stomp on out scope'); 35 | 36 | my $b2 := 'ok 8'; 37 | 38 | { 39 | print($b2); say(' # variables scoped outside of block persists inside the block'); 40 | } 41 | 42 | my $b3; 43 | { 44 | my $b4 := 'ok 9'; 45 | $b3 := $b4; 46 | } 47 | print($b3); say(' # variable is bound to the value, not the symbol in the block'); 48 | 49 | my $b5 := ''; 50 | { 51 | my $b5 := 'not '; 52 | } 53 | print($b5);say('ok 10 # $b5, defined inside block, does not exist outside'); 54 | 55 | { 56 | our $m1 := 'ok 11 '; 57 | } 58 | 59 | our $m1; 60 | unless $m1 { 61 | print('not '); 62 | } 63 | say('ok 11 # our variables have package scope, exists outside of block'); 64 | 65 | our $m2; 66 | $m2 := 'ok 12'; 67 | { 68 | print($m2); say(' # our variables exist inside blocks'); 69 | } 70 | 71 | our $m3; 72 | $m3 := 'not ok 13'; 73 | { 74 | $m3 := 'ok 13'; 75 | } 76 | print($m3); say(' # our variables written inside block keep their values outside'); 77 | -------------------------------------------------------------------------------- /t/nqp/10-cmp.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check comparisons 4 | 5 | say('1..19'); 6 | 7 | ##Integers, positive and negative 8 | 9 | if 1 == 1 { say("ok 1 # numeric equality, integers"); } 10 | 11 | unless 1 == 2 { 12 | say("ok 2 # numeric equality, integers, not equal"); 13 | } 14 | 15 | if -3 == -3 { say("ok 3 # numeric equality, negative integers"); } 16 | 17 | if 1 != 2 { say("ok 4 # numeric inequality, integers"); } 18 | 19 | unless 1 != 1 { 20 | say("ok 5 # numeric inequality, equal, integers"); 21 | } 22 | 23 | unless -2 != -2 { 24 | say("ok 6 # numeric inequality, equal, negative integers"); 25 | } 26 | 27 | ##Strings 28 | 29 | if "eq" eq "eq" { say("ok 7 # string equality"); } 30 | 31 | unless "one" eq "two" { 32 | say("ok 8 # string equality, not equal"); 33 | } 34 | 35 | if "ONE" ne "TWO" { say("ok 9 # string inequality"); } 36 | 37 | unless "STRING" ne "STRING" { 38 | say("ok 10 # string inequality, equal"); 39 | } 40 | 41 | ##Coerce strings into integers 42 | 43 | if "11" ne ~11 { 44 | print("not "); 45 | } 46 | say("ok 11 # coerce integer 11 into string eleven"); 47 | 48 | if "-12" ne ~-12 { 49 | print("not "); 50 | } 51 | say("ok 12 # coerce integer -12 into string twelve"); 52 | 53 | ##Coerce integers into strings 54 | 55 | if 13 ne +"13" { 56 | print("not "); 57 | } 58 | say("ok 13 # coerce string 13 into an integer"); 59 | 60 | if -14 ne +"-14" { 61 | print("not "); 62 | } 63 | say("ok 14 # coerce string -14 into an integer"); 64 | 65 | ##Containers 66 | 67 | if (1,2) =:= (1,2) { 68 | print("not "); 69 | } 70 | say("ok 15 # container equality, unnamed arrays"); 71 | 72 | my @a := (1, 2); 73 | 74 | unless @a =:= @a { 75 | print("not "); 76 | } 77 | say("ok 16 # container equality, self"); 78 | 79 | my @b := @a; 80 | 81 | unless @a =:= @b { 82 | print("not "); 83 | } 84 | say("ok 17 # container equality, named arrays"); 85 | 86 | my $x := 'foo'; 87 | my $y := $x; 88 | my $z := 'foo'; 89 | 90 | unless $x =:= $y { 91 | print("not "); 92 | } 93 | say("ok 18 # container equality, string binding"); 94 | 95 | if $x =:= $z { 96 | print("not "); 97 | } 98 | say("ok 19 # container equality, string value"); 99 | -------------------------------------------------------------------------------- /t/nqp/11-sub.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # check subs 4 | 5 | say('1..14'); 6 | 7 | sub one ( ) { 8 | say("ok 1 # sub def and call"); 9 | } 10 | 11 | one(); 12 | 13 | { 14 | sub two ( ) { 15 | say("ok 2 # sub def and call inside block"); 16 | } 17 | two(); 18 | } 19 | 20 | sub three ( ) { say("ok 3 # sub def; sub call on same line"); }; three(); 21 | 22 | sub four_five ($arg1) { 23 | say($arg1); 24 | } 25 | four_five('ok 4 # passed in 1 arg'); 26 | 27 | { 28 | four_five('ok 5 # calling sub in outer scope'); 29 | } 30 | 31 | { 32 | our sub six ( ) { 33 | say("ok 6 # def in inner scope, called from outer scope"); 34 | } 35 | } 36 | six(); 37 | 38 | sub seven () { 39 | "ok 7 # return string literal from sub"; 40 | } 41 | 42 | say(seven()); 43 | 44 | sub eight () { 45 | "ok 8 # bind sub return to variable"; 46 | } 47 | 48 | my $retVal := eight(); 49 | 50 | unless $retVal { 51 | print("not "); 52 | } 53 | say($retVal); 54 | 55 | sub add_stomp ($first, $last) { 56 | my $sum := $first + $last; 57 | $first := $last - $first; 58 | $sum; 59 | } 60 | 61 | print("ok "); print(add_stomp(3,6)); say(" # returning the result of operating on arguments"); 62 | 63 | my $five := 5; 64 | my $seven := 7; 65 | 66 | add_stomp($five, $seven); 67 | 68 | if $five != 5 { 69 | print("not "); 70 | } 71 | say("ok 10 # subroutines that operate on args do not affect the original arg outside the sub"); 72 | 73 | sub eleven ($arg) { 74 | say("ok 11 # parameter with a trailing comma"); 75 | } 76 | eleven( 'dummy', ); 77 | 78 | sub &twelve() { 79 | say("ok 12 # subroutine name with leading &"); 80 | } 81 | 82 | &twelve(); 83 | 84 | # test that a sub can start with Q 85 | 86 | sub Qstuff() { 13 }; 87 | say('ok ', Qstuff()); 88 | 89 | sub term:sym() { 14 } 90 | say('ok ', term:sym()); 91 | -------------------------------------------------------------------------------- /t/nqp/12-logical.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check '||', '&&', and '//' 4 | 5 | plan(7); 6 | 7 | my $or_no_branch := 1; 8 | $or_no_branch || ( $or_no_branch := 0 ); 9 | ok($or_no_branch, "logical || shortcuts, branch not taken"); 10 | 11 | my $or_branch := 0; 12 | 0 || ( $or_branch := 1 ); 13 | ok($or_branch, "logical || shortcuts, branch taken"); 14 | 15 | my $and_no_branch := 0; 16 | $and_no_branch && ( $and_no_branch := 1 ); 17 | ok(!$and_no_branch, "logical && shortcuts, branch not taken"); 18 | 19 | my $and_branch := 0; 20 | 1 && ( $and_branch := 1 ); 21 | ok($and_branch, "logicl && shortcuts, branch taken"); 22 | 23 | my $err_no_branch := 1; 24 | $err_no_branch // ( $err_no_branch := -1 ); 25 | ok($err_no_branch == 1, "logical // shortcuts on true, branch not taken"); 26 | 27 | $err_no_branch := 0; 28 | $err_no_branch // ( $err_no_branch := -1 ); 29 | ok($err_no_branch == 0, "logical // shortcuts on defined false, branch not taken"); 30 | 31 | my $err_branch; 32 | $err_branch // ( $err_branch := 1 ); 33 | ok($err_branch == 1, "logical // takes branch on undef"); 34 | -------------------------------------------------------------------------------- /t/nqp/13-op.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # checking basic operands and circumfix:( ) 4 | 5 | plan(32); 6 | 7 | ##Additive operators 8 | ok( 1+2 == 3, 'Checking addition 1+2'); 9 | ok( 10-9 == 1, 'Checking subtraction 10-9'); 10 | ok( 10-3+2 == 9, 'Checking compound statements 10-3+2'); 11 | ok( 10-(3+2) == 5, 'Checking parenthesized statement 10-(3+2)'); 12 | 13 | ##Multiplicative operators 14 | ok( 6*7 == 42, 'Checking multiplication 6*7'); 15 | ok( 36/6 == 6, 'Checking division 36/6'); 16 | ok( 4*3+5 == 17, 'Checking compound statements 4*3+5'); 17 | ok( 4*(3+5) == 32, 'Checking parenthesized statements 4*(3+5)'); 18 | ok( 12/4*3 == 9, 'Checking compound statements 12/4*3'); 19 | ok( 12/(4*3) == 1, 'Checking compound statements 12/(4*3)'); 20 | ok( 5-3*2 == -1, 'Checking compound statements 5-3*2'); 21 | 22 | ##Modulo operator 23 | ok( 8%3 == 2, 'Checking modulo 8%3'); 24 | ok( 8%3+2 == 4, 'Checking compound statement 8%3+2'); 25 | ok( 8%(3+2) == 3, 'Checking compound statement 8%(3+2)'); 26 | 27 | ##Concatenation operator 28 | ok( 'a' ~ 'b' eq 'ab', 'Checking concatenation "a" ~ "b"'); 29 | ok( 1 ~ 'b' eq '1b', 'Checking concatenation 1 ~ "b"'); 30 | ok( 'a' ~ 2 eq 'a2', 'Checking concatenation "a" ~ 2 '); 31 | 32 | ##Postfix operators 33 | my $x := 0; 34 | ok( $x++ == 0 ); 35 | ok( $x == 1 ); 36 | ok( $x-- == 1 ); 37 | ok( $x == 0 ); 38 | 39 | ##Relational operators 40 | ok( ?(1 < 2) ); 41 | ok( !(2 < 1) ); 42 | ok( ?(2 <= 2) ); 43 | ok( !(3 <= 2) ); 44 | ok( ?(2 > 1) ); 45 | ok( !(2 > 3) ); 46 | ok( ?(2 >= 1) ); 47 | ok( !(2 >= 3) ); 48 | 49 | #Bitwise operators 50 | ok( (1 +| 3) == 3, 'Checking 1 +| 3' ); 51 | ok( (3 +& 2) == 2, 'Checking 3 +& 2' ); 52 | ok( (3 +^ 3) == 0, 'Checking 3 +^ 3' ); 53 | 54 | -------------------------------------------------------------------------------- /t/nqp/14-while.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # while, until statements 4 | 5 | plan(14); 6 | 7 | my $a; my $sum; 8 | 9 | $a := 1; $sum := 0; 10 | while $a != 10 { 11 | $sum := $sum + $a; 12 | $a := $a + 1; 13 | } 14 | ok($sum == 45, 'basic while loop test'); 15 | 16 | $a := 1; $sum := 0; 17 | $sum := $sum + $a++ while $a < 10; 18 | ok($sum == 45, 'basic while statement modifier'); 19 | 20 | $a := 1; $sum := 0; 21 | until $a == 10 { 22 | $sum := $sum + $a; 23 | $a := $a + 1; 24 | } 25 | ok($sum == 45, 'basic until loop test'); 26 | 27 | $a := 1; $sum := 0; 28 | $sum := $sum + $a++ until $a > 9; 29 | ok($sum == 45, 'basic until statement modifier'); 30 | 31 | $a := 1; $sum := 0; 32 | while $a != 1 { 33 | $sum := 99; 34 | $a := 1; 35 | } 36 | ok($sum == 0, 'while loop exits initial false immediately'); 37 | 38 | $a := 1; $sum := 0; 39 | until $a == 1 { 40 | $sum := 99; 41 | $a := 1; 42 | } 43 | ok($sum == 0, 'until loop exits initial true immediately'); 44 | 45 | $a := 1; $sum := 0; 46 | repeat { 47 | $sum := $sum + $a; 48 | $a := $a + 1; 49 | } while $a != 10; 50 | ok($sum == 45, 'basic repeat_while loop'); 51 | 52 | $a := 1; $sum := 0; 53 | repeat { 54 | $sum := $sum + $a; 55 | $a := $a + 1; 56 | } until $a == 10; 57 | ok($sum == 45, 'basic repeat_until loop'); 58 | 59 | $a := 1; $sum := 0; 60 | repeat while $a != 10 { 61 | $sum := $sum + $a; 62 | $a := $a + 1; 63 | }; 64 | ok($sum == 45, 'basic repeat_while loop'); 65 | 66 | $a := 1; $sum := 0; 67 | repeat until $a == 10 { 68 | $sum := $sum + $a; 69 | $a := $a + 1; 70 | }; 71 | ok($sum == 45, 'basic repeat_until loop'); 72 | 73 | $a := 1; $sum := 0; 74 | repeat { 75 | $sum := 99; 76 | } while $a != 1; 77 | ok($sum == 99, 'repeat_while always executes at least once'); 78 | 79 | $a := 1; $sum := 0; 80 | repeat { 81 | $sum := 99; 82 | } until $a == 1; 83 | ok($sum == 99, 'repeat_until always executes at least once'); 84 | 85 | $a := 1; $sum := 0; 86 | repeat while $a != 1 { 87 | $sum := 99; 88 | }; 89 | ok($sum == 99, 'repeat_while always executes at least once'); 90 | 91 | $a := 1; $sum := 0; 92 | repeat until $a == 1 { 93 | $sum := 99; 94 | }; 95 | ok($sum == 99, 'repeat_until always executes at least once'); 96 | 97 | 98 | -------------------------------------------------------------------------------- /t/nqp/15-list.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # lists and for 4 | 5 | plan(3); 6 | 7 | my $list := (1,2,3); 8 | my $indexer := 0; 9 | 10 | for $list { 11 | print("ok "); print($_); say(" checking loop via indices"); 12 | } 13 | -------------------------------------------------------------------------------- /t/nqp/16-ternary.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # the ternary ?? !! operator 4 | 5 | plan(8); 6 | 7 | ok( 1 ?? 1 !! 0 ); 8 | ok( 0 ?? 0 !! 1 ); 9 | 10 | my $a := 1 ?? 'yes' !! 'no'; 11 | ok( $a eq 'yes' ); 12 | 13 | my $b := 0 ?? 'yes' !! 'no'; 14 | ok( $b eq 'no' ); 15 | 16 | my $c := 1 ?? 'yes' !! ( $a := 'no' ); 17 | ok( $c eq 'yes' ); 18 | ok( $a eq 'yes' ); 19 | 20 | my $d := 0 ?? ( $a := 'no' ) !! 'yes'; 21 | ok( $d eq 'yes' ); 22 | ok( $a eq 'yes' ); 23 | 24 | -------------------------------------------------------------------------------- /t/nqp/17-positional.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check positional subscripting 4 | 5 | plan(7); 6 | 7 | my @l := (1,2,3,4,5); 8 | 9 | say("ok 1 # list assignment didn't barf"); 10 | say('ok ',@l[1], ' # numeric subscript'); 11 | say('ok ', @l['2'], ' # string subscript'); 12 | 13 | my $idx := 3; 14 | 15 | say('ok ', @l[$idx], ' # variable subscript'); 16 | say('ok ', @l[$idx + 1], ' # expression in subscript'); 17 | 18 | @l[0] := 'ok 6 # string array element'; 19 | say(@l[0]); 20 | 21 | @l[10] := 'ok 7 # automatic expansion'; 22 | say(@l[10]); 23 | 24 | -------------------------------------------------------------------------------- /t/nqp/18-associative.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # check hash access methods 4 | 5 | plan(7); 6 | 7 | my %h; 8 | 9 | %h := 1; 10 | say("ok 1 # hash assignment with numeric value works"); 11 | 12 | say('ok ', %h + 1, ' # hash access to numeric value'); 13 | 14 | %h := 'ok 3'; 15 | say(%h, ' # hash access to string value'); 16 | 17 | %h{1} := '4'; 18 | say('ok ', %h{1}, ' # numeric hash access'); 19 | 20 | say('ok ', %h<1> + 1, ' # numbers stringify'); 21 | 22 | %h{'b'} := 'ok 6 # curly braces and single quotes work'; 23 | say(%h{'b'}); 24 | 25 | %h{"foo"} := "ok 7 # curly braces and double quotes work"; 26 | say(%h{"foo"}); 27 | 28 | -------------------------------------------------------------------------------- /t/nqp/19-inline.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # inline 4 | 5 | plan(2); 6 | 7 | Q:PIR { say 'ok 1' }; 8 | my $x := Q:PIR { %r = box 'ok 2' }; 9 | say($x); 10 | 11 | -------------------------------------------------------------------------------- /t/nqp/20-return.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # implicit and explicit returns from subs 4 | 5 | plan(3); 6 | 7 | sub foo() { 1; } 8 | 9 | 10 | sub bar() { 11 | return 2; 12 | 0; 13 | } 14 | 15 | sub baz() { 16 | if (1) { return 3; } 17 | 0; 18 | } 19 | 20 | ok( foo() == 1 , 'last value in block' ); 21 | ok( bar() == 2 , 'explicit return value in block'); 22 | ok( baz() == 3 , 'explicit return from nested block'); 23 | 24 | -------------------------------------------------------------------------------- /t/nqp/21-contextual.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # Tests for contextual variables 4 | 5 | plan(6); 6 | 7 | sub foo() { $*VAR } 8 | 9 | { 10 | my $*VAR := 'abc'; 11 | ok($*VAR eq 'abc', 'basic contextual declaration works'); 12 | ok(foo() eq 'abc', 'called subroutine sees caller $*VAR'); 13 | 14 | sub bar() { $*VAR } 15 | 16 | ok(bar() eq 'abc', 'called subroutine sees caller $*VAR'); 17 | 18 | 19 | 20 | { 21 | my $*VAR := 'def'; 22 | ok( $*VAR eq 'def', 'basic nested contextual works'); 23 | ok( foo() eq 'def', 'called subroutine sees caller $*VAR'); 24 | ok( bar() eq 'def', 'called subroutine sees caller not outer'); 25 | } 26 | } 27 | 28 | 29 | -------------------------------------------------------------------------------- /t/nqp/22-optional-args.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # test optional arguments and parameters 4 | 5 | plan(3); 6 | 7 | sub f1 ($x, $y!, $z?) { 8 | $x; 9 | } 10 | say('ok ', f1(1, 2), ' # optional args ignorable'); 11 | say('ok ', f1(2, 2, 2), ' # optional args passable'); 12 | 13 | sub f2 ($x?, $y?) { 'ok 3 # only optional args'; } 14 | say(f2()); 15 | 16 | # TODO we can't parse .defined() yet - jg 17 | #sub f3 ($x, $y?, $text?) { 18 | # if ! $y.defined() && ! $text.defined() { 19 | # say('ok 4 # unpassed optional args are undef'); 20 | # } else { 21 | # say('ok ', $x - $y, $text); 22 | # } 23 | #} 24 | #f3(2); 25 | #f3(8, 3, ' # optional args get passed values'); 26 | #f3(8, :text(' # optional args specifiable by name'), :y(2)); 27 | 28 | # XXX: need to be able to test that the following is illegal 29 | #sub f4 ($x?, $y) { $y; } 30 | 31 | -------------------------------------------------------------------------------- /t/nqp/23-named-args.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # test named parameters and arguments 4 | 5 | plan(4); 6 | 7 | sub f1 ($x, :$y) { $x - $y; } 8 | say('ok ', f1(2, :y(1)), ' # named args passable'); 9 | 10 | sub f2 ($x, :$y) { $x; } 11 | say('ok ', f2(2), ' # named args ignorable'); 12 | 13 | sub f3 (:$x, :$y) { $x - $y; } 14 | say('ok ', f3(:y(2), :x(5)), ' # args reorderable'); 15 | 16 | sub f4 ($w, $x, :$y, :$z) { $w + $x + $y + $z; } 17 | say('ok ', f4(:z(2), -3, :y(1), 4), ' # named/positional intermixable'); 18 | 19 | 20 | # XXX: test mandatory named args are actually mandatory 21 | -------------------------------------------------------------------------------- /t/nqp/24-module.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check module 4 | 5 | plan(3); 6 | 7 | XYZ::foo('ok 1'); 8 | XYZ::sayfoo(); 9 | 10 | module XYZ { 11 | our $value := 'ok 2'; 12 | our sub foo($x) { $value := $x; } 13 | our sub sayfoo() { say($value // 'ok 1'); } 14 | sayfoo(); 15 | } 16 | 17 | XYZ::foo('ok 3'); 18 | XYZ::sayfoo(); 19 | 20 | -------------------------------------------------------------------------------- /t/nqp/25-class.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # class 4 | 5 | plan(2); 6 | 7 | class XYZ { 8 | method foo($x) { 9 | say($x); 10 | } 11 | } 12 | 13 | my $xyz := XYZ.new(); 14 | 15 | $xyz.foo('ok 1'); 16 | 17 | 18 | # test that a class can start with Q 19 | 20 | class QRS { 21 | method foo($x) { 22 | say($x); 23 | } 24 | } 25 | 26 | my $qrs := QRS.new(); 27 | 28 | $qrs.foo('ok 2'); 29 | 30 | -------------------------------------------------------------------------------- /t/nqp/26-methodops.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # method ops (just method calls for now) 4 | 5 | plan(5); 6 | 7 | class Foo { 8 | method blarg() { 9 | 'ok 1 # method calls work'; 10 | } 11 | method blargless() { 12 | 'ok 3 # argument-less method calls work' 13 | } 14 | method blast() { 15 | 'ok 4 # string method calls work' 16 | } 17 | 18 | method foo:bar() { 19 | 'ok 5 # colonpair named method call work' 20 | } 21 | } 22 | 23 | class Bar { 24 | method blarg() { 25 | 'not ok 1'; 26 | } 27 | } 28 | 29 | sub blarg() { 30 | 'ok 2 # regular subs aren\'t confused with methods'; 31 | } 32 | 33 | my $foo := Foo.new(); 34 | 35 | say($foo.blarg()); 36 | say(blarg()); 37 | say($foo.blargless); 38 | my $t := 'st'; 39 | say($foo."bla$t"()); 40 | say($foo.foo:bar()); 41 | -------------------------------------------------------------------------------- /t/nqp/27-self.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | plan(5); 4 | 5 | class Foo { 6 | has $!abc; 7 | 8 | method foo() { $!abc := 1 }; 9 | 10 | method uno() { 11 | self.foo(); 12 | }; 13 | 14 | method des() { 15 | if 1 { 16 | self.foo(); 17 | } 18 | }; 19 | 20 | method tres($a) { 21 | if 1 { 22 | self.foo(); 23 | } 24 | }; 25 | 26 | method quat() { 27 | for 2,3 -> $a { 28 | ok($a + $!abc, 'Can access attribute within lexical block'); 29 | } 30 | } 31 | }; 32 | 33 | ok(Foo.new.uno, "Can access self within method"); 34 | ok(Foo.new.des, "Can access self within sub-block"); 35 | ok(Foo.new.tres(42), "Can access self within method with signature"); 36 | 37 | Foo.new.quat; 38 | -------------------------------------------------------------------------------- /t/nqp/28-subclass.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # class inheritance 4 | 5 | plan(6); 6 | 7 | class ABC { 8 | method foo() { 9 | say('ok 1'); 10 | } 11 | 12 | method bar() { 13 | say('ok 3'); 14 | } 15 | } 16 | 17 | class XYZ is ABC { 18 | method foo() { 19 | say('ok 2'); 20 | } 21 | } 22 | 23 | 24 | my $abc := ABC.new(); 25 | my $xyz := XYZ.new(); 26 | 27 | $abc.foo(); 28 | $xyz.foo(); 29 | $xyz.bar(); 30 | my $xyzhow := $xyz.HOW; 31 | if $xyzhow.isa($xyz, ABC) { say('ok 4') } 32 | if $xyzhow.isa($xyz, XYZ) { say('ok 5') } 33 | say( $xyzhow.isa($abc, XYZ) ?? 'not ok 6' !! 'ok 6' ); 34 | 35 | -------------------------------------------------------------------------------- /t/nqp/29-make.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # Tests for 'make' builtin. 4 | 5 | plan(2); 6 | 7 | my $/ := Regex::Match.new(); 8 | make 'ok 1'; 9 | say($/.ast); 10 | 11 | # check that it finds contextual $/ 12 | our sub foo() { 13 | make 'ok 2' 14 | } 15 | 16 | foo(); 17 | say($/.ast); 18 | 19 | 20 | -------------------------------------------------------------------------------- /t/nqp/30-pirop.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # Test PIR::op pseudo-functions. 4 | 5 | plan(3); 6 | 7 | say( pir::join__SsP('', ('o', 'k', ' ', 1) ) ); 8 | 9 | say( 'ok ', pir::div(6,3) ); 10 | 11 | say( 'ok ', pir::chr__Si(51) ); 12 | -------------------------------------------------------------------------------- /t/nqp/31-grammar.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # Test grammars and regexes 4 | 5 | plan(6); 6 | 7 | grammar ABC { 8 | token TOP { ok ' ' } 9 | token integer { \d+ } 10 | token TOP2 { ok ' ' } 11 | token int-num { \d+ } 12 | } 13 | 14 | my $match := ABC.parse('not ok'); 15 | ok( !$match, 'parse method works on negative match'); 16 | 17 | ok( $match.chars == 0, 'failed match has 0 .chars'); 18 | 19 | $match := ABC.parse('ok 123'); 20 | ok( ?$match, 'parse method works on positive match'); 21 | 22 | ok( $match == 123, 'captured $'); 23 | 24 | $match := ABC.parse('ok 123', :rule ); 25 | ok( ?$match, 'parse method works with :rule'); 26 | 27 | ok( $match == 123, 'captured $'); 28 | -------------------------------------------------------------------------------- /t/nqp/32-protoregex.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # test protoregexes in grammars 4 | 5 | plan(7); 6 | 7 | grammar ABC { 8 | 9 | token TOP { .* } 10 | 11 | proto token symbols { <...> } 12 | 13 | token symbols:sym { } 14 | token symbols:sym { } 15 | token symbols:sym { $=['!'] } 16 | token symbols:sym<===> { } 17 | } 18 | 19 | 20 | my $/ := ABC.parse('abcdef'); 21 | ok( ?$/ , 'successfully matched grammar' ); 22 | ok( $/ eq 'abcdef', 'successful string match' ); 23 | ok( $ eq 'abc', 'successful protoregex match'); 24 | ok( $ eq 'abc', 'correct proto candidate match' ); 25 | 26 | $/ := ABC.parse('adef'); 27 | ok( ?$/ , 'successfully matched grammar' ); 28 | 29 | $/ := ABC.parse('xxx'); 30 | ok( !$/ , 'successfully failed protoregex match' ); 31 | 32 | $/ := ABC.parse('xxx', :rule); 33 | ok( !$/ , 'successfully failed protoregex match' ); 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /t/nqp/33-init.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # Test INIT blocks 4 | 5 | INIT plan(4); 6 | 7 | our $foo; 8 | 9 | ok($foo == 2, 'after second INIT block'); 10 | 11 | INIT { 12 | our $foo; 13 | ok($foo == 0, 'first INIT'); 14 | $foo := 1; 15 | } 16 | 17 | $foo := 3; 18 | 19 | INIT ok($foo++, 'after first INIT but before mainline'); 20 | 21 | ok($foo == 3, 'After everything else'); 22 | 23 | 24 | -------------------------------------------------------------------------------- /t/nqp/34-rxcodeblock.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(12); 4 | 5 | grammar ABC { 6 | token TOP { { ok(1, 'basic code assertion'); } } 7 | } 8 | ABC.parse('abc'); 9 | 10 | grammar BCD { 11 | token TOP { $=[.*] { ok( $ eq 'bcd', 'match in assertion' ); } } 12 | } 13 | BCD.parse('bcd'); 14 | 15 | grammar CDE { 16 | token TOP { \d+ cde } 17 | } 18 | ok( ?CDE.parse('123cde'), 'passes assertion, match after'); 19 | ok( !CDE.parse('1234cde'), 'fails assertion'); 20 | ok( ?CDE.parse('0cde'), 'passes assertion, match after'); 21 | ok( !CDE.parse('1234'), 'fails assertion'); 22 | ok( !CDE.parse('123'), 'fails regex after passing assertion'); 23 | 24 | grammar DEF { 25 | token TOP { \d+ def } 26 | } 27 | ok( !DEF.parse('123def'), 'fails assertion'); 28 | ok( ?DEF.parse('1234def'), 'passes assertion, text after'); 29 | ok( !DEF.parse('0def'), 'fails assertion'); 30 | ok( !DEF.parse('1234'), 'passes assertion, fails text after'); 31 | ok( ?DEF.parse('999def'), 'passes assertion, text after'); 32 | 33 | -------------------------------------------------------------------------------- /t/nqp/35-prefix-sigil.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # prefix sigils like @(...) and %(...) 4 | 5 | plan(1); 6 | 7 | class XYZ { 8 | method list() { 9 | 'ok ', '1'; 10 | } 11 | } 12 | 13 | my $xyz := XYZ.new(); 14 | 15 | for @( $xyz ) { 16 | print( $_ ); 17 | } 18 | print( "\n" ); 19 | -------------------------------------------------------------------------------- /t/nqp/36-callable.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # postcircumfix:<( )> 4 | 5 | plan(1); 6 | 7 | my $sub := { ok(1, 'works'); } 8 | $sub(); 9 | -------------------------------------------------------------------------------- /t/nqp/37-slurpy.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # slurpy args 4 | 5 | plan(5); 6 | 7 | sub slurpy_pos(*@pos) { 8 | for @pos { 9 | say("ok " ~ $_); 10 | } 11 | } 12 | 13 | slurpy_pos(1, 2, 3); 14 | 15 | sub slurpy_named(*%named) { 16 | say(%named); 17 | say(%named); 18 | } 19 | 20 | slurpy_named(:pivo("ok 4"), :slanina("ok 5")); 21 | -------------------------------------------------------------------------------- /t/nqp/38-quotes.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # interpolating quotes 4 | 5 | plan(7); 6 | 7 | my $abc := 'abc'; 8 | 9 | ok( "xxx$abc" eq 'xxxabc', "basic scalar interpolation" ); 10 | 11 | ok( qq{xxx $abc zzz} eq 'xxx abc zzz', 'basic qq{} interpolation' ); 12 | 13 | my $num := 5; 14 | 15 | ok( "xxx {3+$num} zzz" eq 'xxx 8 zzz', "basic closure interpolation" ); 16 | 17 | ok( qq{xxx {3+$num} zzz} eq 'xxx 8 zzz', 'basic qq{} closure interpolation' ); 18 | 19 | ok( < a > eq 'a', 'spaces around individual element stripped'); 20 | 21 | ok( +< a b > == 2, 'angle quotes correctly produce list'); 22 | 23 | ok( pir::does(< >, 'array'), 'empty angle quotes correctly produce list'); 24 | -------------------------------------------------------------------------------- /t/nqp/39-pointy.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(6); 4 | 5 | my $count := 1; 6 | 7 | my $x := -> $a, $b { ok($a == $count++, $b); } 8 | 9 | $x(1, 'basic pointy block'); 10 | 11 | my $y := -> $a, $b = 2 { ok($b == $count++, $a); } 12 | 13 | $y('pointy block with optional'); 14 | 15 | $y('pointy block with optional + arg', 3); 16 | 17 | for <4 pointy4 5 pointy5 6 pointy6> -> $a, $b { ok($a == $count++, $b); } 18 | 19 | -------------------------------------------------------------------------------- /t/nqp/40-lists.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(18); 4 | 5 | my $a; 6 | $a := (8); 7 | ok( pir::typeof__SP($a) eq 'Integer', 'basic parens'); 8 | 9 | $a := (8,9); 10 | ok( pir::typeof__SP($a) eq 'ResizablePMCArray', 'paren list'); 11 | ok( +$a == 2, 'paren list elems' ); 12 | 13 | $a := (8,); 14 | ok( pir::typeof__SP($a) eq 'ResizablePMCArray', 'paren comma'); 15 | ok( +$a == 1, 'paren comma' ); 16 | 17 | $a := (); 18 | ok( pir::typeof__SP($a) eq 'ResizablePMCArray', 'empty parens'); 19 | ok( +$a == 0, 'paren list elems' ); 20 | 21 | $a := [8]; 22 | ok( pir::typeof__SP($a) eq 'ResizablePMCArray', 'brackets of one elem'); 23 | ok( +$a == 1, 'brackets of one elem' ); 24 | 25 | $a := [7,8,9]; 26 | ok( pir::typeof__SP($a) eq 'ResizablePMCArray', 'brackets of 3 elems'); 27 | ok( +$a == 3, 'brackets of 3 elems' ); 28 | 29 | $a := []; 30 | ok( pir::typeof__SP($a) eq 'ResizablePMCArray', 'brackets of 0 elems'); 31 | ok( +$a == 0, 'brackets of 0 elems' ); 32 | 33 | $a := {}; 34 | ok( pir::typeof__SP($a) eq 'Hash', 'empty braces'); 35 | 36 | $a := { 1 }; 37 | ok( pir::typeof__SP($a) eq 'Sub', 'non-empty braces'); 38 | 39 | sub xyz(*@a) { 40 | ok( +@a == 1, "brackets as single argument #1" ); 41 | ok( +@a[0] == 2, "brackets as single argument #2"); 42 | ok( @a[0][1] == 'b', "brackets as single argument #3"); 43 | } 44 | 45 | xyz(['a', 'b']); 46 | 47 | -------------------------------------------------------------------------------- /t/nqp/41-flat.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # flattened arguments 4 | 5 | plan(6); 6 | 7 | sub xyz($x, $y, $z) { 8 | ok( $x == 7, 'first argument'); 9 | ok( $y == 8, 'second argument'); 10 | ok( $z == 9, 'third argument'); 11 | } 12 | 13 | sub ijk(:$i, :$j, :$k) { 14 | ok( $i == 1, 'first named argument'); 15 | ok( $j == 2, 'second named argument'); 16 | ok( $k == 3, 'third named argument'); 17 | } 18 | 19 | my @a := [7,8,9]; 20 | xyz(|@a); 21 | 22 | my %a; 23 | %a := 1; 24 | %a := 2; 25 | %a := 3; 26 | ijk(|%a); 27 | -------------------------------------------------------------------------------- /t/nqp/42-cond-loop.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # combination of conditional modifier and loop modifier 4 | 5 | plan(11); 6 | 7 | my $a; my $s; 8 | 9 | 10 | $a := 0; $s := 0; 11 | $s := 5 if $a > 7 while $a++ < 9; 12 | ok( $s == 5 && $a == 10, 'true if + while'); 13 | 14 | $a := 0; $s := 0; 15 | $s := 5 if $a > 17 while $a++ < 9; 16 | ok( $s == 0 && $a == 10, 'false if + while'); 17 | 18 | $a := 0; $s := 0; 19 | $s := 5 if $a > 7 until $a++ > 9; 20 | ok( $s == 5 && $a == 11, 'true if + until'); 21 | 22 | $a := 0; $s := 0; 23 | $s := 5 if $a > 17 until $a++ > 9; 24 | ok( $s == 0 && $a == 11, 'false if + until'); 25 | 26 | $a := 0; $s := 0; 27 | $s := 5 unless $a > 0 while $a++ < 9; 28 | ok( $s == 0 && $a == 10, 'true unless + while'); 29 | 30 | $a := 0; $s := 0; 31 | $s := 5 unless $a < 0 while $a++ < 9; 32 | ok( $s == 5 && $a == 10, 'false unless + while'); 33 | 34 | $a := 0; $s := 0; 35 | $s := 5 if $a > 0 until $a++ > 9; 36 | ok( $s == 5 && $a == 11, 'true if + until'); 37 | 38 | $a := 0; $s := 0; 39 | $s := 5 if $a < 0 until $a++ > 9; 40 | ok( $s == 0 && $a == 11, 'false if + until'); 41 | 42 | # Ensure that close curly can end a statement 43 | { ok(1, "correct parse"); $a := 10; } 44 | while $a == 10 { ok($a == 10, 'while still works'); $a++; } 45 | 46 | $a := 1; 47 | $a := $a * $_ for <1 2 3>; 48 | ok( $a == 6 , 'for'); 49 | 50 | -------------------------------------------------------------------------------- /t/nqp/43-package-var.t: -------------------------------------------------------------------------------- 1 | #! nqp.pbc 2 | 3 | # Accessing package variables directly 4 | 5 | plan(5); 6 | 7 | our $var; 8 | 9 | $GLOBAL::var := 1; 10 | $ABC::def := 2; 11 | @XYZ::ghi[0] := 3; 12 | $GLOBAL::context := 4; 13 | GLOBAL::mysub := { ok(5, 'bare GLOBAL works'); }; 14 | 15 | 16 | ok( $var == 1, '$GLOBAL::var works'); 17 | 18 | 19 | module ABC { 20 | our $def; 21 | ok( $def == 2, '$ABC::def works'); 22 | } 23 | 24 | module XYZ { 25 | our @ghi; 26 | ok( @ghi[0] == 3, '@XYZ::ghi works'); 27 | } 28 | 29 | ok( $*context == 4, 'contextual in GLOBAL works'); 30 | 31 | mysub(); 32 | 33 | -------------------------------------------------------------------------------- /t/nqp/44-try-catch.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # Tests for try and catch 4 | 5 | plan(8); 6 | 7 | sub oops($msg = "oops!") { # throw an exception 8 | my $ex := Q:PIR { %r = new ['Exception'] }; 9 | $ex := $msg; 10 | pir::throw($ex); 11 | } 12 | 13 | my $ok := 1; 14 | try { 15 | oops(); 16 | $ok := 0; 17 | } 18 | 19 | ok($ok, "exceptions exit a try block"); 20 | 21 | sub foo() { 22 | try { 23 | return 1; 24 | } 25 | return 0; 26 | } 27 | 28 | ok(foo(), "control exceptions are not caught by a try block"); 29 | 30 | ok(try oops(), "statement prefix form of try works"); 31 | 32 | { 33 | CATCH { ok(1, "CATCH blocks are invoked when an exception occurs"); } 34 | oops(); 35 | } 36 | 37 | 38 | $ok := 1; 39 | sub bar() { 40 | CATCH { $ok := 0; } 41 | return; 42 | } 43 | bar(); 44 | ok($ok, "CATCH blocks ignore control exceptions"); 45 | 46 | $ok := 1; 47 | { 48 | { 49 | { 50 | oops(); 51 | CATCH { $ok := $ok * 2; pir::rethrow($!); } 52 | } 53 | CATCH { $ok := $ok * 2; pir::rethrow($!); } 54 | } 55 | CATCH { $ok := $ok * 2; pir::rethrow($!); } 56 | CATCH { ok($ok == 8, "rethrow and multiple exception handlers work") } 57 | } 58 | 59 | $ok := 1; 60 | 61 | { 62 | for 1, 2, 3, 4 { 63 | $ok := $ok * 2; 64 | oops(); 65 | } 66 | CATCH { my &c := $!; &c(); } 67 | } 68 | 69 | ok($ok == 16, "resuming from resumable exceptions works"); 70 | 71 | $ok := 0; 72 | { 73 | CATCH { $ok := -1; } 74 | CONTROL { $ok := 1; } 75 | return 5; 76 | } 77 | ok($ok == 1, "CONTROL blocks catch control exceptions"); 78 | -------------------------------------------------------------------------------- /t/nqp/45-smartmatch.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | P6metaclass.register('Integer'); 4 | P6metaclass.register('ResizablePMCArray'); 5 | 6 | plan(14); 7 | ok(3 ~~ Integer, "smartmatch of Integer works"); 8 | ok(!(4.5 ~~ Integer), "negative smartmatch of Integer works"); 9 | 10 | ok( ~~ ResizablePMCArray, "smartmatch of RPA works"); 11 | ok(!(3 ~~ ResizablePMCArray), "negative smartmatch of RPA works"); 12 | 13 | my $match := 'cde' ~~ regex abc { c(.)e }; 14 | 15 | ok( $match, "simple smart match" ); 16 | ok( $match.from == 0, "match has correct .from" ); 17 | ok( $match.to == 3, "match has correct .to"); 18 | ok( $match eq 'cde', "match has correct string value" ); 19 | 20 | $match := 'abcdef' ~~ regex abc { c(.)e }; 21 | ok( !$match, "'regex' form doesn't do :c-like scanning" ); 22 | 23 | $match := 'abcdef' ~~ / c(.)e /; 24 | ok( $match, "simple smart match, scanning form" ); 25 | ok( $match.from == 2, "match has correct .from" ); 26 | ok( $match.to == 5, "match has correct .to"); 27 | ok( $match eq 'cde', "match has correct string value" ); 28 | 29 | $match := 'abcdef' ~~ / '' /; 30 | ok( $match, "successfully match empty string (TT #1376)"); 31 | 32 | -------------------------------------------------------------------------------- /t/nqp/46-charspec.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | # check literals 4 | 5 | #plan(4); 6 | plan(3); 7 | 8 | ok("\c111\c107 \c49" eq 'ok 1', '\c###'); 9 | ok("\c[111,107,32,50]" eq 'ok 2', '\c[##,##,##]'); 10 | 11 | # This fails at nqp parse-time without-icu. [parrot #874] 12 | # ok("\c[LATIN SMALL LETTER O, LATIN SMALL LETTER K, SPACE, DIGIT THREE]" eq 'ok 3', '\c[name,name]'); 13 | 14 | ok("\e" eq "\c[27]", '\e'); 15 | -------------------------------------------------------------------------------- /t/nqp/47-loop-control.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(3); 4 | 5 | my $runs := 0; 6 | 7 | while $runs < 5 { 8 | $runs++; 9 | last if $runs == 3; 10 | } 11 | 12 | ok($runs == 3, "last works in while"); 13 | 14 | $runs := 0; 15 | my $i := 0; 16 | while $runs < 5 { 17 | $runs++; 18 | next if $runs % 2; 19 | $i++; 20 | } 21 | 22 | ok($i == 2, "next works in while"); 23 | 24 | $runs := 0; 25 | $i := 0; 26 | while $i < 5 { 27 | $runs++; 28 | redo if $runs % 2; 29 | $i++; 30 | } 31 | 32 | ok($runs == 10, "redo works in while"); 33 | -------------------------------------------------------------------------------- /t/nqp/48-closure.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(2); 4 | 5 | sub A($a) { 6 | return { $a * 2 }; 7 | } 8 | 9 | my $x := A(3); 10 | my $y := A(5); 11 | 12 | ok( $y() == 10, "second closure correct" ); 13 | ok( $x() == 6, "first closure correct" ); 14 | 15 | -------------------------------------------------------------------------------- /t/nqp/49-regex-interpolation.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(33); 4 | 5 | my $b := "b+"; 6 | my @foo := [ "b+", "c+" ]; 7 | 8 | ok("ab+d" ~~ /a $b d/, 'plain scalar interpolates as literal 1'); 9 | ok(!("abbbbbd" ~~ /a $b d/), 'plain scalar interpolates as literal 2'); 10 | 11 | ok("ab+d" ~~ /a @foo d/, 'plain array interpolates as alternations of literals 1'); 12 | ok("ac+d" ~~ /a @foo d/, 'plain array interpolates as alternations of literals 2'); 13 | ok(!("abbbbbd" ~~ /a @foo d/), 'plain array interpolates as alternations of literals 3'); 14 | ok(!("acccccd" ~~ /a @foo d/), 'plain array interpolates as alternations of literals 4'); 15 | 16 | my @ltm := [ "b", "bb", "bbc", "bc" ]; 17 | 18 | ok(("abd" ~~ / @ltm /) eq 'b', 'array finds longest match 1'); 19 | ok(("abbd" ~~ / @ltm /) eq 'bb', 'array finds longest match 2'); 20 | ok(("abbcd" ~~ / @ltm /) eq 'bbc', 'array finds longest match 3'); 21 | ok(("abccd" ~~ / @ltm /) eq 'bc', 'array finds longest match 4'); 22 | 23 | ok(!("ab+d" ~~ /a <$b> d/), 'scalar assertion interpolates as regex 1'); 24 | ok("abbbbbd" ~~ /a <$b> d/, 'scalar assertion interpolates as regex 2'); 25 | 26 | ok(!("ab+d" ~~ /a <@foo> d/), 'array assertion interpolates as alternations of regexen 1'); 27 | ok(!("ac+d" ~~ /a <@foo> d/), 'array assertion interpolates as alternations of regexen 2'); 28 | ok("abbbbbd" ~~ /a <@foo> d/, 'array assertion interpolates as alternations of regexen 3'); 29 | ok("acccccd" ~~ /a <@foo> d/, 'array assertion interpolates as alternations of regexen 4'); 30 | 31 | ok(!("ab+d" ~~ /a <{ "b+" }> d/), 'code assersion interpolates as regex 1'); 32 | ok("abbbbd" ~~ /a <{ "b+" }> d/, 'code assersion interpolates as regex 2'); 33 | 34 | ok("abbbbd" ~~ /a <{ ["b+", "c+"] }> d/, 'code assertion that returns array interpolates as alternations of regexen 1'); 35 | ok("accccd" ~~ /a <{ ["b+", "c+"] }> d/, 'code assertion that returns array interpolates as alternations of regexen 2'); 36 | 37 | my $r := /b+/; 38 | 39 | ok(!("ab+d" ~~ /a $r d/), 'plain scalar containing precompiled regex 1'); 40 | ok("abbbd" ~~ /a $r d/, 'plain scalar containing precompiled regex 2'); 41 | 42 | my @r := [ /b+/, "c+" ]; 43 | 44 | ok("abbbbd" ~~ /a @r d/, 'plain array containing mix of precompiled and literal 1'); 45 | ok("ac+d" ~~ /a @r d/, 'plain array containing mix of precompiled and literal 1'); 46 | 47 | my $xyz := 'xyz'; 48 | 49 | ok("axyzxyzd" ~~ /a $xyz+ d/, 'Quantified plain scalar 1'); 50 | ok("ab+b+b+d" ~~ /a $b+ d/, 'Quantified plain scalar 2'); 51 | ok("abbbc+bbbd" ~~ /a @r+ d/, 'Quantified plain array'); 52 | ok("abbbcccbbcd" ~~ /a <{ [ "b+", /c+/ ] }>+ d/, 'Quantified code assertion'); 53 | 54 | ok("ad" ~~ /a { "bc" } d/, "Plain closure doesn't interpolate 1"); 55 | ok(!("abcd" ~~ /a { "bc" } d/), "Plain closure doesn't interpolate 2"); 56 | 57 | ok("ad" ~~ /a d/, 'Zero-width assertions still work 1'); 58 | ok(!("ad" ~~ /a d/), 'Zero-width assertions still work 2'); 59 | 60 | ok("test.h" ~~ /.h$/, 'Do not parse $/ as variable interpolation'); 61 | 62 | -------------------------------------------------------------------------------- /t/nqp/50-regex.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | plan(7); 4 | 5 | ok(Regex::Cursor.parse('a', :rule(//), :p(0)), 6 | 'Can parse "a" with and :p(0)'); 7 | 8 | ok(!Regex::Cursor.parse('a', :rule(//), :p(1)), 9 | 'Can parse "a" with :p(off-range)'); 10 | 11 | ok(!Regex::Cursor.parse('a', :rule(//), :c(1)), 12 | 'Can parse "a" with :c(off-range)'); 13 | 14 | ok(!Regex::Cursor.parse('a', :rule(//), :p(5)), 15 | 'Can parse "a" with :p(far-off-range)'); 16 | 17 | ok(?('ABC' ~~ /:i abc/), ':i works with literals'); 18 | ok(?('ABC' ~~ /:i 'abc'/), ':i works with single-quoted literals'); 19 | ok(?('ABC' ~~ /:i "abc"/), ':i works with double-quoted literals'); 20 | -------------------------------------------------------------------------------- /t/nqp/51-multi.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | say("1..9"); 4 | 5 | our multi sub foo(Float $f) { 6 | say("ok 1"); 7 | } 8 | 9 | our multi sub foo(NQP::Grammar $f) { 10 | say("ok 2"); 11 | } 12 | 13 | our multi sub foo($def) { 14 | say($def); 15 | } 16 | 17 | foo(42.01); 18 | foo(NQP::Grammar.new); 19 | foo("ok 3"); 20 | 21 | class Foo { 22 | our multi method bar(Float $f) { 23 | say("ok 4"); 24 | }; 25 | 26 | our multi method bar($f) { 27 | say($f); 28 | }; 29 | 30 | multi method baz(Integer $i) { 31 | say("ok 6"); 32 | } 33 | 34 | multi method baz($i) { 35 | say($i); 36 | }; 37 | 38 | }; 39 | 40 | my $f := Foo.new; 41 | $f.bar(43.5 - 0.5); 42 | $f.bar("ok 5"); 43 | $f.baz(42); 44 | $f.baz("ok 7"); 45 | 46 | 47 | class Bar { 48 | our multi method foo($x, :$opt?) { 49 | say($x); 50 | } 51 | 52 | our multi method foo(Float $x, :$opt?) { 53 | say("ok 8"); 54 | } 55 | } 56 | 57 | my $b := Bar.new; 58 | $b.foo(43.5 - 0.5); 59 | $b.foo("ok 9"); 60 | 61 | -------------------------------------------------------------------------------- /t/nqp/52-vtable.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | class ABC { 4 | method () is pirflags<:vtable('get_number')> { 123.0 } 5 | method () is pirflags<:vtable('get_string')> { 'abc' } 6 | } 7 | 8 | plan(2); 9 | 10 | my $abc := ABC.new; 11 | ok($abc == 123, "get_number vtable works"); 12 | ok($abc eq 'abc', "get_string vtable works"); 13 | 14 | 15 | -------------------------------------------------------------------------------- /t/nqp/67-threads.t: -------------------------------------------------------------------------------- 1 | #!./parrot nqp.pbc 2 | 3 | # Copyright (C) 2012, Parrot Foundation. 4 | 5 | plan(3); 6 | 7 | my $x := "ok 2 - sub sucessfully called from Task"; 8 | my $sub := sub foo() { 9 | say($x); 10 | } 11 | 12 | say("# Task ..."); 13 | my $task := pir::new__PSP('Task', $sub); 14 | 15 | say("ok 1 - created a Task PMC from nqp"); 16 | 17 | pir::schedule__0P($task); 18 | pir::wait__0P($task); 19 | 20 | say("ok 3 - wait on a task"); 21 | 22 | # Local Variables: 23 | # mode: nqp 24 | # fill-column: 100 25 | # End: 26 | # vim: expandtab shiftwidth=4 ft=pir: 27 | -------------------------------------------------------------------------------- /t/p6regex/rx_backtrack: -------------------------------------------------------------------------------- 1 | ## Backtracking control tests 2 | a* a bazaar y control 3 | # todo :pge 4 | a*:a bazaar /:a/ basic 5 | a*: a bazaar n basic 6 | ^[a|b]* aba abbabbababba y control 7 | ^[a|b]*: aba abbabbababba n outside a group 8 | \d+: 123abc y cut on character class shortcut 9 | \d+: abc n cut on character class shortcut 10 | [ if not | ify ] verify y control 11 | # todo :pge<::> 12 | [ if :: not | ify ] verify n inside a group 13 | # todo :pge<::> 14 | if :: not | ify verify n the default all group 15 | [ if : not | ify ] verify y simple backtrack still works 16 | # todo :pge<::> 17 | [ if :: not | ify ] | verify verify y rule continues 18 | [ when ever ] | whence whence y full backtrack failure 19 | # todo :pge<::> 20 | [ when ::: ever ] | whence whence n full backtrack failure 21 | # todo :pge<::> 22 | ab::cd | gh::ij xyabghij y group cut at top 23 | # todo :pge<::> 24 | ab:::cd | gh:::ij xyabghij n rule cut at top 25 | # todo :pge<::> 26 | [ab::cd | gh::ij] xyabghij y group cut in group 27 | # todo :pge<::> 28 | [ab:::cd | gh:::ij] xyabghij n rule cut in group 29 | # todo :pge<:> 30 | [ ab | abc ]: de xyzabcde n no backtrack into group 31 | ( ab | abc ): de xyzabcde n no backtrack into subpattern 32 | # todo :pge<:> 33 | [ when ever ] | whence whence n full backtrack failure 34 | 35 | :ratchet a* a bazaar n ratchet modifier 36 | :ratchet a*! a bazaar y force backtracking ! 37 | 38 | ## vim: noexpandtab tabstop=4 shiftwidth=4 39 | -------------------------------------------------------------------------------- /t/p6regex/rx_basic: -------------------------------------------------------------------------------- 1 | ## Basic tests 2 | a a y basic literal 3 | abc abc y basic multichar literal 4 | . a y basic dot 5 | .. abc y basic multidot 6 | a.c a.c y dot in mid pattern 7 | b a n failed literal match 8 | aa a n failed literal match 9 | ... ab n failed dot match 10 | c abc y scanning match 11 | -------------------------------------------------------------------------------- /t/p6regex/rx_captures: -------------------------------------------------------------------------------- 1 | ## captures 2 | (a.)..(..) zzzabcdefzzz y basic match 3 | (a.)..(..) zzzabcdefzzz /mob: / basic $0 4 | (a.)..(..) zzzabcdefzzz /mob 0: / basic $1 5 | (a.)..(..) zzzabcdefzzz /mob 1: / basic $2 6 | (a(b(c))(d)) abcd y nested match 7 | (a(b(c))(d)) abcd /mob: / nested match 8 | (a(b(c))(d)) abcd /mob 0: / nested match 9 | (a(b(c))(d)) abcd /mob 0 0: / nested match 10 | (a(b(c))(d)) abcd /mob 0 0 0: / nested match 11 | (a(b(c))(d)) abcd /mob 0 1: / nested match 12 | ((\w+)+) abcd /mob: / nested match 13 | ((\w+)+) abcd /mob 0: / nested match 14 | ((\w+)+) abcd /mob 0 0 0: / nested match 15 | ((\w+)+) ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz /mob: / alt subpattern before group 19 | (a) [ (bc) (d) | .* (ef) ] .* (g) abcdefg /mob 1: / alt subpattern in group 20 | (a) [ (bc) (d) | .* (ef) ] .* (g) abcdefg /mob 2: / alt subpattern in group 21 | (a) [ (bc) (d) | .* (ef) ] .* (g) abcdefg /mob 3: / alt subpattern after group 22 | (a) [ (bc) (x) | .* (ef) ] .* (g) abcdefg /mob 1: / 2nd alt subpattern in group 23 | (a) [ (bc) (x) | .* (ef) ] .* (g) abcdefg /mob 3: / 2nd alt subpattern after group 24 | ( (.) )* abc /mob 0 1 0: / nested repeated captures 25 | [ (.) ]* abc /mob 0 1: / nested repeated captures 26 | ( [.] )* abc /mob 0 1: / nested repeated captures 27 | (.) (.) $7=(.) (.) $4=(.) abcdefg /mob 0: / numbered aliases $1 28 | (.) (.) $7=(.) (.) $4=(.) abcdefg /mob 1: / numbered aliases $2 29 | (.) (.) $7=(.) (.) $4=(.) abcdefg /mob 7: / numbered aliases $7 30 | (.) (.) $7=(.) (.) $4=(.) abcdefg /mob 8: / numbered aliases $8 31 | (.) (.) $7=(.) (.) $4=(.) abcdefg /mob 4: / numbered aliases $4 32 | $1=[ (.) (.) (.) ] (.) abcdefg /mob 1: / perl5 numbered captures $1 33 | $1=[ (.) (.) (.) ] (.) abcdefg /mob 2: / perl5 numbered captures $1 34 | $1=[ (.) (.) (.) ] (.) abcdefg /mob 3: / perl5 numbered captures $1 35 | $1=[ (.) (.) (.) ] (.) abcdefg /mob 4: / perl5 numbered captures $1 36 | $1=[ (.) (.) (.) ] (.) abcdefg /mob 5: / perl5 numbered captures $1 37 | # todo :pugs 38 | :s $=[\w+] \= $=[\S+] abc = 123 /mob: / named capture 39 | # todo :pugs 40 | :s $=[\w+] \= $=[\S+] abc = 123 /mob: <123 @ 7>/ named capture 41 | # todo :pugs 42 | :s (\w+) $=(\w+) (\w+) abc def ghi /mob: / mixing named and unnamed capture 43 | # todo :pugs 44 | :s (\w+) $=(\w+) (\w+) abc def ghi /mob 1: / mixing named and unnamed capture 45 | # todo :pugs 46 | [ \- ]? abc def ghi /mob 0: / multiple subrule captures in same scope 47 | # todo :pugs 48 | [(.)$0]+ bookkeeper y backreference 49 | # todo :pugs 50 | (\w+) <+ws> $0 hello hello y backreference at end of string 51 | # todo :pugs 52 | [(.)$0]+ bookkeeper /mob 0 0: / backref $1 53 | # todo :pugs 54 | [(.)$0]+ bookkeeper /mob 0 1: / backref $1 55 | # todo :pugs 56 | [(.)$0]+ bookkeeper /mob 0 2: / backref $1 57 | # todo :pugs 58 | (.)*x 123x /mob: <123x @ 0>/ repeated dot capture 59 | 60 | $= 12ab34 /mob: / alias capture 61 | 12ab34 /mob: / alias capture 62 | 63 | ## vim: noexpandtab tabstop=4 shiftwidth=4 64 | -------------------------------------------------------------------------------- /t/p6regex/rx_charclass: -------------------------------------------------------------------------------- 1 | ## Enumerated character lists 2 | <[c]> abcdef y character class 3 | # todo :pugs 4 | <[ z ]> abc def n character class ignores ws 5 | # todo :pugs 6 | <[dcb]>**3 abcdef y repeated character class 7 | ^<[a]> abcdef y anchored character class 8 | <-[e]> abcdef y negated character class 9 | ^<[a]>? abcdef y anchored optional character class 10 | <-[e]>? abcdef y negated optional character class 11 | <-[dcb]>**3 abcdef n repeated negated character class 12 | ^<-[e]> abcdef y anchored negated character class 13 | ^<-[a]> abcdef n anchored negated character class 14 | <[b..d]> abcdef y character range 15 | # todo :pugs 16 | <[b .. d]> c y character range ignores ws 17 | <[b..d]> abxxef y character range 18 | <[b..d]> axcxef y character range 19 | <[b..d]> axxdef y character range 20 | <[b..d]> axxxef n character range 21 | <-[b..d]> abcdef y negated character range 22 | # todo :pugs 23 | <- [b..d]> abcdef y negated allows ws 24 | <-[b..d]> bbccdd n negated character range 25 | # todo :pge 26 | <-[d..b]> bbccdd /parse error/ illegal character range 27 | <[-]> ab-def /Unsupported/ unescaped hyphen 28 | <[\-]> ab-def y escaped hyphen 29 | <[\-]> abcdef n escaped hyphen 30 | <-[\-]> ---x-- y negated escaped hyphen 31 | <-[\-]> ------ n negated escaped hyphen 32 | <[\-+]> ab-def y escaped hyphen in range 33 | <[\-+]> ab+def y escaped hyphen in range 34 | <[\-+]> abcdef n escaped hyphen in range 35 | <[+\-]> ab-def y escaped hyphen in range 36 | <[+\-]> ab+def y escaped hyphen in range 37 | <[+\-]> abcdef n escaped hyphen in range 38 | <-[\-+]> ---x-- y negated escaped hyphen in range 39 | <-[\-+]> ------ n negated escaped hyphen in range 40 | <-[+\-]> ---x-- y negated escaped hyphen in range 41 | <-[+\-]> ------ n negated escaped hyphen in range 42 | <["\\]> \\ y escaped backslash 43 | <[\]]> ] y escaped close bracket 44 | # todo :pge 45 | <[\]> \\]] /error/ unescaped backslash (or no closing brace) 46 | ^\><[<]> >< y lt character class 47 | ^<[>]>\< >< y gt character class 48 | # todo :pugs 49 | ^<[><]>**2 >< y gt, lt character class 50 | # todo :pugs 51 | ^<[<>]>**2 >< y lt, gt character class 52 | ^<-[><]> >< n not gt, lt character class 53 | ^<-[<>]> >< n not lt, gt character class 54 | '... --- ...' ... --- ... y literal match (\') 55 | '... --- ...' ...---... n literal match (\') 56 | # todo :pugs 57 | 'ab\'>cd' ab'>cd y literal match with quote 58 | 'ab\\yz' ab\x5cyz y literal match with backslash 59 | 'ab"cd' ab"cd y literal match with quote 60 | # todo :pugs 61 | 'ab\\yz' ab\x5cyz y literal match with backslash 62 | # todo :pugs :pge 63 | "... --- ..." ... --- ... y literal match (\") 64 | # todo :pugs :pge 65 | "... --- ..." ...---... n literal match (\") 66 | # todo :pugs :pge 67 | "ab<\">cd" ab<">cd y literal match with quote 68 | # todo :pugs :pge 69 | "ab<'>cd" ab<'>cd y literal match with quote 70 | # todo :pugs :pge 71 | "ab\\cd" ab\x5ccd y literal match with backslash 72 | # todo :pugs :pge 73 | (ab)x"$0" abxab y literal match with interpolation 74 | # todo :pugs :pge 75 | (ab)"x$0" abxab y literal match with interpolation 76 | '?' ab abcdef n two enumerated ranges 81 | <[A..Z0..9]> abcDef y two enumerated ranges 82 | 83 | abc abc y negated charclass at end of string (issue #9) 84 | 85 | ## vim: noexpandtab tabstop=4 shiftwidth=4 86 | -------------------------------------------------------------------------------- /t/p6regex/rx_goal: -------------------------------------------------------------------------------- 1 | ## Goal tests 2 | '(' ~ ')' \d+ (123) y basic goal syntax 3 | '(' ~ ')' \d+ (123 /couldn't find final/ missing goal 4 | '(' ~ ')' \d+ (123abc) /couldn't find final/ stuff before goal 5 | '(' ~ ')' \d+ (abc) n can't match internal stuff 6 | '(' ~ ')' \d+ () n missing internal stuff 7 | ['('] ~ [')'] \d+ (123) y goal syntax with brackets 8 | ['('] ~ [')'] [\d+] (123) y goal syntax with brackets 9 | ['('] ~ [')'] [\d\d+] (123) y goal syntax with brackets 10 | ('(') ~ (')') (\d\d+) (123) y goal syntax with parentheses 11 | '(' ~ <[()]> \d+ (123) y non-literal goal 12 | '(' ~ <[()]> \d+ (123( y non-literal goal 13 | '(' ~ <[()]> \d+ (123] /Unable to parse/ failing non-literal goal 14 | # todo :pge<:dba> 15 | :dba('zz') '(' ~ ')' \d+ (123 /zz/ :dba adverb 16 | -------------------------------------------------------------------------------- /t/p6regex/rx_lookarounds: -------------------------------------------------------------------------------- 1 | ## lookarounds 2 | a. abacad /mob: / lookahead 3 | .... abacad n lookahead 4 | . abcd n null 5 | aa aabaaa /mob: / negated lookahead 6 | # todo :pugs :pge 7 | b ab y lookbehind 8 | # todo :pge 9 | b cb n lookbehind 10 | # todo :pge 11 | b b n lookbehind 12 | # todo :pge 13 | b ab y lookbehind 14 | # todo :pge 15 | b cb n lookbehind 16 | # todo :pge 17 | b b y lookbehind 18 | # todo :pge 19 | >b dbcb n lookbehind 20 | # todo :pge 21 | ><[ab]> dbaacb y lookbehind 22 | # todo :pge 23 | b dbcb n lookbehind 24 | # todo :pge 25 | <[ab]> dbaacb y lookbehind 26 | # todo :pge 27 | <[ab]> cbaccb y lookbehind 28 | # todo :pge 29 | $ a y lookbehind 30 | # todo :pge 31 | y axxbxxyc y lookbehind 32 | <[a..z]>+ az y metasyntax with leading + (<+...>) 33 | <+[a..z]>+ az y metasyntax with leading + (<+...>) 34 | <+alpha>+ az y metasyntax with leading + (<+...>) 35 | 36 | '' y null pattern () 37 | ^ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij y null pattern () 38 | $ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij y null pattern () 39 | abc def \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij y null pattern () 40 | x | y | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij y null pattern () 41 | x | y | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij y null pattern () 42 | 43 | abc def \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij n fail pattern 44 | 45 | # todo :pge 46 | a[b} \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /error/ mismatched close 47 | 48 | c abacad /mob: / one character and lookahead 49 | .* abacad /mob: / multiple characters and lookahead 50 | .* abaca/ multiple characters and lookahead with a '<' 51 | .* aba/ greedy any character and lookahead with a '<' 52 | .*? aba/ non-greedy any character and lookahead with a '<' 53 | 54 | ## vim: noexpandtab tabstop=4 shiftwidth=4 55 | -------------------------------------------------------------------------------- /t/p6regex/rx_modifiers: -------------------------------------------------------------------------------- 1 | ## modifiers 2 | :i bcd abcdef y ignorecase (:i) 3 | :i bcd aBcdef y ignorecase (:i) 4 | :i bcd abCdef y ignorecase (:i) 5 | :i bcd abcDef y ignorecase (:i) 6 | :i bcd abc-ef n ignorecase (:i) 7 | :ignorecase bcd abcdef y ignorecase (:ignorecase) 8 | :ignorecase bcd aBCDef y ignorecase (:ignorecase) 9 | :ignorecase bcd abc-ef n ignorecase (:ignorecase) 10 | # todo :pugs 11 | :i(0) bcd abcdef y ignorecase, repetition (:i(0)) 12 | :i(0) bcd abCdef n ignorecase, repetition (:i(0)) 13 | # todo :pugs 14 | :i(1) bcd abcdef y ignorecase, repetition (:i(1)) 15 | # todo :pugs 16 | :i(1) bcd abCdef y ignorecase, repetition (:i(1)) 17 | :i(1) bcd aBxDef n ignorecase, repetition (:i(1)) 18 | # todo :pugs 19 | :0i bcd abcdef y ignorecase, repetition (:0i) 20 | :0i bcd abCdef n ignorecase, repetition (:0i) 21 | # todo :pugs 22 | :1i bcd abcdef y ignorecase, repetition (:1i) 23 | # todo :pugs 24 | :1i bcd abCdef y ignorecase, repetition (:1i) 25 | # todo :pugs 26 | :1i bcd aBCDef y ignorecase, repetition (:1i) 27 | :1i bcd aBxDef n ignorecase, repetition (:1i) 28 | ab [:i cd ] ef abcdef y ignorecase, lexical (:i) 29 | ab [:i cd ] ef abCdef y ignorecase, lexical (:i) 30 | ab [:i cd ] ef abcDef y ignorecase, lexical (:i) 31 | ab [:i cd ] ef abCDef y ignorecase, lexical (:i) 32 | ab [:i cd ] ef aBCDef n ignorecase, lexical (:i) 33 | ab [:i cd ] ef abCDEf n ignorecase, lexical (:i) 34 | :i ab [:i cd ] ef abCDef y ignorecase, lexical (:i) 35 | :i ab [:i cd ] ef AbCDeF y ignorecase, lexical (:i) 36 | :i ab [:i cd ] ef AbcdeF y ignorecase, lexical (:i) 37 | # todo :pugs 38 | :i a [:i(0) b [:i(1) c [:0i d [:1i e [:i(0) f ] ] ] ] ] AbCdEf y ignorecase, lexical (:i) 39 | # todo :pugs 40 | :i aa [:i(0) bb [:i(1) cc [:0i dd [:1i ee [:i(0) ff ] ] ] ] ] AabbCcddEeff y ignorecase, lexical (:i) 41 | :i a [:i(0) b [:i(1) c [:0i d [:1i e [:i(0) f ] ] ] ] ] AbCdEF n ignorecase, lexical (:i) 42 | :i aa [:i(0) bb [:i(1) cc [:0i dd [:1i ee [:i(0) ff ] ] ] ] ] AabbCcddEeFf n ignorecase, lexical (:i) 43 | # todo :pugs 44 | :i ab [:i(0) cd ] ef AbcdeF y ignorecase, lexical repetition (:i) 45 | # todo :pugs :pge 46 | :i ab [:!i cd ] ef AbcdeF y ignorecase, lexical repetition (:i) 47 | # todo :pugs 48 | :i ab [:0i cd ] ef AbcdeF y ignorecase, lexical repetition (:i) 49 | # todo :pugs 50 | :0i ab [:1i cd ] ef abCDef y ignorecase, lexical repetition (:i) 51 | :0i ab [:1i cd ] ef AbCDeF n ignorecase, lexical repetition (:i) 52 | :0i ab [:1i cd ] ef AbcdeF n ignorecase, lexical repetition (:i) 53 | # todo :pugs 54 | :0i ab [:i(0) cd ] ef abcdef y ignorecase, lexical repetition (:i) 55 | :0i ab [:1i cd ] ef AbcdeF n ignorecase, lexical repetition (:i) 56 | # todo :pugs 57 | :i(1) ab [:1i cd ] ef AbCdeF y ignorecase, lexical repetition (:i) 58 | # todo :pugs 59 | :i(1) ab [:i(0) cd ] ef AbcdeF y ignorecase, lexical repetition (:i) 60 | :i(1) ab [:i(0) cd ] ef AbcDeF n ignorecase, lexical repetition (:i) 61 | # todo :pugs 62 | :i(2) ab [:i(999) cd ] ef ABCDEF y ignorecase, lexical repetition (:i) 63 | # todo :pugs 64 | :1i ab [:i(1) cd ] ef ABCDEF y ignorecase, lexical repetition (:i) 65 | :0i ab [:1i cd ] ef abcDeF n ignorecase, lexical repetition (:i) 66 | # todo :pugs 67 | :2i ab [:999i cd ] ef ABCDEF y ignorecase, lexical repetition (:i) 68 | ab [:ignorecase cd ] ef abCDef y ignorecase, lexical (:ignorecase) 69 | ab [:ignorecase cd ] ef aBCDef n ignorecase, lexical (:ignorecase) 70 | # todo :pugs 71 | :1ignorecase ab [:ignorecase(1) cd ] ef ABCDEF y ignorecase, lexical repetition (:ignorecase) 72 | # todo :pugs 73 | :s bcd a bcdef y sigspace (:s) 74 | # todo :pugs 75 | :s bcd a bcd ef y sigspace (:s) 76 | :s bcd abcdef n sigspace (:s) 77 | :s bcd abcd ef n sigspace (:s) 78 | :s bcd ab cdef n sigspace (:s) 79 | # todo :pugs 80 | :s b c d a b c d ef y sigspace (:s) 81 | # todo :pugs 82 | :s b c d a b c def y sigspace (:s) 83 | :s b c d ab c d ef n sigspace (:s) 84 | :s b c d a bcdef n sigspace (:s) 85 | :s b c d abcdef n sigspace (:s) 86 | # todo :pugs 87 | :sigspace bcd a bcdef y sigspace (:sigspace) 88 | # todo :pugs 89 | :sigspace bcd a bcd ef y sigspace (:sigspace) 90 | :sigspace bcd abcdef n sigspace (:sigspace) 91 | # todo :pugs 92 | :sigspace b c d a b c d ef y sigspace (:sigspace) 93 | # todo :pugs 94 | :sigspace b c d a b c def y sigspace (:sigspace) 95 | :sigspace b c d ab c d ef n sigspace (:sigspace) 96 | # todo :pugs 97 | :s(1) b c [:s(0) d e f ] a b c def y sigspace, lexical repetition (:s) 98 | # todo :pugs :pge 99 | :s b c [:!s d e f ] a b c def y sigspace, lexical repetition (:s) 100 | :s(0) b c [:s(1) d e f ] a b c def n sigspace, lexical repetition (:s) 101 | # todo :pge 102 | :!s b c [:s d e f ] a b c def n sigspace, lexical repetition (:s) 103 | :s(0) b c [:s(0) d e f ] a b c def n sigspace, lexical repetition (:s) 104 | # todo :pge 105 | :!s b c [:!s d e f ] a b c def n sigspace, lexical repetition (:s) 106 | # todo :pugs 107 | :s ab ab y sigspace, trailing ws 108 | foo\s*'-'?\s*bar foo\t \n-\n\t bar y basic match 109 | foo\s*'-'?\s*bar foo - bar y basic match 110 | foo\s+'-'?\s*bar foo bar y basic match \s+ \s* 111 | foo\s+'-'?\s*bar foo -bar y basic match \s+ \s* 112 | foo\s*'-'?\s+bar foo- bar y basic match \s* \s+ 113 | foo '-'? bar foo-bar y basic match \s* \s* 114 | foo '-'? bar foobar y basic match 115 | foo '-'? bar foo - bar n basic non-match 116 | # todo :pugs 117 | :s foo '-'? bar foo\n \t- \t\t\nbar y basic ws match 118 | # todo :pugs 119 | :s foo '-'? bar foo - bar y basic ws match 120 | # todo :pugs 121 | :s foo '-'? bar foo bar y basic ws match \s+ \s* 122 | # todo :pugs 123 | :s foo '-'? bar foo -bar y basic ws match \s+ \s* 124 | # todo :pugs 125 | :s foo '-'? bar foo- bar y basic ws match \s* \s+ 126 | # todo :pugs 127 | :s foo '-'? bar foo-bar y basic ws match \s* \s* 128 | :s foo '-'? bar foobar n basic ws non-match 129 | # todo :pge 130 | :s()foo '-'? bar foo - bar n basic ws match 131 | # todo :pugs :pge 132 | :s[]foo '-'? bar foo - bar y basic ws match 133 | # todo :pugs 134 | :sfoo '-'? bar foo - bar y basic ws match with boundary modifier separation 135 | # todo :pge<::> 136 | :s::foo '-'? bar foo - bar y basic ws match with backtrack no-op modifier separation 137 | # todo :pge<::> 138 | :s::(\w+) ':=' (\S+) dog := spot /mob 0: / sigspace and capture together 139 | # todo :pge<::> 140 | :s::(\w+) ':=' (\S+) dog := spot /mob 1: / sigspace and capture together 141 | # todo :pugs :pge 142 | :perl5 \A.*? bcd\Q$\E..\z a bcd$ef y perl5 syntax (:perl5) 143 | :s^[\d+ ]* abc 11 12 13 abc y before closing bracket 144 | 145 | ## vim: noexpandtab tabstop=4 shiftwidth=4 146 | -------------------------------------------------------------------------------- /t/p6regex/rx_quantifiers: -------------------------------------------------------------------------------- 1 | ## Quantifiers 2 | 3 | xa* xaaaay // star 2+ 4 | xa* xay // star 1 5 | xa* xy // star 0 6 | xa*y xaaaay // star 2+ 7 | xa*y xay // star 1 8 | xa*y xy // star 0 9 | 10 | xa+ xaaaay // plus 2+ 11 | xa+ xay // plus 1 12 | xa+ xy n plus 0 13 | xa+y xaaaay // plus 2+ 14 | xa+y xay // plus 1 15 | xa+y xy n plus 0 16 | 17 | xa? xaaaay // ques 2+ 18 | xa? xay // ques 1 19 | xa? xy // ques 0 20 | xa?y xaaaay n ques 2+ 21 | xa?y xay // ques 1 22 | xa?y xy // ques 0 23 | 24 | xa*! xaaaay // star greedy 2+ 25 | xa*! xay // star greedy 1 26 | xa*! xy // star greedy 0 27 | xa*!y xaaaay // star greedy 2+ 28 | xa*!y xay // star greedy 1 29 | xa*!y xy // star greedy 0 30 | 31 | xa+! xaaaay // plus greedy 2+ 32 | xa+! xay // plus greedy 1 33 | xa+! xy n plus greedy 0 34 | xa+!y xaaaay // plus greedy 2+ 35 | xa+!y xay // plus greedy 1 36 | xa+!y xy n plus greedy 0 37 | 38 | xa?! xaaaay // ques greedy 2+ 39 | xa?! xay // ques greedy 1 40 | xa?! xy // ques greedy 0 41 | xa?!y xaaaay n ques greedy 2+ 42 | xa?!y xay // ques greedy 1 43 | xa?!y xy // ques greedy 0 44 | 45 | xa*:! xaaaay // star :greedy 2+ 46 | xa*:! xay // star :greedy 1 47 | xa*:! xy // star :greedy 0 48 | xa*:!y xaaaay // star :greedy 2+ 49 | xa*:!y xay // star :greedy 1 50 | xa*:!y xy // star :greedy 0 51 | 52 | xa+:! xaaaay // plus :greedy 2+ 53 | xa+:! xay // plus :greedy 1 54 | xa+:! xy n plus :greedy 0 55 | xa+:!y xaaaay // plus :greedy 2+ 56 | xa+:!y xay // plus :greedy 1 57 | xa+:!y xy n plus :greedy 0 58 | 59 | xa?:! xaaaay // ques :greedy 2+ 60 | xa?:! xay // ques :greedy 1 61 | xa?:! xy // ques :greedy 0 62 | xa?:!y xaaaay n ques :greedy 2+ 63 | xa?:!y xay // ques :greedy 1 64 | xa?:!y xy // ques :greedy 0 65 | 66 | xa*? xaaaay // star eager 2+ 67 | xa*? xay // star eager 1 68 | xa*? xy // star eager 0 69 | xa*?y xaaaay // star eager 2+ 70 | xa*?y xay // star eager 1 71 | xa*?y xy // star eager 0 72 | 73 | xa+? xaaaay // plus eager 2+ 74 | xa+? xay // plus eager 1 75 | xa+? xy n plus eager 0 76 | xa+?y xaaaay // plus eager 2+ 77 | xa+?y xay // plus eager 1 78 | xa+?y xy n plus eager 0 79 | 80 | xa?? xaaaay // ques eager 2+ 81 | xa?? xay // ques eager 1 82 | xa?? xy // ques eager 0 83 | xa??y xaaaay n ques eager 2+ 84 | xa??y xay // ques eager 1 85 | xa??y xy // ques eager 0 86 | 87 | xa*:? xaaaay // star :eager 2+ 88 | xa*:? xay // star :eager 1 89 | xa*:? xy // star :eager 0 90 | xa*:?y xaaaay // star :eager 2+ 91 | xa*:?y xay // star :eager 1 92 | xa*:?y xy // star :eager 0 93 | 94 | xa+:? xaaaay // plus :eager 2+ 95 | xa+:? xay // plus :eager 1 96 | xa+:? xy n plus :eager 0 97 | xa+:?y xaaaay // plus :eager 2+ 98 | xa+:?y xay // plus :eager 1 99 | xa+:?y xy n plus :eager 0 100 | 101 | xa?:? xaaaay // ques :eager 2+ 102 | xa?:? xay // ques :eager 1 103 | xa?:? xy // ques :eager 0 104 | xa?:?y xaaaay n ques :eager 2+ 105 | xa?:?y xay // ques :eager 1 106 | xa?:?y xy // ques :eager 0 107 | 108 | xa*:y xaaaay // star cut 2+ 109 | xa*:y xay // star cut 1 110 | xa*:y xy // star cut 0 111 | xa*:a xaaaay n star cut 2+ 112 | xa*:a xay n star cut 1 113 | 114 | xa+:y xaaaay // plus cut 2+ 115 | xa+:y xay // plus cut 1 116 | xa+:y xy n plus cut 0 117 | xa+:a xaaaay n plus cut 2+ 118 | xa+:a xay n plus cut 1 119 | 120 | xa?:y xaaaay n ques cut 2+ 121 | xa?:y xay // ques cut 1 122 | xa?:y xy // ques cut 0 123 | xa?:a xaaaay / ques cut 2+ 124 | xa?:a xay n ques cut 1 125 | 126 | :ratchet xa*y xaaaay // star ratchet 2+ 127 | :ratchet xa*y xay // star ratchet 1 128 | :ratchet xa*y xy // star ratchet 0 129 | :ratchet xa*a xaaaay n star ratchet 2+ 130 | :ratchet xa*a xay n star ratchet 1 131 | 132 | :ratchet xa+y xaaaay // plus ratchet 2+ 133 | :ratchet xa+y xay // plus ratchet 1 134 | :ratchet xa+y xy n plus ratchet 0 135 | :ratchet xa+a xaaaay n plus ratchet 2+ 136 | :ratchet xa+a xay n plus ratchet 1 137 | 138 | :ratchet xa?y xaaaay n ques ratchet 2+ 139 | :ratchet xa?y xay // ques ratchet 1 140 | :ratchet xa?y xy // ques ratchet 0 141 | :ratchet xa?a xaaaay / ques ratchet 2+ 142 | :ratchet xa?a xay n ques ratchet 1 143 | 144 | :ratchet xa*!y xaaaay // star ratchet greedy 2+ 145 | :ratchet xa*!y xay // star ratchet greedy 1 146 | :ratchet xa*!y xy // star ratchet greedy 0 147 | :ratchet xa*!a xaaaay // star ratchet greedy 2+ 148 | :ratchet xa*!a xay // star ratchet greedy 1 149 | 150 | :ratchet xa+!y xaaaay // plus ratchet greedy 2+ 151 | :ratchet xa+!y xay // plus ratchet greedy 1 152 | :ratchet xa+!y xy n plus ratchet greedy 0 153 | :ratchet xa+!a xaaaay // plus ratchet greedy 2+ 154 | :ratchet xa+!a xay n plus ratchet greedy 1 155 | 156 | :ratchet xa?!y xaaaay n ques ratchet greedy 2+ 157 | :ratchet xa?!y xay // ques ratchet greedy 1 158 | :ratchet xa?!y xy // ques ratchet greedy 0 159 | :ratchet xa?!a xaaaay / ques ratchet greedy 2+ 160 | :ratchet xa?!a xay / ques ratchet greedy 1 161 | 162 | 163 | ## Quantifier bare range 164 | .**2 a n only one character 165 | .**2 ab y two characters 166 | a**2 foobar n only one "a" character 167 | a**2 baabaa y two "a" characters 168 | a**0..4 bbbbbbb y no "a" characters 169 | a**2..4 bababab n not two consecutive "a" characters 170 | a**2..4 baabbbb y two "a" characters 171 | a**2..4 baaabbb y three "a" characters 172 | a**2..4 baaaabb y four "a" characters 173 | a**2..4 baaaaaa y four "a" characters 174 | a**2..* baaaaaa y six "a" characters 175 | a**?2..* baaaaaa y two "a" characters (non-greedy) 176 | a**:?2..* baaaaaa y two "a" characters (non-greedy) 177 | a**!2..* baaaaaa y six "a" characters (explicit greed) 178 | a**:!2..* baaaaaa y six "a" characters (explicit greed) 179 | a**?2..4 baaabbb y two "a" characters (non-greedy) 180 | a**:?2..4 baaabbb y two "a" characters (non-greedy) 181 | a**!2..4 baaabbb y three "a" characters (explicit greed) 182 | a**:!2..4 baaabbb y three "a" characters (explicit greed) 183 | 184 | ^[\w+] ** \,$ foo,bar,baz y ** with a term 185 | ^[\w+] **? \, ....$ foo,bar,baz y **? with a term 186 | ^[\w+] ** [\,\s*]$ foo, bar, baz y ** with term + ws 187 | :sigspace ^[\w+] ** \, $ foo, bar ,baz y ** under :sigspace 188 | # todo :pge 2+3 ab2 /mob: / capturing builtin 4 | <.ident> 2+3 ab2 y non-capturing builtin <.ident> 5 | 6 | def abc\ndef\n-==\nghi y word boundary \W\w 7 | abc abc\ndef\n-==\nghi y word boundary \w\W 8 | abc abc\ndef\n-==\nghi y BOS word boundary 9 | ghi abc\ndef\n-==\nghi y EOS word boundary 10 | a abc\ndef\n-==\nghi n \w\w word boundary 11 | \- abc\ndef\n-==\nghi n \W\W word boundary 12 | def abc\ndef\n-==\nghi n nonword boundary \W\w 13 | abc abc\ndef\n-==\nghi n nonword boundary \w\W 14 | abc abc\ndef\n-==\nghi n BOS nonword boundary 15 | ghi abc\ndef\n-==\nghi n EOS nonword boundary 16 | a abc\ndef\n-==\nghi y \w\w nonword boundary 17 | \- abc\ndef\n-==\nghi y \W\W nonword boundary 18 | 19 | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: / 20 | <+upper> \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: / <+upper> 21 | <+upper>+ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: / <+upper>+ 22 | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: / 23 | <+lower> \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: / <+lower> 24 | <+lower>+ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: / <+lower>+ 25 | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <_ @ 31>/ 26 | <+alpha> \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <_ @ 31>/ <+alpha> 27 | <+alpha>+ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <_ @ 31>/ <+alpha>+ 28 | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <0 @ 35>/ 29 | <+digit> \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <0 @ 35>/ <+digit> 30 | <+digit>+ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <0123456789 @ 35>/ <+digit>+ 31 | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <0 @ 35>/ 32 | <+xdigit> \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <0 @ 35>/ <+xdigit> 33 | <+xdigit>+ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <0123456789ABCDEF @ 35>/ <+xdigit>+ 34 | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <\t @ 0>/ 35 | <+space> \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <\t @ 0>/ <+space> 36 | <+space>+ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <\t\n\r @ 0>/ <+space>+ 37 | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <\t @ 0>/ 38 | <+blank> \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <\t @ 0>/ <+blank> 39 | <+blank>+ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <\t @ 0>/ <+blank>+ 40 | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <\t @ 0>/ 41 | <+cntrl> \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <\t @ 0>/ <+cntrl> 42 | <+cntrl>+ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <\t\n\r @ 0>/ <+cntrl>+ 43 | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: / 44 | <+punct> \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: / <+punct> 45 | <+punct>+ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: + 46 | \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <0 @ 35>/ 47 | <+alnum> \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <0 @ 35>/ <+alnum> 48 | <+alnum>+ \t\n\r !"#$%&'()*+,-./:;<=>?@[\]^`_{|}0123456789ABCDEFGHIJabcdefghij /mob: <0123456789ABCDEFGHIJabcdefghij @ 35>/ <+alnum>+ 49 | <+alnum+[_]> ident_1 y union of character classes 50 | <+[ab]+[\-]>+ aaa-bbb y enumerated character classes 51 | <+ [ a b ]+[\-]>+ aaa-bbb y whitespace is ignored within square brackets and after the initial + 52 | <+[ab]+[\-]>+ -ab- y enumerated character classes variant 53 | <+[ab]+[\-]>+ ---- y enumerated character classes variant 54 | <+[ab]+[\-]>+ - y enumerated character classes variant 55 | <-[ab]+[cd]>+ ccdd y enumerated character classes variant 56 | ^<-[ab]+[cd]>+$ caad n enumerated character classes variant 57 | <- [ a b ]+[cd]>+ ccdd y whitespace is ignored within square brackets and after the initial - 58 | ^<-upper>dent ident_1 y inverted character class 59 | ^<-upper>dent Ident_1 n inverted character class 60 | <+alpha-[Jj]>+ abc y character class with no j 61 | <+ alpha - [ Jj ]> abc y character class with no j with ws 62 | ^<+alpha-[Jj]>+$ aJc n character class with no j fail 63 | 64 | ## vim: noexpandtab tabstop=4 shiftwidth=4 65 | -------------------------------------------------------------------------------- /t/p6regex/rx_syntax: -------------------------------------------------------------------------------- 1 | ## syntax errors 2 | 3 | {{ abcdef /Missing closing braces/ unterminated closure 4 | \1 abcdef /reserved/ back references 5 | \x[ abcdef /Missing close bracket/ unterminated \x[..] 6 | \X[ abcdef /Missing close bracket/ unterminated \X[..] 7 | 8 | * abc abcdef /Quantifier follows nothing/ bare * at start 9 | * abc abcdef /Quantifier follows nothing/ bare * after ws 10 | [*|a] abcdef /Quantifier follows nothing/ bare * after [ 11 | [ *|a] abcdef /Quantifier follows nothing/ bare * after [+sp 12 | [a|*] abcdef /Quantifier follows nothing/ bare * after | 13 | [a| *] abcdef /Quantifier follows nothing/ bare * after |+sp 14 | 15 | + abc abcdef /Quantifier follows nothing/ bare + at start 16 | + abc abcdef /Quantifier follows nothing/ bare + after ws 17 | [+|a] abcdef /Quantifier follows nothing/ bare + after [ 18 | [ +|a] abcdef /Quantifier follows nothing/ bare + after [+sp 19 | [a|+] abcdef /Quantifier follows nothing/ bare + after | 20 | [a| +] abcdef /Quantifier follows nothing/ bare + after |+sp 21 | 22 | ? abc abcdef /Quantifier follows nothing/ bare ? at start 23 | ? abc abcdef /Quantifier follows nothing/ bare ? after ws 24 | [?|a] abcdef /Quantifier follows nothing/ bare ? after [ 25 | [ ?|a] abcdef /Quantifier follows nothing/ bare ? after [+sp 26 | [a|?] abcdef /Quantifier follows nothing/ bare ? after | 27 | [a| ?] abcdef /Quantifier follows nothing/ bare ? after |+sp 28 | 29 | : abc abcdef /Quantifier follows nothing/ bare : at start 30 | : abc abcdef /Quantifier follows nothing/ bare : after ws 31 | [:|a] abcdef /Quantifier follows nothing/ bare : after [ 32 | [ :|a] abcdef /Quantifier follows nothing/ bare : after [+sp 33 | [a|:] abcdef /Quantifier follows nothing/ bare : after | 34 | [a| :] abcdef /Quantifier follows nothing/ bare : after |+sp 35 | 36 | abcdef /Null pattern illegal/ null pattern 37 | abcdef /Null pattern illegal/ ws null pattern 38 | 39 | =abc abcdef /LHS of alias must be lvalue/ bare : after ws 40 | [ =a] abcdef /LHS of alias must be lvalue/ bare : after [+sp 41 | [a| =a] abcdef /LHS of alias must be lvalue/ bare : after |+sp 42 | -------------------------------------------------------------------------------- /t/setting/01-resizablepmcarray.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | pir::load_bytecode('nqp-setting.pbc'); 4 | 5 | my @array := <0 1 2>; 6 | my @reversed := @array.reverse(); 7 | 8 | plan(16); 9 | 10 | ok( @reversed[0] == 2, 'First element correct'); 11 | ok( @reversed[1] == 1, 'Second element correct'); 12 | ok( @reversed[2] == 0, 'Third element correct'); 13 | 14 | my $join := @array.join('|'); 15 | ok( $join eq '0|1|2', 'Join elements'); 16 | $join := @array.join(); 17 | ok( $join eq '012', 'Join with default separator'); 18 | 19 | ok( join(':', 'foo', 'bar', 'baz') eq 'foo:bar:baz', 'Join as standalone function'); 20 | 21 | my @test := ; 22 | ok( @test.exists(2), 'Item exists at @test[2]' ); 23 | ok( !@test.exists(3), 'Item does not exist at @test[3]'); 24 | @test.delete(1); 25 | ok( @test[1] eq 'cherry', '@test[1] was deleted'); 26 | ok( +@test == 2, '@test[1] has two items'); 27 | ok( !@test.exists(2), '@test[2] no longer exists'); 28 | 29 | @test := <1 2 3>; 30 | my @res := @test.map(-> $a { $a~$a; }); 31 | ok( +@res == 3, 'Map produced same number of elements'); 32 | ok( @res.join() eq '112233', 'Map produced correct elements'); 33 | 34 | @res := @test.grep(-> $a { $a % 2 }); 35 | ok( +@res == 2, 'Grep produced correct number of elements'); 36 | ok( @res[0] == 1, 'Grep produced correct elements'); 37 | ok( @res[1] == 3, 'Grep produced correct elements'); 38 | 39 | # vim: ft=perl6 40 | -------------------------------------------------------------------------------- /t/setting/02-hash.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | pir::load_bytecode('nqp-setting.pbc' ); 4 | 5 | my %hash := hash( foo => 1, bar => 2, baz => 42 ); 6 | 7 | plan(17); 8 | 9 | ok( %hash.exists('foo'), 'Key exists'); 10 | ok( !(%hash.exists('bang')), "Key doesn't exist"); 11 | 12 | my @keys := %hash.keys; 13 | ok(+@keys == 3, "Got 3 keys total" ); 14 | 15 | my @sorted := ; 16 | for @keys.sort -> $key { 17 | my $expected := @sorted.shift; 18 | ok( $expected == $key, "Key is correct" ); 19 | } 20 | 21 | my %expected := hash( foo => 1, bar => 2, baz => 42 ); 22 | my %values; 23 | 24 | for %hash.kv -> $k, $v { 25 | ok( %expected.exists($k), "Key exists" ); 26 | ok( %expected{$k} == $v, "Value correct" ); 27 | %expected.delete($k); 28 | %values{$v} := 1 29 | } 30 | 31 | ok( +%expected.keys == 0, "All keys processed" ); 32 | 33 | for %hash.values -> $v { 34 | ok( %values.exists($v), "Value correct" ); 35 | %values.delete($v); 36 | } 37 | 38 | ok( +%values.keys == 0, "All values processed" ); 39 | 40 | # vim: ft=perl6 41 | -------------------------------------------------------------------------------- /t/setting/03-io.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | pir::load_bytecode('nqp-setting.pbc'); 4 | 5 | plan(1); 6 | 7 | my $content := slurp("t/setting/03-io.t"); 8 | ok($content, "File slurped"); 9 | 10 | # vim: ft=perl6 11 | -------------------------------------------------------------------------------- /t/setting/04-regex.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | pir::load_bytecode('nqp-setting.pbc'); 4 | 5 | plan(4); 6 | 7 | my @a := split(/\d/, 'a23b5d'); 8 | ok(+@a == 4, 'split produced 4 chunks'); 9 | ok((@a.join('!') eq 'a!!b!d'), 'got right chunks'); 10 | 11 | @a := split('/', 'foo/bar/baz'); 12 | ok(+@a == 3, 'split produced 3 chunks'); 13 | ok((@a.join('!') eq 'foo!bar!baz'), 'got right chunks'); 14 | 15 | 16 | # vim: ft=perl6 17 | -------------------------------------------------------------------------------- /t/setting/05-subst.t: -------------------------------------------------------------------------------- 1 | #! nqp 2 | 3 | pir::load_bytecode('nqp-setting.pbc' ); 4 | 5 | plan(7); 6 | 7 | my $str := 'hello'; 8 | 9 | ok(subst($str, /h/, 'f') eq 'fello', 'We can use subst'); 10 | ok($str eq 'hello', '.. withouth side effect'); 11 | 12 | ok(subst($str, /l/, 'r', :global) eq 'herro', 'We can use subst to replace all matches'); 13 | 14 | my $i := 0; 15 | ok(subst($str, /l/, {$i++}) eq 'he0lo', 'We can have a closure as replacement'); 16 | ok($i == 1, '.. and $i updated'); 17 | 18 | ok(subst($str, /FOO/, 'BAR') eq 'hello', "Non-existing string doesn't clobber string"); 19 | ok(subst($str, /FOO/, 'BAR', :global) eq 'hello', "Non-existing string doesn't clobber string globally"); 20 | 21 | # vim: ft=perl6 22 | 23 | -------------------------------------------------------------------------------- /tools/analyze-parse: -------------------------------------------------------------------------------- 1 | #! perl 2 | 3 | my $laststamp = 0; 4 | my @callstack; 5 | my @calltime; 6 | my %stats; 7 | 8 | while (<>) { 9 | my ($eventstamp, $loc, $event, $routine) = split ' ', $_; 10 | next unless ($event =~ /START|PROTO|PASS|FAIL/); 11 | $routine = '' if ($routine eq '' || $routine eq 'at'); 12 | my $elapsed = $eventstamp - $laststamp; 13 | $laststamp = $eventstamp; 14 | if (@callstack) { $calltime[-1] += $elapsed; } 15 | if ($event eq 'START' || $event eq 'PROTO') { 16 | $stats{$routine}{'callcount'}++; 17 | push @callstack, $routine; 18 | push @calltime, 0; 19 | next; 20 | } 21 | if ($callstack[-1] ne $routine) { 22 | die "malformed trace: $routine vs @callstack"; 23 | } 24 | else { pop @callstack; } 25 | if ($event eq 'PASS') { 26 | $stats{$routine}{'passcount'}++; 27 | $stats{$routine}{'passtime'} += pop @calltime; 28 | } 29 | if ($event eq 'FAIL') { 30 | $stats{$routine}{'failcount'}++; 31 | $stats{$routine}{'failtime'} += pop @calltime; 32 | } 33 | } 34 | 35 | foreach my $r (keys %stats) { 36 | $stats{$r}{'calltime'} = $stats{$r}{'passtime'} + $stats{$r}{'failtime'}; 37 | foreach (qw( callcount calltime passcount passtime failcount failtime )) { 38 | $stats{'TOTAL'}{$_} += $stats{$r}{$_}; 39 | } 40 | } 41 | 42 | my @keys = sort { $stats{$b}{'calltime'} <=> $stats{$a}{'calltime'} } 43 | keys %stats; 44 | 45 | print " All Passing Failing \n"; 46 | print "Regex Calls Time Calls Time Calls Time \n"; 47 | print "--------------------------------------------------------------------------------------\n"; 48 | 49 | foreach my $r (@keys) { 50 | printf "%-40s: %5d %8.4f %5d %8.4f %5d %8.4f\n", 51 | $r, 52 | $stats{$r}{'callcount'}, $stats{$r}{'calltime'}, 53 | $stats{$r}{'passcount'}, $stats{$r}{'passtime'}, 54 | $stats{$r}{'failcount'}, $stats{$r}{'failtime'}; 55 | } 56 | --------------------------------------------------------------------------------