external;

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

	Generally speaking, this module handles the various
declarations.  The major exception to this is doblock(), in main.p,
which might be considered a declaration.
}

const
{$I "pasconst.i"}

type
{$I "pastype.i"}

var
{$I "pasvar.i"}

	procedure enterspell(s : string);
	    forward;
	function enterstandard(a, b, c, d, e, f, g : integer) : integer;
	    forward;
	function match(i : integer): boolean;
	    forward;
	procedure error(s : string);
	    forward;
	function conexpr(var i : integer): integer;
	    forward;
	function addtype(i, j, k, l, m, n : integer): integer;
	    forward;
	function declvar(r, f : integer) : integer;
	    forward;
	procedure ns;
	    forward;
	function typecmp(f, s : integer): boolean;
	    forward;
	function findid(s: string): integer;
	    forward;
	function checkid(s : string; f : integer): integer;
	    forward;
	procedure nextsymbol;
	    forward;
	procedure needrightparent;
	    forward;

procedure reformargs;

{
	This is the first in a series of routines that assigns the
proper addresses to procedure or function arguments.
}

var
    index	: integer;
    typeindex	: integer;
begin
    index := idents[currfn].indtype;
    while index <> 0 do begin
	if idents[index].object = valarg then begin
	    typeindex := idents[index].vtype;
	    argstk := argstk - idents[typeindex].size;
	    if odd(argstk) then
		argstk := argstk - 1;
	    idents[index].offset := argstk + 8;
	    if idents[typeindex].size = 1 then
		idents[index].offset := idents[index].offset + 1;
	end else if idents[index].object = refarg then begin
	    argstk := argstk - 4;
	    idents[index].offset := argstk + 8;
	end;
	index := idents[index].indtype;
    end;
end;

function reformvars(firstindex : integer) : integer;

{
	reformvars does a similar job for a block's local
variables.
}

var
    index	: integer;
    typesize	: integer;
    off		: integer;
begin
    off := 0;
    index := firstindex;
    while index < identptr do begin
	if idents[index].object = local then begin
	    typesize := idents[index].vtype;
	    typesize := idents[typesize].size;
	    if odd(abs(off)) and (typesize <> 1) then
		off := off - 1;
	    off := off - typesize;
	    idents[index].offset := off;
	end;
	index := index + 1;
    end;
    if odd(abs(off)) then
	off := off - 1;
    reformvars := off;
end;

function reformfields(startindex : integer): integer;

{
	This routine is much like the previous two.  It cleans up
the addresses of the fields of a record.
}

var
    index	: integer;
    totalsize	: integer;
    typeindex	: integer;
begin
    index := idents[startindex].indtype;
    totalsize := 0;
    while index <> 0 do begin
	typeindex := idents[index].vtype;
	typeindex := idents[typeindex].size;
	if odd(totalsize) and (typeindex > 1) then
	    totalsize := totalsize + 1;
	idents[index].offset := totalsize;
	totalsize := totalsize + typeindex;
	index := idents[index].indtype;
    end;
    if odd(totalsize) then
	totalsize := totalsize + 1;
    reformfields := totalsize;
end;

function addproc(procname : string; isfunction : boolean): integer;

{
	This just adds a procedure to the identifier array.
Hmmm... sounds like this belongs in utilities.p
}

begin
    idents[identptr].name := string(integer(adr(spelling)) + spellptr - 1);
    enterspell(procname);
    if isfunction then
	idents[identptr].object := func
    else
	idents[identptr].object := proc;
    idents[identptr].offset := 0;
    idents[identptr].vtype := 0;
    idents[identptr].upper := 0;
    idents[identptr].lower := 0;
    idents[identptr].size := 0;
    idents[identptr].indtype := 0;
    identptr := identptr + 1;
    addproc := identptr - 1;
end;

procedure getrange(var typerec : idrecord);

{
	This is rather a mistake, actually.  The routine that
declares arrays ought to just look for a range type inside the
brackets, but instead it uses this routine to look for an explicit
range.  When I add range types to the language, this will fix
itself.
}

var
    lowindex	: integer;
    highindex	: integer;
begin
    typerec.lower := conexpr(lowindex);
    if not match(dotdot1) then
	error("expecting '..' here");
    typerec.upper := conexpr(highindex);
    if not typecmp(lowindex, highindex) then begin
	error("incompatible range types");
	typerec.upper := typerec.lower;
    end;
    if typerec.lower > typerec.upper then begin
	error("lower bound greater than upper bound");
	typerec.object := typerec.lower;
	typerec.lower := typerec.upper;
	typerec.upper := typerec.object;
    end;
    typerec.indtype := lowindex;
end;

function readrecord(predname : string): integer;

{
	This just reads a record.  Note that I had to do a bit of
gymnastics in order to handle a field that's a pointer to its
parent record.
}

var
    typeindex	: integer;
    startindex	: integer;
begin
    startindex := addtype(vrecord, 0, 0, 0, 0, 0);
    if predname <> string(0) then
	idents[startindex].name := predname
    else
	idents[startindex].name := string(adr(spelling));
    prevarg := startindex;
    while currsym = ident1 do begin
	typeindex := declvar(field, startindex);
	ns;
    end;
    if not match(end1) then
	error("Missing END of record");
    idents[startindex].size := reformfields(startindex);
    idents[startindex].name := string(adr(spelling));
    readrecord := startindex;
end;

function readenumeration(): integer;

{
	This just reads enumerations and assigns them numbers
starting with zero.
}

var
    position : integer;
    enumtype : integer;
    previous : integer;
    current  : integer;
begin
    position := 0;
    enumtype := addtype(vordinal, 0, 0, 0, 2, 0);
    previous := enumtype;
    while currsym = ident1 do begin
	if findid(symtext) <> 0 then
	    error("Duplicate ID");
	current := enterstandard(constant, position, enumtype, 0, 0, 0, 0);
	enterspell(symtext);
	idents[previous].indtype := current;
	previous := current;
	position := position + 1;
	nextsymbol;
	if currsym <> rightparent1 then
	    if not match(comma1) then
		error("missing comma");
    end;
    needrightparent;
    readenumeration := enumtype;
end;

function readtype(predname : string): integer;

{
	This is a bit of a monster function, but needs yet more
stuff (like ranges).  The pointer part should have support for a
pointer to an as-yet-unknown-id.  This routine returns the index of
the type produced by the type declaration.  Note that I use the
same routine almost wherever I need a type, which is why you can
use a full type description most places.
}

var
    typeindex	: integer;
    typerec	: idrecord;
    tempint	: integer;
begin
    if currsym = ident1 then begin
	typeindex := findid(symtext);
	if (typeindex = 0) or
	   (idents[typeindex].object <> obtype) then begin
	    error("looking for a type description here.");
	    typeindex := badtype;
	end;
	nextsymbol;
    end else if match(carat1) then begin
	typeindex := readtype(string(0));
	typeindex := addtype(vpointer, typeindex, 0, 0, 4, 0);
    end else if match(leftparent1) then
	typeindex := readenumeration()
    else if match(array1) then begin
	if not match(leftbrack1) then
	    error("expecting leftbracket");
	getrange(typerec);
	if not match(rightbrack1) then
	    error("expecting a right bracket");
	if not match(of1) then
	    error("expecting OF");
	typeindex := readtype(string(0));
	typerec.size := (typerec.upper - typerec.lower + 1) *
			   idents[typeindex].size;
	typeindex := addtype(varray, typeindex, typerec.upper,
			typerec.lower, typerec.size, typerec.indtype);
    end else if match(record1) then begin
	typeindex := readrecord(predname);
    end else if match(file1) then begin
	if not match(of1) then
	    error("expecting OF");
	typeindex := readtype(string(0));
	typeindex := addtype(vfile, typeindex,
			     idents[typeindex].size, 0, 18, 0);
    end else begin
	error("unknown type of thing");
	typeindex := badtype;
    end;
    readtype := typeindex;
end;

procedure decltype(firstpos : integer);

{
	This handles a type declaration block.
}

var
    typeindex : integer;
    spellindex : string;
begin
    while currsym = ident1 do begin
	if checkid(symtext, firstpos) <> 0 then
	    error("duplicate id");
	spellindex := string(integer(adr(spelling)) + spellptr - 1);
	enterspell(symtext);
	nextsymbol;
	if not match(equal1) then
	    error("expecting '=' here");
	typeindex := readtype(spellindex);
	ns;
	if typeindex <> 0 then begin
	    if idents[typeindex].name = string(adr(spelling)) then
		idents[typeindex].name := spellindex
	    else begin
		typeindex := addtype(vsynonym, typeindex, 0, 0,
				     idents[typeindex].size, 0);
		idents[typeindex].name := spellindex;
	    end;
	end;
    end;
end;

function addvar(varname : string; varob, vartype, varoff : integer) : integer;

{
	I suppose this too belong in utilities.p
}

begin
    idents[identptr].name := string(integer(adr(spelling)) + spellptr - 1);
    enterspell(varname);
    idents[identptr].object  := varob;
    idents[identptr].offset  := varoff;
    idents[identptr].vtype   := vartype;
    idents[identptr].upper   := 0;
    idents[identptr].lower   := 0;
    idents[identptr].size    := 0;
    idents[identptr].indtype := 0;
    identptr := identptr + 1;
    addvar := identptr - 1;
end;

procedure declvar(storage, firstpos : integer);

{
	This is used to declare a parameter, local variable, global
variable, field, whatever.  It's also the reason I need the
reform things above.
}

var
    typeindex	: integer;
    varindex	: integer;
    typesize	: integer;
begin
    if currsym = ident1 then begin
	if (storage = global) or (storage = local) then begin
	    if checkid(symtext, firstpos) <> 0 then
		error("Duplicate id");
	    varindex := addvar(symtext, storage, 0, 0)
	end else if (storage = valarg) or (storage = refarg) or
		    (storage = field) then begin
	    if checkid(symtext, firstpos) <> 0 then
		error("duplicate ID");
	    varindex := addvar(symtext, storage, 0, 0);
	    idents[prevarg].indtype := varindex;
	    prevarg := varindex;
	end;
	nextsymbol;
	if match(comma1) then
	    typeindex := declvar(storage, firstpos)
	else begin
	    if not match(colon1) then
		error("expecting :");
	    typeindex := readtype(string(0));
	end;
	if typeindex <> 0 then begin
	    idents[varindex].vtype := typeindex;
	    if storage = valarg then begin
		typesize := idents[typeindex].size;
		if odd(typesize) then
		    typesize := typesize + 1;
		argstk := argstk + typesize;
	    end else if storage = refarg then
		argstk := argstk + 4;		
	end;
    end else begin
	error("expecting an identifier");
	if match(colon1) then
	    typeindex := readtype(string(0));
    end;
    declvar := typeindex;
end;

procedure vardeclarations(firstpos : integer);

{
	This handles a variable declaration block.
}

var
    typeindex	: integer;
begin
    while currsym = ident1 do begin
	if blocklevel = 0 then begin
	    typeindex := declvar(global, firstpos);
	    ns;
	end else begin
	    typeindex := declvar(local, firstpos);
	    ns;
	end
    end;
end;

function addcon(conname : string) : integer;

{
	How did all these get in here?
}

begin
    idents[identptr].name := string(integer(adr(spelling)) + spellptr - 1);
    enterspell(conname);
    idents[identptr].object  := constant;
    idents[identptr].offset  := 0;
    idents[identptr].vtype   := 0;
    idents[identptr].upper   := 0;
    idents[identptr].lower   := 0;
    idents[identptr].size    := 0;
    idents[identptr].indtype := 0;
    identptr := identptr + 1;
    addcon := identptr - 1;
end;

procedure declconst(firstpos : integer);

{
	This handles a const declaration block.  The grunt work is
does by conexpr() in expression.p, which is the routine to look at
if you want to improve constant declarations.
}

var
    conindex	: integer;
    typeindex	: integer;
begin
    while currsym = ident1 do begin
	if checkid(symtext, firstpos) <> 0 then
	    error("Duplicate ID");
	conindex := addcon(symtext);
	nextsymbol;
	if not match(equal1) then
	    error("expecting =");
	idents[conindex].offset := conexpr(typeindex);
	idents[conindex].vtype  := typeindex;
	ns;
    end;
end;