###################################################################
#  oopl.pl
#  OOPL Language Parser  -  v002a
#
#  Copyright(C) Dan Ramage, 2000
#               dramage@worldnet.att.net
#               http://www.geocities.com/drram/
#
#
#  This program is released under the terms and conditions of the
#  GNU General Public Liscense and is provided without warranty.
#  Enjoy!
#
#  Last build: Jan 17, 2000
###################################################################

package main;

# Print the welcome message
print <<EOF;
OOPL Language Parser v002a       -  Jan 17, 2000
  Copyright(C) Dan Ramage, 2000  -  http://www.geocities.com/drram/
  This program is released under the terms and conditions of the
  GNU General Public Liscense and is provided without warranty.

EOF


foreach $arg (@ARGV)
    {
    if ($arg =~ s/^(-|\/)//)
        {
        $incldir = $1 if ($arg =~ /^i(.*)/);
        $oplidir = $1 if ($arg =~ /^I(.*)/);
        $outpdir = $1 if ($arg =~ /^o(.*)/i);
        $build   = $1 if ($arg =~ /^(b)/i);
        $help    = $1 if ($arg =~ /^(h|\?)/i);
        }
    else
        {
        $file = $arg;
        @_ = split /\\/,$file;
        $file = pop @_;
        $currdir = (join "\\",@_);
        }
    }


if ($help or not $file)
    {
    print <<EOF;

Usage: oopl [-ipath] [-Ipath] [-opath] [-b|-B] source.oop

    Parses OOPL file source.oop and generates output source.oop.opl in text
    format.  Generated file can be built using opltran or on EPOC by running
    the program editor and importing source.oop.opl.

    -ipath specifies path for #include <>
    -Ipath specifies path for OPL INCLUDE command if differs from -ipath
    -opath specifies path for ouput .opo file (PC only)
    -b directs oopl to build generated file using opltran (PC only)
    -B same as -b but deletes source.oop.opl after opltran completes (PC only)

EOF
    exit;
    }

# Create a new parser object and parse the file
$parser = oopl_parser->new(context->new($currdir,$incldir),$file);
$parser->parse();

# Write the output file
$parser->write("$file.opl");

$file = $parser->{file_context}->build_filename("$file.opl");

if ($build)
    {
    $oplidir = $incldir unless $oplidir;
    $oplidir = "-i$oplidir" if $oplidir;
    $outpdir = "-o$outpdir" if $outpdir;
    print "\nBuilding $file\n";
    system "opltran $file $oplidir $outpdir";
    if ($build eq 'B')
        {
        print "\nDeleting $file";
        unlink $file;
        }
    print "\nDone.\n";
    }


sub escape
    {
    my $in = shift;

    $in =~ s/(\(|\)|\+|\*|\?|\\|\/|\$|\@|\%|\.|\^|\{|\}|\[|\]|\|)/\\$1/g;
    return $in;
    }


# Un-comment the following two lines if you want to see the OOPL parser's
# internal representation of the parsed code (only works on PC):
# use Data::Dumper;
# print Dumper($parser);




# parser class - generic superclass for all parsers
package parser;

sub new
	{
	my $type = shift;
	my $self = {};

	bless $self, $type;

    $self->{file_context} = shift;
    $self->{filename}     = $self->{file_context}->build_filename(shift);

	# Open file
    if (not (open IN, "<$self->{filename}"))
        {
        print "Error: File $self->{filename} not found\n";
        exit;
        }
	$self->{file} = join '', <IN>;
	close IN;

	# Quotes
    while ($self->{file} =~ /(\"(.*?)\")/)
        {
        my $quote = $1;
        push  @{$self->{quote}}, $quote;
        $quote = &main::escape($quote);
        $self->{file} =~ s/$quote/\^\^\^$#{$self->{quote}}\^\^\^/g;
        }

	# Prepare file
	$self->prepare_file();

	# Free memory
	delete $self->{file};

	return $self;
	}


# Virtual method - prepare file pre-parsing
sub prepare_file
	{
	my $self = shift;

	@{$self->{line}} = split /\n/,$self->{file};

	$self->{file} = join "\n", @{$self->{line}};
	}

sub write
	{
	my $self     = shift;
    my $filename = $self->{file_context}->build_filename(shift);


	open  OUT, ">$filename";

    print OUT (join '',@{$self->{line}});

	close OUT;
	}


sub parse
	{
	my $self = shift;

	$self->{pos} = 0;

    print "Parsing $self->{filename}...\n";

    foreach $line (@{$self->{line}})
        {
        $line = $self->parse_line($line);
        $self->{pos}++;
        $line =~ s/\^\^\^(\d+)\^\^\^/$self->{quote}[$1]/g;
        }

    print "Done.\n\n";
	}

# virtual method  -  parse a line
sub parse_line
	{
	my $self = shift;
	my $line = shift;

	return $line;
	}


sub die
	{
	my $self    = shift;
	my $message = shift;

    print "Aaah!  A terrible death!\n\n$message ". $self->current_location() . "\n\n";

#   Un-comment the following two lines of code if you want to see the
#   nitty-gritty if your program dies with an error:
#    use Data::Dumper;
#    print Dumper($self);
	exit;
	}

sub current_location
    {
    my $self = shift;

    return "in $self->{filename}";
    }

sub nice_string
	{
	my $self = shift;
	my @t		 = split /\"/, shift;

	for (my $i = 0; $i<=$#t; $i++)
		{
		if (!($i % 2))
			{
			$t[$i] =~ s/(\s+)/ /g;
			$t[$i] =~ s/(\s+)$//;
			$t[$i] =~ s/^(\s+)//;
			}
		}

    return uc(join "\"", @t);
	}


# oopl_parser class  -  parse oop files
package oopl_parser;

BEGIN
	{
	@ISA = qw(parser);
	}

sub current_location
    {
    my $self = shift;
    my $ret  = "in " .
      ($self->{context}{prc_classname} ? "$self->{context}{prc_classname}::" : "") .
      "$self->{context}{prc_procname}: " if ($self->{context}{prc_procname});

    $ret .= "in line \"$self->{current_line}\" in $self->{filename}";

    return $ret;
    }

sub prepare_file
	{
	my $self = shift;

	$self->parser::prepare_file();
	delete $self->{line};

	# line-splits
	$self->{file} =~ s/\\\n//g;

	# Comments
	$self->{file} =~ s/(\/\*)((.|\s)*?)(\*\/)//g;
	$self->{file} =~ s/(\s*)(\/\/|REM)(\s*)((.|\s)*?)(\n|$)/$6/g;

	# Split file into lines
	my @lines = split /\n/, $self->{file};

	foreach $line (@lines)
		{
		$line = $self->nice_string($line);

        # Funky, confusing spaces
        $line =~ s/(\s*),(\s*)/,/g;
        $line =~ s/\((\s*)/\(/g;
        $line =~ s/(\s*)\)/\)/g;


		push @{$self->{line}}, ($line =~ /^(STATIC )*CLASS/ ?
			$line : (split /\s+:\s*/, $line));
		}

	$self->{file} = join "\n", @{$self->{line}};
	}

sub parse_line
	{
    my $self = shift;
	my $line = $self->parser::parse_line(shift);
    my $preline  = "";
    my $postline = "";
    my @quote;

    study $line;
    $self->{current_line} = $line;

    if ($line =~ /^#(.*?) (.*)/)
        {
        my $command = $1;
        my $arg     = $2;

        if ($command eq "INCLUDE")
            {
            print "\n";

            $arg =~ s/\^\^\^(\d+)\^\^\^/$self->{quote}[$1]/;

            my $parser = oopl_parser->new($self->{file_context},$arg);
            $parser->absorb($self);
            $parser->parse();
            $line = join '', @{$parser->{line}};
            $self->absorb($parser);
            }
        else
            {
            $self->die("Warning: unsupported preprocessor command \"$command\"; continuing anyway...");
            }
        }
    elsif ($line =~ /^STRUCT (.*)$/)
		{
        $self->die("Structure fault 0") if defined $self->{context};

		$self->{context}{str_control} = "STRUCT";
        $self->{context}{str_data}    = structure->new($1);

        $self->{struct}{$1} = $self->{context}{str_data};

		$line = '';
		}
    elsif ($line eq 'ENDS')
		{
        $self->die("Structure fault 1") unless $self->{context}{str_control} eq "STRUCT";

		delete $self->{context};

		$line = '';
		}
	elsif ($line =~ /^(STATIC )*CLASS /)
		{
        $self->die("Structure fault 2") if defined $self->{context};

        $line =~ /^(STATIC )*(CLASS )(.*?)( :( *)((.|\s)*))*$/;

		my $static = $1 ? 1 : 0;
        my $name   = $3;
		my @super  = split /,/,$6;

		$self->{context}{cls_control} = "CLASS";
		$self->{context}{cls_data}    = class->new($name,\@super,$static);

        $self->{struct}{$name}  = $self->{context}{cls_data};

		$line = '';
		}
	elsif ($line eq 'ENDC')
		{
        $self->die("Structure fault 3") unless $self->{context}{cls_control} eq "CLASS";

		delete $self->{context};

		$line = '';
		}
	elsif ($line eq 'DATA')
		{
        $self->die("Structure fault 4") unless $self->{context}{cls_control} eq "CLASS";

		$self->{context}{str_control} = "DATA";
		$self->{context}{str_data}    = $self->{context}{cls_data};

		$line = '';
		}
	elsif ($line eq 'ENDD')
		{
        $self->die("Structure fault 5") unless $self->{context}{str_control} eq "DATA";
		delete $self->{context}{str_control};
		delete $self->{context}{str_data};

		$line = '';
		}
	elsif ($line =~ /^PROC( |$)/)
		{
        if (not defined $self->{context})
			{
			$self->{context}{prc_control}   = "PROC";

            $line =~ /^PROC ((.*)::)*(.*):(\((.*)\))*$/;
            $self->{context}{prc_procname}  = $3;
            $self->{context}{prc_classname} = $2 if $1;
			$self->{context}{prc_vardef}    = 1;

            print "$line\n";

			my @passed = split /,/, $5;
            unshift @passed, "<$self->{context}{prc_classname}\*>ME\@"
              if ($self->{context}{prc_classname} and $self->{context}{prc_classname} ne $self->{context}{prc_procname});

			$line  = "PROC ";
			$line .= $self->{context}{prc_classname} . "_"
              if $self->{context}{prc_classname};
			$line .= $self->{context}{prc_procname} . ":";
			$line .= '(' . $self->process_local(@passed) . ')'
              unless $#passed < 0;
			}
		elsif ($self->{context}{cls_control} eq "CLASS")
			{
			$self->{context}{mth_control} = "PROC";
			$self->{context}{mth_data}    = $self->{context}{cls_data};

			$line = '';
			}
		else
			{
            $self->die("Structure fault 6");
			}
 		}
	elsif ($line eq 'ENDP')
		{
		if ($self->{context}{prc_control} eq "PROC")
			{
            if (defined $self->{context}{prc_classname})
                {
                if ($self->{context}{prc_classname} eq $self->{context}{prc_procname})
                    {
                    $preline .= $self->parse_line("RETURN ME@");
                    }
                if (("_" . $self->{context}{prc_classname}) eq $self->{context}{prc_procname})
                    {
                    # Destructor

                    $preline .= $self->make_destructor("ME@",$self->{context}{prc_classname});
                    }
                }

            delete $self->{context};
			delete $self->{vars}{local};
            }
		elsif ($self->{context}{mth_control} eq "PROC")
			{
			delete $self->{context}{mth_control};
			delete $self->{context}{mth_data};

			$line = '';
			}
		else
			{
            $self->die("Structure fault 7");
			}
		}

    elsif ($line =~ /^EXTERN (.*)$/)                  # External variable reference
        {
        $self->process_global(split /,/,$1);
        $line = '';
        }
    else                                              # Not structure - data/code
		{
        if (defined $self->{context}{str_control})
			{
            $self->{context}{str_data}->add_entry($self->parse_vardef($line));

			$line = '';
			}
		elsif (defined $self->{context}{mth_control})
			{
			$self->{context}{mth_data}->add_method($line);

			$line = '';
			}
		elsif (defined $self->{context}{prc_control})
			{
            if ($line =~ /^(LOCAL|GLOBAL) (.*)$/)
				{
				$line = 'LOCAL '  . $self->process_local(split /,/,$2)
					if ($1 eq 'LOCAL');
				$line = 'GLOBAL ' . $self->process_global(split /,/,$2)
					if ($1 eq 'GLOBAL');
				}
			else
				{
                if ($self->{context}{prc_vardef})
					{
					#Insert code at start of proc that needs to go
					#at start of proc

					delete $self->{context}{prc_vardef};

					if (defined $self->{context}{prc_classname})
						{
						if ($self->{context}{prc_classname} eq $self->{context}{prc_procname})
							{
                            # Constructor

                            $preline .= $self->parse_line("LOCAL <".$self->{context}{prc_classname}."*>ME@")
                              . $self->make_constructor("ME@",$self->{context}{prc_classname});
							}
						}
					}

				#Process language extensions - multi-dimensional
				#arrays, struct references, method calls, built-in
                #macros, class instance creation/destruction

                while ($line =~ /SIZEOF\((.*?)\)/)
                    {
                    if (defined $self->{struct}{$1})
                      {
                      $line =~ s/SIZEOF\((.*?)\)/$self->{struct}{$1}->size()/e
                      }
                    else
                      {
                      $self->die("Invalid class/structure name \"$1\"");
                      }
                    }
                while ($line =~ /OFFSETOF\(((.*?),(.*?))\)/)
                    {
                    if (defined $self->{struct}{$2})
                      {
                      $line =~ s/OFFSETOF\(((.*?),(.*?))\)/$self->{struct}{$2}->offset_of_entry($3)/e
                      }
                    else
                      {
                      $self->die("Invalid class/structure name \"$1\"");
                      }
                    }

                if (not defined $self->{context}{prc_vardef})
                    {
                    my $go;

                    # Make the spacing right
                    $line =~ s/(\s*)(\+|-|\/|\*|=|>|<|\,|;)(\s*)/ $2 /g;
                    $line =~ s/\(/\( /g;
                    $line =~ s/\)/ \)/g;
                    $line =~ s/  / /g;
                    $line =~ s/(\s*)-(\s*)>(\s*)/->/g;
                    $line =~ s/ (\+|-|\/|\*|>|<) (<|>|=) / $1$2 /g;

                    # Process enhanced arithmetic operators (++,+=,*=,etc)
                    $line =~ s/^(.*) \+ \+/$1 \+= 1/g;
                    $line =~ s/^(.*) \- \-/$1 \-= 1/g;
                    $line =~ s/^(.*) (\+|-|\/|\*)= (.*)$/$1 = $1 $2 $3/g;

                    # Process NEW command
                    if ($line =~ /^(.*) = NEW (.*)$/)
                        {
                        my $var   = $1;
                        my $sname = $2;
                        my $match = &main::escape($&);

                        my $struct = $self->{struct}{$sname} || $self->struct_by_var($var);
                        if ($struct)
                            {
                            if ((ref $struct) eq "class" and $struct->find_method($struct->{name}))
                                {
                                chomp (my $call = $self->parse_line(" $struct->{name}::$struct->{name}:"));
                                $line =~ s/$match/$var = $call/;
                                }
                            else
                                {
                                my $t = $self->make_constructor($var,$struct->{name});
                                $line =~ s/$match/$t/;
                                }
                            }
                        }

                     # Process DESTROY command
                    if ($line =~ /^DESTROY (.*)$/)
                        {
                        my $var   = $1;
                        my $match = &main::escape($&);

                        my $struct = $self->struct_by_var($var);
                        if (((ref $struct) eq "class") and $struct->find_method("_" . $struct->{name}))
                            {
                            my $call = ($struct->{static} ? "$var._$struct->{name}:" : "$var->ROOT\@.DESTROY:");
                            $line =~ s/$match/$call/;
                            goto process_method;
                            }
                        else
                            {
                            my $t = $self->make_destructor($var,$struct->{name});
                            $line =~ s/$match/$t/;
                            }
                        }

                    process_method:
                    # Process pointer references and method calls
                    while ($line =~ /(^| )((\w+?)\@(\((.*?)\))*)(->|\.| |$)/)
                        {
                        my $expr  = $2;
                        my $post  = $6;
                        my $match = &main::escape($&);

                        build:
                        if ($post eq '->')
                            {
                            $line =~ /$match(.*?)(\(.*?\))*(->|\.| |$)/;
                            $expr .= '->'.$1.$2;
                            $post  = $3;
                            $match = &main::escape($&);
                            goto build;
                            }

                        my $new   = $self->process_pointer($expr);

                        if ($post eq '.')
                            {
                            my $class = $self->struct_by_var($new);
                            $self->die("Error: class not found") if not $class or ref $class ne "class";

                            $line =~ /$match(.*?)(\$|\&|\@|\%)*:/;
                            my $meth = $1;
                            my $type = $2;
                            $match = &main::escape($&);

                            if (($class->{static}) or ($meth eq $class->{name}) or ($meth eq ("_" . $class->{name})))
                                {
                                $new = "$class->{name}_$meth$type:($new)";
                                }
                            else
                                {
                                $new = "\@$type(COBJECT_CLASSBYMETHOD\$:(PEEKL($new),\"$meth\")+\"_$meth\"):(COBJECT_DATABYMETHOD&:(PEEKL($new)))";
                                }
                            }

                        $line =~ s/$match/ $new /;
                        $line =~ s/\)(\s*)\(/,/g;
                        }

                    # Process language extensions and cleanups:
                    # Get rid of pointer casts
                    $line =~ s/<(\s*)(\w*?)(\s*)\*(\s*)>(\s*)(\w*?)/$6/g;

                    # Make PEEK(a) = b into POKE a,b
                    while ($line =~ s/^(\s*)\((.*)\) = (.*)$/$1$2 = $3/) {};
                    $line =~ s/^(\s|\()*PEEK(.)(.*) = (.*)$/$1POKE$2 $3,$4/;

                    $line =~ s/(\D) \(/$1\(/g;

                    # Process straight method calls
                    $line =~ s/(^|\s)(\w*?)::(\w*?):/$1$2_$3:/g;
                    }
				}
            }
        else
            {
            delete $self->{context};
            }
		}

    return $preline . ($line ? $line . "\n" : $line) . $postline;
	}


# sub absorb  -  absorb another parser object's definitions
sub absorb
    {
    my $self = shift;
    my $victim = shift;

    push @{$self->{vars}{global}},@{$victim->{vars}{global}};
    $self->{struct}{$_} = $victim->{struct}{$_} foreach (keys %{$victim->{struct}});
    }


# sub parse_vardef  -  parse variable definitions into hash
sub parse_vardef
	{
	my $self = shift;
    my $line = shift;
    my $parsed = {};

    $line =~ /^(\s*<\s*(.*)\s*\*\s*>\s*)*\s*(.*?)(\@|\$|\%|\&)*(\((.*)\))*$/;
    my $vartype = $4;
    my @arg     = split /,/, $6;

    $parsed->{pointer} = $2;
    $parsed->{varname} = $3 . $4;
    $parsed->{size}    = 8   if ($vartype eq '');
    $parsed->{size}    = 4   if ($vartype eq '@' or $vartype eq '&');
    $parsed->{size}    = 2   if ($vartype eq '%');
    $parsed->{size}    = 1 + pop(@arg) if ($vartype eq '$');
    $parsed->{vartype} = $vartype;
    $parsed->{varlet}  = 'F' if $vartype eq '';
    $parsed->{varlet}  = 'W' if $vartype eq '%';
    $parsed->{varlet}  = 'L' if $vartype eq '&' or $vartype eq '@';
    $parsed->{varlet}  = '$' if $vartype eq '$';

    $parsed->{elements} = $#arg < 0 ? 1 : $arg[0];
    for (my $j = 1; $j <= $#arg; $j++)
        {
        $parsed->{elements} *= $arg[$j];
        }

    $parsed->{fullsize} = $parsed->{elements} * $parsed->{size};
    @{$parsed->{arg}} = @arg;

    return $parsed;
	}


sub process_local
	{
	my $self   = shift;
	my @vars   = @_;
    my $var;

    foreach $var (@vars)
        {
        my $i = $self->parse_vardef($var);
        push @{$self->{vars}{local}}, $i if ($i->{vartype} eq '@');
        }

    $_ =~ s/<(.*)>(.*)\@/$2\&/ foreach (@vars);
	return join ',', @vars;
	}

sub process_global
	{
	my $self   = shift;
	my @vars   = @_;
    my $var;

    foreach $var (@vars)
        {
        my $i = $self->parse_vardef($var);
        push @{$self->{vars}{global}}, $i if ($i->{vartype} eq '@');
        }

    $_ =~ s/<(.*)>(.*)\@/$2\&/ foreach (@vars);
	return join ',', @vars;
	}

sub locate_vardef
    {
    my $self    = shift;
    my $varname = shift;
    my $ret;

    foreach $var (@{$self->{vars}{global}})
        {
        $ret = $var if $var->{varname} eq $varname;
        }
    foreach $var (@{$self->{vars}{local}})
        {
        $ret = $var if $var->{varname} eq $varname;
        }

    return $ret;
    }

sub struct_by_var
    {
    my $self    = shift;
    my $varname = shift;
    my $sname;

    $varname = $self->process_pointer($varname) if ($varname =~ /->/);
    $varname =~ /^(\((\s*)<(\s*)(\S*?)(\s*)\*(\s*)>(\s*))*(.*)(\)\@)*$/;

    if ($1)
        {
        $sname = $4;
        }
    else
        {
        $varname = $8;
        $varname =~ s/\((.*)\)$//;
        my $var = $self->locate_vardef($varname);
        $sname  = $var->{pointer};
        }

    return $self->{struct}{$sname};
    }

sub process_pointer
    {
    my $self = shift;
    my $exp  = shift;

    my @list = split /->/,$exp;

    for (my $i = 0; $i <= $#list; $i++)
        {
        splice(@list, $i, 2, ($list[$i].'->'.$list[$i+1])) if ($list[$i] =~ /\(/ and not $list[$i] =~ /\(.*\)/);
        }

    my $var  = shift @list;
    my $mem  = shift @list;
    my $post = join '->',@list;

    my $p;

    my $index = "($2)" if $var =~ s/^(.*)\((.*)\)$/$1/;

    my $struct = $self->struct_by_var($var);
    $self->die("\"$var\" not a valid pointer") unless $struct;

    $var =~ s/^\((.*?)\)(\@|\&)*$/$1/;
    $var =~ s/\@$/\&/;

    if ($mem)
        {
        $mem =~ s/ //g;

        my @arg = split /,/, $2 if $mem =~ s/^(.*?)\((.*)\)$/$1/;

        my $entry  = $struct->locate_entry($mem);
        $self->die("Entry $mem not found in structure $struct->{name}") unless $entry;

        my $offset;
        my $z = 1;
        for (my $i = 0; $i <= $#arg; $i++)
            {
            $z *= ($i == 0 ? 1 : $entry->{arg}[$i-1]);
            $offset .= " + ".$entry->{size}." * ".($arg[$i] =~ /\D/ ? "( ".($arg[$i] =~ /\@/ ? $self->process_pointer($arg[$i]) : $arg[$i])." - 1 )" : $arg[$i]-1)." * ".$z;
            }

        $var = "PEEK" . $entry->{varlet} . "\{$var$index + " . $struct->offset_of_entry($entry->{varname}) . $offset . "\}";
        $p = $entry->{pointer};
        }
    else
        {
        $p = $struct->{name};
        }

    $index = "" if $mem;

    if ($post)
        {
        $var = $self->process_pointer("(<$p\*>$var)\@$index->$post");
        $p = "";
        }

    $var =~ s/\{/\(/g;
    $var =~ s/\}/\)/g;

    $var =~ s/<(.*?)\*>//;
    $p = $1 unless $p;

    $var =~ s/<(.*?)\*>//g;
    $var = "(<$p\*>$var$index)" if $p;

#    $var = s/(\+)(\d|\+|-|\*|\/|\s)+(\)|\+)/$1 . eval($2) . $3/e;
#    $var =~ s/(\d(\d|\+|-|\*|\/|\s)+)\)/eval($1).')'/ge;

    return $var;
    }


sub make_constructor
    {
    my $self = shift;
    my $var  = shift;
    my $cnam = shift;

    my $ret  = $self->parse_line("$var = ALLOC(SIZEOF(".$cnam."))");

    my $foundroot = 0;

    my $class = $self->{struct}{$cnam};
    my $t;

    if ((ref $class) eq "class")
        {
        foreach $t (@{$class->{superclass}})
            {
            $ret .= $self->parse_line("$var->SUPER_$t\@ = NEW $t");
            if ((not $class->{static}) and ($t eq "COBJECT"))
                {
                $ret .= $self->parse_line("$var->ROOT@ = $var->SUPER_$t\@");
                $foundroot = 1;
                }
            }

        if (not $class->{static})
            {
            if (not $foundroot)
                {
                $ret .= $self->parse_line("$var->ROOT@ = PEEKL($var->SUPER_$class->{superclass}[0]\@)");
                }

            $ret .= $self->parse_line("COBJECT_RegisterClass:($var->ROOT@,\"$class->{name}\",$var)");
            foreach $t (@{$class->{method}})
                {
                $ret .= $self->parse_line("COBJECT_RegisterMethod:($var->ROOT@,\"$class->{name}\",\"$t->{name}\")")
                unless (($t->{name} eq $class->{name}) or ($t->{name} eq ("_" . $class->{name})));
                }
            }
        }

    return $ret;
    }

sub make_destructor
    {
    my $self = shift;
    my $var  = shift;
    my $cnam = shift;
    my $t;

    my $ret;

    my $class = $self->{struct}{$cnam};

    if ((ref $class) eq "class")
        {
        foreach $t (@{$class->{superclass}})
            {
            $ret .= $self->parse_line($t.'::_'."$t:($var->SUPER_$t\@)");
            }
        }

    $ret .= $self->parse_line("FREEALLOC $var");

    return $ret;
    }





# context class - maps filenames, etc
package context;

sub new
    {
    my $type = shift;
    my $self = {};
    my $i;

    $self->{current_dir} = shift;
    $i = chop($self->{current_dir});
    if ($i)
        {
        $self->{current_dir} .= $i unless $i eq "\\";
        $self->{current_dir} .= "\\";
        }

    $self->{include_dir} = shift;
    $i = chop($self->{include_dir});
    if ($i)
        {
        $self->{include_dir} .= $i unless $i eq "\\";
        $self->{include_dir} .= "\\";
        }

    return bless $self, $type;
    }


sub build_filename
    {
    my $self     = shift;
    my $filename = shift;

    $filename =~ s/^(\"|<)*(.*?)(\"|>)*$/$2/;
    my $specifier = $1;

    if (not $filename =~ /^(.\:\\|\\)/)
        {
        $filename = "$self->{current_dir}$filename" if $specifier eq '"' or not $specifier;
        $filename = "$self->{include_dir}$filename" if $specifier eq '<';
        }

    return $filename;
    }









# structure class - keeps track of a named structure type
package structure;

sub new
	{
	my $type = shift;
	my $self = {};

    $self->{name} = uc(shift);

	return bless $self, $type;
	}

sub add_entry
	{
	my $self = shift;
    my $var  = shift;

    push @{$self->{data}}, $var;
	}

sub offset_of_entry
	{
	my $self = shift;
	my $name = uc(shift);
	my $size = 0.0;

	foreach $entry (@{$self->{data}})
		{
        return $size if (uc $entry->{varname} eq $name);
        $size += $entry->{fullsize};
		}

	return -1;
	}

sub size
	{
	my $self = shift;
	my $size;

    $size += $_->{fullsize} foreach (@{$self->{data}});

	return $size;
	}

sub locate_entry
    {
    my $self = shift;
    my $name = shift;

    foreach $entry (@{$self->{data}})
        {
        return $entry if $entry->{varname} eq $name;
        }
    }


# class class - keeps track of a named class type
package class;

BEGIN
	{
	@ISA = qw(structure);
	}

sub new
	{
	my $type = shift;
    my $self = structure->new(shift);

	$self->{superclass} = shift;
	$self->{static}     = shift;


    if (not $self->{static})
        {
        $self->add_entry($main::parser->parse_vardef("<COBJECT*>ROOT\@"));
        }

    foreach (@{$self->{superclass}})
        {
        $self->add_entry($main::parser->parse_vardef("<$_*>SUPER_$_\@"));
        }

	return bless $self, $type;
	}

sub add_method
	{
    my $self   = shift;
    my $method = shift;

    $method =~ /^(.*?)(\$|\&|\@|\%)*:(\((.*)\))*/;

    push @{$self->{method}}, {'name' => $1, 'return' => $2, 'arg' => $4};
	}

sub find_method
	{
	my $self = shift;
    my $name = shift;
    my $method;

	foreach $method (@{$self->{method}})
		{
        return true if ($name eq $method->{name});
		}
	}