cgcc

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