Ticket #1147: nci_pmc_fixup_tests.patch

File nci_pmc_fixup_tests.patch, 9.6 KB (added by plobsing, 5 years ago)
  • tools/build/nativecall.pl

     
    3030use strict; 
    3131use warnings; 
    3232 
     33use lib 'lib'; 
     34use Parrot::NativeCall; 
     35 
    3336my $opt_warndups = 0; 
    3437 
    3538# This file will eventually be compiled 
     
    3740 
    3841print_head( \@ARGV ); 
    3942 
     43my %sig_table = %Parrot::NativeCall::signature_table; 
    4044 
    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 future 
    73     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  
    9945my $temp_cnt = 0; 
    10046my (@put_pointer, @put_pointer_nci_too, @nci_defs); 
    10147my %seen; 
  • lib/Parrot/NativeCall.pm

     
     1# Copyright (C) 2009, Parrot Foundation. 
     2# $Id$ 
     3 
     4package Parrot::NativeCall; 
     5 
     6use strict; 
     7use warnings; 
     8 
     9use base 'Exporter'; 
     10our @EXPORT_OK = qw{ signature_nci_to_pcc }; 
     11 
     12=head1 NAME 
     13 
     14Parrot::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 
     24C<Parrot::NativeCall> knows how to map NCI signatures to nci frame 
     25functions. 
     26 
     27=head1 GLOBAL VARIABLES 
     28 
     29=over 
     30 
     31=item C<%signature_table> 
     32 
     33Maps NCI signature items to elements of a native call routine. 
     34 
     35For use by F<tools/build/nativecall.pl>. New code should probably write 
     36a wrapper in this module to encapsulate the access. 
     37 
     38=cut 
     39 
     40our %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 
     84for (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 
     105Converts an NCI signature to a PCC signature. 
     106 
     107=cut 
     108 
     109sub 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 
     1171; 
     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

     
    55use strict; 
    66use warnings; 
    77use lib qw( . lib ../lib ../../lib ); 
     8use Parrot::BuildUtil; 
     9use Parrot::NativeCall 'signature_nci_to_pcc'; 
     10 
     11my @nci_sigs; 
     12BEGIN { 
     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 
    819use Test::More; 
    9 use Parrot::Test tests => 70; 
     20use Parrot::Test tests => (70 + @nci_sigs); 
    1021use Parrot::Config qw(%PConfig); 
    1122 
    1223=head1 NAME 
     
    3243 
    3344$ENV{TEST_PROG_ARGS} ||= ''; 
    3445 
     46foreach 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 
     64CODE 
     65} 
     66 
    3567SKIP: { 
    3668    unless ( -e "runtime/parrot/dynext/libnci_test$PConfig{load_ext}" ) { 
    3769        skip( "Please make libnci_test$PConfig{load_ext}", Test::Builder->expected_tests() );