external;

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

	This module only has two parts.  The first is expression(),
which handles all run-time expressions.  The other one is
conexpr(), which handles all constant expressions.
}

const
{$I "pasconst.i"}

type
{$I "pastype.i"}

var
{$I "pasvar.i"}

	function typecheck(l, r : integer) : boolean;
	    forward;
	procedure nextsymbol;
	    forward;
	procedure gch;
	    forward;
	procedure error(s : string);
	    forward;
	procedure callfunc(f : integer);
	    forward;
	procedure stdfunc(f : integer);
	    forward;
	function match(s : integer): boolean;
	    forward;
	function findid(s : string) : integer;
	    forward;
	procedure printlabel(l : integer);
	    forward;
	function getlabel() : integer;
	    forward;
	function selector(f : integer) : integer;
	    forward;
	procedure mismatch;
	    forward;
	procedure noleftparent;
	    forward;
	procedure norightparent;
	    forward;
	procedure neednumber;
	    forward;
	procedure needrightparent;
	    forward;
	procedure needleftparent;
	    forward;
	function suffix(s : integer) : char;
	    forward;
	function numbertype(l : integer) : boolean;
	    forward;
	function basetype(b : integer): integer;
	    forward;
	procedure writehex(h : integer);
	    forward;
	procedure promotetype(var f : integer; o, r : integer);
	    forward;

function expression() : integer;
    forward;

function readlit(firstchar : char) : integer;

{
	This routine reads a literal array of char into the literal
array.  Read factor() to figure out why this is passed
firstchar....
}

var
    length : integer;
begin
    length := 1;
    litq[litptr] := firstchar;
    litptr := litptr + 1;
    while (currentchar <> chr(39)) and (currentchar <> chr(10)) do begin
	litq[litptr] := currentchar;
	gch;
	if currentchar = chr(10) then
	   error("missing closing apostrophe");
	length := length + 1;
	litptr := litptr + 1;
    end;
    gch;
    nextsymbol;
    readlit := length;
end;

function simpletype(testtype : integer) : boolean;

{
	If a variable passes this test, it is held in a register
during processing.  If not, the address of the variable is held in
the register.  This is the main reason why type conversions don't
work across all types of the same size.
}

begin
    simpletype := (idents[testtype].size <= 4) and
		  (idents[testtype].size <> 3) and
		  (idents[testtype].offset <> vrecord) and
		  (idents[testtype].offset <> varray);
end;

function idfactor(factindex : integer) : integer;

{
	idfactor() is another nightmare function.  It does whatever
is necessary when the compiler runs across an identifer in an
expression, which almost always means loading a value into d0.
}

var
    facttype	: integer;
    selecttype	: integer;
    originaltype : integer;
begin
    if factindex <> 0 then begin
	facttype := idents[factindex].vtype;
	if idents[factindex].object = func then begin
	    { call a user-defined function }
	    callfunc(factindex);
	    idfactor := facttype;
	end else if idents[factindex].object = stanfunc then begin
	    { 'call' a standard function, which is actually handled
		in-line. }
	    stdfunc(factindex);
	    idfactor := idents[factindex].vtype;
	end else if idents[factindex].object = obtype then begin
	    { this implements the type conversion thing. }
	    needleftparent;
	    selecttype := expression();
	    needrightparent;
	    idfactor := factindex;
	end else if idents[factindex].object = constant then begin
	    { load a constant or enumeration.  Expand this when
		real numbers and string constants are included. }
	    writeln(output, "\tmove.l\t#", idents[factindex].offset, ',d0');
	    idfactor := idents[factindex].vtype;
	end else begin
	    { it's probably a variable }
	    selecttype := selector(factindex);
	    if selecttype <> 0 then begin
		{ there was some sort of selection required }
		facttype := selecttype;
		originaltype := idents[factindex].vtype;
		if idents[factindex].object = global then begin
		    if (idents[originaltype].offset = vpointer) or
			(idents[originaltype].offset = vfile) then
			writeln(output, "\tmove.l\td0,a0")
		    else begin
			writeln(output, "\tmove.l\t#_",
					idents[factindex].name, ',a0');
			writeln(output, "\tadd.l\td0,a0");
		    end
		end else if idents[factindex].object = refarg then begin
		    if (idents[originaltype].offset = vpointer) or
			(idents[originaltype].offset = vfile) then
			writeln(output, "\tmove.l\td0,a0")
		    else begin
			writeln(output, "\tmove.l\t", idents[factindex].offset,
					'(a5),a0');
			writeln(output, "\tadd.l\td0,a0");
		    end
		end else begin
		    if (idents[originaltype].offset = vpointer) or
			(idents[originaltype].offset = vfile) then
			writeln(output, "\tmove.l\td0,a0")
		    else begin
			writeln(output, "\tlea\t", idents[factindex].offset,
					'(a5),a0');
			writeln(output, "\tadd.l\td0,a0");
		    end
		end;
		if simpletype(facttype) then
		    writeln(output, "\tmove.", suffix(idents[facttype].size),
			"\t(a0),d0");
		else
		    writeln(output, "\tmove.l\ta0,d0");
	    end else begin
		{ this is a simple variable }
		if idents[factindex].object = global then begin
		    if not simpletype(facttype) then begin
			writeln(output, "\tmove.l\t#_",
					idents[factindex].name, ',d0');
		    end else begin
			writeln(output,"\tmove.",suffix(idents[facttype].size),
				"\t_", idents[factindex].name, ',d0');
		    end
		end else if (idents[factindex].object = local) or
		    (idents[factindex].object = valarg) then begin
		    if not simpletype(facttype) then begin
			writeln(output, "\tlea\t", idents[factindex].offset, 
					'(a5),a0');
			writeln(output, "\tmove.l\ta0,d0");
		    end else begin
			writeln(output,"\tmove.",suffix(idents[facttype].size),
				chr(9), idents[factindex].offset, '(a5),d0');
		    end;
		end else if idents[factindex].object = refarg then begin
		    if not simpletype(facttype) then begin
			writeln(output, "\tmove.l\t", idents[factindex].offset,
					'(a5),d0');
		    end else begin
			writeln(output, "\tmove.l\t", idents[factindex].offset,
					'(a5),a0');
			writeln(output, "\tmove.",suffix(idents[facttype].size),
				"\t(a0),d0");
		    end;
		end else begin
		    error("expecting a variable or function");
		    facttype := badtype;
		end;
	    end;
	    idfactor := facttype;
	end;
	error("expecting an expression");
	idfactor := badtype;
    end else begin
	error("Unknown identifier");
	idfactor := badtype;
    end;
end;

function factor() : integer;

{
	This is the lowest level of the expression parsing
business.  It's pretty standard stuff.  All these expression
routines return the index of the type they're working on.
}

var
    facttype	: integer;
    factindex	: integer;
    length	: integer;
    firstchar	: char;
begin
    if currsym = ident1 then begin
	factindex := findid(symtext);
	nextsymbol;
	facttype := idfactor(factindex);
    end else if currsym = numeral1 then begin
	if abs(symloc) > 32767 then begin
	    facttype := inttype;
	    write(output, "\tmove.l\t#");
	    writehex(symloc);
	    writeln(output, ',d0');
	end else begin
	    { assumes short integers for literals...}
	    writeln(output, "\tmove.w\t#", symloc, ',d0');
	    facttype := shorttype;
	end;
	nextsymbol;
{   end else if currsym = realnumeral1 then begin
	write(output, "\tmove.l\t#");
	writehex(integer(realnum));
	writeln(output, ",d0");
	facttype := realtype;
	nextsymbol; }
    end else if currsym = apostrophe1 then begin
	firstchar := currentchar;
	gch;
	if currentchar <> chr(39) then begin
	    write(output, "\tmove.l\t#");
	    printlabel(litlab);
	    writeln(output, '+', litptr - 1, ',d0');
	    length := readlit(firstchar);
	    idents[literaltype].upper := length;
	    idents[literaltype].size := length;
	    facttype := literaltype;
	end else begin
	    gch;
	    nextsymbol;
	    writeln(output, "\tmove.b\t#", ord(firstchar), ',d0');
	    facttype := chartype;
	end;
    end else if match(not1) then begin
	facttype := factor();
	if not typecheck(facttype, booltype) then begin
	    error("NOT applies only to Booleans");
	    facttype := badtype;
	end else
	    writeln(output, "\tnot.b\td0");
    end else if match(leftparent1) then begin
	facttype := expression();
	needrightparent;
    end else if currsym = quote1 then begin
	{ Read a string.  This should go to a separate procedure }
	write(output, "\tmove.l\t#");
	printlabel(litlab);
	writeln(output, '+', litptr - 1, ',d0');
	while (currentchar <> '"') and (currentchar <> chr(10)) do begin
	    if currentchar = '\' then begin
		gch;
		if currentchar = 't' then
		    litq[litptr] := chr(9)
		else if currentchar = 'n' then
		    litq[litptr] := chr(10)
		else
		    litq[litptr] := currentchar;
	    end else
		litq[litptr] := currentchar;
	    gch;
	    if currentchar = chr(10) then
		error("missing close quote");
	    litptr := litptr + 1;
	end;
	gch;
	nextsymbol;
	litq[litptr] := chr(0);
	litptr := litptr + 1;
	facttype := stringtype;
    end else begin
	error("bizarre expression");
	facttype := badtype;
    end;
    factor := facttype;
end;
	
function operate(lefttype, righttype, operator : integer) : integer;

{
	This routine handles the actual code generation for the
various operations.  This handles all the math stuff, even though
it's called by different routines.  In the next version this bit
will properly handle the multiplication and division of 32 bit
values.
}

begin
    if not typecheck(lefttype, righttype) then begin
	mismatch;
	lefttype := badtype;
    end else begin
	writeln(output, "\tmove.l\t(sp)+,d1");
	if (operator = and1) or (operator = or1) then begin
	    if not typecheck(lefttype, booltype) then
		error("Need Boolean expression for AND and OR");
	end else begin
	    if numbertype(lefttype) then begin
		promotetype(lefttype, righttype, 1);
		promotetype(righttype, lefttype, 0);
	    end else
		neednumber;
	end;

	{ The following arithmetic operations will undergo a major
	  change when two more things are added.  They are, not
	  surprisingly, real math and full 32 bit multiplication
	  and division.  Each of the following cases will have to
	  be fleshed out a bit to decide what kind of math routines
	  to use for a particular operation. }

	if operator = asterisk1 then begin
	    if lefttype = bytetype then begin
		promotetype(lefttype, shorttype, 1);
		promotetype(righttype, shorttype, 0);
	    end;
	    writeln(output, "\tmuls\td1,d0");
	    lefttype := inttype;
	end else if operator = div1 then begin
	    if lefttype <> inttype then begin
		promotetype(lefttype, inttype, 1);
		promotetype(righttype, shorttype, 0);
	    end;
	    writeln(output, "\tdivs\td0,d1");
	    writeln(output, "\tmove.l\td1,d0");
	    lefttype := shorttype;
	end else if operator = mod1 then begin
	    if lefttype <> inttype then begin
		promotetype(lefttype, inttype, 1);
		promotetype(righttype, shorttype, 0);
	    end;
	    writeln(output, "\tdivs\td0,d1");
	    writeln(output, "\tmove.l\td1,d0");
	    writeln(output, "\tswap\td0");
	    lefttype := shorttype;
	end else if operator = and1 then begin
	    writeln(output, "\tand.b\td1,d0")
	end else if operator = plus1 then begin
	    writeln(output, "\tadd.", suffix(idents[lefttype].size),
				"\td1,d0");
	end else if operator = minus1 then begin
		writeln(output, "\tsub.", suffix(idents[lefttype].size),
			"\td1,d0");
		writeln(output, "\tneg.", suffix(idents[lefttype].size),
			"\td0");
	end else if operator = or1 then
	    writeln(output, "\tor.b\td1,d0")
    end;
    operate := lefttype;
end;

function term() : integer;

{
	Again, pretty standard stuff.  This handles the level of
precedence that includes *, div, mod, and and.
}

var
    lefttype	: integer;
    righttype	: integer;
    stay	: boolean;
begin
    lefttype := factor();
    stay := true;
    while stay do begin
	if match(asterisk1) then begin
	    writeln(output, "\tmove.l\td0,-(sp)");
	    righttype := factor();
	    lefttype := operate(lefttype, righttype, asterisk1);
	end else if match(div1) then begin
	    writeln(output, "\tmove.l\td0,-(sp)");
	    righttype := factor();
	    lefttype := operate(lefttype, righttype, div1);
	end else if match(mod1) then begin
	    writeln(output, "\tmove.l\td0,-(sp)");
	    righttype := factor();
	    lefttype := operate(lefttype, righttype, mod1);
	end else if match(and1) then begin
	    writeln(output, "\tmove.l\td0,-(sp)");
	    righttype := factor();
	    lefttype := operate(lefttype, righttype, and1);
	end else
	    stay := false;
    end;
    term := lefttype;
end;

function simple() : integer;

{
	This is similar to term(), except it handles plus, minus,
or, and unary minus.
}

var
    lefttype	: integer;
    righttype	: integer;
    stay	: boolean;
begin
    if match(minus1) then begin
	lefttype := term();
	if not typecheck(lefttype, inttype) then begin
	    error("need numeric type for unary minus");
	    lefttype := badtype;
	end else
	    writeln(output, "\tneg.", suffix(idents[lefttype].size),"\td0");
    end else
	lefttype := term();

    stay := true;
    while stay do begin
	if match(plus1) then begin
	    writeln(output, "\tmove.l\td0,-(sp)");
	    righttype := term();
	    lefttype := operate(lefttype, righttype, plus1);
	end else if match(minus1) then begin
	    writeln(output, "\tmove.l\td0,-(sp)");
	    righttype := term();
	    lefttype := operate(lefttype, righttype, minus1);
	end else if match(or1) then begin
	    writeln(output, "\tmove.l\td0,-(sp)");
	    righttype := term();
	    lefttype := operate(lefttype, righttype, or1);
	end else
	    stay := false;
    end;
    simple := lefttype;
end;

function exprrelop(lefttype, operation : integer) : integer;

{
	This handles the code for the various relative comparisons
(like <, >, <=, etc.)
}

var
    righttype	: integer;
begin
    writeln(output, "\tmove.l\td0,-(sp)");
    righttype := simple();
    if not typecheck(lefttype, righttype) then begin
	mismatch;
	lefttype := badtype;
    end else if idents[lefttype].offset <> vordinal then begin
	error("only simple types allowed in inequalities");
	lefttype := badtype;
    end else begin
	writeln(output, "\tmove.l\t(sp)+,d1");
	if numbertype(lefttype) then begin
	    promotetype(lefttype, righttype, 1);
	    promotetype(righttype, lefttype, 0);
	end;
	writeln(output, "\tcmp.", suffix(idents[lefttype].size), "\td0,d1");
	if operation = less1 then
	    writeln(output, "\tslt\td0")
	else if operation = greater1 then
	    writeln(output, "\tsgt\td0")
	else if operation = notless1 then
	    writeln(output, "\tsge\td0")
	else if operation = notgreater1 then
	    writeln(output, "\tsle\td0");
	lefttype := booltype;
    end;
    exprrelop := lefttype;
end;

function expreqop(lefttype, operation : integer) : integer;

{
	This generated code for comparisons of equality.  The main
difference between this and the previous routine is that Pascal
allows the comparison of complex types, so this routine has to
handle that.
}

var
    righttype	: integer;
    lab		: integer;
    totalsize	: integer;
begin
    writeln(output, "\tmove.l\td0,-(sp)");
    righttype := simple();
    if not typecheck(lefttype, righttype) then begin
	mismatch;
	lefttype := badtype;
	writeln(output, "\tmove.l\t(sp)+,d0");
    end else begin
	totalsize := idents[lefttype].size;
	if not simpletype(lefttype) then begin

	  { If we got here, this must be a complex type.  Therefore
	    compare the two objects byte by byte. }

	    writeln(output, "\tmove.l\td0,a0");
	    writeln(output, "\tmove.l\t(sp)+,a1");
	    writeln(output, "\tmove.b\t#-1,d0");
	    writeln(output, "\tmove.l\t#", totalsize, ",d1");
	    lab := getlabel();
	    printlabel(lab);
	    writeln(output, "\tmove.b\t(a0)+,d2");
	    writeln(output, "\tcmp.b\t(a1)+,d2");
	    writeln(output, "\tseq\td2");
	    writeln(output, "\tand.b\td2,d0");
	    write(output, "\tdbra\td1,");
	    printlabel(lab);
	    writeln(output);
	    writeln(output, "\ttst.b\td0");
	    if operation = notequal1 then
		writeln(output, "\tseq\td0");
	end else begin
	    writeln(output, "\tmove.l\t(sp)+,d1");
	    if numbertype(lefttype) then begin
		promotetype(lefttype, righttype, 1);
		promotetype(righttype, lefttype, 0);
	    end;
	    writeln(output, "\tcmp.", suffix(idents[lefttype].size), "\td0,d1");
	    if operation = equal1 then
		writeln(output, "\tseq\td0")
	    else if operation = notequal1 then
		writeln(output, "\tsne\td0");
	end;
	lefttype := booltype;
    end;
    expreqop := lefttype;
end;

function expression() : integer;

{
	This is the main part of expression().  If there weren't
any errors, the result of the expression will be in d0.
}

var
    lefttype : integer;
begin
    lefttype := simple();
    if match(equal1) then
	lefttype := expreqop(lefttype, equal1)
    else if match(notequal1) then
	lefttype := expreqop(lefttype, notequal1)
    else if match(less1) then
	lefttype := exprrelop(lefttype, less1)
    else if match(greater1) then
	lefttype := exprrelop(lefttype, greater1)
    else if match(notless1) then
	lefttype := exprrelop(lefttype, notless1)
    else if match(notgreater1) then
	lefttype := exprrelop(lefttype, notgreater1);
    expression := lefttype;
end;

function conexpr(var c : integer) : integer;
    forward;

function conprimary(var contype : integer) : integer;

{
	These routines are very similar to the other expression
routines, but are much simpler.  They return the running value of
the expression.  The type is returned in the reference parameter.
This routine should handle type conversions and standard functions.
}

var
    result	: integer;
    idindex	: integer;
begin
    if match(leftparent1) then begin
	result := conexpr(contype);
	needrightparent;
	conprimary := result;
    end else if currsym = numeral1 then begin
	result := symloc;
	nextsymbol;
	contype := inttype;
	conprimary := result;
    end else if match(minus1) then begin
	conprimary := -conprimary(contype);
    end else if currsym = apostrophe1 then begin
	contype := chartype;
	result := ord(currentchar);
	gch;
	if currentchar <> chr(39) then begin
	    error("Only single character constants allowed.");
	    while (currentchar <> ';') and (currentchar <> chr(39)) and
		  (currentchar <> chr(10)) and (currentchar <> chr(0)) do
		gch();
	end;
	gch;
	nextsymbol;
	conprimary := result;
    end else if currsym = ident1 then begin
	idindex := findid(symtext);
	if idents[idindex].object = constant then begin
	    nextsymbol;
	    contype := idents[idindex].vtype;
	    conprimary := idents[idindex].offset;
	end else begin
	    error("expecting a constant");
	    contype := inttype;
	    conprimary := 1;
	end;
    end else begin
	error("unknown constant");
	contype := inttype;
	conprimary := 1;
    end;
end;

function confactor(var contype : integer) : integer;

{
	This handles the second level of precedence for constant
expressions.
}

var
    result, rightresult	: integer;
    righttype	: integer;
begin
    result := conprimary(contype);
    while (currsym = asterisk1) or (currsym = div1) do begin
	if match(asterisk1) then begin
	    rightresult := conprimary(righttype);
	    if typecheck(contype, righttype) then
		result := result * rightresult
	    else
		mismatch;
	end else if match(div1) then begin
	    rightresult := conprimary(righttype);
	    if typecheck(contype, righttype) then begin
		if rightresult = 0 then begin
		    error("Division by zero");
		    rightresult := 1;
		end;
		result := result div rightresult;
	    end else
		mismatch;
	end;
    end;
    confactor := result;
end;

function conexpr(var contype : integer) : integer;

{
	This handles the other level of constant expressions, and
is also the outermost level.
}

var
    result	: integer;
    rightresult	: integer;
    righttype	: integer;
begin
    result := confactor(contype);
    while (currsym = minus1) or (currsym = plus1) do begin
	if match(minus1) then begin
	    rightresult := confactor(righttype);
	    if typecheck(contype, righttype) then
		result := result - rightresult
	    else
		mismatch;
	end else if match(plus1) then begin
	    rightresult := confactor(righttype);
	    if typecheck(contype, righttype) then
		result := result + rightresult
	    else
		mismatch;
	end;
    end;
    conexpr := result;
end;