X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fgen_shrfls.pl;h=8e89348ae4c42459c5fd7f29e891803f420c6002;hb=13e080377416312a935982b1a5c15673e6ce0d66;hp=286695feb3848d1791e40d3a307a9f8f451393ea;hpb=e518068a77032c4207f9b00e462857e158778ea4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 286695f..8e89348 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -33,12 +33,26 @@ # library has everything old one did # (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)? # -# Author: Charles Bailey bailey@genetics.upenn.edu -# Revised: 4-Dec-1995 +# Author: Charles Bailey bailey@newman.upenn.edu require 5.000; $debug = $ENV{'GEN_SHRFLS_DEBUG'}; + +print "gen_shrfls.pl Rev. 14-Dec-1997\n" if $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 . . . @@ -50,10 +64,23 @@ $docc = ($cc_cmd !~ /^~~/); print "\$docc = $docc\n" if $debug; if ($docc) { + if (-f 'perl.h') { $dir = '[]'; } + elsif (-f '[-]perl.h') { $dir = '[-]'; } + else { die "$0: Can't find perl.h\n"; } + + # Go see if debugging is enabled in config.h + $config = $dir . "config.h"; + open CONFIG, "< $config"; + while() { + $debugging_enabled++ if /define\s+DEBUGGING/; + $use_mymalloc++ if /define\s+MYMALLOC/; + } + # put quotes back onto defines - they were removed by DCL on the way in if (($prefix,$defines,$suffix) = ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) { $defines =~ s/^\((.*)\)$/$1/; + $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/; @defines = split(/,/,$defines); $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines)) . ')' . $suffix; @@ -65,23 +92,25 @@ if ($docc) { $isvaxc = 0; $isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/ or 0; # make debug output nice - $isvaxc = (!$isgcc && $isvax && `$cc_cmd /prefix=all _nla0:` =~ /IVQUAL/) + $isvaxc = (!$isgcc && $isvax && + # Check exit status too, in case message is shut off + (`$cc_cmd /prefix=all _nla0:` =~ /IVQUAL/ || $? == 0x38240)) or 0; # again, make debug output nice print "\$isgcc: $isgcc\n" if $debug; print "\$isvaxc: $isvaxc\n" if $debug; + print "\$debugging_enabled: $debugging_enabled\n" if $debug; - if (-f 'perl.h') { $dir = '[]'; } - elsif (-f '[-]perl.h') { $dir = '[-]'; } - else { die "$0: Can't find perl.h\n"; } } else { - ($ccvers,$cpp_file) = ($cc_cmd =~ /^~~(\w+)~~(.*)/); - $isgcc = $ccvers =~ /GCC/ + ($junk,$junk,$cpp_file,$cc_cmd) = split(/~~/,$cc_cmd,4); + $isgcc = $cc_cmd =~ /case_hack/i or 0; # for nice debug output - $isvaxc = (!$isgcc && $ccvers =~ /VAXC/) + $isvaxc = (!$isgcc && $cc_cmd !~ /standard=/i) or 0; # again, for nice debug output + $debugging_enabled = $cc_cmd =~ /\bdebugging\b/i; print "\$isgcc: \\$isgcc\\\n" if $debug; print "\$isvaxc: \\$isvaxc\\\n" if $debug; + print "\$debugging_enabled: \\$debugging_enabled\\\n" if $debug; print "Not running cc, preprocesor output in \\$cpp_file\\\n" if $debug; } @@ -119,23 +148,39 @@ sub scan_enum { $line =~ s/,?\s*\n?$//; print "\tfiltered to \\$line\\\n" if $debug > 1; if ($line =~ /(\w+)$/) { - print "\tvar name is \\$1\\\n" if $debug > 1; - $vars{$1}++; + print "\tconstant name is \\$1\\\n" if $debug > 1; + $enums{$1}++; } } sub scan_var { my($line) = @_; + my($const) = $line =~ /^EXTCONST/; print "\tchecking for global variable\n" if $debug > 1; - $line =~ s/INIT\(.*\)//; + $line =~ s/\s*EXT/EXT/; + $line =~ s/INIT\s*\(.*\)//; $line =~ s/\[.*//; $line =~ s/=.*//; $line =~ s/\W*;?\s*$//; + $line =~ s/\W*\)\s*\(.*$//; # closing paren for args stripped in previous stmt print "\tfiltered to \\$line\\\n" if $debug > 1; if ($line =~ /(\w+)$/) { - print "\tvar name is \\$1\\\n" if $debug > 1; - $vars{$1}++; + print "\tvar name is \\$1\\" . ($const ? ' (const)' : '') . "\n" if $debug > 1; + if ($const) { $cvars{$1}++; } + else { $vars{$1}++; } + } + if ($isvaxc) { + my($type) = $line =~ /^\s*EXT\w*\s+(\w+)/; + print "\tchecking for use of enum (type is \"$type\")\n" if $debug > 2; + 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; + } } } @@ -143,7 +188,7 @@ 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; @@ -152,55 +197,91 @@ sub scan_func { } } +# Go add some right up front if we need 'em +if ($use_mymalloc) { + $fcns{'Perl_malloc'}++; + $fcns{'Perl_calloc'}++; + $fcns{'Perl_realloc'}++; + $fcns{'Perl_mfree'}++; +} + +$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"; } +%checkh = map { $_,1 } qw( thread bytecode byterun proto ); +$ckfunc = 0; 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($_); } - last LINE unless $_ = ; + if (/^\s*EXT/) { &scan_var($_); } + else { &scan_func($_); } + last LINE unless defined($_ = ); } print "vmsish.h>> $_" if $debug > 2; - if (/^EXT/) { &scan_var($_); } - last LINE unless $_ = ; + if (/^\s*EXT/) { &scan_var($_); } + last LINE unless defined($_ = ); } while (/^#.*opcode\.h/i .. /^#.*perl\.h/i) { print "opcode.h>> $_" if $debug > 2; if (/^OP \*\s/) { &scan_func($_); } - if (/^EXT/) { &scan_var($_); } + if (/^\s*EXT/) { &scan_var($_); } if (/^\s+OP_/) { &scan_enum($_); } - last LINE unless $_ = ; + last LINE unless defined($_ = ); } - while (/^typedef enum/ .. /^\}/) { + while (/^typedef enum/ .. /^\s*\}/) { print "global enum>> $_" if $debug > 2; &scan_enum($_); - last LINE unless $_ = ; + last LINE unless defined($_ = ); } - while (/^#.*proto\.h/i .. /^#.*perl\.h/i) { - print "proto.h>> $_" if $debug > 2; - &scan_func($_); - if (/^EXT/) { &scan_var($_); } - last LINE unless $_ = ; + # Check for transition to new header file + if (/^# \d+ "(\S+)"/) { + my $spec = $1; + # Pull name from library module or header filespec + $spec =~ /^(\w+)$/ or $spec =~ /(\w+)\.h/i; + my $name = lc $1; + $ckfunc = exists $checkh{$name} ? 1 : 0; + $scanname = $name if $ckfunc; + print "Header file transition: ckfunc = $ckfunc for $name.h\n" if $debug > 1; + } + if ($ckfunc) { + print "$scanname>> $_" if $debug > 2; + if (/\s*^EXT/) { &scan_var($_); } + else { &scan_func($_); } + } + else { + print $_ if $debug > 3 && ($debug > 5 || length($_)); + if (/^\s*EXT/) { &scan_var($_); } } - print $_ if $debug > 3; - if (/^EXT/) { &scan_var($_); } } close CPP; + +# This was: +# Kluge to determine whether we need to add EMBED prefix to +# symbols read from local list. vmsreaddirversions() is a VMS- +# specific function whose Perl_ prefix is added in vmsish.h +# if EMBED is #defined. +# +# but now we always define EMBED, so it's not a big deal any more while () { next if /^#/; s/\s+#.*\n//; next if /^\s*$/; ($key,$array) = split('=',$_); + if ($array eq 'vars') { + $key = "PL_$key"; + } else { + $key = "Perl_$key"; + } print "Adding $key to \%$array list\n" if $debug > 1; ${$array}{$key}++; } +if ($debugging_enabled and $isgcc) { $vars{'colors'}++ } foreach (split /\s+/, $extnames) { my($pkgname) = $_; $pkgname =~ s/::/__/g; @@ -208,6 +289,30 @@ foreach (split /\s+/, $extnames) { 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{"${embed}Error"}++; +} + # Eventually, we'll check against existing copies here, so we can add new # symbols to an existing options file in an upwardly-compatible manner. @@ -219,7 +324,11 @@ if ($isvax) { or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n"; print MAR "\t.title perlshr_gbl$marord\n"; } -foreach $var (sort keys %vars) { +unless ($isgcc) { + print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n"; + print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n"; +} +foreach $var (sort (keys %vars,keys %cvars)) { if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; } else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; } # This hack brought to you by the lack of a globaldef in gcc. @@ -254,9 +363,19 @@ if ($isvax) { 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"; +if ($isvaxc) { + print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; +} +elsif ($isgcc) { + foreach $var (sort keys %cvars) { + print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n"; + } + foreach $var (sort keys %vars) { + print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; + } +} +else { + print OPTATTR "! No additional linker directives are needed when using DECC\n"; } close OPTATTR; @@ -272,7 +391,7 @@ if ($isvax) { print DRVR "\$ Set Verify\n"; print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n"; do { - $incstr .= ",perlshr_gbl$marord"; + push(@symfiles,"perlshr_gbl$marord"); print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n"; print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n"; } while (--$marord); @@ -287,11 +406,21 @@ if ($isvax) { close DRVR; } +# Initial hack to permit building of compatible shareable images for a +# given version of Perl. +if ($ENV{PERLSHR_USE_GSMATCH}) { + my $major = int($] * 1000) & 0xFF; # range 0..255 + my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF; # range 0..255 + print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n"; + print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,', + map(",$_$objsuffix",@symfiles), "\n"; +} +elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); } # Include object modules and RTLs in options file # 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; @@ -302,29 +431,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 regkind=vars # declared in regcomp.h simple=vars # declared in regcomp.h varies=vars # declared in regcomp.h -watchaddr=vars # declared in run.c -watchok=vars # declared in run.c -yychar=vars # generated by byacc in perly.c -yycheck=vars # generated by byacc in perly.c -yydebug=vars # generated by byacc in perly.c -yydefred=vars # generated by byacc in perly.c -yydgoto=vars # generated by byacc in perly.c -yyerrflag=vars # generated by byacc in perly.c -yygindex=vars # generated by byacc in perly.c -yylen=vars # generated by byacc in perly.c -yylhs=vars # generated by byacc in perly.c -yylval=vars # generated by byacc in perly.c -yyname=vars # generated by byacc in perly.c -yynerrs=vars # generated by byacc in perly.c -yyrindex=vars # generated by byacc in perly.c -yyrule=vars # generated by byacc in perly.c -yysindex=vars # generated by byacc in perly.c -yytable=vars # generated by byacc in perly.c -yyval=vars # generated by byacc in perly.c