view release on metacpan or  search on metacpan

lib/Language/Basic/Statement.pm  view on Meta::CPAN

    $self->{"expression"} = new Language::Basic::Expression::Arithmetic $token_group
        or Exit_Error("Bad expression in GOTO!");
} # end sub Language::Basic::Statement::Goto::parse

# Note that this sub allows "GOTO X+17/3", not just "GOTO 20"
sub implement {
    my $self = shift;
    my $prog = &Language::Basic::Program::current_program;
    my $goto = $self->{"expression"}->evaluate;
    if ($goto !~ /^\d+$/) {Exit_Error("Bad GOTO: $goto")}
    $prog->goto_line($goto);
} # end sub Language::Basic::Statement::Goto::implement

sub output_perl {
    my $self = shift;
    # if it's just a number , don't use $tmp
    my $exp = $self->{"expression"};
    my $goto = $exp->output_perl;
    my $ret;
    if ($goto =~ /^\d+$/) {
        $ret = "goto L$goto;";
    } else {
	# Form the label name
	$ret = "\$Goto_tmp = 'L' . " . $goto . ";\n";
	# Go to it
	$ret .= "goto \$Goto_tmp;";
    }

    return ($ret);
} # end sub Language::Basic::Statement::Goto::output_perl
} # end package Language::Basic::Statement::Goto

######################################################################
# package Language::Basic::Statement::If
# An IF statement in a BASIC program.
{
package Language::Basic::Statement::If;
@Language::Basic::Statement::If::ISA = qw(Language::Basic::Statement);
use Language::Basic::Common;

sub parse {
    my $self = shift;
    my $token_group = shift;

    # Until the token "then", we're copying a conditional expression
    my $exp = new Language::Basic::Expression::Logical_Or $token_group or
        Exit_Error("Bad Condition in IF!");
    $self->{"condition"} = $exp;
    $token_group->eat_if_string("THEN") or Exit_Error("IF missing 'THEN'!");

    # Until the token "ELSE" or the end of the line, is one or more
    # statements to do if the IF is true
    # TODO we need to handle ELSE either within the same statement
    # as the last THEN statement *OR* at the beginning of a statement.
    # Also nested IFs?

    # Take everything up to ELSE into a separate Token::Group &
    # call parsing with that so that other parse routines can complain if
    # there's something left in their token_group. Right now, they'll have
    # problem with ELSE token
    # TODO need a Token::Group::split method or some such
    my $t1 = new Language::Basic::Token::Group;
    $t1->slurp($token_group, "ELSE");

    # Call new with an extra arg so it knows it's parsing a THEN/ELSE.
    # That way, "THEN 20" gets parsed like "THEN GOTO 20"
    my $then = new Language::Basic::Statement $t1, "line_num_ok" or
	Exit_Error("No statement found after THEN");
    $then->parse($t1);
    my $oldst = $then;
    # Eat [: Statement]*
    while (defined($t1->eat_if_class("Statement_End"))) {
	# Plain line number is only allowed in the *first* THEN/ELSE statement
	my $st = new Language::Basic::Statement $t1;
	$st->parse($t1);
	$oldst->{"next_statement"} = $st;
	$oldst = $st;
    }
    # Make sure we don't do the ELSE after the THEN!
    $oldst->{"next_statement"} = undef;

    # If there's anything left in $token_group, it's the ELSE.
    my $else;
    if (defined($token_group->eat_if_string("ELSE"))) {
	# Use up all the leftover tokens
	$else = new Language::Basic::Statement $token_group, "line_num_ok" or
	    Exit_Error("No statement found after THEN");
	$else->parse ($token_group);
	$oldst = $else;
	while (defined($token_group->eat_if_class("Statement_End"))) {
	    my $st = new Language::Basic::Statement $token_group;
	    $st->parse($token_group);
	    $oldst->{"next_statement"} = $st;
	    $oldst = $st;
	}
	$oldst->{"next_statement"} = undef;
	Exit_Error("Unknown stuff after ELSE statement(s)") if 
	    $token_group->stuff_left;
    } else {
	Exit_Error("Unknown stuff after THEN statement(s)") if 
	    $token_group->stuff_left;
    }

    $self->{"then_s"} = $then;
    $self->{"else_s"} = $else; # may be undef
} # end sub Language::Basic::Statement::If::parse

# Need to set line numbers for THEN and ELSE statements, so we can't
# use the default LBS::set_line_number
sub set_line_number {
    my $self = shift;
    my $num = shift;
    $self->{"line_number"} = $num;
    foreach ("then_s", "else_s") {
        my $st = $self->{"$_"};
	while (defined $st) {
	    $st->set_line_number($num);
	    $st = $st->{"next_statement"};
	}
    }
}