external;

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

	Calls.p is the first attempt to organize the various
addressing and code generating routines in one section.  If you
read the other sections you'll find that not much effort went into
this project.  Nonetheless, a couple of common addressing things
can be found here.
	If the compiler were designed so that all the addressing
things were here, it would be much easier to port to a different
computer.
}

const
{$I "pasconst.i"}

type
{$I "pastype.i"}

var
{$I "pasvar.i"}

	function match(s : integer) : boolean;
	    forward;
	procedure error(s : string);
	    forward;
	function findfield(s : string; p : integer): integer;
	    forward;
	procedure nextsymbol;
	    forward;
	function expression() : integer;
	    forward;
	function typecheck(t1, t2 : integer): boolean;
	    forward;
	function typecmp(t1, t2 : integer) : boolean;
	    forward;
	function findid(s : string) : integer;
	    forward;
	function isvariable(i : integer) : boolean;
	    forward;
	function getlabel() : integer;
	    forward;
	procedure printlabel(l : integer);
	    forward;
	procedure ns;
	    forward;
	function suffix(s : integer): char;
	    forward;
	procedure mismatch;
	    forward;
	function basetype(t : integer): integer;
	    forward;
	function simpletype(t : integer): boolean;
	    forward;
	function numbertype(t : integer): Boolean;
	    forward;
	procedure promotetype(var f : integer; o, r : integer);
	    forward;

procedure dorangecheck(vartype : integer);

{
	This routine is called from selector() when range checking
is turned on.  Notice that the code is all inline, rather than
calling some library function.  I see this as a debugging option,
so I didn't try very hard to optimize it.
}

var
    safelabel : integer;
    badlabel  : integer;
begin
    if idents[vartype].offset = varray then begin
	safelabel := getlabel();
	badlabel := getlabel();
	writeln(output, "\tcmp.l\t#", idents[vartype].lower, ',d0');
	write(output, "\tblt.s\t");
	printlabel(badlabel);
	writeln(output, "\n\tcmp.l\t#", idents[vartype].upper, ',d0');
	write(output, "\tbgt.s\t");
	printlabel(badlabel);
	write(output, "\n\tbra.s\t");
	printlabel(safelabel);
	writeln(output);
	printlabel(badlabel);
	writeln(output, "\tmove.l\t#52,d0");
	writeln(output, "\tjsr\t_p%exit");
	printlabel(safelabel);
	writeln(output);
    end;
end;

procedure getpointerval(varindex : integer);

{
	This routine puts the value of a pointer variable (or a
reference parameter) into d0.
}

begin
    if idents[varindex].object = global then
	writeln(output, "\tmove.l\t_", idents[varindex].name, ',d0');
    else if idents[varindex].object = refarg then begin
	writeln(output, "\tmove.l\t", idents[varindex].offset, '(a5),a0');
	writeln(output, "\tmove.l\t(a0),d0");
    end else
	writeln(output, "\tmove.l\t", idents[varindex].offset, '(a5),d0');
end;

procedure simpleaddress(varindex : integer);

{
	simpleaddress() is passed a idrecord of some sort of
variable, and just loads its address into a0.
}

begin
    if idents[varindex].object = global then
	writeln(output, "\tmove.l\t#_", idents[varindex].name, ',a0');
    else if (idents[varindex].object = local)
	    or (idents[varindex].object = valarg) then
	writeln(output, "\tlea\t", idents[varindex].offset, '(a5),a0');
    else if idents[varindex].object = refarg then
	writeln(output, "\tmove.l\t", idents[varindex].offset, '(a5),a0');
end;

function selector(varindex : integer) : integer;

{
	This is an overlarge function that handles all the
selectors- in other words ^, ., and [].  It can handle a series of
them, of course.  selector() returns 0 if no selection was
required, and the type if there was some selection.  This routine
will be split up, and I'm planning to add addressing for strings
like that in C.
}

var
    vartype	: integer;
    typeindex	: integer;
    indextype	: integer;
    stacked	: boolean;
    bufsize	: integer;
begin
    stacked := false;
    vartype := idents[varindex].vtype;
    while (currsym = period1) or (currsym = leftbrack1) or
	  (currsym = carat1) do begin
	if match(period1) then begin
	    if idents[vartype].offset <> vrecord then
		error("not a record type");
	    typeindex := findfield(symtext, vartype);
	    if typeindex = 0 then
		error("unknown field");
	    nextsymbol;
	    if idents[typeindex].offset <> 0 then begin
		if stacked then
		    write(output, "\tadd.l\t#")
		else
		    write(output, "\tmove.l\t#");
		writeln(output, idents[typeindex].offset, ',d0');
	    end else if not stacked then
		writeln(output, "\tmoveq\t#0,d0");
	    stacked := true;
	    vartype := idents[typeindex].vtype;
	end else if match(carat1) then begin
	    if idents[vartype].offset = vfile then begin
		if stacked then
		    writeln(output, "\tmove.l\td0,a0")
		else begin
		    simpleaddress(varindex);
		    stacked := true;
		end;
		bufsize := idents[vartype].vtype;
		bufsize := idents[bufsize].size;
		if (bufsize <= 4) and (bufsize <> 3) then begin
		    writeln(output, "\tlea\t4(a0),a0");
		    writeln(output, "\tmove.l\ta0,d0");
		end else
		    writeln(output, "\tmove.l\t4(a0),d0");
		vartype := idents[vartype].vtype;
	    end else if idents[vartype].offset = vpointer then begin
		if stacked then begin
		    writeln(output, "\tmove.l\td0,a0");
		    writeln(output, "\tmove.l\t(a0),d0");
		end else
		    getpointerval(varindex);
		stacked := true;
		vartype := idents[vartype].vtype;
	    end else
		error("Need a file or pointer for ^");
	end else if match(leftbrack1) then begin
	    if idents[vartype].offset <> varray then
		error("not an array");
	    if stacked then
		writeln(output, "\tmove.l\td0,-(sp)");
	    indextype := expression();
	    promotetype(indextype, inttype, 0);
	    if rangecheck then
		dorangecheck(vartype);
	    if not typecheck(indextype, idents[vartype].indtype) then
		mismatch;
	    if not match(rightbrack1) then
		error("expecting ]");
	    if idents[vartype].lower <> 0 then
		writeln(output, "\tsub.l\t#", idents[vartype].lower, ',d0');
	    vartype := idents[vartype].vtype;
	    if idents[vartype].size <> 1 then
		writeln(output, "\tmuls\t#", idents[vartype].size, ',d0');
	    if stacked then begin
		writeln(output, "\tmove.l\t(sp)+,d1");
		writeln(output, "\tadd.l\td1,d0");
	    end	else
		stacked := true;
	end;
    end;
    if stacked then
	selector := vartype
    else
	selector := 0;
end;

function loadvar(varindex : integer) : integer;

{
	This routine is used in assignments.  If the variable
reference requires selection, loadvar() loads the address into d0
and returns the appropriate type.  If not, it does not load the
address, and returns zero.
}

var
    vartype		: integer;
    originaltype	: integer;
begin
    nextsymbol;
    vartype := selector(varindex);
    originaltype := idents[varindex].vtype;
    if vartype = 0 then
	loadvar := 0
    else begin
	if (idents[originaltype].offset <> vpointer) and
	   (idents[originaltype].offset <> vfile) then begin
	    simpleaddress(varindex);
	    writeln(output, "\tadd.l\ta0,d0");
	end;
	loadvar := vartype;
    end;
end;

function loadaddress() : integer;

{
	This is the routine used wherever I need the address of a
variable, for example reference parameters or the adr() function.
The address is loaded into a0.
}

var
    argindex	: integer;
    argtype	: integer;
    bt		: integer;
begin
    if currsym = ident1 then begin
	argindex := findid(symtext);
	nextsymbol;
	if argindex = 0 then begin
	    error("Unknown ID");
	    argindex := badtype;
	end else begin
	    if isvariable(argindex) then begin
		argtype := selector(argindex);
		bt := basetype(idents[argindex].vtype);
		if argtype = 0 then begin
		    simpleaddress(argindex);
		    argtype := idents[argindex].vtype
		end else begin
		    if (idents[bt].offset = vpointer) or
			(idents[bt].offset = vfile) then
			writeln(output, "\tmove.l\td0,a0");
		    else begin
			simpleaddress(argindex);
			writeln(output, "\tadda.l\td0,a0");
		    end;
		end;
		loadaddress := argtype;
	    end else
		if argindex <> badtype then
		    error("expecting a variable (reference parameter)");
	end
    end else
	error("expecting a variable identifier");
    loadaddress := badtype;
end;

procedure getparams(procindex : integer);

{
	This routine handles the parameters of a call (not the
declaration, which is handled in doblock()).  It sorts out the
various reference and value parameters and gets the stack properly
set up.
}

var
    currentparam	: integer;
    stay		: boolean;
    argtype		: integer;
    argindex		: integer;
    totalsize		: integer;
    lab			: integer;
begin
    stay := true;
    if match(leftparent1) then begin
	currentparam := idents[procindex].indtype;
	while (not match(rightparent1)) and stay do begin
	    if currentparam = 0 then begin
		error("argument not expected");
		nextsymbol;
		stay := false;
	    end else begin
		if idents[currentparam].object = valarg then begin
		    argtype := expression();
		    if not typecheck(argtype, idents[currentparam].vtype)
				then begin
			mismatch;
			argtype := badtype;
		    end else begin
			if numbertype(argtype) then
			    promotetype(argtype, idents[currentparam].vtype, 0);
			argtype := idents[currentparam].vtype;
			if simpletype(argtype) then begin
			    if idents[argtype].size <= 2 then
				writeln(output, "\tmove.w\td0,-(sp)")
			    else if idents[argtype].size = 4 then
				writeln(output, "\tmove.l\td0,-(sp)");
			end else begin
			    writeln(output, "\tmove.l\td0,a0");
			    writeln(output, "\tmove.l\tsp,a1");
			    writeln(output, "\tsub.l\t#",
				idents[argtype].size, ',a1');
			    writeln(output, "\tmove.l\t#",
				idents[argtype].size - 1, ',d1');

			    lab := getlabel();
			    printlabel(lab);
			    writeln(output, "\tmove.b\t(a0)+,d0");
			    writeln(output, "\tmove.b\td0,(a1)+");
			    write(output, "\tdbra\td1,");
			    printlabel(lab);
			    writeln(output);
			    write(output, "\tsub.l\t#");
			    if odd(idents[argtype].size) then
				write(output, idents[argtype].size + 1)
			    else
				write(output, idents[argtype].size);
			    writeln(output, ',sp');
			end;
		    end;
		end else if idents[currentparam].object = refarg then begin
		    if currsym = ident1 then begin
			argtype := loadaddress();
			writeln(output, "\tmove.l\ta0,-(sp)");
			if not typecmp(argtype, idents[currentparam].vtype)
				    then
			    mismatch;
		    end else
			error("Expecting a variable name (reference param)");
		end;
		currentparam := idents[currentparam].indtype;
		if currentparam <> 0 then
		    if not match(comma1) then
			error("expected ,");
	    end;
	end;
	if currentparam <> 0 then
	    error("more parameters needed");
    end else begin
	if idents[procindex].indtype <> 0 then
	    error("expecting some parameters")
	else if idents[procindex].object = func then
	    error("expecting parentheses for a function");
    end
end;

procedure callproc(varindex : integer);

{
	This routine makes an actual call to a procedure.  In the
next version this routine will have to push an extra address, which
will point to the routine's parent's frame pointer.  Never mind
about that except that it is required in order to properly
implement nested blocks.
}

begin
    nextsymbol;
    getparams(varindex);
    ns;
    writeln(output, "\tjsr\t_", idents[varindex].name);
    if idents[varindex].size <> 0 then
	writeln(output, "\tadd.l\t#", idents[varindex].size, ',sp');
end;

procedure callfunc(varindex : integer);

{
	This calls a function.  It's mostly the same as callproc,
but it's called from deep within expression() rather than
statement().  This will also have to push a back pointer.
}

begin
    getparams(varindex);
    writeln(output, "\tjsr\t_", idents[varindex].name);
    if idents[varindex].size <> 0 then
	writeln(output, "\tadd.l\t#", idents[varindex].size, ',sp');
end;

procedure savethrougha0(totalsize : integer);

{
	This saves a complex data object pointed to by d0 to the
memory at a0.
}

var
    lab		: integer;
begin
    writeln(output, "\tmove.l\td0,a1");
    writeln(output, "\tmove.l\t#", totalsize - 1, ',d1');
    lab := getlabel();
    printlabel(lab);
    writeln(output, "\tmove.b\t(a1)+,d0");
    writeln(output, "\tmove.b\td0,(a0)+");
    write(output, "\tdbra\td1,");
    printlabel(lab);
    writeln(output);
end;

procedure savestack(typeindex : integer);

{
	This saves a variable into the memory pointed to by the
longword on the top of the stack.  Odd as it may sound, this occurs
fairly often.
}

begin
    writeln(output, "\tmove.l\t(sp)+,a0");
    if simpletype(typeindex) then
	writeln(output, "\tmove.", suffix(idents[typeindex].size), "\td0,(a0)");
    else
	savethrougha0(idents[typeindex].size);
end;

procedure saveval(varindex : integer);

{
	This saves whatever's in d0 into the variable pointed to by
varindex.
}

var
    totalsize	: integer;
begin
    totalsize := idents[varindex].vtype;
    totalsize := idents[totalsize].size;
    if idents[varindex].object = global then begin
	if not simpletype(idents[varindex].vtype) then begin
	    writeln(output, "\tmove.l\t#_", idents[varindex].name, ',a0');
	    savethrougha0(totalsize);
	end else
	    writeln(output, "\tmove.", suffix(totalsize), "\td0,_",
			idents[varindex].name);
    end else if (idents[varindex].object = local) or
		(idents[varindex].object = valarg) then begin
	if not simpletype(idents[varindex].vtype) then begin
	    writeln(output, "\tlea\t", idents[varindex].offset, '(a5),a0');
	    savethrougha0(totalsize);
	end else
	    writeln(output, "\tmove.", suffix(totalsize), "\td0,",
			idents[varindex].offset, '(a5)');
    end else begin
	writeln(output, "\tmove.l\t", idents[varindex].offset, '(a5),a0');
	if not simpletype(idents[varindex].vtype) then
	    savethrougha0(totalsize)
	else
	    writeln(output, "\tmove.", suffix(totalsize), "\td0,(a0)");
    end;
end;