#!/usr/local/bin/perl

# Copyright (c) 1995 Matthew Flatt

# This file reads C++ class descriptsions from files ending in ".xc".
# It produces a C++ file suitable for linking with libscheme plus
# objscheme.cc.

# See xctocc.dvi for information about using this program.

# No one should write code like this. It's horrible. It's immoral.
#
# Still, it works well enough for now.

############################################################

# Overall file parsing

$key_include = '@INCLUDE ';
$key_boolean = '@BOOLEAN ';
$key_classbase = '@CLASSBASE ';
$key_interface = '@INTERFACE ';
$key_classid = '@CLASSID ';
$key_global = '@GLOBAL ';
$key_header = '@HEADER ';
$key_end = '@END ';
$key_stop = '@STOP ';
$key_creator = '@CREATOR ';
$key_creatorx = '@CREATORX ';
$key_macro = '@MACRO ';
$key_var = '@VAR ';
$key_set = '@SET ';
$key_define = '@DEFINE ';
$key_ifdefine = '@IFDEFINE ';
$key_ivar = '@IVAR ';
$key_constant = '@CONSTANT ';
$key_suffix = '@CLASSSUFFIX ';
$key_test = '@TEST ';
$key_setmark = '@SETMARK ';
$key_idfield = '@IDFIELD ';
$key_startsymbols = '@BEGINSYMBOLS ';
$key_endsymbols = '@ENDSYMBOLS ';
$key_sym = '@SYM ';
$key_argnames = '@ARGNAMES ';

sub ResetObjParams 
{
    @functions = ();
    @funcnames = ();
    @vars = ();
    @ivars = ();
    @creators = ();
    $iargnames = 'BYPOS';
    @distinct_creators = ();
    @constants = ();
    %justoneok = ();
    %justonemin = ();
    %justonemax = ();
    $globalname = '';
    $classid = '';
    $global = 0;
    $implementor = "";
    $interfacestring = "";
}

&ResetObjParams();

sub ReadFile {
    @openfiles = ();
    $stop = 0;
    $linenum = 0;
    $filepos = 0;
    $testfile = 0;
    $classsuffix = '';
    $idfield = '';
    $bool = 'boolean';
    $cursymset = '';
    %macros = ();
    %sets = ();
    %marks = ();
    @syms = ();
    $symsetkind = "";
    $symsetomit = "";
    $marks{'V'} = 'V';
    $marks{'H'} = 'H';
    $marks{'v'} = 'v';
    $marks{'m'} = 'm';
    $ifzero = 0;

    open(SOUT, ">${file}.ss");

    while(!$stop)
    {
	$_ = <IN>;
	$linenum += 1;
	$filepos += length($_);
	if ($_ eq undef) {
	    if ($#openfiles >= 0) {
		close(IN);
		$oldin = pop(@openfiles);
		$p = index($oldin, ":");
		$linenum = substr($oldin, 0, $p);
		$oldin = substr($oldin, $p + 1); 
		$p = index($oldin, ":");
		$filepos = substr($oldin, 0, $p);
		$thisfile = substr($oldin, $p + 1); 
		open(IN, "$thisfile");
		if ($filepos > 0) {
		    seek(IN, $filepos, 0);
		} else {
		    seek(IN, 0, 2);
		}
	    } else {
		$stop = 1;
	    }
	} elsif ($ifzero) {
           if (/^\#endif/) {
	       $ifzero -= 1;
	   } elsif (/^\#if/) {
	       $ifzero += 1;
	   }
        } elsif (/^\@/) {
	    chop;
	    $_ = $_ . " ";
	    if (&StartsWithKey($_, $key_include)) {
		$_ = &SkipKey($_, $key_include);
		$incfile = &Wash($_);
		$oldin = $linenum . ":" . $filepos . ":" . $thisfile;
		$thisfile =~ /^((.*\/)|)([^\/]*)$/;
		$incpath = $1;
		if (!open(IN2, "$incpath$incfile")) {
		    print STDERR "Couldn't open \"${incfile}\"\n";
		} else {
		    $thisfile = "$incpath$incfile";
		    $linenum = 0;
		    $filepos = 0;
		    push(@openfiles, $oldin);
		    close(IN);
		    open(IN, "<&IN2");
		}
	    } elsif (&StartsWithKey($_, $key_boolean)) {
		$bool = &Wash(&SkipKey($_, $key_boolean));
	    } elsif (&StartsWithKey($_, $key_test)) {
		$testfile = 1;
	    } elsif (&StartsWithKey($_, $key_classbase)) {
		&ResetObjParams();
		$_ = &Wash(&SkipKey($_, $key_classbase));
		$pos = index($_, ' ');
		$base = substr($_, 0, $pos);
		($base,$mkbase) = split(/=/, $base, 2);
		if ($mkbase eq '') {
		    $mkbase = $base;
		}
		$classstring = substr($_, $pos);
		$base = &Wash($base);
		$mkbase = &Wash($mkbase);
		($classstring,$classflags) = split(/\//, $classstring, 2);
		($classstring,$parentstring) = &SplitColon($classstring);
		$classstring = '"' . &Unquote(&Wash($classstring))
		    . &Unquote($classsuffix) . '"';
		$parentstring = &Wash($parentstring);
		if ($parentstring ne '') {
		    $parentstring = '"' . &Unquote($parentstring)
			. &Unquote($classsuffix) . '"';
		}
		$classflags = &Wash($classflags);
		$oldclass = $base;
		$oldclassmk = $mkbase;
		$newclass = 'os_' . $base;
	    } elsif (&StartsWithKey($_, $key_interface)) {
		$_ = &Wash(&SkipKey($_, $key_classbase));
		$interfacestring =$_;
	    } elsif (&StartsWithKey($_, $key_global)) {
		&ResetObjParams();
		$global = 1;
		$globalname = &Wash(&SkipKey($_, $key_global));
	    } elsif (&StartsWithKey($_, $key_idfield)) {
		$idfield = &Wash(&SkipKey($_, $key_idfield));
	    } elsif (&StartsWithKey($_, $key_classid)) {
		$classid = &Wash(&SkipKey($_, $key_classid));
	    } elsif (&StartsWithKey($_, $key_header)) {
		&PrintHeader();
	    } elsif (&StartsWithKey($_, $key_end)) {
		&DoPrintClass();
	    } elsif (&StartsWithKey($_, $key_stop)) {
		$stop = 1;
	    } elsif (&StartsWithKey($_, $key_creator)) {
		$creator = &SkipKey($_, $key_creator);
		@creators = (@creators, $creator);
		@distinct_creators = (@distinct_creators, $creator);
	    } elsif (&StartsWithKey($_, $key_creatorx)) {
		$creator = &SkipKey($_, $key_creatorx);
		@creators = (@creators, $creator);
	    } elsif (&StartsWithKey($_, $key_argnames)) {
		$iargnames = &SkipKey($_, $key_argnames);
		$iargnames = &Wash($iargnames);
	    } elsif (&StartsWithKey($_, $key_macro)) {
		$s = &Wash(&SkipKey($_, $key_macro));
		$eqpos = index($s, '=');
		$parenpos = index($s, '[');
		if ($parenpos >= $[ && $parenpos < $eqpos) {
		    $macro = substr($s, 0, $parenpos);
		} else {
		    $macro = substr($s, 0, $eqpos);
		}
		$macro = &Wash($macro);
		$macros{$macro} = $s;
	    } elsif (&StartsWithKey($_, $key_var)) {
		@vars = (@vars, &Wash(substr($_, 4)));
	    } elsif (&StartsWithKey($_, $key_set)) {
		($var, $val) = split(/=/, &SkipKey($_, $key_set));
		$var = &Wash($var);
		$val = &Wash($val);
		$sets{$var} = $val;
	    } elsif (&StartsWithKey($_, $key_define)) {
		($var, $val) = split(/=/, &SkipKey($_, $key_define));
		$var = &Wash($var);
		$val = &Wash($val);
		&DefineVar($var, $val);
	    } elsif (&StartsWithKey($_, $key_ifdefine)) {
		($var, $val) = split(/=/, &SkipKey($_, $key_ifdefine), 2);
		$var = &Wash($var);
		($test, $val1, $val2) = &SplitColon($val);
		if ($sets{&Wash($test)} > 0) {
		    $val = $val1;
		} else {
		    $val = $val2;
		}
		$val = &Wash($val);
		&DefineVar($var, $val);
	    } elsif (&StartsWithKey($_, $key_ivar)) {
		@ivars = (@ivars, &Wash(&SkipKey($_, $key_ivar)));
	    } elsif (&StartsWithKey($_, $key_constant)) {
		@constants = (@constants, &Wash(&SkipKey($_, $key_constant)));
	    } elsif (&StartsWithKey($_, $key_suffix)) {
		$classsuffix = &Wash(&SkipKey($_, $key_suffix));
	    } elsif (&StartsWithKey($_, $key_setmark)) {
		($mark, $val) = split(/=/, &SkipKey($_, $key_setmark), 2);
		$mark = &Wash($mark);
		$marks{$mark} = &Wash($val);
	    } elsif (&StartsWithKey($_, $key_startsymbols)) {
		($name, $kind, $omit) = split(/>/, &SkipKey($_, $key_startsymbols), 3);
		$name = &Wash($name);
		@syms = ();
		$cursymset = $name;
		$symsetkind = $kind;
		$symsetomit = $omit;
	    } elsif (&StartsWithKey($_, $key_sym)) {
		($name, $val) = split(/:/, &SkipKey($_, $key_sym), 2);
		$name = &Wash($name);
		$val = &Wash($val);
		@syms = (@syms, "$name,$val");
	    } elsif (&StartsWithKey($_, $key_endsymbols)) {
		&PrintSymSet($cursymset, $symsetkind, $symsetomit, @syms);
	    } elsif (substr($_, 1, 1) ne ' ') {
		print STDERR 
		    "syntax error at line $linenum of \"$thisfile\".\n"
		} else {
		    $function = &Wash(substr($_, 1));
		    $mark = substr($function, 0, 1);
		    if ($mark ne '"') {
			$mark = $marks{$mark};
			substr($function, 0, 1) = $mark;
		    }
		    @functions = ($function, @functions);
		    &ReadFields($function);
		    @funcnames = ($func, @funcnames);
		}
	} elsif (/^\#if 0/) {
	    $ifzero = 1;
	} else {
	    &IgnoreLine($_);
	}
    }

    close(OUT);

    # Finish up the file
    while(<IN>) { &IgnoreLine($_); }

    &PrintFooter();
}

sub StartsWithKey
{
    return (index($_[0], $_[1]) == $[);
}

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

sub Wash 
{
    $_[0] =~ /^ *(.*[^ ]) *$/;
    return $1;
}

sub SplitColon
{
    local($s) = @_;
    local($balance, @ans, $a, $c);
    
    $balance = 0;
    $a = '';
    @ans = ();
    while ($s ne '') {
	$c = substr($s, 0, 1);
	if (!$balance && $c eq ':') {
	    @ans = (@ans, $a);
	    $a = '';
	} else {
	    $a = $a . $c;
	}

	if ($c eq '"') {
	    $balance = !$balance;
	} 
	$s = substr($s, 1);
    }
    @ans = (@ans, $a) if ($a ne '');

    return @ans;
}

sub ReadFields {

    ($s) = @_;

    $virtual = $virtualonly = $hidden = $delegate = $externalmethod = $phantom = 0;

    $mark = substr($s, 0, 1);
    if ($mark ne '"') {
	substr($s, 0, 1) = '';
    }

    if ($mark eq 'p') {
	$phantom = 1;
    } elsif ($mark eq 'V') {
	$virtual = $virtualonly = 1;
    } elsif ($mark eq 'v') {
	$virtual = 1;
    } elsif ($mark eq 'H') {
	$virtual = $virtualonly = $hidden = 1;
    } elsif ($mark eq 'd') {
	$virtual = 1;
    } elsif ($mark eq 'm') {
	$externalmethod = 1;
    }

    ($s, $casename) = split(/<>/, $s);
    if ($casename eq "") {
	($s, $onlyif) = split(/##/, $s);
    } else {
	($casename, $onlyif) = split(/##/, $casename);
    }

    $casename = &Wash($casename);

    ($fname, $s, $methodpostmacros, $gluepostmacros, $exception, $vexception, $implementor) 
	= &SplitColon($s);
    
    $s = &Wash($s);

    $p = index($s, ' ');
    $returntype = substr($s, 0, $p);
    $s = substr($s, $p + 1);

    $p = index($s, '(');
    $func = substr($s, 0, $p);
    $s = substr($s, $p + 1);

    $p = rindex($s, ')');
    $s = substr($s, 0, $p);

    @defvals = ();
    @bundles = ();
    @unbundles = ();
    @typechecks = ();
    @typeids = ();
    @schemes = ();
    @schemeparams = ();
    @spideytypes = ();
    @pushables = ();
    @paramtypes = split(/,/, $s);
    $numschemes = 0;
    foreach $paramtype (@paramtypes) {
	($paramtype, $bundle, $unbundle, $typecheck, $typeid, $spideytype, $pushable) 
	    = split('/', $paramtype);

	($paramtype, $defval) = split(/=/, $paramtype);
	$paramtype = &Wash($paramtype);
	if (substr($paramtype, 0, 1) eq '-') {
	    $paramtype = substr($paramtype, 1);
	    $scheme = 0;
	} else {
	    $scheme = 1;
	}
	$defval = &Wash($defval);
	$bundle = &Wash($bundle);
	$unbundle = &Wash($unbundle);
	$typecheck = &Wash($typecheck);
	$typeid = &Wash($typeid);
	$spideytype = &Wash($spideytype);
	$pushable = &Wash($pushable);

	@defvals = (@defvals, $defval); 
	@bundles = (@bundles, $bundle);
	@unbundles = (@unbundles, $unbundle);
	@typechecks = (@typechecks, $typecheck);
	@typeids = (@typeids, $typeid);
	@spideytypes = (@spideytypes, $spideytype);
	@pushables = (@pushables, $pushable);
	@schemes = (@schemes, $scheme);
	if ($scheme) {
	    @schemeparams = (@schemeparams, $paramtype);
	    $numschemes += 1;
	}
    }

    ($returntype, $returnbundle, $returnunbundle, $returnspideytype, $returnpushable) = split('/', $returntype);

    $func = &Wash($func);
    $fname = &Wash($fname);
    $returntype = &Wash($returntype);
    $returnbundle = &Wash($returnbundle);
    $returnunbundle = &Wash($returnunbundle);
    $returnpushable = &Wash($returnpushable);

    ($methpre, $methprecall, $methpostcall, $methpost) 
	= split('/', $methodpostmacros);
    ($gluepre, $glueprecall, $gluepostcall, $gluepost, $gluepostschemebind) 
	= split('/', $gluepostmacros);

    $methpre = &Wash($methpre);
    $methprecall = &Wash($methprecall);
    $methpost = &Wash($methpost);
    $methpostcall = &Wash($methpostcall);

    $gluepre = &Wash($gluepre);
    $glueprecall = &Wash($glueprecall);
    $gluepost = &Wash($gluepost);
    $gluepostcall = &Wash($gluepostcall);
    $gluepostschemebind = &Wash($gluepostschemebind);

    if ($virtualonly && ($vexception ne '')) {
	$exception = &Wash($vexception);
    } else {
	$exception = &Wash($exception);
    }
    if ($exception eq '') {
	$exception = 'SUPER';
    }

    if ($classstring eq '') {
	$method = $fname;
    } else {
	if ($interfacestring eq '') {
	    $sourcestring = $classstring;
	} else {
	    $sourcestring = substr($interfacestring, 0, length($interfacestring) - 1) . '<%>"';
	}
	$method = '"' . substr($fname, 1, length($fname) - 2) . " in "
	    . substr($sourcestring, 1, length($sourcestring) - 2) . '"';
    }
}

sub ReadIvarFields
{
    local($s) = @_;

    $readonly = 0;

    ($s, $onlyif) = split(/##/, $s);

    if (substr($s, 0, 1) eq 'r') {
	$readonly = 1;
    }

    substr($s, 0, 1) = '' if $readonly;
    
    ($iname, $itype) = &SplitColon($s);
    ($itype, $ivarname) = split(/ /, &Wash($itype));

    $iname = &Wash($iname);
    $getname = substr($iname, 1);
    substr($getname, -1) = '';
    $setname = "\"set-" . $getname . "\"";
    $getname = "\"get-" . $getname . "\"";

    $ivartype = &Wash($itype);
    $ivarname = &Wash($ivarname);

    $method = 'et-' . substr($iname, 1, length($iname) - 2) 
	    . " in " . substr($classstring, 1, length($classstring) - 2) . '"';

    $longsetname = '"s' . $method;
    $longgetname = '"g' . $method;
    $method = $longsetname;
}

sub ReadConstFields
{
    local($s) = @_;

    ($s, $onlyif) = split(/##/, $s);

    ($const, $ctype) = &SplitColon($s);
    ($ctype, $cname) = split(/ /, &Wash($ctype));

    $const = &Wash($const);
    $ctype = &Wash($ctype);
    $cname = &Wash($cname);
}

sub DefineReplace
{
    local($val) = @_;

    while ($val =~ /<([^>]*)>/ ) {
	$subval = $sets{$1};
	$val =~ s/<[^>]*>/$subval/;
    }

    return $val;
}

sub DefineVar
{
    local($var, $val) = @_;

    $val = &DefineReplace($val);
    &PrintDefine("#define $var $val\n");
}

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

sub Sprintfify
{
    $_[0] =~ s/%/%%/g;
}

sub ApplyMacro
{
    local($name, $var, $var2) = @_;

    if (($name eq '') || ($name eq undef)) {
	return "";
    }

    local($pos, @args, @argnames, $arg);
    $pos = index($name, '[');
    if ($pos >= $[) {
	$arg = substr($name, $pos + 1);
	$name = substr($name, 0, $pos);
	$pos = index($arg, ']');
	$arg = substr($arg, 0, $pos);
	@args = split(/\./, $arg);
    } else {
	@args = ();
    }

    $macro = $macros{$name};

    if ($macro eq undef) {
	print STDERR "Unknown macro $name in $func.\n";
	return "";
    }

    $pos = index($macro, '=');

    $m = substr($macro, $pos + 1);
    $macro = substr($macro, 0, $pos);
    $pos = index($macro, '[');
    if ($pos >= $[) {
	$arg = substr($macro, $pos + 1);
	$pos = index($arg, ']');
	$arg = substr($arg, 0, $pos);
	@argnames = split(/\./, $arg);
    } else {
	@argnames = ();
    }
    
    $m =~ s/{x}/$var/g;
    $m =~ s/{s}/$var2/g;

    if ($#argnames != $#args) {
	print STDERR "Bad parameter ("
	    . ($#args + 1)
	    . " for "
	    . ($#argnames + 1)
	    . ") count to macro $name in $func.\n";
	return "";
    }

    foreach $name (@argnames) {
	$arg = shift(@args);
	$name = &Wash($name);
	$arg = &Wash($arg);
	$m =~ s/<${name}>/$arg/g;
    }

    $m = &Wash($m);

    while (substr($m, 0, 2) eq '$$') {
	if (substr($m, 2, 1) eq '>') {
	    $m = &DefineReplace(substr($m, 3));
	} else {
	    $m = &ApplyMacro(substr($m, 2), "", "");
	}
    }

    return $m;
}

sub ApplyMacros
{
    local($macrolist, $var, $var2) = @_;

    @macros = split(/\|/, $macrolist);
    $str = '';
    foreach $macro (@macros) {
	$str = $str . &ApplyMacro(&Wash($macro), $var, $var2);
    }

    return $str;
}


sub Desymbol
{
    local($t, $e) = @_;

    $e = substr($t, -1);
    if ($e eq '*') {
	substr($t, -1) = '';
	return &Desymbol($t) . "P";
    }
    if ($e eq '&') {
	substr($t, -1) = '';
	return &Desymbol($t) . "A";
    }
    if ($e eq '?') {
	substr($t, -1) = '';
	return &Desymbol($t) . "Q";
    }
    if ($e eq '!') {
	substr($t, -1) = '';
	return &Desymbol($t) . "PT";
    }
    if ($e eq '^') {
	substr($t, -1) = '';
	return &Desymbol($t) . "NP";
    }
    if ($e eq '%') {
	substr($t, -1) = '';
	return &Desymbol($t) . "AD";
    }
    if ($e eq ']') {
	$badflag = 1;
	return "XXX";
    }

    return $t;
}

############################################################

$cc_suffix = "cc";

if ($ARGV[0] eq '-cxx') {
    $cc_suffix = "cxx";
    shift(@ARGV);
}

$file = $infile = $ARGV[0];

if ($file =~ s/.xc$//) {
} else {
    print STDERR "Bad extension \"$infile\".\n";
    exit 1;
}

if (!open(IN, "$file.xc")) {
    print STDERR "Couldn't open \"${file}.xc\"\n";
    exit 1;
}

if (!open(OUT, ">${file}.${cc_suffix}")) {
    print STDERR "Couldn't write \"${file}.${cc_suffix}\"\n";
    exit 1;
}

if (!open(HEADER, ">${file}.h")) {
    print STDERR "Couldn't write \"${file}.h\"\n";
    exit 1;
}

$setup_d_start = "#ifndef WXS_SETUP_ONLY\n";
$setup_d_end = "#endif\n";

print HEADER $setup_d_start;

select(OUT);

$base = '';

$dummyfields = " \"initialization\" : x create";
$scheme_args = "int n,  Scheme_Object *p[]";
$global_scheme_args = "int n,  Scheme_Object *p[]";

$file =~ /([^\/]*)$/;
$filenopath = $1;

print "/* DO NOT EDIT THIS FILE. */\n";
print "/* This file was generated by xctocc from \"${filenopath}.xc\". */\n\n";

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

print HEADER $setup_d_end;

close(IN);
close(OUT);
close(HEADER);

sub IgnoreLine
{
    print $_[0];
}

sub PrintHeader
{
    print "#include \"wxscheme.h\"\n";
    print "#include \"${filenopath}.h\"\n";
    print "\n";

    print "#ifdef MZ_PRECISE_GC\n";
    print "START_XFORM_SKIP;\n";
    print "#endif\n";
}

sub PrintFooter
{
    print "#ifdef MZ_PRECISE_GC\n";
    print "END_XFORM_SKIP;\n";
    print "#endif\n";
}

sub PrintDefine
{
    print $_[0];
}

sub DoPrintClass 
{

    if (!$global) {
	$globalname = "";

	print "class ${newclass} : public ${oldclassmk} {\n";
	print " public:\n";
	foreach $var (@vars) {
	    print "  $var\n";
	}

	print "\n";

	# Print creation prototypes:
	if ($#distinct_creators >= 0) {
	    $did_one_creator = 0;
	    foreach $creator (@distinct_creators) {
		&ReadFields($dummyfields . $creator);
		if ($did_one_creator) {
		    printf "#ifndef MZ_PRECISE_GC\n";
		}
		print "  ${newclass} CONSTRUCTOR_ARGS((";
		&PrintParams(1);
		print "));\n";
		if ($did_one_creator) {
		    printf "#endif\n";
		}
		$did_one_creator = 1;
	    }
	}

	# destruction
	print "  ~${newclass}();\n";
    } else {
	$newclass = "";

	select(HEADER);
    }

    # Print method prototypes
    if (!$global) {
	$pos = 0;
	foreach $function (@functions) {
	    if (!&Overridden($function, $pos)) {
		&ReadFields($function);
		if ($virtual) {
		    &OIStart;
		    print "  " . &NormalType($returntype) 
			. " ${globalname}${func}(";
		    &PrintParams(1);
		    print ");\n";
		    &OIEnd;
		}
	    }
	    $pos += 1;
	}
    }

    if (!$global) {
	print "#ifdef MZ_PRECISE_GC\n";
	print "  void gcMark();\n";
	print "  void gcFixup();\n";
	print "#endif\n";

	print "};\n\n";

	print "#ifdef MZ_PRECISE_GC\n";
	print "void ${newclass}::gcMark() {\n";
	print "  ${oldclassmk}::gcMark();\n";
	foreach $var (@vars) {
	    if ($var =~ /(.*[*])(.*);/) {
		print "  gcMARK_TYPED($1, $2);\n";
	    }
	}
	print "}\n";
	
	print "void ${newclass}::gcFixup() {\n";
	print "  ${oldclassmk}::gcFixup();\n";
	foreach $var (@vars) {
	    if ($var =~ /(.*[*])(.*);/) {
		print "  gcFIXUP_TYPED($1, $2);\n";
	    }
	}
	print "}\n";
	print "#endif\n\n";

	# End of class definition
    } else {
	select(OUT);
    }

    if ($global) {
	$POFFSET = "0";
    } else {
	$POFFSET = "POFFSET";
    }

    # Print class and interface decls:
    if (!$global) {
	print "static Scheme_Object *${newclass}_class;\n";
	if ($interfacestring ne '') {
	    print "static Scheme_Object *${newclass}_interface;\n";
	}
	print "\n";
    }

    if (!$global) {
	#Do creation methods
	if ($#distinct_creators >= 0) {
	    $did_one_creator = 0;
	    foreach $creator (@distinct_creators) {
		&ReadFields($dummyfields . $creator);
		if ($did_one_creator) {
		    printf "#ifndef MZ_PRECISE_GC\n";
		}
		&OIStart;
		print "${newclass}::${newclass} CONSTRUCTOR_ARGS((";
		&PrintParams(0);
		print "))\n";
		print "CONSTRUCTOR_INIT(: ${oldclassmk}(";
		&PrintArgs(1);
		print "))\n";
		print "{\n";
		print "}\n";
		&OIEnd;
		if ($did_one_creator) {
		    printf "#endif\n";
		}
		print "\n";
		$did_one_creator = 1;
	    }
	}

	# destruction
	print "${newclass}::~${newclass}()\n{\n  ";
	print "  objscheme_destroy(this, (Scheme_Object *) __gc_external);\n}\n\n";
    }

    #Do regular methods
    @funcs = ();
    $pos = 0;
    foreach $function (@functions) {
	if (!&Overridden($function, $pos)) {
	    &PrintMethod($function);
	    @l = grep($_ =~ /^$func$/, @funcs);
	    if ($#l < $[) {
		@funcs = (@funcs, $func);
	    }
	}
	$pos += 1;
    }

    ##Regular glue code

    foreach $func (@funcs) {
	&PrintFunction($func);
    }
    
    foreach $ivar (@ivars) {
	&ReadIvarFields($ivar);
	&OIStart;
	print "static Scheme_Object *objscheme_${oldclass}_Get${ivarname}(";
	print $scheme_args;
	print ")\n{\n  ";
	print "Scheme_Class_Object *cobj INIT_NULLED_OUT;\n  ";
	print &NormalType($ivartype, 1) . " v";
	print ";\n";
	print "  REMEMBER_VAR_STACK();\n\n";
	print "  objscheme_check_valid(${newclass}_class, $longgetname, n, p);\n";
	print "  if (n > POFFSET) WITH_REMEMBERED_STACK(scheme_wrong_count_m($longgetname, POFFSET, POFFSET, n, p, 1));\n";
	print "  cobj = (Scheme_Class_Object *)p[0];\n";
	print "  if (cobj->primflag)\n";
	print "    v = ";
	&PrintIndirect($ivartype);
	print "(($newclass *)cobj->primdata)->${oldclass}::${ivarname}";
	print ";\n  else\n    v = ";
	&PrintIndirect($ivartype);
	print "(($oldclass *)cobj->primdata)->${ivarname}";

	print ";\n\n  return ";
	&PrintBundleVar("v", $ivartype, "WITH_REMEMBERED_STACK", '', 1);
	print ";\n}\n";

	if (!$readonly) {
	    print "\nstatic Scheme_Object *objscheme_${oldclass}_Set${ivarname}(";
	    print $scheme_args;
	    print ")\n{\n  ";
	    print "Scheme_Class_Object *cobj = (Scheme_Class_Object *)p[0];\n  ";
	    print &NormalType($ivartype, 1) . " v";
	    print ";\n";
	    print "  SETUP_VAR_STACK(1);\n  VAR_STACK_PUSH(0, cobj);\n\n";
	    print "  WITH_VAR_STACK(objscheme_check_valid(${newclass}_class, $longsetname, n, p));\n";
	    print "  if (n != (POFFSET+1)) WITH_VAR_STACK(scheme_wrong_count_m($longsetname, POFFSET+1, POFFSET+1, n, p, 1));\n\n";
	    print "  v = ";
	    &PrintUnbundleVar("p[POFFSET]", $ivartype);
	    print ";\n  ";
	    if (substr($ivartype, -1) eq '%' || substr($ivartype, -1) eq '&') {
		print "memcpy(";
		print "&(($oldclass *)cobj->primdata)->${ivarname}";
		print ", v, sizeof(*v));\n";
	    } else {
		print "(($oldclass *)cobj->primdata)->${ivarname}";
		print " = v;\n\n";
	    }
	    print "  READY_TO_RETURN;\n  return scheme_void;\n}\n";
	}
	&OIEnd;
	print "\n";
    }

    ## General glue code

    if (!$global) {
	# Init function
	if ($#creators >= 0) {
	    @savefunctions = @functions;
	    @savefuncnames = @funcnames;
	    @functions = ();
	    @funcnames = ();
	    foreach $creator (@creators) {
		$function = $dummyfields . $creator;
		@functions = (@functions, $function);
		@funcnames = (@funcnames, "create");
	    }
	    &PrintFunction("create", 1);
	    @functions = @savefunctions;
	    @funcnames = @savefuncnames;
	}

	# Destroy function
	if (0) {
	    print "static Scheme_Object *objscheme_destroy_${newclass}(";
	    print $scheme_args;
	    print ")\n{\n";
	    print "  Scheme_Class_Object *cobj = (Scheme_Class_Object *)p[0];\n";
	    print "  if (n) scheme_signal_error(\"";
	    print "destroy: method takes no arguments";
	    print "\");\n";
	    print "  if (cobj->primflag > 1) return scheme_void;\n";
	    print "  if (cobj->primflag) {\n";
	    print "    cobj->primflag = 2;\n\n";
	    print "    delete (${newclass} *)(cobj->primdata);\n";
	    print "  } else\n";
	    print "    delete (${oldclass} *)(cobj->primdata);\n";
	    print "\n";
	    print "  cobj->primflag = -1;\n\n";
	    print "  return scheme_void;\n}\n\n";
	}
    }

    # Setup function
    if (!$global) {
	$proto = "void objscheme_setup_${oldclass}(Scheme_Env *env)";
        print HEADER $setup_d_end;
	print HEADER "$proto;\n";
	print HEADER $setup_d_start;
	print "$proto\n{\n";

	# Count methods to be installed:
	@funcs = ();
	$nmethod = 0; # count
	foreach $function (@functions) {
	    &ReadFields($function);
	    if (!$phantom) {
		@l = grep($_ =~ /^$func$/, @funcs);
		if ($#l < $[) {
		    @funcs = (@funcs, $func);
		    $nmethod += 1;
		}
	    }
	}
	foreach $ivar (@ivars) {
	    &ReadIvarFields($ivar);
	    $nmethod += 1;
	    if (!$readonly) {
		$nmethod += 1;
	    }
	}

	# Create class:
	print "  SETUP_VAR_STACK(1);\n";
	print "  VAR_STACK_PUSH(0, env);\n\n";
	print "  wxREGGLOB(${newclass}_class);\n";
	if ($interfacestring ne '') {
	    print "  wxREGGLOB(${newclass}_interface);\n";
	}
	print "\n";

	print "  ${newclass}_class = WITH_VAR_STACK(objscheme_def_prim_class(env, ";
	print "${classstring}, ";
	if ($parentstring ne '') {
	    print "${parentstring}";
	} else {
	    print "NULL";
	}
	print ", ";
	if ($#creators >= 0) {
	    print "(Scheme_Method_Prim *)${newclass}_ConstructScheme";
	} else {
	    print "NULL";
	}
	print ", ${nmethod}))";
	print ";\n\n";

	if ($interfacestring ne '') {
	    $sym = &Unquote($classstring);
	    print SOUT "  (define-private-class $sym ";
	    $sym = &Unquote($interfacestring);
	    print SOUT "$sym<%> ";
	} else {
	    $sym = &Unquote($classstring);
	    print SOUT "  (define-class $sym ";
	}
	if ($parentstring ne '') {
	    $sym = &Unquote($parentstring);
	    print SOUT "$sym";
	} else {
	    print SOUT "#f";
	}
	if ($iargnames ne 'BYPOS') {
	    print SOUT " ($iargnames)";
	} else {
	    print SOUT " #f";
	}

	@funcs = ();
	foreach $function (@functions) {
	    &ReadFields($function);
	    @l = grep($_ =~ /^$func$/, @funcs);
	    if ($#l < $[) {
		$sym = &Unquote($fname);
		print SOUT "\n    $sym";
		
		@funcs = (@funcs, $func);
		if (!$delegate && !$phantom) {
		    &OIStart;
		    print "  WITH_VAR_STACK(";
		    if ($justoneok{$func}) {
			print "scheme_add_method_w_arity";
		    } else {
			print "scheme_add_method";
		    }
		    print "(${newclass}_class, ";
		    $cleanfunc = $func;
		    $cleanfunc = &OperatorClean($cleanfunc);
		    print "${fname} \" method\", (Scheme_Method_Prim *)${newclass}${cleanfunc}";
		    if ($justoneok{$func}) {
			print ", ";
			print $justonemin{$func};
			print ", ";
			print $justonemax{$func};
		    }
		    print "));\n";
		    &OIEnd;
		}
	    }
	}
	
	print "\n";

	foreach $ivar (@ivars) {
	    &ReadIvarFields($ivar);
	    &OIStart;
	    print "  WITH_VAR_STACK(scheme_add_method_w_arity(${newclass}_class,";
	    print "${getname} \" method\", (Scheme_Method_Prim *)objscheme_${oldclass}_Get${ivarname}, 0, 0));\n";

	    $sym = &Unquote($getname);
	    print SOUT "\n    $sym";

	    if (!$readonly) {
		print "  WITH_VAR_STACK(scheme_add_method_w_arity(${newclass}_class,";
		print "${setname} \" method\", (Scheme_Method_Prim *)objscheme_${oldclass}_Set${ivarname}, 1, 1));\n";

		$sym = &Unquote($setname);
		print SOUT "\n    $sym";
	    }
	    &OIEnd;
	}

	print "\n";
	print SOUT ")\n";

	print "  WITH_VAR_STACK(scheme_made_class(${newclass}_class));\n\n";
	if ($interfacestring ne '') {
	    print "  ${newclass}_interface = WITH_VAR_STACK(";
	    print "scheme_class_to_interface(${newclass}_class, ${interfacestring} \"<%>\"));\n\n";
	    print "  WITH_VAR_STACK(";
	    print "objscheme_add_global_interface(${newclass}_interface, ${interfacestring} \"<%>\", env));\n";
	}

	if ($idfield ne '' && $classid ne '') {
	    print "  WITH_VAR_STACK(objscheme_install_bundler(";
	    print "(Objscheme_Bundler)objscheme_bundle_";
	    print "${oldclass}, ${classid}));\n";
	}

	print "\n";
    } else {
	$proto = "void objscheme_setup_${globalname}(Scheme_Env *env)";
        print HEADER $setup_d_end;
	print HEADER "$proto;\n";
        print HEADER $setup_d_start;
	print "$proto\n{\n";

	print "  Scheme_Object *functmp INIT_NULLED_OUT;\n";
	print "  SETUP_VAR_STACK(1);\n";
	print "  VAR_STACK_PUSH(0, env);\n";

	@funcs = ();
	foreach $function (@functions) {
	    &ReadFields($function);

	    @l = grep($_ =~ /^$func$/, @funcs);
	    if ($#l < $[) {
		$sym = &Unquote($fname);
		print SOUT "  (define-function $sym)\n";

		@funcs = (@funcs, $func);
		&OIStart;
		print "  functmp = WITH_VAR_STACK(";
		if ($justoneok{$func}) {
		    print "scheme_make_prim_w_arity";
		} else {
		    print "scheme_make_prim";
		}
		print "((Scheme_Prim *)${globalname}${func}";
		if ($justoneok{$func}) {
		    print ", ${fname}, ";
		    print $justonemin{$func};
		    print ", ";
		    print $justonemax{$func};
		}
		print "));\n";
		print "  WITH_VAR_STACK(scheme_install_xc_global(${fname}, functmp, env));\n";
		&OIEnd;
	    }
	}
    }

    if ($#constants >= 0) {
	print "  Scheme_Object *xcconsttmp INIT_NULLED_OUT;\n";
    }
    foreach $constant (@constants) {
	&ReadConstFields($constant);
	&OIStart;
	print "  xcconsttmp = ";
	&PrintBundleVar($cname, $ctype, 'WITH_VAR_STACK');
	print ";\n";
	print "  WITH_VAR_STACK(scheme_install_xc_global(${const}, xcconsttmp, env));\n";
	&OIEnd;

	$sym = &Unquote($const);
	print SOUT "  (define-constant $sym)\n";
    }

    print "  READY_TO_RETURN;\n";
    print "}\n\n";

    if (!$global) {
	$proto="int objscheme_istype_${oldclass}"
	    . "(Scheme_Object *obj, const char *stop, int nullOK)";
	print HEADER "$proto;\n";
	print "$proto\n";
	print "{\n";
	print "  REMEMBER_VAR_STACK();\n";
	print "  if (nullOK && XC_SCHEME_NULLP(obj)) return 1;\n";
	print "  if (objscheme_is_a(obj, ";
	print " ${newclass}_class))\n";
	print "    return 1;\n";
	print "  else {\n";
	print "    if (!stop)\n";
	print "       return 0;\n";
	$cs = &Unquote($classstring, 1);
	print "    WITH_REMEMBERED_STACK(scheme_wrong_type(stop, nullOK ? \"$cs object or \" XC_NULL_STR: \"$cs object\", -1, 0, &obj));\n";
	print "    return 0;\n";
	print "  }\n";
	print "}\n\n";
	
	# Bundle function
	$proto="Scheme_Object *objscheme_bundle_${oldclass}"
	    . "(class ${oldclass} *realobj)";
	print HEADER "$proto;\n";
	print "$proto\n";
	print "{\n  Scheme_Class_Object *obj INIT_NULLED_OUT;\n  Scheme_Object *sobj INIT_NULLED_OUT;\n\n";
	print "  if (!realobj) return XC_SCHEME_NULL;\n\n";
	print "  if (realobj->__gc_external)\n";
	print "    return (Scheme_Object *)realobj->__gc_external;\n";
	print "\n  SETUP_VAR_STACK(2);\n  VAR_STACK_PUSH(0, obj);\n  VAR_STACK_PUSH(1, realobj);\n\n";
	if ($idfield ne '') {
	    print "  if (";
	    if ($classid ne '') {
		print "(realobj->${idfield} != ${classid}) && ";
	    }
	    print "(sobj = WITH_VAR_STACK(objscheme_bundle_by_type(realobj, ";
	    print "realobj->${idfield}))))\n";
	    print "    { READY_TO_RETURN; return sobj; }\n";
	}
	print "  obj = (Scheme_Class_Object *)";
	print "WITH_VAR_STACK(scheme_make_uninited_object(${newclass}_class));\n\n";
	print "  obj->primdata = realobj;\n";
	if ($classflags ne "nofnl") {
	    print "  WITH_VAR_STACK(objscheme_register_primpointer(obj, &obj->primdata));\n";
	}
	print "  obj->primflag = 0;\n\n";
	print "  realobj->__gc_external = (void *)obj;\n";
	# print "  objscheme_note_creation((Scheme_Object *)obj);\n";
	print "  READY_TO_RETURN;\n";
	print "  return (Scheme_Object *)obj;\n}\n\n";

	# Unbundle function
	$proto = "class ${oldclass} *objscheme_unbundle_${oldclass}"
	    . "(Scheme_Object *obj, const char *where, int nullOK)";
	print HEADER "$proto;\n";
	print "$proto\n";
	print "{\n";
	print "  if (nullOK && XC_SCHEME_NULLP(obj)) return NULL;\n\n";
	print "  REMEMBER_VAR_STACK();\n\n";
	print "  (void)objscheme_istype_${oldclass}(obj, where, nullOK);\n";

	print "  Scheme_Class_Object *o = ";
	print "(Scheme_Class_Object *)obj;\n";

	print "  WITH_REMEMBERED_STACK(objscheme_check_valid(NULL, NULL, 0, &obj));\n";
	print "  if (o->primflag)\n";
	print "    return (${newclass} *)o->primdata;\n";
	print "  else\n";
	print "    return (${oldclass} *)o->primdata;\n";
	print "}\n\n";
    }
}

sub CalcNumRequired
{
    local($forscheme) = @_;

    $paramnum = 0;
    @defvs = @defvals;
    @scms = @schemes;
    foreach $paramtype (@paramtypes) {
	$defval = shift(@defvs);
	$scheme = shift(@scms);
	if (($defval ne '') && ($defval ne '.')) {
	    return $paramnum;
	}
	if (!$forscheme || $scheme) {
	    $paramnum += 1;
	}
    }
    return $paramnum;
}

sub CalcNumPossible
{
    local($forscheme) = @_;
    local($offset);

    $offset = 0;
    if ($forscheme) {
	foreach $scheme (@schemes) {
	    $offset += 1 if (!$scheme);
	}
    }

    return $#paramtypes + 1 - $offset;
}

sub PrintFailureHandling
{
    local($callback) = @_;

    if (($exception eq 'SUPER') && !$virtualonly) {
	print "READY_TO_RETURN; ";
	print "return " if ($returntype ne 'void');
	if ($callback) {
	    print "obj->";
	}
	print "ASSELF ${oldclass}::${func}(";
	&PrintArgs(1);
	print ");";
    } elsif ($exception ne '' && $exception ne 'SUPER') {
	print &ApplyMacros($exception);
    } else {
	print "{ READY_TO_RETURN; return; }";
    }
}

sub PrintMethod
{
    ($s) = @_;

    &ReadFields($s);

    $save_onlyif = $onlyif;

    if ($global || !$virtual || $phantom) {
	return;
    }

    &OIStart;

    # Define Class function
    # 
    $methodfuncname = "${newclass}::${func}";

    # Prototype for implementation
    print "static Scheme_Object *";
    print $newclass;
    print $func;
    print "(int n, Scheme_Object *p[]);\n\n";

    print &NormalType($returntype) . " ${methodfuncname}(";
    
    &PrintParams(0);
    $pcount = $paramnum;

    print ")\n";
    print "{\n";
    
    if ($hidden) {
	 print "}\n\n";
	 return;
    }

    $returnptr = 0;
    if ((($methodpost eq "")  || ($methodpost eq undef))
	&& (($methodpost ne "") || ($methodpost eq undef))
	&& (&SomeParamNeedsDeref() == 0)) {
	# No need to push return value
    } else {
	if ($returntype ne 'void') {
	    if ($returnpushable =~ /push/) {
		if ($returnpushable eq "push") {
		    $returnptr = 1;
		}
	    } elsif (ParamIsPointer($returntype)) {
		$returnptr = 1;
	    }
	}
    }

    # Local variables
    print "  Scheme_Object *p[POFFSET+${numschemes}] INIT_NULLED_ARRAY({ ";
    $i = $numschemes;
    while ($i > 0) {
	print "NULLED_OUT INA_comma ";
	$i -= 1;
    }
    print "NULLED_OUT });\n";
    $varstacksize = 5;
    print "  Scheme_Object *v";
    if ($returnptr) {
	printf " INIT_NULLED_OUT";
	$varstacksize += 1;
    }
    print ";\n";
    print "  Scheme_Object *method INIT_NULLED_OUT;\n";
    print "#ifdef MZ_PRECISE_GC\n";
    print "  ${newclass} *sElF = this;\n";
    print "#endif\n";
    print "  static void *mcache = 0;\n";
    &PrintSboxTmp();
    print "\n";

    # Count pushable arguments
    @scms = @schemes;
    @pbls = @pushables;
    foreach $paramtype (@paramtypes) {
	$scheme = shift(@scms);
	$pushable = shift(@pbls);

	if ($scheme) {
	    if ($pushable =~ /push/) {
		if ($pushable eq "push") {
		    $varstacksize += 1;
		}
	    } elsif (&ParamIsPointer($paramtype)) {
		$varstacksize += 1;
	    }
	}
    }

    print "  SETUP_VAR_STACK($varstacksize);\n";
    print "  VAR_STACK_PUSH(0, method);\n";
    print "  VAR_STACK_PUSH(1, sElF);\n";
    print "  VAR_STACK_PUSH_ARRAY(2, p, POFFSET+$numschemes);\n";
    $varstackpos = 5;
    if ($returnptr) {
	print "  VAR_STACK_PUSH($varstackpos, v);\n";
	$varstackpos += 1;
    }

    # Push arguments
    $paramnum = 0;
    $offset = 0;
    @scms = @schemes;
    @pbls = @pushables;
    foreach $paramtype (@paramtypes) {
	$scheme = shift(@scms);
	$pushable = shift(@pbls);

	if ($scheme) {
	    $pushit = 0;
	    if ($pushable =~ /push/) {
		if ($pushable eq "push") {
		    $pushit = 1;
		}
	    } elsif (&ParamIsPointer($paramtype)) {
		$pushit = 1;
	    }

	    if ($pushit) {
		$var = "x" . ($paramnum + $offset);
		print "  VAR_STACK_PUSH($varstackpos, $var);\n";
		$varstackpos += 1;
	    }
	    $paramnum += 1;
	} else {
	    $offset += 1;
	}
    }
    print "  SET_VAR_STACK();\n";
    print "\n";

    print "  method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, ";
    print "${newclass}_class, ";
    print $fname;
    print ", &mcache);\n";
    # print "  if (method && !OBJSCHEME_PRIM_METHOD(method)) {\n";
    # print "    COPY_JMPBUF(savebuf, scheme_error_buf);\n";
    # print "    sj = scheme_setjmp(scheme_error_buf);\n";
    # print "    if (sj) {\n";
    # print "      COPY_JMPBUF(scheme_error_buf, savebuf);\n";
    # print "      scheme_clear_escape();\n";
    # print "    }\n"; else if (sj)
    # print "  } else {\n";

    print "  if (!method || OBJSCHEME_PRIM_METHOD(method, ";
    print $newclass;
    print $func;
    print ")) {\n";
    print "    SET_VAR_STACK();\n    ";

    &PrintFailureHandling();

    print "\n  } else {\n";
    
    print "  " . &ApplyMacros($methpre) . "\n";

    # Setup param array:
    $paramnum = 0;
    $offset = 0;
    @bunds = @bundles;
    @scms = @schemes;
    foreach $paramtype (@paramtypes) {
	$bundle = shift(@bunds);
	$scheme = shift(@scms);

	if ($scheme) {
	    print "  p[POFFSET+${paramnum}] = ";
	    $var = "x" . ($paramnum + $offset);

	    &PrintBundleVar($var, $paramtype, 'WITH_VAR_STACK', $bundle);
	    
	    print ";\n";

	    $paramnum += 1;
	} else {
	    $offset += 1;
	}
    }

    print "  " . &ApplyMacros($methprecall) . "\n";

    print "  p[0] = (Scheme_Object *) ASSELF __gc_external;\n";
    
    print "\n  v = WITH_VAR_STACK(scheme_apply(";
    print "method, ";
    print "POFFSET+${numschemes}, p));\n";

    print "  " . &ApplyMacros($methpostcall) . "\n";

    &PrintUnbundledEffects();

    print "  " . &ApplyMacros($methpost) . "\n";

    # print "  COPY_JMPBUF(scheme_error_buf, savebuf);\n\n";
    
    if ($returntype ne 'void') {
	print "  {\n";
	print "     " . &NormalType($returntype) . " resval;\n";
	print "     resval = ";
	&PrintUnbundleVar("v", $returntype, $returnunbundle, 1, &GetMethod(1) . "\", extracting return value\"");
	print ";\n";
	print "     READY_TO_RETURN;\n";
	print "     return resval;\n  }\n";
    } else {
	print "     READY_TO_RETURN;\n";
    }
    print "  }\n}\n";

    $onlyif = $save_onlyif;
    &OIEnd;
    print "\n";
}

sub PrintFunction 
{
    ($thefunc, $iscreator) = @_;

    # Define Scheme callback
    #

    $numfuncs = 0;
    $thisfuncs = ();
    $fp = 0;
    foreach $func (@funcnames) {
	if ($thefunc eq $func) {
	    $function = $functions[$fp];
	    &ReadFields($function);
	    if ($numfuncs > 0) {
		$thefunction = $function;
		@argtypes = @schemeparams;
		@argtypeids = @typeids;
		$numposs = &CalcNumRequired(1);
		$found = 1;
		$argpos = 0;
		$foundpos = 0;
		$foundlen = $numfuncs; 
		while ($found && ($argpos < $numposs)) {
		    $found = 0;
		    $checkid = ($argtypeids[$argpos] ne '');
		    foreach $pos (0..($foundlen - 1)) {
			&ReadFields($thisfuncs[$pos + $foundpos]);
			$numposs2 = &CalcNumRequired(1);
			if ($numposs2 > $argpos
			    && (($checkid &&
				 ($typeids[$argpos] eq $argtypeids[$argpos]))
				|| ($schemeparams[$argpos] 
				    eq $argtypes[$argpos]))) {
			    if ($found) {
				$foundlen += 1;
			    } else {
				$foundpos = $pos + $foundpos;
				$foundlen = 1;
				$found = 1;
			    }
			}
		    }
		    $argpos += 1;
		}
		if (!$found) {
		    $foundlen = 0;
		} elsif ($argpos >= $numposs) {
		    &ReadFields($thisfuncs[$foundpos]);
		    $numposs2 = &CalcNumRequired(1);
		    if ($numposs2 == $numposs) {
			$foundlen = -1;
			$thisfuncs[$foundpos] = $thefunction;
		    }
		}
		if ($foundlen >= 0) {
		    splice(@thisfuncs, $foundpos+$foundlen, 0, $thefunction);
		    $numfuncs += 1;
		}
	    } else {
		$numfuncs = 1;
		$thisfuncs[0] = $function;
	    }
	}
	$fp += 1;
    }

    &ReadFields($thisfuncs[0]);

    if ($delegate) {
	return; # Superclass will dispatch for us
    }

    if ($phantom) {
	return; # No such method, really
    }

    if ($numfuncs == 1) {
	&OIStart;
    }

    # print "#pragma argsused\n";

    $pre_var_stack = "";

    if ($iscreator) {
	print "static Scheme_Object *${newclass}_ConstructScheme(${scheme_args})";
	print "\n{\n";

	print "  SETUP_PRE_VAR_STACK(1);\n";
	print "  PRE_VAR_STACK_PUSH(0, p);\n";
	
	$pre_var_stack = "PRE_";
	print "  ${newclass} *realobj INIT_NULLED_OUT;\n";
	print "  REMEMBER_VAR_STACK();\n";
	$returnptr = 0;
    } else {
	print "static Scheme_Object *";
	$func2 = $func;
	$func2 = &OperatorClean($func2);
	print "${globalname}${newclass}${func2}";
	print "(";
	if (!$global) {
	    print "${scheme_args}";
	} else {
	    print "${global_scheme_args}";
	}

	print ")\n{\n";

	print "  WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)\n";

	if ($numfuncs > 1) {
	    print "  SETUP_PRE_VAR_STACK(1);\n";
	    print "  PRE_VAR_STACK_PUSH(0, p);\n";

	    $pre_var_stack = "PRE_";
	}
	print "  REMEMBER_VAR_STACK();\n";

	# We only need to push if something's going
	# to happen after the function/method call.
	$returnptr = 0;
	if (($numfuncs == 1)
	    && (($gluepostcall eq "")  || ($gluepostcall eq undef))
	    && (($gluepost ne "") || ($gluepost eq undef))
	    && (&SomeParamNeedsDeref() == 0)) {
	    # No need to push return value
	} else {
	    if ($returntype ne 'void') {
		if ($returnpushable =~ /push/) {
		    if ($returnpushable eq "push") {
			$returnptr = 1;
		    }
		} elsif (ParamIsPointer($returntype)) {
		    $returnptr = 1;
		}
	    }
	}

	if ($returntype ne 'void') {
	    print "  " . &NormalType($returntype, 1) . " r";
	    if ($returnptr) {
		print " INIT_NULLED_OUT";
	    }
	    print ";\n";
	}

	if (!$global) {
	    print "  objscheme_check_valid(${newclass}_class, $method, n, p);\n";
	}
    }

    if (!$iscreator) {
	$justoneok{$func} = 1;
    }

    if ($numfuncs == 1) {
	if (!$iscreator) {
	    $justonemin{$func} = &CalcNumRequired(1);
	    $justonemax{$func} = &CalcNumPossible(1);
	}
	&PrintSpecificFunction("", $iscreator, !$iscreator, "", $pre_var_stack, $returnptr);
	print "  READY_TO_RETURN;\n";
    } else {
	print "  ";

	if (!$iscreator) {
	    $justonemin{$func} = 1000;
	    $justonemax{$func} = 0;
	}

	foreach $pos (0..($numfuncs-2)) {
	    &ReadFields($thisfuncs[$pos + 1]);
	    @schemeparams2 = @schemeparams;
	    @typeids2 = @typeids;
	    &ReadFields($thisfuncs[$pos]);

	    if (!$iscreator) {
		$how_many_args_this_case = &CalcNumRequired(1);
		if ($how_many_args_this_case < $justonemin{$func}) {
		    $justonemin{$func} = $how_many_args_this_case;
		}
		$how_many_args_this_case = &CalcNumPossible(1);
		if ($how_many_args_this_case > $justonemax{$func}) {
		    $justonemax{$func} = $how_many_args_this_case;
		}
	    }

	    print "if (";

	    # Figure out how many things we'll check
	    $pos = 0;
	    while ($schemeparams[$pos] eq $schemeparams2[$pos]
		   || (($typeids[$pos] ne '')
		       && ($typeids[$pos] eq $typeids2[$pos]))) {
		if ($schemeparams[$pos] eq undef) {
		    print STDERR "error: duplicate function ${newclass}::$func\n";
		    exit(-1);
		}
		$pos += 1;
	    }
	    $checkcount = $pos;
	    $pos += 1;
	    print "(n >= ($POFFSET+$pos))";

	    # Check them:
	    $pos = 0;
	    @checks = @typechecks;
	    @scms = @schemes;
	    while ($pos < $checkcount) {
		$scheme = 0;
		while (!$scheme) {
		    $check = shift(@checks);
		    $scheme = shift(@scms);
		}
		print " && ";
		&PrintTypecheck("p[$POFFSET+${pos}]", $schemeparams[$pos], $check, 0);
		$pos += 1;
	    }
	    print " && ";
	    $scheme = 0;
	    while (!$scheme) {
		$check = shift(@checks);
		$scheme = shift(@scms);
	    }
	    &PrintTypecheck("p[$POFFSET+${pos}]", $schemeparams[$pos], $check, 0);
	    
	    print ") {\n";
	    if ($casename eq "") {
		print STDERR "Warning: unnamed ${newclass}::$func case\n";
		$casename = "";
	    } else {
		$casename = " ($casename case)";
	    }
	    &PrintSpecificFunction("  ", $iscreator, 0, $casename, $pre_var_stack, $returnptr);
	    print "    READY_TO_" . $pre_var_stack . "RETURN;\n";
	    print "  } else ";
	}

	&ReadFields($thisfuncs[$numfuncs - 1]);

	if (!$iscreator) {
	    $how_many_args_this_case = &CalcNumRequired(1);
	    if ($how_many_args_this_case < $justonemin{$func}) {
		$justonemin{$func} = $how_many_args_this_case;
	    }
	    $how_many_args_this_case = &CalcNumPossible(1);
	    if ($how_many_args_this_case > $justonemax{$func}) {
		$justonemax{$func} = $how_many_args_this_case;
	    }
	}

	if ($numfuncs > 1) {
	    if ($casename eq "") {
		print STDERR "Warning: unnamed ${newclass}::$func case\n";
		$casename = "";
	    } else {
		$casename = " ($casename case)";
	    }
   	} else {
	    $casename = "";
	}

	print " {\n";
	&PrintSpecificFunction("  ", $iscreator, 0, $casename, $pre_var_stack, $returnptr);
	print "    READY_TO_" . $pre_var_stack . "RETURN;\n";
	print "  }";
	print "\n\n";
    }

    if ($iscreator) {
	print "  ((Scheme_Class_Object *)p[0])->primdata = realobj;\n";
	print "  ((Scheme_Class_Object *)p[0])->primflag = 1;\n";
	if ($classflags ne "nofnl") {
	    print "  WITH_REMEMBERED_STACK(objscheme_register_primpointer(p[0], &((Scheme_Class_Object *)p[0])";
	    print "->primdata));\n";
	}
	if ($gluepostschemebind ne undef) {
	    print "  " . &ApplyMacros($gluepostschemebind) . "\n";
	}
	print "  return scheme_void;\n";
	print "}\n";
    } else {
	print "  return ";

	if ($returntype eq 'void') {
	    print "scheme_void";
	} else {
	    &PrintBundleVar("r", $returntype, "WITH_REMEMBERED_STACK", $returnbundle, 1);
	}
	print ";\n}\n";
    }

    if ($numfuncs == 1) {
	&OIEnd;
    }

    print "\n";
}

sub PrintCallRealMethod
{
    local($prefix, $ret_val, $direct) = @_;

    if ($global) {
	print "$prefix  ";
	print $ret_val if ($returntype ne 'void');
	print "WITH_VAR_STACK(${func}(";
	&PrintArgs($direct);
	print "));\n\n";
    } else {
	print "$prefix  ";
	if ($virtual) {
	    print "if (((Scheme_Class_Object *)p[0])->primflag)\n";
	    print "$prefix    ";
	    print $ret_val if ($returntype ne 'void');
	    &PrintIndirect($returntype) if (!$direct);
	    if ($virtualonly) {
		if ($exception ne "SUPER") {
		    $rets = &ApplyMacros($exception);
		    if ((substr($rets, -1) eq ';') && (substr($rets, 0, 6) eq 'return')) {
			print substr($rets, 6);
		    } else {
			print STDERR "error: cannot use exception for value: $rets\n";
			exit(-1);
		    }
		    print "\n";
		} else {
		    print "{}\n";
		}
	    } else {
		print "WITH_VAR_STACK((($newclass *)((Scheme_Class_Object *)p[0])->primdata)->";
		if ($implementor ne "") {
		    print $implementor;
		} else {
		    print $oldclass;
		}
		print "::";
		print "${func}(";
		&PrintArgs($direct);
		print "));\n";
	    }
	    print "$prefix  else\n";
	    print "$prefix    ";
	}
	print $ret_val if ($returntype ne 'void');
	&PrintIndirect($returntype) if (!$direct);
	print "WITH_VAR_STACK(";
	if (!$externalmethod) {
	    print "(($oldclass *)((Scheme_Class_Object *)p[0])->primdata)";
	    print "->";
	}
	print "${func}(";
	if ($externalmethod) {
	    print "(($oldclass *)((Scheme_Class_Object *)p[0])->primdata)";
	    print ", " if ($#paramtypes >= 0);
	}
	&PrintArgs($direct);
	print "));\n";
	print "\n";
    }
}

sub PrintSpecificFunction
{
    local($prefix, $iscreator, $just_one, $casename, $pre_var_stack, $returnptr) = @_;

    return if ($hidden);

    &OIStart;

    $req = &CalcNumRequired(1);
    $aname = &Unquote($method);
    
    &PrintLocals($prefix);
    &PrintSboxTmp();

    # Count pushable pointers:
    if ($global) {
	$pointercount = 1;
    } else {
	if ($iscreator) {
	    $pointercount = 2;
	} else {
	    $pointercount = 1;
	}
    }
    if ($returnptr) {
	$pointercount += 1;
    }
    @pbls = @pushables;
    foreach $paramtype (@paramtypes) {
	$pt = $paramtype;
	$pushable = shift(@pbls);
	if ($pushable =~ /push/) {
	    if ($pushable eq "push") {
		$pointercount += 1;
	    }
	} elsif (&ParamIsPointer($pt)) {
	    if (!(&NeedsDeref($pt))) {
		$pointercount += 1;
	    }
	}
    }
    print "\n$prefix  SETUP_VAR_STACK_${pre_var_stack}REMEMBERED($pointercount);\n";
    print "$prefix  VAR_STACK_PUSH(0, p);\n";
    if (!$global) {
	if ($iscreator) {
	    print "$prefix  VAR_STACK_PUSH(1, realobj);\n";
	}
    }
    if ($returnptr) {
	print "$prefix  VAR_STACK_PUSH(1, r);\n";
    }
    # Push each pounter:
    $paramnum = 0;
    if ($global) {
	$pointercount = 1;
    } else {
	if ($iscreator) {
	    $pointercount = 2;
	} else {
	    $pointercount = 1;
	}
    }
    if ($returnptr) {
	$pointercount += 1;
    }
    
    @pbls = @pushables;
    foreach $paramtype (@paramtypes) {
	$pt = $paramtype;
	$pushable = shift(@pbls);	
	if ($pushable =~ /push/) {
	    if ($pushable eq "push") {
		print "$prefix  VAR_STACK_PUSH($pointercount, x$paramnum);\n";
		$pointercount += 1;
	    }
	} elsif (&ParamIsPointer($pt)) {
	    if (!(&NeedsDeref($pt))) {
		print "$prefix  VAR_STACK_PUSH($pointercount, x$paramnum);\n";
		$pointercount += 1;
	    }
	}
	$paramnum += 1;
    }

    print "\n";
    print "$prefix  " . &ApplyMacros($gluepre) . "\n";

    if (!$just_one) {
	$possible = &CalcNumPossible(1);
	print "$prefix  if (";
	if ($req == $possible) {
	    print "n != ($POFFSET+$req)";
	    $minimumok = $possible;
	} else {
	    if ($req) {
		$req_arg = $req;
		print "(n < ($POFFSET+$req_arg)) || ";
		$minimumok = $req_arg;
	    } else {
		$minimumok = "$POFFSET";
	    }
	    print "(n > ($POFFSET+$possible))";
	}
	print ") \n";
	
	print "$prefix    WITH_VAR_STACK(scheme_wrong_count_m(";
	print "\"${aname}${casename}\"";
	
	print ", $POFFSET+${minimumok}, $POFFSET+${possible}, n, p, ";
	if ($global) {
	    print "0";
	} else {
	    print "1";
	}
	print "));\n";
    }

    &PrintUnbundles($prefix, "\"${aname}${casename}\"");
    print "\n";
    print "$prefix  " . &ApplyMacros($glueprecall) . "\n";

    if ($iscreator) {
	print "$prefix  realobj = WITH_VAR_STACK(new ${newclass} CONSTRUCTOR_ARGS((";
	&PrintArgs();
	print ")));\n";
	print "#ifdef MZ_PRECISE_GC\n";
	print "$prefix  WITH_VAR_STACK(realobj->gcInit_${oldclassmk}(";
	&PrintArgs();
	print "));\n";
	print "#endif\n";
	print "$prefix  realobj->__gc_external = (void *)p[0];\n";
	# print "$prefix  objscheme_note_creation(p[0]);\n";
    } else {
	&PrintCallRealMethod($prefix, "r = ", $vonlyval);
    }

    print "$prefix  " . &ApplyMacros($gluepostcall) . "\n";

    &PrintBundledEffects($prefix);

    print "$prefix  " . &ApplyMacros($gluepost) . "\n";

    if (($onlyif ne '') && ($returntype ne 'void')) {
	print "#else\n";
	print " scheme_signal_error(";
	print "\"%s: provided arglist unsupported on this platform\"";
	print ", \"${aname}${casename}\");\n";
#	print "${prefix}r = ";
#	if ($exception ne '' && $exception ne 'SUPER') {
#	    print &ApplyMacros($exception);
#	} else {
#	    print "0";
#	}
#	print ";\n";
    }

    &OIEnd;
}

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

    if ((substr($type, -1) eq '%') || (substr($type, -1) eq '&')) {
	print "&";
    }
}

sub PrintBundleObject
{
    local($var, $paramtype, $wvs, $nullOK) = @_;

    $nullOK = '0' if ($nullOK eq '');

    print "$wvs(objscheme_bundle_${paramtype}($var))";
    print HEADER "extern Scheme_Object *objscheme_bundle_${paramtype}";
    print HEADER "(class ${paramtype} *);\n";
}

sub PrintBundleVar
{
    local($var, $paramtype, $wvs, $bundle, $outgoing) = @_;

    if (($bundle ne undef) && ($bundle ne '')) {
	print &ApplyMacros($bundle, $var);
    } elsif (substr($paramtype, 0, 7) eq 'unknown') {
	print "$wvs(objscheme_bundle_generic((void *)$var))";
    } elsif (substr($paramtype, -1) eq '*') {
	substr($paramtype, -1) = '';
	print "(sbox_tmp = ";
	&PrintBundleVar("(*$var)", $paramtype, $wvs);
	print ", $wvs(objscheme_box(sbox_tmp)))";
    } elsif (substr($paramtype, -1) eq '?') {
	substr($paramtype, -1) = '';
	print "(($var) ? ";
	print "(sbox_tmp = ";
	&PrintBundleVar("(*$var)", $paramtype, $wvs);
	print ", $wvs(objscheme_box(sbox_tmp)))";
	print " : XC_SCHEME_NULL)";
    } elsif (substr($paramtype, -1) eq '&') {
	substr($paramtype, -1) = '';
	$var = "&$var" unless $outgoing;
	&PrintBundleVar("$var", $paramtype, $wvs);
    } elsif (substr($paramtype, -1) eq '+') {
	substr($paramtype, -1) = '';
	print "(sbox_tmp = ";
	&PrintBundleVar($var, $paramtype, $wvs);
	print ", $wvs(objscheme_box(sbox_tmp)))";
    } elsif ($paramtype eq 'bool') {
	print "($var ? scheme_true : scheme_false)";
    } elsif ($paramtype eq 'char' || $paramtype eq 'mzchar') {
	print "scheme_make_char($var)";
    } elsif ($paramtype eq 'uchar') {
	print "scheme_make_char((char)$var)";
    } elsif ($paramtype eq 'int' 
	     || $paramtype eq 'nnint' 
	     || $paramtype eq 'unsigned'
	     || (substr($paramtype,0,4) eq 'rint')) {
	print "scheme_make_integer($var)";
    } elsif ($paramtype eq 'short') {
	print "scheme_make_integer($var)";
    } elsif ($paramtype eq 'byte' || $paramtype eq 'ubyte') {
	print "scheme_make_integer($var)";
    } elsif ($paramtype eq 'long' 
	     || $paramtype eq 'nnlong' 
	     || (substr($paramtype, 0, 4) eq 'nnls')
             || $paramtype eq 'Long') {
	print "scheme_make_integer($var)";
    } elsif ($paramtype eq 'ExactLong') {
	print "$wvs(scheme_make_integer_value($var))";
    } elsif (($paramtype eq 'double') 
	     || ($paramtype eq 'nndouble')
	     || ($paramtype eq 'Double')
	     || (substr($paramtype,0,7) eq 'rdouble')) {
	print "$wvs(scheme_make_double($var))";
    } elsif (substr($paramtype,0,4) eq 'nnfs') {
	$paramtype =~ /nnfs\[(.*)\]/;
	$symname = $1;
	print "$wvs(objscheme_bundle_nonnegative_symbol_double($var, \"$symname\"))";
    } elsif (($paramtype eq 'string') || ($paramtype eq 'cstring')
	     || ($paramtype eq 'nstring') || ($paramtype eq 'ncstring')) {
	print "$wvs(objscheme_bundle_string((char *)$var))";
    } elsif (($paramtype eq 'bstring') || ($paramtype eq 'cbstring')
	     || ($paramtype eq 'nbstring') || ($paramtype eq 'ncbstring') 
	     || ($paramtype eq 'wbstring')) {
	print "$wvs(objscheme_bundle_bstring((char *)$var))";
    } elsif (($paramtype eq 'mzstring') || ($paramtype eq 'mzxstring') || ($paramtype eq 'cmzstring')
	     || ($paramtype eq 'nmzstring') || ($paramtype eq 'ncmzstring') 
	     || ($paramtype eq 'wmzstring')) {
	print "$wvs(objscheme_bundle_mzstring((mzchar *)$var))";
    } elsif (($paramtype eq 'pstring') || ($paramtype eq 'cpstring')
	     || ($paramtype eq 'npstring') || ($paramtype eq 'ncpstring')) {
	print "$wvs(objscheme_bundle_pstring((char *)$var))";
    } elsif (($paramtype eq 'pathname') 
	     || ($paramtype eq 'cpathname')
	     || ($paramtype eq 'npathname')
	     || ($paramtype eq 'ncpathname')
	     || ($paramtype eq 'wpathname') 
	     || ($paramtype eq 'wnpathname')
	     || ($paramtype eq 'epathname') 
	     || ($paramtype eq 'nepathname')
	     || ($paramtype eq 'xpathname') 
	     || ($paramtype eq 'nxpathname')) {
	print "$wvs(objscheme_bundle_pathname((char *)$var))";
    } elsif (substr($paramtype, -1) eq '!') {
	substr($paramtype, -1) = '';
	&PrintBundleObject($var, $paramtype, $wvs);
    } elsif (substr($paramtype, -1) eq '^') {
	substr($paramtype, -1) = '';
	&PrintBundleObject($var, $paramtype, $wvs, 1);
    } elsif (substr($paramtype, -1) eq '%') {
	substr($paramtype, -1) = '';
	$var = "&$var" unless $outgoing;
	&PrintBundleObject($var, $paramtype, $wvs);
    } elsif (substr($paramtype, 0, 3) eq 'SYM') {
	$paramtype =~ /SYMZ?\[(.*)\]/;
	$symtype = $1;
	print "$wvs(bundle_symset_${symtype}($var))";
    } else {
	print STDERR "Unknown type ${paramtype} in $func.\n";
    }
}

sub ParamIsPointer
{
    local($paramtype) = @_;

    if (substr($paramtype, 0, 7) eq 'unknown') {
	return 1;
    } elsif (substr($paramtype, -1) eq '*') {
	return 1;
    } elsif (substr($paramtype, -1) eq '?') {
	return 1;
    } elsif (substr($paramtype, -1) eq '&') {
	return 1;
    } elsif (substr($paramtype, -1) eq '+') {
	return 1;
    } elsif ($paramtype eq 'bool') {
	return 0;
    } elsif ($paramtype eq 'char' || $paramtype eq 'mzchar') {
	return 0;
    } elsif ($paramtype eq 'uchar') {
	return 0;
    } elsif ($paramtype eq 'int' 
	     || $paramtype eq 'nnint' 
	     || $paramtype eq 'unsigned'
	     || (substr($paramtype,0,4) eq 'rint')) {
	return 0;
    } elsif ($paramtype eq 'short') {
	return 0;
    } elsif ($paramtype eq 'byte' || $paramtype eq 'ubyte') {
	return 0;
    } elsif ($paramtype eq 'long' 
	     || $paramtype eq 'nnlong' 
	     || (substr($paramtype, 0, 4) eq 'nnls')
             || $paramtype eq 'Long') {
	return 0;
    } elsif ($paramtype eq 'ExactLong') {
	return 0;
    } elsif (($paramtype eq 'double') 
	     || ($paramtype eq 'nndouble')
	     || ($paramtype eq 'Double')
	     || (substr($paramtype,0,7) eq 'rdouble')) {
	return 0;
    } elsif (substr($paramtype,0,4) eq 'nnfs') {
	return 0;
    } elsif (($paramtype eq 'string') || ($paramtype eq 'cstring')
	     || ($paramtype eq 'nstring') || ($paramtype eq 'ncstring')) {
	return 1;
    } elsif (($paramtype eq 'bstring') || ($paramtype eq 'cbstring')
	     || ($paramtype eq 'nbstring') || ($paramtype eq 'ncbstring')
	     || ($paramtype eq 'wbstring')) {
	return 1;
    } elsif (($paramtype eq 'pstring') || ($paramtype eq 'cpstring')
	     || ($paramtype eq 'npstring') || ($paramtype eq 'ncpstring')) {
	return 1;
    } elsif (($paramtype eq 'mzstring') || ($paramtype eq 'mzxstring') || ($paramtype eq 'cmzstring')
	     || ($paramtype eq 'nmzstring') || ($paramtype eq 'ncmzstring')
	     || ($paramtype eq 'wmzstring')) {
	return 1;
    } elsif (($paramtype eq 'pathname') 
	     || ($paramtype eq 'cpathname')
	     || ($paramtype eq 'npathname')
	     || ($paramtype eq 'ncpathname')
	     || ($paramtype eq 'wpathname')
	     || ($paramtype eq 'wnpathname')
	     || ($paramtype eq 'epathname')
	     || ($paramtype eq 'nepathname')
	     || ($paramtype eq 'xpathname')
	     || ($paramtype eq 'nxpathname')) {
	return 1;
    } elsif (substr($paramtype, -1) eq '!') {
	return 1;
    } elsif (substr($paramtype, -1) eq '^') {
	return 1;
    } elsif (substr($paramtype, -1) eq '%') {
	return 1;
    } elsif (substr($paramtype, 0, 3) eq 'SYM') {
	return 0;
    } else {
	print STDERR "Unknown type ${paramtype} in $func [for ParamIsPointer].\n";
	return 1;
    }
}

sub PrintUnbundleObject
{
    local($var, $paramtype, $nullOK, $mname) = @_;
    local($stop);

    $nullOK = '0' if ($nullOK eq '');

    if (($mname eq '') || ($mname eq undef)) {
	$stop = &GetMethod(1);
    } else {
	$stop = $mname;
    }

    print "WITH_VAR_STACK(objscheme_unbundle_${paramtype}($var, $stop, $nullOK))";
    print HEADER "extern class ${paramtype} *";
    print HEADER "objscheme_unbundle_${paramtype}" .
	"(Scheme_Object *, const char *, int);\n";
}
    
sub PrintUnbundleVar
{
    local($var, $paramtype, $unbundle, $outgoing, $mname) = @_;
    local($stop, $pos);

    if (($mname eq "") || ($mname eq undef)) {
	$stop = &GetMethod(1);
    } else {
	$stop = $mname;
    }

    if (($unbundle ne undef) && ($unbundle ne '')) {
	if ($var =~ /([0-9]+)/) {
	    $pos = $1;
	}
	print &ApplyMacros($unbundle, $var, $pos);
    } elsif (substr($paramtype, 0, 7) eq 'unknown') {
	print "(";
	print substr($paramtype, 8);
	print ")WITH_VAR_STACK(objscheme_unbundle_generic($var, $stop))";
    } elsif (substr($paramtype, -1) eq '*' || substr($paramtype, -1) eq '+') {
	substr($paramtype, -1) = '';
	print "(sbox_tmp = WITH_VAR_STACK(objscheme_unbox($var, $stop)), ";
	&PrintUnbundleVar("sbox_tmp", $paramtype, "", "", &Unboxing($stop));
	print ")";
    } elsif (substr($paramtype, -1) eq '&') {
	substr($paramtype, -1) = '';
	print "*" if ($outgoing);
	&PrintUnbundleVar("$var", $paramtype, "", "", $stop);
    } elsif (substr($paramtype, -1) eq '?') {
	substr($paramtype, -1) = '';
	print "(sbox_tmp = WITH_VAR_STACK(objscheme_nullable_unbox($var, $stop)), ";
	&PrintUnbundleVar("sbox_tmp", $paramtype, "", "", &Unboxing($stop));
	print ")";
    } elsif ($paramtype eq 'bool') {
	print "WITH_VAR_STACK(objscheme_unbundle_bool(${var}, $stop))";
    } elsif ($paramtype eq 'char' || $paramtype eq 'mzchar') {
	print "WITH_VAR_STACK(objscheme_unbundle_char(${var}, $stop))";
    } elsif ($paramtype eq 'uchar') {
	print "((unsigned char)WITH_VAR_STACK(objscheme_unbundle_char(${var}, $stop)))";
    } elsif (($paramtype eq 'int') || ($paramtype eq 'unsigned') 
	     || ($paramtype eq 'short') || ($paramtype eq 'long')
	     || ($paramtype eq 'Long')) {
	print "WITH_VAR_STACK(objscheme_unbundle_integer($var, $stop))";
    } elsif ($paramtype eq 'ubyte') {
	print "WITH_VAR_STACK(objscheme_unbundle_integer_in($var, 0, 255, $stop))";
    } elsif (substr($paramtype,0,4) eq 'rint') {
	$paramtype =~ /rint\[([^|]*)\|(.*)\]/;
	print "WITH_VAR_STACK(objscheme_unbundle_integer_in($var, $1, $2, $stop))";
    } elsif ($paramtype eq 'ExactLong') {
	print "WITH_VAR_STACK(objscheme_unbundle_ExactLong($var, $stop))";
    } elsif (($paramtype eq 'nnint') || ($paramtype eq 'nnlong')) {
	print "WITH_VAR_STACK(objscheme_unbundle_nonnegative_integer($var, $stop))";
    } elsif (substr($paramtype,0,4) eq 'nnls') {
	$paramtype =~ /nnls\[(.*)\]/;
	$symname = $1;
	print "WITH_VAR_STACK(objscheme_unbundle_nonnegative_symbol_integer($var, \"$symname\", $stop))";
    } elsif (($paramtype eq 'double')
	     || ($paramtype eq 'Double')) {
	print "WITH_VAR_STACK(objscheme_unbundle_double($var, $stop))";
    } elsif (($paramtype eq 'nndouble')) {
	print "WITH_VAR_STACK(objscheme_unbundle_nonnegative_double($var, $stop))";
    } elsif (substr($paramtype,0,7) eq 'rdouble') {
	$paramtype =~ /rdouble\[([^|]*)\|(.*)\]/;
	print "WITH_VAR_STACK(objscheme_unbundle_double_in($var, $1, $2, $stop))";
    } elsif (substr($paramtype,0,4) eq 'nnfs') {
	$paramtype =~ /nnfs\[(.*)\]/;
	$symname = $1;
	print "WITH_VAR_STACK(objscheme_unbundle_nonnegative_symbol_double($var, \"$symname\", $stop))";
    } elsif ($paramtype eq 'string' || $paramtype eq 'cstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_string(${var}, $stop))";
    } elsif ($paramtype eq 'nstring' || $paramtype eq 'ncstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_string($var, $stop))";
    } elsif ($paramtype eq 'bstring' || $paramtype eq 'cbstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_bstring(${var}, $stop))";
    } elsif ($paramtype eq 'wbstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_mutable_bstring(${var}, $stop))";
    } elsif ($paramtype eq 'nbstring' || $paramtype eq 'ncbstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_bstring($var, $stop))";
    } elsif ($paramtype eq 'pstring' || $paramtype eq 'cpstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_pstring(${var}, $stop))";
    } elsif ($paramtype eq 'npstring' || $paramtype eq 'ncpstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_pstring($var, $stop))";
    } elsif ($paramtype eq 'mzstring' || $paramtype eq 'cmzstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_mzstring(${var}, $stop))";
    } elsif ($paramtype eq 'mzxstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_mzxstring(${var}, $stop))";
    } elsif ($paramtype eq 'wmzstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_mutable_mzstring(${var}, $stop))";
    } elsif ($paramtype eq 'nmzstring' || $paramtype eq 'ncmzstring') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_mzstring($var, $stop))";
    } elsif ($paramtype eq 'pathname' || $paramtype eq 'cpathname') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_pathname(${var}, $stop))";
    } elsif ($paramtype eq 'npathname' || $paramtype eq 'ncpathname') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_pathname(${var}, $stop))";
    } elsif ($paramtype eq 'wpathname') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_write_pathname(${var}, $stop))";
    } elsif ($paramtype eq 'wnpathname') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_write_pathname(${var}, $stop))";
    } elsif ($paramtype eq 'epathname' || $paramtype eq 'cepathname') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_epathname(${var}, $stop))";
    } elsif ($paramtype eq 'nepathname' || $paramtype eq 'ncepathname') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_epathname(${var}, $stop))";
    } elsif ($paramtype eq 'xpathname' || $paramtype eq 'cxpathname') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_xpathname(${var}, $stop))";
    } elsif ($paramtype eq 'nxpathname' || $paramtype eq 'ncxpathname') {
	print "(${paramtype})WITH_VAR_STACK(objscheme_unbundle_nullable_xpathname(${var}, $stop))";
    } elsif (substr($paramtype, -1) eq '!') {
	substr($paramtype, -1) = '';
	&PrintUnbundleObject($var, $paramtype, 0, $mname);
    } elsif (substr($paramtype, -1) eq '^') {
	substr($paramtype, -1) = '';
	&PrintUnbundleObject($var, $paramtype, 1, $mname);
    } elsif (substr($paramtype, -1) eq '%') {
	substr($paramtype, -1) = '';
	print "*" if ($outgoing);
	&PrintUnbundleObject("$var", $paramtype, 0, $mname);
    } elsif (substr($paramtype, 0, 4) eq 'SYMZ') {
	$paramtype =~ /SYMZ\[(.*)\]/;
	$symtype = $1;
	print "WITH_VAR_STACK(unbundle_symset_${symtype}($var, NULL))";
    } elsif (substr($paramtype, 0, 3) eq 'SYM') {
	$paramtype =~ /SYM\[(.*)\]/;
	$symtype = $1;
	print "WITH_VAR_STACK(unbundle_symset_${symtype}($var, $stop))";
    } else {
	print STDERR "Unknown type ${paramtype} in $func.\n";
    }
}

sub NormalType {
    local($paramtype, $islocal) = @_;

    if (substr($paramtype, -1) eq '*' || substr($paramtype, -1) eq '?') {
	substr($paramtype, -1) = '';
	$paramtype = &NormalType($paramtype) . '*';
    } elsif (substr($paramtype, 0, 7) eq 'unknown') {
	return substr($paramtype, 8);
    } elsif (substr($paramtype, -1) eq '!') {
	substr($paramtype, -1) = '*';
	$paramtype = "class " . $paramtype;
    } elsif (substr($paramtype, -1) eq '^') {
	substr($paramtype, -1) = '*';
	$paramtype = "class " . $paramtype;
    } elsif (substr($paramtype, -1) eq '%') {
	if ($islocal) {
	    substr($paramtype, -1) = '*';
	} else {
	    substr($paramtype, -1) = '&';
	}
	$paramtype = "class " . $paramtype;
    } elsif (substr($paramtype, -1) eq '+') {
	substr($paramtype, -1) = '';
	$paramtype = &NormalType($paramtype);
	if ($islocal) {
	     $paramtype = $paramtype . '*';
	} else {
	     $paramtype = $paramtype . '&';
	}
    } elsif (substr($paramtype, -2) eq '[]') {
	substr($paramtype, -2) = '*';	
    } elsif ($islocal && (substr($paramtype, -1) eq '&')) {
	substr($paramtype, -1) = '';
	$paramtype = &NormalType($paramtype) . '*';
    } elsif ($paramtype eq 'uchar') {
	$paramtype = 'unsigned char';
    } elsif (substr($paramtype,0,4) eq 'rint') {
	$paramtype = 'int';
    } elsif ($paramtype eq 'bool') {
	$paramtype = $bool;
    } elsif ($paramtype eq 'Long') {
	$paramtype = 'long';
    } elsif ($paramtype eq 'ExactLong') {
	$paramtype = 'ExactLong';
    } elsif ($paramtype eq 'Double') {
	$paramtype = 'double';
    } elsif (substr($paramtype,0,7) eq 'rdouble') {
	$paramtype = 'double';
    } elsif (substr($paramtype, 0, 4) eq 'nnls') {
	$paramtype = 'long';
    } elsif (substr($paramtype, 0, 4) eq 'nnfs') {
	$paramtype = 'double';
    } elsif (substr($paramtype, 0, 3) eq 'SYM') {
	$paramtype = 'int';
    }

    return $paramtype;
}

sub PrintParams {

    ($dodefval, $prefix, $pointify) = @_;

    if ($prefix eq '') {
	$prefix = 'x';
    }

    $paramnum = 0;
    @defvs = @defvals;
    foreach $paramtype (@paramtypes) {
	$defval = shift(@defvs);

	print ", " if ($paramnum > 0);

	print &NormalType($paramtype, $pointify) . " ${prefix}${paramnum}";
	if ($dodefval && ($defval ne '') && ($defval ne '.')) {
	    print " = ${defval}";
	}
	$paramnum += 1;
    }
}

sub PrintArgs 
{
    local($direct) = @_;

    $paramnum = 0;
    foreach $paramtype (@paramtypes) {
	print ", " if ($paramnum > 0);
	print "*" if (($direct != 1) && &CallByRef($paramtype));
	print "x${paramnum}";
	$paramnum += 1;
    }
}

sub PrintLocals
{
    local($prefix) = @_;
    
    $paramnum = 0;
    @pbls = @pushables;
    foreach $paramtype (@paramtypes) {
	$pt = $paramtype;
	$pushable = shift(@pbls);

	if (&NeedsDeref($pt)) {
	    $temp = $pt;
	    substr($temp, -1)  = '';
	    print "$prefix  " . &NormalType($temp) . " _x${paramnum};\n";
	    $deref = 1;
	} else {
	    $deref = 0;
	}
	print "$prefix  " . &NormalType($pt, 1) . " x${paramnum}";
	if ($deref) {
	    print " = &_x${paramnum}";
	} else {
	    if ($pushable =~ /push/) {
		if ($pushable eq "push") {
		    print " INIT_NULLED_OUT";
		}
	    } elsif (ParamIsPointer($pt)) {
		print " INIT_NULLED_OUT";
	    }
	}
        print ";\n";
	$paramnum += 1;
    }
}

sub PrintUnbundles
{
    local($prefix, $mname) = @_;

    $paramnum = 0;
    @defvs = @defvals;
    @unbunds = @unbundles;
    @scms = @schemes;
    $offset = 0;
    foreach $paramtype (@paramtypes) {
	$defval = shift(@defvs);
	$unbundle = shift(@unbunds);
	$scheme = shift(@scms);

	if ($scheme || ($unbundle ne '')) {
	    print "$prefix  ";
	    if (($defval ne '') && ($defval ne '.')) {
		print "if (n > ($POFFSET+" . ($paramnum -  $offset) . ")) {\n$prefix    ";
	    }
	    $svar = "p[$POFFSET+" . ($paramnum - $offset) . "]";
	    $xvar = "x${paramnum}";
	    if (&NeedsDeref($paramtype)) {
		if (&CanBeNull($paramtype)) {
		    print "if (XC_SCHEME_NULLP($svar))\n";
		    print "$prefix    $xvar = NULL;";
		    print "\n$prefix  else\n";
		}
		print "$prefix    *";
	    }
	    print "$xvar = ";
	    &PrintUnbundleVar($svar, $paramtype, $unbundle, "", $mname);
	    print ";\n";
	    if (($defval ne '') && ($defval ne '.')) {
		print "$prefix  } else\n$prefix    ";
		print "x${paramnum} = ";
		print "${defval}";
		print ";\n";
	    }
	} 

	if (!$scheme) {
	    $offset += 1;
	}
	$paramnum += 1;
    }
}

sub PrintBundledEffects
{
    local($prefix) = @_;

    $paramnum = 0;
    $offset = 0;
    foreach $paramtype (@paramtypes) {
	if ($schemes[$paramnum]) {
	    if (&NeedsDeref($paramtype)) {
		$pos = $paramnum - $offset;
		print "$prefix  if (n > ($POFFSET+$pos)";
		print " && !XC_SCHEME_NULLP(p[$POFFSET+$pos])" if &CanBeNull($paramtype);
		print ")\n$prefix    { Scheme_Object *sbv_ = ";
		substr($paramtype, -1) = '';
		&PrintBundleVar("_x${paramnum}", $paramtype, 'WITH_VAR_STACK', $bundle);
		print "; WITH_VAR_STACK(objscheme_set_box(p[$POFFSET+$pos], sbv_)); } \n";
	    }
	} else {
	    $offset += 1;
	}
	$paramnum += 1;
    }
}

sub PrintUnbundledEffects
{
    local($prefix) = @_;

    $paramnum = 0;
    $offset = 0;
    foreach $paramtype (@paramtypes) {
	if ($schemes[$paramnum]) {
	    if (&NeedsDeref($paramtype)) {
		# substr($paramtype, -1) = '';
		print "$prefix  ";
		if (!&CallByRef($paramtype)) {
		    print "if (x${paramnum}) *";
		}
		print "x${paramnum} = ";
		$svar = "p[$POFFSET+". ($paramnum - $offset) . "]";
		&PrintUnbundleVar($svar, $paramtype, undef, undef, &GetMethod(1) . "\", extracting return value via box\"");
		print ";\n";
	    }
	} else {
	    $offset += 1;
	}
	$paramnum += 1;
    }	
}

sub PrintSboxTmp
{
    $paramnum = 0;
    foreach $paramtype (@paramtypes) {
	if ($schemes[$paramnum]) {
	    if (&NeedsDeref($paramtype)) {
		print "  Scheme_Object *sbox_tmp;\n";
		return;
	    }
	}
	$paramnum += 1;
    }	
}

sub SomeParamNeedsDeref
{
    $paramnum = 0;
    foreach $paramtype (@paramtypes) {
	if ($schemes[$paramnum]) {
	    if (&NeedsDeref($paramtype)) {
		return 1;
	    }
	}
	$paramnum += 1;
    }

    return 0;
}

sub PrintTypecheckObj
{
    local($var, $paramtype, $stop, $nullOK) = @_;

    $nullOK = '0' if ($nullOK eq '');
    $stop = &GetMethod($stop);

    print "WITH_REMEMBERED_STACK(objscheme_istype_${paramtype}($var, $stop, $nullOK))";
    print HEADER "extern int objscheme_istype_${paramtype}";
    print HEADER "(Scheme_Object *, const char *, int);\n";
}

sub PrintTypecheck
{
    local($var, $paramtype, $check, $stop) = @_;

    $stop = &GetMethod($stop);

    if (substr($paramtype, 0, 7) eq 'unknown') {
	print "WITH_REMEMBERED_STACK(objscheme_istype_generic($var, $stop))";
    } elsif (($check ne undef) && ($check ne '')) {
	print &ApplyMacros($check, $var, $stop);
    } elsif (substr($paramtype, -1) eq '*') {
	print "(WITH_REMEMBERED_STACK(objscheme_istype_box($var, $stop)) && ";
	substr($paramtype, -1) = '';
	&PrintTypecheck("objscheme_unbox($var, $stop)", $paramtype, '', &Unboxing($stop));
	print ")";
    } elsif (substr($paramtype, -1) eq '+') {
	print "(WITH_REMEMBERED_STACK(objscheme_istype_box($var, $stop)) && ";
	substr($paramtype, -1) = '';
	&PrintTypecheck("WITH_REMEMBERED_STACK(objscheme_unbox($var, $stop))", $paramtype, '', &Unboxing($stop));
	print ")";
    } elsif (substr($paramtype, -1) eq '?') {
	print "(XC_SCHEME_NULLP($var) || (WITH_REMEMBERED_STACK(objscheme_istype_box($var, $stop)) && ";
	substr($paramtype, -1) = '';
	&PrintTypecheck("WITH_REMEMBERED_STACK(objscheme_nullable_unbox($var, $stop))", $paramtype, '', &Unboxing($stop));
	print "))";
    } elsif (substr($paramtype, -1) eq '&') {
	substr($paramtype, -1) = '';
	&PrintTypecheck($var, $paramtype);
    } elsif ($paramtype eq 'bool') {
	print "WITH_REMEMBERED_STACK(objscheme_istype_bool($var, $stop))";
    } elsif ($paramtype eq 'char' || $paramtype eq 'mzchar' || $paramtype eq 'uchar') {
	print "WITH_REMEMBERED_STACK(objscheme_istype_char($var, $stop))";
    } elsif (($paramtype eq 'int') || ($paramtype eq 'unsigned') 
	     || ($paramtype eq 'nnint') || ($paramtype eq 'nnlong') 
	     || ($paramtype eq 'byte') || ($paramtype eq 'ubyte')
	     || ($paramtype eq 'short') || ($paramtype eq 'long')
	     || ($paramtype eq 'double') || ($paramtype eq 'nndouble') 
	     || (substr($paramtype,0,4) eq 'rint')
	     || (substr($paramtype,0,7) eq 'rdouble')) {
	print "WITH_REMEMBERED_STACK(objscheme_istype_number($var, $stop))";
    } elsif (substr($paramtype,0,4) eq 'nnls') {
	$paramtype =~ /nnls\[(.*)\]/;
	$symname = $1;
	print "WITH_REMEMBERED_STACK(objscheme_istype_nonnegative_symbol_integer($var, \"$symname\", $stop))";
    } elsif (substr($paramtype,0,4) eq 'nnfs') {
	$paramtype =~ /nnfs\[(.*)\]/;
	$symname = $1;
	print "WITH_REMEMBERED_STACK(objscheme_istype_nonnegative_symbol_double($var, \"$symname\", $stop))";
    } elsif (($paramtype eq 'ExactLong')) {
	print "WITH_REMEMBERED_STACK(objscheme_istype_ExactLong($var, $stop))";
    } elsif (($paramtype eq 'Long')) {
	print "WITH_REMEMBERED_STACK(objscheme_istype_integer($var, $stop))";
    } elsif (($paramtype eq 'Double')) {
	print "WITH_REMEMBERED_STACK(objscheme_istype_double($var, $stop))";
    } elsif ($paramtype eq 'string' || $paramtype eq 'cstring') {
	print "WITH_REMEMBERED_STACK(objscheme_istype_string($var, $stop))";
    } elsif ($paramtype eq 'nstring' || $paramtype eq 'ncstring') {
	print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_string($var, $stop)))";
    } elsif ($paramtype eq 'bstring' || $paramtype eq 'cbstring'
	     || $paramtype eq 'wbstring') {
	print "WITH_REMEMBERED_STACK(objscheme_istype_bstring($var, $stop))";
    } elsif ($paramtype eq 'nbstring' || $paramtype eq 'ncbstring') {
	print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_bstring($var, $stop)))";    
    } elsif ($paramtype eq 'pstring' || $paramtype eq 'cpstring') {
	print "WITH_REMEMBERED_STACK(objscheme_istype_pstring($var, $stop))";
    } elsif ($paramtype eq 'npstring' || $paramtype eq 'ncpstring') {
	print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_pstring($var, $stop)))";
    } elsif ($paramtype eq 'mzstring' || $paramtype eq 'mzxstring' || $paramtype eq 'cmzstring'
	     || $paramtype eq 'wmzstring') {
	print "WITH_REMEMBERED_STACK(objscheme_istype_mzstring($var, $stop))";
    } elsif ($paramtype eq 'nmzstring' || $paramtype eq 'ncmzstring') {
	print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_mzstring($var, $stop)))";    
    } elsif ($paramtype eq 'pathname' || $paramtype eq 'cpathname') {
	print "WITH_REMEMBERED_STACK(objscheme_istype_pathname($var, $stop))";
    } elsif ($paramtype eq 'npathname' || $paramtype eq 'ncpathname') {
	print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_pathname($var, $stop)))";
    } elsif ($paramtype eq 'epathname' || $paramtype eq 'cepathname') {
	print "WITH_REMEMBERED_STACK(objscheme_istype_epathname($var, $stop))";
    } elsif ($paramtype eq 'nepathname' || $paramtype eq 'ncepathname') {
	print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_epathname($var, $stop)))";
    } elsif ($paramtype eq 'xpathname' || $paramtype eq 'cxpathname') {
	print "WITH_REMEMBERED_STACK(objscheme_istype_xpathname($var, $stop))";
    } elsif ($paramtype eq 'nxpathname' || $paramtype eq 'ncxpathname') {
	print "(XC_SCHEME_NULLP($var) || WITH_REMEMBERED_STACK(objscheme_istype_xpathname($var, $stop)))";
    } elsif (substr($paramtype, -1) eq '!') {
	substr($paramtype, -1) = '';
	&PrintTypecheckObj($var, $paramtype, $stop);
    } elsif (substr($paramtype, -1) eq '^') {
	substr($paramtype, -1) = '';
	&PrintTypecheckObj($var, $paramtype, $stop, 1);
    } elsif (substr($paramtype, -1) eq '%') {
	substr($paramtype, -1) = '';
	&PrintTypecheckObj("$var", $paramtype, $stop);
    } elsif (substr($paramtype, 0, 3) eq 'SYM') {
	$paramtype =~ /SYMZ?\[(.*)\]/;
	$symtype = $1;
	print "WITH_REMEMBERED_STACK(istype_symset_${symtype}($var, $stop))";
    } else {
	print STDERR "Unknown type ${paramtype} in $func.\n";
    }
}

sub NeedsDeref
{
    local($paramtype) = @_;

    return ((substr($paramtype,0,7) ne 'unknown')
	    && ((substr($paramtype, -1) eq '*')
		|| (substr($paramtype, -1) eq '+')
		|| (substr($paramtype, -1) eq '?')))
}

sub CanBeNull
{
    return (substr($_[0], -1) eq '?');
}

sub CallByRef
{
    local($paramtype) = @_;

    return ((substr($paramtype, -1) eq '&')
	    || (substr($paramtype, -1) eq '+')
	    || (substr($paramtype, -1) eq '%'));
}

sub GetMethod
{
    local ($stop) = @_;

    if ($stop > 0) {
	return $method;
    } else {
	return "NULL";
    }
}

sub Overridden
{
    local($function, $pos) = @_;

    &ReadFields($function);
    $thefunc = $func;
    @theparamtypes = @paramtypes;
    $thepos = $pos;
    $fp = 0;
    foreach $func (@funcnames) {
	if ($fp >= $thepos) {
	    return 0;
	}
	if ($thefunc eq $func) {
	    &ReadFields($functions[$fp]);
	    if ($#paramtypes == $#theparamtypes) {
		$same = 1;
		foreach $pos (0 .. $#paramtypes) {
		    if ($paramtypes[$pos] ne $theparamtypes[$pos]) {
			$same = 0;
		    }
		}
		if ($same) {
		    return 1;
		}
	    }
	}
	$fp += 1;
    }

    return 0;
}

sub Unboxing
{
    local($stop) = @_;

    if ($stop) {
	return "$stop\", extracting boxed argument\"";
    } else {
	return $stop;
    }
}

sub OperatorClean
{
    if (index($_[0], "operator") == $[) {
	$_[0] =~ s/</LT/g;
	$_[0] =~ s/>/GT/g;
	$_[0] =~ s/\*/STAR/g;
	$_[0] =~ s/\-/MINUS/g;
	$_[0] =~ s/\+/PLUS/g;
	$_[0] =~ s/\&/AND/g;
	$_[0] =~ s/\|/OR/g;
	$_[0] =~ s/\!/BANG/g;
	$_[0] =~ s/\:/COLON/g;
	$_[0] =~ s/\@/AT/g;
	$_[0] =~ s/\=/EQUAL/g;
	$_[0] =~ s/\$/DOLLAR/g;
	$_[0] =~ s/\%/MOD/g;
	$_[0] =~ s/\#/NUMBER/g;
	$_[0] =~ s/\~/TILDE/g;
	$_[0] =~ s/\//SLASH/g;
    }
	
    return $_[0];
}

sub OIStart
{
    if ($onlyif ne '') {
	print "#if $onlyif\n";
    }
}

sub OIEnd
{
    if ($onlyif ne '') {
	print "#endif\n";
    }
}

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

    if ($kind =~ /ONE/) {
	$multi = 0;
	$lname = "";
    } else {
	$multi = 1;
	$lname = " list";
    }
    if ($kind =~ /CHAR/) {
	$char = 1;
    } else {
	$char = 0;
    }

    if ($#syms < 0) {
	if (!($omit =~ /PRED/)) {
	    print "static int istype_symset_${name}(Scheme_Object *v, const char *where) {\n";
	    print "  if SCHEME_NULLP(v) return 1;\n";
	    print "  if (where) scheme_wrong_type(where, \"$name symbol${lname}\", -1, 0, &v);\n";
	    print "  return 0;\n";
	    print "}\n\n";
	}
	if (!($omit =~ /UNBUNDLE/)) {
	    print "static int unbundle_symset_${name}(Scheme_Object *v, const char *where) {\n";
	    print "  istype_symset_${name}(v, where);\n";
	    print "  return 0;\n";
	    print "}\n";
	}
	if (!($omit =~ /BUNDLE/)) {
	    print "static Scheme_Object *bundle_symset_${name}(int) {\n";
	    print "  return scheme_null;\n";
	    print "}\n\n";
	}
	return;
    }

    foreach $sym (@syms) {
	($n, $v) = split(/,/, $sym);
	print "static Scheme_Object *${name}_${v}_sym = NULL;\n";
    }
    print "\n";

    print "static void init_symset_${name}(void) {\n";
    print "  REMEMBER_VAR_STACK();\n";
    foreach $sym (@syms) {
	($n, $v) = split(/,/, $sym);
	print "  wxREGGLOB(${name}_${v}_sym);\n";
	print "  ${name}_${v}_sym = WITH_REMEMBERED_STACK(scheme_intern_symbol($n));\n";
    }
    print "}\n\n";

    foreach $mode ("unbundle", "istype") {
	if ($mode eq 'unbundle') {
	    $dothisone = !($omit =~ /UNBUNDLE/);
	} else {
	    $dothisone = !($omit =~ /PRED/);
	}

	if ($dothisone) {
	    print "static int ${mode}_symset_${name}(Scheme_Object *v, const char *where) {\n";
	    print "  SETUP_VAR_STACK(1);\n";
	    print "  VAR_STACK_PUSH(0, v);\n";
	    print "  if (!${name}_${v}_sym) WITH_VAR_STACK(init_symset_${name}());\n";
	    if ($multi) {
		$vv = "i";
		print "  Scheme_Object *i INIT_NULLED_OUT, *l = v;\n";
		if ($mode eq 'unbundle') {
		    print "  long result = 0;\n";
		} else {
		    print "  long result = 1;\n";
		}
		print "  while (SCHEME_PAIRP(l)) {\n";
		print "  i = SCHEME_CAR(l);\n";
		if ($mode eq 'unbundle') {
		    $donepre = "result = result | ";
		} else {
		    $donepre = "";
		}
		$donepost = "";
	    } else {
		$vv = "v";
		$donepre = "READY_TO_RETURN; return ";
		$donepost = "";
	    }
	    print "  if (0) { }\n";
	    if ($char) {
		print "  else if (SCHEME_CHARP(v)) { READY_TO_RETURN; return ";
		if ($mode eq 'unbundle') {
		    print "SCHEME_CHAR_VAL(v)";
		} else {
		    print "1";
		}
		print "; }\n";
	    }
	    foreach $sym (@syms) {
		($n, $v) = split(/,/, $sym);
		if ($mode eq 'unbundle') {
		    $result = $v;
		} else {
		    if ($multi) {
			$result = "";
		    } else {
			$result = "1";
		    }
		}
		print "  else if (${vv} == ${name}_${v}_sym) { $donepre$result$donepost; }\n";
	    }
	    if ($multi) {
		print "  else { break; } \n";
		print "  l = SCHEME_CDR(l);\n";
		print "  }\n";
		print "  if (SCHEME_NULLP(l)) { READY_TO_RETURN; return result; }\n";
	    }
	    print "  if (where) WITH_VAR_STACK(scheme_wrong_type(where, \"$name symbol${lname}\", -1, 0, &v));\n";
	    print "  READY_TO_RETURN;\n";
	    print "  return 0;\n";
	    print "}\n\n";
	}
    }

    if (!($omit =~ /BUNDLE/)) {
	print "static Scheme_Object *bundle_symset_${name}(int v) {\n";
	if ($multi) {
	    print "  REMEMBER_VAR_STACK();\n";
	}
	print "  if (!${name}_${v}_sym) init_symset_${name}();\n";
	if ($multi) {
	    print "  Scheme_Object *l = scheme_null;\n";
	    foreach $sym (@syms) {
		($n, $v) = split(/,/, $sym);
		print "  if (v & $v) l = WITH_REMEMBERED_STACK(scheme_make_pair(${name}_${v}_sym, l));\n";
	    }
	    print "  return l;\n";
	} else {
	    print "  switch (v) {\n";
	    foreach $sym (@syms) {
		($n, $v) = split(/,/, $sym);
		print "  case $v: return ${name}_${v}_sym;\n";
	    }
	    if ($char) {
		print "  default: return scheme_make_char_or_nul(v);\n";
	    } else {
		print "  default: return NULL;\n";
	    }
	    print "  }\n";
	}
	print "}\n\n";
    }
}
