[OpenSPARC-T2-DV] / tools / perlmod / pal / 1.13 / lib / PAL_runtime.pl


$_LIB_PATH= "$BASE/lib";

sub	proc_SEL_version {
$version= '$Id: PAL_runtime.pl,v 1.1 2007/03/23 20:08:01 drp Exp $';
}

#---------------- proc_SEL() is called by testgen to evaluate $list
#---------------------- at testgen runtime. The advantage is that
#---------------------- the list can contain $perl variables. On
#---------------------- the other hand, it is slower because list
#---------------------- needs be parsed every time.

#----------------- SELECTION LIST FORMAT ===> [$cmd[ list ]]
#-------------------* DONE :
#---------------------* $cmd= 'r' or nil: random selection list
#---------------------* $cmd= 's': random STRING selection list
#---------------------* $cmd= 'e', enumeration list
#---------------------* $cmd= 'l', return number of list elements
#---------------------* $cmd= 'D:{id}', define a random element index to be
#---------------------* 		used by 'U{id}'.
#---------------------* $cmd= 'U:{id}', instead of random choice, use the
#---------------------* 		element index used by SELECTION LIST
#---------------------* 		named 'D{id}'.
#---------------------* $cmd= '[dox]{n}': to print output in C's "%{n}[dox]"
#---------------------* 		format to be used with 'r' or 'e'.
#-------------------* TO DO :
#---------------------* $cmd= a number (n), select that n elements
#-----------------------      and apply enumeration or selection
#-----------------------      of permutation out of n elements.
#------------------------   $cmd= '1', same as nil
#------------------------   $cmd= '1e', same as nil
#---------------------* $cmd= 'a', all pertumation

sub	proc_SEL {
my($idx, $list, $cmd, $lineinfo)= @_;		#$indx for the list, and list itself
my($strList)= 0;

$list=~ s/\[\s*(.*)\s*\]$/$1/;			#for [ {list} ]: pass {list}
# $cmd=~ tr/[A-Z]/[a-z]/;			#translate cmd to the lower-case.

$LINE_INFO_FOR_ERR= $lineinfo;
if(   $cmd eq '') {	$cmd= 'r'; }
elsif($cmd =~ /s/) {	$strList= 1; }
# elsif($cmd =~ /s/) {	$cmd= 'r';	$strList= 1; }

my($result);
if( $list =~ /^\s*[\+\d-]/ && !$strList ) {
	$result= &num_list($idx, $list, $cmd);
}else{	$result= &str_list($idx, $list, $cmd); }

$result;
}

sub	str_list {		## take "{str} [:{weit}], {str} [:{weit}] ..."
my($idx, $list, $cmd)= @_;
my(@value, $i, $list_save);
my($elm_idx);
my($USE_WEIGHT)= 0;
local(@weight);


$list_save= $list;
$list=~ s/^\s*//;
while(1) {
   if($list =~ s/^([\&\$\w][\w_]*)//) {	#a unquoted identifier
	push(@value, $1);

# }elsif($list =~ s/^(\s*)(["'])([^\2]*)(\2)(\s*)//) {	#a '/" quoted string
# why can't I say [^\2]*, which means anything but not \2 ??

#   }elsif($list =~ s/^\s*(["'])([\$\w\s,.-]*)(\1)\s*//) { #a '/" quoted str
#	@value= (@value, $1 . $2 . $3);			#including enclosing "/'
#	# $list=~ s/$1$2$3$4$5//;

   }elsif($list =~ s/^'([^']*)'//) {		#a ' quoted str
	push(@value, "$1");				#including enclosing '

   }elsif($list =~ s/^"([^"]*)"//) {		#a " quoted str
	push(@value, "$1");				#including enclosing "

   }else{	& rt_error("illegal string list: [$list_save]"); }

##### process weight:
   $list =~ s/^\s*//;
   if($list =~ s/^:\s*([^,\s]+)\s*//) {
	push(@weight, eval $1);
	$USE_WEIGHT= 1;
   }else{
	push(@weight, 100);			#default weight 100
	}

   if($list eq '') {		last;
   }elsif($list !~ s/^,\s*//) {
	$list=~ /^(.)/;
	& rt_error(", expected but got `$1' in string list: [$list_save]");
	}
   } #end of while(1)

#-------------------------------$str_list_${idx} will be a $global variable
my($mark)= ($cmd =~ s/D:?(\w+)//) ? $1 : '';

if(    $cmd eq 'l')   {		return($#value + 1);
}elsif($cmd =~ s/U:?(\w+)//) {	$elm_idx= $DEF_ORDER{$1} % ($#value + 1);
}elsif($cmd =~ s/e//) {
	$USE_WEIGHT= 0;
	$elm_idx= eval("++ \$str_list_$idx") -1 ;
	if($elm_idx > $#value) { $elm_idx= 0;
				 eval("\$str_list_$idx= 1"); }
}else{
######### only this category allows weight !!
	$elm_idx= $USE_WEIGHT ?  & weighed_select( *weight ) 
			      :  int(rand( $#value+1 ));

# }elsif($cmd =~ s/r//) {		$elm_idx= int(rand($#value+1));
# }else {	& rt_error("No such string list command: $cmd");
	}


$DEF_ORDER{$mark}= $elm_idx	if($mark);

if($value[$elm_idx] =~ /^\&/) {
	eval '$result=' . $value[$elm_idx];
} else {
	$result= $value[$elm_idx];
	}

if($cmd=~/s(\d*)|(\d+)s/) {
	$result= sprintf("%$1s", $result);
	}
$result;
}

sub	weighed_select {	#Given weight array, return random idx selected
local(*W)= @_;
my($i, $sel);
for($i=1; $i<=$#W; ++$i) { $W[$i] += $W[$i-1]; }	#accumulate weight
$sel= int(rand( $W[$#W] ));
for($i=0; $i<=$#W; ++$i) {
	if($W[$i] > $sel) {
		$sel= $i;
		last;
		}
	}
$sel;
}

sub	num_list {			#take [-num .. +num2]
my($idx, $list, $cmd)= @_;
my(@range, @value, $list_save);
my($num_items)= 0;
my($lb, $ub, $i);
my($has_hex)=0;

$list_save= $list;
$list=~ s/\s//g;
while(1) {				#parse number list
    if($list =~ s/^(\+|-)?([0-9a-fx]+)(-|\.\.)(\+|-)?([0-9a-fx]+)//) {		#is a range
	$n1= "$1$2";	$n2= "$4$5";
	if($n1=~ s/^(\+|-)?0x//) { $n1= $1 . hex($n1); $has_hex= 1;}
	if($n2=~ s/^(\+|-)?0x//) { $n2= $1 . hex($n2); $has_hex= 1;}
	
	if($n1 > $n2) {
		## &rt_error("from ($n1) is greater than to ($n2)");
		$tmp= $n1;
		$n1= $n2;
		$n2= $tmp;
		}
	$num_items += $n2- $n1+ 1;
	@range= (@range, $n1, $n2);			# $list= 'x-y...'
    }elsif($list =~ s/^(\+|-)?([0-9a-fx]+)//) {
	$n1= "$1$2";
	if($n1=~ s/^(\+|-)?0x//) { $n1= $1 . hex($n1); $has_hex= 1;}
	++ $num_items;
	@value= (@value, $n1);				# $list= 'x.....'
    }else{	& rt_error("illegal number list: [$list_save]"); }

    $list =~ s/^\s*//;
    if($list eq '') {			last;
    }elsif($list !~ s/^,\s*//) {
	$list=~ /^(.)/;
	& rt_error(", expected but got `$1' in number list: [$list_save]");
	}
    } #end of while(1)

########### select from [$list]
my($elm_idx, $result);

#-------------------------------$str_list_${idx} will be a $gloabl variable
my($mark)= ($cmd =~ s/D:?(\w+)//) ? $1 : '';

if(    $cmd eq 'l') {		return($num_items);
}elsif($cmd =~ s/U:?(\w+)//) {	$elm_idx= $DEF_ORDER{$1} % $num_items;
}elsif($cmd =~ /e/) {
	$elm_idx= eval("++ \$str_list_$idx") -1 ;
	if($elm_idx > $num_items-1) { $elm_idx= 0;
				      eval("\$str_list_$idx= 1"); }
# }elsif($cmd =~ /r/) {	$elm_idx= int(rand($num_items));
}else{			$elm_idx= int(rand($num_items));
# }else {	& rt_error("No such number list command: $cmd");
	}
$DEF_ORDER{$mark}= $elm_idx	if($mark);

if($elm_idx <= $#value) {	$result= $value[$elm_idx];
}else{	$lb= $#value;
	for($i= 0; $i <= $#range; $i+=2) {
	   $ub= $lb+ ($range[$i+1] - $range[$i] + 1);
	   if($elm_idx <= $ub) {
		$result= $range[$i]+ $elm_idx- ($lb+ 1);
		last;
		}
	   $lb= $ub;
	   }
	}

$format= ($cmd=~/(\d+)([doxs])/) ? "%$1$2" :		#new
	 ($cmd=~/([doxs])(\d*)/) ? "%$2$1" :
	 $has_hex ?	          "%x"    :
			          "%d"    ;
$result= sprintf($format, $result);

$result;
}

sub   rt_error { print STDERR "\nERR ($LINE_INFO_FOR_ERR): @_\n";     exit(1); }

1;
Commit	Line	Data
86530b38 AT	1
	2	$_LIB_PATH= "$BASE/lib";
	3
	4	sub proc_SEL_version {
	5	$version= '$Id: PAL_runtime.pl,v 1.1 2007/03/23 20:08:01 drp Exp $';
	6	}
	7
	8	#---------------- proc_SEL() is called by testgen to evaluate $list
	9	#---------------------- at testgen runtime. The advantage is that
	10	#---------------------- the list can contain $perl variables. On
	11	#---------------------- the other hand, it is slower because list
	12	#---------------------- needs be parsed every time.
	13
	14	#----------------- SELECTION LIST FORMAT ===> [$cmd[ list ]]
	15	#-------------------* DONE :
	16	#---------------------* $cmd= 'r' or nil: random selection list
	17	#---------------------* $cmd= 's': random STRING selection list
	18	#---------------------* $cmd= 'e', enumeration list
	19	#---------------------* $cmd= 'l', return number of list elements
	20	#---------------------* $cmd= 'D:{id}', define a random element index to be
	21	#---------------------* used by 'U{id}'.
	22	#---------------------* $cmd= 'U:{id}', instead of random choice, use the
	23	#---------------------* element index used by SELECTION LIST
	24	#---------------------* named 'D{id}'.
	25	#---------------------* $cmd= '[dox]{n}': to print output in C's "%{n}[dox]"
	26	#---------------------* format to be used with 'r' or 'e'.
	27	#-------------------* TO DO :
	28	#---------------------* $cmd= a number (n), select that n elements
	29	#----------------------- and apply enumeration or selection
	30	#----------------------- of permutation out of n elements.
	31	#------------------------ $cmd= '1', same as nil
	32	#------------------------ $cmd= '1e', same as nil
	33	#---------------------* $cmd= 'a', all pertumation
	34
	35	sub proc_SEL {
	36	my($idx, $list, $cmd, $lineinfo)= @_; #$indx for the list, and list itself
	37	my($strList)= 0;
	38
	39	$list=~ s/\[\s(.)\s*\]$/$1/; #for [ {list} ]: pass {list}
	40	# $cmd=~ tr/[A-Z]/[a-z]/; #translate cmd to the lower-case.
	41
	42	$LINE_INFO_FOR_ERR= $lineinfo;
	43	if( $cmd eq '') { $cmd= 'r'; }
	44	elsif($cmd =~ /s/) { $strList= 1; }
	45	# elsif($cmd =~ /s/) { $cmd= 'r'; $strList= 1; }
	46
	47	my($result);
	48	if( $list =~ /^\s*[\+\d-]/ && !$strList ) {
	49	$result= &num_list($idx, $list, $cmd);
	50	}else{ $result= &str_list($idx, $list, $cmd); }
	51
	52	$result;
	53	}
	54
	55	sub str_list { ## take "{str} [:{weit}], {str} [:{weit}] ..."
	56	my($idx, $list, $cmd)= @_;
	57	my(@value, $i, $list_save);
	58	my($elm_idx);
	59	my($USE_WEIGHT)= 0;
	60	local(@weight);
	61
	62
	63	$list_save= $list;
	64	$list=~ s/^\s*//;
65	while(1) {
66	if($list =~ s/^([\&\$\w][\w_]*)//) { #a unquoted identifier
67	push(@value, $1);
68
69	# }elsif($list =~ s/^(\s)(["'])([^\2])(\2)(\s*)//) { #a '/" quoted string
70	# why can't I say [^\2]*, which means anything but not \2 ??
71
72	# }elsif($list =~ s/^\s(["'])([\$\w\s,.-])(\1)\s*//) { #a '/" quoted str
73	# @value= (@value, $1 . $2 . $3); #including enclosing "/'
74	# # $list=~ s/$1$2$3$4$5//;
75
76	}elsif($list =~ s/^'([^']*)'//) { #a ' quoted str
77	push(@value, "$1"); #including enclosing '
78
79	}elsif($list =~ s/^"([^"]*)"//) { #a " quoted str
80	push(@value, "$1"); #including enclosing "
81
82	}else{ & rt_error("illegal string list: [$list_save]"); }
83
84	##### process weight:
85	$list =~ s/^\s*//;
86	if($list =~ s/^:\s([^,\s]+)\s//) {
87	push(@weight, eval $1);
88	$USE_WEIGHT= 1;
89	}else{
90	push(@weight, 100); #default weight 100
91	}
92
93	if($list eq '') { last;
94	}elsif($list !~ s/^,\s*//) {
95	$list=~ /^(.)/;
96	& rt_error(", expected but got `$1' in string list: [$list_save]");
97	}
98	} #end of while(1)
99
100	#-------------------------------$str_list_${idx} will be a $global variable
101	my($mark)= ($cmd =~ s/D:?(\w+)//) ? $1 : '';
102
103	if( $cmd eq 'l') { return($#value + 1);
104	}elsif($cmd =~ s/U:?(\w+)//) { $elm_idx= $DEF_ORDER{$1} % ($#value + 1);
105	}elsif($cmd =~ s/e//) {
106	$USE_WEIGHT= 0;
107	$elm_idx= eval("++ \$str_list_$idx") -1 ;
108	if($elm_idx > $#value) { $elm_idx= 0;
109	eval("\$str_list_$idx= 1"); }
110	}else{
111	######### only this category allows weight !!
112	$elm_idx= $USE_WEIGHT ? & weighed_select( *weight )
113	: int(rand( $#value+1 ));
114
115	# }elsif($cmd =~ s/r//) { $elm_idx= int(rand($#value+1));
116	# }else { & rt_error("No such string list command: $cmd");
117	}
118
119
120	$DEF_ORDER{$mark}= $elm_idx if($mark);
121
122	if($value[$elm_idx] =~ /^\&/) {
123	eval '$result=' . $value[$elm_idx];
124	} else {
125	$result= $value[$elm_idx];
126	}
127
128	if($cmd=~/s(\d*)\|(\d+)s/) {
129	$result= sprintf("%$1s", $result);
130	}
131	$result;
132	}
133
134	sub weighed_select { #Given weight array, return random idx selected
135	local(*W)= @_;
136	my($i, $sel);
137	for($i=1; $i<=$#W; ++$i) { $W[$i] += $W[$i-1]; } #accumulate weight
138	$sel= int(rand( $W[$#W] ));
139	for($i=0; $i<=$#W; ++$i) {
140	if($W[$i] > $sel) {
141	$sel= $i;
142	last;
143	}
144	}
145	$sel;
146	}
147
148	sub num_list { #take [-num .. +num2]
149	my($idx, $list, $cmd)= @_;
150	my(@range, @value, $list_save);
151	my($num_items)= 0;
152	my($lb, $ub, $i);
153	my($has_hex)=0;
154
155	$list_save= $list;
156	$list=~ s/\s//g;
157	while(1) { #parse number list
158	if($list =~ s/^(\+\|-)?([0-9a-fx]+)(-\|\.\.)(\+\|-)?([0-9a-fx]+)//) { #is a range
159	$n1= "$1$2"; $n2= "$4$5";
160	if($n1=~ s/^(\+\|-)?0x//) { $n1= $1 . hex($n1); $has_hex= 1;}
161	if($n2=~ s/^(\+\|-)?0x//) { $n2= $1 . hex($n2); $has_hex= 1;}
162
163	if($n1 > $n2) {
164	## &rt_error("from ($n1) is greater than to ($n2)");
165	$tmp= $n1;
166	$n1= $n2;
167	$n2= $tmp;
168	}
169	$num_items += $n2- $n1+ 1;
170	@range= (@range, $n1, $n2); # $list= 'x-y...'
171	}elsif($list =~ s/^(\+\|-)?([0-9a-fx]+)//) {
172	$n1= "$1$2";
173	if($n1=~ s/^(\+\|-)?0x//) { $n1= $1 . hex($n1); $has_hex= 1;}
174	++ $num_items;
175	@value= (@value, $n1); # $list= 'x.....'
176	}else{ & rt_error("illegal number list: [$list_save]"); }
177
178	$list =~ s/^\s*//;
179	if($list eq '') { last;
180	}elsif($list !~ s/^,\s*//) {
181	$list=~ /^(.)/;
182	& rt_error(", expected but got `$1' in number list: [$list_save]");
183	}
184	} #end of while(1)
185
186	########### select from [$list]
187	my($elm_idx, $result);
188
189	#-------------------------------$str_list_${idx} will be a $gloabl variable
190	my($mark)= ($cmd =~ s/D:?(\w+)//) ? $1 : '';
191
192	if( $cmd eq 'l') { return($num_items);
193	}elsif($cmd =~ s/U:?(\w+)//) { $elm_idx= $DEF_ORDER{$1} % $num_items;
194	}elsif($cmd =~ /e/) {
195	$elm_idx= eval("++ \$str_list_$idx") -1 ;
196	if($elm_idx > $num_items-1) { $elm_idx= 0;
197	eval("\$str_list_$idx= 1"); }
198	# }elsif($cmd =~ /r/) { $elm_idx= int(rand($num_items));
199	}else{ $elm_idx= int(rand($num_items));
200	# }else { & rt_error("No such number list command: $cmd");
201	}
202	$DEF_ORDER{$mark}= $elm_idx if($mark);
203
204	if($elm_idx <= $#value) { $result= $value[$elm_idx];
205	}else{ $lb= $#value;
206	for($i= 0; $i <= $#range; $i+=2) {
207	$ub= $lb+ ($range[$i+1] - $range[$i] + 1);
208	if($elm_idx <= $ub) {
209	$result= $range[$i]+ $elm_idx- ($lb+ 1);
210	last;
211	}
212	$lb= $ub;
213	}
214	}
215
216	$format= ($cmd=~/(\d+)([doxs])/) ? "%$1$2" : #new
217	($cmd=~/([doxs])(\d*)/) ? "%$2$1" :
218	$has_hex ? "%x" :
219	"%d" ;
220	$result= sprintf($format, $result);
221
222	$result;
223	}
224
225	sub rt_error { print STDERR "\nERR ($LINE_INFO_FOR_ERR): @_\n"; exit(1); }
226
227	1;