Mercurial > hg > Gears > GearsAgda

comparison src/parallel_execution/generate_stub.pl @ 253:ebc13549394c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
generate stubArgs
author mir3636
date Thu, 26 Jan 2017 19:52:08 +0900
parents 682b1195e604
children edb3aff688d0
comparison
equal deleted inserted replaced
252:682b1195e604 253:ebc13549394c
24 my %type; 24 my %type;
25 my %code; 25 my %code;
26 my %dataGearVar; 26 my %dataGearVar;
27 my %dataGear; 27 my %dataGear;
28 my %dataGearName; 28 my %dataGearName;
29 my $implementation;
30 my $interface;
29 31
30 sub getDataGear { 32 sub getDataGear {
31 my ($filename) = @_; 33 my ($filename) = @_;
32 my ($interface, $implementation, $codeGearName, $name, $inTypedef); 34 my ($codeGearName, $name, $inTypedef);
33 open my $fd,"<",$filename or die("can't open $filename $!"); 35 open my $fd,"<",$filename or die("can't open $filename $!");
34 while (<$fd>) { 36 while (<$fd>) {
35 if (! $inTypedef) { 37 if (! $inTypedef) {
36 if (/^typedef struct (\w+) {/) { 38 if (/^typedef struct (\w+) {/) {
37 $inTypedef = 1; 39 $inTypedef = 1;
38 $name = $1; 40 $name = $1;
39 $dataGear{$name} = $_; 41 $dataGear{$name} = $_;
42 $code{$name} = [];
40 } elsif (/^(\w+)\* create(\w+)\(/) { 43 } elsif (/^(\w+)\* create(\w+)\(/) {
41 if (defined $interface) { 44 if (defined $interface) {
42 die "duplicate interface $interface\n"; 45 die "duplicate interface $interface\n";
43 } 46 }
44 $interface = $1; 47 $interface = $1;
45 $implementation = $2; 48 $implementation = $2;
46 if ( -f "$interface.cbc") { 49 if ( -f "$interface.cbc") {
47 &getDataGear("$interface.cbc"); 50 &getDataGear("$interface.cbc");
48 } 51 }
49 } elsif (/^\_\_code (\w+)/) {
50 $codeGearName = $1;
51 $dataGearVar{$codeGearName} = [];
52 args:while (/(struct|union) (\w+)(\*)+\s(\w+)/g) {
53 my $structType = $1;
54 my $typeName = $2;
55 my $varName = $4;
56 my $typeField = lcfirst($typeName);
57 push @{$dataGearVar{$codeGearName}},$varName;
58 if ($typeField ne $varName) {
59 $dataGearName{$codeGearName} .= "\t$typeName* $varName = ($typeName*)GearImpl(context, $varName, $varName);\n";
60 print STDOUT "$codeGearName \t$typeName* $varName = ($typeName*)GearImpl(context, $varName, $varName);\n";
61 } else {
62 for my $ivar ($var{$interface}) {
63 if ($varName eq $ivar) {
64 $dataGearName{$codeGearName} .= "\t$typeName* $varName = Gearef(context, $interface)->$varName;\n";
65 print STDOUT "$codeGearName \t$typeName* $varName = Gearef(context, $interface)->$varName;\n";
66 next args;
67 }
68 }
69 $dataGearName{$codeGearName} .= "\t$typeName* $varName = Gearef(context, $typeName)->$typeField;\n";
70 print STDOUT "$codeGearName \t$typeName* $varName = Gearef(context, $typeName)->$typeField;\n";
71 }
72 }
73 $dataGearName{$codeGearName} .= "\tgoto $codeGearName(context";
74 for my $arg ( @{$dataGearVar{$codeGearName}}) {
75 $dataGearName{$codeGearName} .= ", $arg";
76 }
77 $dataGearName{$codeGearName} .= ");";
78 } 52 }
79 next; 53 next;
80 } 54 }
81 # gather type name and type 55 # gather type name and type
82 $dataGear{$name} .= $_; 56 $dataGear{$name} .= $_;
105 print $fd $dataGearName; 79 print $fd $dataGearName;
106 print $fd "\n} \n\n"; 80 print $fd "\n} \n\n";
107 return 1; 81 return 1;
108 } 82 }
109 83
84 sub generateStubArgs {
85 my($codeGearName, $varName, $typeName, $typeField, $interface) = @_;
86 push @{$dataGearVar{$codeGearName}},$varName;
87 if ($typeField ne $varName) {
88 $dataGearName{$codeGearName} .= "\t$typeName* $varName = ($typeName*)GearImpl(context, $typeName, $varName);\n";
89 # print STDOUT "$codeGearName \t$typeName* $varName = ($typeName*)GearImpl(context, $typeName, $varName);\n";
90 } else {
91 for my $ivar ($var{$interface}) {
92 if ($varName eq $ivar) {
93 $dataGearName{$codeGearName} .= "\t$typeName* $varName = Gearef(context, $interface)->$varName;\n";
94 # print STDOUT "$codeGearName \t$typeName* $varName = Gearef(context, $interface)->$varName;\n";
95 return;
96 }
97 }
98 $dataGearName{$codeGearName} .= "\t$typeName* $varName = Gearef(context, $typeName)->$typeField;\n";
99 # print STDOUT "$codeGearName \t$typeName* $varName = Gearef(context, $typeName)->$typeField;\n";
100 }
101 }
102
110 sub generateDataGear { 103 sub generateDataGear {
111 my ($filename) = @_; 104 my ($filename) = @_;
112 my $fn1 = $filename; 105 my $fn1 = $filename;
113 $fn1 =~ s/\.cbc/.c/; 106 $fn1 =~ s/\.cbc/.c/;
114 open my $in,"<",$filename or die("can't open $filename $!"); 107 open my $in,"<",$filename or die("can't open $filename $!");
125 my $codeGearName; 118 my $codeGearName;
126 while (<$in>) { 119 while (<$in>) {
127 if (! $inTypedef) { 120 if (! $inTypedef) {
128 if (/^typedef struct (\w+) {/) { 121 if (/^typedef struct (\w+) {/) {
129 $inTypedef = 1; 122 $inTypedef = 1;
130 } elsif (/^\_\_code (\w+)/) { 123 } elsif (/^\_\_code (\w+)\((.*)\)(.*)/) {
131 $codeGearName = $1; 124 $codeGearName = $1;
125 my $args = $2;
126 my $tail = $3;
132 if ($codeGearName =~ /_stub$/) { 127 if ($codeGearName =~ /_stub$/) {
133 $stub{$codeGearName} = 1; 128 $stub{$codeGearName} = 1;
134 print $fd $_; 129 print $fd $_;
135 next; 130 next;
136 } 131 }
137 $prevCodeGearName = $codeGearName;
138 if (defined $prevCodeGearName) { 132 if (defined $prevCodeGearName) {
139 if (defined $stub{$prevCodeGearName."_stub"}) { 133 if (defined $stub{$prevCodeGearName."_stub"}) {
140 undef $prevCodeGearName; 134 undef $prevCodeGearName;
141 print $fd $_; 135 print $fd $_;
142 next; 136 next;
143 } 137 }
144 $stub{$prevCodeGearName."_stub"} = &generateStub($fd,$prevCodeGearName,$dataGearName{$codeGearName}); 138 $stub{$prevCodeGearName."_stub"} = &generateStub($fd,$prevCodeGearName,$dataGearName{$prevCodeGearName});
145 } 139 }
146 #$prevCodeGearName = $codeGearName; 140 $prevCodeGearName = $codeGearName;
141 $dataGearVar{$codeGearName} = [];
142 my $newArgs = "";
143 while($args) {
144 if ($args =~ s/(^\s*,\s*)//) {
145 $newArgs .= $1;
146 }
147 # replace __code next
148 if ($args =~ s/^\_\_code\s(\w+)\([^)]*\)//) {
149 my $next = $1;
150 my @args = split(/,/,$2);
151 $newArgs .= "enum Code $next";
152 for my $arg (@args) {
153 $arg =~ s/^\s*//;
154 $arg =~ s/^(struct|union) (\w+)(\*)+\s(\w+)//;
155 my $structType = $1;
156 my $typeName = $2;
157 my $varName = $4;
158 my $typeField = lcfirst($typeName);
159 &generateStubArgs($codeGearName, $varName, $typeName, $typeField, $interface);
160 }
161 } elsif ($args =~ s/^(struct|union) (\w+)(\*)+\s(\w+)//) {
162 my $structType = $1;
163 my $typeName = $2;
164 my $varName = $4;
165 my $typeField = lcfirst($typeName);
166 $newArgs .= $&;
167 &generateStubArgs($codeGearName, $varName, $typeName, $typeField, $interface);
168 }
169 }
170 $dataGearName{$codeGearName} .= "\tgoto $codeGearName(context";
171 for my $arg ( @{$dataGearVar{$codeGearName}}) {
172 $dataGearName{$codeGearName} .= ", $arg";
173 }
174 $dataGearName{$codeGearName} .= ");";
175 print $fd "__code $codeGearName($newArgs)$tail\n";
176 next;
147 } elsif (/^(.*)goto next\(\.\.\.(.*)\);/) { 177 } elsif (/^(.*)goto next\(\.\.\.(.*)\);/) {
148 my $prev = $1; 178 my $prev = $1;
149 my $args = $2; 179 my $args = $2;
150 print $fd "${prev}goto meta(context, next);\n"; 180 print $fd "${prev}goto meta(context, next);\n";
151 next; 181 next;