Frozen Fish 1: Amiga/FrozenFish-Apr94.iso/bbs/alib/d1xx/d183/pcq.lha/PCQ/Source/Declarations.p

Text File | 1989-02-26 | 12KB | 477 lines

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;