Commit | Line | Data |
2304df62 |
1 | #!./miniperl |
75f92628 |
2 | |
3 | =head1 NAME |
4 | |
5 | xsubpp - compiler to convert Perl XS code into C code |
6 | |
7 | =head1 SYNOPSIS |
8 | |
9 | B<xsubpp> [B<-C++>] [B<-except>] [B<-typemap typemap>] file.xs |
10 | |
11 | =head1 DESCRIPTION |
12 | |
13 | I<xsubpp> will compile XS code into C code by embedding the constructs |
14 | necessary to let C functions manipulate Perl values and creates the glue |
15 | necessary to let Perl access those functions. The compiler uses typemaps to |
16 | determine how to map C function parameters and variables to Perl values. |
17 | |
18 | The compiler will search for typemap files called I<typemap>. It will use |
19 | the following search path to find default typemaps, with the rightmost |
20 | typemap taking precedence. |
21 | |
22 | ../../../typemap:../../typemap:../typemap:typemap |
23 | |
24 | =head1 OPTIONS |
25 | |
26 | =over 5 |
27 | |
28 | =item B<-C++> |
29 | |
30 | Adds ``extern "C"'' to the C code. |
31 | |
32 | |
33 | =item B<-except> |
34 | |
35 | Adds exception handling stubs to the C code. |
36 | |
37 | =item B<-typemap typemap> |
38 | |
39 | Indicates that a user-supplied typemap should take precedence over the |
40 | default typemaps. This option may be used multiple times, with the last |
41 | typemap having the highest precedence. |
42 | |
43 | =back |
44 | |
45 | =head1 ENVIRONMENT |
46 | |
47 | No environment variables are used. |
48 | |
49 | =head1 AUTHOR |
50 | |
51 | Larry Wall |
52 | |
f06db76b |
53 | =head1 MODIFICATION HISTORY |
54 | |
55 | =head2 1.0 |
56 | |
57 | I<xsubpp> as released with Perl 5.000 |
58 | |
59 | =head2 1.1 |
60 | |
61 | I<xsubpp> as released with Perl 5.001 |
62 | |
63 | =head2 1.2 |
64 | |
65 | Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 22 May 1995. |
66 | |
67 | =over 5 |
68 | |
69 | =item 1. |
70 | |
71 | Added I<xsubpp> version number for the first time. As previous releases |
72 | of I<xsubpp> did not have a formal version number, a numbering scheme |
73 | has been applied retrospectively. |
74 | |
75 | =item 2. |
76 | |
77 | If OUTPUT: is being used to specify output parameters and RETVAL is |
78 | also to be returned, it is now no longer necessary for the user to |
79 | ensure that RETVAL is specified last. |
80 | |
81 | =item 3. |
82 | |
83 | The I<xsubpp> version number, the .xs filename and a time stamp are |
84 | written to the generated .c file as a comment. |
85 | |
86 | =item 4. |
87 | |
88 | When I<xsubpp> is parsing the definition of both the input parameters |
89 | and the OUTPUT parameters, any duplicate definitions will be noted and |
90 | ignored. |
91 | |
92 | =item 5. |
93 | |
94 | I<xsubpp> is slightly more forgiving with extra whitespace. |
95 | |
96 | =back |
97 | |
98 | =head2 1.3 |
99 | |
100 | Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 23 May 1995. |
101 | |
102 | =over 5 |
103 | |
104 | =item 1. |
105 | |
106 | More whitespace restrictions have been relaxed. In particular some |
107 | cases where a tab character was used to delimit fields has been |
108 | removed. In these cases any whitespace will now suffice. |
109 | |
110 | The specific places where changes have been made are in the TYPEMAP |
111 | section of a typemap file and the input and OUTPUT: parameter |
112 | declarations sections in a .xs file. |
113 | |
114 | =item 2. |
115 | |
116 | More error checking added. |
117 | |
118 | Before processing each typemap file I<xsubpp> now checks that it is a |
119 | text file. If not an warning will be displayed. In addition, a warning |
120 | will be displayed if it is not possible to open the typemap file. |
121 | |
122 | In the TYPEMAP section of a typemap file, an error will be raised if |
123 | the line does not have 2 columns. |
124 | |
125 | When parsing input parameter declarations check that there is at least |
126 | a type and name pair. |
127 | |
128 | =back |
129 | |
130 | =head2 1.4 |
131 | |
132 | When parsing the OUTPUT arguments check that they are all present in |
133 | the corresponding input argument definitions. |
134 | |
c2960299 |
135 | =head2 1.5 |
136 | |
137 | Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 1 June 1995. |
138 | |
139 | Started tidy up to allow clean run using C<-w> flag. |
140 | |
141 | Added some more error checking. |
142 | |
143 | The CASE: functionality now works. |
144 | |
145 | =head2 1.6 |
146 | |
147 | Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 3 June 1995. |
148 | |
149 | Added some more error checking. |
150 | |
151 | =head2 1.7 |
152 | |
153 | Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 5 June 1995. |
154 | |
155 | When an error or warning message is printed C<xsubpp> will now attempt |
156 | to identify the exact line in the C<.xs> file where the fault occurs. |
157 | This can be achieved in the majority of cases. |
158 | |
75f92628 |
159 | =head1 SEE ALSO |
160 | |
161 | perl(1) |
162 | |
163 | =cut |
93a17b20 |
164 | |
c2960299 |
165 | use FileHandle ; |
166 | |
f06db76b |
167 | # Global Constants |
c2960299 |
168 | $XSUBPP_version = "1.7" ; |
f06db76b |
169 | |
a0d0e21e |
170 | $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n"; |
93a17b20 |
171 | |
8990e307 |
172 | SWITCH: while ($ARGV[0] =~ s/^-//) { |
93a17b20 |
173 | $flag = shift @ARGV; |
8990e307 |
174 | $spat = shift, next SWITCH if $flag eq 's'; |
175 | $cplusplus = 1, next SWITCH if $flag eq 'C++'; |
176 | $except = 1, next SWITCH if $flag eq 'except'; |
177 | push(@tm,shift), next SWITCH if $flag eq 'typemap'; |
93a17b20 |
178 | die $usage; |
179 | } |
8990e307 |
180 | @ARGV == 1 or die $usage; |
181 | chop($pwd = `pwd`); |
748a9306 |
182 | # Check for error message from VMS |
183 | if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} } |
c2960299 |
184 | ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# |
185 | or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# |
8990e307 |
186 | or ($dir, $filename) = ('.', $ARGV[0]); |
187 | chdir($dir); |
93a17b20 |
188 | |
f06db76b |
189 | sub TrimWhitespace |
190 | { |
191 | $_[0] =~ s/^\s+|\s+$//go ; |
192 | } |
193 | |
194 | sub TidyType |
195 | { |
196 | local ($_) = @_ ; |
197 | |
198 | # rationalise any '*' by joining them into bunches and removing whitespace |
199 | s#\s*(\*+)\s*#$1#g; |
200 | |
201 | # change multiple whitespace into a single space |
202 | s/\s+/ /g ; |
203 | |
204 | # trim leading & trailing whitespace |
205 | TrimWhitespace($_) ; |
206 | |
207 | $_ ; |
208 | } |
209 | |
93a17b20 |
210 | $typemap = shift @ARGV; |
8990e307 |
211 | foreach $typemap (@tm) { |
212 | die "Can't find $typemap in $pwd\n" unless -r $typemap; |
93a17b20 |
213 | } |
748a9306 |
214 | unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap |
215 | ../../lib/ExtUtils/typemap ../../../typemap ../../typemap |
216 | ../typemap typemap); |
8990e307 |
217 | foreach $typemap (@tm) { |
f06db76b |
218 | next unless -e $typemap ; |
219 | # skip directories, binary files etc. |
220 | warn("Warning: ignoring non-text typemap file '$typemap'\n"), next |
221 | unless -T $typemap ; |
222 | open(TYPEMAP, $typemap) |
223 | or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; |
8990e307 |
224 | $mode = Typemap; |
c2960299 |
225 | $junk = "" ; |
8990e307 |
226 | $current = \$junk; |
227 | while (<TYPEMAP>) { |
228 | next if /^#/; |
229 | if (/^INPUT\s*$/) { $mode = Input, next } |
230 | if (/^OUTPUT\s*$/) { $mode = Output, next } |
231 | if (/^TYPEMAP\s*$/) { $mode = Typemap, next } |
232 | if ($mode eq Typemap) { |
233 | chop; |
f06db76b |
234 | my $line = $_ ; |
235 | TrimWhitespace($_) ; |
236 | # skip blank lines and comment lines |
237 | next if /^$/ or /^#/ ; |
238 | my @words = split (' ') ; |
c2960299 |
239 | warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next |
f06db76b |
240 | unless @words >= 2 ; |
241 | my $kind = pop @words ; |
242 | TrimWhitespace($kind) ; |
243 | $type_kind{TidyType("@words")} = $kind ; |
463ee0b2 |
244 | } |
8990e307 |
245 | elsif ($mode eq Input) { |
246 | if (/^\s/) { |
247 | $$current .= $_; |
248 | } |
249 | else { |
250 | s/\s*$//; |
a0d0e21e |
251 | $input_expr{$_} = ''; |
8990e307 |
252 | $current = \$input_expr{$_}; |
253 | } |
93a17b20 |
254 | } |
8990e307 |
255 | else { |
256 | if (/^\s/) { |
257 | $$current .= $_; |
258 | } |
259 | else { |
260 | s/\s*$//; |
a0d0e21e |
261 | $output_expr{$_} = ''; |
8990e307 |
262 | $current = \$output_expr{$_}; |
263 | } |
93a17b20 |
264 | } |
8990e307 |
265 | } |
266 | close(TYPEMAP); |
267 | } |
93a17b20 |
268 | |
8990e307 |
269 | foreach $key (keys %input_expr) { |
270 | $input_expr{$key} =~ s/\n+$//; |
271 | } |
93a17b20 |
272 | |
8990e307 |
273 | sub Q { |
274 | local $text = shift; |
275 | $text =~ tr/#//d; |
2304df62 |
276 | $text =~ s/\[\[/{/g; |
277 | $text =~ s/\]\]/}/g; |
8990e307 |
278 | $text; |
93a17b20 |
279 | } |
280 | |
c2960299 |
281 | open(F, $filename) or die "cannot open $filename: $!\n"; |
282 | |
f06db76b |
283 | # Identify the version of xsubpp used |
284 | $TimeStamp = localtime ; |
285 | print <<EOM ; |
286 | /* |
287 | * This file was generated automatically by xsubpp version $XSUBPP_version |
288 | * from $filename on $TimeStamp |
289 | * |
290 | */ |
291 | |
292 | EOM |
293 | |
294 | |
93a17b20 |
295 | while (<F>) { |
a0d0e21e |
296 | last if ($Module, $foo, $Package, $foo1, $Prefix) = |
297 | /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/; |
298 | print $_; |
93a17b20 |
299 | } |
2304df62 |
300 | exit 0 if $_ eq ""; |
301 | $lastline = $_; |
93a17b20 |
302 | |
2304df62 |
303 | sub fetch_para { |
304 | # parse paragraph |
305 | @line = (); |
c2960299 |
306 | @line_no = () ; |
2304df62 |
307 | if ($lastline ne "") { |
308 | if ($lastline =~ |
a0d0e21e |
309 | /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) { |
2304df62 |
310 | $Module = $1; |
311 | $foo = $2; |
312 | $Package = $3; |
313 | $foo1 = $4; |
314 | $Prefix = $5; |
a0d0e21e |
315 | ($Module_cname = $Module) =~ s/\W/_/g; |
2304df62 |
316 | ($Packid = $Package) =~ s/:/_/g; |
317 | $Packprefix = $Package; |
318 | $Packprefix .= "::" if defined $Packprefix && $Packprefix ne ""; |
319 | while (<F>) { |
320 | chop; |
a0d0e21e |
321 | next if /^#/ && |
322 | !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/; |
2304df62 |
323 | last if /^\S/; |
324 | } |
c2960299 |
325 | push(@line, $_), push(@line_no, input_line_number F) if $_ ne ""; |
93a17b20 |
326 | } |
2304df62 |
327 | else { |
328 | push(@line, $lastline); |
c2960299 |
329 | push(@line_no, $lastline_no) ; |
93a17b20 |
330 | } |
2304df62 |
331 | $lastline = ""; |
332 | while (<F>) { |
a0d0e21e |
333 | next if /^#/ && |
334 | !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/; |
2304df62 |
335 | chop; |
336 | if (/^\S/ && @line && $line[-1] eq "") { |
337 | $lastline = $_; |
c2960299 |
338 | $lastline_no = input_line_number F ; |
2304df62 |
339 | last; |
340 | } |
341 | else { |
342 | push(@line, $_); |
c2960299 |
343 | push(@line_no, input_line_number F) ; |
2304df62 |
344 | } |
93a17b20 |
345 | } |
c2960299 |
346 | pop(@line), pop(@line_no) while @line && $line[-1] =~ /^\s*$/; |
2304df62 |
347 | } |
a0d0e21e |
348 | $PPCODE = grep(/PPCODE:/, @line); |
2304df62 |
349 | scalar @line; |
350 | } |
93a17b20 |
351 | |
c2960299 |
352 | PARAGRAPH: |
2304df62 |
353 | while (&fetch_para) { |
354 | # initialize info arrays |
355 | undef(%args_match); |
356 | undef(%var_types); |
357 | undef(%var_addr); |
358 | undef(%defaults); |
359 | undef($class); |
360 | undef($static); |
361 | undef($elipsis); |
f06db76b |
362 | undef($wantRETVAL) ; |
363 | undef(%arg_list) ; |
2304df62 |
364 | |
365 | # extract return type, function name and arguments |
f06db76b |
366 | $ret_type = TidyType(shift(@line)); |
c2960299 |
367 | |
a0d0e21e |
368 | if ($ret_type =~ /^BOOT:/) { |
369 | push (@BootCode, @line, "", "") ; |
c2960299 |
370 | next PARAGRAPH ; |
a0d0e21e |
371 | } |
c2960299 |
372 | |
373 | # a function definition needs at least 2 lines |
374 | blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH |
375 | unless @line ; |
376 | |
2304df62 |
377 | if ($ret_type =~ /^static\s+(.*)$/) { |
378 | $static = 1; |
379 | $ret_type = $1; |
380 | } |
381 | $func_header = shift(@line); |
c2960299 |
382 | blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH |
383 | unless $func_header =~ /^([\w:]+)\s*\((.*)\)$/; |
384 | |
385 | ($func_name, $orig_args) = ($1, $2) ; |
2304df62 |
386 | if ($func_name =~ /(.*)::(.*)/) { |
387 | $class = $1; |
388 | $func_name = $2; |
389 | } |
c2960299 |
390 | $Prefix = '' unless defined $Prefix ; # keep -w happy |
2304df62 |
391 | ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; |
c2960299 |
392 | |
393 | # Check for duplicate function definition |
394 | blurt("Error: ignoring duplicate function definition '$func_name'"), next PARAGRAPH |
395 | if defined $Func_name{"${Packid}_$func_name"} ; |
396 | $Func_name{"${Packid}_$func_name"} ++ ; |
397 | |
2304df62 |
398 | push(@Func_name, "${Packid}_$func_name"); |
399 | push(@Func_pname, $pname); |
400 | @args = split(/\s*,\s*/, $orig_args); |
a0d0e21e |
401 | if (defined($class)) { |
402 | if (defined($static)) { |
403 | unshift(@args, "CLASS"); |
404 | $orig_args = "CLASS, $orig_args"; |
405 | $orig_args =~ s/^CLASS, $/CLASS/; |
406 | } |
407 | else { |
2304df62 |
408 | unshift(@args, "THIS"); |
409 | $orig_args = "THIS, $orig_args"; |
410 | $orig_args =~ s/^THIS, $/THIS/; |
a0d0e21e |
411 | } |
2304df62 |
412 | } |
413 | $orig_args =~ s/"/\\"/g; |
414 | $min_args = $num_args = @args; |
415 | foreach $i (0..$num_args-1) { |
416 | if ($args[$i] =~ s/\.\.\.//) { |
417 | $elipsis = 1; |
418 | $min_args--; |
c2960299 |
419 | if ($args[$i] eq '' && $i == $num_args - 1) { |
2304df62 |
420 | pop(@args); |
421 | last; |
422 | } |
423 | } |
424 | if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) { |
425 | $min_args--; |
426 | $args[$i] = $1; |
427 | $defaults{$args[$i]} = $2; |
428 | $defaults{$args[$i]} =~ s/"/\\"/g; |
429 | } |
430 | } |
a0d0e21e |
431 | if (defined($class)) { |
2304df62 |
432 | $func_args = join(", ", @args[1..$#args]); |
433 | } else { |
434 | $func_args = join(", ", @args); |
435 | } |
436 | @args_match{@args} = 1..@args; |
437 | |
438 | # print function header |
a0d0e21e |
439 | print Q<<"EOF"; |
440 | #XS(XS_${Packid}_$func_name) |
2304df62 |
441 | #[[ |
a0d0e21e |
442 | # dXSARGS; |
93a17b20 |
443 | EOF |
2304df62 |
444 | if ($elipsis) { |
445 | $cond = qq(items < $min_args); |
446 | } |
447 | elsif ($min_args == $num_args) { |
448 | $cond = qq(items != $min_args); |
449 | } |
450 | else { |
451 | $cond = qq(items < $min_args || items > $num_args); |
452 | } |
8990e307 |
453 | |
2304df62 |
454 | print Q<<"EOF" if $except; |
455 | # char errbuf[1024]; |
456 | # *errbuf = '\0'; |
457 | EOF |
458 | |
459 | print Q<<"EOF"; |
8990e307 |
460 | # if ($cond) { |
461 | # croak("Usage: $pname($orig_args)"); |
462 | # } |
93a17b20 |
463 | EOF |
464 | |
a0d0e21e |
465 | print Q<<"EOF" if $PPCODE; |
466 | # SP -= items; |
467 | EOF |
468 | |
2304df62 |
469 | # Now do a block of some sort. |
93a17b20 |
470 | |
2304df62 |
471 | $condnum = 0; |
c2960299 |
472 | $else_cond = 0 ; |
2304df62 |
473 | if (!@line) { |
474 | @line = "CLEANUP:"; |
475 | } |
476 | while (@line) { |
c2960299 |
477 | if ($line[0] =~ s/^\s*CASE\s*:\s*//) { |
2304df62 |
478 | $cond = shift(@line); |
c2960299 |
479 | TrimWhitespace($cond) ; |
2304df62 |
480 | if ($condnum == 0) { |
c2960299 |
481 | # Check $cond is not blank |
482 | blurt("Error: First CASE: needs a condition") |
483 | if $cond eq '' ; |
484 | print " if ($cond)\n" |
2304df62 |
485 | } |
486 | elsif ($cond ne '') { |
487 | print " else if ($cond)\n"; |
488 | } |
489 | else { |
c2960299 |
490 | blurt ("Error: Too many CASE: statements without a condition") |
491 | unless $else_cond ; |
492 | ++ $else_cond ; |
2304df62 |
493 | print " else\n"; |
494 | } |
495 | $condnum++; |
c2960299 |
496 | $_ = '' ; |
93a17b20 |
497 | } |
498 | |
8990e307 |
499 | if ($except) { |
500 | print Q<<"EOF"; |
2304df62 |
501 | # TRY [[ |
93a17b20 |
502 | EOF |
8990e307 |
503 | } |
504 | else { |
505 | print Q<<"EOF"; |
2304df62 |
506 | # [[ |
93a17b20 |
507 | EOF |
8990e307 |
508 | } |
93a17b20 |
509 | |
510 | # do initialization of input variables |
511 | $thisdone = 0; |
512 | $retvaldone = 0; |
463ee0b2 |
513 | $deferred = ""; |
c2960299 |
514 | %arg_list = () ; |
515 | $gotRETVAL = 0; |
2304df62 |
516 | while (@line) { |
517 | $_ = shift(@line); |
93a17b20 |
518 | last if /^\s*NOT_IMPLEMENTED_YET/; |
2304df62 |
519 | last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/; |
f06db76b |
520 | |
521 | TrimWhitespace($_) ; |
522 | # skip blank lines |
523 | next if /^$/ ; |
524 | my $line = $_ ; |
c2960299 |
525 | |
526 | # remove trailing semicolon if no initialisation |
527 | s/\s*;+\s*$//g unless /=/ ; |
528 | |
f06db76b |
529 | # check for optional initialisation code |
c2960299 |
530 | my $var_init = '' ; |
531 | $var_init = $1 if s/\s*(=.*)$// ; |
f06db76b |
532 | |
533 | my @words = split (' ') ; |
534 | blurt("Error: invalid argument declaration '$line'"), next |
535 | unless @words >= 2 ; |
536 | my $var_name = pop @words ; |
537 | my $var_type = "@words" ; |
538 | |
748a9306 |
539 | # catch many errors similar to: SV<tab>* name |
540 | blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n") |
541 | unless ($var_name =~ m/^&?\w+$/); |
93a17b20 |
542 | if ($var_name =~ /^&/) { |
543 | $var_name =~ s/^&//; |
544 | $var_addr{$var_name} = 1; |
545 | } |
f06db76b |
546 | |
547 | # Check for duplicate definitions |
548 | blurt ("Error: duplicate definition of argument '$var_name' ignored"), next |
549 | if $arg_list{$var_name} ++ ; |
550 | |
93a17b20 |
551 | $thisdone |= $var_name eq "THIS"; |
552 | $retvaldone |= $var_name eq "RETVAL"; |
553 | $var_types{$var_name} = $var_type; |
554 | print "\t" . &map_type($var_type); |
555 | $var_num = $args_match{$var_name}; |
556 | if ($var_addr{$var_name}) { |
c2960299 |
557 | $func_args =~ s/\b($var_name)\b/&$1/; |
93a17b20 |
558 | } |
559 | if ($var_init !~ /^=\s*NO_INIT\s*$/) { |
560 | if ($var_init !~ /^\s*$/) { |
561 | &output_init($var_type, $var_num, |
562 | "$var_name $var_init"); |
563 | } elsif ($var_num) { |
564 | # generate initialization code |
565 | &generate_init($var_type, $var_num, $var_name); |
566 | } else { |
567 | print ";\n"; |
568 | } |
569 | } else { |
570 | print "\t$var_name;\n"; |
571 | } |
572 | } |
a0d0e21e |
573 | if (!$thisdone && defined($class)) { |
574 | if (defined($static)) { |
575 | print "\tchar *"; |
576 | $var_types{"CLASS"} = "char *"; |
577 | &generate_init("char *", 1, "CLASS"); |
578 | } |
579 | else { |
93a17b20 |
580 | print "\t$class *"; |
581 | $var_types{"THIS"} = "$class *"; |
582 | &generate_init("$class *", 1, "THIS"); |
a0d0e21e |
583 | } |
93a17b20 |
584 | } |
585 | |
586 | # do code |
587 | if (/^\s*NOT_IMPLEMENTED_YET/) { |
463ee0b2 |
588 | print "\ncroak(\"$pname: not implemented yet\");\n"; |
93a17b20 |
589 | } else { |
590 | if ($ret_type ne "void") { |
591 | print "\t" . &map_type($ret_type) . "\tRETVAL;\n" |
592 | if !$retvaldone; |
593 | $args_match{"RETVAL"} = 0; |
594 | $var_types{"RETVAL"} = $ret_type; |
595 | } |
2304df62 |
596 | if (/^\s*PPCODE:/) { |
2304df62 |
597 | print $deferred; |
598 | while (@line) { |
599 | $_ = shift(@line); |
c2960299 |
600 | death ("PPCODE must be last thing") |
a0d0e21e |
601 | if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; |
2304df62 |
602 | print "$_\n"; |
603 | } |
a0d0e21e |
604 | print "\tPUTBACK;\n\treturn;\n"; |
2304df62 |
605 | } elsif (/^\s*CODE:/) { |
606 | print $deferred; |
607 | while (@line) { |
608 | $_ = shift(@line); |
93a17b20 |
609 | last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/; |
610 | print "$_\n"; |
611 | } |
a0d0e21e |
612 | } elsif ($func_name eq "DESTROY") { |
613 | print $deferred; |
614 | print "\n\t"; |
615 | print "delete THIS;\n" |
93a17b20 |
616 | } else { |
2304df62 |
617 | print $deferred; |
93a17b20 |
618 | print "\n\t"; |
619 | if ($ret_type ne "void") { |
463ee0b2 |
620 | print "RETVAL = "; |
93a17b20 |
621 | } |
622 | if (defined($static)) { |
a0d0e21e |
623 | if ($func_name =~ /^new/) { |
624 | $func_name = "$class"; |
625 | } |
626 | else { |
93a17b20 |
627 | print "$class::"; |
a0d0e21e |
628 | } |
93a17b20 |
629 | } elsif (defined($class)) { |
630 | print "THIS->"; |
631 | } |
632 | if (defined($spat) && $func_name =~ /^($spat)(.*)$/) { |
633 | $func_name = $2; |
634 | } |
635 | print "$func_name($func_args);\n"; |
c2960299 |
636 | $wantRETVAL = 1 unless $ret_type eq "void"; |
93a17b20 |
637 | } |
638 | } |
639 | |
640 | # do output variables |
641 | if (/^\s*OUTPUT\s*:/) { |
c2960299 |
642 | $gotRETVAL = 0; |
643 | my $RETVAL_code ; |
f06db76b |
644 | my %outargs ; |
2304df62 |
645 | while (@line) { |
646 | $_ = shift(@line); |
c2960299 |
647 | last if /^\s*CLEANUP|CASE\s*:/; |
f06db76b |
648 | TrimWhitespace($_) ; |
649 | next if /^$/ ; |
650 | my ($outarg, $outcode) = /^(\S+)\s*(.*)/ ; |
651 | if (!$gotRETVAL and $outarg eq 'RETVAL') { |
652 | # deal with RETVAL last |
c2960299 |
653 | $RETVAL_code = $outcode ; |
f06db76b |
654 | $gotRETVAL = 1 ; |
f06db76b |
655 | next ; |
656 | } |
657 | blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next |
658 | if $outargs{$outarg} ++ ; |
659 | blurt ("Error: OUTPUT $outarg not an argument"), next |
660 | unless defined($args_match{$outarg}); |
661 | blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next |
662 | unless defined $var_types{$outarg} ; |
93a17b20 |
663 | if ($outcode) { |
a0d0e21e |
664 | print "\t$outcode\n"; |
93a17b20 |
665 | } else { |
93a17b20 |
666 | $var_num = $args_match{$outarg}; |
667 | &generate_output($var_types{$outarg}, $var_num, |
668 | $outarg); |
669 | } |
670 | } |
c2960299 |
671 | |
672 | if ($gotRETVAL) { |
673 | if ($RETVAL_code) |
674 | { print "\t$RETVAL_code\n" } |
675 | else |
676 | { &generate_output($ret_type, 0, 'RETVAL') } |
677 | } |
93a17b20 |
678 | } |
f06db76b |
679 | |
680 | # all OUTPUT done, so now push the return value on the stack |
681 | &generate_output($ret_type, 0, "RETVAL") |
c2960299 |
682 | if $wantRETVAL and ! $gotRETVAL ; |
f06db76b |
683 | |
93a17b20 |
684 | # do cleanup |
685 | if (/^\s*CLEANUP\s*:/) { |
2304df62 |
686 | while (@line) { |
687 | $_ = shift(@line); |
93a17b20 |
688 | last if /^\s*CASE\s*:/; |
689 | print "$_\n"; |
690 | } |
691 | } |
692 | # print function trailer |
8990e307 |
693 | if ($except) { |
694 | print Q<<EOF; |
2304df62 |
695 | # ]] |
8990e307 |
696 | # BEGHANDLERS |
697 | # CATCHALL |
698 | # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); |
699 | # ENDHANDLERS |
93a17b20 |
700 | EOF |
8990e307 |
701 | } |
702 | else { |
703 | print Q<<EOF; |
2304df62 |
704 | # ]] |
93a17b20 |
705 | EOF |
8990e307 |
706 | } |
93a17b20 |
707 | if (/^\s*CASE\s*:/) { |
8990e307 |
708 | unshift(@line, $_); |
93a17b20 |
709 | } |
2304df62 |
710 | } |
a0d0e21e |
711 | |
2304df62 |
712 | print Q<<EOF if $except; |
713 | # if (errbuf[0]) |
714 | # croak(errbuf); |
715 | EOF |
a0d0e21e |
716 | |
717 | print Q<<EOF unless $PPCODE; |
718 | # XSRETURN(1); |
719 | EOF |
720 | |
2304df62 |
721 | print Q<<EOF; |
2304df62 |
722 | #]] |
8990e307 |
723 | # |
93a17b20 |
724 | EOF |
725 | } |
726 | |
727 | # print initialization routine |
8990e307 |
728 | print qq/extern "C"\n/ if $cplusplus; |
729 | print Q<<"EOF"; |
a0d0e21e |
730 | #XS(boot_$Module_cname) |
2304df62 |
731 | #[[ |
a0d0e21e |
732 | # dXSARGS; |
8990e307 |
733 | # char* file = __FILE__; |
734 | # |
93a17b20 |
735 | EOF |
736 | |
737 | for (@Func_name) { |
2304df62 |
738 | $pname = shift(@Func_pname); |
a0d0e21e |
739 | print " newXS(\"$pname\", XS_$_, file);\n"; |
740 | } |
741 | |
742 | if (@BootCode) |
743 | { |
744 | print "\n /* Initialisation Section */\n\n" ; |
745 | print grep (s/$/\n/, @BootCode) ; |
746 | print " /* End of Initialisation Section */\n\n" ; |
93a17b20 |
747 | } |
a0d0e21e |
748 | |
749 | print " ST(0) = &sv_yes;\n"; |
750 | print " XSRETURN(1);\n"; |
93a17b20 |
751 | print "}\n"; |
752 | |
753 | sub output_init { |
2304df62 |
754 | local($type, $num, $init) = @_; |
a0d0e21e |
755 | local($arg) = "ST(" . ($num - 1) . ")"; |
93a17b20 |
756 | |
2304df62 |
757 | eval qq/print " $init\\\n"/; |
93a17b20 |
758 | } |
759 | |
c2960299 |
760 | sub Warn |
761 | { |
762 | # work out the line number |
763 | my $line_no = $line_no[@line_no - @line -1] ; |
764 | |
765 | print STDERR "@_ in $filename, line $line_no\n" ; |
766 | } |
767 | |
768 | sub blurt |
769 | { |
770 | Warn @_ ; |
771 | $errors ++ |
772 | } |
773 | |
774 | sub death |
775 | { |
776 | Warn @_ ; |
777 | exit 1 ; |
778 | } |
8990e307 |
779 | |
93a17b20 |
780 | sub generate_init { |
2304df62 |
781 | local($type, $num, $var) = @_; |
a0d0e21e |
782 | local($arg) = "ST(" . ($num - 1) . ")"; |
2304df62 |
783 | local($argoff) = $num - 1; |
784 | local($ntype); |
785 | local($tk); |
93a17b20 |
786 | |
f06db76b |
787 | $type = TidyType($type) ; |
c2960299 |
788 | blurt("Error: '$type' not in typemap"), return |
789 | unless defined($type_kind{$type}); |
790 | |
2304df62 |
791 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
792 | $subtype = $ntype; |
793 | $subtype =~ s/Ptr$//; |
794 | $subtype =~ s/Array$//; |
795 | $tk = $type_kind{$type}; |
796 | $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; |
797 | $type =~ s/:/_/g; |
c2960299 |
798 | blurt("Error: No INPUT definition for type '$type' found"), return |
799 | unless defined $input_expr{$tk} ; |
2304df62 |
800 | $expr = $input_expr{$tk}; |
801 | if ($expr =~ /DO_ARRAY_ELEM/) { |
c2960299 |
802 | blurt("Error: '$subtype' not in typemap"), return |
803 | unless defined($type_kind{$subtype}); |
804 | blurt("Error: No INPUT definition for type '$subtype' found"), return |
805 | unless defined $input_expr{$type_kind{$subtype}} ; |
2304df62 |
806 | $subexpr = $input_expr{$type_kind{$subtype}}; |
807 | $subexpr =~ s/ntype/subtype/g; |
808 | $subexpr =~ s/\$arg/ST(ix_$var)/g; |
809 | $subexpr =~ s/\n\t/\n\t\t/g; |
810 | $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g; |
a0d0e21e |
811 | $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; |
2304df62 |
812 | $expr =~ s/DO_ARRAY_ELEM/$subexpr/; |
813 | } |
814 | if (defined($defaults{$var})) { |
815 | $expr =~ s/(\t+)/$1 /g; |
816 | $expr =~ s/ /\t/g; |
817 | eval qq/print "\\t$var;\\n"/; |
818 | $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; |
819 | } elsif ($expr !~ /^\t\$var =/) { |
820 | eval qq/print "\\t$var;\\n"/; |
821 | $deferred .= eval qq/"\\n$expr;\\n"/; |
822 | } else { |
823 | eval qq/print "$expr;\\n"/; |
824 | } |
93a17b20 |
825 | } |
826 | |
827 | sub generate_output { |
2304df62 |
828 | local($type, $num, $var) = @_; |
a0d0e21e |
829 | local($arg) = "ST(" . ($num - ($num != 0)) . ")"; |
2304df62 |
830 | local($argoff) = $num - 1; |
831 | local($ntype); |
93a17b20 |
832 | |
f06db76b |
833 | $type = TidyType($type) ; |
2304df62 |
834 | if ($type =~ /^array\(([^,]*),(.*)\)/) { |
835 | print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n"; |
836 | } else { |
f06db76b |
837 | blurt("Error: '$type' not in typemap"), return |
2304df62 |
838 | unless defined($type_kind{$type}); |
c2960299 |
839 | blurt("Error: No OUTPUT definition for type '$type' found"), return |
840 | unless defined $output_expr{$type_kind{$type}} ; |
2304df62 |
841 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
842 | $ntype =~ s/\(\)//g; |
843 | $subtype = $ntype; |
844 | $subtype =~ s/Ptr$//; |
845 | $subtype =~ s/Array$//; |
846 | $expr = $output_expr{$type_kind{$type}}; |
847 | if ($expr =~ /DO_ARRAY_ELEM/) { |
c2960299 |
848 | blurt("Error: '$subtype' not in typemap"), return |
849 | unless defined($type_kind{$subtype}); |
850 | blurt("Error: No OUTPUT definition for type '$subtype' found"), return |
851 | unless defined $output_expr{$type_kind{$subtype}} ; |
2304df62 |
852 | $subexpr = $output_expr{$type_kind{$subtype}}; |
853 | $subexpr =~ s/ntype/subtype/g; |
854 | $subexpr =~ s/\$arg/ST(ix_$var)/g; |
855 | $subexpr =~ s/\$var/${var}[ix_$var]/g; |
856 | $subexpr =~ s/\n\t/\n\t\t/g; |
857 | $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; |
a0d0e21e |
858 | eval "print qq\a$expr\a"; |
2304df62 |
859 | } |
a0d0e21e |
860 | elsif ($var eq 'RETVAL') { |
2304df62 |
861 | if ($expr =~ /^\t\$arg = /) { |
a0d0e21e |
862 | eval "print qq\a$expr\a"; |
2304df62 |
863 | print "\tsv_2mortal(ST(0));\n"; |
93a17b20 |
864 | } |
2304df62 |
865 | else { |
8990e307 |
866 | print "\tST(0) = sv_newmortal();\n"; |
a0d0e21e |
867 | eval "print qq\a$expr\a"; |
463ee0b2 |
868 | } |
2304df62 |
869 | } |
a0d0e21e |
870 | elsif ($arg =~ /^ST\(\d+\)$/) { |
871 | eval "print qq\a$expr\a"; |
872 | } |
2304df62 |
873 | } |
93a17b20 |
874 | } |
875 | |
876 | sub map_type { |
2304df62 |
877 | local($type) = @_; |
93a17b20 |
878 | |
2304df62 |
879 | $type =~ s/:/_/g; |
880 | if ($type =~ /^array\(([^,]*),(.*)\)/) { |
881 | return "$1 *"; |
882 | } else { |
883 | return $type; |
884 | } |
93a17b20 |
885 | } |
8990e307 |
886 | |
748a9306 |
887 | # If this is VMS, the exit status has meaning to the shell, so we |
888 | # use a predictable value (SS$_Abort) rather than an arbitrary |
889 | # number. |
c2960299 |
890 | exit ($Is_VMS ? 44 : $errors) ; |