view src/parallel_execution/lib/Gears/Stub.pm @ 732:a7f52fd3d546

s/file_name/path/g
author anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
date Tue, 08 Dec 2020 16:42:07 +0900
parents b3d446fb5b93
children 331fe5141b20
line wrap: on
line source

package Gears::Stub;
use strict;
use warnings;

use Carp qw/croak/;

use Gears::Interface;

sub generate_constructor {
  my ($class, $interface_info, $impl_info, $is_cbc) = @_;

  my $interface_name = $interface_info->{name};
  my $impl_name      = $impl_info->{name};

  my $interface_ir = Gears::Interface->detailed_parse($interface_info->{file_name});
  my $impl_ir  = Gears::Interface->detailed_parse($impl_info->{file_name});

  my $interface_var_name = shift @{$interface_ir->{data}} // _decamelize($interface_name);

  if ($interface_var_name =~ /union\s*Data\*\s*(\w+)/) {
    $interface_var_name = $1;
  }

  my $impl_var_name  = _decamelize($impl_name);

  my @interface_data = @{$interface_ir->{data}};
  my @impl_data      = @{$impl_ir->{data}};

  my $constructor;

    #  struct StackTest2* stackTest2  = &ALLOCATE(context, StackTest2)->StackTest2;
    #struct StackTest2Impl* stack_test2impl = &ALLOCATE(context, StackTest2Impl)->StackTest2Impl;

  if ($is_cbc) {
  $constructor .=  <<"EOF";
$impl_ir->{isa}* create$impl_ir->{name}(struct Context* context) {
    struct $impl_ir->{isa}* $interface_var_name  = &ALLOCATE(context, $impl_ir->{isa})->$impl_ir->{isa};
    struct $impl_ir->{name}* $impl_var_name = &ALLOCATE(context, $impl_ir->{name})->$impl_ir->{name};
    $interface_var_name->$interface_var_name = (union Data*)$impl_var_name;
EOF
  } else {
  $constructor .= <<"EOF";
$impl_ir->{isa}* create$impl_ir->{name}(struct Context* context) {
    struct $impl_ir->{isa}* $interface_var_name  = new $impl_ir->{isa}();
    struct $impl_ir->{name}* $impl_var_name = new $impl_ir->{name}();
    ${interface_var_name}->${interface_var_name} = (union Data*)$impl_var_name;
EOF
  }

  $constructor .= _generate_variable_initialization($interface_ir->{data}, $interface_var_name);
  $constructor .= _generate_variable_initialization($impl_ir->{data},      $impl_var_name);



  for my $code (@{$impl_ir->{codes}}) {
      my $code_gear = $code->{name};
      next if $code_gear eq 'next';
      $constructor .= "    ${impl_var_name}->$code_gear = C_$code_gear;\n"
  }

  for my $code (@{$interface_ir->{codes}}) {
      my $code_gear = $code->{name};
      next if $code_gear eq 'next';
      $constructor .= "    ${interface_var_name}->$code_gear = C_${code_gear}$impl_ir->{name};\n"
  }

  $constructor .= "    return $interface_var_name;\n";
  $constructor .= "}\n";

  return $constructor;
}

sub _generate_variable_initialization {
  my ($data, $varTypeName) = @_;
  my @generate_lines;
  for my $datum (@$data) {
        $datum =~ s|//[\s\w]+||;
        if ($datum =~ /^\s+#/) {
          next;
        }

        if ($datum =~ /\w+\s\w+\*\s(\w+)/) {
           push(@generate_lines, "    ${varTypeName}->$1 = NULL;\n");
            next;
        }
        if ($datum =~ /\w+\s\w+\s(\w+)/) {
            push(@generate_lines, "    ${varTypeName}->$1 = 0;\n");
        }

        if ($datum =~ /\w+(\*)?\s(\w+)/) {
            my $is_pointer = $1;
            my $name = $2;
            if ($is_pointer) {
                push(@generate_lines, "    ${varTypeName}->$name = NULL;\n");
            } else {
                push(@generate_lines, "    ${varTypeName}->$name  = 0;\n");
            }
        }
  }

  return join '', @generate_lines;
}

#https://metacpan.org/pod/String::CamelCase
sub _decamelize {
  my $s = shift;
  $s =~ s{([^a-zA-Z]?)([A-Z]*)([A-Z])([a-z]?)}{
          my $fc = pos($s)==0;
          my ($p0,$p1,$p2,$p3) = ($1,lc$2,lc$3,$4);
          my $t = $p0 || $fc ? $p0 : '_';
          $t .= $p3 ? $p1 ? "${p1}_$p2$p3" : "$p2$p3" : "$p1$p2";
          $t;
  }ge;
  $s;
}


1;