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;