X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b6837a3b27252f74ff8399514c00fa18a38dd3a6..dad790286e318c5c7f4b6ccd52b4fd512c87c763:/vms/gen_shrfls.pl diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 35cab2f..98afe30 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -39,7 +39,7 @@ require 5.000; $debug = $ENV{'GEN_SHRFLS_DEBUG'}; -print "gen_shrfls.pl Rev. 14-Dec-1997\n" if $debug; +print "gen_shrfls.pl Rev. 18-Dec-2003\n" if $debug; if ($ARGV[0] eq '-f') { open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n"; @@ -56,9 +56,14 @@ if ($ARGV[0] eq '-f') { $cc_cmd = shift @ARGV; # Someday, we'll have $GetSyI built into perl . . . -$isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024; +$isvax = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .LE. 1024 .AND. F\$GetSyI(\"HW_MODEL\") .GT. 0\)`; +chomp $isvax; print "\$isvax: \\$isvax\\\n" if $debug; +$isi64 = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .GE. 4096)`; +chomp $isi64; +print "\$isi64: \\$isi64\\\n" if $debug; + print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug; $docc = ($cc_cmd !~ /^~~/); print "\$docc = $docc\n" if $debug; @@ -68,16 +73,22 @@ if ($docc) { 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"; + $use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0; + $hide_mymalloc = $isgcc = $use_perlio = 0; + + # Go see what is enabled in config.sh + $config = $dir . "config.sh"; open CONFIG, "< $config"; while() { - $debugging_enabled++ if /define\s+DEBUGGING/; - $use_mymalloc++ if /define\s+MYMALLOC/; - $hide_mymalloc++ if /define\s+EMBEDMYMALLOC/; - $use_threads++ if /define\s+USE_THREADS/; - $care_about_case++ if /define\s+VMS_WE_ARE_CASE_SENSITIVE/; + $use_threads++ if /usethreads='(define|yes|true|t|y|1)'/i; + $use_mymalloc++ if /usemymalloc='(define|yes|true|t|y|1)'/i; + $care_about_case++ if /d_vms_case_sensitive_symbols='(define|yes|true|t|y|1)'/i; + $debugging_enabled++ if /usedebugging_perl='(define|yes|true|t|y|1)'/i; + $hide_mymalloc++ if /embedmymalloc='(define|yes|true|t|y|1)'/i; + $isgcc++ if /gccversion='[^']/; + $use_perlio++ if /useperlio='(define|yes|true|t|y|1)'/i; } + close CONFIG; # put quotes back onto defines - they were removed by DCL on the way in if (($prefix,$defines,$suffix) = @@ -92,15 +103,8 @@ if ($docc) { # 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 && - # 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; } @@ -108,11 +112,8 @@ 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 $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; } @@ -129,33 +130,6 @@ print "\$extnames: \\$extnames\\\n" if $debug; $rtlopt = shift @ARGV; print "\$rtlopt: \\$rtlopt\\\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) = @_; my($const) = $line =~ /^EXTCONST/; @@ -173,30 +147,22 @@ sub scan_var { 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; - } - } } sub scan_func { - my($line) = @_; - - print "\tchecking for global routine\n" if $debug > 1; - 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; + my @lines = split /;/, @_[0]; + + for my $line (@lines) { + print "\tchecking for global routine\n" if $debug > 1; + $line =~ s/\b(IV|Off_t|Size_t|SSize_t|void)\b//i; + if ( $line =~ /(\w+)\s*\(/ ) { + print "\troutine name is \\$1\\\n" if $debug > 1; + if ($1 eq 'main' || $1 eq 'perl_init_ext' || $1 eq '__attribute__format__' + || $1 eq 'sizeof' || (($1 eq 'Perl_stashpv_hvname_match') && ! $use_threads)) { + print "\tskipped\n" if $debug > 1; + } + else { $fcns{$1}++ } } - else { $fcns{$1}++ } } } @@ -208,15 +174,21 @@ if ($use_mymalloc) { $fcns{'Perl_mfree'}++; } +if ($use_perlio) { + $preprocess_list = "${dir}perl.h+${dir}perlapi.h,${dir}perliol.h"; +} else { + $preprocess_list = "${dir}perl.h+${dir}perlapi.h"; +} + $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"; + open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output $preprocess_list|") + or die "$0: Can't preprocess $preprocess_list: $!\n"; } else { open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n"; } -%checkh = map { $_,1 } qw( thread bytecode byterun proto ); +%checkh = map { $_,1 } qw( thread bytecode byterun proto perlapi perlio perlvars intrpvar thrdvar ); $ckfunc = 0; LINE: while () { while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) { @@ -234,12 +206,6 @@ LINE: while () { print "opcode.h>> $_" if $debug > 2; if (/^OP \*\s/) { &scan_func($_); } if (/^\s*EXT/) { &scan_var($_); } - if (/^\s+OP_/) { &scan_enum($_); } - last LINE unless defined($_ = ); - } - while (/^typedef enum/ .. /^\s*\}/) { - print "global enum>> $_" if $debug > 2; - &scan_enum($_); last LINE unless defined($_ = ); } # Check for transition to new header file @@ -248,13 +214,14 @@ LINE: while () { # Pull name from library module or header filespec $spec =~ /^(\w+)$/ or $spec =~ /(\w+)\.h/i; my $name = lc $1; + $name = 'perlio' if $name eq 'perliol'; $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($_); } + if (/^\s*EXT/) { &scan_var($_); } else { &scan_func($_); } } else { @@ -282,22 +249,6 @@ 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"; - } -} - # Eventually, we'll check against existing copies here, so we can add new # symbols to an existing options file in an upwardly-compatible manner. @@ -311,8 +262,14 @@ if ($isvax) { } 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"; + if ($isi64) { + print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,NOEXE,RD,NOWRT,SHR\n"; + print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,NOEXE,RD,WRT,NOSHR\n"; + } + else { + 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"; + } } print OPTBLD "case_sensitive=yes\n" if $care_about_case; foreach $var (sort (keys %vars,keys %cvars)) { @@ -350,10 +307,7 @@ if ($isvax) { open(OPTATTR,">${dir}perlshr_attr.opt") or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n"; -if ($isvaxc) { - print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n"; -} -elsif ($isgcc) { +if ($isgcc) { foreach $var (sort keys %cvars) { print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n"; } @@ -401,6 +355,7 @@ if ($ENV{PERLSHR_USE_GSMATCH}) { # number in the top four bits and use the bottom four for build options # that'll cause incompatibilities ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/; + $ver += 0; $sub += 0; $gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for # dev, but be more forgiving # for releases