#!/usr/local/bin/perl
# $Header: /private/postgres/src/contrib/pgperl/RCS/pg-mus,v 1.2 1991/03/08 13:22:34 kemnitz Exp $
# This perl-script take a "mus" file and converts it to C.
# Written by Larry Wall (?).
# Adapted for use with Postgres by Igor Metz <metz@iam.unibe.ch>

# $Id: pg-mus,v 1.2 1991/03/08 13:22:34 kemnitz Exp $
# $Log: pg-mus,v $
# Revision 1.2  1991/03/08  13:22:34  kemnitz
# added RCS header.
#
# Revision 1.1  90/10/24  20:31:14  cimarron
# Initial revision
# 
# Revision 1.2  90/08/23  14:17:39  metz
# o comments added
# 
# Revision 1.1  90/08/23  11:41:19  metz
# Initial revision
# 

while (<>) {
    if (s/^CASE\s+//) {
	@fields = split;
	$funcname = pop(@fields);
	$rettype = "@fields";
	@modes = ();
	@types = ();
	@names = ();
	@outies = ();
	@callnames = ();
	$pre = "\n";
	$post = '';

	while (<>) {
	    last unless /^[IO]+\s/;
	    @fields = split(' ');
	    push(@modes, shift(@fields));
	    push(@names, pop(@fields));
	    push(@types, "@fields");
	}
	while (s/^<\s//) {
	    $pre .= "\t    $_";
	    $_ = <>;
	}
	while (s/^>\s//) {
	    $post .= "\t    $_";
	    $_ = <>;
	}
	$items = @names;
	$namelist = '$' . join(', $', @names);
	$namelist = '' if $namelist eq '$';
	print <<EOF;
    case US_$funcname:
	if (items != $items)
	    fatal("Usage: &$funcname($namelist)");
	else {
EOF
	if ($rettype eq 'void') {
	    print <<EOF;
	    /* int retval = 1; */
EOF
	}
	else {
	    print <<EOF;
	    $rettype retval;
EOF
	}
	foreach $i (1..@names) {
	    $mode = $modes[$i-1];
	    $type = $types[$i-1];
	    $name = $names[$i-1];
	    $what = ($type =~ /^(struct\s+\w+|char|\w+)\s*\*$/ ? "get" : "gnum");
	    $type .= "\t" if length($type) < 4;
	    $cast .= "\t" if length($cast) < 8;
	    $x = "\t" x (length($name) < 6);
	    if ($mode =~ /O/) {
		if ($what eq 'gnum') {
		    push(@outies, "\t    str_numset(st[$i], (double) $name);\n");
		}
		else {
		    push(@outies, "\t    str_set(st[$i], (char*) $name);\n");
		}
		push(@callnames, "&$name");
	    }
	    else {
		push(@callnames, $name);
	    }
	    if ($mode =~ /I/) {
  	      if ($type =~ /^char\*$/) {
	          # no special handling necessary
		  print <<EOF;
	    $type	$name =$x	str_get(st[$i]);
EOF
	      }
	      elsif ($type =~ /^\w+\*$/) {
		  print <<EOF;
	    $type	$name =$x ($type) dbl2uint(str_gnum(st[$i]));
EOF
	      }
	      else {
		  print <<EOF;
	    $type	$name =$x ($type) dbl2uint(str_gnum(st[$i]));
EOF
	      }
           }
	}
	$callnames = join(', ', @callnames);
	$outies = join("\n",@outies);
	if ($rettype eq 'void') {
	    print <<EOF;
$pre	    (void)$funcname($callnames);
EOF
	}
	else {
	    print <<EOF;
$pre	    retval = $funcname($callnames);
EOF
	}

	if ($rettype =~ /^char\s*\*$/) {  # char*
	    print <<EOF;
	    str_set(st[0], retval);
EOF
        }
	elsif ($rettype =~ /^\s*void\s*$/) { # void
	    print <<EOF;
	    str_numset(st[0], 1.0);
EOF
	}
	elsif ($rettype =~ /^\w+\s*\*+$/) { # anyothertype*
	    print <<EOF;
	    str_numset(st[0],  uint2dbl((unsigned int) retval));
EOF
        }
	elsif ($rettype =~ /^(char|short|int|unsigned\s+int|signed\s+int)$/) {
	    print <<EOF;
	    str_numset(st[0],  uint2dbl((unsigned int) retval));
EOF
	}
	else { # ($rettype =~ /^\w+\s*$/) 
	    print <<EOF;
	    str_nset(st[0], (char*) &retval, sizeof(retval));
EOF
	}
	print $outies if $outies;
	print $post if $post;
	if (/^END/) {
	    print "\t}\n\treturn sp;\n";
	}
	else {
	    redo;
	}
    }
    elsif (/^END/) {
	print "\t}\n\treturn sp;\n";
    }
    else {
	print;
    }
}
