view release on metacpan or  search on metacpan

sbin/build-gcc-builtins-package.pl  view on Meta::CPAN

				last ARGLOOP;
			} else {
				$testargs .= "2,";
			}
		} elsif( $argus->{'type'} =~ /double|float/ ){
			if( exists($argus->{'pointer'}) && defined($argus->{'pointer'}) ){
				print STDERR "$0 : I don't know how to call this function '".$func{'xs-signature'}."' from Perl.\n";
				last ARGLOOP;
			} else {
				$testargs .= "2.56,";
			}
		} elsif( $argus->{'type'} =~ /char/ ){
			if( exists($argus->{'pointer'}) && defined($argus->{'pointer'}) ){
				$testargs .= "'some string',";
			} else {
				$testargs .= "'c',";
			}
		} elsif( $argus->{'type'} =~ /void/ ){
		} else {
			die "error, input parameters for '".$func{'xs-signature'}."' need to be implemented because they are of type '".$argus->{'type'}."' which it is unknown to me."
		}
	}
	$testargs =~ s/,$//;

	if( $func{'return-type'} eq 'void' ){
		$func{'test_func_run'} = $func{'xs-name'}.'('.$testargs.');';
		$func{'test_func_is_ok'} = "";
	} else {
		$func{'test_func_run'} = 'my $res = '.$func{'xs-name'}.'('.$testargs.');';
		my $expected;
		if( ! exists($T_EXPECTED_RESULTS{$func{'xs-name'}}) || ! defined($expected=$T_EXPECTED_RESULTS{$func{'xs-name'}}) ){
			print STDERR "$0 : warning, there is no expected value for testing ".$func{'xs-name'}."(). I will use a dummy and you need to fix it when the test fails.\n";
			$expected = 'dummy_expected';
		}
		# because Sometimes we get 'inf' and not 'Inf' we make a case-insensitive
		# comparison for non-numerical expected values.
		$func{'test_func_is_ok'} = 'my $expected = "'.$expected.'";'
					   ."\n".'if( $expected =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/ ){'
					   ."\n\t".'my $dif = abs($res-$expected);'
					   ."\n\t".'ok($dif<'.$FLOATS_ARE_EQUAL_DIFF.', "called '
					   .$func{'xs-name'}
					   .'('.$testargs.') returned ($res) and expected ($expected) values differ ($dif) by less than '.$FLOATS_ARE_EQUAL_DIFF.'.");'
					   ."\n} else {"
					   ."\n\t".'is(lc($res), lc($expected), "called '
					   .$func{'xs-name'}
					   .'('.$testargs.') returned ($res) and expected ($expected) values are identical.");'
					   ."\n}"
					   ."\n".'diag("copy-this-expected-value \''.$func{'xs-name'}.'\' => \'$res\',");'
		;
	}

	# and done
	$funcs{ $func{'name'} } = \%func;
}

# Inside the .pm output we have 2 lists to add: exported subs
# and pod of each of this exported sub
my $list_of_sub_names = "";
my $list_of_exported_subs = "";
my $exported_subs_descriptions = "";
# you can use $afuncdata->{'xs-signature-without-identifiers'} to have identifiers included
for my $afuncname (sort keys %funcs){
	my $afuncdata = $funcs{$afuncname};
	$list_of_sub_names .= $afuncdata->{'xs-name'}.' ';
	$list_of_exported_subs .= '=item * C<'.$afuncdata->{'xs-signature-without-identifiers'}.">\n\n";
	$exported_subs_descriptions .=<<EOP;
=head2 C<$afuncdata->{'xs-signature-without-identifiers'}>

$afuncdata->{'description'}

EOP
}

######################################################
################## Write test files ##################
my $tidx = 666;
for($tidx..999){
	my $tfile = File::Spec->catfile($TDIR, $_.'-*.t');
	my @files = glob($tfile);
	unlink @files;
}

for my $afuncname (sort keys %funcs){
	my $afuncdata = $funcs{$afuncname};
	my $tfile = File::Spec->catfile($TDIR, $tidx++.'-'.$afuncdata->{'xs-name'}.'.t');
	if( ! open($FH, '>', $tfile) ){ die "error, failed to open output XS file '$tfile' for writing: $!" }
	my $tcon = $T_CONTENTS;
	$tcon =~ s/<%\s*test_func_run\s*%>/$afuncdata->{'test_func_run'}/;
	$tcon =~ s/<%\s*test_func_is_ok\s*%>/$afuncdata->{'test_func_is_ok'}/;
	print $FH $tcon;
	close $FH;
	print "$0 : done, test file written to '$tfile'.\n";
}

######################################################
################## Write .pm file ####################
$PM_CONTENTS =~ s/^package\s*GCC::Builtins;.+?\n/package GCC::Builtins;\n/s;
$PM_CONTENTS =~ s/<%\s*list_of_sub_names\s*%>/${list_of_sub_names}/;
$PM_CONTENTS =~ s/<%\s*list_of_exported_subs\s*%>/${list_of_exported_subs}/;
$PM_CONTENTS =~ s/<%\s*exported_subs_descriptions\s*%>/${exported_subs_descriptions}/;
open($FH, '>', $PM_outfile) or die "error, failed to open output file '$TYPEMAP_outfile' for writing: $!";
print $FH $PM_CONTENTS;
close $FH;
print "$0 : done, perl module and pod written to '$PM_outfile'.\n";

######################################################
################## Write XS output ###################
if( ! open($FH, '>', $XS_outfile) ){ die "error, failed to open output XS file '$XS_outfile' for writing: $!" }
print $FH $XS_CONTENTS;
for my $afuncname (sort keys %funcs){
	my $afuncdata = $funcs{$afuncname};
	print $FH "\n".$afuncdata->{'xs-code'}."\n"
}
close $FH;
print "$0 : done, ".scalar(keys %funcs)." builtin functions written to '$XS_outfile'.\n";

######################################################
################## Write TYPEMAP file ################
# write the typemap, we assume that uintYYY_t types are not typemap'ed yet
open($FH, '>', $TYPEMAP_outfile) or die "error, failed to open output file '$TYPEMAP_outfile' for writing: $!";
print $FH <<'EOT';
#########################################################################
#### WARNING: do not edit GCC/Buildins.pm or GCC/Buildins.xs
####          or typemap or t/6*.t files
####          they are auto-generated by me and all changes will be lost
#### EDIT all these here, they are in string vars
#### and then run sbin/build-gcc-builtins-package.pl
#### to update these files
#########################################################################
EOT
print $FH "TYPEMAP\n";
for my $atype (sort keys %TYPEMAP){
	my $mapsto = $TYPEMAP{$atype};
	print $FH "${atype}\t${mapsto}\n";
}
close $FH;
print "$0 : done, ".scalar(keys %TYPEMAP)." typemap items written to file '$TYPEMAP_outfile'.\n";

print "$0 : done, success.\n";

######################################################
################## Assorted subs #####################
sub get_function_return_type {
	my $parent_tag = shift;

	my $cssSelector2 = 'span code.def-type';
	my $atag2 = $parent_tag->find($cssSelector2);
	if( ! defined($atag2) ){ die 'get_function_return_type()'." : error, failed to find span with CSS selector '$cssSelector2' under tag : ${parent_tag}" }
	if( $atag2->length() != 1 ){ die $parent_tag."\n".'get_function_return_type()'." : error, failed to find exactly 1 span with CSS selector '$cssSelector2'. I found ".$atag2->length()." items instead." }
	$atag2 = $atag2->[0];
	# we will skip all type-generic functions I don't know how to implement them in XS
	my $cssSelector3 = 'var.var';
	my $atag3 = $atag2->find($cssSelector3);
	# if we have <var> it is most likely type of _Floatnx etc.
	if( defined($atag3) && ($atag3->length()>0) ){
		for my $atag4 ( @{ $atag3->array } ){
			my $tx = $atag4->text();
			if( $tx =~ /^\s*type\s*$/ ){
				print STDERR 'get_function_return_type()'." : skipping function with type-generic return:\n${parent_tag}\n";
				return undef # means forget it and next
			} else {
				print STDERR $parent_tag."\n".'get_function_return_type()'." : found var tag for above node but it is not 'type', it is:\n".$tx;
				return undef # means forget it and next
			}
		}
	}
	my $rt = $atag2->text();
	if( ($rt eq 'Pmode')
	 || ($rt eq 'uint128_t')
	){
		print STDERR $parent_tag."\n$0 : found function with illegal return type in above node. The return type is:   $rt\n";
		return undef;