[perl5.git] / vms / gen_shrfls.pl

# Create global symbol declarations, transfer vector, and
# linker options files for PerlShr.
#
# Processes the output of makedef.pl.
#
# Input:
#    $cc_cmd - compiler command
#    $objsuffix - file type (including '.') used for object files.
#    $libperl - Perl object library.
#    $extnames - package names for static extensions (used to generate
#        linker options file entries for boot functions)
#    $rtlopt - name of options file specifying RTLs to which PerlShr.Exe
#        must be linked
#
# Output:
#    PerlShr_Attr.Opt - linker options file which specifies that global vars
#        be placed in NOSHR,WRT psects.  Use when linking any object files
#        against PerlShr.Exe, since cc places global vars in SHR,WRT psects
#        by default.
#    PerlShr_Bld.Opt - declares universal symbols for PerlShr.Exe
#    Perlshr_Gbl*.Mar, Perlshr_Gbl*.Obj (VAX  only) - declares global symbols
#        for global vars (done here because gcc can't globaldef) and creates
#        transfer vectors for routines on a VAX.
#    PerlShr_Gbl.Opt (VAX only) - list of PerlShr_Gbl*.Obj, used for input
#        to the linker when building PerlShr.Exe.
#
# To do:
#   - figure out a good way to collect global vars in one psect, given that
#     we can't use globaldef because of gcc.
#   - then, check for existing files and preserve symbol and transfer vector
#     order for upward compatibility
#   - then, add GSMATCH to options file - but how do we insure that new
#     library has everything old one did
#     (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)?
#
# Author: Charles Bailey  bailey@newman.upenn.edu

use strict;
require 5.000;

my $debug = $ENV{'GEN_SHRFLS_DEBUG'};

print "gen_shrfls.pl Rev. 8-Jul-2011\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 (<INP>) {
    chomp;
    push(@ARGV,split(/\|/,$_));
  }
  close INP;
  print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1;
}

my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor

# Someday, we'll have $GetSyI built into perl . . .
my $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;

my $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;
my $docc = ($cc_cmd !~ /^~~/);
print "\$docc = $docc\n" if $debug;

my ( $use_threads, $use_mymalloc, $care_about_case, $shorten_symbols,
     $debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir )
   = ( 0, 0, 0, 0, 0, 0, 0, 0 );

if (-f 'perl.h') { $dir = '[]'; }
elsif (-f '[-]perl.h') { $dir = '[-]'; }
else { die "$0: Can't find perl.h\n"; }

# Go see what is enabled in config.sh
my $config = $dir . "config.sh";
open CONFIG, '<', $config;
while(<CONFIG>) {
    $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;
    $shorten_symbols++ if /d_vms_shorten_long_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 (my ($prefix,$defines,$suffix) =
         ($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) {
  $defines =~ s/^\((.*)\)$/$1/;
  $debugging_enabled ||= $defines =~ /\bDEBUGGING\b/;
  my @defines = split(/,/,$defines);
  $cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines)) 
              . ')' . $suffix;
}
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

print "\$isgcc: $isgcc\n" if $debug;
print "\$debugging_enabled: $debugging_enabled\n" if $debug;

my $objsuffix = shift @ARGV;
print "\$objsuffix: \\$objsuffix\\\n" if $debug;
my $dbgprefix = shift @ARGV;
print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
my $olbsuffix = shift @ARGV;
print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
my $libperl = "${dbgprefix}libperl$olbsuffix";
my $extnames = shift @ARGV;
print "\$extnames: \\$extnames\\\n" if $debug;
my $rtlopt = shift @ARGV;
print "\$rtlopt: \\$rtlopt\\\n" if $debug;

my (%vars, %fcns);

open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";

while (my $line = <$makedefs>) {
  chomp $line;
  $line = shorten_symbol($line, $care_about_case) if $shorten_symbols;
  # makedef.pl loses distinction between vars and funcs, so
  # use the start of the name to guess and add specific
  # exceptions when we know about them.
  if ($line =~ m/^PL_/
      || $line eq 'PerlIO_perlio'
      || $line eq 'PerlIO_pending') {
    $vars{$line}++;
  }
  else {
    $fcns{$line}++;
  }
}

if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
foreach (split /\s+/, $extnames) {
  my($pkgname) = $_;
  $pkgname =~ s/::/__/g;
  $fcns{"boot_$pkgname"}++;
  print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
}

# Eventually, we'll check against existing copies here, so we can add new
# symbols to an existing options file in an upwardly-compatible manner.

my $marord = 1;
open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
  or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.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";
}

unless ($isgcc) {
  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 "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
}
print OPTBLD "case_sensitive=yes\n" if $care_about_case;
my $count = 0;
foreach my $var (sort (keys %vars)) {
  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.
  if ($isgcc) {
    if ($count++ > 200) {  # max 254 psects/file
      print MAR "\t.end\n";
      close MAR;
      $marord++;
      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";
      $count = 0;
    }
    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 my $func (sort keys %fcns) {
  if ($isvax) {
    print MAR "\t.transfer $func\n";
    print MAR "\t.mask $func\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";
if ($isgcc) {
# TODO -- lost ability to distinguish constant vars from others when
# we switched to using makedef.pl for input.
#  foreach my $var (sort keys %cvars) {
#    print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
#  }
  foreach my $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;

my $incstr = 'PERL,GLOBALS';
my (@symfiles, $drvrname);
if ($isvax) {
  $drvrname = "Compile_shrmars.tmp_".time;
  open (DRVR,'>', $drvrname) or die "$0: Can't write to $drvrname: $!\n";
  print DRVR "\$ Set NoOn\n";  
  print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n";
  print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n";
  print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n";
  print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n";
  print DRVR "\$ Set Verify\n";
  print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
  do {
    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); 
  # We had to have a working miniperl to run this program; it's probably the
  # one we just built.  It depended on LibPerl, which will be changed when
  # the PerlShr_Gbl* modules get inserted, so miniperl will be out of date,
  # and so, therefore, will all of its dependents . . .
  # We touch LibPerl here so it'll be back 'in date', and we won't rebuild
  # miniperl etc., and therefore LibPerl, the next time we invoke MM[KS].
  print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n";
  print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n";
  close DRVR;
}

# Initial hack to permit building of compatible shareable images for a
# given version of Perl.
if ($ENV{PERLSHR_USE_GSMATCH}) {
  if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
    # Build up a major ID. Since it can only be 8 bits, we encode the version
    # number in the top four bits and use the bottom four for build options
    # that'll cause incompatibilities
    my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/;
    $ver += 0; $sub += 0;
    my $gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for
						  # dev, but be more forgiving
						  # for releases

    $ver *=16;
    $ver += 8 if $debugging_enabled;	# If DEBUGGING is set
    $ver += 4 if $use_threads;		# if we're threaded
    $ver += 2 if $use_mymalloc;		# if we're using perl's malloc
    print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
  }
  else {
    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 options file $rtlopt: $!\n";
while (<RTLOPT>) { print OPTBLD; }
close RTLOPT;
close OPTBLD;

exec "\$ \@$drvrname" if $isvax;


# Symbol shortening Copyright (c) 2012 Craig A. Berry
#
# Released under the same terms as Perl itself.
#
# This code provides shortening of long symbols (> 31 characters) using the
# same mechanism as the OpenVMS C compiler.  The basic procedure is to compute
# an AUTODIN II checksum of the entire symbol, encode the checksum in base32,
# and glue together a shortened symbol from the first 23 characters of the
# original symbol plus the encoded checksum appended.  The output format is
# the same used in the name mangler database, stored by default in
# [.CXX_REPOSITORY]CXX$DEMANGLER_DB.

sub crc32 {
    use constant autodin_ii_table => [
        0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f,
        0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988,
        0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2,
        0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7,
        0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
        0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172,
        0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c,
        0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59,
        0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423,
        0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
        0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106,
        0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433,
        0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d,
        0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e,
        0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
        0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65,
        0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7,
        0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0,
        0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa,
        0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
        0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81,
        0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a,
        0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84,
        0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1,
        0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
        0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc,
        0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e,
        0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b,
        0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55,
        0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
        0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28,
        0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d,
        0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f,
        0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38,
        0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
        0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777,
        0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69,
        0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2,
        0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc,
        0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
        0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693,
        0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94,
        0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d,
    ];

    my $input_string = shift;
    my $crc = 0xFFFFFFFF;

    for my $byte (unpack 'C*', $input_string) {
        $crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
    }
    return ~$crc;
}

sub base32 {
    my $input = shift;
    my $output = '';
    use constant base32hex_table => [
        '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
        'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
        'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
        'u', 'v'
    ];

    # Grab lowest 5 bits and look up conversion in table.  Lather, rinse,
    # repeat for a total of 7, 5-bit chunks to accommodate 32 bits of input.

    for (0..6) {
        $output  = base32hex_table->[$input & 0x1f] . $output;
        $input >>= 5;     # position to look at next 5
    }
    $output .= '$';       #  It's DEC, so use '$' not '=' to pad.

    return $output;
}

sub shorten_symbol {
    my $input_symbol = shift;
    my $as_is_flag = shift;
    my $symbol = $input_symbol;

    return $symbol unless length($input_symbol) > 31;

    $symbol = uc($symbol) unless $as_is_flag;
    my $crc = crc32($symbol);
    $crc = ~$crc;  # Compiler uses non-inverted form.
    my $b32 = base32($crc);
    $b32 = uc($b32) unless $as_is_flag;

    return substr($symbol, 0, 23) . $b32;
}

__END__
Commit	Line	Data
a0d0e21e LW	1	# Create global symbol declarations, transfer vector, and
	2	# linker options files for PerlShr.
	3	#
93ea32b8 CB	4	# Processes the output of makedef.pl.
93ea32b8 CB	5	#
a0d0e21e	6	# Input:
93ea32b8	7	# $cc_cmd - compiler command
a0d0e21e	8	# $objsuffix - file type (including '.') used for object files.
748a9306 LW	9	# $libperl - Perl object library.
	10	# $extnames - package names for static extensions (used to generate
	11	# linker options file entries for boot functions)
	12	# $rtlopt - name of options file specifying RTLs to which PerlShr.Exe
	13	# must be linked
a0d0e21e LW	14	#
a0d0e21e LW	15	# Output:
94ae10c0	16	# PerlShr_Attr.Opt - linker options file which specifies that global vars
a0d0e21e LW	17	# be placed in NOSHR,WRT psects. Use when linking any object files
	18	# against PerlShr.Exe, since cc places global vars in SHR,WRT psects
	19	# by default.
748a9306	20	# PerlShr_Bld.Opt - declares universal symbols for PerlShr.Exe
a0d0e21e LW	21	# Perlshr_Gbl.Mar, Perlshr_Gbl.Obj (VAX only) - declares global symbols
	22	# for global vars (done here because gcc can't globaldef) and creates
	23	# transfer vectors for routines on a VAX.
	24	# PerlShr_Gbl.Opt (VAX only) - list of PerlShr_Gbl*.Obj, used for input
	25	# to the linker when building PerlShr.Exe.
	26	#
	27	# To do:
	28	# - figure out a good way to collect global vars in one psect, given that
	29	# we can't use globaldef because of gcc.
	30	# - then, check for existing files and preserve symbol and transfer vector
	31	# order for upward compatibility
	32	# - then, add GSMATCH to options file - but how do we insure that new
	33	# library has everything old one did
	34	# (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)?
	35	#
bd3fa61c	36	# Author: Charles Bailey bailey@newman.upenn.edu
a0d0e21e	37
466adc1d	38	use strict;
a0d0e21e LW	39	require 5.000;
a0d0e21e LW	40
466adc1d	41	my $debug = $ENV{'GEN_SHRFLS_DEBUG'};
a5f75d66	42
93ea32b8	43	print "gen_shrfls.pl Rev. 8-Jul-2011\n" if $debug;
71be2cbc	44
a5f75d66 AD	45	if ($ARGV[0] eq '-f') {
	46	open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
	47	print "Input taken from file $ARGV[1]\n" if $debug;
	48	@ARGV = ();
	49	while (<INP>) {
	50	chomp;
	51	push(@ARGV,split(/\\|/,$_));
	52	}
	53	close INP;
	54	print "Read input data \| ",join(' \| ',@ARGV)," \|\n" if $debug > 1;
	55	}
	56
93ea32b8	57	my $cc_cmd = shift @ARGV; # no longer used to run the preprocessor
4633a7c4 LW	58
4633a7c4 LW	59	# Someday, we'll have $GetSyI built into perl . . .
466adc1d	60	my $isvax = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .LE. 1024 .AND. F\$GetSyI(\"HW_MODEL\") .GT. 0\)`;
a50752f9	61	chomp $isvax;
4633a7c4 LW	62	print "\$isvax: \\$isvax\\\n" if $debug;
4633a7c4 LW	63
466adc1d	64	my $isi64 = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .GE. 4096)`;
e8e09534 PP	65	chomp $isi64;
	66	print "\$isi64: \\$isi64\\\n" if $debug;
	67
a0d0e21e	68	print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
466adc1d	69	my $docc = ($cc_cmd !~ /^~~/);
a0d0e21e LW	70	print "\$docc = $docc\n" if $debug;
a0d0e21e LW	71
0729becf CB	72	my ( $use_threads, $use_mymalloc, $care_about_case, $shorten_symbols,
0729becf CB	73	$debugging_enabled, $hide_mymalloc, $isgcc, $use_perlio, $dir )
466adc1d CB	74	= ( 0, 0, 0, 0, 0, 0, 0, 0 );
466adc1d CB	75
93ea32b8 CB	76	if (-f 'perl.h') { $dir = '[]'; }
	77	elsif (-f '[-]perl.h') { $dir = '[-]'; }
	78	else { die "$0: Can't find perl.h\n"; }
429a5e67	79
93ea32b8 CB	80	# Go see what is enabled in config.sh
	81	my $config = $dir . "config.sh";
	82	open CONFIG, '<', $config;
	83	while(<CONFIG>) {
ac25e0e7	84	$use_threads++ if /usethreads='(define\|yes\|true\|t\|y\|1)'/i;
cbe4ad0c	85	$use_mymalloc++ if /usemymalloc='(define\|yes\|true\|t\|y\|1)'/i;
ac25e0e7	86	$care_about_case++ if /d_vms_case_sensitive_symbols='(define\|yes\|true\|t\|y\|1)'/i;
0729becf	87	$shorten_symbols++ if /d_vms_shorten_long_symbols='(define\|yes\|true\|t\|y\|1)'/i;
ac25e0e7 CL	88	$debugging_enabled++ if /usedebugging_perl='(define\|yes\|true\|t\|y\|1)'/i;
ac25e0e7 CL	89	$hide_mymalloc++ if /embedmymalloc='(define\|yes\|true\|t\|y\|1)'/i;
de4b552e	90	$isgcc++ if /gccversion='[^']/;
ac25e0e7	91	$use_perlio++ if /useperlio='(define\|yes\|true\|t\|y\|1)'/i;
93ea32b8 CB	92	}
93ea32b8 CB	93	close CONFIG;
429a5e67	94
93ea32b8 CB	95	# put quotes back onto defines - they were removed by DCL on the way in
93ea32b8 CB	96	if (my ($prefix,$defines,$suffix) =
a0d0e21e	97	($cc_cmd =~ m#(.)/Define=(.?)([/\s].*)#i)) {
93ea32b8 CB	98	$defines =~ s/^\((.*)\)$/$1/;
	99	$debugging_enabled \|\|= $defines =~ /\bDEBUGGING\b/;
	100	my @defines = split(/,/,$defines);
	101	$cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"",@defines))
a0d0e21e	102	. ')' . $suffix;
93ea32b8 CB	103	}
93ea32b8 CB	104	print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
de4b552e	105
93ea32b8 CB	106	# check for gcc - if present, we'll need to use MACRO hack to
93ea32b8 CB	107	# define global symbols for shared variables
4633a7c4	108
93ea32b8 CB	109	print "\$isgcc: $isgcc\n" if $debug;
93ea32b8 CB	110	print "\$debugging_enabled: $debugging_enabled\n" if $debug;
a0d0e21e	111
466adc1d	112	my $objsuffix = shift @ARGV;
a0d0e21e	113	print "\$objsuffix: \\$objsuffix\\\n" if $debug;
466adc1d	114	my $dbgprefix = shift @ARGV;
748a9306	115	print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
466adc1d	116	my $olbsuffix = shift @ARGV;
748a9306	117	print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
466adc1d CB	118	my $libperl = "${dbgprefix}libperl$olbsuffix";
466adc1d CB	119	my $extnames = shift @ARGV;
748a9306	120	print "\$extnames: \\$extnames\\\n" if $debug;
466adc1d	121	my $rtlopt = shift @ARGV;
748a9306	122	print "\$rtlopt: \\$rtlopt\\\n" if $debug;
a0d0e21e	123
93ea32b8	124	my (%vars, %fcns);
713ca5fa	125
93ea32b8	126	open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis: $!";
713ca5fa	127
93ea32b8 CB	128	while (my $line = <$makedefs>) {
93ea32b8 CB	129	chomp $line;
24ad4a07	130	$line = shorten_symbol($line, $care_about_case) if $shorten_symbols;
93ea32b8 CB	131	# makedef.pl loses distinction between vars and funcs, so
	132	# use the start of the name to guess and add specific
	133	# exceptions when we know about them.
	134	if ($line =~ m/^PL_/
	135	\|\| $line eq 'PerlIO_perlio'
	136	\|\| $line eq 'PerlIO_pending') {
	137	$vars{$line}++;
09b7f37c CB	138	}
09b7f37c CB	139	else {
93ea32b8	140	$fcns{$line}++;
a0d0e21e	141	}
a0d0e21e	142	}
b9f71c63	143
9ef4b0a6	144	if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
748a9306 LW	145	foreach (split /\s+/, $extnames) {
	146	my($pkgname) = $_;
	147	$pkgname =~ s/::/__/g;
4633a7c4 LW	148	$fcns{"boot_$pkgname"}++;
4633a7c4 LW	149	print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
748a9306	150	}
a0d0e21e LW	151
	152	# Eventually, we'll check against existing copies here, so we can add new
	153	# symbols to an existing options file in an upwardly-compatible manner.
	154
466adc1d CB	155	my $marord = 1;
466adc1d CB	156	open(OPTBLD,'>', "${dir}${dbgprefix}perlshr_bld.opt")
748a9306	157	or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
a0d0e21e	158	if ($isvax) {
466adc1d	159	open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
a0d0e21e	160	or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
748a9306	161	print MAR "\t.title perlshr_gbl$marord\n";
a0d0e21e	162	}
5e4ba136	163
71be2cbc	164	unless ($isgcc) {
e8e09534 PP	165	if ($isi64) {
	166	print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,NOEXE,RD,NOWRT,SHR\n";
	167	print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,NOEXE,RD,WRT,NOSHR\n";
	168	}
	169	else {
	170	print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n";
	171	print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n";
	172	}
e2367aa8	173	print OPTBLD "PSECT_ATTR=LIB\$INITIALIZE,GBL,NOEXE,NOWRT,NOSHR,LONG\n";
71be2cbc	174	}
b6837a3b	175	print OPTBLD "case_sensitive=yes\n" if $care_about_case;
466adc1d	176	my $count = 0;
93ea32b8	177	foreach my $var (sort (keys %vars)) {
748a9306 LW	178	if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
748a9306 LW	179	else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
4633a7c4 LW	180	# This hack brought to you by the lack of a globaldef in gcc.
4633a7c4 LW	181	if ($isgcc) {
a0d0e21e LW	182	if ($count++ > 200) { # max 254 psects/file
	183	print MAR "\t.end\n";
	184	close MAR;
	185	$marord++;
466adc1d	186	open(MAR, '>', "${dir}perlshr_gbl${marord}.mar")
a0d0e21e	187	or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
748a9306	188	print MAR "\t.title perlshr_gbl$marord\n";
a0d0e21e LW	189	$count = 0;
a0d0e21e LW	190	}
a0d0e21e LW	191	print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n";
	192	print MAR "\t${var}:: .blkl 1\n";
	193	}
	194	}
	195
	196	print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax);
466adc1d	197	foreach my $func (sort keys %fcns) {
a0d0e21e LW	198	if ($isvax) {
	199	print MAR "\t.transfer $func\n";
	200	print MAR "\t.mask $func\n";
4633a7c4	201	print MAR "\tjmp G\^${func}+2\n";
a0d0e21e	202	}
748a9306	203	else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
a0d0e21e	204	}
4633a7c4 LW	205	if ($isvax) {
	206	print MAR "\t.end\n";
	207	close MAR;
	208	}
a0d0e21e	209
466adc1d	210	open(OPTATTR, '>', "${dir}perlshr_attr.opt")
4633a7c4	211	or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
ecc0eccd	212	if ($isgcc) {
93ea32b8 CB	213	# TODO -- lost ability to distinguish constant vars from others when
	214	# we switched to using makedef.pl for input.
	215	# foreach my $var (sort keys %cvars) {
	216	# print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
	217	# }
466adc1d	218	foreach my $var (sort keys %vars) {
71be2cbc	219	print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
	220	}
	221	}
	222	else {
	223	print OPTATTR "! No additional linker directives are needed when using DECC\n";
4633a7c4	224	}
a0d0e21e	225	close OPTATTR;
4633a7c4	226
466adc1d CB	227	my $incstr = 'PERL,GLOBALS';
466adc1d CB	228	my (@symfiles, $drvrname);
a0d0e21e	229	if ($isvax) {
a0d0e21e	230	$drvrname = "Compile_shrmars.tmp_".time;
466adc1d	231	open (DRVR,'>', $drvrname) or die "$0: Can't write to $drvrname: $!\n";
a0d0e21e LW	232	print DRVR "\$ Set NoOn\n";
	233	print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n";
	234	print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n";
	235	print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n";
748a9306	236	print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n";
a0d0e21e	237	print DRVR "\$ Set Verify\n";
748a9306	238	print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
a0d0e21e	239	do {
bbce6d69	240	push(@symfiles,"perlshr_gbl$marord");
a0d0e21e	241	print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n";
748a9306	242	print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n";
a0d0e21e	243	} while (--$marord);
748a9306 LW	244	# We had to have a working miniperl to run this program; it's probably the
	245	# one we just built. It depended on LibPerl, which will be changed when
	246	# the PerlShr_Gbl* modules get inserted, so miniperl will be out of date,
	247	# and so, therefore, will all of its dependents . . .
	248	# We touch LibPerl here so it'll be back 'in date', and we won't rebuild
	249	# miniperl etc., and therefore LibPerl, the next time we invoke MM[KS].
a0d0e21e	250	print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n";
748a9306	251	print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n";
a0d0e21e	252	close DRVR;
a0d0e21e	253	}
748a9306	254
bbce6d69	255	# Initial hack to permit building of compatible shareable images for a
	256	# given version of Perl.
	257	if ($ENV{PERLSHR_USE_GSMATCH}) {
424a8fe9 CB	258	if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
	259	# Build up a major ID. Since it can only be 8 bits, we encode the version
	260	# number in the top four bits and use the bottom four for build options
	261	# that'll cause incompatibilities
466adc1d	262	my ($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/;
e4dfc136	263	$ver += 0; $sub += 0;
466adc1d	264	my $gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for
424a8fe9 CB	265	# dev, but be more forgiving
	266	# for releases
	267
	268	$ver *=16;
	269	$ver += 8 if $debugging_enabled; # If DEBUGGING is set
	270	$ver += 4 if $use_threads; # if we're threaded
	271	$ver += 2 if $use_mymalloc; # if we're using perl's malloc
	272	print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
	273	}
	274	else {
	275	my $major = int($] * 1000) & 0xFF; # range 0..255
	276	my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF; # range 0..255
	277	print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
	278	}
09b7f37c CB	279	print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,',
09b7f37c CB	280	map(",$_$objsuffix",@symfiles), "\n";
bbce6d69	281	}
36477c24	282	elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
748a9306 LW	283	# Include object modules and RTLs in options file
	284	# Linker wants /Include and /Library on different lines
	285	print OPTBLD "$libperl/Include=($incstr)\n";
	286	print OPTBLD "$libperl/Library\n";
a5f75d66	287	open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n";
748a9306 LW	288	while (<RTLOPT>) { print OPTBLD; }
	289	close RTLOPT;
	290	close OPTBLD;
	291
	292	exec "\$ \@$drvrname" if $isvax;
	293
	294
24ad4a07 CB	295	# Symbol shortening Copyright (c) 2012 Craig A. Berry
	296	#
	297	# Released under the same terms as Perl itself.
	298	#
	299	# This code provides shortening of long symbols (> 31 characters) using the
	300	# same mechanism as the OpenVMS C compiler. The basic procedure is to compute
	301	# an AUTODIN II checksum of the entire symbol, encode the checksum in base32,
	302	# and glue together a shortened symbol from the first 23 characters of the
	303	# original symbol plus the encoded checksum appended. The output format is
	304	# the same used in the name mangler database, stored by default in
	305	# [.CXX_REPOSITORY]CXX$DEMANGLER_DB.
	306
	307	sub crc32 {
	308	use constant autodin_ii_table => [
	309	0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f,
	310	0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988,
	311	0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2,
	312	0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7,
	313	0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
	314	0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172,
	315	0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c,
	316	0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59,
	317	0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423,
	318	0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
	319	0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106,
	320	0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433,
	321	0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d,
	322	0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e,
	323	0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
	324	0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65,
	325	0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7,
	326	0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0,
	327	0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa,
	328	0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
	329	0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81,
	330	0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a,
	331	0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84,
	332	0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1,
	333	0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
	334	0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc,
	335	0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e,
	336	0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b,
	337	0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55,
	338	0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
	339	0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28,
	340	0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d,
	341	0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f,
	342	0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38,
	343	0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
	344	0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777,
	345	0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69,
	346	0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2,
	347	0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc,
	348	0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
	349	0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693,
	350	0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94,
	351	0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d,
	352	];
	353
	354	my $input_string = shift;
	355	my $crc = 0xFFFFFFFF;
	356
	357	for my $byte (unpack 'C*', $input_string) {
	358	$crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
359	}
360	return ~$crc;
361	}
362
363	sub base32 {
364	my $input = shift;
365	my $output = '';
366	use constant base32hex_table => [
367	'0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
368	'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
369	'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
370	'u', 'v'
371	];
372
373	# Grab lowest 5 bits and look up conversion in table. Lather, rinse,
374	# repeat for a total of 7, 5-bit chunks to accommodate 32 bits of input.
375
376	for (0..6) {
377	$output = base32hex_table->[$input & 0x1f] . $output;
378	$input >>= 5; # position to look at next 5
379	}
380	$output .= '$'; # It's DEC, so use '$' not '=' to pad.
381
382	return $output;
383	}
384
385	sub shorten_symbol {
386	my $input_symbol = shift;
387	my $as_is_flag = shift;
388	my $symbol = $input_symbol;
389
390	return $symbol unless length($input_symbol) > 31;
391
392	$symbol = uc($symbol) unless $as_is_flag;
393	my $crc = crc32($symbol);
394	$crc = ~$crc; # Compiler uses non-inverted form.
395	my $b32 = base32($crc);
396	$b32 = uc($b32) unless $as_is_flag;
397
398	return substr($symbol, 0, 23) . $b32;
399	}
400
a0d0e21e	401	__END__
24ad4a07	402