external;

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

	This routine implements the various standard procedures,
hence the name.
}

const
{$I "pasconst.i"}

type
{$I "pastype.i"}

var
{$I "pasvar.i"}

	procedure nextsymbol;
	    forward;
	function match(s : integer): boolean;
	    forward;
	procedure error(s : string);
	    forward;
	function expression(): integer;
	    forward;
	function conexpr(var t : integer): integer;
	    forward;
	function typecmp(t1, t2 : integer): boolean;
	    forward;
	function typecheck(t1, t2 : integer): boolean;
	    forward;
	function loadaddress() : integer;
	    forward;
	procedure mismatch;
	    forward;
	procedure needleftparent;
	    forward;
	procedure needrightparent;
	    forward;
	function findid(s : string) : integer;
	    forward;
	procedure savestack(t : integer);
	    forward;
	procedure saveval(v : integer);
	    forward;
	procedure ns;
	    forward;
	function loadvar(v : integer) : integer;
	    forward;
	procedure promotetype(var f : integer; o, r : integer);
	    forward;
	function numbertype(t : integer): boolean;
	    forward;

procedure callwrite(vartype : integer);

{
	This routine calls the appropriate library routine to write
vartype to a text file.
}

var
    elementtype	: integer;
begin
    if numbertype(vartype) then begin
	promotetype(vartype, inttype, 0);
	writeln(output, "\tjsr\t_p%writeint");
    end else if typecmp(vartype, chartype) then
	writeln(output, "\tjsr\t_p%writechar")
    else if typecmp(vartype, booltype) then
	writeln(output, "\tjsr\t_p%writebool")
    else if idents[vartype].offset = varray then begin
	elementtype := idents[vartype].vtype;
	if typecmp(elementtype, chartype) then begin
	    writeln(output, "\tmove.l\t#",
		idents[vartype].upper - idents[vartype].lower + 1, ',d3');
	    writeln(output, "\tjsr\t_p%writecharray");
	end else
	    error("can only write arrays of char");
    end else if typecmp(vartype, stringtype) then
	writeln(output, "\tjsr\t_p%writestring")
    else
	error("can't write that type to text file");
end;

procedure filewrite(vartype : integer);

{
	This routine writes a variable to a 'file of that
variable'.
}

begin
    writeln(output, "\tmove.l\t#", idents[vartype].size, ',d3');
    writeln(output, "\tjsr\t_p%writearb");
end;

procedure dowrite(varindex : integer);

{
	This routine handles all aspects of the write and writeln
statements.
}

var
    filetype	: integer; { file type if there is one }
    exprtype	: integer; { current element type }
    pushed	: boolean; { have pushed the file handle on stack }
    width	: integer; { constant field width }
    widtype     : integer; { type of the above }
begin
    if match(leftparent1) then begin
	filetype := expression();
	pushed := true;
	if idents[filetype].offset = vfile then begin
	    writeln(output, "\tmove.l\td0,a0");
	    writeln(output, "\tmove.l\t(a0),d0");
	    writeln(output, "\tmove.l\td0,-(sp)");
	end else begin
	    writeln(output, "\tmove.l\t_stdout,-(sp)");
	    if match(colon1) then begin
		width := conexpr(widtype);
		if not typecheck(inttype, widtype) then
		    error("Expecting integer value.");
		writeln(output, "\tmove.w\t#", width, ',-(sp)');
	    end else
		writeln(output, "\tmove.w\t#1,-(sp)");
	    callwrite(filetype);
	    writeln(output, "\taddq.l\t#2,sp");
	    filetype := texttype;
	end;
	while not match(rightparent1) do begin
	    if not match(comma1) then
		error("expecting , or )");
	    exprtype := expression();
	    if typecmp(filetype, texttype) then begin
		if match(colon1) then begin
		    width := conexpr(widtype);
		    if not typecheck(inttype, widtype) then
			error("Expecting integer value.");
		    writeln(output, "\tmove.w\t#", width, ',-(sp)');
		end else
		    writeln(output, "\tmove.w\t#1,-(sp)");
		callwrite(exprtype);
		writeln(output, "\taddq.l\t#2,sp");
	    end else begin
		if typecmp(idents[filetype].vtype, exprtype) then
		    filewrite(exprtype)
		else
		    mismatch;
	    end;
	end;
    end else begin
	filetype := texttype;
	pushed := false;
	if idents[varindex].offset = 1 then
	    error("'write' requires arguments.");
    end;
    if idents[varindex].offset = 2 then begin
	if filetype = texttype then begin
	    if pushed then
		writeln(output, "\tjsr\t_p%writeln")
	    else begin
		writeln(output, "\tmove.l\t_stdout,-(sp)");
		writeln(output, "\tjsr\t_p%writeln");
		writeln(output, "\taddq.l\t#4,sp");
	    end;
	end else
	   error("No ...ln for non-text files");
    end;
    if pushed then
	writeln(output, "\taddq.l\t#4,sp");
end;

procedure callread(vartype : integer);

{
	This routine calls the appropriate library routines to read
the vartype from a text file.
}

begin
    if typecmp(vartype, chartype) then
	writeln(output, "\tjsr\t_p%readchar")
    else if typecmp(vartype, inttype) then begin
	writeln(output, "\tjsr\t_p%readint");
	writeln(output, "\tmove.l\td0,(a0)");
    end else if typecmp(vartype, shorttype) then begin
	writeln(output, "\tjsr\t_p%readint");
	writeln(output, "\tmove.w\td0,(a0)");
    end else if idents[vartype].offset = varray then begin
	if typecmp(idents[vartype].vtype, chartype) then begin
	    writeln(output, "\tmove.l\t#",
		idents[vartype].upper - idents[vartype].lower + 1, ',d3');
	    writeln(output, "\tjsr\t_p%readcharray");
	end else
	    error("can only read character arrays");
    end else if typecmp(vartype, stringtype) then
	writeln(output, "\tjsr\t_p%readstring");
    else
	error("cannot read that type from a text file");
end;

procedure doread(varindex : integer);

{
	This handles the read statement.  Note that read(f, var) from a
non-text file really does end up being var := f^; get(f).  Same
goes for text files, but it's all handled within the library.
	Note the difference between this and dowrite(),
specifically the use of expression() up there and loadaddress()
here.
}

var
    filetype	: integer;
    vartype	: integer;
    pushed	: boolean;
begin
    if match(leftparent1) then begin
	filetype := loadaddress();
	pushed := true;
	if idents[filetype].offset = vfile then
	    writeln(output, "\tmove.l\ta0,-(sp)");
	else begin
	    writeln(output, "\tmove.l\t#0,-(sp)");
	    callread(filetype);
	    filetype := texttype;
	end;
	while not match(rightparent1) do begin
	    if not match(comma1) then
		error("expecting , or )");
	    vartype := loadaddress();
	    if typecmp(filetype, texttype) then
		callread(vartype)
	    else begin
		if typecmp(idents[filetype].vtype, vartype) then
		    writeln(output, "\tjsr\t_p%readarb")
		else
		    mismatch;
	    end;
	end;
    end else begin
	filetype := texttype;
	pushed := false;
	if idents[varindex].offset = 3 then
	    error("'read' requires arguments.");
    end;
    if idents[varindex].offset = 4 then begin
	if typecmp(filetype, texttype) then begin
	    if pushed then
		writeln(output, "\tjsr\t_p%readln")
	    else begin
		writeln(output, "\tmove.l\t#0,-(sp)");
		writeln(output, "\tjsr\t_p%readln");
		writeln(output, "\taddq.l\t#4,sp");
	    end;
	end else
	   error("No ...ln for non-text files");
    end;
    if pushed then
	writeln(output, "\taddq.l\t#4,sp");
end;

procedure donew;

{
	This just handles allocation of memory.
}

var
    varindex	: integer;
    vartype	: integer;
    varsize	: integer;
    stackvar	: integer;
begin
    needleftparent;
    varindex := findid(symtext);
    if varindex <> 0 then begin
	stackvar := loadvar(varindex);
	if stackvar <> 0 then begin
	    writeln(output, "\tmove.l\td0,-(sp)");
	    vartype := stackvar;
	end else
	    vartype := idents[varindex].vtype;
	if idents[vartype].offset <> vpointer then
	    error("expecting a pointer type");
	varsize := idents[vartype].vtype;
	varsize := idents[varsize].size;
	writeln(output, "\tmove.l\t#", varsize, ',d0');
	writeln(output, "\tjsr\t_p%new");
	if stackvar <> 0 then
	    savestack(vartype)
	else
	    saveval(varindex);
    end else
	error("Unknown identifier");
    needrightparent;
end;

procedure dodispose;

{
	This routine calls the library routine that disposes of
memory.
}

var
    exprtype	: integer;
begin
    needleftparent;
    exprtype := expression();
    if idents[exprtype].offset <> vpointer then
	error("Expecting a pointer type")
    else
	writeln(output, "\tjsr\t_p%dispose");
    needrightparent;
end;

procedure doclose;

{
	Closes a file.  The difference between this and a normal
DOS close is that this routine must un-link the file from the
program's open file list.
}

var
    exprtype	: integer;
begin
    needleftparent;
    exprtype := expression();
    if idents[exprtype].offset <> vfile then
	error("Expecting a file type")
    else
	writeln(output, "\tjsr\t_p%close");
    needrightparent;
end;

procedure doget;

{
	This implements get.  There is no analogous put(), since
the write statements never needed it.
}

var
    exprtype	: integer;
begin
    needleftparent;
    exprtype := expression();
    if idents[exprtype].offset <> vfile then
	error("Expecting a file type")
    else begin
	writeln(output, "\tmove.l\td0,a0");
	writeln(output, "\tjsr\t_p%readarbbuf");
    end;
    needrightparent;
end;

procedure doexit;

{
	Just calls the routine that allows the graceful shut-down
of the program.
}

var
    exprtype : integer;
begin
    needleftparent;
    exprtype := expression();
    if not typecheck(exprtype, inttype) then
	error("Expecting an integer argument.");
    writeln(output, "\tjsr\t_p%exit");
    needrightparent;
end;

procedure dotrap;

{
	This is just for debugging a program.  Use some trap, and
your debugger will stop at that statement.
}

var
    exprtype,
    trapnum   : integer;
begin
    needleftparent;
    trapnum := conexpr(exprtype);
    writeln(output, "\ttrap\t#", trapnum);
    needrightparent;
end;

procedure stdproc(varindex : integer);

{
	This routine sifts out the proper routine to call.
}

var
    exprtype	: integer;
    pushed	: boolean;
begin
    nextsymbol;
    pushed := false;
    if (idents[varindex].offset = 1) or
	    (idents[varindex].offset = 2) then
	dowrite(varindex)
    else if (idents[varindex].offset = 3) or
	    (idents[varindex].offset = 4) then
	doread(varindex)
    else if idents[varindex].offset = 5 then
	donew
    else if idents[varindex].offset = 6 then
	dodispose
    else if idents[varindex].offset = 7 then
	doclose
    else if idents[varindex].offset = 8 then
	doget
    else if idents[varindex].offset = 9 then
	doexit
    else if idents[varindex].offset = 10 then
	dotrap;
    ns;
end;