Skip to content
Snippets Groups Projects
Commit ee1fdf9b authored by sof's avatar sof
Browse files

[project @ 1998-05-12 15:08:57 by sof] 

Removed -genSPECS magic (no longer used.)
parent cdf3461f
No related merge requests found
Hide whitespace changes
Inline Side-by-side
ghc/utils/hscpp/hscpp.prl
+ 2
− 188
View file @ ee1fdf9b
#
#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";
}
......@@ -106,140 +51,9 @@ while (<INPIPE>) {
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);
}
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment