Club Amiga de Montreal - CAM/CAM_CD_1.iso/files/254a.lha/PCQ/Source/Calls.p

Text File | 1989-05-10 | 13.5 KB | 495 lines

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;