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

Text File | 1989-05-10 | 19.7 KB | 727 lines

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;