Ticket #1147: nci_pmc_fixup_tests.patch
| File nci_pmc_fixup_tests.patch, 9.6 KB (added by plobsing, 12 years ago) |
|---|
-
tools/build/nativecall.pl
30 30 use strict; 31 31 use warnings; 32 32 33 use lib 'lib'; 34 use Parrot::NativeCall; 35 33 36 my $opt_warndups = 0; 34 37 35 38 # This file will eventually be compiled … … 37 40 38 41 print_head( \@ARGV ); 39 42 43 my %sig_table = %Parrot::NativeCall::signature_table; 40 44 41 my %sig_table = (42 p => {43 as_proto => "void *",44 other_decl => "PMC * const final_destination = pmc_new(interp, enum_class_UnManagedStruct);",45 sig_char => "P",46 ret_assign => "VTABLE_set_pointer(interp, final_destination, return_data);\n Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"P\", final_destination);",47 },48 i => { as_proto => "int", sig_char => "I" },49 l => { as_proto => "long", sig_char => "I" },50 c => { as_proto => "char", sig_char => "I" },51 s => { as_proto => "short", sig_char => "I" },52 f => { as_proto => "float", sig_char => "N" },53 d => { as_proto => "double", sig_char => "N" },54 t => { as_proto => "char *",55 other_decl => "STRING *final_destination;",56 ret_assign => "final_destination = Parrot_str_new(interp, return_data, 0);\n Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"S\", final_destination);",57 sig_char => "S" },58 v => { as_proto => "void",59 return_type => "void *",60 sig_char => "v",61 ret_assign => "",62 func_call_assign => ""63 },64 P => { as_proto => "PMC *", sig_char => "P" },65 O => { as_proto => "PMC *", returns => "", sig_char => "Pi" },66 J => { as_proto => "PARROT_INTERP", returns => "", sig_char => "" },67 S => { as_proto => "STRING *", sig_char => "S" },68 I => { as_proto => "INTVAL", sig_char => "I" },69 N => { as_proto => "FLOATVAL", sig_char => "N" },70 b => { as_proto => "void *", as_return => "", sig_char => "S" },71 B => { as_proto => "char **", as_return => "", sig_char => "S" },72 # These should be replaced by modifiers in the future73 2 => { as_proto => "short *", sig_char => "P", return_type => "short",74 ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' },75 3 => { as_proto => "int *", sig_char => "P", return_type => "int",76 ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' },77 4 => { as_proto => "long *", sig_char => "P", return_type => "long",78 ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' },79 L => { as_proto => "long *", as_return => "" },80 T => { as_proto => "char **", as_return => "" },81 V => { as_proto => "void **", as_return => "", sig_char => "P" },82 '@' => { as_proto => "PMC *", as_return => "", cname => "xAT_", sig_char => 'Ps' },83 );84 85 for (values %sig_table) {86 if (not exists $_->{as_return}) { $_->{as_return} = $_->{as_proto} }87 if (not exists $_->{return_type}) { $_->{return_type} = $_->{as_proto} }88 if (not exists $_->{return_type_decl}) { $_->{return_type_decl} = $_->{return_type} }89 if (not exists $_->{ret_assign} and exists $_->{sig_char}) {90 $_->{ret_assign} = 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "'91 . $_->{sig_char} . '", return_data);';92 }93 if (not exists $_->{func_call_assign}) {94 $_->{func_call_assign} = "return_data = "95 }96 }97 98 99 45 my $temp_cnt = 0; 100 46 my (@put_pointer, @put_pointer_nci_too, @nci_defs); 101 47 my %seen; -
lib/Parrot/NativeCall.pm
1 # Copyright (C) 2009, Parrot Foundation. 2 # $Id$ 3 4 package Parrot::NativeCall; 5 6 use strict; 7 use warnings; 8 9 use base 'Exporter'; 10 our @EXPORT_OK = qw{ signature_nci_to_pcc }; 11 12 =head1 NAME 13 14 Parrot::NativeCall - Tools for building native call routines 15 16 =head1 SYNOPSIS 17 18 use Parrot::NativeCall 'signature_nci_to_pcc'; 19 20 my $pcc_sig = signature_nci_to_pcc("v VVV"); 21 22 =head1 DESCRIPTION 23 24 C<Parrot::NativeCall> knows how to map NCI signatures to nci frame 25 functions. 26 27 =head1 GLOBAL VARIABLES 28 29 =over 30 31 =item C<%signature_table> 32 33 Maps NCI signature items to elements of a native call routine. 34 35 For use by F<tools/build/nativecall.pl>. New code should probably write 36 a wrapper in this module to encapsulate the access. 37 38 =cut 39 40 our %signature_table = ( 41 p => { 42 as_proto => "void *", 43 other_decl => "PMC * const final_destination = pmc_new(interp, enum_class_UnManagedStruct);", 44 sig_char => "P", 45 ret_assign => "VTABLE_set_pointer(interp, final_destination, return_data);\n Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"P\", final_destination);", 46 }, 47 i => { as_proto => "int", sig_char => "I" }, 48 l => { as_proto => "long", sig_char => "I" }, 49 c => { as_proto => "char", sig_char => "I" }, 50 s => { as_proto => "short", sig_char => "I" }, 51 f => { as_proto => "float", sig_char => "N" }, 52 d => { as_proto => "double", sig_char => "N" }, 53 t => { as_proto => "char *", 54 other_decl => "STRING *final_destination;", 55 ret_assign => "final_destination = Parrot_str_new(interp, return_data, 0);\n Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"S\", final_destination);", 56 sig_char => "S" }, 57 v => { as_proto => "void", 58 return_type => "void *", 59 sig_char => "v", 60 ret_assign => "", 61 func_call_assign => "" 62 }, 63 P => { as_proto => "PMC *", sig_char => "P" }, 64 O => { as_proto => "PMC *", returns => "", sig_char => "Pi" }, 65 J => { as_proto => "PARROT_INTERP", returns => "", sig_char => "" }, 66 S => { as_proto => "STRING *", sig_char => "S" }, 67 I => { as_proto => "INTVAL", sig_char => "I" }, 68 N => { as_proto => "FLOATVAL", sig_char => "N" }, 69 b => { as_proto => "void *", as_return => "", sig_char => "S" }, 70 B => { as_proto => "char **", as_return => "", sig_char => "S" }, 71 # These should be replaced by modifiers in the future 72 2 => { as_proto => "short *", sig_char => "P", return_type => "short", 73 ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' }, 74 3 => { as_proto => "int *", sig_char => "P", return_type => "int", 75 ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' }, 76 4 => { as_proto => "long *", sig_char => "P", return_type => "long", 77 ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' }, 78 L => { as_proto => "long *", as_return => "" }, 79 T => { as_proto => "char **", as_return => "" }, 80 V => { as_proto => "void **", as_return => "", sig_char => "P" }, 81 '@' => { as_proto => "PMC *", as_return => "", cname => "xAT_", sig_char => 'Ps' }, 82 ); 83 84 for (values %signature_table) { 85 if (not exists $_->{as_return}) { $_->{as_return} = $_->{as_proto} } 86 if (not exists $_->{return_type}) { $_->{return_type} = $_->{as_proto} } 87 if (not exists $_->{return_type_decl}) { $_->{return_type_decl} = $_->{return_type} } 88 if (not exists $_->{ret_assign} and exists $_->{sig_char}) { 89 $_->{ret_assign} = 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "' 90 . $_->{sig_char} . '", return_data);'; 91 } 92 if (not exists $_->{func_call_assign}) { 93 $_->{func_call_assign} = "return_data = " 94 } 95 } 96 97 =back 98 99 =head1 FUNCTIONS 100 101 =over 102 103 =item C<signature_nci_to_pcc> 104 105 Converts an NCI signature to a PCC signature. 106 107 =cut 108 109 sub signature_nci_to_pcc { 110 my $nci_sig = shift; 111 my ($nci_ret, $nci_params) = $nci_sig =~ /^(.)\s*(\S*)/; 112 my $pcc_ret = $signature_table{$nci_ret}{sig_char}; 113 my $pcc_params = join '', map $signature_table{$_}{sig_char}, split //, $nci_params; 114 return "${pcc_params}->${pcc_ret}"; 115 } 116 117 1; 118 119 =back 120 121 =cut 122 123 # Local Variables: 124 # mode: cperl 125 # cperl-indent-level: 4 126 # fill-column: 100 127 # End: 128 # vim: expandtab shiftwidth=4: -
t/pmc/nci.t
5 5 use strict; 6 6 use warnings; 7 7 use lib qw( . lib ../lib ../../lib ); 8 use Parrot::BuildUtil; 9 use Parrot::NativeCall 'signature_nci_to_pcc'; 10 11 my @nci_sigs; 12 BEGIN { 13 @nci_sigs = 14 grep {$_} 15 map {chomp; s/^\s*//; s/\s*$//; s/#.*$//; $_} 16 split /\n/, Parrot::BuildUtil::slurp_file('src/call_list.txt'); 17 } 18 8 19 use Test::More; 9 use Parrot::Test tests => 70;20 use Parrot::Test tests => (70 + @nci_sigs); 10 21 use Parrot::Config qw(%PConfig); 11 22 12 23 =head1 NAME … … 32 43 33 44 $ENV{TEST_PROG_ARGS} ||= ''; 34 45 46 foreach my $nci_sig (@nci_sigs) { 47 my ($nci_ret, $nci_params) = $nci_sig =~ /\S+/g; 48 $nci_params ||= ''; 49 my $pcc_sig = signature_nci_to_pcc($nci_sig); 50 pir_output_is( << "CODE", "$pcc_sig\n", "NCI PMC signatures equivalent to nativecall.pl ('$nci_sig')" ); 51 .include "nci.pasm" 52 .sub test :main 53 .local pmc nci 54 nci = new ['NCI'] 55 nci = "${nci_ret}${nci_params}" 56 .local string s 57 s = nci[ .PARROT_NCI_PCC_SIGNATURE_PARAMS ] 58 print s 59 print "->" 60 s = nci[ .PARROT_NCI_PCC_SIGNATURE_RET ] 61 print s 62 print "\\n" 63 .end 64 CODE 65 } 66 35 67 SKIP: { 36 68 unless ( -e "runtime/parrot/dynext/libnci_test$PConfig{load_ext}" ) { 37 69 skip( "Please make libnci_test$PConfig{load_ext}", Test::Builder->expected_tests() );
