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

Text File | 1989-02-26 | 17KB | 799 lines

external;

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

    This module handles the IO of the compiler.  The actual
compilation of the io statements is handled in stanprocs.p
}

const
{$I "pasconst.i"}

type
{$I "pastype.i"}

var
{$I "pasvar.i"}

    procedure doinclude;
        forward;
    function AllocString(i : integer): string;
        forward;
    procedure FreeString(s : string);
        forward;
    function searchreserved(): integer;
        forward;
    function raise(c : Char): Char;
        forward;

procedure readchar;
    forward;
procedure endinclude;
    forward;


{    This routine lists the contents of the identifier table for
debugging purposes.

procedure dumptypes;
var
    index : integer;
begin
    for index := 1 to identptr - 1 do begin
    write(index, chr(9));
    if idents[index].name = string(adr(spelling)) then
        writeln('no name')
    else
        writeln(idents[index].name);
    writeln('object  ', idents[index].object);
    writeln('offset  ', idents[index].offset);
    writeln('vtype   ', idents[index].vtype);
    writeln('upper   ', idents[index].upper);
    writeln('lower   ', idents[index].lower);
    writeln('size    ', idents[index].size);
    writeln('indtype ', idents[index].indtype);
    writeln;
    end;
end;
}

procedure abort;

{
    This routine cuts out cleanly.  If you are debugging the
compiler, this is a likely place to put post mortem dumps, like the
one commented out.
}

begin
    if including then begin
    close(input2);
    close(input);
    end else
    close(input);
    writeln('Compilation aborted');
 {   writeln('IdentPtr = ', identptr, '.  SpellPtr = ', spellptr,
        '.  LitPtr = ', litptr);
    dumptypes; }
    exit(20);
end;

function eqfix(x : integer): integer;

{
    This helps implement a queue.  In this case it's for the
error queue.
}

begin
    if x = -1 then
    eqfix := eqsize
    else
    eqfix := x mod (eqsize + 1);
end;

procedure error(ptr : string);

{
    This just writes out at most the previous 128 characters or
two lines, then writes the error message passed to it.  If there
are more than five errors, it aborts.
}

var
    index : integer;
    newlines : integer;
begin
    index := eqend;
    newlines := 0;
    while (index <> eqstart) and (newlines < 2) do begin
    index := eqfix(index - 1);
    if errorq[eqfix(index - 1)] = chr(10) then
        newlines := newlines + 1;
    end;

    while index <> eqend do begin
    if index = errorptr then
        write(chr($9b), '0;33;40m');  { start highlight for ANSI }
    write(errorq[index]);
    index := eqfix(index + 1);
    end;
    write(chr($9b), '0;31;40m');  { end highlight }
    writeln;

    if including then
    write('"', includename, '", ')
    else
    write('"', mainname, '", ');

    write('Line ', lineno, ' ');
    if currfn <> 0 then
    write('(', idents[currfn].name, ')');
    writeln(': ', ptr);
    writeln;

{    writeln('Identptr = ', identptr, '.  SpellPtr = ', spellptr); }

    errorcount := errorcount + 1;
    if errorcount > 5 then
    abort;
end;

function endoffile(): boolean;

{
    This is the modified eof() function.  This is necessary
because of include files.
}

begin
    if including then
    if eof(input2) then begin
        endinclude;
        endoffile := eof(input);
    end else
        endoffile := false;
    else
    endoffile := eof(input);
end;

procedure endcomment;

{
    This just eats characters up to the end of a comment.  If
you want nested comments, this is probably the place to do it.
}

begin
    while currentchar <> '}' do begin
    if endoffile() then begin
        error("The file ended in a comment!");
        return;
    end;
    readchar;
    end;
    readchar;
end;

procedure endinclude;

{
    This switches the input back to the main file.
}

begin
    close(input2);
    including := false;
    lineno  := saveline;
    fnstart := savestart;
    currentchar := savechar;
    endcomment;
end;

procedure readchar;

{
    This just reads a character from wherever it's appropriate.
In the next version, the options might include an ARexx port.
}

begin
    if including then begin
    if eof(input2) then begin
        endinclude;
    end else
        read(input2, currentchar)
    end else
    read(input, currentchar);

      { At this point the character is read.  The following code just
    inserts the character into a queue, which will be printed if
    we hit an error. }

    if currentchar = chr(10) then
    lineno := lineno + 1;
    eqend := eqfix(eqend + 1);
    errorq[eqend] := currentchar;
    if eqstart = eqend then
    eqstart := eqfix(eqend + 1);
end;

procedure gch;

{
    This reads a character from the same line, for situations
where a symbol cannot be spread over two lines.
}

begin
    if currentchar <> chr(10) then
    readchar;
end;

function getlabel() : integer;

{
    As in all compilers, this just returns a unique serial
number.
}

begin
    nxtlab := nxtlab + 1;
    getlabel := nxtlab;
end;

procedure printlabel(lab : integer);

{
    This routine prints a label based on a number from the
above procedure.  The prefix for the label can be anything the
assembler accepts - in this case I wanted it similar to the prefix
of the run time library routines.  I didn't realize how ugly it
would look.
}

begin
    write(output, '_p%', lab);
end;

function nch(): char;

{
    This stands for next character, and just returns the
buffered character from the appropriate file.  It looks ahead.
}

begin
    if including then
    nch := input2^
     else
    nch := input^;
end;

procedure doinclude;

{
    The name says it all.  The mechanics of the include
directive are all handled here.  If you want to nest includes,
you'll have to implement a list or something here, then adjust
endoffile(), readchar(), nextchar(), etc.  Not too hard, I suppose.
}

var
    c        : string;
begin
    if including then
    error("Cannot nest include files")
    else begin
    while (currentchar = ' ') or (currentchar = chr(9)) or
        (currentchar = chr(10)) do
        readchar;
    if currentchar = '"' then
        gch
    else
        error("missing open quote");
    c := includename;
    while (currentchar <> '"') and (currentchar <> chr(10)) do begin
        c^ := currentchar;
        readchar;
        c := string(integer(c) + 1); { sorry. }
    end;

    if currentchar = '"' then
        readchar
    else
        error("missing close quote");

    c^ := chr(0);

    if reopen(includename, input2) then begin
        saveline  := lineno;
        savestart := fnstart;
        savechar  := currentchar;
        including := true;
        readchar;
    end else
        error("Could not open include file");
    end
end;

procedure docomment;

{
    This routine implements compiler directives.  When I get a
few more directives I'll probably split these up a bit.  I'd also
like to make the directives themselves full words.
}

begin
    readchar;
    if currentchar = '$' then begin
    readchar;
    if currentchar = 'I' then begin
        readchar;
        doinclude;
        return;
    end else if currentchar = 'A' then begin
        readchar;
        while currentchar <> '}' do begin
        write(output, currentchar);
        if endoffile() then begin
            error("File ended in a comment");
            return;
        end;
        readchar;
        end;
        readchar;
        writeln(output);
        return;
    end else if currentchar = 'R' then begin
        readchar;
        if currentchar = '+' then
        rangecheck := true
        else if currentchar = '-' then
        rangecheck := false;
    end;
    end;
    endcomment;
end;

function alpha(c : char): boolean;

{
    This function answers the eternal question "is this
character an alphabetic character?"  Note that _ is.
}

begin
    if (ord(c) >= ord('a')) and (ord(c) <= ord('z')) then
    alpha := true
    else if (ord(c) >= ord('A')) and (ord(c) <= ord('Z')) then
    alpha := true
    else if c = '_' then
    alpha := true
    else
    alpha := false;
end;

function numeric(c : char): boolean;

{
    Is the character a digit?
}

begin
    numeric := (ord(c) >= ord('0')) and (ord(c) <= ord('9'));
end;

function an(c : char): boolean;

{
    Is the character a letter or digit?
}

begin
    an := alpha(c) or numeric(c);
end;

procedure header;

{
    This routine references all the run time library routines.
One thing I like about A68k is that the only routines that will
actually be referenced are those that are used in the code.  Maybe
all assemblers do this, but I don't know.
}

begin
    writeln(output, "* Pascal compiler intermediate assembly program.\n\n");
    writeln(output, "\tSECTION\tONE\n");
    writeln(output, "\tXREF\t_stdout");
    writeln(output, "\tXREF\t_p%writeint");
    writeln(output, "\tXREF\t_p%writechar");
    writeln(output, "\tXREF\t_p%writebool");
    writeln(output, "\tXREF\t_p%writecharray");
    writeln(output, "\tXREF\t_p%writestring");
    writeln(output, "\tXREF\t_p%writeln");
    writeln(output, "\tXREF\t_p%readint");
    writeln(output, "\tXREF\t_p%readcharray");
    writeln(output, "\tXREF\t_p%readchar");
    writeln(output, "\tXREF\t_p%readarbbuf");
    writeln(output, "\tXREF\t_p%readstring");
    writeln(output, "\tXREF\t_p%readln");
    writeln(output, "\tXREF\t_p%readarb");
    writeln(output, "\tXREF\t_p%dispose");
    writeln(output, "\tXREF\t_p%new");
    writeln(output, "\tXREF\t_p%open");
    writeln(output, "\tXREF\t_p%writearb");
    writeln(output, "\tXREF\t_p%close");
    writeln(output, "\tXREF\t_p%case");
    writeln(output, "\tXREF\t_p%exit\n");
    if mainmode then begin
    writeln(output, "\tXREF\t_p%initialize");
    writeln(output, "\tXREF\t_p%wrapitup");
    writeln(output, "\tjsr\t_p%initialize");
    writeln(output, "\tjsr\t_MAIN");
    writeln(output, "\tjsr\t_p%wrapitup");
    writeln(output, "\trts");
    end
end;

procedure trailer;

{
    This routine is the most important in the compiler
}

begin
    writeln(output, "\tEND");
end;

procedure blanks;

{
    blanks() skips spaces, tabs and eoln's.  It handles
comments if it comes across one.
}

var
    done : boolean;
begin
    if currentchar = '{' then
    docomment;
    done := false;
    while not done do begin
    if endoffile() then
        done := true
    else if (currentchar = ' ') or (currentchar = chr(9)) or
        (currentchar = chr(10)) then
        readchar
    else if currentchar = '{' then
        docomment;
    else
        done := true;
    end;
end;

procedure dumplits;

{
    This procedure dumps the literal table at the end of the
compilation.  Individual components are referenced as offsets to
the literal label.
}

var
    j, k    : integer;
    quotemode    : boolean;
begin
    if litptr = 0 then
    return;
    writeln(output, "\n\tSECTION\tTWO,DATA\n");
    printlabel(litlab);
    k := 1;
    while k < litptr do begin
    write(output, "\tdc.b\t");
    j := 0;
    quotemode := false;
    while j < 40 do begin
        if (ord(litq[k]) > 31) and (ord(litq[k]) <> 39) then begin
        if quotemode then
            write(output, litq[k])
        else begin
            if j > 0 then
            write(output, ',');
            write(output, chr(39), litq[k]);
            quotemode := true;
        end;
        end else begin
        if quotemode then begin
            write(output, chr(39));
            quotemode := false;
        end;
        if j > 0 then
            write(output, ',');
        write(output, ord(litq[k]));
        if j > 32 then
            j := 40
        else
            j := j + 3;
        end;
        j := j + 1;
        k := k + 1;
        if k >= litptr then
        j := 40;
    end;
    if quotemode then
        write(output, chr(39));
    writeln(output);
    end
end;

procedure dumpids;

{
    This routine does whatever is appropriate with the various
identifers.  If it's a global, it either references it or allocates
space.  Similar stuff for the other ids.  When the modularity of
PCQ is better defined, this routine will have to do more work.
}

var
    vartype    : integer;
    index    : integer;
    isodd    : boolean;
begin
    if mainmode then
    writeln(output, "\n\tSECTION\tTHREE,BSS\n");
    index:= 1;
    isodd := false;
    while index < identptr do begin
    if idents[index].object = global then begin
        if mainmode then begin
        vartype := idents[index].vtype;
        if isodd and (idents[vartype].size > 1) then begin
            writeln(output, "\tCNOP\t0,2");
            isodd := false;
        end;
        writeln(output, "\tXDEF\t_", idents[index].name);
        write(output, '_', idents[index].name);
        writeln(output, "\tds.b\t", idents[vartype].size);
        if odd(idents[vartype].size) then
            isodd := not isodd;
        end else
        writeln(output, "\tXREF\t_", idents[index].name);
    end else if (idents[index].object = proc) or
            (idents[index].object = func) then
        if idents[index].upper = 0 then
        writeln(output, "\tXREF\t_", idents[index].name);
    index := index + 1;
    end
end;

procedure readword;

{
    This reads a Pascal identifier into symtext.
}

var
    index    : integer;
    ptr        : string;
begin
    index := 0;
    ptr := symtext;
    while an(currentchar) do begin
    ptr^ := currentchar;
    gch;
    ptr := string(integer(ptr) + 1); { here's that thing again...}
    end;
    ptr^ := chr(0);
    currsym := searchreserved();
    if currsym = 0 then
    currsym := ident1;
    symloc := 0;
end;

procedure readnumber;

{
    This routine reads a literal integer.  Since it uses *, it
will not properly handle numbers whose magnitude is greater than
about 200,000 or 300,000.  Note that _ can be used.
}

var
    negative : boolean;
begin
    if currentchar = '-' then begin
    negative := true;
    gch();
    end else
    negative := false;
    symloc:= 0;
    while numeric(currentchar) do begin
    symloc := symloc * 10 + ord(currentchar) - ord('0');
    gch();
    if currentchar = '_' then
        gch();
    end;
    if negative then
    symloc := -symloc;
    currsym := numeral1;
end;

procedure readhex;

{
    readhex() reads a hexadecimal number.  Since it uses the
assembly instructions it is able to read full 32 bit values.
}

var
   rc : integer;
begin
    gch;
    symloc := 0;
    rc := ord(raise(currentchar));
    while numeric(currentchar) or
      ((rc >= ord('A')) and (rc <= ord('F'))) do begin

{$A    move.l    _symloc,d0
    asl.l    #4,d0
    move.l    d0,_symloc    ; symloc := symloc * 16;
}
    if numeric(currentchar) then
        symloc := symloc + ord(currentchar) - ord('0')
    else
        symloc := symloc + rc - ord('A') + 10;
    gch;
    rc := ord(raise(currentchar));
    end;
    currsym := numeral1;
end;

procedure writehex(num : integer);

{
    This writes full 32 bit hexadecimal numbers.
}

var
    numary  : array [1..8] of char;
    pos     : integer;
    ch      : char;
begin
    pos := 8;
    while (num <> 0) and (pos > 0) do begin
{$A    move.l    8(a5),d0
    and.b    #15,d0
    move.b    d0,-13(a5)    ; ch := num AND $0f;
}
    if ord(ch) < 10 then
        numary[pos] := chr(ord(ch) + ord('0'))
    else
        numary[pos] := chr(ord(ch) + ord('A') - 10);
    pos := pos - 1;

{$A    move.l    8(a5),d0
    lsr.l    #4,d0
    move.l    d0,8(a5)    ; num := num div 16;
}
    end;
    if pos = 8 then begin
    pos := 7;
    numary[8] := '0';
    end;
    write(output, '$');
    for num := pos + 1 to 8 do
    write(output, numary[num]);
end;

procedure nextsymbol;

{
    This is the workhorse lexical analysis routine.  It sets
currsym to the appropriate symbol number, sets symtext equal to
whatever identifier is read, and symloc to the value of a literal
integer.
    Soon this will be a big case statement.
}

begin
    errorptr := eqend;
    blanks;
    if endoffile() then begin
    currentchar := chr(0);
    currsym := endtext1; { I don't think this routine is ever hit }
    return;
    end;
    while currentchar = '{' do begin
    docomment;    { I think this is unused }
    blanks;
    end;
    if alpha(currentchar) then
    readword
    else if numeric(currentchar) then
    readnumber
    else if currentchar = '[' then begin
    currsym:= leftbrack1;
    readchar;
    end else if currentchar = ']' then begin
    currsym:= rightbrack1;
    readchar;
    end else if currentchar = '(' then begin
    currsym:= leftparent1;
    readchar;
    end else if currentchar = ')' then begin
    currsym:= rightparent1;
    readchar;
    end else if currentchar = '+' then begin
    currsym := plus1;
    readchar;
    end else if currentchar = '-' then begin
    currsym := minus1;
    readchar;
    end else if currentchar = '*' then begin
    currsym:= asterisk1;
    readchar;
    end else if currentchar = '<' then begin
    gch;
    if currentchar = '=' then begin
        currsym := notgreater1;
        readchar;
    end else if currentchar = '>' then begin
        currsym := notequal1;
        readchar;
    end else
        currsym:= less1;
    end else if currentchar = '=' then begin
    currsym:= equal1;
    readchar;
    end else if currentchar = '>' then begin
    gch;
    if currentchar = '=' then begin
        currsym:= notless1;
        readchar;
    end else
        currsym:= greater1;
    end else if currentchar = ':' then begin
    gch;
    if currentchar = '=' then begin
        currsym:= becomes1;
        readchar;
    end else
        currsym:= colon1;
    end else if currentchar = ',' then begin
    currsym:= comma1;
    readchar;
    end else if currentchar = '.' then begin
    gch;
    if currentchar = '.' then begin
        currsym:= dotdot1;
        readchar;
    end else
        currsym:= period1;
    end else if currentchar = ';' then begin
    currsym:= semicolon1;
    readchar;
    end else if currentchar = chr(39) then begin
    currsym:= apostrophe1;
    readchar;
    end else if currentchar = '"' then begin
    currsym:= quote1;
    readchar;
    end else if currentchar = '^' then begin
    currsym:= carat1;
    readchar;
    end else if currentchar = '$' then
    readhex;
    else if currentchar = chr(0) then
    currsym:= endtext1;
    else begin
    error("Unknown symbol.");
    readchar;
    end
end;