diff -ru :perl:lib:ExtUtils: :perl.new:lib:ExtUtils:xsubpp --- :perl:lib:ExtUtils:xsubpp Mon Feb 19 17:07:32 2001 +++ :perl.new:lib:ExtUtils:xsubpp Mon Feb 19 15:31:31 2001 @@ -173,7 +173,13 @@ ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)# or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# + or ($dir, $filename) = $ARGV[0] =~ m#(.*):(.*)# or ($dir, $filename) = ('.', $ARGV[0]); + +$Is_MacOS = $^O eq 'MacOS'; +if ($Is_MacOS && $dir eq '.') { + $dir = ":"; +} chdir($dir); $pwd = cwd(); @@ -209,9 +215,21 @@ foreach $typemap (@tm) { die "Can't find $typemap in $pwd\n" unless -r $typemap; } -unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap +if ($Is_MacOS) { my @tmp; + foreach (qw(:::: ::: :: :)) { + push @tmp, "$_:lib:ExtUtils:typemap"; + push @tmp, "$_:macos:lib:ExtUtils:typemap"; + push @tmp, "$_:Mac:typemap"; + push @tmp, "$_:macos:ext:Mac:typemap"; + push @tmp, "$_:typemap"; + } + unshift @tm, @tmp, "typemap"; +} else { + unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap ../../lib/ExtUtils/typemap ../../../typemap ../../typemap ../typemap typemap); +} + foreach $typemap (@tm) { next unless -e $typemap ; # skip directories, binary files etc. @@ -364,7 +382,7 @@ print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { - print "$_\n"; + XS_process("$_\n"); } print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; } @@ -746,7 +764,85 @@ $lastline_no = $. ; } - + +sub XS_PUSH_handler +{ + my($type, $value, $xpush) = @_; + if ($xpush) { + print "\tEXTEND(sp, 1);\n"; + } + print "\t++sp;\n"; + &generate_output($type, 0, "($value)", "*sp", 1); + ""; +} + +sub XS_OUTPUT_handler +{ + my($type, $value, $arg) = @_; + + &generate_output($type, 0, "($value)", 0, 0, $arg); + ""; +} + +sub XS_INPUT_handler +{ + my($type, $var, $arg) = @_; + &generate_init($type, 0, $var, 0, 0, $arg, 1); + ""; +} + + +sub XS_POP_handler +{ + my($type, $var, $pop) = @_; + &generate_init($type, 0, $var, "TOPs", 1); + print "\tPOPs;\n" if $pop; + ""; +} + +sub SplitArgs +{ + my(@bits,@pieces,$item); + @bits = split /,/, $_[0]; + while (@bits) { + $item .= "," if $item; + $item .= shift @bits; + if (tr/(// == tr/)// + && tr/{// == tr/}// + && tr/[// == tr/]// + && !(tr/"// & 1) + && !(tr/'// & 1) + ) { + push @pieces, $item; + $item = ""; + } + } + @pieces; +} + +sub XS_process +{ + my($text) = @_; + + while (length($text)) { + if ($text =~ s/^.*\bXS_PUSH\(([^,]+),\s*(.*)\)\s*;?.*\n?//) { + XS_PUSH_handler($1, $2, 0); + } elsif ($text =~ s/^.*\bXS_XPUSH\(([^,]+),\s*(.*)\)\s*;?.*\n?//) { + XS_PUSH_handler($1, $2, 1); + } elsif ($text =~ s/^.*\bXS_OUTPUT\((.*)\)\s*;?.*\n?//) { + XS_OUTPUT_handler(SplitArgs($1)); + } elsif ($text =~ s/^.*\bXS_INPUT\((.*)\)\s*;?.*\n?//) { + XS_INPUT_handler(SplitArgs($1)); + } elsif ($text =~ s/^.*\bXS_POP\(([^,]+),\s*(.*)\)\s*;?.*\n?//) { + XS_POP_handler($1, $2, 1); + } elsif ($text =~ s/^.*\bXS_TOP\(([^,]+),\s*(.*)\)\s*;?.*\n?//) { + XS_POP_handler($1, $2, 0); + } elsif ($text =~ s/^(.*\n?)//) { + print $1; + } + } +} + sub PopFile() { return 0 unless $XSStack[-1]{type} eq 'file' ; @@ -861,8 +957,8 @@ my $podstartline = $.; do { if (/^=cut\s*$/) { - print("/* Skipped embedded POD. */\n"); - printf("#line %d \"$filename\"\n", $. + 1) + XS_process("/* Skipped embedded POD. */\n"); + XS_process(sprintf("#line %d \"$filename\"\n", $. + 1)) if $WantLineNumbers; next firstmodule } @@ -880,7 +976,7 @@ if ($OBJ) { s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/; } - print $_; + XS_process($_); } &Exit unless defined $_; @@ -949,6 +1045,185 @@ 1; } +sub indent { + my($line) = @_; + my($indent) = 0; + + for (;;) { + if ($line =~ s/^( +)//) { $indent += length $1; next; } + if ($line =~ s/^\t//) { $indent += 8 - ($indent & 7); next; } + last; + } + $indent; +} + +sub handle_struct +{ + # extract return type, function name and arguments + my($deref, $structpack) = /(\**)\s*(\S+)/; + my($handle) = ($^O eq "MacOS") && ($deref eq "**"); + $deref =~ s/\*$/->/; + $deref =~ s/\*/\[0\]/g; + $deref ||= "."; + my($structtype) = $structpack; + + # a struct definition needs at least 2 lines + blurt ("Error: Struct definition too short '$structpack'"), next PARAGRAPH + unless @line ; + + ($clean_struct_name = $structpack) =~ s/^$Prefix//; + $Full_struct_name = "${Packid}_$clean_struct_name"; + if ($Is_VMS) { $Full_struct_name = $SymSet->addsym($Full_struct_name); } + + # Check for duplicate function definition + for $tmp (@XSStack) { + next unless defined $tmp->{functions}{$Full_struct_name}; + Warn("Warning: duplicate struct definition '$clean_struct_name' detected"); + last; + } + + # print struct function header + print Q<<"EOF"; +#XS(XS_${Full_struct_name}) +#[[ +# dXSARGS; +# dXSI32; +# if (items < 1 || items > 2) +# croak("Usage: %s(STRUCT [, VALUE])", GvNAME(CvGV(cv))); +# SP -= items; +EOF + + # Now do a block of some sort. + + &check_cpp; + my($structinput, $structoutput, $structindir, $structoutdir); + my(@field, @fieldindir, @fieldoutdir, @input, @output); + $structindir = $structoutdir = line_directive(); + $_ = ""; + while (defined $_) { + $_ = shift @line while /^\s*$/; + my($fieldindir) = line_directive(); + my($fieldoutdir)= $fieldindir; + my($indent,$fieldtype,$fieldname) = + m|^(\s*)(\S.*\S)\s*\b(\w+)\s*;?\s*(?:/\*.*\*/)?$|; + $indent = indent $indent; + $fieldtype = TidyType $fieldtype; + my($input, $output); + my $var = "STRUCT$deref$fieldname"; + $_ = shift @line; + while (/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) { + if (/ALIAS\s*(.*)/) { + $var = $1; + $_ = shift @line; + } elsif (/READ_ONLY/) { + $fieldindir = line_directive(); + $input = "$_"; + $_ = shift @line; + } elsif (/INPUT/) { + last unless ($_ = shift @line); + $fieldindir = line_directive(); + while (indent($_) > $indent && !/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) { + $input .= "$_\n"; + $_ = shift @line; + } + } else { + last unless ($_ = shift @line); + $fieldoutdir = line_directive(); + while (indent($_) > $indent && !/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) { + $output .= "$_\n"; + $_ = shift @line; + } + } + } + if ($fieldname eq "STRUCT") { + $structindir = $fieldindir; + $structoutdir= $fieldoutdir; + $structtype = $fieldtype; + $arg = "ST(0)"; + $structinput = eval "qq\a$input\a"; + $structoutput= eval "qq\a$output\a"; + } else { + if ($input =~ /READ_ONLY/) { + $input = "\tcroak(\"$var is read-only\");\n"; + } elsif ($input) { + $arg = "ST(1)"; + $input = eval "qq\a$input\a"; + } else { + $input = "\tXS_INPUT($fieldtype, $var, ST(1));"; + } + if ($output) { + $arg = "*sp"; + $output = "\tPUSHs(sv_newmortal());\n" . eval "qq\a$output\a"; + } else { + $output = "\tXS_PUSH($fieldtype, $var);"; + } + push @field, $fieldname; + push @fieldindir, $fieldindir; + push @fieldoutdir, $fieldoutdir; + push @input, $input; + push @output, $output; + } + } + print Q<<"EOF"; +# [[ +# $structtype STRUCT; +EOF + print "\tchar STRUCT_state;\n" if $handle; + print "\n$structindir"; + XS_process($structinput || "\tXS_INPUT($structtype, STRUCT, ST(0));"); + print "\n\tSTRUCT_state = HGetState((Handle)STRUCT); HLock((Handle)STRUCT);\n" if ($handle); + print Q<<"EOF"; +# if (items == 1) [[ /* Get field */ +# switch (ix) [[ +EOF + for (0..$#field) { + print Q<<"EOF"; +# case $_: /* $field[$_] */ +EOF + print $fieldoutdir[$_]; + XS_process($output[$_]); + print Q<<"EOF"; +# break; +EOF + } + print Q<<"EOF"; +# ]] +# ]] else [[ /* Set field */ +# switch (ix) [[ +EOF + for (0..$#field) { + print Q<<"EOF"; +# case $_: /* $field[$_] */ +EOF + print $fieldindir[$_]; + XS_process($input[$_]); + print Q<<"EOF"; +# break; +EOF + } + print Q<<"EOF"; +# ]] +EOF + print $structoutdir; + XS_process($structoutput || "\tXS_OUTPUT($structtype, STRUCT, ST(0))\n"); + print Q<<"EOF"; +# ]] +EOF + print "\tHSetState((Handle)STRUCT, STRUCT_state);\n" if $handle; + print Q<<"EOF"; +# ]] +# XSRETURN(1); +#]] +# +EOF + for (0..$#field) { + push(@InitFileCode, Q<<"EOF"); +# cv = newXS(\"${structpack}::$field[$_]\", XS_$Full_struct_name, file); +# XSANY.any_i32 = $_ ; +EOF + } +} + PARAGRAPH: while (fetch_para()) { # Print initial preprocessor statements and blank lines @@ -1040,7 +1315,11 @@ next PARAGRAPH ; } - + if (s/^STRUCT\s*//) { + handle_struct(); + next PARAGRAPH; + } + # extract return type, function name and arguments ($ret_type) = TidyType($_); $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//; @@ -1285,7 +1564,7 @@ $processing_arg_with_types = 1; INPUT_handler() ; } - print $deferred; + XS_process($deferred); process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; @@ -1338,7 +1617,7 @@ # all OUTPUT done, so now push the return value on the stack if ($gotRETVAL && $RETVAL_code) { - print "\t$RETVAL_code\n"; + XS_process("\t$RETVAL_code\n"); } elsif ($gotRETVAL || $wantRETVAL) { my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; my $var = 'RETVAL'; @@ -1574,6 +1853,14 @@ } } +sub line_directive +{ + # work out the line number + my $line_no = $line_no[@line_no - @line -1] ; + + return "#line $line_no \"$filename\"\n" ; +} + sub Warn { # work out the line number @@ -1595,12 +1882,12 @@ } sub generate_init { - local($type, $num, $var) = @_; - local($arg) = "ST(" . ($num - 1) . ")"; + local($type, $num, $var, $arg, $immed) = @_; local($argoff) = $num - 1; local($ntype); local($tk); + $arg ||= "ST(" . ($num - 1) . ")"; $type = TidyType($type) ; blurt("Error: '$type' not in typemap"), return unless defined($type_kind{$type}); @@ -1656,17 +1943,18 @@ } else { die "panic: do not know how to handle this branch for function pointers" if $name_printed; - eval qq/print "$expr;\\n"/; + eval qq/XS_process "$expr;\\n"/; warn $@ if $@; } } sub generate_output { - local($type, $num, $var, $do_setmagic, $do_push) = @_; - local($arg) = "ST(" . ($num - ($num != 0)) . ")"; + local($type, $num, $var, $do_setmagic, $do_push, $arg, $mortalize) = @_; local($argoff) = $num - 1; local($ntype); + $mortalize ||= $var eq 'RETVAL'; + $arg ||= "ST(" . ($num - ($num != 0)) . ")"; $type = TidyType($type) ; if ($type =~ /^array\(([^,]*),(.*)\)/) { print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; @@ -1695,30 +1983,30 @@ warn $@ if $@; print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; } - elsif ($var eq 'RETVAL') { + elsif ($mortalize) { if ($expr =~ /^\t\$arg = new/) { # We expect that $arg has refcnt 1, so we need to # mortalize it. eval "print qq\a$expr\a"; warn $@ if $@; - print "\tsv_2mortal(ST($num));\n"; - print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; + print "\tsv_2mortal($arg);\n"; + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } elsif ($expr =~ /^\s*\$arg\s*=/) { # We expect that $arg has refcnt >=1, so we need # to mortalize it! eval "print qq\a$expr\a"; warn $@ if $@; - print "\tsv_2mortal(ST(0));\n"; - print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; + print "\tsv_2mortal($arg);\n"; + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } else { # Just hope that the entry would safely write it # over an already mortalized value. By # coincidence, something like $arg = &sv_undef # works too. - print "\tST(0) = sv_newmortal();\n"; - eval "print qq\a$expr\a"; + print "\t$arg = sv_newmortal();\n"; + eval "XS_process qq\a$expr\a"; warn $@ if $@; # new mortals don't have set magic } @@ -1730,8 +2018,8 @@ warn $@ if $@; print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } - elsif ($arg =~ /^ST\(\d+\)$/) { - eval "print qq\a$expr\a"; + else { + eval "XS_process qq\a$expr\a"; warn $@ if $@; print "\tSvSETMAGIC($arg);\n" if $do_setmagic; }