X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fgen_shrfls.pl;h=7ba40fd5afc5ad8b67ba4153fb05640cb7b4df09;hb=fe578d7fdd84ab0398dc36da7f84e59e1f2bb290;hp=48499d4a4912d2a57a29acc096143815bd5bae05;hpb=0e06870bf080a38cda51c06c6612359afc2334e1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 48499d4..7ba40fd 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; @@ -69,18 +74,19 @@ if ($docc) { else { die "$0: Can't find perl.h\n"; } $use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0; - $hide_mymalloc = $isgcc = 0; + $hide_mymalloc = $isgcc = $use_perlio = 0; # Go see what is enabled in config.sh $config = $dir . "config.sh"; open CONFIG, "< $config"; while() { - $use_threads++ if /usethreads='define'/; - $use_mymalloc++ if /usemymalloc='Y'/; - $care_about_case++ if /d_vms_case_sensitive_symbols='define'/; - $debugging_enabled++ if /usedebugging_perl='Y'/; - $hide_mymalloc++ if /embedmymalloc='Y'/; + $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; @@ -144,15 +150,19 @@ sub scan_var { } 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|int)\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}++ } } } @@ -166,30 +176,44 @@ if ($use_mymalloc) { $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"; + 1 while unlink 'perlincludes.tmp'; + END { 1 while unlink 'perlincludes.tmp'; } # and clean up after + + open(PERLINC, '>perlincludes.tmp') or die "Couldn't open 'perlincludes.tmp' $!"; + + print PERLINC qq/#include "${dir}perl.h"\n/; + print PERLINC qq/#include "${dir}perlapi.h"\n/; + print PERLINC qq/#include "${dir}perliol.h"\n/ if $use_perlio; + print PERLINC qq/#include "${dir}regcomp.h"\n/; + + close PERLINC; + $preprocess_list = 'perlincludes.tmp'; + + 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 perlio ); +%checkh = map { $_,1 } qw( bytecode byterun intrpvar perlapi perlio perliol + perlvars proto regcomp thrdvar thread ); $ckfunc = 0; LINE: while () { while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) { while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) { print "vms_proto>> $_" if $debug > 2; - if (/^\s*EXT/) { &scan_var($_); } + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } else { &scan_func($_); } last LINE unless defined($_ = ); } print "vmsish.h>> $_" if $debug > 2; - if (/^\s*EXT/) { &scan_var($_); } + if (/^\s*EXT(CONST|\s+)/) { &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 (/^\s*EXT/) { &scan_var($_); } + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } last LINE unless defined($_ = ); } # Check for transition to new header file @@ -204,12 +228,12 @@ LINE: while () { } if ($ckfunc) { print "$scanname>> $_" if $debug > 2; - if (/\s*^EXT/) { &scan_var($_); } + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } else { &scan_func($_); } } else { print $_ if $debug > 3 && ($debug > 5 || length($_)); - if (/^\s*EXT/) { &scan_var($_); } + if (/^\s*EXT(CONST|\s+)/) { &scan_var($_); } } } close CPP; @@ -245,8 +269,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)) { @@ -367,6 +397,5 @@ exec "\$ \@$drvrname" if $isvax; __END__ # Oddball cases, so we can keep the perl.h scan above simple -regkind=vars # declared in regcomp.h -simple=vars # declared in regcomp.h -varies=vars # declared in regcomp.h +#Foo=vars # uncommented becomes PL_Foo +#Bar=funcs # uncommented becomes Perl_Bar