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

Text File | 1989-05-10 | 8.5 KB | 363 lines

program PQPascal;

{
    PCQ Pascal Compiler
    Copyright (c) 1989 Patrick Quaid.

    This is the main file of the compiler.  When this file is
compiled, it allocates BSS for all the global variables.
}

const
{$I "pasconst.i"}

type
{$I "pastype.i"}

var
{$I "pasvar.i"}

    { The following routines are all exported by the other
      compiler files. }

    function strlen(s : string): integer;
        forward;
    function AllocString(l : integer): string;
        forward;
    procedure error(s : string);
        forward;
    function findid(s : string): integer;
        forward;
    function addproc(p : string; i : boolean): integer;
        forward;
    procedure nextsymbol;
        forward;
    function match(s : integer): boolean;
        forward;
    function declvar(r, f : integer) : integer;
        forward;
    procedure decltype(f : integer);
        forward;
    procedure declconst(f : integer);
        forward;
    procedure ns;
        forward;
    procedure reformargs;
        forward;
    function readtype(n : integer): integer;
        forward;
    function endoffile(): boolean;
        forward;
    procedure vardeclarations(f : integer);
        forward;
    function reformvars(i : integer): integer;
        forward;
    procedure outname(s : string);
        forward;
    procedure initreserved;
        forward;
    procedure initglobals;
        forward;
    procedure dumpids;
        forward;
    procedure dumplits;
        forward;
    procedure dumptypes;
        forward;
    procedure trailer;
        forward;
    procedure compound;
        forward;
    procedure header;
        forward;
    procedure initstandard;
        forward;
    procedure readchar;
        forward;
    function an(c : char): boolean;
        forward;
    procedure needrightparent;
        forward;
    function simpletype(t : integer): boolean;
        forward;


procedure openfiles;

{
    This routine does all the command line business, which is
at this point not much.  It only accepts spaces and tabs as
delimeters, for example, and doesn't take care of quotes or escape
sequences.  Furthermore, it doesn't handle any command line
switches.  In the future I'll use a routine more like that in
ChopCL.p
}

var
    index    : integer;
    str        : string;
begin
    index := 1;
    while ((commandline[index]= ' ') or (commandline[index] = chr(9)))
    and (index <= 128) do
    index := index + 1;
    if index >= 128 then begin
    writeln('Bad file names.');
    exit(20);
    end;
    mainname := string(adr(commandline[index]));
    while (commandline[index]<> ' ') and (commandline[index] <> chr(9))
    and (index <= 128) do
    index := index + 1;
    if index >= 128 then begin
    writeln('Bad file names.');
    exit(20);
    end;
    commandline[index] := chr(0);
    if not reopen(mainname, input) then begin
    writeln('Could not open ', mainname);
    exit(20);
    end;
    index := index + 1;

    while ((commandline[index]= ' ') or (commandline[index] = chr(9)))
    and (index <= 128) do
    index := index + 1;
    if index >= 128 then begin
    writeln('Bad file names.');
    exit(20);
    end;
    str := string(adr(commandline[index]));
    while (ord(commandline[index]) > ord(' ')) and
      (ord(commandline[index]) < 127) and
      (index <= 128) do
    index := index + 1;
    if index >= 128 then begin
    writeln('Bad file names.');
    exit(20);
    end;
    commandline[index] := chr(0);

    if not open(str, output) then begin
    writeln('Could not open the output file.');
    exit(20);
    end;
end;

procedure doblock(isfunction : boolean);

{
    This is the main routine for handling program, procedure
and function blocks.  It handles the various declaration blocks and
the procedure and function parameters.  This is one of the many
routines which should, and will, be broken into more manageable
parts.
}

var
    blockloc    : integer;
    blockspell    : integer;
    firstident    : integer;
    functype    : integer;
    index    : integer;
    varspace    : integer;
    savefn    : integer;
    forded    : boolean;
begin
    fnstart := lineno;
    firstident := identptr;
    forded := false;
    if blocklevel > 0 then begin
    if currsym <> ident1 then begin
        error("Missing function or procedure name!");
        return;
    end;
    currfn:= findid(symtext);
    if currfn <> 0 then begin
        if idents[currfn].upper <> 0 then
        error("Duplicate ID")
        else
        forded := true;
    end else
        currfn := addproc(symtext, isfunction);
    nextsymbol;

    if match(leftparent1) then begin
        prevarg := currfn;
        argstk := 0;
        while (currsym = ident1) or (currsym = var1) do begin
        if match(var1) then
            index := declvar(refarg, firstident)
        else
            index := declvar(valarg, firstident);
        if currsym <> rightparent1 then
            ns;
        end;
        idents[currfn].size := argstk;
        reformargs;
        needrightparent;
    end else if isfunction then
        error("Functions must have parentheses");

    if isfunction then begin
        if not match(colon1) then
        error("expecting :");
        functype := readtype(0);
        if functype > 0 then begin
        if not simpletype(functype) then begin
            error("expecting a simple type");
            functype := badtype;
        end;
        end else
        functype := badtype;
        idents[currfn].vtype := functype;
    end;
    ns;
    blockloc := identptr;
    blockspell := spellptr;
    varspace := 0;
    end;

    if match(forward1) then begin
    idents[currfn].upper := 0;
    ns;
    blockloc := idents[currfn].indtype;
    while blockloc <> 0 do begin
        idents[blockloc].name := string(adr(spelling));
        blockloc := idents[blockloc].indtype;
    end;
    end else begin
    idents[currfn].upper := -1;
    while currsym <> begin1 do begin
        if endoffile() then begin
        if mainmode or (blocklevel > 0) then
            error("There was no code section!");
        return;
        end else if match(var1) then begin
        index := identptr - 1;
        vardeclarations(firstident);
        if blocklevel > 0 then
            varspace := reformvars(index);
        end else if match(type1) then
        decltype(firstident)
        else if match(const1) then
        declconst(firstident)
        else if match(proc1) then begin
        blocklevel := blocklevel + 1;
        savefn := currfn;
        doblock(false);
        currfn := savefn;
        blocklevel := blocklevel - 1;
        end else if match(func1) then begin
        blocklevel := blocklevel + 1;
        savefn := currfn;
        doblock(true);
        currfn := savefn;
        blocklevel := blocklevel - 1;
        end else begin
        error("expecting block identifier");
        nextsymbol;
        end;
    end;
    if (not mainmode) and (blocklevel = 0) then begin
        error("Expected a procedure or function header");
        return;
    end;
    if (blocklevel = 0) and mainmode then begin
        writeln(output, "\n\tXDEF\t_MAIN");
        writeln(output, '_MAIN');
    end;

    if blocklevel > 0 then begin
        writeln(output, "\n\tXDEF\t_", idents[currfn].name);
        writeln(output, '_', idents[currfn].name, "\tlink\ta5,#", varspace);
    end;
    nextsymbol;

    compound;

    if blocklevel > 0 then begin
        ns;
        identptr := blockloc;
        spellptr := blockspell;
        writeln(output, "\tunlk\ta5");

        blockloc := idents[currfn].indtype;
        while blockloc <> 0 do begin
        idents[blockloc].name := string(adr(spelling));
        blockloc := idents[blockloc].indtype;
        end;
    end;
    writeln(output, "\trts");
    end;
end;

procedure parse;

{
    This is the outermost parsing routine.  It uses doblock()
mainly, and will eventually be able to handle program parameters.
}

begin
    if match(program1) then begin
    mainmode:= true;
    if currsym <> ident1 then
        error("Missing program name.")
    else
        writeln('Compiling ', symtext);
    while not match(semicolon1) do
        nextsymbol;
    end else if match(extern1) then begin
    mainmode := false;
    writeln('Compiling external routines.');
    ns;
    end else begin
    error("First symbol must be PROGRAM or EXTERNAL.");
    mainmode:= false;
    end;
    header;
    blocklevel := 0;
    doblock(false);
    if mainmode then
    if not match(period1) then
        error("Program must end with a period.");
    if (not endoffile()) and (mainmode) then
    error("There should be nothing after the main procedure.");
end;

begin

{
    This is the big one, the main routine, which by itself does
very little.  Read parse() and doblock() to get a much better idea
of how things work.
}
    writeln('PCQ Compiler 1.0  (February 1, 1989)');
    writeln('Copyright ', chr(169),
        ' 1989 Patrick Quaid.  All rights reserved.');

    initglobals;    { initialize everything }
    initreserved;
    openfiles;
    initstandard;

    readchar;        { jump-start lex analysis }
    nextsymbol;

    parse;        { do everything }

    if errorcount = 0 then
    writeln('There were no errors.')
    else if errorcount = 1 then
    writeln('There was one error')
    else
    writeln('There were ', errorcount, ' errors.');

    dumpids;        { write ids and lits to assem file }
    dumplits;
    trailer;        { write 'END' }
    if errorcount <> 0 then
    exit(10);    { make sure there's an error is necessary }
end.