line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# |
2
|
|
|
|
|
|
|
# This file is part of the Perlilog project. |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# Copyright (C) 2003, Eli Billauer |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# This program is free software; you can redistribute it and/or modify |
7
|
|
|
|
|
|
|
# it under the terms of the GNU General Public License as published by |
8
|
|
|
|
|
|
|
# the Free Software Foundation; either version 2 of the License, or |
9
|
|
|
|
|
|
|
# (at your option) any later version. |
10
|
|
|
|
|
|
|
# |
11
|
|
|
|
|
|
|
# This program is distributed in the hope that it will be useful, |
12
|
|
|
|
|
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
13
|
|
|
|
|
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
14
|
|
|
|
|
|
|
# GNU General Public License for more details. |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
# You should have received a copy of the GNU General Public License |
17
|
|
|
|
|
|
|
# along with this program; if not, write to the Free Software |
18
|
|
|
|
|
|
|
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA |
19
|
|
|
|
|
|
|
# |
20
|
|
|
|
|
|
|
# A copy of the license can be found in a file named "licence.txt", at the |
21
|
|
|
|
|
|
|
# root directory of this project. |
22
|
|
|
|
|
|
|
# |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
${__PACKAGE__.'::errorcrawl'}='system'; |
25
|
|
|
|
|
|
|
sub who { |
26
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
27
|
0
|
|
|
|
|
0
|
return "CodeGen. Obj. \'".$self->get('name')."\'"; |
28
|
|
|
|
|
|
|
} |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
sub new { |
31
|
1
|
|
|
1
|
|
1
|
my $this = shift; |
32
|
1
|
|
|
|
|
5
|
my $self = $this->SUPER::new(@_); |
33
|
1
|
50
|
|
|
|
3
|
$self -> registerobject($self -> get('beginend')) |
34
|
|
|
|
|
|
|
unless (defined $Perlilog::interface_rec); |
35
|
|
|
|
|
|
|
|
36
|
1
|
|
|
|
|
2
|
return $self; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub sustain { |
40
|
0
|
|
|
0
|
|
|
my $self = shift; |
41
|
0
|
|
|
|
|
|
$self->SUPER::sustain(@_); |
42
|
0
|
|
|
|
|
|
$self -> registerobject($self -> get('beginend')); |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub complete { |
46
|
0
|
|
|
0
|
|
|
my $self = shift; |
47
|
0
|
|
|
|
|
|
$self->SUPER::complete(@_); |
48
|
0
|
|
|
|
|
|
$self->set('header-comment', |
49
|
|
|
|
|
|
|
"// This is a generated file. Do not edit -- changes will be lost\n". |
50
|
|
|
|
|
|
|
"// Created by Perlilog v". |
51
|
|
|
|
|
|
|
$Perlilog::VERSION." on ".$Perlilog::STARTTIME."\n". |
52
|
|
|
|
|
|
|
"// Originating object: ".$self->who."\n\n"); |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub IDvar { |
56
|
0
|
|
|
0
|
|
|
my ($junk, $ID)=@_; |
57
|
0
|
|
|
|
|
|
my ($obj, $var)=@{$Perlilog::VARS[$ID]}; |
|
0
|
|
|
|
|
|
|
58
|
0
|
0
|
|
|
|
|
if (ref $obj) { |
59
|
0
|
0
|
|
|
|
|
return ($obj, $var) if wantarray; |
60
|
0
|
|
|
|
|
|
return $var; |
61
|
|
|
|
|
|
|
} else { |
62
|
0
|
0
|
|
|
|
|
return () if wantarray; |
63
|
0
|
|
|
|
|
|
return undef; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
sub varwho { |
68
|
0
|
|
|
0
|
|
|
my ($junk, $ID)=@_; |
69
|
0
|
|
|
|
|
|
my ($obj, $var)=@{$Perlilog::VARS[$ID]}; |
|
0
|
|
|
|
|
|
|
70
|
0
|
0
|
|
|
|
|
return "(unknown var ID $ID)" unless (ref $obj); |
71
|
0
|
|
|
|
|
|
my $name=$obj->get('name'); |
72
|
0
|
|
|
|
|
|
return "\'$var\' in module \'$name\'"; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub attach { |
76
|
|
|
|
|
|
|
#TODO: Save the comment both for immediate use and log it as well. |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# Get the details of the variables involved... |
79
|
|
|
|
|
|
|
# Note that it doesn't matter which object we are |
80
|
0
|
|
|
0
|
|
|
my ($junk, $ID1, $ID2, $comment) = @_; |
81
|
0
|
|
|
|
|
|
my ($obj1, $var1) = @{$Perlilog::VARS[$ID1]}; |
|
0
|
|
|
|
|
|
|
82
|
0
|
|
|
|
|
|
my ($obj2, $var2) = @{$Perlilog::VARS[$ID2]}; |
|
0
|
|
|
|
|
|
|
83
|
0
|
|
|
|
|
|
my $eq1 = $Perlilog::EQVARS[$ID1]; |
84
|
0
|
|
|
|
|
|
my $eq2 = $Perlilog::EQVARS[$ID2]; |
85
|
|
|
|
|
|
|
|
86
|
0
|
0
|
|
|
|
|
puke("attach() run with illegal ID1=$ID1\n") |
87
|
|
|
|
|
|
|
unless (ref $obj1); |
88
|
0
|
0
|
|
|
|
|
puke("attach() run with illegal ID2=$ID2\n") |
89
|
|
|
|
|
|
|
unless (ref $obj2); |
90
|
|
|
|
|
|
|
|
91
|
0
|
0
|
|
|
|
|
return 1 if ($eq1 eq $eq2); # Do nothing if they are already connected |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# Make a new equivalence list, and update all relevant entries. |
94
|
0
|
|
|
|
|
|
my @neweq = (@{$eq1}, @{$eq2}); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
95
|
0
|
|
|
|
|
|
my $i; |
96
|
0
|
|
|
|
|
|
foreach $i (@neweq) { |
97
|
0
|
|
|
|
|
|
$Perlilog::EQVARS[$i] = \@neweq; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# Set magic callbacks to update (or check) the 'dim' property mutually. |
101
|
|
|
|
|
|
|
# If you read this and try to imitate, you'd better know a few things |
102
|
|
|
|
|
|
|
# about the scope in which the anonymous subroutine is run. |
103
|
|
|
|
|
|
|
# You've been warned. |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
$obj1->addmagic(['vars', $var1, 'dim'], |
106
|
0
|
|
|
0
|
|
|
sub { $obj2->const(['vars', $var2, 'dim'], |
107
|
0
|
|
|
|
|
|
$obj1->get(['vars', $var1, 'dim'])); }); |
108
|
|
|
|
|
|
|
$obj2->addmagic(['vars', $var2, 'dim'], |
109
|
0
|
|
|
0
|
|
|
sub { $obj1->const(['vars', $var1, 'dim'], |
110
|
0
|
|
|
|
|
|
$obj2->get(['vars', $var2, 'dim'])); }); |
111
|
0
|
|
|
|
|
|
return 1; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub samedim { |
115
|
0
|
|
|
0
|
|
|
my $self = shift; |
116
|
0
|
|
|
|
|
|
my $var1 = shift; |
117
|
0
|
0
|
|
|
|
|
puke("samedim called with unknown variable name ".$self->prettyval($var1). |
118
|
|
|
|
|
|
|
" on object ".$self->who."\n") |
119
|
|
|
|
|
|
|
unless (defined $self->get(['vars', $var1, 'ID'])); |
120
|
0
|
|
|
|
|
|
my $i; |
121
|
0
|
|
|
|
|
|
foreach $i (@_) { |
122
|
|
|
|
|
|
|
# We get a local copy of $i for this BLOCK ($var2). |
123
|
|
|
|
|
|
|
# We can't use $i, because by the time the callback is executed, |
124
|
|
|
|
|
|
|
# its value may have been altered. |
125
|
0
|
|
|
|
|
|
my $var2 = $i; |
126
|
0
|
0
|
|
|
|
|
puke("samedim called with unknown variable name ".$self->prettyval($var2). |
127
|
|
|
|
|
|
|
" on object ".$self->who."\n") |
128
|
|
|
|
|
|
|
unless (defined $self->get(['vars', $var2, 'ID'])); |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
$self->addmagic(['vars', $var1, 'dim'], |
131
|
0
|
|
|
0
|
|
|
sub { $self->const(['vars', $var2, 'dim'], |
132
|
0
|
|
|
|
|
|
$self->get(['vars', $var1, 'dim'])); }); |
133
|
|
|
|
|
|
|
$self->addmagic(['vars', $var2, 'dim'], |
134
|
0
|
|
|
0
|
|
|
sub { $self->const(['vars', $var1, 'dim'], |
135
|
0
|
|
|
|
|
|
$self->get(['vars', $var2, 'dim'])); }); |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
sub getID { |
140
|
0
|
|
|
0
|
|
|
my $self = shift; |
141
|
0
|
|
|
|
|
|
my @vars = @_; |
142
|
0
|
|
|
|
|
|
my $ID; |
143
|
0
|
|
|
|
|
|
foreach (@vars) { |
144
|
0
|
|
|
|
|
|
$ID = $self->get(['vars', $_, 'ID']); |
145
|
0
|
0
|
|
|
|
|
puke("getID called with unknown variable name\n") |
146
|
|
|
|
|
|
|
unless (defined $ID); |
147
|
0
|
|
|
|
|
|
$_=$ID; |
148
|
|
|
|
|
|
|
} |
149
|
0
|
0
|
|
|
|
|
return @vars if wantarray; |
150
|
0
|
|
|
|
|
|
return $vars[0]; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
sub getport { |
154
|
0
|
|
|
0
|
|
|
my $self = shift; |
155
|
0
|
|
|
|
|
|
my $name = shift; |
156
|
0
|
|
|
|
|
|
my $port = $self->get(['user_port_names', $name]); |
157
|
|
|
|
|
|
|
|
158
|
0
|
0
|
|
|
|
|
puke("Failed to find port \'$name\' in ".$self->who."\n") |
159
|
|
|
|
|
|
|
unless (ref $port); |
160
|
0
|
|
|
|
|
|
return $port; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
sub labelID { |
165
|
0
|
|
|
0
|
|
|
my ($self, $port) = @_; |
166
|
0
|
0
|
|
|
|
|
puke("labelID called with non-object argument\n") |
167
|
|
|
|
|
|
|
unless ($self->isobject($port)); |
168
|
0
|
|
|
|
|
|
my $obj = $port->get('parent'); |
169
|
0
|
0
|
|
|
|
|
puke("labelID called with a port with no parent (is it really a port?)\n") |
170
|
|
|
|
|
|
|
unless ($self->isobject($obj)); |
171
|
0
|
|
|
|
|
|
my %h=$port->get('labels'); |
172
|
0
|
|
|
|
|
|
my ($val, $name); |
173
|
0
|
|
|
|
|
|
foreach (sort keys %h) { |
174
|
0
|
|
|
|
|
|
$name = $h{$_}; |
175
|
0
|
0
|
|
|
|
|
if ($name =~ /^\d+$/) { # $name is an ID? |
176
|
0
|
0
|
|
|
|
|
wrong("Unknown variable ID ".$self->prettyval($name). |
177
|
|
|
|
|
|
|
" given as \'$_\' in 'labels' property of ". |
178
|
|
|
|
|
|
|
$port->who()."\n") |
179
|
|
|
|
|
|
|
unless ($self->IDvar($name)); |
180
|
0
|
|
|
|
|
|
next; # It's in ID format. No more hassle. |
181
|
|
|
|
|
|
|
} |
182
|
0
|
|
|
|
|
|
$val = $obj->get(['vars', $name, 'ID']); |
183
|
0
|
0
|
|
|
|
|
if (defined $val) { |
184
|
0
|
|
|
|
|
|
$h{$_} = $val; |
185
|
|
|
|
|
|
|
} else { |
186
|
0
|
|
|
|
|
|
wrong("Undefined variable ".$self->prettyval($name). |
187
|
|
|
|
|
|
|
" given as \'$_\' in 'labels' property of ".$port->who()."\n"); |
188
|
0
|
|
|
|
|
|
delete $h{$_}; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
} |
191
|
0
|
|
|
|
|
|
return %h; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
sub interface { |
195
|
0
|
|
|
0
|
|
|
my $self = shift; |
196
|
0
|
|
|
|
|
|
my $obj = &Perlilog::interface(@_); |
197
|
0
|
0
|
|
|
|
|
$obj->setparent($self) if ($self->isobject($obj)); |
198
|
0
|
|
|
|
|
|
return $obj; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
sub getreset { |
202
|
0
|
|
|
0
|
|
|
my $self = shift; |
203
|
0
|
|
|
|
|
|
my $global = $self->globalobj(); |
204
|
0
|
|
|
|
|
|
my $type = $global->get('reset_type'); |
205
|
0
|
|
|
|
|
|
my $ID = $global->get('reset_ID'); |
206
|
0
|
0
|
|
|
|
|
return ($ID, $type) if wantarray; |
207
|
0
|
|
|
|
|
|
return $ID; |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
sub wheretorec { |
211
|
0
|
|
|
0
|
|
|
my $self = shift; |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
# First we check up if we've already answered this question. |
214
|
|
|
|
|
|
|
|
215
|
0
|
|
|
|
|
|
my $cached = $self->get('perlilog-whereto-answer'); |
216
|
0
|
0
|
|
|
|
|
return $cached if defined($cached); |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
# Now we ask ourselves for recommendations. "self" is always |
219
|
|
|
|
|
|
|
# assumed as a last (possibly only) resort, so we add it. |
220
|
|
|
|
|
|
|
|
221
|
0
|
|
|
|
|
|
my @targets = $self->codetargets; |
222
|
|
|
|
|
|
|
|
223
|
0
|
|
|
|
|
|
@targets = ((grep { ref } @targets), $self); |
|
0
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
# A yes/no lookup hash for those objects that we are not allowed |
226
|
|
|
|
|
|
|
# to return to (avoiding infinite recursion) |
227
|
0
|
|
|
|
|
|
my %blacklisted = map {($_, 1)} @_; |
|
0
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
|
229
|
0
|
|
|
|
|
|
my $answer = undef; |
230
|
|
|
|
|
|
|
|
231
|
0
|
|
|
|
|
|
foreach my $target (@targets) { |
232
|
0
|
0
|
|
|
|
|
next if ($blacklisted{$target}); |
233
|
0
|
0
|
|
|
|
|
next if ($target->get('static')); # Static objects are no targets |
234
|
0
|
0
|
|
|
|
|
if ($target == $self) { # $self was a last resort, remember? |
235
|
0
|
|
|
|
|
|
$answer = $target; |
236
|
0
|
|
|
|
|
|
last; # Perl novices: "last" means that we're skipping the rest... |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
# We want someone else to hold our code. But maybe this "someone else" |
239
|
|
|
|
|
|
|
# has a better idea? Let's ask. Note that when looking for that better |
240
|
|
|
|
|
|
|
# idea, $self has been added to the black list, so we won't loop around |
241
|
|
|
|
|
|
|
# forever. |
242
|
|
|
|
|
|
|
|
243
|
0
|
|
|
|
|
|
my $gossip = $target->wheretorec(@_, $self); |
244
|
0
|
0
|
|
|
|
|
if (ref $gossip) { # Did we get a solid answer? |
245
|
0
|
|
|
|
|
|
$answer = $gossip; |
246
|
0
|
|
|
|
|
|
last; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
# Remember our answer if it's worth anything. |
250
|
0
|
0
|
|
|
|
|
$self->const('perlilog-whereto-answer', $answer) |
251
|
|
|
|
|
|
|
if (ref $answer); |
252
|
0
|
|
|
|
|
|
return $answer; |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
sub whereto { |
256
|
0
|
|
|
0
|
|
|
my $self = shift; |
257
|
0
|
|
|
|
|
|
my $answer = $self->wheretorec(); |
258
|
|
|
|
|
|
|
|
259
|
0
|
0
|
|
|
|
|
wrong("Failed to find an object to put the Verilog code created by ". |
260
|
|
|
|
|
|
|
$self->who." (this is strange)\n") |
261
|
|
|
|
|
|
|
unless (ref $answer); |
262
|
|
|
|
|
|
|
|
263
|
0
|
|
|
|
|
|
return $answer; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
sub codetargets { |
267
|
0
|
|
|
0
|
|
|
return (); # By default, no other objects to divert the code to |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
# Empty methods (to avoid unknown method error) |
271
|
|
|
|
0
|
|
|
sub sanity {} |
272
|
|
|
|
0
|
|
|
sub generate {} |
273
|
|
|
|
0
|
|
|
sub instantiate {} |
274
|
|
|
|
0
|
|
|
sub headers {} |
275
|
|
|
|
0
|
|
|
sub epilogue {} |
276
|
|
|
|
0
|
|
|
sub files {} |