projects / OpenSPARC-T2-DV / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 design and verification files.
[OpenSPARC-T2-DV] / tools / perlmod / SunOS-i386 / Bit / Vector / Overload.pm
CommitLineData
86530b38
AT		 1package Bit::Vector::Overload;
2
3use strict;
4use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
5
6use Bit::Vector;
7
8require Exporter;
9
10@ISA = qw(Exporter Bit::Vector);
11
12@EXPORT = qw();
13
14@EXPORT_OK = qw();
15
16$VERSION = '6.4';
17
18package Bit::Vector;
19
20use Carp::Clan '^Bit::Vector\b';
21
22use overload
23 '""' => '_stringify',
24 'bool' => '_boolean',
25 '!' => '_not_boolean',
26 '~' => '_complement',
27 'neg' => '_negate',
28 'abs' => '_absolute',
29 '.' => '_concat',
30 'x' => '_xerox',
31 '<<' => '_shift_left',
32 '>>' => '_shift_right',
33 '|' => '_union',
34 '&' => '_intersection',
35 '^' => '_exclusive_or',
36 '+' => '_add',
37 '-' => '_sub',
38 '*' => '_mul',
39 '/' => '_div',
40 '%' => '_mod',
41 '**' => '_pow',
42 '.=' => '_assign_concat',
43 'x=' => '_assign_xerox',
44 '<<=' => '_assign_shift_left',
45 '>>=' => '_assign_shift_right',
46 '|=' => '_assign_union',
47 '&=' => '_assign_intersection',
48 '^=' => '_assign_exclusive_or',
49 '+=' => '_assign_add',
50 '-=' => '_assign_sub',
51 '*=' => '_assign_mul',
52 '/=' => '_assign_div',
53 '%=' => '_assign_mod',
54 '**=' => '_assign_pow',
55 '++' => '_increment',
56 '--' => '_decrement',
57 'cmp' => '_lexicompare', # also enables lt, le, gt, ge, eq, ne
58 '<=>' => '_compare',
59 '==' => '_equal',
60 '!=' => '_not_equal',
61 '<' => '_less_than',
62 '<=' => '_less_equal',
63 '>' => '_greater_than',
64 '>=' => '_greater_equal',
65 '=' => '_clone',
66'fallback' => undef;
67
68$CONFIG[0] = 0;
69$CONFIG[1] = 0;
70$CONFIG[2] = 0;
71
72# Configuration:
73#
74# 0 = Scalar Input: 0 = Bit Index (default)
75# 1 = from_Hex
76# 2 = from_Bin
77# 3 = from_Dec
78# 4 = from_Enum
79#
80# 1 = Operator Semantics: 0 = Set Ops (default)
81# 1 = Arithmetic Ops
82#
83# Affected Operators: "+" "-" "*"
84# "<" "<=" ">" ">="
85# "abs"
86#
87# 2 = String Output: 0 = to_Hex() (default)
88# 1 = to_Bin()
89# 2 = to_Dec()
90# 3 = to_Enum()
91
92sub Configuration
93{
94 my(@commands);
95 my($assignment);
96 my($which,$value);
97 my($m0,$m1,$m2,$m3,$m4);
98 my($result);
99 my($ok);
100
101 if (@_ > 2)
102 {
103 croak('Usage: $oldconfig = Bit::Vector->Configuration( [ $newconfig ] );');
104 }
105 $result = "Scalar Input = ";
106 if ($CONFIG[0] == 4) { $result .= "Enumeration"; }
107 elsif ($CONFIG[0] == 3) { $result .= "Decimal"; }
108 elsif ($CONFIG[0] == 2) { $result .= "Binary"; }
109 elsif ($CONFIG[0] == 1) { $result .= "Hexadecimal"; }
110 else { $result .= "Bit Index"; }
111 $result .= "\nOperator Semantics = ";
112 if ($CONFIG[1] == 1) { $result .= "Arithmetic Operators"; }
113 else { $result .= "Set Operators"; }
114 $result .= "\nString Output = ";
115 if ($CONFIG[2] == 3) { $result .= "Enumeration"; }
116 elsif ($CONFIG[2] == 2) { $result .= "Decimal"; }
117 elsif ($CONFIG[2] == 1) { $result .= "Binary"; }
118 else { $result .= "Hexadecimal"; }
119 shift if (@_ > 0);
120 if (@_ > 0)
121 {
122 $ok = 1;
123 @commands = split(/[,;:|\/\n&+-]/, $_[0]);
124 foreach $assignment (@commands)
125 {
126 if ($assignment =~ /^\s*$/) { } # ignore empty lines
127 elsif ($assignment =~ /^([A-Za-z\s]+)=([A-Za-z\s]+)$/)
128 {
129 $which = $1;
130 $value = $2;
131 $m0 = 0;
132 $m1 = 0;
133 $m2 = 0;
134 if ($which =~ /\bscalar|\binput|\bin\b/i) { $m0 = 1; }
135 if ($which =~ /\boperator|\bsemantic|\bops\b/i) { $m1 = 1; }
136 if ($which =~ /\bstring|\boutput|\bout\b/i) { $m2 = 1; }
137 if ($m0 && !$m1 && !$m2)
138 {
139 $m0 = 0;
140 $m1 = 0;
141 $m2 = 0;
142 $m3 = 0;
143 $m4 = 0;
144 if ($value =~ /\bbit\b|\bindex|\bindice/i) { $m0 = 1; }
145 if ($value =~ /\bhex/i) { $m1 = 1; }
146 if ($value =~ /\bbin/i) { $m2 = 1; }
147 if ($value =~ /\bdec/i) { $m3 = 1; }
148 if ($value =~ /\benum/i) { $m4 = 1; }
149 if ($m0 && !$m1 && !$m2 && !$m3 && !$m4) { $CONFIG[0] = 0; }
150 elsif (!$m0 && $m1 && !$m2 && !$m3 && !$m4) { $CONFIG[0] = 1; }
151 elsif (!$m0 && !$m1 && $m2 && !$m3 && !$m4) { $CONFIG[0] = 2; }
152 elsif (!$m0 && !$m1 && !$m2 && $m3 && !$m4) { $CONFIG[0] = 3; }
153 elsif (!$m0 && !$m1 && !$m2 && !$m3 && $m4) { $CONFIG[0] = 4; }
154 else { $ok = 0; last; }
155 }
156 elsif (!$m0 && $m1 && !$m2)
157 {
158 $m0 = 0;
159 $m1 = 0;
160 if ($value =~ /\bset\b/i) { $m0 = 1; }
161 if ($value =~ /\barithmetic/i) { $m1 = 1; }
162 if ($m0 && !$m1) { $CONFIG[1] = 0; }
163 elsif (!$m0 && $m1) { $CONFIG[1] = 1; }
164 else { $ok = 0; last; }
165 }
166 elsif (!$m0 && !$m1 && $m2)
167 {
168 $m0 = 0;
169 $m1 = 0;
170 $m2 = 0;
171 $m3 = 0;
172 if ($value =~ /\bhex/i) { $m0 = 1; }
173 if ($value =~ /\bbin/i) { $m1 = 1; }
174 if ($value =~ /\bdec/i) { $m2 = 1; }
175 if ($value =~ /\benum/i) { $m3 = 1; }
176 if ($m0 && !$m1 && !$m2 && !$m3) { $CONFIG[2] = 0; }
177 elsif (!$m0 && $m1 && !$m2 && !$m3) { $CONFIG[2] = 1; }
178 elsif (!$m0 && !$m1 && $m2 && !$m3) { $CONFIG[2] = 2; }
179 elsif (!$m0 && !$m1 && !$m2 && $m3) { $CONFIG[2] = 3; }
180 else { $ok = 0; last; }
181 }
182 else { $ok = 0; last; }
183 }
184 else { $ok = 0; last; }
185 }
186 unless ($ok)
187 {
188 croak('configuration string syntax error');
189 }
190 }
191 return($result);
192}
193
194sub _error
195{
196 my($name,$code) = @_;
197 my($text);
198
199 if ($code == 0)
200 {
201 $text = $@;
202 $text =~ s!\s+! !g;
203 $text =~ s!\s+at\s.*$!!;
204 $text =~ s!^(?:Bit::Vector::)?[a-zA-Z0-9_]+\(\):\s*!!i;
205 $text =~ s!\s+$!!;
206 }
207 elsif ($code == 1) { $text = 'illegal operand type'; }
208 elsif ($code == 2) { $text = 'illegal reversed operands'; }
209 else { croak('unexpected internal error - please contact author'); }
210 $text .= " in overloaded ";
211 if (length($name) > 5) { $text .= "$name operation"; }
212 else { $text .= "'$name' operator"; }
213 croak($text);
214}
215
216sub _vectorize_
217{
218 my($vector,$scalar) = @_;
219
220 if ($CONFIG[0] == 4) { $vector->from_Enum($scalar); }
221 elsif ($CONFIG[0] == 3) { $vector->from_Dec ($scalar); }
222 elsif ($CONFIG[0] == 2) { $vector->from_Bin ($scalar); }
223 elsif ($CONFIG[0] == 1) { $vector->from_Hex ($scalar); }
224 else { $vector->Bit_On ($scalar); }
225}
226
227sub _scalarize_
228{
229 my($vector) = @_;
230
231 if ($CONFIG[2] == 3) { return( $vector->to_Enum() ); }
232 elsif ($CONFIG[2] == 2) { return( $vector->to_Dec () ); }
233 elsif ($CONFIG[2] == 1) { return( $vector->to_Bin () ); }
234 else { return( $vector->to_Hex () ); }
235}
236
237sub _fetch_operand
238{
239 my($object,$argument,$flag,$name,$build) = @_;
240 my($operand);
241
242 if ((defined $argument) && ref($argument) && (ref($argument) !~ /^[A-Z]+$/))
243 {
244 eval
245 {
246 if ($build && (defined $flag))
247 {
248 $operand = $argument->Clone();
249 }
250 else { $operand = $argument; }
251 };
252 if ($@) { &_error($name,0); }
253 }
254 elsif ((defined $argument) && (!ref($argument)))
255 {
256 eval
257 {
258 $operand = $object->Shadow();
259 &_vectorize_($operand,$argument);
260 };
261 if ($@) { &_error($name,0); }
262 }
263 else { &_error($name,1); }
264 return($operand);
265}
266
267sub _check_operand
268{
269 my($argument,$flag,$name) = @_;
270
271 if ((defined $argument) && (!ref($argument)))
272 {
273 if ((defined $flag) && $flag) { &_error($name,2); }
274 }
275 else { &_error($name,1); }
276}
277
278sub _stringify
279{
280 my($vector) = @_;
281 my($name) = 'string interpolation';
282 my($result);
283
284 eval
285 {
286 $result = &_scalarize_($vector);
287 };
288 if ($@) { &_error($name,0); }
289 return($result);
290}
291
292sub _boolean
293{
294 my($object) = @_;
295 my($name) = 'boolean test';
296 my($result);
297
298 eval
299 {
300 $result = $object->is_empty();
301 };
302 if ($@) { &_error($name,0); }
303 return(! $result);
304}
305
306sub _not_boolean
307{
308 my($object) = @_;
309 my($name) = 'negated boolean test';
310 my($result);
311
312 eval
313 {
314 $result = $object->is_empty();
315 };
316 if ($@) { &_error($name,0); }
317 return($result);
318}
319
320sub _complement
321{
322 my($object) = @_;
323 my($name) = '~';
324 my($result);
325
326 eval
327 {
328 $result = $object->Shadow();
329 $result->Complement($object);
330 };
331 if ($@) { &_error($name,0); }
332 return($result);
333}
334
335sub _negate
336{
337 my($object) = @_;
338 my($name) = 'unary minus';
339 my($result);
340
341 eval
342 {
343 $result = $object->Shadow();
344 $result->Negate($object);
345 };
346 if ($@) { &_error($name,0); }
347 return($result);
348}
349
350sub _absolute
351{
352 my($object) = @_;
353 my($name) = 'abs()';
354 my($result);
355
356 eval
357 {
358 if ($CONFIG[1] == 1)
359 {
360 $result = $object->Shadow();
361 $result->Absolute($object);
362 }
363 else
364 {
365 $result = $object->Norm();
366 }
367 };
368 if ($@) { &_error($name,0); }
369 return($result);
370}
371
372sub _concat
373{
374 my($object,$argument,$flag) = @_;
375 my($name) = '.';
376 my($result);
377
378 $name .= '=' unless (defined $flag);
379 if ((defined $argument) && ref($argument) && (ref($argument) !~ /^[A-Z]+$/))
380 {
381 eval
382 {
383 if (defined $flag)
384 {
385 if ($flag) { $result = $argument->Concat($object); }
386 else { $result = $object->Concat($argument); }
387 }
388 else
389 {
390 $object->Interval_Substitute($argument,0,0,0,$argument->Size());
391 $result = $object;
392 }
393 };
394 if ($@) { &_error($name,0); }
395 return($result);
396 }
397 elsif ((defined $argument) && (!ref($argument)))
398 {
399 eval
400 {
401 if (defined $flag)
402 {
403 if ($flag) { $result = $argument . &_scalarize_($object); }
404 else { $result = &_scalarize_($object) . $argument; }
405 }
406 else
407 {
408 if ($CONFIG[0] == 2) { $result = $object->new( length($argument) ); }
409 elsif ($CONFIG[0] == 1) { $result = $object->new( length($argument) << 2 ); }
410 else { $result = $object->Shadow(); }
411 &_vectorize_($result,$argument);
412 $object->Interval_Substitute($result,0,0,0,$result->Size());
413 $result = $object;
414 }
415 };
416 if ($@) { &_error($name,0); }
417 return($result);
418 }
419 else { &_error($name,1); }
420}
421
422sub _xerox # (in Brazil, a photocopy is called a "xerox")
423{
424 my($object,$argument,$flag) = @_;
425 my($name) = 'x';
426 my($result);
427 my($offset);
428 my($index);
429 my($size);
430
431 $name .= '=' unless (defined $flag);
432 &_check_operand($argument,$flag,$name);
433 eval
434 {
435 $size = $object->Size();
436 if (defined $flag)
437 {
438 $result = $object->new($size * $argument);
439 $offset = 0;
440 $index = 0;
441 }
442 else
443 {
444 $result = $object;
445 $result->Resize($size * $argument);
446 $offset = $size;
447 $index = 1;
448 }
449 for ( ; $index < $argument; $index++, $offset += $size )
450 {
451 $result->Interval_Copy($object,$offset,0,$size);
452 }
453 };
454 if ($@) { &_error($name,0); }
455 return($result);
456}
457
458sub _shift_left
459{
460 my($object,$argument,$flag) = @_;
461 my($name) = '<<';
462 my($result);
463
464 $name .= '=' unless (defined $flag);
465 &_check_operand($argument,$flag,$name);
466 eval
467 {
468 if (defined $flag)
469 {
470 $result = $object->Clone();
471 $result->Insert(0,$argument);
472# $result->Move_Left($argument);
473 }
474 else
475 {
476# $object->Move_Left($argument);
477 $object->Insert(0,$argument);
478 $result = $object;
479 }
480 };
481 if ($@) { &_error($name,0); }
482 return($result);
483}
484
485sub _shift_right
486{
487 my($object,$argument,$flag) = @_;
488 my($name) = '>>';
489 my($result);
490
491 $name .= '=' unless (defined $flag);
492 &_check_operand($argument,$flag,$name);
493 eval
494 {
495 if (defined $flag)
496 {
497 $result = $object->Clone();
498 $result->Delete(0,$argument);
499# $result->Move_Right($argument);
500 }
501 else
502 {
503# $object->Move_Right($argument);
504 $object->Delete(0,$argument);
505 $result = $object;
506 }
507 };
508 if ($@) { &_error($name,0); }
509 return($result);
510}
511
512sub _union_
513{
514 my($object,$operand,$flag) = @_;
515
516 if (defined $flag)
517 {
518 $operand->Union($object,$operand);
519 return($operand);
520 }
521 else
522 {
523 $object->Union($object,$operand);
524 return($object);
525 }
526}
527
528sub _union
529{
530 my($object,$argument,$flag) = @_;
531 my($name) = '|';
532 my($operand);
533
534 $name .= '=' unless (defined $flag);
535 $operand = &_fetch_operand($object,$argument,$flag,$name,1);
536 eval
537 {
538 $operand = &_union_($object,$operand,$flag);
539 };
540 if ($@) { &_error($name,0); }
541 return($operand);
542}
543
544sub _intersection_
545{
546 my($object,$operand,$flag) = @_;
547
548 if (defined $flag)
549 {
550 $operand->Intersection($object,$operand);
551 return($operand);
552 }
553 else
554 {
555 $object->Intersection($object,$operand);
556 return($object);
557 }
558}
559
560sub _intersection
561{
562 my($object,$argument,$flag) = @_;
563 my($name) = '&';
564 my($operand);
565
566 $name .= '=' unless (defined $flag);
567 $operand = &_fetch_operand($object,$argument,$flag,$name,1);
568 eval
569 {
570 $operand = &_intersection_($object,$operand,$flag);
571 };
572 if ($@) { &_error($name,0); }
573 return($operand);
574}
575
576sub _exclusive_or
577{
578 my($object,$argument,$flag) = @_;
579 my($name) = '^';
580 my($operand);
581
582 $name .= '=' unless (defined $flag);
583 $operand = &_fetch_operand($object,$argument,$flag,$name,1);
584 eval
585 {
586 if (defined $flag)
587 {
588 $operand->ExclusiveOr($object,$operand);
589 }
590 else
591 {
592 $object->ExclusiveOr($object,$operand);
593 $operand = $object;
594 }
595 };
596 if ($@) { &_error($name,0); }
597 return($operand);
598}
599
600sub _add
601{
602 my($object,$argument,$flag) = @_;
603 my($name) = '+';
604 my($operand);
605
606 $name .= '=' unless (defined $flag);
607 $operand = &_fetch_operand($object,$argument,$flag,$name,1);
608 eval
609 {
610 if ($CONFIG[1] == 1)
611 {
612 if (defined $flag)
613 {
614 $operand->add($object,$operand,0);
615 }
616 else
617 {
618 $object->add($object,$operand,0);
619 $operand = $object;
620 }
621 }
622 else
623 {
624 $operand = &_union_($object,$operand,$flag);
625 }
626 };
627 if ($@) { &_error($name,0); }
628 return($operand);
629}
630
631sub _sub
632{
633 my($object,$argument,$flag) = @_;
634 my($name) = '-';
635 my($operand);
636
637 $name .= '=' unless (defined $flag);
638 $operand = &_fetch_operand($object,$argument,$flag,$name,1);
639 eval
640 {
641 if ($CONFIG[1] == 1)
642 {
643 if (defined $flag)
644 {
645 if ($flag) { $operand->subtract($operand,$object,0); }
646 else { $operand->subtract($object,$operand,0); }
647 }
648 else
649 {
650 $object->subtract($object,$operand,0);
651 $operand = $object;
652 }
653 }
654 else
655 {
656 if (defined $flag)
657 {
658 if ($flag) { $operand->Difference($operand,$object); }
659 else { $operand->Difference($object,$operand); }
660 }
661 else
662 {
663 $object->Difference($object,$operand);
664 $operand = $object;
665 }
666 }
667 };
668 if ($@) { &_error($name,0); }
669 return($operand);
670}
671
672sub _mul
673{
674 my($object,$argument,$flag) = @_;
675 my($name) = '*';
676 my($operand);
677
678 $name .= '=' unless (defined $flag);
679 $operand = &_fetch_operand($object,$argument,$flag,$name,1);
680 eval
681 {
682 if ($CONFIG[1] == 1)
683 {
684 if (defined $flag)
685 {
686 $operand->Multiply($object,$operand);
687 }
688 else
689 {
690 $object->Multiply($object,$operand);
691 $operand = $object;
692 }
693 }
694 else
695 {
696 $operand = &_intersection_($object,$operand,$flag);
697 }
698 };
699 if ($@) { &_error($name,0); }
700 return($operand);
701}
702
703sub _div
704{
705 my($object,$argument,$flag) = @_;
706 my($name) = '/';
707 my($operand);
708 my($temp);
709
710 $name .= '=' unless (defined $flag);
711 $operand = &_fetch_operand($object,$argument,$flag,$name,1);
712 eval
713 {
714 $temp = $object->Shadow();
715 if (defined $flag)
716 {
717 if ($flag) { $operand->Divide($operand,$object,$temp); }
718 else { $operand->Divide($object,$operand,$temp); }
719 }
720 else
721 {
722 $object->Divide($object,$operand,$temp);
723 $operand = $object;
724 }
725 };
726 if ($@) { &_error($name,0); }
727 return($operand);
728}
729
730sub _mod
731{
732 my($object,$argument,$flag) = @_;
733 my($name) = '%';
734 my($operand);
735 my($temp);
736
737 $name .= '=' unless (defined $flag);
738 $operand = &_fetch_operand($object,$argument,$flag,$name,1);
739 eval
740 {
741 $temp = $object->Shadow();
742 if (defined $flag)
743 {
744 if ($flag) { $temp->Divide($operand,$object,$operand); }
745 else { $temp->Divide($object,$operand,$operand); }
746 }
747 else
748 {
749 $temp->Divide($object,$operand,$object);
750 $operand = $object;
751 }
752 };
753 if ($@) { &_error($name,0); }
754 return($operand);
755}
756
757sub _pow
758{
759 my($object,$argument,$flag) = @_;
760 my($name) = '**';
761 my($operand,$result);
762
763 $name .= '=' unless (defined $flag);
764 $operand = &_fetch_operand($object,$argument,$flag,$name,0);
765 eval
766 {
767 if (defined $flag)
768 {
769 $result = $object->Shadow();
770 if ($flag) { $result->Power($operand,$object); }
771 else { $result->Power($object,$operand); }
772 }
773 else
774 {
775 $object->Power($object,$operand);
776 $result = $object;
777 }
778 };
779 if ($@) { &_error($name,0); }
780 return($result);
781}
782
783sub _assign_concat
784{
785 my($object,$argument) = @_;
786
787 return( &_concat($object,$argument,undef) );
788}
789
790sub _assign_xerox
791{
792 my($object,$argument) = @_;
793
794 return( &_xerox($object,$argument,undef) );
795}
796
797sub _assign_shift_left
798{
799 my($object,$argument) = @_;
800
801 return( &_shift_left($object,$argument,undef) );
802}
803
804sub _assign_shift_right
805{
806 my($object,$argument) = @_;
807
808 return( &_shift_right($object,$argument,undef) );
809}
810
811sub _assign_union
812{
813 my($object,$argument) = @_;
814
815 return( &_union($object,$argument,undef) );
816}
817
818sub _assign_intersection
819{
820 my($object,$argument) = @_;
821
822 return( &_intersection($object,$argument,undef) );
823}
824
825sub _assign_exclusive_or
826{
827 my($object,$argument) = @_;
828
829 return( &_exclusive_or($object,$argument,undef) );
830}
831
832sub _assign_add
833{
834 my($object,$argument) = @_;
835
836 return( &_add($object,$argument,undef) );
837}
838
839sub _assign_sub
840{
841 my($object,$argument) = @_;
842
843 return( &_sub($object,$argument,undef) );
844}
845
846sub _assign_mul
847{
848 my($object,$argument) = @_;
849
850 return( &_mul($object,$argument,undef) );
851}
852
853sub _assign_div
854{
855 my($object,$argument) = @_;
856
857 return( &_div($object,$argument,undef) );
858}
859
860sub _assign_mod
861{
862 my($object,$argument) = @_;
863
864 return( &_mod($object,$argument,undef) );
865}
866
867sub _assign_pow
868{
869 my($object,$argument) = @_;
870
871 return( &_pow($object,$argument,undef) );
872}
873
874sub _increment
875{
876 my($object) = @_;
877 my($name) = '++';
878 my($result);
879
880 eval
881 {
882 $result = $object->increment();
883 };
884 if ($@) { &_error($name,0); }
885 return($result);
886}
887
888sub _decrement
889{
890 my($object) = @_;
891 my($name) = '--';
892 my($result);
893
894 eval
895 {
896 $result = $object->decrement();
897 };
898 if ($@) { &_error($name,0); }
899 return($result);
900}
901
902sub _lexicompare
903{
904 my($object,$argument,$flag) = @_;
905 my($name) = 'cmp';
906 my($operand);
907 my($result);
908
909 $operand = &_fetch_operand($object,$argument,$flag,$name,0);
910 eval
911 {
912 if ((defined $flag) && $flag)
913 {
914 $result = $operand->Lexicompare($object);
915 }
916 else
917 {
918 $result = $object->Lexicompare($operand);
919 }
920 };
921 if ($@) { &_error($name,0); }
922 return($result);
923}
924
925sub _compare
926{
927 my($object,$argument,$flag) = @_;
928 my($name) = '<=>';
929 my($operand);
930 my($result);
931
932 $operand = &_fetch_operand($object,$argument,$flag,$name,0);
933 eval
934 {
935 if ((defined $flag) && $flag)
936 {
937 $result = $operand->Compare($object);
938 }
939 else
940 {
941 $result = $object->Compare($operand);
942 }
943 };
944 if ($@) { &_error($name,0); }
945 return($result);
946}
947
948sub _equal
949{
950 my($object,$argument,$flag) = @_;
951 my($name) = '==';
952 my($operand);
953 my($result);
954
955 $operand = &_fetch_operand($object,$argument,$flag,$name,0);
956 eval
957 {
958 $result = $object->equal($operand);
959 };
960 if ($@) { &_error($name,0); }
961 return($result);
962}
963
964sub _not_equal
965{
966 my($object,$argument,$flag) = @_;
967 my($name) = '!=';
968 my($operand);
969 my($result);
970
971 $operand = &_fetch_operand($object,$argument,$flag,$name,0);
972 eval
973 {
974 $result = $object->equal($operand);
975 };
976 if ($@) { &_error($name,0); }
977 return(! $result);
978}
979
980sub _less_than
981{
982 my($object,$argument,$flag) = @_;
983 my($name) = '<';
984 my($operand);
985 my($result);
986
987 $operand = &_fetch_operand($object,$argument,$flag,$name,0);
988 eval
989 {
990 if ($CONFIG[1] == 1)
991 {
992 if ((defined $flag) && $flag)
993 {
994 $result = ($operand->Compare($object) < 0);
995 }
996 else
997 {
998 $result = ($object->Compare($operand) < 0);
999 }
1000 }
1001 else
1002 {
1003 if ((defined $flag) && $flag)
1004 {
1005 $result = ((!$operand->equal($object)) &&
1006 ($operand->subset($object)));
1007 }
1008 else
1009 {
1010 $result = ((!$object->equal($operand)) &&
1011 ($object->subset($operand)));
1012 }
1013 }
1014 };
1015 if ($@) { &_error($name,0); }
1016 return($result);
1017}
1018
1019sub _less_equal
1020{
1021 my($object,$argument,$flag) = @_;
1022 my($name) = '<=';
1023 my($operand);
1024 my($result);
1025
1026 $operand = &_fetch_operand($object,$argument,$flag,$name,0);
1027 eval
1028 {
1029 if ($CONFIG[1] == 1)
1030 {
1031 if ((defined $flag) && $flag)
1032 {
1033 $result = ($operand->Compare($object) <= 0);
1034 }
1035 else
1036 {
1037 $result = ($object->Compare($operand) <= 0);
1038 }
1039 }
1040 else
1041 {
1042 if ((defined $flag) && $flag)
1043 {
1044 $result = $operand->subset($object);
1045 }
1046 else
1047 {
1048 $result = $object->subset($operand);
1049 }
1050 }
1051 };
1052 if ($@) { &_error($name,0); }
1053 return($result);
1054}
1055
1056sub _greater_than
1057{
1058 my($object,$argument,$flag) = @_;
1059 my($name) = '>';
1060 my($operand);
1061 my($result);
1062
1063 $operand = &_fetch_operand($object,$argument,$flag,$name,0);
1064 eval
1065 {
1066 if ($CONFIG[1] == 1)
1067 {
1068 if ((defined $flag) && $flag)
1069 {
1070 $result = ($operand->Compare($object) > 0);
1071 }
1072 else
1073 {
1074 $result = ($object->Compare($operand) > 0);
1075 }
1076 }
1077 else
1078 {
1079 if ((defined $flag) && $flag)
1080 {
1081 $result = ((!$object->equal($operand)) &&
1082 ($object->subset($operand)));
1083 }
1084 else
1085 {
1086 $result = ((!$operand->equal($object)) &&
1087 ($operand->subset($object)));
1088 }
1089 }
1090 };
1091 if ($@) { &_error($name,0); }
1092 return($result);
1093}
1094
1095sub _greater_equal
1096{
1097 my($object,$argument,$flag) = @_;
1098 my($name) = '>=';
1099 my($operand);
1100 my($result);
1101
1102 $operand = &_fetch_operand($object,$argument,$flag,$name,0);
1103 eval
1104 {
1105 if ($CONFIG[1] == 1)
1106 {
1107 if ((defined $flag) && $flag)
1108 {
1109 $result = ($operand->Compare($object) >= 0);
1110 }
1111 else
1112 {
1113 $result = ($object->Compare($operand) >= 0);
1114 }
1115 }
1116 else
1117 {
1118 if ((defined $flag) && $flag)
1119 {
1120 $result = $object->subset($operand);
1121 }
1122 else
1123 {
1124 $result = $operand->subset($object);
1125 }
1126 }
1127 };
1128 if ($@) { &_error($name,0); }
1129 return($result);
1130}
1131
1132sub _clone
1133{
1134 my($object) = @_;
1135 my($name) = 'automatic duplication';
1136 my($result);
1137
1138 eval
1139 {
1140 $result = $object->Clone();
1141 };
1142 if ($@) { &_error($name,0); }
1143 return($result);
1144}
1145
11461;
1147
1148__END__
1149
Full OpenSPARC design & verification tarball including full HDL.