← Back to branch summary

~ubuntu-branches/ubuntu/lucid/pdl/lucid

« back to all changes in this revision

Viewing changes to Basic/Gen/PP/CType.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ben Gertzfield
  • Date: 2002-04-08 18:47:16 UTC
  • Revision ID: james.westby@ubuntu.com-20020408184716-0hf64dc96kin3htp
Tags: upstream-2.3.2
Import upstream version 2.3.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
Basic/Gen/PP/CType.pm
 
1
# Represent any C type.
 
2
# Type contains the size of arrays, which is either constant
 
3
# or resolved (into an object) from resolveobj.
 
4
 
 
5
package C::Type;
 
6
use Carp;
 
7
 
 
8
# new C::Type(resolveobj,str)
 
9
 
 
10
sub new {
 
11
        my $this = bless {},shift;
 
12
        $this->{Resolve} = shift;
 
13
        if(@_) {
 
14
                $this->parsefrom(shift);
 
15
        }
 
16
        return $this;
 
17
}
 
18
 
 
19
sub stripptrs {
 
20
        my($this,$str) = @_;
 
21
        if($str =~ /^\s*\w+\s*$/) {
 
22
                $str =~ s/\s//g;
 
23
                $this->{ProtoName} = $str;
 
24
                return [];
 
25
        } else {
 
26
# Now, recall the different C syntaxes. First priority is a pointer:
 
27
                my $decl;
 
28
                if($str =~ /^\s*\*(.*)$/) {
 
29
                        $decl = $this->stripptrs($1);
 
30
                        unshift @$decl,"PTR";
 
31
                } elsif($str =~ /^\s*\(.*\)\s*$/) {
 
32
# XXX Should try to see if a funccall.
 
33
                        return $this->stripptrs($1);
 
34
                } elsif($str =~ /^(.*)\[([^]]+)\]\s*$/) {
 
35
                        my $siz = $2;
 
36
                        print "ARR($str): ($siz)\n" if $::PP_VERBOSE;
 
37
                        $decl = $this->stripptrs($1);
 
38
                        unshift @$decl,"ARR($siz)";
 
39
                        print "ARR($str): ($siz)\n" if $::PP_VERBOSE;
 
40
                } else {
 
41
                        die("Invalid C type '$str'");
 
42
                }
 
43
                return $decl;
 
44
        }
 
45
}
 
46
 
 
47
# XXX Correct to *real* parsing. This is only a subset.
 
48
sub parsefrom {
 
49
        my($this,$str) = @_;
 
50
# First, take the words in the beginning
 
51
        $str =~ /^\s*((?:\w+\b\s*)+)([^[].*)$/;
 
52
        my $base = $1; my $decl = $2;
 
53
        my $foo = $this->stripptrs($decl);
 
54
        $this->{Base} = $base;
 
55
        $this->{Chain} = $foo;
 
56
}
 
57
 
 
58
sub get_decl {
 
59
        my($this,$name,$opts) = @_;
 
60
        for(@{$this->{Chain}}) {
 
61
                if($_ eq "PTR") {$name = "*$name"}
 
62
                elsif($_ =~/^ARR\((.*)\)$/) {
 
63
                        if($opts->{VarArrays2Ptrs}) {
 
64
                                $name = "*$name";
 
65
                        } else {
 
66
                                $name = "($name)[$1]";
 
67
                        }
 
68
                }
 
69
                else { confess("Invalid decl") }
 
70
        }
 
71
        return "$this->{Base} $name";
 
72
}
 
73
 
 
74
# Useful when parsing argument decls
 
75
sub protoname { return shift->{ProtoName} }
 
76
 
 
77
sub get_copy {
 
78
        my($this,$from,$to) = @_;
 
79
        my ($prev,$close);
 
80
        if($#{$this->{Chain}} >= 0) {
 
81
                # strdup loses portability :(
 
82
                return "($to) = malloc(strlen($from)+1); strcpy($to,$from);"
 
83
                 if $this->{Base} =~ /^\s*char\s*$/;
 
84
                return "($to) = newSVsv($from);"
 
85
                 if $this->{Base} =~ /^\s*SV\s*$/;
 
86
                my $code = $this->get_malloc($to,$from);
 
87
                my ($deref0,$deref1) = ($from,$to);
 
88
                for(@{$this->{Chain}}) {
 
89
                        if($_ eq "PTR") {confess("Cannot alloc pointer, must be array");}
 
90
                        elsif($_ =~/^ARR\((.*)\)$/) {
 
91
                                $no++;
 
92
                                $prev .= "
 
93
                                  if(!$deref0) {$deref1=0;}
 
94
                                  else {int __malloc_ind_$no;
 
95
                                        for(__malloc_ind_$no = 0;
 
96
                                                __malloc_ind_$no < $1;
 
97
                                                __malloc_ind_$no ++) {";
 
98
                                $deref0 = $deref0."[__malloc_ind_$no]";
 
99
                                $deref1 = $deref1."[__malloc_ind_$no]";
 
100
                                $close .= "}}";
 
101
                        } else { confess("Invalid decl $_") }
 
102
                }
 
103
                $code .= "$prev $deref1 = $deref0; $close";
 
104
                return $code;
 
105
        }
 
106
        return "($to) = ($from);";
 
107
}
 
108
 
 
109
sub get_free {
 
110
        my($this,$from) = @_;
 
111
        my ($prev,$close);
 
112
        if($#{$this->{Chain}} >= 0) {
 
113
                return "free($from);"
 
114
                 if $this->{Base} =~ /^\s*char\s*$/;
 
115
                return "SvREFCNT_dec($from);"
 
116
                 if $this->{Base} =~ /^\s*SV\s*$/;
 
117
                my @mallocs;
 
118
                my $str = "{";
 
119
                my $deref = "$from";
 
120
                my $prev = undef;
 
121
                my $close = undef;
 
122
                my $no = 0;
 
123
                for(@{$this->{Chain}}) {
 
124
                        $no++;
 
125
                        if($no > 1) {croak("Can only free one layer!\n");}
 
126
#                       if($_ eq "PTR") {confess("Cannot free pointer, must be array ;) (FIX CType.pm)");}
 
127
                        return "free($from);\n ";
 
128
                }
 
129
        } else {
 
130
                "";
 
131
        }
 
132
}
 
133
 
 
134
sub need_malloc {
 
135
        my($this) = @_;
 
136
        return scalar grep /(ARR|PTR)/,(@{$this->{Chain}})
 
137
}
 
138
 
 
139
# Just returns with the array string.
 
140
sub get_malloc {
 
141
        my($this,$assignto) = @_;
 
142
        my $str = "{";
 
143
        my $deref = "$assignto";
 
144
        my $prev = undef;
 
145
        my $close = undef;
 
146
        my $no = 0;
 
147
        for(@{$this->{Chain}}) {
 
148
                if($_ eq "PTR") {confess("Cannot alloc pointer, must be array");}
 
149
                elsif($_ =~/^ARR\((.*)\)$/) {
 
150
                        $str .= "$prev $assignto =
 
151
                                malloc(sizeof(* $assignto) * $1);
 
152
                                ";
 
153
                        $no++;
 
154
                        $prev = "{int __malloc_ind_$no;
 
155
                                for(__malloc_ind_$no = 0;
 
156
                                        __malloc_ind_$no < $1;
 
157
                                        __malloc_ind_$no ++) {";
 
158
                        $deref = $deref."[__malloc_ind_$no]";
 
159
                        $close .= "}}";
 
160
                } else { confess("Invalid decl $_") }
 
161
        }
 
162
        $str .= "}";
 
163
        return $str;
 
164
}
 
165
 
 
166
sub getvar {
 
167
}
 
168
 
 
169
# Determine if everything constant and can just declare
 
170
sub need_alloc {
 
171
}
 
172
 
 
173
sub alloccode {
 
174
}
 
175
 
 
176
sub copycode {
 
177
}
 
178
 
 
179
sub freecode {
 
180
}
 
181
 
 
182
1;