Mercurial > hg > Gears > Gears
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;