head	1.2;
access;
symbols
	RELENG_2_2_8_RELEASE:1.1
	RELENG_2_2_7_RELEASE:1.1
	RELENG_2_2_6_RELEASE:1.1
	RELENG_2_2_5_RELEASE:1.1
	RELENG_2_2_2_RELEASE:1.1
	RELENG_2_2_1_RELEASE:1.1
	RELENG_2_2_0_RELEASE:1.1
	RELENG_2_1_7_RELEASE:1.1
	RELENG_2_1_6_1_RELEASE:1.1
	RELENG_2_1_6_RELEASE:1.1
	RELENG_2_2:1.1.0.6
	RELENG_2_2_BP:1.1
	RELENG_2_1_5_RELEASE:1.1
	RELENG_2_1_0_RELEASE:1.1
	RELENG_2_1_0:1.1.0.4
	RELENG_2_1_0_BP:1.1
	RELENG_2_0_5_RELEASE:1.1
	RELENG_2_0_5:1.1.0.2
	RELENG_2_0_5_BP:1.1
	RELENG_2_0_5_ALPHA:1.1;
locks; strict;
comment	@# @;


1.2
date	98.09.09.06.49.31;	author markm;	state dead;
branches;
next	1.1;

1.1
date	95.03.24.04.33.52;	author jkh;	state Exp;
branches;
next	;


desc
@@


1.2
log
@Old Perl is leaving us. Goodbye, faithful friend.
@
text
@#!/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;
    }
}
@


1.1
log
@Bring back perl/usub as usub/, this time containing an updated curseperl
which is also installed by default (the reason for which should also be
plain shortly).
@
text
@@
