#!/usr/local/bin/perl

# Copyright (c) 1996 Matthew Flatt

# Generate information for automatic testing from .xc files

# Get the directory where this file is, and add to include path:
{$0 =~ /^(.*)\/.*$/;  $my_dir = $1; 
 if ($my_dir !~ ?^/?) {
     open(DIRNAME, "pwd | ");
     $pwd = <DIRNAME>;
     close(DIRNAME);
     chop($pwd);
     $my_dir = $pwd . "/" . $my_dir;}
 if ($my_dir =~ ?/$?) {chop ($my_dir);}}
push(@INC, $my_dir);

$dangerfile = shift(@ARGV);

%danger = ();
open(DANGER, $dangerfile);
while (<DANGER>) {
    chop;
    if (/^\#/) {
	; skip
    } elsif (/^(.*) (.*)/) {
	$key = $1 . "::" . $2;
	$danger{$key} = 1;
    }
}
close(DANGER);

require "parse.pl";

@allclasses = ();
%notest = ();
$dummyfields = " \"initialization\" : x create";

$notest{wxMetaFileDC} = 1;
$notest{wxMetaFile} = 1;
$notest{wxPrinterDC} = 1;
$notest{wxLayoutConstraints} = 1;
$notest{wxIndividualLayoutConstraint} = 1;
$notest{wxForm} = 1;
$notest{wxFormItem} = 1;
$notest{wxFormGlobal} = 1;
$notest{wxHelpInstance} = 1;
$notest{wxEnhDialogBox} = 1;
$notest{wxToolBar} = 1;
$notest{wxToolBarTool} = 1;
$notest{wxButtonBar} = 1;

while (($file = shift(@ARGV)) ne undef) {

    if ($file =~ s/.xc$//) {
    } else {
	print STDERR "Bad extension \"$file\".\n";
	exit 1;
    }
    
    if (!open(IN, "$file.xc")) {
	print STDERR "Couldn't open \"${file}.xc\"\n";
	exit 1;
    }

    $thisfile = "$file.xc";
    &ReadFile();

    close(IN);
}

@allclasses = sort(@allclasses);

print "\n(define classes\n  (list";
foreach $class (@allclasses)
{
    print "\n    $class";
}
print "))\n\n";

sub DoPrintClass 
{
    return if ($testfile || $common);

    if ($global) {
	$classstring = ${globalname};
    
        if ($notest{$classstring}) {
	    return;
	}

    $classstring = "'$classstring";

	$oldclass = "#f";
    } else {
	$classstring = &StripQuotes($classstring);

	if ($notest{$oldclass}) {
	    return;
	}

	$oldclass = "${oldclass}!-example-list";
    }

    
    if ($classstring =~ /media/) {
	print "(unless skip-media?\n ";
    }

    print "(hash-table-put! classinfo ${classstring}\n";
    print "  (list ${oldclass} (quote ${classstring})";

    print "\n    (list";
    foreach $creator (@creators) {
	&ReadFields($dummyfields . $creator);
	print "\n      (list";
        @scms = @schemes;
	foreach $paramtype (@paramtypes) {
	    $scheme = shift(@scms);
	    if ($scheme) { 
		print " ";
		&PrintType(${paramtype});
	    }
	}
	print ")";
    }
    print ")";

    foreach $function (@functions) {
	&ReadFields($function);
	$fname = &StripQuotes($fname);
        
        $key = $classstring . "::" . $fname;

        if ($danger{$key}) {
        } else {
	    print "\n    (list '$fname ";
	    
           &PrintType(${returntype});

	   @scms = @schemes;
	   foreach $paramtype (@paramtypes) {
	       $scheme = shift(@scms);
	       if ($scheme) {
		   print " ";
		   &PrintType(${paramtype});
	       }
	   } 
	   print ")";
        }
    }

    foreach $ivar (@ivars) {
	&ReadIvarFields($ivar);
	$iname = &StripQuotes($iname);

	print "\n    (list 'get-${iname} ";
	&PrintType(${itype});
        print ")";

	if (!$readonly) {
            print "\n    (list 'set-${iname} void-example-list ";
	    &PrintType(${itype});
            print ")";
	}
    }

    if ($classstring =~ /media/) {
      print ")";
    }

    print "))\n";

    push(@allclasses, $classstring);
}

sub PrintType 
{
    local($type) = @_;
    
    $type =~ s/\[\]/ARRAY/g;
    $type =~ s/SYM\[([^\]]*)\]/SYM-\1/g;

    print "${type}-example-list";
}

sub StripQuotes
{
    return substr($_[0], 1, length($_[0]) - 2);
}

sub IgnoreLine
{
}

sub PrintHeader
{
}

sub PrintDefine
{
}

sub PrintSymSet
{
    local ($name, $kind, @syms) = @_;
    local ($multi, $vv, $lname);

    print "(define SYM-${name}-example-list (make-object example-list\% 'SYM-${name} null))\n";
    
    if ($kind =~ /ONE/) {
	$multi = 0;
    } else {
	$multi = 1;
	print "(add-all-combinations\n SYM-${name}-example-list\n (list";
    }

    foreach $sym (@syms) {
	($n, $v) = split(/,/, $sym);
	$n = &StripQuotes($n);
	if ($multi) {
	    print "\n  '$n";
	} else {
	    print "(send SYM-${name}-example-list add '$n)\n";
	}
    }
    
    if ($multi) {
	print "))\n";
    }
}

