external;

{
	Statements.p (of PCQ Pascal)
	Copyright (c) 1989 Patrick Quaid

	This module handles normal statements, including the
standard statements like if, while, case, etc.
}

const
{$I "pasconst.i"}

type
{$I "pastype.i"}

var
{$I "pasvar.i"}

	function loadvar(v : integer) : integer;
	    forward;
	function match(s : integer) : boolean;
	    forward;
	function expression() : integer;
	    forward;
	procedure error(s : string);
	    forward;
	function typecheck(t1, t2 : integer): boolean;
	    forward;
	procedure savestack(t : integer);
	    forward;
	procedure saveval(v : integer);
	    forward;
	procedure ns;
	    forward;
	procedure nextsymbol;
	    forward;
	function getlabel(): integer;
	    forward;
	procedure printlabel(l : integer);
	    forward;
	function suffix(s : integer) : char;
	    forward;
	procedure mismatch;
	    forward;
	function loadaddress() : integer;
	    forward;
	procedure callproc(v : integer);
	    forward;
	procedure stdproc(v : integer);
	    forward;
	function endoffile() : boolean;
	    forward;
	procedure readchar;
	    forward;
	function findid(s : string): integer;
	    forward;
	function isvariable(i : integer) : boolean;
	    forward;
	function conexpr(var t : integer) : integer;
	    forward;
	function basetype(t : integer) : integer;
	    forward;
	procedure promotetype(var f : integer; o, r : integer);
	    forward;
	function numbertype(t : integer): boolean;
	    forward;

procedure statement;
    forward;

procedure assignment(varindex : integer);

{
	Not surprisingly, this routine handles assignments.
}

var
    vartype	: integer;
    exprtype	: integer;
    stackvar	: integer;
begin
    stackvar := loadvar(varindex);
    if stackvar <> 0 then begin
	writeln(output, "\tmove.l\td0,-(sp)");
	vartype := stackvar;
    end else
	vartype := idents[varindex].vtype;
    if not match(becomes1) then
	error("expecting :=");
    exprtype := expression();
    if typecheck(vartype, exprtype) then begin
	promotetype(exprtype, vartype, 0);
	if stackvar <> 0 then
	    savestack(vartype)
	else
	    saveval(varindex);
    end else
	mismatch;
    ns;
end;

procedure returnval;

{
	This is similar to the above, but the value is left in d0.
}

var
    exprtype	: integer;
begin
    nextsymbol;
    if not match(becomes1) then
	error("expecting :=");
    exprtype := expression();
    if not typecheck(idents[currfn].vtype, exprtype) then
	mismatch;
    if numbertype(exprtype) then
	promotetype(exprtype, idents[currfn].vtype, 0);
    writeln(output, "\tunlk\ta5");
    writeln(output, "\trts");
    ns;
end;

procedure dowhile;

{
	Handles the while statement.
}

var
    looplabel,
    exitlabel	: integer;
begin
    looplabel := getlabel();
    exitlabel := getlabel();
    printlabel(looplabel);
    writeln(output);
    if not typecheck(expression(), booltype) then
	error("Expecting boolean expression");
    writeln(output, "\ttst.b\td0");
    write(output, "\tbeq\t");
    printlabel(exitlabel);
    writeln(output);
    if not match(do1) then
	error("Missing DO");
    statement;
    write(output, "\tbra\t");
    printlabel(looplabel);
    writeln(output);
    printlabel(exitlabel);
    writeln(output);
end;

procedure dorepeat;

{
	Handles the repeat statement.
}

var
    replabel	: integer;
begin
    replabel := getlabel();
    printlabel(replabel);
    writeln(output);
    while not match(until1) do
	statement;
    if not typecheck(expression(), booltype) then
	error("Expecting a Boolean expression.");
    writeln(output, "\ttst.b\td0");
    write(output, "\tbeq\t");
    printlabel(replabel);
    writeln(output);
end;

procedure savefor(vartype, varindex, off : integer);

{
	This routine saves the new value of the index variable for
for statements.
}

begin
    write(output, "\tmove.l\t");
    if off <> 0 then
	write(output, off);
    writeln(output, '(sp),a0');
    writeln(output, "\tmove.", suffix(idents[vartype].size), "\td0,(a0)");
end;

procedure incfor(vartype, value : integer);

{
	This routine adjusts the index for increments of 1 or -1.
}

begin
    writeln(output, "\tmove.l\t4(sp),a0");
    writeln(output, "\tadd.", suffix(idents[vartype].size), "\t#",
			value,',(a0)');
    writeln(output, "\tmove.", suffix(idents[vartype].size), "\t(a0),d0");
end;

procedure stackinc(vartype : integer);

{
	This handles non-standard increments.
}

begin
    writeln(output, "\tmove.l\t8(sp),a0");
    writeln(output, "\tmove.l\t(sp),d0");
    writeln(output, "\tadd.", suffix(idents[vartype].size), "\td0,(a0)");
    writeln(output, "\tmove.", suffix(idents[vartype].size), "\t(a0),d0");
end;

procedure dofor;

{
	handles the for statement.
}

var
    looplabel	: integer;
    varindex	: integer;
    vartype	: integer;
    boundtype	: integer;
    increment	: integer;
    bytype	: integer;
    default	: boolean;
begin
    vartype := loadaddress();
    if idents[vartype].offset <> vordinal then
	error("expecting an ordinal type");
    writeln(output, "\tmove.l\ta0,-(sp)");
    if not match(becomes1) then
	error("missing :=");
    boundtype := expression();
    if not typecheck(vartype, boundtype) then
	mismatch;
    savefor(vartype, varindex, 0);
    if match(to1) then
	increment := 1
    else if match(downto1) then
	increment := -1
    else
	error("Expecting TO or DOWNTO");
    boundtype := expression();
    if not typecheck(boundtype, vartype) then
	mismatch;
    writeln(output, "\tmove.l\td0,-(sp)");

    if match(by1) then begin
	default := false;
	bytype := expression();
	if not typecheck(bytype, vartype) then
	    mismatch;
	writeln(output, "\tmove.l\td0,-(sp)");
    end else
	default := true;

    if not match(do1) then
	error("missing DO");
    looplabel := getlabel();
    printlabel(looplabel);
    writeln(output);
    statement;
    if default then begin
	incfor(vartype, increment);
	writeln(output, "\tmove.l\t(sp),d1");
    end else begin
	stackinc(vartype);
	writeln(output, "\tmove.l\t4(sp),d1");
    end;
    writeln(output, "\tcmp.", suffix(idents[vartype].size), "\td1,d0");
    if increment > 0 then
	write(output, "\tble\t")
    else
	write(output, "\tbge\t");
    printlabel(looplabel);
    writeln(output);
    if default then
	writeln(output, "\tadd.l\t#8,sp")
    else
	writeln(output, "\tadd.l\t#12,sp");
end;

procedure doreturn;

{
	This just takes care of return.
}

begin
    if currfn <> 0 then begin
	if idents[currfn].object = proc then begin
	    writeln(output, "\tunlk\ta5");
	    writeln(output, "\trts");
	end else
	    error("return only allowed in procedures.");
    end else
	error("No return from the main procedure");
end;

procedure compound;

{
	This takes care of the begin...end syntax.
}

begin
    while not match(end1) do
	statement;
end;

procedure doif;

{
	This handles the if statement.  Eventually it should handle
elsif.
}

var
    flab1, flab2	: integer;
begin
    flab1 := getlabel();
    if not typecheck(expression(), booltype) then
	error("Expecting a Boolean type");
    writeln(output, "\ttst.b\td0");
    write(output, "\tbeq\t");
    printlabel(flab1);
    writeln(output);
    if not match(then1) then
	error("Missing THEN");
    statement;
    if match(else1) then begin
	flab2 := getlabel();
	write(output, "\tbra\t");
	printlabel(flab2);
	writeln(output);
	printlabel(flab1);
	writeln(output);
	statement;
	printlabel(flab2);
	writeln(output);
    end else begin
	printlabel(flab1);
	writeln(output);
    end;
end;

procedure docase;

{
	This block handles the case statement.  At the moment, it
only allows single constant cases.  That will change soon.
}

type
    caserecord = record
	value : integer;
	lab : integer;
    end;

{ Gasp! An arbitrary number of cases? }

    casetabletype = array [1..40] of caserecord;

var
    endtable   : integer;
    tablelabel : integer;
    cases      : integer;
    casetype   : integer;
    casetable  : casetabletype;
    index      : integer;

    procedure readcases(var cases : integer;
			var ct : casetabletype; ctype : integer);
    {
	This routine should at least read series of cases,
	separated by commas.  It would be nice if it would read
	ranges as well.
    }

    var
	eltype : integer;
    begin
	if cases < 40 then begin
	    cases := cases + 1;
	    ct[cases].value := conexpr(eltype);
	    if not typecheck(ctype, eltype) then
		mismatch;
	    ct[cases].lab := getlabel();
	end else begin
	    error("Too many cases");
	    eltype := conexpr(eltype);
	end;
    end;

begin
    tablelabel := getlabel();
    endtable   := getlabel();
    cases := 0;
    casetype := expression();
    if idents[basetype(casetype)].offset <> vordinal then
	error("Expecting an ordinal type");
    write(output, "\tlea\t");
    printlabel(tablelabel);
    writeln(output, ',a0');
    writeln(output, "\tjmp\t_p%case");
    if not match(of1) then
	error("expecting OF");
    while (currsym <> end1) and (currsym <> else1) do begin
	readcases(cases, casetable, casetype);
	if not match(colon1) then
	    error("Expecting :");
	printlabel(casetable[cases].lab);
	writeln(output);
	statement;
	write(output, "\tjmp\t");
	printlabel(endtable);
	writeln(output);
    end;
    if match(else1) then begin
	cases := cases + 1;
	casetable[cases].lab := 0;
	casetable[cases].value := getlabel();
	printlabel(casetable[cases].value);
	writeln(output);
	statement;
	write(output, "\tbra\t");
	printlabel(endtable);
	writeln(output);
    end else begin
	cases := cases + 1;
	casetable[cases].lab := 0;
	casetable[cases].value := endtable;
    end;
    if not match(end1) then
	error("Missing END");
    printlabel(tablelabel);
    if cases = 0 then begin
	write(output, "\tdc.l\t0,");
	printlabel(endtable);
	writeln(output);
    end else begin
	for index := 1 to cases do begin
	    if casetable[index].lab <> 0 then begin
		write(output, "\tdc.l\t");
		printlabel(casetable[index].lab);
		writeln(output, ',', casetable[index].value);
	    end else begin
		write(output, "\tdc.l\t0,");
		printlabel(casetable[index].value);
		writeln(output);
	    end;
	end;
    end;
    printlabel(endtable);
    writeln(output);
end;

procedure statement;

{
	This is the main routine for handling statements of all
sorts.  It distributes the work as necessary.
}

var
    varindex	: integer;
begin
    if endoffile() then
	return
    else if currsym = ident1 then begin
	varindex := findid(symtext);
	if varindex = 0 then begin
	    error("unknown ID");
	    while (currsym <> semicolon1) and
		  (currsym <> end1) and
		  (currentchar <> chr(10)) do
		nextsymbol;
	    if currsym = semicolon1 then
		nextsymbol;
	end else if (varindex = currfn) and (idents[currfn].object = func) then
	    returnval
	else if isvariable(varindex) then
	    assignment(varindex)
	else if idents[varindex].object = proc then
	    callproc(varindex)
	else if idents[varindex].object = stanproc then
	    stdproc(varindex)
	else begin
	    error("expecting a variable or procedure.");
	    while (currsym <> semicolon1) and
		  (currsym <> end1) and
		  (currentchar <> chr(10)) do
		nextsymbol;
	    if currsym = semicolon1 then
		nextsymbol;
	end;
    end else if match(begin1) then begin
	compound;
	ns;
    end else if match(if1) then begin
	doif;
    end else if match(while1) then begin
	dowhile;
    end else if match(repeat1) then begin
	dorepeat;
    end else if match(for1) then begin
	dofor;
    end else if match(case1) then begin
	docase;
    end else if match(semicolon1) then;
    else if match(return1) then begin
	doreturn;
	ns;
    end else begin
	error("expecting a statement");
	while (currsym <> semicolon1) and
	      (currsym <> end1) and
	      (currentchar <> chr(10)) do
	    nextsymbol;
	if currsym = semicolon1 then
	    nextsymbol;
    end;
end;