1 files changed, 135 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/perl/usub/mus b/gnu/usr.bin/perl/perl/usub/mus
new file mode 100755
index 0000000..b1675fd
--- /dev/null
+++ b/gnu/usr.bin/perl/perl/usub/mus
@@ -0,0 +1,135 @@
+#!/usr/bin/perl
+
+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];
+	    if ($type =~ /^[A-Z]+\*$/) {
+		$cast = "*($type*)";
+	    }
+	    else {
+		$cast = "($type)";
+	    }
+	    $what = ($type =~ /^(struct\s+\w+|char|[A-Z]+)\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");
+		    push(@callnames, "&$name");
+		}
+		else {
+		    push(@outies, "\t    str_set(st[$i], (char*) $name);\n");
+		    push(@callnames, "$name");
+		}
+	    }
+	    else {
+		push(@callnames, $name);
+	    }
+	    if ($mode =~ /I/) {
+	    print <<EOF;
+	    $type	$name =$x	$cast	str_$what(st[$i]);
+EOF
+	    }
+            elsif ($type =~ /char/) {
+            print <<EOF;
+	    char	${name}[133];
+EOF
+	    }
+	    else {
+		print <<EOF;
+	    $type	$name;
+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 =~ /^(struct\s+\w+|char)\s*\*$/) {
+	    print <<EOF;
+	    str_set(st[0], (char*) retval);
+EOF
+	}
+	elsif ($rettype =~ /^[A-Z]+\s*\*$/) {
+	    print <<EOF;
+	    str_nset(st[0], (char*) &retval, sizeof retval);
+EOF
+	}
+	else {
+	    print <<EOF;
+	    str_numset(st[0], (double) 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;
+    }
+}