Skip to content
Browse files

Moved library files to src

git-svn-id: http://close.googlecode.com/svn/trunk@166 c0894e90-627b-11de-987a-95e5a5a5d5f1
  • Loading branch information...
1 parent 0aa3ae7 commit 04d72428964925df5ef48202008925530a606f84 austin_hastings@yahoo.com committed Sep 27, 2009
Showing with 1,333 additions and 0 deletions.
  1. +240 −0 src/Array.nqp
  2. +49 −0 src/Config.nqp
  3. +244 −0 src/Dumper.nqp
  4. +110 −0 src/File.nqp
  5. +136 −0 src/Hash.nqp
  6. +71 −0 src/OS.nqp
  7. +47 −0 src/Scalar.nqp
  8. +436 −0 src/String.nqp
View
240 src/Array.nqp
@@ -0,0 +1,240 @@
+# $Id$
+
+class Array;
+
+sub ASSERT($condition, *@message) {
+ Dumper::ASSERT(Dumper::info(), $condition, @message);
+}
+
+sub BACKTRACE() {
+ Q:PIR {{
+ backtrace
+ }};
+}
+
+sub DIE(*@msg) {
+ Dumper::DIE(Dumper::info(), @msg);
+}
+
+sub DUMP(*@pos, *%what) {
+ Dumper::DUMP(Dumper::info(), @pos, %what);
+}
+
+sub NOTE(*@parts) {
+ Dumper::NOTE(Dumper::info(), @parts);
+}
+
+################################################################
+
+sub append(@dest, @append) {
+ for @append {
+ @dest.push($_);
+ }
+
+ return @dest;
+}
+
+sub delete(@array, $index) {
+ Q:PIR {
+ $P0 = find_lex '@array'
+ $P1 = find_lex '$index'
+ $I0 = $P1
+ delete $P0[$I0]
+ };
+}
+
+sub _get_function($name) {
+ my $sub := Q:PIR {
+ $P0 = find_lex '$name'
+ $S0 = $P0
+ %r = get_global $S0
+ };
+
+ return $sub;
+}
+
+sub cmp_numeric($a, $b) { return $b - $a; }
+sub cmp_numeric_R($a, $b) { return $a - $b; }
+sub cmp_string($a, $b) { if $a lt $b { return -1; } else { return 1; } }
+sub cmp_string_R($a, $b) { if $b lt $a { return -1; } else { return 1; } }
+
+our %Bsearch_compare_func;
+%Bsearch_compare_func{'<=>'} := _get_function('cmp_numeric');
+%Bsearch_compare_func{'R<=>'} := _get_function('cmp_numeric_R');
+%Bsearch_compare_func{'cmp'} := _get_function('cmp_string');
+%Bsearch_compare_func{'Rcmp'} := _get_function('cmp_string_R');
+
+=sub bsearch(@array, $value, ...)
+
+Binary searches for C<$value> in C<@array>, using a selectable comparison
+function.
+
+The adverbs C<:low(#)> and C<:high(#)> may be specified to search within a subset
+of C<@array>.
+
+The adverb C<:cmp(val)> may be specified to select a comparison function. A
+user-provided function may be passed as the value to C<:cmp()>, or a string may
+be given to choose one of the following default comparison functions:
+
+=item C<< <=> >> - numeric ascending order
+
+=item C<< R<=> >> - numeric descending (reversed) order
+
+=item C<cmp> - string ascending order
+
+=item C<Rcmp> - string descending (reversed) order
+
+If a user-provided function is passed in, it must accept two arguments,
+and return some value less than zero if the first argument would appear earlier
+in C<@array> than the second argument.
+
+If the C<$value> is found, returns the index corresponding to the
+value. Otherwise, returns a negative value, V, such that (-V) - 1
+is the index where C<$value> would be inserted. These shenanigans
+are required because there is no "negative zero" to indicate insertion
+at the start of the array.
+
+=cut
+
+sub bsearch(@array, $value, *%adverbs) {
+ DUMP(:array(@array));
+ NOTE("bsearch: for value ", $value);
+ my $low := 0 + %adverbs<low>;
+
+ if $low < 0 {
+ $low := $low + @array;
+ }
+
+ NOTE("low end: ", $low);
+
+ my $high := +@array + %adverbs<high>;
+
+ if $high > +@array {
+ $high := %adverbs<high>;
+ }
+
+ NOTE("high end: ", $high);
+
+ my $top := $high;
+
+ my $cmp := '==';
+
+ if %adverbs<cmp> {
+ $cmp := %adverbs<cmp>;
+ }
+
+ my &compare := %Bsearch_compare_func{$cmp};
+ unless &compare {
+ &compare := %adverbs<cmp>;
+ }
+
+ NOTE("Compare function is: ", &compare);
+
+ my $mid;
+ while $low < $high {
+ # NQP gets this wrong -- floating point math
+ #$mid := $low + ($high - $low) / 2;
+ $mid := Q:PIR {
+ .local int high, low
+ $P0 = find_lex '$high'
+ high = $P0
+ $P0 = find_lex '$low'
+ low = $P0
+ $I0 = high - low
+ $I0 = $I0 / 2
+ $I0 = $I0 + low
+ %r = box $I0
+ };
+
+ if &compare($value, @array[$mid]) < 0 {
+ $low := $mid + 1;
+ }
+ else {
+ $high := $mid;
+ }
+ }
+
+ my $result := - ($low + 1);
+
+ if $low < $top
+ && &compare(@array[$mid], $value) == 0 {
+ $result := $low;
+ }
+
+ NOTE("Returning ", $result);
+ return $result;
+}
+
+sub clone(@original) {
+ my @clone := empty();
+
+ for @original {
+ @clone.push($_);
+ }
+
+ return @clone;
+}
+
+sub concat(*@sources) {
+ my @result := empty();
+
+ for @sources {
+ for $_ {
+ @result.push($_);
+ }
+ }
+
+ return @result;
+}
+
+sub empty() {
+ my @empty := Q:PIR { %r = new 'ResizablePMCArray' };
+ return @empty;
+}
+
+sub join($_delim, @parts) {
+ my $result := '';
+ my $delim := '';
+
+ for @parts {
+ $result := $result ~ $delim ~ $_;
+ $delim := $_delim;
+ }
+
+ return $result;
+}
+
+sub new(*@elements) {
+ return @elements;
+}
+
+sub reverse(@original) {
+ my @result := empty();
+
+ for @original {
+ @result.unshift($_);
+ }
+
+ return @result;
+}
+
+sub unique(@original) {
+ my @result := Array::empty();
+
+ for @original {
+ my $o := $_;
+ my $found := 0;
+
+ for @result {
+ if $o =:= $_ {
+ $found := 1;
+ }
+ }
+
+ unless $found {
+ @result.push($o);
+ }
+ }
+
+ return @result;
+}
View
49 src/Config.nqp
@@ -0,0 +1,49 @@
+# $Id: $
+class Config;
+
+sub ASSERT($condition, *@message) {
+ Dumper::ASSERT(Dumper::info(), $condition, @message);
+}
+
+sub BACKTRACE() {
+ Q:PIR {{
+ backtrace
+ }};
+}
+
+sub DIE(*@msg) {
+ Dumper::DIE(Dumper::info(), @msg);
+}
+
+sub DUMP(*@pos, *%what) {
+ my @info := Dumper::info();
+ @info[0] and Dumper::DUMP(@info, @pos, %what);
+}
+
+sub NOTE(*@parts) {
+ my @info := Dumper::info();
+ @info[0] and Dumper::NOTE(@info, @parts);
+}
+
+################################################################
+
+our $_Pmc;
+
+sub _get_pmc() {
+ unless Scalar::defined($_Pmc) {
+ $_Pmc := Q:PIR {
+ load_bytecode "config.pbc"
+ %r = _config()
+ };
+ }
+
+ DUMP($_Pmc);
+ return $_Pmc;
+}
+
+sub query($key) {
+ NOTE("Querying for Config setting: '", $key, "'");
+ my $result := _get_pmc(){$key};
+ DUMP($result);
+ return $result;
+}
View
244 src/Dumper.nqp
@@ -0,0 +1,244 @@
+# $Id$
+
+class Dumper;
+
+our %Bits;
+%Bits<NOTE> := 1;
+%Bits<DUMP> := 2;
+%Bits<ASSERT> := 4;
+
+our $Prefix;
+
+our %Already_in;
+%Already_in<ASSERT> := 0;
+%Already_in<DIE> := 0;
+%Already_in<DUMP> := 0;
+%Already_in<INFO> := 0;
+%Already_in<NOTE> := 0;
+
+sub ASSERT(@info, $condition, @message) {
+ unless %Already_in<ASSERT> {
+ %Already_in<ASSERT>++;
+
+ if $condition {
+ if @info[0] && @info[0] % 8 >= 4 {
+ @message.unshift("ASSERT PASSED: ");
+ NOTE(@info, @message);
+ }
+ }
+ else {
+ @message.unshift("ASSERT FAILED: ");
+ DIE(@info, @message);
+ }
+
+ %Already_in<ASSERT>--;
+ }
+}
+
+sub BACKTRACE() {
+ Q:PIR {{
+ backtrace
+ }};
+}
+
+sub DIE(@info, @msg) {
+ unless %Already_in<DIE> {
+ %Already_in<DIE>++;
+
+ my $message := @info[2] ~ '::' ~ @info[3]
+ ~ ': ' ~ Array::join('', @msg);
+
+ Q:PIR {
+ $P0 = find_lex '$message'
+ $S0 = $P0
+ die $S0
+ };
+
+ %Already_in<DIE>--;
+ }
+}
+
+sub DUMP(@info, @pos, %named) {
+ unless %Already_in<DUMP> {
+ %Already_in<DUMP>++;
+
+ if @info[0] && @info[0] % 4 > 1 {
+ $Prefix := make_prefix(@info[1]);
+
+ if +@pos {
+ print($Prefix);
+ PCT::HLLCompiler.dumper(@pos, @info[2] ~ '::' ~ @info[3]);
+ }
+
+ if +%named {
+ print($Prefix);
+ PCT::HLLCompiler.dumper(%named, @info[2] ~ '::' ~ @info[3]);
+ }
+ }
+
+ %Already_in<DUMP>--;
+ }
+}
+
+sub DUMP_(*@what) {
+ for @what {
+ PCT::HLLCompiler.dumper($_, '');
+ }
+}
+
+sub NOTE(@info, @parts) {
+ unless %Already_in<NOTE> {
+ %Already_in<NOTE>++;
+
+ if @info[0] && @info[0] % 2 {
+ $Prefix := make_prefix(@info[1]);
+ $Prefix := $Prefix ~ @info[2] ~ '::' ~ @info[3];
+
+ say($Prefix, ': ', Array::join('', @parts));
+ }
+
+ %Already_in<NOTE>--;
+ }
+}
+
+our @Info_rejected := Array::new(0, -1, 'null', 'null');
+
+sub info() {
+ my @result := @Info_rejected;
+
+ unless %Already_in<INFO> {
+ %Already_in<INFO>++;
+
+ my $caller_name := '<null>';
+ my $class_name := '<null>';
+ my $stack_depth := -1;
+ my $proceed := 0;
+
+ Q:PIR {
+ .local pmc caller, key, namespace
+ .local int depth
+ $P0= getinterp
+ depth = 2 # How far up the stack to start looking
+
+ find_named_caller:
+ inc depth
+ key = new 'Key'
+ key = 'sub'
+ $P1 = new 'Key'
+ $P1 = depth
+ push key, $P1
+ caller = $P0[ key ]
+
+ $S0 = caller
+ $S1 = substr $S0, 0, 6
+ if '_block' == $S1 goto find_named_caller
+
+ $P1 = box $S0
+ store_lex '$caller_name', $P1
+
+ namespace = caller.'get_namespace'()
+ $P1 = namespace.'get_name'()
+ $P2 = pop $P1
+ store_lex '$class_name', $P2
+ };
+
+ $proceed := get_config($class_name, $caller_name);
+
+ if $proceed {
+ # Foo calls NOTE(), calls info(), calls stack_depth() : subtract 3
+ $stack_depth := stack_depth() - 3;
+ @result := Array::new($proceed, $stack_depth, $class_name, $caller_name);
+ }
+
+ %Already_in<INFO>--;
+ }
+
+ return @result;
+}
+
+sub get_config($class, $sub) {
+ my @keys := Array::new('Dump', $class, $sub);
+ my $result := close::Compiler::Config::query_array(@keys);
+ return $result;
+}
+
+sub make_prefix($depth) {
+ if $depth < 1 {
+ $depth := 1;
+ }
+
+ return String::repeat('| ', $depth - 1) ~ '+- ';
+}
+
+sub stack_depth() {
+ our $Stack_root;
+ our $Stack_root_offset;
+ our $Root_sub;
+ our $Root_nsp;
+
+ unless $Stack_root {
+ $Stack_root := get_config('Stack', 'Root');
+ $Stack_root_offset := 0 + get_config('Stack', 'Root_offset');
+
+ unless $Stack_root {
+ $Stack_root := 'parrot::close::Compiler::main';
+ $Stack_root_offset := 6; # 6 PCT subs on stack when parsing.
+ }
+
+ my @parts := String::split('::', $Stack_root);
+ $Root_sub := @parts.pop();
+ $Root_nsp := Array::join('::', @parts);
+
+ #say("Stack root: ", $Stack_root);
+ #say("Stack root_offset: ", $Stack_root_offset);
+ }
+
+
+ my $depth := Q:PIR {
+ .local pmc interp
+ .local int depth, show_depth
+ .local pmc key, namespace, caller
+ .local string sub_name, nsp_name
+
+ interp = getinterp
+ depth = 0
+ show_depth = 0
+ $P0 = get_global '$Root_sub'
+ sub_name = $P0
+ $P0 = get_global '$Root_nsp'
+ nsp_name = $P0
+
+ while_not_root:
+ inc depth # depth++
+
+ key = new 'Key' # key = new Key('sub' ; depth)
+ key = 'sub'
+ $P0 = new 'Key'
+ $P0 = depth
+ push key, $P0
+ caller = interp[ key ] # caller = interp[ key ]
+
+ $S0 = caller # $S0 = caller.name()
+ $S1 = substr $S0, 0, 6
+
+ if $S1 == '_block' goto while_not_root
+
+ inc show_depth # found a 'real' sub name
+
+ unless $S0 == sub_name goto while_not_root
+
+ namespace = caller.'get_namespace'()
+
+ $P0 = namespace.'get_name'()
+ $S0 = join '::', $P0
+
+ unless $S0 == nsp_name goto while_not_root
+
+ # Done: depth indicates depth from "parrot::close::Compiler::main" to present.
+ %r = box show_depth
+ };
+
+ $depth := $depth - $Stack_root_offset;
+
+ return $depth;
+}
View
110 src/File.nqp
@@ -0,0 +1,110 @@
+# $Id$
+class File;
+
+sub ASSERT($condition, *@message) {
+ Dumper::ASSERT(Dumper::info(), $condition, @message);
+}
+
+sub BACKTRACE() {
+ Q:PIR {{
+ backtrace
+ }};
+}
+
+sub DIE(*@msg) {
+ Dumper::DIE(Dumper::info(), @msg);
+}
+
+sub DUMP(*@pos, *%what) {
+ my @info := Dumper::info();
+ @info[0] and Dumper::DUMP(@info, @pos, %what);
+}
+
+sub NOTE(*@parts) {
+ my @info := Dumper::info();
+ @info[0] and Dumper::NOTE(@info, @parts);
+}
+
+################################################################
+
+our $_Pmc;
+
+sub _get_pmc() {
+ unless Scalar::defined($_Pmc) {
+ $_Pmc := Q:PIR {
+ %r = root_new [ 'parrot' ; 'File' ]
+ };
+ }
+
+ return $_Pmc;
+}
+
+sub copy($from, $to) {
+ _get_pmc().copy($from, $to);
+}
+
+sub exists($path) {
+ return _get_pmc().exists($path);
+}
+
+sub find_all($path, @search_list) {
+ NOTE("Finding all paths matching '", $path, "' in ", +@search_list, " directories");
+ my @results := Array::empty();
+
+ if String::char_at($path, 0) eq '/' {
+ NOTE("Path is rooted - not using search paths");
+ @search_list := Array::new('');
+ }
+ else {
+ $path := '/' ~ $path;
+ }
+
+ for @search_list {
+ my $name := $_ ~ $path;
+ NOTE("Trying ", $name);
+
+ if exists($name) {
+ NOTE("Success! it's a match");
+ @results.push($name);
+ }
+ }
+
+ NOTE("Found ", +@results, " results");
+ DUMP(@results);
+ return @results;
+}
+
+sub find_first($path, @search_list) {
+ return find_all($path, @search_list)[0];
+}
+
+sub is_dir($path) {
+ return _get_pmc().is_dir($path);
+}
+
+sub is_file($path) {
+ return _get_pmc().is_file($path);
+}
+
+sub is_link($path) {
+ return _get_pmc().is_link($path);
+}
+
+sub rename($from, $to) {
+ _get_pmc().rename($from, $to);
+}
+
+sub slurp($path) {
+ NOTE("Slurping contents of file: ", $path);
+
+ my $data := Q:PIR {
+ $P0 = new 'FileHandle'
+ $P1 = find_lex '$path'
+ $S0 = $P0.'readall'($P1)
+ %r = box $S0
+ };
+
+ NOTE("done");
+ DUMP($data);
+ return $data;
+}
View
136 src/Hash.nqp
@@ -0,0 +1,136 @@
+# $Id$
+
+class Hash;
+
+sub ASSERT($condition, *@message) {
+ Dumper::ASSERT(Dumper::info(), $condition, @message);
+}
+
+sub BACKTRACE() {
+ Q:PIR {{
+ backtrace
+ }};
+}
+
+sub DIE(*@msg) {
+ Dumper::DIE(Dumper::info(), @msg);
+}
+
+sub DUMP(*@pos, *%what) {
+ Dumper::DUMP(Dumper::info(), @pos, %what);
+}
+
+sub NOTE(*@parts) {
+ Dumper::NOTE(Dumper::info(), @parts);
+}
+
+################################################################
+
+sub delete(%hash, $key) {
+ Q:PIR {{
+ $P0 = find_lex '%hash'
+ $P1 = find_lex '$key'
+ delete $P0[$P1]
+ }};
+}
+
+sub elements(%hash) {
+ my %results := Q:PIR {{
+ $P0 = find_lex '%hash'
+ $I0 = elements $P0
+ %r = box $I0
+ }};
+
+ return %results;
+}
+
+sub exists(%hash, $key) {
+ my %results;
+
+ if %hash {
+ %results := Q:PIR {{
+ $P0 = find_lex '%hash'
+ $P1 = find_lex '$key'
+ $I0 = exists $P0[$P1]
+ %r = box $I0
+ }};
+ }
+ else {
+ %results := 0;
+ }
+
+ return %results;
+}
+
+sub _yes() {
+ return 1;
+}
+
+sub merge(%first, *@hashes, :%into?, :$use_last?) {
+
+ @hashes.unshift(%first); # Ensure at least one element.
+
+ unless Scalar::defined(%into) {
+ %into := @hashes.shift();
+
+ unless Scalar::defined(%into) {
+ %into := Hash::new();
+ }
+ }
+
+ my %stored := %into;
+
+ if $use_last {
+ @hashes := Array::reverse(@hashes);
+ %stored := Hash::new();
+ }
+
+ for @hashes {
+ my $hash := $_;
+ for $hash {
+ unless Hash::exists(%stored, $_) {
+ # Order matters, %stored may alias %into
+ %into{$_} :=
+ %stored{$_} := $hash{$_};
+ }
+ }
+ }
+
+ return %into;
+}
+
+sub merge_keys(%first, *@hashes, :@keys!, :%into?, :$use_last?) {
+ @hashes.unshift(%first);
+
+ unless Scalar::defined(%into) {
+ %into := @hashes.shift();
+
+ unless Scalar::defined(%into) {
+ %into := Hash::new();
+ }
+ }
+
+ my %stored := %into;
+
+ if $use_last {
+ @hashes := Array::reverse(@hashes);
+ %stored := Hash::new();
+ }
+
+ for @hashes {
+ my $hash := $_;
+
+ for @keys {
+ if ! Hash::exists(%stored, $_) && Hash::exists($hash, $_) {
+ %into{$_} :=
+ %stored{$_} := $hash{$_};
+ }
+ }
+ }
+
+ return %into;
+}
+
+sub new(*%pairs) {
+ return %pairs;
+}
View
71 src/OS.nqp
@@ -0,0 +1,71 @@
+# $Id$
+class OS;
+
+sub _get_pmc() {
+ our $_Pmc;
+
+ unless Scalar::defined($_Pmc) {
+ $_Pmc := Q:PIR {
+ %r = root_new [ 'parrot' ; 'OS' ]
+ };
+ }
+
+ return $_Pmc;
+}
+
+sub chdir($path) {
+ _get_pmc().chdir($path);
+}
+
+sub chroot($path) {
+ return _get_pmc().chroot($path);
+}
+
+sub cwd() {
+ return _get_pmc().cwd();
+}
+
+sub link($from, $to) {
+ _get_pmc().link($from, $to);
+}
+
+sub lstat($path) {
+ return _get_pmc().lstat($path);
+}
+
+sub mkdir($path, $mode) {
+ _get_pmc().mkdir($path, $mode);
+}
+
+sub readdir($path) {
+ return _get_pmc().readdir($path);
+}
+
+sub rename($oldpath, $newpath) {
+ return _get_pmc().rename($oldpath, $newpath);
+}
+
+sub rm($path) {
+ _get_pmc().rm($path);
+}
+
+sub stat($path) {
+ return _get_pmc().stat($path);
+}
+
+sub symlink($from, $to) {
+ _get_pmc().symlink($from, $to);
+}
+
+# This isn't provided by the OS object, but where else should it go?
+sub time() {
+ my $result := Q:PIR {
+ $N0 = time
+ %r = box $N0
+ };
+ return $result;
+}
+
+sub umask($mask) {
+ return _get_pmc().umask($mask);
+}
View
47 src/Scalar.nqp
@@ -0,0 +1,47 @@
+# $Id$
+
+class Scalar;
+
+sub ASSERT($condition, *@message) {
+ Dumper::ASSERT(Dumper::info(), $condition, @message);
+}
+
+sub BACKTRACE() {
+ Q:PIR {{
+ backtrace
+ }};
+}
+
+sub DIE(*@msg) {
+ Dumper::DIE(Dumper::info(), @msg);
+}
+
+sub DUMP(*@pos, *%what) {
+ Dumper::DUMP(Dumper::info(), @pos, %what);
+}
+
+sub NOTE(*@parts) {
+ Dumper::NOTE(Dumper::info(), @parts);
+}
+
+################################################################
+
+sub defined($what) {
+ NOTE("Checking if something is defined");
+ DUMP($what);
+
+ my $result := Q:PIR {{
+ $P0 = find_lex '$what'
+ $I0 = defined $P0
+ %r = box $I0
+ }};
+
+ NOTE("Returning ", $result);
+ return $result;
+}
+
+sub undef() {
+ my $undef;
+
+ return $undef;
+}
View
436 src/String.nqp
@@ -0,0 +1,436 @@
+# $Id$
+
+class String;
+
+sub ASSERT($condition, *@message) {
+ Dumper::ASSERT(Dumper::info(), $condition, @message);
+}
+
+sub BACKTRACE() {
+ Q:PIR {{
+ backtrace
+ }};
+}
+
+sub DIE(*@msg) {
+ Dumper::DIE(Dumper::info(), @msg);
+}
+
+sub DUMP(*@pos, *%what) {
+ Dumper::DUMP(Dumper::info(), @pos, %what);
+}
+
+sub NOTE(*@parts) {
+ Dumper::NOTE(Dumper::info(), @parts);
+}
+
+################################################################
+
+our %Cclass_id;
+%Cclass_id<ANY> := 65535;
+%Cclass_id<NONE> := 0;
+%Cclass_id<UPPERCASE> := 1;
+%Cclass_id<LOWERCASE> := 2;
+%Cclass_id<ALPHABETIC> := 4;
+%Cclass_id<NUMERIC> := 8;
+%Cclass_id<HEXADECIMAL> := 16;
+%Cclass_id<WHITESPACE> := 32;
+%Cclass_id<PRINTING> := 64;
+%Cclass_id<GRAPHICAL> := 128;
+%Cclass_id<BLANK> := 256;
+%Cclass_id<CONTROL> := 512;
+%Cclass_id<PUNCTUATION> := 1024;
+%Cclass_id<ALPHANUMERIC> := 2048;
+%Cclass_id<NEWLINE> := 4096;
+%Cclass_id<WORD> := 8192;
+
+=sub char_at($str, $index)
+
+Returns the character at C<$index> in C<$str> -- that is, char_at($str, $index)
+is equivalent to doing C<$str[$index]>, except that doesn't work.
+
+=cut
+
+sub char_at($str, $index) {
+ #NOTE("index = ", $index, ", str = ", $str);
+
+ my $result := Q:PIR {
+ $P0 = find_lex '$str'
+ $P1 = find_lex '$index'
+ $S1 = $P0[$P1]
+ %r = box $S1
+ };
+
+ #NOTE("Result = '", $result, "'");
+ return $result;
+}
+
+sub character_offset_of($string, *%opts) {
+ DUMP(:string($string), :options(%opts));
+
+ our %Line_number_info;
+
+ unless %Line_number_info{$string} {
+ _init_line_number_info($string);
+ }
+
+ my $offset := 0 + %opts<offset>;
+
+ unless Hash::exists(%opts, 'line') {
+ %opts<line> := line_number_of($string, :offset($offset));
+ }
+
+ my $line := -1 + %opts<line>;
+ my $line_offset := %Line_number_info{$string}[$line];
+ NOTE("Line number offset is: ", $line_offset);
+ my $result := $offset - $line_offset;
+ return $result;
+}
+
+=sub display_width($str) {
+
+Compute the display width of the C<$str>, assuming that tabs
+are 8 characters wide, and all other chars are 1 character wide. Thus, a
+sequence like tab-space-space-tab will have a width of 16, since the two spaces
+do not equate to a full tab stop.
+
+Returns the computed width of C<$str>.
+
+=cut
+
+sub display_width($str) {
+ my $width := 0;
+
+ if $str {
+ my $i := 0;
+ my $len := length($str);
+
+ while $i < $len {
+ if char_at($str, $i) eq "\t" {
+ $width := $width + 8 - ($width % 8);
+ }
+ else {
+ $width++;
+ }
+
+ $i++;
+ }
+ }
+
+ return $width;
+}
+
+=sub find_cclass($class_name, $str, [:offset(#),] [:count(#)])
+
+Returns the index of the first character in C<$str> at or after C<:offset()> that
+is a member of the character class C<$class_name>. If C<:count()> is
+specified, scanning ends after the C<:count()> characters have been scanned.
+By default, C<:offset(0)> and C<:count(length($str))> are used.
+
+If no matching characters are found, returns the last index plus one.
+
+=cut
+
+sub find_cclass($class_name, $str, *%opts) {
+ my $offset := 0 + %opts<offset>;
+ my $count := %opts<count>;
+
+ unless $count {
+ $count := length($str) - $offset;
+ }
+
+ my $cclass := 0 + %Cclass_id{$class_name};
+
+ #NOTE("class = ", $class_name, "(", $cclass, "), offset = ", $offset, ", count = ", $count, ", str = ", $str);
+
+ my $result := Q:PIR {
+ .local int cclass, offset, count
+ $P0 = find_lex '$cclass'
+ cclass = $P0
+ $P0 = find_lex '$offset'
+ offset = $P0
+ $P0 = find_lex '$count'
+ count = $P0
+
+ .local string str
+ $P0 = find_lex '$str'
+ str = $P0
+
+ $I0 = find_cclass cclass, str, offset, count
+ %r = box $I0
+
+ };
+
+ #NOTE("Result = ", $result);
+ return $result;
+}
+
+=sub find_not_cclass($class_name, $str, [:offset(#),] [:count(#)])
+
+Behaves like L<#find_cclass> except that the search is for the first
+character B<not> a member of C<$class_name>. Useful for skipping
+leading whitespace, etc.
+
+=cut
+
+sub find_not_cclass($class_name, $str, *%opts) {
+ my $offset := %opts<offset>;
+
+ unless $offset {
+ $offset := 0;
+ }
+
+ my $count := %opts<count>;
+
+ unless $count {
+ $count := length($str) - $offset;
+ }
+
+ my $class := 0 + %Cclass_id{$class_name};
+
+ #NOTE("class = ", $class_name, "(", $class, "), offset = ", $offset, ", count = ", $count, ", str = ", $str);
+
+ my $result := Q:PIR {
+ $P0 = find_lex '$class'
+ $I1 = $P0
+ $P0 = find_lex '$str'
+ $S2 = $P0
+ $P0 = find_lex '$offset'
+ $I3 = $P0
+ $P0 = find_lex '$count'
+ $I4 = $P0
+ $I0 = find_not_cclass $I1, $S2, $I3, $I4
+ %r = box $I0
+ };
+
+ #NOTE("Result = ", $result);
+ return $result;
+}
+
+sub index($haystack, $needle, *%opts) {
+ my $offset := 0 + %opts<offset>;
+
+ my $result := Q:PIR {
+ .local string haystack
+ $P0 = find_lex '$haystack'
+ haystack = $P0
+
+ .local string needle
+ $P0 = find_lex '$needle'
+ needle = $P0
+
+ .local int offset
+ $P0 = find_lex '$offset'
+ offset = $P0
+
+ $I0 = index haystack, needle, offset
+ %r = box $I0
+ };
+
+ return $result;
+}
+
+sub is_cclass($class_name, $str, *%opts) {
+ my $offset := 0 + %opts<offset>;
+ my $class := 0 + %Cclass_id{$class_name};
+
+ #NOTE("class = ", $class_name, "(", $class, "), offset = ", $offset, ", str = ", $str);
+
+ my $result := Q:PIR {
+ $P0 = find_lex '$class'
+ $I1 = $P0
+ $P0 = find_lex '$str'
+ $S2 = $P0
+ $P0 = find_lex '$offset'
+ $I3 = $P0
+ $I0 = is_cclass $I1, $S2, $I3
+ %r = box $I0
+ };
+
+ #NOTE("Result = ", $result);
+ return $result;
+}
+
+sub length($str, *%opts) {
+ my $offset := 0 + %opts<offset>;
+ #NOTE("Computing length of string beyond offset ", $offset);
+ #DUMP($str);
+
+ my $result := Q:PIR {
+ $P0 = find_lex '$str'
+ $S0 = $P0
+ $I0 = length $S0
+ %r = box $I0
+ };
+
+ if $offset > $result {
+ $offset := $result;
+ }
+
+ $result := $result - $offset;
+
+ #NOTE("Result = ", $result);
+ return $result;
+}
+
+sub _init_line_number_info($string) {
+ #NOTE("Initializing line-number information of previously-unseen string");
+ #DUMP($string);
+
+ my @lines := Array::new(-1);
+ my $len := String::length($string);
+ my $i := -1;
+
+ while $i < $len {
+ $i := String::find_cclass('NEWLINE', $string, :offset($i + 1));
+ @lines.push($i);
+ }
+
+ our %Line_number_info;
+
+ %Line_number_info{$string} := @lines;
+ #NOTE("String parsed into ", +@lines, " lines");
+ #DUMP(@lines);
+}
+
+sub line_number_of($string, *%opts) {
+ DUMP(:string($string), :options(%opts));
+
+ unless $string {
+ NOTE("String is empty or undef. Returning 1");
+ return 1;
+ }
+
+ our %Line_number_info;
+
+ unless %Line_number_info{$string} {
+ _init_line_number_info($string);
+ }
+
+ my $offset := 0 + %opts<offset>;
+
+ NOTE("Bsearching for line number of ", $offset, " in string");
+
+ my $line := Array::bsearch(%Line_number_info{$string}, $offset, :cmp('<=>'));
+
+ if $line < 0 {
+ # Likely case - token is between the newlines.
+ $line := (-$line) - 1;
+ }
+
+ #$line ++;
+ NOTE("Returning line number (1-based): ", $line);
+ return $line;
+}
+
+sub ltrim_indent($str, $indent) {
+ my $limit := find_not_cclass('WHITESPACE', $str);
+
+ my $i := 0;
+ my $prefix := 0;
+
+ while $i < $limit && $prefix < $indent {
+ if char_at($str, $i) eq "\t" {
+ $prefix := $prefix + 8 - $prefix % 8;
+ }
+ else {
+ $prefix ++;
+ }
+ }
+
+ return substr($str, $i);
+}
+
+sub repeat($str, $times) {
+ my $result := Q:PIR {
+ $P0 = find_lex '$str'
+ $S0 = $P0
+ $P0 = find_lex '$times'
+ $I0 = $P0
+ $S1 = repeat $S0, $I0
+ %r = box $S1
+ };
+
+ return $result;
+}
+
+sub split($delim, $str) {
+ #NOTE("delim = '", $delim, "', str = ", $str);
+
+ my @array := Q:PIR {
+ $P0 = find_lex '$delim'
+ $S0 = $P0
+ $P1 = find_lex '$str'
+ $S1 = $P1
+ %r = split $S0, $S1
+ };
+
+ #DUMP(@array);
+ return @array;
+}
+
+sub substr($str, $start, *@rest) {
+ my $len := length($str);
+
+ if $start < 0 {
+ $start := $start + $len;
+ }
+
+ if $start > $len {
+ $start := $len;
+ }
+
+ $len := $len - $start;
+
+ my $limit := $len;
+
+ if +@rest {
+ $limit := @rest.shift();
+
+ if $limit < 0 {
+ $limit := $limit + $len;
+ }
+
+ if $limit > $len {
+ $limit := $len;
+ }
+ }
+
+ my $result := Q:PIR {
+ $P0 = find_lex '$str'
+ $S0 = $P0
+ $P0 = find_lex '$start'
+ $I0 = $P0
+ $P0 = find_lex '$limit'
+ $I1 = $P0
+ $S1 = substr $S0, $I0, $I1
+ %r = box $S1
+ };
+
+ return $result;
+}
+
+sub trim($str) {
+ my $result := '';
+ my $left := find_not_cclass('WHITESPACE', $str);
+ #NOTE("$left : ", $left);
+
+ my $len := length($str);
+ #NOTE("$len : ", $len);
+
+ if $left < $len {
+ my $right := $len - 1;
+
+ while is_cclass('WHITESPACE', $str, :offset($right)) {
+ $right --;
+ }
+
+ #NOTE("$right: ", $right);
+
+ # NB: +1 below to re-include non-ws that broke while.
+ $result := substr($str, $left, $right - $left + 1);
+ }
+
+ #NOTE("result: ", $result);
+ return $result;
+}

0 comments on commit 04d7242

Please sign in to comment.
Something went wrong with that request. Please try again.