projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Re: Magic numbers in B::Concise
[p5sagit/p5-mst-13.2.git] / macos / xsubpp.patch
CommitLineData
d536870a 1diff -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 }
Unnamed repository; edit this file to name it for gitweb.