X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fgen_shrfls.pl;h=6972c67edff4f4580675b7b69cb6818b69c4d4c5;hb=7aa5c81fb93ce6741dd5751e93d46dc87d2c1c61;hp=043faccb0981905d5cdef2e99a5d5fd94d1a6d86;hpb=748a93069b3d16374a9859d1456065dd3ae11394;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 043facc..6972c67 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -34,14 +34,32 @@ # (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)? # # Author: Charles Bailey bailey@genetics.upenn.edu -# Revised: 01-Mar-1995 +# Revised: 20-Feb-1996 require 5.000; $debug = $ENV{'GEN_SHRFLS_DEBUG'}; + +if ($ARGV[0] eq '-f') { + open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n"; + print "Input taken from file $ARGV[1]\n" if $debug; + @ARGV = (); + while () { + chomp; + push(@ARGV,split(/\|/,$_)); + } + close INP; + print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1; +} + $cc_cmd = shift @ARGV; + +# Someday, we'll have $GetSyI built into perl . . . +$isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024; +print "\$isvax: \\$isvax\\\n" if $debug; + print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug; -$docc = ($cc_cmd !~ /~~NOCC~~/); +$docc = ($cc_cmd !~ /^~~/); print "\$docc = $docc\n" if $debug; if ($docc) { @@ -55,11 +73,30 @@ if ($docc) { } print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug; + # check for gcc - if present, we'll need to use MACRO hack to + # define global symbols for shared variables + $isvaxc = 0; + $isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/ + or 0; # make debug output nice + $isvaxc = (!$isgcc && $isvax && `$cc_cmd /prefix=all _nla0:` =~ /IVQUAL/) + or 0; # again, make debug output nice + print "\$isgcc: $isgcc\n" if $debug; + print "\$isvaxc: $isvaxc\n" if $debug; + if (-f 'perl.h') { $dir = '[]'; } elsif (-f '[-]perl.h') { $dir = '[-]'; } else { die "$0: Can't find perl.h\n"; } } -else { ($cpp_file) = ($cc_cmd =~ /~~NOCC~~(.*)/) } +else { + ($junk,$junk,$cpp_file,$cc_cmd) = split(/~~/,$cc_cmd,4); + $isgcc = $cc_cmd =~ /case_hack/i + or 0; # for nice debug output + $isvaxc = (!$isgcc && $cc_cmd !~ /standard=/i) + or 0; # again, for nice debug output + print "\$isgcc: \\$isgcc\\\n" if $debug; + print "\$isvaxc: \\$isvaxc\\\n" if $debug; + print "Not running cc, preprocesor output in \\$cpp_file\\\n" if $debug; +} $objsuffix = shift @ARGV; print "\$objsuffix: \\$objsuffix\\\n" if $debug; @@ -73,9 +110,32 @@ print "\$extnames: \\$extnames\\\n" if $debug; $rtlopt = shift @ARGV; print "\$rtlopt: \\$rtlopt\\\n" if $debug; -# Someday, we'll have $GetSyI built into perl . . . -$isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024; -print "\$isvax: \\$isvax\\\n" if $debug; +# This part gets tricky. VAXC creates global symbols for each of the +# constants in an enum if that enum is ever used as the data type of a +# global[dr]ef. We have to detect enums which are used in this way, so we +# can set up the constants as universal symbols, since anything which +# #includes perl.h will want to resolve these global symbols. +# We're using a weak test here - we basically know that the only enums +# we need to handle now are the big one in opcode.h, and the +# "typedef enum { ... } expectation" in perl.h, so we hard code +# appropriate tests below. Since we can't know in general whether a given +# enum will be used elsewhere in a globaldef, it's hard to decide a +# priori whether its constants need to be treated as global symbols. +sub scan_enum { + my($line) = @_; + + return unless $isvaxc; + + return unless /^\s+(OP|X)/; # we only want opcode and expectation enums + print "\tchecking for enum constant\n" if $debug > 1; + $line =~ s#/\*.+##; + $line =~ s/,?\s*\n?$//; + print "\tfiltered to \\$line\\\n" if $debug > 1; + if ($line =~ /(\w+)$/) { + print "\tconstant name is \\$1\\\n" if $debug > 1; + $enums{$1}++; + } +} sub scan_var { my($line) = @_; @@ -96,28 +156,29 @@ sub scan_func { my($line) = @_; print "\tchecking for global routine\n" if $debug > 1; - if ( /(\w+)\s+\(/ ) { + if ( $line =~ /(\w+)\s+\(/ ) { print "\troutine name is \\$1\\\n" if $debug > 1; if ($1 eq 'main' || $1 eq 'perl_init_ext') { print "\tskipped\n" if $debug > 1; } - else { $funcs{$1}++ } + else { $fcns{$1}++ } } } +$used_expectation_enum = $used_opcode_enum = 0; # avoid warnings if ($docc) { open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output ${dir}perl.h|") or die "$0: Can't preprocess ${dir}perl.h: $!\n"; } else { - open(CPP,"$cpp_file") or die "$0: Can't read $cpp_file: $!\n"; + open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n"; } LINE: while () { while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) { while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) { print "vms_proto>> $_" if $debug > 2; - &scan_func($_); - if (/^EXT/) { &scan_var($_); } + if (/^EXT/) { &scan_var($_); } + else { &scan_func($_); } last LINE unless $_ = ; } print "vmsish.h>> $_" if $debug > 2; @@ -128,30 +189,81 @@ LINE: while () { print "opcode.h>> $_" if $debug > 2; if (/^OP \*\s/) { &scan_func($_); } if (/^EXT/) { &scan_var($_); } + if (/^\s+OP_/) { &scan_enum($_); } + last LINE unless $_ = ; + } + while (/^typedef enum/ .. /^\}/) { + print "global enum>> $_" if $debug > 2; + &scan_enum($_); last LINE unless $_ = ; } while (/^#.*proto\.h/i .. /^#.*perl\.h/i) { print "proto.h>> $_" if $debug > 2; - &scan_func($_); - if (/^EXT/) { &scan_var($_); } + if (/^EXT/) { &scan_var($_); } + else { &scan_func($_); } last LINE unless $_ = ; } print $_ if $debug > 3; - if (/^EXT/) { &scan_var($_); } + if (($type) = /^EXT\s+(\w+)/) { + if ($isvaxc) { + if ($type eq 'expectation') { + $used_expectation_enum++; + print "\tsaw global use of enum \"expectation\"\n" if $debug > 1; + } + if ($type eq 'opcode') { + $used_opcode_enum++; + print "\tsaw global use of enum \"opcode\"\n" if $debug > 1; + } + } + &scan_var($_); + } } close CPP; + + +# Kluge to determine whether we need to add EMBED prefix to +# symbols read from local list. init_os_extras() is a VMS- +# specific function whose Perl_ prefix is added in vmsish.h +# if EMBED is #defined. +$embed = exists($fcns{'Perl_init_os_extras'}) ? 'Perl_' : ''; while () { next if /^#/; s/\s+#.*\n//; + next if /^\s*$/; ($key,$array) = split('=',$_); + $key = "$embed$key"; print "Adding $key to \%$array list\n" if $debug > 1; ${$array}{$key}++; } foreach (split /\s+/, $extnames) { my($pkgname) = $_; $pkgname =~ s/::/__/g; - $funcs{"boot_$pkgname"}++; - print "Adding boot_$pkgname to \%funcs (for extension $_)\n" if $debug; + $fcns{"boot_$pkgname"}++; + print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug; +} + +# If we're using VAXC, fold in the names of the constants for enums +# we've seen as the type of global vars. +if ($isvaxc) { + foreach (keys %enums) { + if (/^OP/) { + $vars{$_}++ if $used_opcode_enum; + next; + } + if (/^X/) { + $vars{$_}++ if $used_expectation_enum; + next; + } + print STDERR "Unrecognized enum constant \"$_\" ignored\n"; + } +} +elsif ($isgcc) { + # gcc creates this as a SHR,WRT psect in globals.c, but we + # don't see it in the perl.h scan, since it's only declared + # if DOINIT is #defined. Bleah. It's cheaper to just add + # it by hand than to add /Define=DOINIT to the preprocessing + # run and wade through all the extra junk. + $vars{'Error'}++; } # Eventually, we'll check against existing copies here, so we can add new @@ -160,19 +272,16 @@ foreach (split /\s+/, $extnames) { $marord++; open(OPTBLD,">${dir}${dbgprefix}perlshr_bld.opt") or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n"; -open(OPTATTR,">${dir}perlshr_attr.opt") - or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; if ($isvax) { open(MAR,">${dir}perlshr_gbl${marord}.mar") or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; print MAR "\t.title perlshr_gbl$marord\n"; } -print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; foreach $var (sort keys %vars) { - print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; } else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; } - if ($isvax) { + # This hack brought to you by the lack of a globaldef in gcc. + if ($isgcc) { if ($count++ > 200) { # max 254 psects/file print MAR "\t.end\n"; close MAR; @@ -182,27 +291,35 @@ foreach $var (sort keys %vars) { print MAR "\t.title perlshr_gbl$marord\n"; $count = 0; } - # This hack brought to you by the lack of a globaldef in gcc. print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n"; print MAR "\t${var}:: .blkl 1\n"; } } print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax); -foreach $func (sort keys %funcs) { +foreach $func (sort keys %fcns) { if ($isvax) { print MAR "\t.transfer $func\n"; print MAR "\t.mask $func\n"; - print MAR "\tjmp L\^${func}+2\n"; + print MAR "\tjmp G\^${func}+2\n"; } else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; } } +if ($isvax) { + print MAR "\t.end\n"; + close MAR; +} +open(OPTATTR,">${dir}perlshr_attr.opt") + or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; +print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; +foreach $var (sort keys %vars) { + print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; +} close OPTATTR; + $incstr = 'perl,globals'; if ($isvax) { - print MAR "\t.end\n"; - close MAR; $drvrname = "Compile_shrmars.tmp_".time; open (DRVR,">$drvrname") or die "$0: Can't write to $drvrname: $!\n"; print DRVR "\$ Set NoOn\n"; @@ -232,7 +349,7 @@ if ($isvax) { # Linker wants /Include and /Library on different lines print OPTBLD "$libperl/Include=($incstr)\n"; print OPTBLD "$libperl/Library\n"; -open(RTLOPT,$rtlopt) or die "$0: Can't read $rtlopt: $!\n"; +open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n"; while () { print OPTBLD; } close RTLOPT; close OPTBLD; @@ -243,7 +360,6 @@ exec "\$ \@$drvrname" if $isvax; __END__ # Oddball cases, so we can keep the perl.h scan above simple -error=vars # declared in perl.h only when DOINIT defined by INTERN.h rcsid=vars # declared in perl.c regarglen=vars # declared in regcomp.h regdummy=vars # declared in regcomp.h