#!/usr/bin/perl
# -*- perl -*-

eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
    if 0;

use strict;
use POSIX;
use FindBin qw($RealBin);

my $CC= 'gcc';
my @CPPFLAGS=split(/\s+/,'');
my @CFLAGS=split(/\s+/,'-Wall -O6 -mcpu=pentium');
push(@CFLAGS,'-DHAVE_CONFIG_H'); 
my @LIBS = split(/\s+/,'-lgc -lm -ldl ');
$ENV{'LIBRARY_PATH'} = "/usr/lib/DyALog:$ENV{LIBRARY_PATH}";

my $libtool;
my @TFSFLAGS=();
my @LFLAGS=();

# if an option is unknown, used for dyalog if oclass=0, for gcc otherwise
my $oclass=0; 

my @tmpfiles=();
my $savetmp=0;

my $dev=0;
my $dotfs=1;
my $dolib=1;
my $verbose=0;
my $debug=0;
my $lang='none';

my $rpath="/usr/local/lib";

my $dir= "/home/mandrake/rpm/BUILD/DyALog-1.12.0";
my $bindir= "/home/mandrake/rpm/BUILD/DyALog-1.12.0";

my $tfs='tfs';

my $tfsfile;
my $descfile;
my $cfile;
my $ofile;

# Variables used in read_desc_file and emit_library
my @types=();
my %arity=();
my %subtypes=();
my @features=();
my %features=();
my %intro=();
my @orderedtypes=();
my %order=();
my %skel=();
my %escape=();
my %unif=();
my %subs=();
my %template=();
my %escape_code = ( char => "TFS_X_CHAR",
		    symbol => "TFS_X_SMB",
		    integer => "TFS_X_INT",
		    compound => "TFS_X_COMPOUND"
		    );


# Detect if the script is run from the package or the installation place
unshift(@ARGV,'-dev') if ($RealBin =~ m{^/home/mandrake/rpm/BUILD/DyALog-1.12.0});

my @tfsext = ( 'def' );
my $tfsext_pat = join('|',@tfsext);

while (@ARGV) {

    $_=shift;

    if (/^-help$/) {
	open(HELP,"-|") || system perldoc,"$0";
	print <HELP>;
	exit;
    }

    # Special option to be used only when the package is not installed

    if (/^-dev$/) {
	$dev=1;
	$libtool="$bindir/libtool";
	$tfs = "$bindir/Tfs/tfs";
	next;
    }

    # Configuring

    if (/^-v$/) {
	$verbose=1;
	next;
    }

    if (/^-save-temps$/) {
	$savetmp=1;
	next;
    }

    if (/^-tfs-ext$/) {
	my $suffixe = shift;
	$suffixe =~ s/^\.//;
	push(@tfsext,$suffixe);
	$tfsext_pat = join('|',@tfsext);
	next;
    }

    if (/^-rpath$/) {
	$rpath=shift;
	next;
    }

    if (/^-libtool/) {
	$libtool=shift;
	next;
    }

    if (/^-debug$/) {
	$debug = 1;
	next;
    }

    if (/^-I$/) {
	my $lib = shift;
	push(@TFSFLAGS,'-I',$lib);
	push(@CFLAGS,'-I',$lib);
	next;
    }

    # Collecting files to process

    if (/^(.+)\.($tfsext_pat)$/o) {
	$tfsfile=$_;
	next;
    }

    if (/^(.+)\.desc$/) {
	$descfile=$_;
	next;
    }

    if (/^(.+)\.c$/) {
	$cfile=$_;
	next;
    }

    # other files
    if (!/^-/) {
	$ofile = $_;
	next;
    }

    ## Processing level
    
    if (/^-x$/) {
	$lang = shift;
	next;
    }

    if (/^-tfs$/) {
	$dotfs=0;
	next;
    }

    if (/^-[cSE]$/) {
	push(@CFLAGS,$_);
	$dolib=0;
	next;
    }

    # after -- options are by default for GCC
    last if (/^--$/);  

    push(@TFSFLAGS,$_);

}

push(@CFLAGS,@ARGV);

print STDERR "Default options: $ENV{DYACC}\n" if $verbose;

## from .def to .desc

if ($tfsfile) {
    my ($basefile);
    $tfsfile =~ /^(.+)\.($tfsext_pat)$/;
    $descfile = "$1.desc";
    $descfile =~ s%^(.*/)%%;
    print STDERR join(' ',$tfs,@TFSFLAGS,'-a',"$tfsfile",'-o',"$descfile"),"\n" if $verbose;
    system($tfs,'-a',@TFSFLAGS,"$tfsfile",'-o',"$descfile") == 0 || exit(1);
}

goto CLEAN unless $dotfs;

## from .desc to .c
if ($descfile) {
    push(@tmpfiles,$descfile) if $tfsfile;
    $descfile =~ /^(.+)\.desc$/;
    $cfile = "$1.c";
    $cfile =~ s%^(.*/)%%;
    print STDERR join(' ','tfs2lib',"$descfile",'-o',"$cfile"),"\n" if $verbose;
    &read_desc_file("$descfile");
    &emit_library("$cfile");
}

## From .c to .o

my @CC=();

if (!$libtool)  {
    @CC=($CC);
} else {
    @CC=($libtool,'--mode=compile',$CC);
}

if ($dev) {
  push(@CFLAGS,'-I',"$dir/Runtime",'-I',"$bindir/Runtime"); 
} else {
  push(@CFLAGS,'-I',"/usr/include/DyALog");
}

if ($cfile) {
    push(@tmpfiles,$cfile) if $descfile;
    print STDERR join(' ',@CC,@CFLAGS,@CPPFLAGS,'-c',$cfile),"\n" if $verbose;
    system(@CC,@CFLAGS,@CPPFLAGS,'-c',$cfile) == 0 || exit(1);
}


goto CLEAN unless $dolib && $cfile;

if (!$libtool)  {
    @CC=($CC,'-shared');
} else {
    @CC=($libtool,'--mode=link',$CC,'-export-dynamic','-rpath',$rpath);
}

my $lib;

## C library (.so)
if ($cfile) {
    $cfile =~ m%([^/]+)\.c$%;
    $ofile = $1 . ($libtool ? '.lo' : '.o' );
    $lib = $1 . ($libtool ? '.la' : '.so' );
    $lib =~ s%^(.*/)%%;
    $lib = "lib$lib";
    push(@tmpfiles,$ofile);
    print STDERR join(' ',@CC,@CFLAGS,@CPPFLAGS,$ofile,'-o',$lib),"\n" if $verbose;
    system(@CC,@CFLAGS,@CPPFLAGS,$ofile,'-o',$lib) == 0 || exit(1);
}

print STDOUT 
    "**********************************************************************\n",
    "**** $0 has successfuly build library $lib\n",
    "**********************************************************************\n"
    ;


CLEAN:
    if (@tmpfiles && !$savetmp) {
	print STDERR join(' ','rm',@tmpfiles),"\n" if $verbose;
	system 'rm',@tmpfiles;
    }

exit 0;

######################################################################
# subroutines to emit the TFS library

sub read_desc_file {

    my $file = shift;
    my $left;
    my $right;

    open( FILE, "<$file" ) || die "can't open $file";

    while (<FILE>) {

	next if (/^;;/);
	
	if ( s/^TYPES\s*=\s*//o ) {
	    push(@types,split);
	    @arity{@types} = (0) x @types;
	    next;
	}
	
	if ( s/^SUBTYPES\s+(\S+?)\s*=\s*//o ) {
	    $subtypes{$1} = [ split ];
	    $arity{$1}++;
	    next;
	}
	
	if ( s/^FEATURES\s*=\s*//o ) {
	    @features=split;
	    next;
	}
	
	if ( s/^INTRO\s+(\S+?)\s*=\s*//o ) {
	    ($intro{$1}) = split;
	    next;
	}
	
	if ( s/^SKEL\s+(\S+?)\s*=\s*//o) {
	    push(@orderedtypes,$1);
	    $order{$1} = $#orderedtypes;
	    my @ft = map &treat_feature_pair($_), split;
	    $skel{$1} = [@ft];
	    $arity{$1} += @ft;
	    next;
	}

	if ( s/^XTYPE\s+(\S+?)\s*=\s*\S+?//o) {
	    $arity{$1}++,
	    $subtypes{$1}=[ ];
	    next;
	}

	if ( s/^ESCAPE\s+(\S+?)\s*=\s*//o) {
	    $escape{$1} = [ split ];
	    next;
	}

	if ( s/^UNIF\s+(\S+?)\s+(\S+?)\s*=\s*//o ) {
	    $left=$1;
	    $right=$2;
	    ( $unif{$left}{$right}{type} ) = split;
	    next;
	}
	
	if ( /^\+\s+NEW\s+(\S+?)\s+(\d+)/o ){
	    push( @{$unif{$left}{$right}{actions}}, 
		  { type => "NEW",
		    feature => $1,
		    res => $2,
		    imm => 1
		    });
	    next;
	}
	
	if ( /^\+\s+UNIF\s+(\S+?)\s+LEFT\s+(\d+)\s+RIGHT\s+(\d+)\s+(DIRECT|INDIRECT)\s+(\d+)/o ) {
	    push( @{$unif{$left}{$right}{actions}}, 
		  { type => "UNIF",
		    feature => $1,
		    left => $2,
		    right => $3,
		    res => $5,
		    imm => ($4 eq "DIRECT")
		    });
	    next;
	}
    
	if ( /^\+\s+INHERIT\s+(\S+?)\s+LEFT\s+(\d+)\s+(DIRECT|INDIRECT)\s+(\d+)/o ) {
	    push( @{$unif{$left}{$right}{actions}}, 
		  { type => "LEFT",
		    feature => $1,
		    left => $2,
		    res => $4,
		    imm => ($3 eq "DIRECT")
		    });
	    next;
	}
	
	if ( /^\+\s+INHERIT\s+(\S+?)\s+RIGHT\s+(\d+)\s+(DIRECT|INDIRECT)\s+(\d+)/o ) {
	    push( @{$unif{$left}{$right}{actions}}, 
		  { type => "RIGHT",
		    feature => $1,
		    right => $2,
		    res => $4,
		    imm => ($3 eq "DIRECT")
		    });
	    next;
	}

	if ( s/^SUBS\s+(\S+?)\s+(\S+?)\s*=\s*//o) {
	    $left=$1;
	    $right=$2;
	    next;
	}
	
	if ( /^\+\s+CHECK\s+(\S+?)\s+(\d+)\s+(\d+)/o ) {
	    push( @{$subs{$left}{$right}{actions}}, 
		  { type => "CHECK",
		    feature => $1,
		    left => $2,
		    right => $3
		    });
	    next;
	}
	
    }
}

######################################################################
# Emitting Library

sub emit_library {
    my $file = shift;

    open(CODE,">$file") || die "can't open code file $file";

    my $nbtypes = @types;
    my $nbfeat = 1+@features;
    my %unifname=();
    my %subname=();

print CODE  <<EOF;   #Emitting static part
// Automatically generated by lib2tfs from desc file $file

#include "tfslib.h"

static Template Template_Table[$nbtypes];

EOF

####  Emitting Unification Functions

foreach my $left (keys %unif) {

    foreach my $right (keys %{ $unif{$left} }) {

	next if ($left eq $right);

	my $name = "UF_${left}_VS_${right}";

	my $res = $unif{$left}{$right}{type};
	my $max  = $subtypes{$res} ? 0 : 1;

	my $newtype = !($res eq $right || $res eq $left);

	my $sL   = ($res eq $left) ? (1-$max) : 1;
	my $sR   = ($res eq $right) ? (1-$max) : 1;
	my $sRes = (1-$max);
	my $flag = 1;

	my $body = <<EOF;
static Bool
$name(SP(Left), SP(Right)) 
{
EOF

    if ($debug) {
	$body .= <<EOF;
	V_LEVEL_DISPLAY(V_TFS,"TFS Unification $left x $right -> $res\\n\\tleft=%&s\\n\\tright=%&s\\n",
			Left,Sk(Left),
			Right,Sk(Right));
EOF
    }

    if ($newtype) { 
	$body .= <<EOF;
    Bind_To_Template(Left,Right,Res,$order{$res});
EOF
    } elsif ($res eq $right) {
	    $body .= <<EOF;
    Unif_Bind(Left,Sk(Left),Right,Sk(Right));
EOF
    } else {
	    $body .= <<EOF;
    Unif_Bind(Right,Sk(Right),Left,Sk(Left));
EOF
}

    foreach my $action (@{ $unif{$left}{$right}{actions} }){

	my %action = %$action;

	my $aL = $action{left}+$sL;
	my $aR = $action{right}+$sR;
	my $aRes = $action{res}+$sRes;

	# Actions New are ignored
	next if ($action{type} =~ /NEW/);

	# Action Unif bewteen two features of the parents
	if ($action{type} =~ /UNIF/o ) {
	    $flag = 0 if ($action{left} != $action{right} || $action{res} != $action{left});
	    $body .= <<EOF;
    Unify_Or_Fail(FOLCMP_REF(Left,$aL),Sk(Left),FOLCMP_REF(Right,$aR),Sk(Right));
EOF
             $body .= $action{imm} ? <<BIND : <<UNIF if ($newtype);
    Unif_Bind(FOLCMP_REF(Res,$aRes),Sk(Res),FOLCMP_REF(Left,$aL),Sk(Left));
BIND
    Unify_Or_Fail(FOLCMP_REF(Res,$aRes),Sk(Res),FOLCMP_REF(Left,$aL),Sk(Left));
UNIF
              next;
	}

	# Action Herit feature from left parent
	# (=> this is not a type/subtype unif)
	# nothing to do when left type = res type
	if ($action{type} =~ /LEFT/o && !($left eq $res)){
	    $flag=0;
	    $body .= $action{imm} ? <<BIND  : <<UNIF ;
    Unif_Bind(FOLCMP_REF(Res,$aRes),Sk(Res),FOLCMP_REF(Left,$aL),Sk(Left));
BIND
    Unify_Or_Fail(FOLCMP_REF(Res,$aRes),Sk(Res),FOLCMP_REF(Left,$aL),Sk(Left));
UNIF
	next;
	}

	# Action Herit feature from right parent
	# (=> this is not a type/subtype unif)
	# nothing to do when right type = res type
	if ($action{type} =~ /RIGHT/o && !($right eq $res)){
	    $flag=0;
	    $body .= $action{imm} ? <<BIND  : <<UNIF ;
    Unif_Bind(FOLCMP_REF(Res,$aRes),Sk(Res),FOLCMP_REF(Right,$aR),Sk(Right));
BIND
    Unify_Or_Fail(FOLCMP_REF(Res,$aRes),Sk(Res),FOLCMP_REF(Right,$aR),Sk(Right));
UNIF
	next;
	}

    }

    $body .= <<EOF;
    Succeed;
}

EOF
    
    if ($flag && !$newtype) {
	# => left subtype of right or converse
	# identify which case we are facing
	if ($res eq $right) {
	    $unifname{$left}{$right} = "Tfs_Subtype_Unif";
	} else {
	    $unifname{$right}{$left} = "Tfs_Subtype_Unif";
	}
    } else {
	$unifname{$left}{$right} = $name;
	print CODE  $body;
    }

}
}

### Subsumption Functions

foreach my $left (keys %subs) {

    foreach my $right (keys %{ $subs{$left} }) {
    
	my $name = "SB_${left}_VS_${right}";
	my $sR  = $subtypes{$right} ? 0 : 1;
   
	my $flag=1;
	my $body = <<EOF;
static Bool
$name(SP(Left), SP(Right)) 
{
EOF

    if ($debug) {
	$body .= <<EOF;
	V_LEVEL_DISPLAY(V_TFS,"TFS Subsumption $left x $right\\n\\tleft=%&s\\n\\tright=%&s\\n",
			Left,Sk(Left),
			Right,Sk(Right));
EOF
    }

    $body .= <<EOF;
    Subs_Bind(Left,Sk(Left),Right,Sk(Right));
EOF

    foreach my $action (@{ $subs{$left}{$right}{actions} }) {

	my %action = %$action;

	$flag = 0 if ($action{left} != $action{right});
	my $aL = $action{left}+1;
	my $aR = $action{right}+$sR;
	$body .= <<EOF
    Subsume_Or_Fail(FOLCMP_REF(Left,$aL),Sk(Left),FOLCMP_REF(Right,$aR),Sk(Right));
EOF
}

     $body .= <<EOF;
    Succeed;
}

EOF

    if ($flag) {
	$subname{$left}{$right} = "Tfs_Simple_Subsume";
    } else {
	$subname{$left}{$right} = $name;
	print CODE  $body;
    }
    
}
}

### Emitting Init Function

print CODE  <<EOF;

void Tfs_Init()
{
    fol_t type[$nbtypes];
    fol_t feat[$nbfeat];

    dyalog_printf("Running Tfs_Init\\n");

    Unif_Table = Hash_Alloc_Table(100,sizeof(struct Tfs_Data));
    Subs_Table = Hash_Alloc_Table(100,sizeof(struct Tfs_Data));
    Escape_Table = Hash_Alloc_Table(100,sizeof(struct Tfs_Escape));

EOF

print CODE <<EOF;

    // Installing types

EOF

    foreach my $type (@orderedtypes) {
	my $xtype = emit_symbol($type);
	my $is_deref = $subtypes{$type} ? 1 : 0;
	print CODE <<EOF;
    type[$order{$type}] = Tfs_Type($xtype,$arity{$type},$is_deref);
EOF
     }

print CODE<<EOF;

    // Installing features

EOF

	my $featcount=0;

    foreach my $feature ('$$',@features) {
	$features{$feature}=$featcount;
	my $xfeature = emit_symbol($feature);
	print CODE <<EOF;
	feat[$featcount] = $xfeature;
EOF
	     ++$featcount;
    }


print CODE<<EOF;

    // Installing feature info

EOF

    foreach my $type (@orderedtypes) {
	my @f = map($_,@{ $skel{$type} });
	@f = (['$$',""],@f) if ($subtypes{$type});
	my $l = @f;
	@f = map( @{emit_feature_pair($_)}, @f);
	my $f = join(",",$l,@f);
	print CODE <<EOF;
    set_features(type[$order{$type}], $f );
EOF
    }

print CODE <<EOF;
    
    // Building Type Templates (in correct order)

EOF

    foreach my $type (@orderedtypes){
	&emit_template($type);
    }

print CODE <<EOF;
    
    // Setting Escapes

EOF
    
    foreach my $escape (keys %escape) {
	foreach my $type (@{ $escape{$escape} }) {
	    &emit_escape($type,$escape);
	}
    }

    print CODE  <<EOF;

    // Installing intro

EOF

	foreach my $feature (@features) {
	    my $intro = $intro{$feature};
	    my $pos = &feature_pos($feature,$intro);
	    print CODE <<EOF;
    set_intro(feat[$features{$feature}],type[$order{$intro}],$order{$intro},$pos);
EOF
	}

    print CODE  <<EOF;

    // Installing Unification functions

EOF

foreach my $left (keys %unifname) {

    foreach my $right (keys %{ $unifname{$left} }) {

	my $name = $unifname{$left}{$right};

	print CODE  <<EOF;
    AddTableEntry(type[$order{$left}],type[$order{$right}],&$name,Unif_Table);
EOF
    }
}

    print CODE  <<EOF;

    // Installing Subsumption functions

EOF

foreach my $left (keys %subname) {

    foreach my $right (keys %{ $subname{$left} }) {

	my $name = $subname{$left}{$right};

    print CODE  <<EOF;
    AddTableEntry(type[$order{$left}],type[$order{$right}],&$name,Subs_Table);
EOF
     }
}

print CODE  <<EOF;
}
EOF

    close(CODE);

}				# End of emit_library


sub emit_symbol {
    my @smb = split('!',shift);
    my $smb= "0";
    foreach my $x (@smb) {
	$smb="Tfs_Symbol(\"".$x."\",0,$smb)";
    }
    return $smb;
}

sub treat_feature_pair {
    my $ft = shift;
    my ($f,$t) = split(/:/,$_);
    $t="" if ($t eq '$untyped');
    return [ $f,$t ];
}

sub emit_feature_pair {
    my $ft = shift;
    my ($f,$t) = @$ft;
    $t = $t ? "type[$order{$t}]" : 0;
    return ["feat[$features{$f}]",$t];
}

sub emit_template {
    my $type = shift;
    my (@args,$maximal,$arity,$args);
    return if $template{$type};
    $template{$type}=1;
    $maximal = $subtypes{$type} ? 0 : 1;
    $arity = $arity{$type} - ($maximal ? 0 : 1) ;	
    @args = ($arity, $maximal);
    foreach my $feature (@{$skel{$type}}) {
	if ($order{$feature->[1]}) { 		
	    emit_template($feature->[1]);
	    push(@args,$order{$feature->[1]});
	} else {
	    push(@args,-1); # Feature with internal type
	}
    }
    $args = join(',',@args);
    print CODE  <<EOF;
    Make_Template($order{$type},type[$order{$type}],$args);
EOF
}

sub emit_escape {
    # should be done after emit_template
    my ($type,$escape) = @_;
    my ($order);
    print CODE <<EOF
    Add_Escape(type[$order{$type}],$escape_code{$escape});
EOF
}


sub subtype {			# test is $a subtype of $b
    my ($a,$b) = @_;

    return 1 if ($a eq $b);

    foreach my $c (@{$subtypes{$b}}) {
	return 1 if &subtype($a,$c);
    }

    return 0;

}

sub feature_pos {
    my ($feature,$type) = @_;
    my $pos = $subtypes{$type} ? 1 : 0;
    foreach my $f (@{$skel{$type}}) {
	$pos++;
	return $pos if ($feature eq $f->[0]);
    }
    die "Feature $feature not present for type $type";
}

__END__

=head1 NAME

tfs2lib - Building C libraries from Typed Feature Structure hierachies

=head1 SYNOPSIS

B<tfs2lib> B<option>... F<filename>

=head1 DESCRIPTION

B<tfs2lib> is a PERL script used to generate and compile C libraries
from a file describing a Typed Feature Structure [TFS] hierarchy a la
Carpenter. 

B<tfs2lib> uses a sub program called B<tfs> going from a Prolog file
(B<.def>) to an intermediate description file (B<.desc>) with is then
converted into a C file by B<tfs2lib> and compiled as a C dynamic
library with B<gcc>.

=head1 OPTIONS

=over 5

=item B<-help>
Display this help

=item B<-dev>
Developement mode (activate libtool mode)

=item B<-libtool B<libtool>>
Use B<libtool> as a wrapper aroung B<gcc> to deal with dynamic libraries

=item B<-v> 
Print (on standard error output) the commands executed to run the
stages of compilation.

=item B<-save-temps> 
Keep intermediate files (.desc and .c) but do not transmit the option to
gcc.

=item B<-debug> 
Add debbuging information in the library functions

=item B<-tfs-ext F<suffixe>>
Specify an extra F<suffixe> for TFS files

=item B<-rpath F<directory>> 
Specify F<directory> as the place where to eventually install the
library (when using B<libtool>).

=item B<-tfs>
Stop after generation of the description file (B<.desc>).

=item B<-c>
Do not link.

=back

=head1 SEE ALSO

dyalog, ma2asm, dyacc as man pages or as info entries.

=head1 AUTHORS

Eric de la Clergerie <Eric.De_La_Clergerie@inria.fr>

=cut

### Local Variables: 
### comment-column:0 
### comment-start: "### "  
### comment-end:"" 
### mode: perl
### End: 
