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.