Commit | Line | Data |
d536870a |
1 | diff -ru :perl:lib:ExtUtils: :perl.new:lib:ExtUtils:xsubpp |
2 | --- :perl:lib:ExtUtils:xsubpp Mon Feb 19 17:07:32 2001 |
3 | +++ :perl.new:lib:ExtUtils:xsubpp Mon Feb 19 15:31:31 2001 |
4 | @@ -173,7 +173,13 @@ |
5 | ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# |
6 | or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)# |
7 | or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# |
8 | + or ($dir, $filename) = $ARGV[0] =~ m#(.*):(.*)# |
9 | or ($dir, $filename) = ('.', $ARGV[0]); |
10 | + |
11 | +$Is_MacOS = $^O eq 'MacOS'; |
12 | +if ($Is_MacOS && $dir eq '.') { |
13 | + $dir = ":"; |
14 | +} |
15 | chdir($dir); |
16 | $pwd = cwd(); |
17 | |
18 | @@ -209,9 +215,21 @@ |
19 | foreach $typemap (@tm) { |
20 | die "Can't find $typemap in $pwd\n" unless -r $typemap; |
21 | } |
22 | -unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap |
23 | +if ($Is_MacOS) { my @tmp; |
24 | + foreach (qw(:::: ::: :: :)) { |
25 | + push @tmp, "$_:lib:ExtUtils:typemap"; |
26 | + push @tmp, "$_:macos:lib:ExtUtils:typemap"; |
27 | + push @tmp, "$_:Mac:typemap"; |
28 | + push @tmp, "$_:macos:ext:Mac:typemap"; |
29 | + push @tmp, "$_:typemap"; |
30 | + } |
31 | + unshift @tm, @tmp, "typemap"; |
32 | +} else { |
33 | + unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap |
34 | ../../lib/ExtUtils/typemap ../../../typemap ../../typemap |
35 | ../typemap typemap); |
36 | +} |
37 | + |
38 | foreach $typemap (@tm) { |
39 | next unless -e $typemap ; |
40 | # skip directories, binary files etc. |
41 | @@ -364,7 +382,7 @@ |
42 | print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") |
43 | if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; |
44 | for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { |
45 | - print "$_\n"; |
46 | + XS_process("$_\n"); |
47 | } |
48 | print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; |
49 | } |
50 | @@ -746,7 +764,85 @@ |
51 | $lastline_no = $. ; |
52 | |
53 | } |
54 | - |
55 | + |
56 | +sub XS_PUSH_handler |
57 | +{ |
58 | + my($type, $value, $xpush) = @_; |
59 | + if ($xpush) { |
60 | + print "\tEXTEND(sp, 1);\n"; |
61 | + } |
62 | + print "\t++sp;\n"; |
63 | + &generate_output($type, 0, "($value)", "*sp", 1); |
64 | + ""; |
65 | +} |
66 | + |
67 | +sub XS_OUTPUT_handler |
68 | +{ |
69 | + my($type, $value, $arg) = @_; |
70 | + |
71 | + &generate_output($type, 0, "($value)", 0, 0, $arg); |
72 | + ""; |
73 | +} |
74 | + |
75 | +sub XS_INPUT_handler |
76 | +{ |
77 | + my($type, $var, $arg) = @_; |
78 | + &generate_init($type, 0, $var, 0, 0, $arg, 1); |
79 | + ""; |
80 | +} |
81 | + |
82 | + |
83 | +sub XS_POP_handler |
84 | +{ |
85 | + my($type, $var, $pop) = @_; |
86 | + &generate_init($type, 0, $var, "TOPs", 1); |
87 | + print "\tPOPs;\n" if $pop; |
88 | + ""; |
89 | +} |
90 | + |
91 | +sub SplitArgs |
92 | +{ |
93 | + my(@bits,@pieces,$item); |
94 | + @bits = split /,/, $_[0]; |
95 | + while (@bits) { |
96 | + $item .= "," if $item; |
97 | + $item .= shift @bits; |
98 | + if (tr/(// == tr/)// |
99 | + && tr/{// == tr/}// |
100 | + && tr/[// == tr/]// |
101 | + && !(tr/"// & 1) |
102 | + && !(tr/'// & 1) |
103 | + ) { |
104 | + push @pieces, $item; |
105 | + $item = ""; |
106 | + } |
107 | + } |
108 | + @pieces; |
109 | +} |
110 | + |
111 | +sub XS_process |
112 | +{ |
113 | + my($text) = @_; |
114 | + |
115 | + while (length($text)) { |
116 | + if ($text =~ s/^.*\bXS_PUSH\(([^,]+),\s*(.*)\)\s*;?.*\n?//) { |
117 | + XS_PUSH_handler($1, $2, 0); |
118 | + } elsif ($text =~ s/^.*\bXS_XPUSH\(([^,]+),\s*(.*)\)\s*;?.*\n?//) { |
119 | + XS_PUSH_handler($1, $2, 1); |
120 | + } elsif ($text =~ s/^.*\bXS_OUTPUT\((.*)\)\s*;?.*\n?//) { |
121 | + XS_OUTPUT_handler(SplitArgs($1)); |
122 | + } elsif ($text =~ s/^.*\bXS_INPUT\((.*)\)\s*;?.*\n?//) { |
123 | + XS_INPUT_handler(SplitArgs($1)); |
124 | + } elsif ($text =~ s/^.*\bXS_POP\(([^,]+),\s*(.*)\)\s*;?.*\n?//) { |
125 | + XS_POP_handler($1, $2, 1); |
126 | + } elsif ($text =~ s/^.*\bXS_TOP\(([^,]+),\s*(.*)\)\s*;?.*\n?//) { |
127 | + XS_POP_handler($1, $2, 0); |
128 | + } elsif ($text =~ s/^(.*\n?)//) { |
129 | + print $1; |
130 | + } |
131 | + } |
132 | +} |
133 | + |
134 | sub PopFile() |
135 | { |
136 | return 0 unless $XSStack[-1]{type} eq 'file' ; |
137 | @@ -861,8 +957,8 @@ |
138 | my $podstartline = $.; |
139 | do { |
140 | if (/^=cut\s*$/) { |
141 | - print("/* Skipped embedded POD. */\n"); |
142 | - printf("#line %d \"$filename\"\n", $. + 1) |
143 | + XS_process("/* Skipped embedded POD. */\n"); |
144 | + XS_process(sprintf("#line %d \"$filename\"\n", $. + 1)) |
145 | if $WantLineNumbers; |
146 | next firstmodule |
147 | } |
148 | @@ -880,7 +976,7 @@ |
149 | if ($OBJ) { |
150 | s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/; |
151 | } |
152 | - print $_; |
153 | + XS_process($_); |
154 | } |
155 | &Exit unless defined $_; |
156 | |
157 | @@ -949,6 +1045,185 @@ |
158 | 1; |
159 | } |
160 | |
161 | +sub indent { |
162 | + my($line) = @_; |
163 | + my($indent) = 0; |
164 | + |
165 | + for (;;) { |
166 | + if ($line =~ s/^( +)//) { $indent += length $1; next; } |
167 | + if ($line =~ s/^\t//) { $indent += 8 - ($indent & 7); next; } |
168 | + last; |
169 | + } |
170 | + $indent; |
171 | +} |
172 | + |
173 | +sub handle_struct |
174 | +{ |
175 | + # extract return type, function name and arguments |
176 | + my($deref, $structpack) = /(\**)\s*(\S+)/; |
177 | + my($handle) = ($^O eq "MacOS") && ($deref eq "**"); |
178 | + $deref =~ s/\*$/->/; |
179 | + $deref =~ s/\*/\[0\]/g; |
180 | + $deref ||= "."; |
181 | + my($structtype) = $structpack; |
182 | + |
183 | + # a struct definition needs at least 2 lines |
184 | + blurt ("Error: Struct definition too short '$structpack'"), next PARAGRAPH |
185 | + unless @line ; |
186 | + |
187 | + ($clean_struct_name = $structpack) =~ s/^$Prefix//; |
188 | + $Full_struct_name = "${Packid}_$clean_struct_name"; |
189 | + if ($Is_VMS) { $Full_struct_name = $SymSet->addsym($Full_struct_name); } |
190 | + |
191 | + # Check for duplicate function definition |
192 | + for $tmp (@XSStack) { |
193 | + next unless defined $tmp->{functions}{$Full_struct_name}; |
194 | + Warn("Warning: duplicate struct definition '$clean_struct_name' detected"); |
195 | + last; |
196 | + } |
197 | + |
198 | + # print struct function header |
199 | + print Q<<"EOF"; |
200 | +#XS(XS_${Full_struct_name}) |
201 | +#[[ |
202 | +# dXSARGS; |
203 | +# dXSI32; |
204 | +# if (items < 1 || items > 2) |
205 | +# croak("Usage: %s(STRUCT [, VALUE])", GvNAME(CvGV(cv))); |
206 | +# SP -= items; |
207 | +EOF |
208 | + |
209 | + # Now do a block of some sort. |
210 | + |
211 | + &check_cpp; |
212 | + my($structinput, $structoutput, $structindir, $structoutdir); |
213 | + my(@field, @fieldindir, @fieldoutdir, @input, @output); |
214 | + $structindir = $structoutdir = line_directive(); |
215 | + $_ = ""; |
216 | + while (defined $_) { |
217 | + $_ = shift @line while /^\s*$/; |
218 | + my($fieldindir) = line_directive(); |
219 | + my($fieldoutdir)= $fieldindir; |
220 | + my($indent,$fieldtype,$fieldname) = |
221 | + m|^(\s*)(\S.*\S)\s*\b(\w+)\s*;?\s*(?:/\*.*\*/)?$|; |
222 | + $indent = indent $indent; |
223 | + $fieldtype = TidyType $fieldtype; |
224 | + my($input, $output); |
225 | + my $var = "STRUCT$deref$fieldname"; |
226 | + $_ = shift @line; |
227 | + while (/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) { |
228 | + if (/ALIAS\s*(.*)/) { |
229 | + $var = $1; |
230 | + $_ = shift @line; |
231 | + } elsif (/READ_ONLY/) { |
232 | + $fieldindir = line_directive(); |
233 | + $input = "$_"; |
234 | + $_ = shift @line; |
235 | + } elsif (/INPUT/) { |
236 | + last unless ($_ = shift @line); |
237 | + $fieldindir = line_directive(); |
238 | + while (indent($_) > $indent && !/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) { |
239 | + $input .= "$_\n"; |
240 | + $_ = shift @line; |
241 | + } |
242 | + } else { |
243 | + last unless ($_ = shift @line); |
244 | + $fieldoutdir = line_directive(); |
245 | + while (indent($_) > $indent && !/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) { |
246 | + $output .= "$_\n"; |
247 | + $_ = shift @line; |
248 | + } |
249 | + } |
250 | + } |
251 | + if ($fieldname eq "STRUCT") { |
252 | + $structindir = $fieldindir; |
253 | + $structoutdir= $fieldoutdir; |
254 | + $structtype = $fieldtype; |
255 | + $arg = "ST(0)"; |
256 | + $structinput = eval "qq\a$input\a"; |
257 | + $structoutput= eval "qq\a$output\a"; |
258 | + } else { |
259 | + if ($input =~ /READ_ONLY/) { |
260 | + $input = "\tcroak(\"$var is read-only\");\n"; |
261 | + } elsif ($input) { |
262 | + $arg = "ST(1)"; |
263 | + $input = eval "qq\a$input\a"; |
264 | + } else { |
265 | + $input = "\tXS_INPUT($fieldtype, $var, ST(1));"; |
266 | + } |
267 | + if ($output) { |
268 | + $arg = "*sp"; |
269 | + $output = "\tPUSHs(sv_newmortal());\n" . eval "qq\a$output\a"; |
270 | + } else { |
271 | + $output = "\tXS_PUSH($fieldtype, $var);"; |
272 | + } |
273 | + push @field, $fieldname; |
274 | + push @fieldindir, $fieldindir; |
275 | + push @fieldoutdir, $fieldoutdir; |
276 | + push @input, $input; |
277 | + push @output, $output; |
278 | + } |
279 | + } |
280 | + print Q<<"EOF"; |
281 | +# [[ |
282 | +# $structtype STRUCT; |
283 | +EOF |
284 | + print "\tchar STRUCT_state;\n" if $handle; |
285 | + print "\n$structindir"; |
286 | + XS_process($structinput || "\tXS_INPUT($structtype, STRUCT, ST(0));"); |
287 | + print "\n\tSTRUCT_state = HGetState((Handle)STRUCT); HLock((Handle)STRUCT);\n" if ($handle); |
288 | + print Q<<"EOF"; |
289 | +# if (items == 1) [[ /* Get field */ |
290 | +# switch (ix) [[ |
291 | +EOF |
292 | + for (0..$#field) { |
293 | + print Q<<"EOF"; |
294 | +# case $_: /* $field[$_] */ |
295 | +EOF |
296 | + print $fieldoutdir[$_]; |
297 | + XS_process($output[$_]); |
298 | + print Q<<"EOF"; |
299 | +# break; |
300 | +EOF |
301 | + } |
302 | + print Q<<"EOF"; |
303 | +# ]] |
304 | +# ]] else [[ /* Set field */ |
305 | +# switch (ix) [[ |
306 | +EOF |
307 | + for (0..$#field) { |
308 | + print Q<<"EOF"; |
309 | +# case $_: /* $field[$_] */ |
310 | +EOF |
311 | + print $fieldindir[$_]; |
312 | + XS_process($input[$_]); |
313 | + print Q<<"EOF"; |
314 | +# break; |
315 | +EOF |
316 | + } |
317 | + print Q<<"EOF"; |
318 | +# ]] |
319 | +EOF |
320 | + print $structoutdir; |
321 | + XS_process($structoutput || "\tXS_OUTPUT($structtype, STRUCT, ST(0))\n"); |
322 | + print Q<<"EOF"; |
323 | +# ]] |
324 | +EOF |
325 | + print "\tHSetState((Handle)STRUCT, STRUCT_state);\n" if $handle; |
326 | + print Q<<"EOF"; |
327 | +# ]] |
328 | +# XSRETURN(1); |
329 | +#]] |
330 | +# |
331 | +EOF |
332 | + for (0..$#field) { |
333 | + push(@InitFileCode, Q<<"EOF"); |
334 | +# cv = newXS(\"${structpack}::$field[$_]\", XS_$Full_struct_name, file); |
335 | +# XSANY.any_i32 = $_ ; |
336 | +EOF |
337 | + } |
338 | +} |
339 | + |
340 | PARAGRAPH: |
341 | while (fetch_para()) { |
342 | # Print initial preprocessor statements and blank lines |
343 | @@ -1040,7 +1315,11 @@ |
344 | next PARAGRAPH ; |
345 | } |
346 | |
347 | - |
348 | + if (s/^STRUCT\s*//) { |
349 | + handle_struct(); |
350 | + next PARAGRAPH; |
351 | + } |
352 | + |
353 | # extract return type, function name and arguments |
354 | ($ret_type) = TidyType($_); |
355 | $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//; |
356 | @@ -1285,7 +1564,7 @@ |
357 | $processing_arg_with_types = 1; |
358 | INPUT_handler() ; |
359 | } |
360 | - print $deferred; |
361 | + XS_process($deferred); |
362 | |
363 | process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; |
364 | |
365 | @@ -1338,7 +1617,7 @@ |
366 | |
367 | # all OUTPUT done, so now push the return value on the stack |
368 | if ($gotRETVAL && $RETVAL_code) { |
369 | - print "\t$RETVAL_code\n"; |
370 | + XS_process("\t$RETVAL_code\n"); |
371 | } elsif ($gotRETVAL || $wantRETVAL) { |
372 | my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; |
373 | my $var = 'RETVAL'; |
374 | @@ -1574,6 +1853,14 @@ |
375 | } |
376 | } |
377 | |
378 | +sub line_directive |
379 | +{ |
380 | + # work out the line number |
381 | + my $line_no = $line_no[@line_no - @line -1] ; |
382 | + |
383 | + return "#line $line_no \"$filename\"\n" ; |
384 | +} |
385 | + |
386 | sub Warn |
387 | { |
388 | # work out the line number |
389 | @@ -1595,12 +1882,12 @@ |
390 | } |
391 | |
392 | sub generate_init { |
393 | - local($type, $num, $var) = @_; |
394 | - local($arg) = "ST(" . ($num - 1) . ")"; |
395 | + local($type, $num, $var, $arg, $immed) = @_; |
396 | local($argoff) = $num - 1; |
397 | local($ntype); |
398 | local($tk); |
399 | |
400 | + $arg ||= "ST(" . ($num - 1) . ")"; |
401 | $type = TidyType($type) ; |
402 | blurt("Error: '$type' not in typemap"), return |
403 | unless defined($type_kind{$type}); |
404 | @@ -1656,17 +1943,18 @@ |
405 | } else { |
406 | die "panic: do not know how to handle this branch for function pointers" |
407 | if $name_printed; |
408 | - eval qq/print "$expr;\\n"/; |
409 | + eval qq/XS_process "$expr;\\n"/; |
410 | warn $@ if $@; |
411 | } |
412 | } |
413 | |
414 | sub generate_output { |
415 | - local($type, $num, $var, $do_setmagic, $do_push) = @_; |
416 | - local($arg) = "ST(" . ($num - ($num != 0)) . ")"; |
417 | + local($type, $num, $var, $do_setmagic, $do_push, $arg, $mortalize) = @_; |
418 | local($argoff) = $num - 1; |
419 | local($ntype); |
420 | |
421 | + $mortalize ||= $var eq 'RETVAL'; |
422 | + $arg ||= "ST(" . ($num - ($num != 0)) . ")"; |
423 | $type = TidyType($type) ; |
424 | if ($type =~ /^array\(([^,]*),(.*)\)/) { |
425 | print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; |
426 | @@ -1695,30 +1983,30 @@ |
427 | warn $@ if $@; |
428 | print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; |
429 | } |
430 | - elsif ($var eq 'RETVAL') { |
431 | + elsif ($mortalize) { |
432 | if ($expr =~ /^\t\$arg = new/) { |
433 | # We expect that $arg has refcnt 1, so we need to |
434 | # mortalize it. |
435 | eval "print qq\a$expr\a"; |
436 | warn $@ if $@; |
437 | - print "\tsv_2mortal(ST($num));\n"; |
438 | - print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; |
439 | + print "\tsv_2mortal($arg);\n"; |
440 | + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
441 | } |
442 | elsif ($expr =~ /^\s*\$arg\s*=/) { |
443 | # We expect that $arg has refcnt >=1, so we need |
444 | # to mortalize it! |
445 | eval "print qq\a$expr\a"; |
446 | warn $@ if $@; |
447 | - print "\tsv_2mortal(ST(0));\n"; |
448 | - print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; |
449 | + print "\tsv_2mortal($arg);\n"; |
450 | + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
451 | } |
452 | else { |
453 | # Just hope that the entry would safely write it |
454 | # over an already mortalized value. By |
455 | # coincidence, something like $arg = &sv_undef |
456 | # works too. |
457 | - print "\tST(0) = sv_newmortal();\n"; |
458 | - eval "print qq\a$expr\a"; |
459 | + print "\t$arg = sv_newmortal();\n"; |
460 | + eval "XS_process qq\a$expr\a"; |
461 | warn $@ if $@; |
462 | # new mortals don't have set magic |
463 | } |
464 | @@ -1730,8 +2018,8 @@ |
465 | warn $@ if $@; |
466 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
467 | } |
468 | - elsif ($arg =~ /^ST\(\d+\)$/) { |
469 | - eval "print qq\a$expr\a"; |
470 | + else { |
471 | + eval "XS_process qq\a$expr\a"; |
472 | warn $@ if $@; |
473 | print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
474 | } |