Generate the SignedBuf/UnsignedBuf roles

So that we only need to maintain one set of code
rakudo · Feb 14, 2022 · 65507b8 · niner · Feb 15, 2022 · lizmat
1 parent b5f49ac
commit 65507b8
Show file tree

Hide file tree

Showing 2 changed files with 226 additions and 38 deletions.
diff --git a/src/core.c/Buf.pm6 b/src/core.c/Buf.pm6
@@ -880,37 +880,40 @@ my class utf32 does Blob[uint32] is repr('VMArray') {
 
 my role Buf[::T = uint8] does Blob[T] is repr('VMArray') is array_type(T) {
 
+#- start of generated part of Buf Signed role --------------------------------
+#- Generated on 2022-02-14T22:51:31+01:00 by ./tools/build/makeNATIVE_BLOB.raku
+#- PLEASE DON'T CHANGE ANYTHING BELOW THIS LINE
+
     my role SignedBuf[::T] is repr('VMArray') is array_type(T) is implementation-detail {
-        multi method AT-POS(::?ROLE:D: int \pos) is raw {
-            nqp::islt_i(pos,0)
-              ?? Failure.new(X::OutOfRange.new(
-                   :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>))
-              !! nqp::atposref_i(self, pos)
+        sub OOR(int $got) {
+            Failure.new(X::OutOfRange.new(
+              :what($*INDEX // 'Index'), :$got, :range<0..^Inf>
+            ))
+        }
+        multi method AT-POS(::?ROLE:D: int $pos) is raw is default {
+            nqp::islt_i($pos,0)
+              ?? OOR($pos)
+              !! nqp::atposref_i(self,$pos)
         }
-        multi method AT-POS(::?ROLE:D: Int:D \pos) is raw {
-            my int $pos = nqp::unbox_i(pos);
+        multi method AT-POS(::?ROLE:D: Int:D $pos) is raw is default {
             nqp::islt_i($pos,0)
-              ?? Failure.new(X::OutOfRange.new(
-                   :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>))
+              ?? OOR($pos)
               !! nqp::atposref_i(self,$pos)
         }
 
-        multi method ASSIGN-POS(::?CLASS:D: int \pos, Mu \assignee) {
-            nqp::islt_i(pos,0)
-              ?? Failure.new(X::OutOfRange.new(
-                   :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>))
-              !! nqp::bindpos_i(self,pos,assignee)
+        multi method ASSIGN-POS(::?ROLE:D: int $pos, Mu \assignee) {
+            nqp::islt_i($pos,0)
+              ?? OOR($pos)
+              !! nqp::bindpos_i(self,$pos,assignee)
         }
-        multi method ASSIGN-POS(::?CLASS:D: Int:D \pos, Mu \assignee) {
-            my int $pos = nqp::unbox_i(pos);
+        multi method ASSIGN-POS(::?ROLE:D: Int:D $pos, Mu \assignee) {
             nqp::islt_i($pos,0)
-              ?? Failure.new(X::OutOfRange.new(
-                   :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>))
+              ?? OOR($pos)
               !! nqp::bindpos_i(self,$pos,assignee)
         }
 
         multi method list(::?ROLE:D:) is default {
-            my int $elems = nqp::elems(self);
+            my uint $elems = nqp::elems(self);
 
             # presize memory, but keep it empty, so we can just push
             my $buffer := nqp::setelems(
@@ -991,38 +994,43 @@ my role Buf[::T = uint8] does Blob[T] is repr('VMArray') is array_type(T) {
             $self
         }
     }
+#- PLEASE DON'T CHANGE ANYTHING ABOVE THIS LINE
+#- end of generated part of Buf Signed role ----------------------------------
+
+#- start of generated part of Buf Unsigned role --------------------------------
+#- Generated on 2022-02-14T22:51:31+01:00 by ./tools/build/makeNATIVE_BLOB.raku
+#- PLEASE DON'T CHANGE ANYTHING BELOW THIS LINE
 
     my role UnsignedBuf[::T] is repr('VMArray') is array_type(T) is implementation-detail {
-        multi method AT-POS(::?ROLE:D: int \pos) is raw is default {
-            nqp::islt_i(pos,0)
-              ?? Failure.new(X::OutOfRange.new(
-                   :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>))
-              !! nqp::atposref_u(self, pos)
+        sub OOR(int $got) {
+            Failure.new(X::OutOfRange.new(
+              :what($*INDEX // 'Index'), :$got, :range<0..^Inf>
+            ))
+        }
+        multi method AT-POS(::?ROLE:D: int $pos) is raw is default {
+            nqp::islt_i($pos,0)
+              ?? OOR($pos)
+              !! nqp::atposref_u(self,$pos)
         }
-        multi method AT-POS(::?ROLE:D: Int:D \pos) is raw is default {
-            my int $pos = nqp::unbox_i(pos);
+        multi method AT-POS(::?ROLE:D: Int:D $pos) is raw is default {
             nqp::islt_i($pos,0)
-              ?? Failure.new(X::OutOfRange.new(
-                   :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>))
+              ?? OOR($pos)
               !! nqp::atposref_u(self,$pos)
         }
 
-        multi method ASSIGN-POS(::?CLASS:D: int \pos, Mu \assignee) {
-            nqp::islt_i(pos,0)
-              ?? Failure.new(X::OutOfRange.new(
-                   :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>))
-              !! nqp::bindpos_u(self,pos,assignee)
+        multi method ASSIGN-POS(::?ROLE:D: int $pos, Mu \assignee) {
+            nqp::islt_i($pos,0)
+              ?? OOR($pos)
+              !! nqp::bindpos_u(self,$pos,assignee)
         }
-        multi method ASSIGN-POS(::?CLASS:D: Int:D \pos, Mu \assignee) {
-            my int $pos = nqp::unbox_i(pos);
+        multi method ASSIGN-POS(::?ROLE:D: Int:D $pos, Mu \assignee) {
             nqp::islt_i($pos,0)
-              ?? Failure.new(X::OutOfRange.new(
-                   :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>))
+              ?? OOR($pos)
               !! nqp::bindpos_u(self,$pos,assignee)
         }
 
         multi method list(::?ROLE:D:) is default {
-            my int $elems = nqp::elems(self);
+            my uint $elems = nqp::elems(self);
 
             # presize memory, but keep it empty, so we can just push
             my $buffer := nqp::setelems(
@@ -1103,6 +1111,8 @@ my role Buf[::T = uint8] does Blob[T] is repr('VMArray') is array_type(T) {
             $self
         }
     }
+#- PLEASE DON'T CHANGE ANYTHING ABOVE THIS LINE
+#- end of generated part of Buf Unsigned role ----------------------------------
 
     $?CLASS.^add_role(T.^unsigned ?? UnsignedBuf[T] !! SignedBuf[T]);
 

diff --git a/tools/build/makeNATIVE_BLOB.raku b/tools/build/makeNATIVE_BLOB.raku
@@ -0,0 +1,178 @@
+#!/usr/bin/env raku
+
+# This script reads the native_array.pm6 file, and generates the intarray,
+# numarray and strarray roles in it, and writes it back to the file.
+
+# always use highest version of Raku
+use v6.*;
+
+my $generator = $*PROGRAM-NAME;
+my $generated = DateTime.now.gist.subst(/\.\d+/,'');
+my $start     = '#- start of generated part of Buf ';
+my $idpos     = $start.chars;
+my $idchars   = 3;
+my $end       = '#- end of generated part of Buf ';
+
+# slurp the whole file and set up writing to it
+my $filename = "src/core.c/Buf.pm6";
+my @lines = $filename.IO.lines;
+$*OUT = $filename.IO.open(:w);
+
+my %type_mapper = (
+  Signed => ( :name<SignedBuf>,
+              :postfix<i>,
+            ).Map,
+  Unsigned => ( :name<UnsignedBuf>,
+                :postfix<u>,
+              ).Map,
+);
+
+
+# for all the lines in the source that don't need special handling
+while @lines {
+    my $line := @lines.shift;
+
+    # nothing to do yet
+    unless $line.starts-with($start) {
+        say $line;
+        next;
+    }
+
+    my $type = $line.substr($idpos).words.head;
+
+    # found header, check validity and set up mapper
+    die "Don't know how to handle $type"
+      unless my %mapper := %type_mapper{$type};
+
+    say $start ~ $type ~ " role --------------------------------";
+    say "#- Generated on $generated by $generator";
+    say "#- PLEASE DON'T CHANGE ANYTHING BELOW THIS LINE";
+
+    # skip the old version of the code
+    while @lines {
+        last if @lines.shift.starts-with($end);
+    }
+    # spurt the role
+    say Q:to/SOURCE/.subst(/ '#' (\w+) '#' /, -> $/ { %mapper{$0} }, :g).chomp;
+
+    my role #name#[::T] is repr('VMArray') is array_type(T) is implementation-detail {
+        sub OOR(int $got) {
+            Failure.new(X::OutOfRange.new(
+              :what($*INDEX // 'Index'), :$got, :range<0..^Inf>
+            ))
+        }
+        multi method AT-POS(::?ROLE:D: int $pos) is raw is default {
+            nqp::islt_i($pos,0)
+              ?? OOR($pos)
+              !! nqp::atposref_#postfix#(self,$pos)
+        }
+        multi method AT-POS(::?ROLE:D: Int:D $pos) is raw is default {
+            nqp::islt_i($pos,0)
+              ?? OOR($pos)
+              !! nqp::atposref_#postfix#(self,$pos)
+        }
+
+        multi method ASSIGN-POS(::?ROLE:D: int $pos, Mu \assignee) {
+            nqp::islt_i($pos,0)
+              ?? OOR($pos)
+              !! nqp::bindpos_#postfix#(self,$pos,assignee)
+        }
+        multi method ASSIGN-POS(::?ROLE:D: Int:D $pos, Mu \assignee) {
+            nqp::islt_i($pos,0)
+              ?? OOR($pos)
+              !! nqp::bindpos_#postfix#(self,$pos,assignee)
+        }
+
+        multi method list(::?ROLE:D:) is default {
+            my uint $elems = nqp::elems(self);
+
+            # presize memory, but keep it empty, so we can just push
+            my $buffer := nqp::setelems(
+              nqp::setelems(nqp::create(IterationBuffer),$elems),
+              0
+            );
+
+            my int $i = -1;
+            nqp::while(
+              nqp::islt_i(++$i,$elems),
+              nqp::push($buffer,nqp::atposref_#postfix#(self,$i))
+            );
+            $buffer.List
+        }
+
+        method write-ubits(::?ROLE \SELF:
+          int $pos, Int:D $bits, UInt:D \value
+        ) is raw {
+
+            # sanity check
+            POS-OOR(SELF, $pos) if $pos < 0;
+            my $self := nqp::isconcrete(self) ?? self !! nqp::create(self);
+
+            # set up basic info
+            my int $first-bit = $pos +& 7;
+            my int $last-bit  = ($pos + $bits) +& 7;
+            my int $first-byte = $pos +> 3;
+            my int $last-byte  = ($pos + $bits - 1) +> 3;
+
+            my $value := value +& (1 +< $bits - 1);            # mask valid part
+            $value := $value +< (8 - $last-bit) if $last-bit;  # move into position
+
+            my int $lmask = nqp::sub_i(1 +< $first-bit,1) +< (8 - $first-bit)
+              if $first-bit;
+            my int $rmask = 1 +< nqp::sub_i(8 - $last-bit,1)
+              if $last-bit;
+
+            # all done in a single byte
+            if $first-byte == $last-byte {
+                nqp::bindpos_#postfix#($self,$first-byte,
+                  $value +| (nqp::atpos_#postfix#($self,$first-byte) +& ($lmask +| $rmask))
+                );
+            }
+
+            # spread over multiple bytes
+            else {
+                my int $i = $last-byte;
+
+                # process last byte first if it is a partial
+                if $last-bit {
+                    nqp::bindpos_#postfix#($self,$i,
+                      ($value +& 255) +| (nqp::atpos_#postfix#($self,$i) +& $rmask)
+                    );
+                    $value := $value +> 8;
+                }
+
+                # not a partial, so make sure we process last byte later
+                else {
+                    ++$i;
+                }
+
+                # walk from right to left, exclude left-most is partial
+                my int $last = $first-byte + nqp::isgt_i($first-bit,0);
+                nqp::while(
+                  nqp::isge_i(--$i,$last),
+                  nqp::stmts(
+                    nqp::bindpos_#postfix#($self,$i,($value +& 255)),
+                    ($value := $value +> 8)
+                  )
+                );
+
+                # process last byte if it was a partial
+                nqp::bindpos_#postfix#($self,$i,($value +& 255)
+                  +| (nqp::atpos_#postfix#($self,$i) +& $lmask))
+                  if $first-bit;
+            }
+
+            $self
+        }
+    }
+SOURCE
+
+    # we're done for this role
+    say "#- PLEASE DON'T CHANGE ANYTHING ABOVE THIS LINE";
+    say $end ~ $type ~ " role ----------------------------------";
+}
+
+# close the file properly
+$*OUT.close;
+
+# vim: expandtab sw=4