#!/usr/local/bin/perl

# Copyright (c) 1996 Matthew Flatt
#
# Make Spidey signature files from .xc info

# 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);

require "parse.pl";
require "common.pl";

$dummyfields = " \"initialization\" : x create";

if ($ARGV[0] eq '-v') {
    shift(@ARGV);
    $verbose = 1;
} else {
    $verbose = 0;
}

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

    print STDERR "$file\n" if ($verbose);

    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);
}

sub IgnoreLine
{
}

sub PrintHeader
{
}

sub PrintDefine
{
}

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

    if ($global) {
	$define = "\n(define ";
	$close = ")";
    } else {
	$classstring = &StripQuotes($classstring);
	if ($parentstring eq "") {
	    $parentstring = "null";
	} else {
	    $parentstring = &StripQuotes($parentstring);
	}
	print "(define ${classstring}\n  (class $parentstring\n";

	print "    ()\n" if ($#creators < 0);
	foreach $creator (@creators) {
	    print "    (";
	    
	    &ReadFields($dummyfields . $creator);
            @scms = @schemes;
	    @defvs = @defvals;
	    @spids = @spideytypes;
	    $pos = 0;
	    foreach $param (@paramtypes) {
		$defval = shift(@defvs);
		$scheme = shift(@scms);
		$spidey = shift(@spids);
		
		if ($scheme) {
		    if ($pos > 0) {
			print " ";
		    }
		    $pos += 1;
		    if ($defval ne '') {
			print "[init${pos} (type: ";
			&PrintType($param, $spidey);
			print ")]";
		    } else {
			print "|init${pos}-arg-";
			&PrintType($param, $spidey);
			print "|";
		    }
		}
	    }

	    print ")\n";
	}

	print "    (public";

        $define = "\n      [";
	$close = "]";
    }

    foreach $function (@functions) {
	&ReadFields($function);
	$fname = &StripQuotes($fname);
	
	print "${define}${fname} (type: (";

	@scms = @schemes;
	@defvs = @defvals;
	@spids = @spideytypes;
	foreach $param (@paramtypes) {
	    $defval = shift(@defvs);
	    $scheme = shift(@scms);
	    $spidey = shift(@spids);
	    
	    if ($scheme) {
		print "optional " if ($defval ne '');
		&PrintType($param, $spidey);
		print " ";
	    }
	}

	print "-> ";

	&PrintType($returntype, $returnspideytype);

	print "))${close}";
    }

    foreach $ivar (@ivars) {
	&ReadIvarFields($ivar);

	$iname = &StripQuotes($iname);

	print "${define} get-${iname} (type: (-> ";
	&PrintType($itype, "");
	print "))${close}";
	
	if (!$readonly) {
	    print "${define} get-${iname} (type: (";
	    &PrintType($itype, "");
	    print " -> void))${close}";
	}
    }

    if (!$global) {
	print ")))\n";
    }

    foreach $constant (@constants) {
	&ReadConstFields($constant);
	$const = &StripQuotes($const);

	print "(define $const (type: ";
	&PrintType($ctype, "");
	print "))\n";
    }
}

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

sub PrintType
{
    local($type, $macro) = @_;

    if (($macro ne undef) && ($macro ne '')) {
	print &ApplyMacros($macro, "");
    } elsif (substr($type, 0, 7) eq 'unknown') {
	print "anything";
    } elsif ((substr($type, -1) eq '*')
	     || (substr($type, -1) eq '&')
	     || (substr($type, -1) eq '+')) {
	substr($type, -1) = '';
	print "(box ";
	&PrintType($type);
	print ")";
    } elsif (substr($type, -1) eq '?') {
	substr($type, -1) = '';
	print "(union null (box ";
	&PrintType($type);
	print "))";
    } elsif (substr($type, -2) eq '[]') {
	substr($type, -2) = '';
	print "(listof ";
	&PrintType($type);
	print ")";
    } elsif ($type eq 'void') {
	print "void";
    } elsif ($type eq 'bool') {
	print "bool";
    } elsif (($type eq 'char') || ($type eq 'uchar')) {
	print "char";
    } elsif ($type eq 'int' || $type eq 'unsigned') {
	print "num";
    } elsif ($type eq 'short') {
	print "num";
    } elsif ($type eq 'byte' || $type eq 'ubyte') {
	print "num";
    } elsif ($type eq 'long' || $type eq 'Long') {
	print "num";
    } elsif (($type eq 'float') || ($type eq 'double')
	     || ($type eq 'Double')) {
	print "num";
    } elsif (($type eq 'string') || ($type eq 'cstring')
	     || ($type eq 'custring') || ($type eq 'ustring')
	     || ($type eq 'ncustring') || ($type eq 'nustring')
	     || ($type eq 'nstring') || ($type eq 'ncstring')) {
	print "str";
    } elsif ((substr($type, -1) eq '!') || (substr($type, -1) eq '%')) {
	substr($type, -1) = '';
	&PrintObjectType($type);
    } elsif (substr($type, -1) eq '^') {
	substr($type, -1) = '';
	print "(union null ";
	&PrintObjectType($type);
	print ")";
    } else {
	print STDERR "Unknown type ${type} in $func.\n";
	print "???";
    }
}

sub PrintObjectType
{
    local($type) = @_;

    print "${type}-object";
}
