#
-#eval "exec perl -S $0 $*"
-# if $running_under_some_random_shell;
-#
# reads CPP output and turns #line things into appropriate Haskell
# pragmas
#
# considered to be GHC-project specific
#
-# OPTIONALLY processes GENERATE_SPECS pragmas
-# when give flag -genSPECS
-#
-# EXAMPLE:
-#
-# {-# GENERATE_SPECS a b #-}
-# fn :: type
-#
-#==>>
-#
-# fn :: type
-# {-# SPECIALIZE fn :: type[ a/a,u1/b] #-}
-# {-# SPECIALIZE fn :: type[ a/a,u2/b] #-}
-# {-# SPECIALIZE fn :: type[u1/a, b/b] #-}
-# {-# SPECIALIZE fn :: type[u1/a,u1/b] #-}
-# {-# SPECIALIZE fn :: type[u1/a,u2/b] #-}
-# {-# SPECIALIZE fn :: type[u2/a, b/b] #-}
-# {-# SPECIALIZE fn :: type[u2/a,u1/b] #-}
-# {-# SPECIALIZE fn :: type[u2/a,u2/b] #-}
-#
-# where the u's are extracted from a predetermined
-# set of unboxed types $SpecingString
-#
-# The types to substitute can be specified explicitly in { }s following
-# the type variable
-#
-# EXAMPLES:
-#
-# {-# GENERATE_SPECS a{ty1,ty2...} b{+,ty1,ty2...} c{~,ty1,ty2,...} d{~,+,ty1,ty2,...} #-}
-# fn :: type
-#
-# where
-# ~ indicates that no specialisations are to be left polymorhphic in this type variable
-# (this is required for overloaded tyvars which must have ground specialisations)
-# + indicates that the predetermined types are to be added to the list
-#
-# Note: There must be no white space between { }s
-# Use ( )s around type names when separation is required
-#
#
# NOTE: this script needs RAWCPP set in order to do something
# useful:
#
-#$RAWCPP='';
-#
$Verbose = 0;
-$DoGenSpecs = 0;
-$DoGenSpecsUnboxed = 0;
-@SpecingTypes = ();
-
-while ($#ARGV >= 0 && $ARGV[0] eq '-v' || $ARGV[0] =~ /^-genSPECS/) {
+while ( $#ARGV >= 0 && $ARGV[0] eq '-v' ) {
if ($ARGV[0] eq '-v') {
$Verbose = 1;
- } elsif ($ARGV[0] eq '-genSPECS') {
- $DoGenSpecs = 1;
- } elsif ($ARGV[0] eq '-genSPECSunboxed') {
- $DoGenSpecs = 1;
- $DoGenSpecsUnboxed = 1;
- $SpecingString = "Char#,Int#,Double#";
- @SpecingTypes = split(/,/, $SpecingString);
} else {
die "hscpp: unrecognised argument: $$ARGV[0]\n";
}
s/^#\s*line\s+(\d+)\s+(\".+\")$/\{\-# LINE \1 \2 \-\}/;
s/^#\s*(\d+)\s+(\".*\").*/\{\-# LINE \1 \2 \-\}/;
-# genSPEC processing:
- if ( /^\s*\{-#\s*GENERATE_SPECS/ ) {
- if ( $DoGenSpecs ) {
- $line = $_;
- $data_or_inst = 0;
- $data_inst_str = "";
- $remove_poly = 1;
- $space = "";
-
- if ( /^\s*\{-#\s*GENERATE_SPECS\s+(data)\s+(\S.*)\s*::(.*)#-\}\s*$/ ) {
- $data_or_inst = 1;
- $data_inst_str = $1;
- $vars = $2;
- $type = $3;
- } elsif ( /^\s*\{-#\s*GENERATE_SPECS\s+(instance)\s+(\S.*)\s*::(.*)#-\}\s*$/ ) {
- $data_or_inst = 1;
- $data_inst_str = $1;
- $vars = $2;
- $type = $3;
- } elsif ( /^(\s*)\{-#\s*GENERATE_SPECS\s+(\S+)\s+(.*)\s*#-\}\s*$/ ) {
- $space = $1;
- $fun = $2;
- $vars = $3;
-
- $tysig = <INPIPE>;
- while ( $tysig =~ /^\s*$/ ) {
- print $tysig;
- $tysig = <INPIPE>;
- }
- $funpat = $fun; # quote non alphanumeric characters in pattern
- $funpat =~ s/(\W)/\\\1/g;
- $tysig =~ /^\s*$funpat\s*::(.*)$/ || die "Error: GENERATE_SPECS not followed by type signature for $fun:\n$line$tysig\n";
- $type = $1;
- $type =~ s/^(.*)=>//; # remove context from type
- } else {
- die "Error: invlaid GENERATE_SPECS pragma:\n $_";
- }
-
- @tyvars = split(/\s+/, $vars);
- @tospec = ($type);
- foreach $var (@tyvars) {
- @specing = @tospec;
-
- if ( $var =~ /^(\w+)\{(.*)\}$/ ) {
- $var = $1;
- @specing_types = &split_types($2);
- if ($specing_types[0] eq '~') {
- shift(@specing_types);
- @tospec = (); # remove specs polymorphic in this tyvar
- $remove_poly = 0;
- }
- if ($specing_types[0] eq '+') {
- shift(@specing_types);
- unshift(@specing_types, @SpecingTypes);
- }
- } else {
- @specing_types = @SpecingTypes;
- }
-
- # If not $DoGenSpecsUnboxed we remove any unboxed types
- # (i.e. types containing a #) from the specing_types
-
- @specing_types = grep(!/#/, @specing_types) if ! $DoGenSpecsUnboxed;
-
- foreach $uty (@specing_types) {
- @speced = @specing;
- foreach $i (0..$#speced) {
- $speced[$i] =~ s/\b$var\b/$uty/g ;
- }
- push(@tospec, @speced);
- }
- }
- shift(@tospec) if $remove_poly; # remove fully polymorphic spec
-
- if ($#tospec >= 0) {
- $specty = shift(@tospec);
- print ($data_or_inst ? "\{-# SPECIALIZE $data_inst_str $specty #-\}" : "$space\{-# SPECIALIZE $fun :: $specty");
- while ($#tospec >= 0) {
- $specty = shift(@tospec);
- print ($data_or_inst ? "; \{-# SPECIALIZE $data_inst_str $specty #-\}" : ", $specty");
- }
- print ($data_or_inst ? "\n" : " #-}\n");
- } else {
- print "\{- NO_SPECS_GENERATED ", $data_or_inst ? $specty : $fun, " -\}\n";
- print STDERR "Warning: No specs for GENERATE_SPECS pre-processing pragma:\n $_";
- }
- print $tysig if ! $data_or_inst;
- } else {
- print STDERR "Warning: GENERATE_SPECS pre-processing pragma ignored:\n $_";
- print $_;
- }
- } else {
- print $_;
- }
+ print $_;
}
close(INPIPE) || exit(1); # exit is so we reflect any errors.
exit(0);
-
-
-# splits a list of types seperated by ,s but allowing ,s within ()s
-
-
-sub split_types {
- local($type_str) = @_;
-
- local(@chars) = split(//,$type_str);
- local($depth) = 0;
- local($start) = 0;
- local($cur) = 0;
- local($char);
-
- local(@types) = ();
-
- while ($char = $chars[$cur]) {
- if ($char eq ',' && $depth == 0) {
- push(@types, join('', @chars[$start .. $cur-1])) if ($start < $cur);
- $start = $cur+1;
- } elsif ($char eq '(') {
- $depth++;
- } elsif ($char eq ')') {
- $depth--;
- }
- $cur++;
- }
- if ($depth == 0) {
- push(@types, join('', @chars[$start .. $cur-1])) if ($start < $cur);
- } else {
- print STDERR "Error: GENERATE_SPECS pre-processing pragma has unbalanced ( )s\n$line\n";
- exit(1);
- }
- return(@types);
-}
-
-
-
projects / ghc-hetmet.git / commitdiff