cgcc

   1 #!/usr/bin/perl -w
   2 # -----------------------------------------------------------------------------
   3
   4 my $cc = $ENV{'REAL_CC'} || 'cc';
   5 my $check = $ENV{'CHECK'} || 'check';
   6
   7 my $m64 = 0;
   8 my $has_specs = 0;
   9 my $do_check = 0;
  10 my $do_compile = 1;
  11 my $verbose = 0;
  12
  13 foreach (@ARGV) {
  14     # Look for a .c file.  We don't want to run the checker on .o or .so files
  15     # in the link run.  (This simplistic check knows nothing about options
  16     # with arguments, but it seems to do the job.)
  17     $do_check = 1 if /^[^-].*\.c$/;
  18
  19     # Ditto for stdin.
  20     $do_check = 1 if $_ eq '-';
  21
  22     $m64 = 1 if /^-m64$/;
  23
  24     if (/^-specs=(.*)$/) {
  25         $check .= &add_specs ($1);
  26         $has_specs = 1;
  27         next;
  28     }
  29
  30     if ($_ eq '-no-compile') {
  31         $do_compile = 0;
  32         next;
  33     }
  34
  35     # If someone adds "-E", don't pre-process twice.
  36     $do_compile = 0 if $_ eq '-E';
  37
  38     $verbose = 1 if $_ eq '-v';
  39
  40     my $this_arg = ' ' . &quote_arg ($_);
  41     $cc .= $this_arg unless &check_only_option ($_);
  42     $check .= $this_arg;
  43 }
  44
  45 if ($do_check) {
  46     if (!$has_specs) {
  47         $check .= &add_specs ('host_arch_specs');
  48         $check .= &add_specs ('host_os_specs');
  49     }
  50     print "$check\n" if $verbose;
  51 #    exit 1;
  52     system ($check);
  53 }
  54
  55 if ($do_compile) {
  56     print "$cc\n" if $verbose;
  57     exec ($cc);
  58 }
  59
  60 exit 0;
  61
  62 # -----------------------------------------------------------------------------
  63 # Check if an option is for "check" only.
  64
  65 sub check_only_option {
  66     my ($arg) = @_;
  67     return 1 if $arg =~ /^-W(no-?)?(default-bitfield-sig|bitwise|typesign)$/;
  68     return 0;
  69 }
  70
  71 # -----------------------------------------------------------------------------
  72 # Simple arg-quoting function.  Just adds backslashes when needed.
  73
  74 sub quote_arg {
  75     my ($arg) = @_;
  76     return "''" if $arg eq '';
  77     return join ('',
  78                  map {
  79                      m|^[-a-zA-Z0-9._/,=]+$| ? $_ : "\\" . $_;
  80                  } (split (//, $arg)));
  81 }
  82
  83 # -----------------------------------------------------------------------------
  84
  85 sub integer_types {
  86     my ($char,@dummy) = @_;
  87
  88     my %pow2m1 =
  89         (8 => '127',
  90          16 => '32767',
  91          32 => '2147483647',
  92          64 => '9223372036854775807',
  93          );
  94     my @types = (['SCHAR',''], ['SHRT',''], ['INT',''], ['LONG','L'], ['LONG_LONG','LL']);
  95
  96     my $result = " -D__CHAR_BIT__=$char";
  97     while (@types) {
  98         my $bits = shift @_;
  99         my ($name,$suffix) = @{ shift @types };
 100         die "$0: wierd number of bits." unless exists $pow2m1{$bits};
 101         $result .= " -D__${name}_MAX__=" . $pow2m1{$bits} . $suffix;
 102     }
 103     return $result;
 104 }
 105
 106 # -----------------------------------------------------------------------------
 107
 108 sub float_types {
 109     my ($has_inf,$has_qnan,$dec_dig,@bitsizes) = @_;
 110     my $result = " -D__FLT_RADIX__=2";
 111     $result .= " -D__FINITE_MATH_ONLY__=" . ($has_inf || $has_qnan ? '0' : '1');
 112     $result .= " -D__DECIMAL_DIG__=$dec_dig";
 113
 114     my %constants =
 115         (24 =>
 116          {
 117              'MIN' => '1.17549435e-38',
 118              'MAX' => '3.40282347e+38',
 119              'EPSILON' => '1.19209290e-7',
 120              'DENORM_MIN' => '1.40129846e-45',
 121          },
 122          53 =>
 123          {
 124              'MIN' => '2.2250738585072014e-308',
 125              'MAX' => '1.7976931348623157e+308',
 126              'EPSILON' => '2.2204460492503131e-16',
 127              'DENORM_MIN' => '4.9406564584124654e-324',
 128          },
 129          64 =>
 130          {
 131              'MIN' => '3.36210314311209350626e-4932',
 132              'MAX' => '1.18973149535723176502e+4932',
 133              'EPSILON' => '1.08420217248550443401e-19',
 134              'DENORM_MIN' => '3.64519953188247460253e-4951',
 135          },
 136          113 =>
 137          {
 138              'MIN' => '3.36210314311209350626267781732175260e-4932',
 139              'MAX' => '1.18973149535723176508575932662800702e+4932',
 140              'EPSILON' => '1.92592994438723585305597794258492732e-34',
 141              'DENORM_MIN' => '6.47517511943802511092443895822764655e-4966',
 142          },
 143          );
 144
 145     my @types = (['FLT','F'], ['DBL',''], ['LDBL','L']);
 146     while (@types) {
 147         my ($mant_bits,$exp_bits) = @{ shift @bitsizes };
 148         my ($name,$suffix) = @{ shift @types };
 149
 150         my $h = $constants{$mant_bits};
 151         die "$0: wierd number of mantissa bits." unless $h;
 152
 153         my $mant_dig = int (($mant_bits - 1) * log (2) / log (10));
 154         my $max_exp = 1 << ($exp_bits - 1);
 155         my $min_exp = 3 - $max_exp;
 156         my $max_10_exp = int ($max_exp * log (2) / log (10));
 157         my $min_10_exp = -int (-$min_exp * log (2) / log (10));
 158
 159         $result .= " -D__${name}_MANT_DIG__=$mant_bits";
 160         $result .= " -D__${name}_DIG__=$mant_dig";
 161         $result .= " -D__${name}_MIN_EXP__='($min_exp)'";
 162         $result .= " -D__${name}_MAX_EXP__=$max_exp";
 163         $result .= " -D__${name}_MIN_10_EXP__='($min_10_exp)'";
 164         $result .= " -D__${name}_MAX_10_EXP__=$max_10_exp";
 165         $result .= " -D__${name}_HAS_INFINITY__=" . ($has_inf ? '1' : '0');
 166         $result .= " -D__${name}_HAS_QUIET_NAN__=" . ($has_qnan ? '1' : '0');;
 167
 168         foreach my $inf (sort keys %$h) {
 169             $result .= " -D__${name}_${inf}__=" . $h->{$inf} . $suffix;
 170         }
 171     }
 172     return $result;
 173 }
 174
 175 # -----------------------------------------------------------------------------
 176
 177 sub define_size_t {
 178     my ($text) = @_;
 179     # We have to undef in order to override check's internal definition.
 180     return ' -U__SIZE_TYPE__ ' . &quote_arg ("-D__SIZE_TYPE__=$text");
 181 }
 182
 183 # -----------------------------------------------------------------------------
 184
 185 sub add_specs {
 186     my ($spec) = @_;
 187     if ($spec eq 'sunos') {
 188         return &add_specs ('unix') .
 189             ' -D__sun__=1 -D__sun=1 -Dsun=1' .
 190             ' -D__svr4__=1 -DSVR4=1' .
 191             ' -D__STDC__=0' .
 192             ' -D_REENTRANT' .
 193             ' -D_SOLARIS_THREADS' .
 194             ' -DNULL="((void *)0)"';
 195     } elsif ($spec eq 'linux') {
 196         return &add_specs ('unix') .
 197             ' -D__linux__=1 -D__linux=1 -Dlinux=linux' .
 198             ' -D__STDC__=1';
 199     } elsif ($spec eq 'unix') {
 200         return ' -Dunix=1 -D__unix=1 -D__unix__=1';
 201     } elsif ($spec eq 'i86') {
 202         return (' -Di386=1 -D__i386=1 -D__i386__=1' .
 203                 &integer_types (8, 16, 32, $m64 ? 64 : 32, 64) .
 204                 &float_types (1, 1, 21, [24,8], [53,11], [64,15]) .
 205                 &define_size_t ($m64 ? "long unsigned int" : "unsigned int"));
 206     } elsif ($spec eq 'sparc') {
 207         return (' -Dsparc=1 -D__sparc=1 -D__sparc__=1' .
 208                 &integer_types (8, 16, 32, $m64 ? 64 : 32, 64) .
 209                 &float_types (1, 1, 33, [24,8], [53,11], [113,15]) .
 210                 &define_size_t ($m64 ? "long unsigned int" : "unsigned int"));
 211     } elsif ($spec eq 'host_os_specs') {
 212         my $os = `uname -s`;
 213         chomp $os;
 214         return &add_specs (lc $os);
 215     } elsif ($spec eq 'host_arch_specs') {
 216         my $arch = `uname -m`;
 217         chomp $arch;
 218         if ($arch =~ /^(i.?86|athlon)$/i) {
 219             return &add_specs ('i86');
 220         } elsif ($arch =~ /^(sun4u)$/i) {
 221             return &add_specs ('sparc');
 222         }
 223     } else {
 224         die "$0: invalid specs: $spec\n";
 225     }
 226 }
 227
 228 # -----------------------------------------------------------------------------