Mercurial > hg > Papers > 2021 > anatofuz-master
view paper/src/Interface.pm @ 84:88ae1e4d83c6
update
author | anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp> |
---|---|
date | Fri, 05 Feb 2021 11:01:56 +0900 |
parents | |
children |
line wrap: on
line source
package Gears::Interface; use strict; use warnings; use Carp qw/croak cluck confess/; use File::Basename qw/dirname/; use File::Spec; use Gears::Util; #use DDP {deparse => 1}; sub parse { # create this data structure my ($class, $file) = @_; my $ir = {}; $ir->{file_name} = $file // confess "require file"; return undef unless (Gears::Util->file_checking($file)); open my $fh, '<', $file; my $line = <$fh>; my $static_data_gear_write_mode = 0; my $dir_name = dirname(File::Spec->rel2abs($file)); while ($line =~ /#include\s+"([\w\/\.]+)"/) { my $header_file = $1; if ($header_file =~ m|\./context\.h|) { $line = <$fh>; next; } push(@{$ir->{cbc_context_include_headers}}, "$dir_name/$header_file"); $line = <$fh>; } # skip space while ($line =~ /^\s*$/) { $line = <$fh>; } my $typed_variable = {}; if ($line =~ /typedef struct (\w+)\s?<(.*)>([\s\w{]+)/) { my $vname = $1; my $v_typed_variable = $2; my $annotation = $3; unless ($vname) { cluck "[WARN] invalied struct name from $file"; return undef; } $ir->{name} = $vname; if ($v_typed_variable) { $typed_variable = parse_header_typed_variable($v_typed_variable); $ir->{typed_variable_order} = $typed_variable->{__order}; } if ($annotation =~ m|\s*impl\s*([\w+]+)\s*{|) { $ir->{isa} = $1; } } return undef unless ($ir->{name}); my @data_gears; my %inner_code_gears; while ($line = <$fh>) { chomp $line; if ($line =~ m|\s*/\*|) { while ( $line !~ m|\*/|) { $line = <$fh>; next; } next; } next if ($line =~ /^\s+$/); next if ($line =~ m[^\s*//]); next if ($line =~ m[^\}\s*$ir->{name};]); if ($line =~ m|__code (\w+)|) { push(@data_gears,"enum Code $1;"); #this case insert __code name (__code hoge -> enum Code hoge;) #In the case of writing field variables one line at a time, cancel the following next if $static_data_gear_write_mode; my $args = $'; #$args eq (Impl* vm, pde_t* pgdir, char* init, uint sz, __code next(...)); while ($args =~ /\s*(struct|union|const|enum)?\s*([<>\w\[\]_]+)(\*)?\s*(\w+)?,?/g) { my $const_type = $1; my $type = $2; my $pointer = $3 // ""; my $vname = $4; if ($type eq '__code') { $inner_code_gears{$vname} = 1; #collect inner code gears (ex. next, whenEmpty) next; } next unless $vname; # __code hoge(int ret, __code next(ret, ...); this is second "ret" case $type =~ s/^(?:Impl|Type|Isa)\s*(\*)?/union Data/; my $val = "$type$pointer $vname;"; parse_generics($val); my $generics_info; if ($typed_variable) { ($val, $generics_info) = check_use_typed_variable($ir->{name},$typed_variable, $val); #define typed variable if (defined $generics_info->{type}){ unless (grep {$_->{vname} eq $generics_info->{vname} } @{$ir->{typed_variable}}) { push(@{$ir->{typed_variable}},$generics_info); push(@{$ir->{typed_variable_types}->{$generics_info->{type}}}, $generics_info->{vname}); } } } $generics_info = {}; ($val, $generics_info) = check_use_instance_generics_type($val); #define instance generics variable if (defined $generics_info->{type}){ unless (grep {$_->{vname} eq $generics_info->{vname} } @{$ir->{generics}}) { push(@{$ir->{generics}},$generics_info); } } push(@data_gears, $const_type ? "$const_type $val" : $val); } next; } #this is a case of writing field variables one line at a time $line =~ s/^\s+//; parse_generics($line); my $generics_info; if ($typed_variable && keys(%$typed_variable)) { ($line, $generics_info) = check_use_typed_variable($ir->{name},$typed_variable, $line); #define typed variable if (defined $generics_info->{type}){ unless (grep {$_->{vname} eq $generics_info->{vname} } @{$ir->{typed_variable}}) { push(@{$ir->{typed_variable}},$generics_info); push(@{$ir->{typed_variable_types}->{$generics_info->{type}}}, $generics_info->{vname}); } } } $generics_info = {}; ($line, $generics_info) = check_use_instance_generics_type($line); #define typed variable if (defined $generics_info->{type}){ unless (grep {$_->{vname} eq $generics_info->{vname} } @{$ir->{generics}}) { push(@{$ir->{generics}},$generics_info); } } push(@data_gears,$line); $static_data_gear_write_mode = 1; } $ir->{inner_code_gears} = \%inner_code_gears; push(@{$ir->{content}}, Gears::Util->uniq(@data_gears)); return $ir; } # separate_code_and_data_gear_after_parse sub detailed_parse { my ($class, $file) = @_; my $ir = Gears::Interface->parse($file); return undef unless ($ir); $ir->{hasOutputArgs} = {}; my @data_gears; my @code_gears; for my $dg (@{$ir->{content}}) { if ($dg =~ /enum Code (\w+);/) { push(@code_gears, $1); } else { push(@data_gears, $dg); } } open my $fh , '<', $file; my $i = 0; my @have_output_data; my @inner_code_gears; my @output_code_gears; while (($i < scalar @code_gears) && (my $line = <$fh>)) { my $codeGearName = $code_gears[$i]; if (exists $ir->{inner_code_gears}->{$codeGearName}) { $i++; next; } if ($line =~ m|__code $codeGearName\(([()\.\*\s\w,_]+)\)|) { my $arg = $1; # check individual argument # eg. (Impl* self, Int a, char* b, struct hoge* h, __code next(out* o, out* o2, ...)) # indivisual argument is self, a, b, h, next ( $argc == 5) my @comma_split_arg = split /,/, $arg; my $inParen = undef; my $argc = 0; for my $tmpArg (@comma_split_arg) { #ignore inner code gear (eg next) if ($tmpArg =~ /\(/ ) { $inParen = 1; } # want to __code next(...) <- right paren if ($tmpArg =~ /\)/) { $inParen = undef; } next if ($inParen); $argc++; } #ignore self # ex upper case, before $argc == 5, after $argc == 4 if (@comma_split_arg) { $argc-- if ($comma_split_arg[0] =~ /Impl/); } my $element = { name => $codeGearName, args => $arg, argc => $argc }; push(@output_code_gears, $element); #code gear name to hash $ir->{codeName}->{$codeGearName} = $element; # args eq "Impl* stack, __code next(Type* data, Type* data1, ...)", if ($arg =~ /__code \w+\((.+),\s*\.\.\.\s*\)/) { my $outputArgs = $1; while ($outputArgs =~ /(struct|union|const|enum)?\s*([\w*]+)\s(\w+),?/g) { my $structType = $1; my $ttype = $2; my $tname = $3; $ir->{hasOutputArgs}->{$codeGearName}->{$tname} = $ttype; } } $i++; } } $ir->{codes} = \@output_code_gears; $ir->{data} = \@data_gears; return $ir; } sub isThisFileInterface { my ($class, $filename) = @_; open my $fh, '<', $filename; my $line = <$fh>; #read top line ex Typedef struct Stack<Type, Impl> { return 0 unless ($line =~ /typedef struct \w+\s?<.*>([\s\w{]+)/); my $annotation = $1; return 0 if ($annotation =~ /impl/); return 1; } sub parse_header_typed_variable { #parsed typedef struct Hoge <S, T> { my $str = shift; my @pair_generics = split /,/, $str; my %typed_variable; for my $pear (@pair_generics) { $pear =~ s/\s*(\w+)/$1/; my ($type, $border) = split /:/, $pear; confess "failed parsed type at $pear\n" unless $type; unless ($border) { $border = "_any"; #_any is union Data* } $typed_variable{$type} = $border; push(@{$typed_variable{__order}},$type); } return \%typed_variable; } sub parse_generics { my $line = shift; return unless ($line =~ /([\w\*]+)\s*<([\w\*]+)>/); print "[INFO] use generics $1 $2 at $line\n"; } sub collect_interfaces_from_all_headers { my ($class, $find_path) = @_; my $header_files = Gears::Util->find_headers_from_path($find_path); my @result = sort grep { Gears::Interface->isThisFileInterface($_) } @$header_files; return \@result; } sub check_use_typed_variable { my ($caller, $typed_variable, $line) = @_; if ($line =~ /(\w+)(\*?)\s+(\w+);?$/) { my $type = $1; my $pointer = $2 // ''; my $vname = $3; my $typed_info = { type => $type, vname => $vname}; if (exists $typed_variable->{$type}) { if ($typed_variable->{$type} eq "_any") { #$line = "TYPED_GENERICS_${caller}_$type $pointer $vname;"; #no extend case } else { #extend case #$line = "EXTEND_TYPED_GENERICS_${type}_$typed_variable->{$type}$pointer $vname;"; # <T:Say> -> T_say $typed_info->{extends} = $typed_variable->{$type}; } return ($line, $typed_info); } } return ($line, {}); } sub check_use_instance_generics_type { #define typed variable my $line = shift; my $not_use = {}; my $use = {}; unless ($line =~ /(\w+)<(\w+)>(\*)?\s+(\w+);/) { return ($line, $not_use); } my $type = $1; my $generics = $2; my $pointer = $3; my $vname = $4; unless ($pointer) { $pointer = ""; } my $upGenerics = ucfirst($generics); $use->{type} = $type; $use->{generics} = $generics; $use->{vname} = $vname; #return ("INTERFACE_GENERICS_${type}_$upGenerics$pointer $vname;", $use); return ("$type$pointer $vname;", $use); } 1;