2850 lines
69 KiB
ObjectPascal
2850 lines
69 KiB
ObjectPascal
{$optimize 15}
|
|
{------------------------------------------------------------}
|
|
{ }
|
|
{ ORCA/Pascal Call Procedure }
|
|
{ }
|
|
{ The call procedure handles parsing, semantic analysis }
|
|
{ and code generation for all procedure and function calls. }
|
|
{ This includes both user-defined and predeclared }
|
|
{ routines. }
|
|
{ }
|
|
{ By Mike Westerfield }
|
|
{ }
|
|
{ Copyright March 1988 }
|
|
{ By the Byte Works, Inc. }
|
|
{ }
|
|
{------------------------------------------------------------}
|
|
|
|
unit Call;
|
|
|
|
interface
|
|
|
|
{$segment 'Pascal2'}
|
|
{$LibPrefix '0/obj/'}
|
|
|
|
uses pcommon, scanner, cgi, symbols;
|
|
|
|
{-- Externally available variables --------------------------------------------}
|
|
|
|
type
|
|
{subroutine calls}
|
|
{----------------}
|
|
callKinds = (cStandard, cMethod, cInherited);
|
|
|
|
{temporary variable allocation}
|
|
{-----------------------------}
|
|
tempPtr = ^tempRecord;
|
|
tempRecord = record
|
|
last,next: tempPtr; {doubly linked list}
|
|
labelNum: integer; {label number}
|
|
size: integer; {size of the variable}
|
|
end;
|
|
|
|
var
|
|
psize: integer; {size of the parameter space for the current stack frame}
|
|
lc: addrrange; {current stack frame size}
|
|
|
|
{temporary variable allocation}
|
|
{-----------------------------}
|
|
tempList: tempPtr; {list of temp work variables}
|
|
|
|
{-- Externally available subroutines ------------------------------------------}
|
|
|
|
procedure Call (fsys: setofsys; fcp,fprocp: ctp);
|
|
|
|
{ generate a call to a procedure or function }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
{ fcp - }
|
|
{ fprocp - }
|
|
|
|
|
|
procedure CallNonStandard (fsys: setofsys; fcp,fprocp: ctp; odisp: longint;
|
|
callKind: callKinds);
|
|
|
|
{ Handle a call to a user defined procedure/function }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
{ fcp - }
|
|
{ fprocp - }
|
|
{ odisp - disp in object for method calls; else 0 }
|
|
{ callKind - type of this call }
|
|
|
|
|
|
procedure CheckBool;
|
|
{load a value, insuring that it is boolean}
|
|
|
|
procedure CheckBnds(fsp: stp);
|
|
{generate range checking code (if needed)}
|
|
|
|
procedure FreeTemp (labelNum, size: integer);
|
|
|
|
{ place a temporary label in the available label list }
|
|
{ }
|
|
{ parameters: }
|
|
{ labelNum - number of the label to free }
|
|
{ size - size of the variable }
|
|
{ }
|
|
{ variables: }
|
|
{ tempList - list of free labels }
|
|
|
|
|
|
function GetTemp (size: integer): integer;
|
|
|
|
{ find a temporary work variable }
|
|
{ }
|
|
{ parameters: }
|
|
{ size - size of the variable }
|
|
{ }
|
|
{ variables: }
|
|
{ tempList - list of free labels }
|
|
{ }
|
|
{ Returns the label number. }
|
|
|
|
|
|
procedure Load;
|
|
{load a value onto the evaluation stack}
|
|
|
|
procedure LoadAddress;
|
|
{load the address of a variable onto the top of the stack}
|
|
|
|
procedure LoadStringAddress;
|
|
{load the address and length of a string}
|
|
|
|
procedure LoadString(kind: stringKind);
|
|
{load the address of a string constant}
|
|
|
|
function ParmSize(lsp: stp; vkind: idkind): integer;
|
|
{find the length of a parameter}
|
|
|
|
procedure ResetTemp;
|
|
|
|
{ forget all of the temporary work variables }
|
|
|
|
|
|
procedure Store(var fattr: attr);
|
|
{store the value on top of stack}
|
|
|
|
{-- Private declarations ------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
const
|
|
realfw = 16; {field width for reals & doubles}
|
|
longfw = 16; {field width for long integers}
|
|
intfw = 8; {field width for integers}
|
|
boolfw = 8; {field width for booleans}
|
|
|
|
var
|
|
lkey: keyrange; {proc/func key for std proc compilation}
|
|
{-- Imported subroutines ------------------------------------------------------}
|
|
|
|
procedure DoConstant(fsys: setofsys; var fsp: stp; var fvalu: valu); extern;
|
|
{compile a constant term}
|
|
|
|
procedure Expression(fsys: setofsys; fprocp: ctp); extern;
|
|
{compile an expression}
|
|
|
|
procedure Selector (fsys: setofsys; fcp,fprocp: ctp; var isMethod: boolean);
|
|
extern;
|
|
|
|
{ handle indexing arrays, field selection, dereferencing of }
|
|
{ pointers, windowing files }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
{ fcp - }
|
|
{ fprocp - }
|
|
{ isMethod - (returned) Did the selection resolve to a }
|
|
{ method call? If so, take no further action. }
|
|
|
|
{-- Private subroutines -------------------------------------------------------}
|
|
|
|
procedure Variable(fsys: setofsys; fprocp: ctp);
|
|
{compile a variable for the parm list of a standard proc/func}
|
|
|
|
var
|
|
isMethod: boolean; {dummy variable for Selector call}
|
|
lcp: ctp;
|
|
|
|
begin {Variable}
|
|
if sy = ident then begin
|
|
SearchId([varsm,field],lcp);
|
|
InSymbol;
|
|
end
|
|
else begin
|
|
Error(2);
|
|
lcp := uvarptr;
|
|
end;
|
|
Selector(fsys, lcp, fprocp, isMethod);
|
|
glcp := lcp;
|
|
end; {Variable}
|
|
|
|
procedure GetPutClose(fsys: setofsys; fprocp: ctp);
|
|
{Compile one of the named standard procs}
|
|
|
|
begin {GetPutClose}
|
|
{compile the file variable}
|
|
Variable(fsys + [rparent],fprocp);
|
|
{load the file variable}
|
|
Load;
|
|
Gen0t(pc_stk, cgULong);
|
|
{do type checking on file variable}
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form <> files then
|
|
Error(44);
|
|
{generate the standard proc call}
|
|
Gen1(pc_csp,lkey{get,put,opn,cls})
|
|
end; {GetPutClose}
|
|
|
|
procedure resetrewriteopen(fsys: setofsys; fprocp: ctp);
|
|
|
|
var
|
|
key: integer; {open kind key; 1->read; 2->write; 3->both}
|
|
size: longint; {for remembering file size}
|
|
lsp: stp; {file type}
|
|
fkind: (stin,stout,errout,fileout); {kind of file}
|
|
|
|
begin {resetrewriteopen}
|
|
{process the file variable}
|
|
Variable(fsys+[comma,rparent],fprocp);
|
|
fkind := fileout;
|
|
if gattr.typtr = nil then
|
|
Error(44)
|
|
else if gattr.typtr^.form = files then begin
|
|
size := gattr.typtr^.filtype^.size;
|
|
if glcp = outptr then begin
|
|
fkind := stout;
|
|
if nooutput then Error(92);
|
|
end
|
|
else if glcp = inptr then begin
|
|
fkind := stin;
|
|
if noinput then Error(91);
|
|
end
|
|
else if glcp = erroroutputptr then
|
|
fkind := errout;
|
|
end
|
|
else Error(44);
|
|
{determine the type of the open}
|
|
if lkey = 3 then
|
|
key := 3
|
|
else
|
|
key := lkey-4;
|
|
case key of
|
|
1: if fkind in [stout,errout] then Error(44);
|
|
2: if fkind = stin then Error(44);
|
|
3: if fkind <> fileout then Error(44);
|
|
end;
|
|
if gattr.typtr <> nil then
|
|
if fkind = fileout then begin
|
|
{load the file variable}
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
{push the open type onto the stack}
|
|
lsp := glcp^.idtype;
|
|
if lsp^.form = pointerStruct then lsp := lsp^.eltype;
|
|
Gen1t(pc_ldc, key+4*ord(lsp=textptr), cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
{load the length of the file}
|
|
Gen1t(pc_ldc, ord(size), cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end {if}
|
|
else begin
|
|
Gen1t(pc_ldc, ord(fkind), cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {else}
|
|
{if there is another parameter, use it for the file name}
|
|
if sy = comma then begin
|
|
if iso then Error(112);
|
|
InSymbol;
|
|
Expression(fsys+[rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then begin
|
|
LoadStringAddress;
|
|
Gen0t(pc_bno, cgULong);
|
|
end {if}
|
|
else Error(44)
|
|
else Error(44);
|
|
end
|
|
else begin
|
|
GenLdcLong(0);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1t(pc_ldc, 0, cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {else}
|
|
{open the file}
|
|
if fkind = fileout then
|
|
Gen1(pc_csp,3{opn})
|
|
else
|
|
Gen1(pc_csp,115{rdr});
|
|
end; {resetrewriteopen}
|
|
|
|
procedure seek(fsys: setofsys; fprocp: ctp);
|
|
{Compile the seek statement}
|
|
|
|
begin {seek}
|
|
Variable(fsys+[comma,rparent],fprocp);
|
|
if gattr.typtr = nil then
|
|
Error(44)
|
|
else if gattr.typtr^.form <> files then
|
|
Error(44);
|
|
Load;
|
|
Gen0t(pc_stk, cgULong);
|
|
Match(comma,20);
|
|
Expression(fsys+[rparent],fprocp);
|
|
Load;
|
|
if gattr.typtr <> nil then begin
|
|
if (gattr.typtr=intptr) or (gattr.typtr=byteptr) then begin
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgLong));
|
|
gattr.typtr := longptr;
|
|
end;
|
|
if gattr.typtr <> longptr then Error(44);
|
|
end
|
|
else Error(44);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp,44{sek});
|
|
end; {seek}
|
|
|
|
procedure page(fsys: setofsys; fprocp: ctp);
|
|
{compile a page procedure call}
|
|
|
|
var
|
|
lsp: stp;
|
|
|
|
begin {page}
|
|
if sy = lparent then begin
|
|
InSymbol;
|
|
Variable(fsys+[rparent],fprocp);
|
|
lsp := gattr.typtr;
|
|
if lsp <> nil then
|
|
if lsp = textptr then
|
|
if sy <> rparent then begin
|
|
Error(4);
|
|
Skip(fsys+[rparent]);
|
|
end
|
|
else InSymbol
|
|
else Error(44)
|
|
else Error(44);
|
|
if glcp = outptr then begin
|
|
Gen0(pc_nop);
|
|
Gen1(pc_csp,32{pag});
|
|
end {if}
|
|
else if glcp = erroroutputptr then begin
|
|
Gen0(pc_nop);
|
|
Gen1(pc_csp,33{pag});
|
|
end {else if}
|
|
else begin
|
|
Load;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1(pc_csp,15{pag});
|
|
end;
|
|
end
|
|
else begin
|
|
if nooutput then Error(92);
|
|
Gen0(pc_nop);
|
|
Gen1(pc_csp,32{pag});
|
|
end;
|
|
end; {page}
|
|
|
|
procedure HaltSeed(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to halt or seed}
|
|
|
|
begin {HaltSeed}
|
|
Expression(fsys+[rparent],fprocp);
|
|
Load;
|
|
if gattr.typtr <> nil then begin
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
|
|
end
|
|
else Error(44);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen1(pc_csp,46+lkey);
|
|
end; {HaltSeed}
|
|
|
|
procedure Delete(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to the delete string procedure}
|
|
|
|
begin {Delete}
|
|
{load the string to delete characters from}
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then begin
|
|
if gattr.kind <> varbl then Error(44);
|
|
LoadStringAddress;
|
|
end
|
|
else Error(44)
|
|
else Error(44);
|
|
{load the index}
|
|
Match(comma,20);
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
if gattr.typtr <> nil then begin
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
|
|
Error(44);
|
|
end
|
|
else Error(44);
|
|
{load the number of chars to delete}
|
|
Match(comma,20);
|
|
Expression(fsys+[rparent],fprocp);
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
if gattr.typtr <> nil then begin
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
|
|
end
|
|
else Error(44);
|
|
{call the delete procedure}
|
|
Gen1(pc_csp,68{dlt});
|
|
end; {Delete}
|
|
|
|
procedure Insert(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to insert one string an another}
|
|
|
|
begin {Insert}
|
|
{load the string to insert characters into}
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then
|
|
LoadStringAddress
|
|
else if gattr.typtr = charptr then begin
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
GenLdcLong(-1);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgWord);
|
|
end
|
|
else Error(44)
|
|
else Error(44);
|
|
{load the string to insert}
|
|
Match(comma,20);
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then begin
|
|
if gattr.kind <> varbl then
|
|
Error(44);
|
|
LoadStringAddress;
|
|
Gen0t(pc_bno, cgWord);
|
|
end
|
|
else Error(44)
|
|
else Error(44);
|
|
{load the index}
|
|
Match(comma,20);
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
if gattr.typtr <> nil then begin
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
|
|
end
|
|
else Error(44);
|
|
{call the insert procedure}
|
|
Gen1(pc_csp,69{ins});
|
|
end; {Insert}
|
|
|
|
procedure CommandLineShellID(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to CommandLine or ShellID}
|
|
|
|
begin {CommandLineShellID}
|
|
{load the string to place characters in}
|
|
Expression(fsys+[rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then begin
|
|
if gattr.kind <> varbl then Error(44);
|
|
LoadStringAddress;
|
|
end
|
|
else Error(44)
|
|
else Error(44);
|
|
{call the procedure}
|
|
Gen1(pc_csp,46+lkey);
|
|
end; {CommandLineShellID}
|
|
|
|
procedure StartGraphDesk(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to StartGraph or StartDesk}
|
|
|
|
begin {StartGraphDesk}
|
|
Expression(fsys+[rparent],fprocp);
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
if gattr.typtr <> nil then begin
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
|
|
Error(44);
|
|
end
|
|
else Error(44);
|
|
Gen1(pc_csp,46+lkey);
|
|
end; {StartGraphDesk}
|
|
|
|
procedure EndGraphDesk;
|
|
{compile a call to EndGraph or EndDesk}
|
|
|
|
begin {EndGraphDesk}
|
|
Gen0(pc_nop);
|
|
Gen1(pc_csp,46+lkey);
|
|
end; {EndGraphDesk}
|
|
|
|
procedure DoRead (fsys: setofsys; fprocp: ctp);
|
|
|
|
{ compile a read procedure call }
|
|
{ }
|
|
{ Parameters: }
|
|
{ fsys - }
|
|
{ fprocp - }
|
|
|
|
var
|
|
lattr,tattr: attr;
|
|
lsp : stp;
|
|
needBno: boolean; {do we need a pc_bno?}
|
|
test: boolean;
|
|
standardIn: boolean; {is the read from standard input?}
|
|
llb: unsigned; {for allocating temporary space}
|
|
inLocalPtr: boolean; {is file ptr in local area?}
|
|
|
|
begin {DoRead}
|
|
inLocalPtr := false;
|
|
standardIn := true;
|
|
lattr.typtr := textptr;
|
|
if sy = lparent then begin
|
|
InSymbol;
|
|
Variable(fsys + [comma, rparent], fprocp);
|
|
if glcp <> nil then
|
|
with glcp^ do
|
|
if klass = varsm then begin
|
|
if vcontvar then
|
|
Error(97);
|
|
if vlev <> level then
|
|
vrestrict := true;
|
|
end; {if}
|
|
lsp := gattr.typtr;
|
|
test := false;
|
|
if lsp <> nil then
|
|
if lsp^.form = files then
|
|
|
|
{handle reads from files}
|
|
with gattr, lsp^ do begin
|
|
if (lkey = 13{readln}) and (typtr <> textptr) then
|
|
Error(44);
|
|
if access = indrct then begin
|
|
Load;
|
|
llb := GetTemp(ptrsize);
|
|
Gen3t(pc_str, llb, 0, 0, cgULong);
|
|
inLocalPtr := true;
|
|
dplab := llb;
|
|
gattr.isPacked := false;
|
|
kind := varbl;
|
|
access := drct;
|
|
vlevel := level;
|
|
FreeTemp(llb, ptrsize);
|
|
end; {if}
|
|
lattr := gattr;
|
|
standardIn := glcp = inptr;
|
|
if sy = rparent then begin
|
|
if lkey = 7{read} then
|
|
Error(44);
|
|
test := true;
|
|
end {if}
|
|
else if sy <> comma then begin
|
|
Error(44);
|
|
Skip(fsys + [comma, rparent]);
|
|
end; {else if}
|
|
if sy = comma then begin
|
|
InSymbol;
|
|
Variable(fsys + [comma, rparent], fprocp);
|
|
end {if}
|
|
else
|
|
test := true;
|
|
end {with}
|
|
else if noinput then
|
|
Error(91);
|
|
if lattr.typtr = textptr then begin
|
|
|
|
{read from a text file}
|
|
if not test then
|
|
repeat
|
|
if glcp <> nil then
|
|
with glcp^ do
|
|
if klass = varsm then begin
|
|
if vcontvar then
|
|
Error(97);
|
|
if vlev <> level then
|
|
vrestrict := true;
|
|
end; {if}
|
|
needBno := false;
|
|
if IsString(gattr.typtr) then begin
|
|
if gattr.kind <> expr then begin
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1t(pc_ldc, StrLen(gattr.typtr), cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
needBno := true;
|
|
end; {if}
|
|
end {if}
|
|
else begin
|
|
if gattr.typtr <> nil then
|
|
if (gattr.access<>drct) or
|
|
(gattr.typtr^.form in [arrays,records,objects,files]) then
|
|
LoadAddress;
|
|
end; {else}
|
|
tattr := gattr;
|
|
if not standardIn then begin
|
|
gattr := lattr;
|
|
if inLocalPtr then
|
|
Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
|
|
else
|
|
Load;
|
|
Gen0t(pc_stk, cgULong);
|
|
if needBno then
|
|
Gen0t(pc_bno, cgULong);
|
|
end; {if}
|
|
if tattr.typtr <> nil then
|
|
if (tattr.typtr^.form <= subrange) or IsString(tattr.typtr) then
|
|
begin
|
|
if standardIn then
|
|
Gen0(pc_nop);
|
|
if CompTypes(intptr, tattr.typtr) then begin
|
|
if standardIn then
|
|
Gen1(pc_csp, 59{rii})
|
|
else
|
|
Gen1(pc_csp, 5{rdi});
|
|
CheckBnds(tattr.typtr);
|
|
Store(tattr);
|
|
end {if}
|
|
else if CompTypes(longptr, tattr.typtr) then begin
|
|
if standardIn then
|
|
Gen1(pc_csp, 98{ril})
|
|
else
|
|
Gen1(pc_csp, 99{rdl});
|
|
CheckBnds(tattr.typtr);
|
|
Store(tattr);
|
|
end {else if}
|
|
else if CompTypes(charptr, tattr.typtr) then begin
|
|
if standardIn then
|
|
Gen1(pc_csp, 58{ric})
|
|
else
|
|
Gen1(pc_csp, 7{rdc});
|
|
CheckBnds(tattr.typtr);
|
|
Store(tattr);
|
|
end {else if}
|
|
else if CompTypes(realptr, tattr.typtr) then begin
|
|
if standardIn then
|
|
Gen1(pc_csp, 61{rir})
|
|
else
|
|
Gen1(pc_csp, 6{rdr});
|
|
CheckBnds(tattr.typtr);
|
|
Store(tattr);
|
|
end {else if}
|
|
else if CompTypes(stringptr, tattr.typtr) then begin
|
|
if standardIn then
|
|
Gen1(pc_csp, 84{ris})
|
|
else
|
|
Gen1(pc_csp, 50{rds});
|
|
end {esle if}
|
|
else
|
|
Error(44);
|
|
end {if}
|
|
else
|
|
Error(44);
|
|
test := sy <> comma;
|
|
if not test then begin
|
|
InSymbol;
|
|
Variable(fsys + [comma, rparent], fprocp);
|
|
end; {if}
|
|
until test;
|
|
end {if}
|
|
else if not test then begin
|
|
|
|
{do non-text reads}
|
|
repeat
|
|
if glcp <> nil then
|
|
with glcp^ do
|
|
if klass = varsm then begin
|
|
if vcontvar then
|
|
Error(97);
|
|
if vlev <> level then
|
|
vrestrict := true;
|
|
end; {if}
|
|
if gattr.typtr <> nil then
|
|
if (gattr.access<>drct) or
|
|
(gattr.typtr^.form in [arrays,records,files]) then
|
|
LoadAddress;
|
|
tattr := gattr;
|
|
if not CompTypes(gattr.typtr, lattr.typtr^.filtype) then
|
|
if not CompObjects(gattr.typtr, lattr.typtr^.filtype) then
|
|
Error(44);
|
|
gattr := lattr;
|
|
if inLocalPtr then
|
|
Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
|
|
else
|
|
Load;
|
|
with gattr do begin
|
|
typtr := lattr.typtr^.filtype;
|
|
kind := varbl;
|
|
isPacked := false;
|
|
access := indrct;
|
|
idplmt := 0;
|
|
end; {with}
|
|
if gattr.typtr^.form in [scalar,subrange,pointerStruct,power,objects]
|
|
then
|
|
Load
|
|
else
|
|
LoadAddress;
|
|
case tattr.typtr^.form of
|
|
scalar,subrange: begin
|
|
CheckBnds(tattr.typtr);
|
|
Store(tattr);
|
|
end;
|
|
pointerStruct,power,objects:
|
|
Store(tattr);
|
|
arrays,records:
|
|
Gen2(pc_mov, long(tattr.typtr^.size).msw,
|
|
long(tattr.typtr^.size).lsw);
|
|
files: Error(71);
|
|
end; {case}
|
|
|
|
{get the next file variable}
|
|
gattr := lattr;
|
|
if inLocalPtr then
|
|
Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
|
|
else
|
|
Load;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1(pc_csp, 1{get});
|
|
test := sy <> comma;
|
|
if not test then begin
|
|
InSymbol;
|
|
Variable(fsys+[comma,rparent], fprocp);
|
|
end; {if}
|
|
until test;
|
|
end; {else if not test}
|
|
Match(rparent, 4);
|
|
end {if}
|
|
else if lkey = 7{read} then
|
|
Error(44);
|
|
if lkey = 13{readln} then begin
|
|
if standardIn then begin
|
|
Gen0(pc_nop);
|
|
Gen1(pc_csp, 60{rin});
|
|
end {if}
|
|
else begin
|
|
gattr := lattr;
|
|
if inLocalPtr then
|
|
Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
|
|
else
|
|
Load;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1(pc_csp, 13{rln})
|
|
end; {else}
|
|
end; {if}
|
|
end; {DoRead}
|
|
|
|
procedure DoWrite(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to write, writeln}
|
|
|
|
var
|
|
lsp: stp;
|
|
default,defaultr : boolean;
|
|
llkey: keyrange;
|
|
lcp: ctp;
|
|
len: addrrange;
|
|
lattr,tattr: attr;
|
|
test: boolean;
|
|
standardOut,errorOut: boolean; {is the write to the console?}
|
|
llb: unsigned; {for allocating temporary space}
|
|
inLocalPtr: boolean; {is file ptr in local area?}
|
|
|
|
procedure LoadFile;
|
|
{load the file variable}
|
|
|
|
begin {LoadFile}
|
|
gattr := lattr;
|
|
if inLocalPtr then
|
|
Gen3t(pc_lod, gattr.dplab, 0, 0, cgULong)
|
|
else
|
|
Load;
|
|
end; {LoadFile}
|
|
|
|
begin {DoWrite}
|
|
inLocalPtr := false;
|
|
llkey := lkey;
|
|
standardOut := true;
|
|
errorOut := false;
|
|
lattr.typtr := textptr;
|
|
if sy = lparent then begin
|
|
InSymbol;
|
|
Expression(fsys + [comma,colon,rparent],fprocp);
|
|
lsp := gattr.typtr;
|
|
test := false;
|
|
if lsp <> nil then
|
|
if lsp^.form = files then
|
|
with gattr, lsp^ do begin
|
|
if access = indrct then begin
|
|
Load;
|
|
llb := GetTemp(ptrsize);
|
|
Gen3t(pc_str, llb, 0, 0, cgULong);
|
|
gattr.isPacked := false;
|
|
kind := varbl;
|
|
access := drct;
|
|
vlevel := level;
|
|
dplab := llb;
|
|
inLocalPtr := true;
|
|
FreeTemp(llb, ptrsize);
|
|
end;
|
|
lattr := gattr;
|
|
standardOut := glcp = outptr;
|
|
errorOut := glcp = erroroutputptr;
|
|
if (lkey = 14{writeln}) and (typtr <> textptr) then Error(44);
|
|
if sy = rparent then begin
|
|
if llkey = 8{write} then Error(44);
|
|
test := true;
|
|
end
|
|
else if sy <> comma then begin
|
|
Error(44);
|
|
Skip(fsys+[comma,rparent]);
|
|
end;
|
|
if sy = comma then begin
|
|
InSymbol;
|
|
if lattr.typtr = textptr then
|
|
Expression(fsys+[comma,colon,rparent],fprocp);
|
|
end
|
|
else test := true
|
|
end
|
|
else if nooutput then Error(92);
|
|
if lattr.typtr = textptr then begin
|
|
|
|
{text file reads}
|
|
if not test then
|
|
repeat
|
|
lsp := gattr.typtr;
|
|
if lsp^.form = subrange then
|
|
lsp := lsp^.rangetype;
|
|
if lsp <> nil then
|
|
if lsp^.form <= subrange then begin
|
|
Load;
|
|
if (lsp = intptr) or (lsp = byteptr) or (lsp = charptr)
|
|
or (lsp = boolptr) then
|
|
Gen0t(pc_stk, cgWord)
|
|
else if lsp = longptr then
|
|
Gen0t(pc_stk, cgLong)
|
|
else if IsReal(lsp) then
|
|
Gen0t(pc_stk, cgExtended)
|
|
else if lsp <> nil then
|
|
Gen0t(pc_stk, cgULong);
|
|
end {if}
|
|
else begin
|
|
if IsString(gattr.typtr) then
|
|
LoadStringAddress
|
|
else begin
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
end; {else}
|
|
end;
|
|
if sy = colon then begin
|
|
InSymbol;
|
|
Expression(fsys + [comma,colon,rparent],fprocp);
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
|
|
Error(44);
|
|
if debug then
|
|
Gen2t(pc_chk, 0, maxint, cgUWord);
|
|
default := false;
|
|
end
|
|
else default := true;
|
|
if sy = colon then begin
|
|
InSymbol;
|
|
Expression(fsys + [comma,rparent],fprocp);
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then
|
|
Error(44);
|
|
if not IsReal(lsp) then
|
|
Error(50);
|
|
defaultr := false;
|
|
end
|
|
else defaultr := true;
|
|
if (lsp = intptr) or (lsp = byteptr) then begin
|
|
if default then begin
|
|
Gen1t(pc_ldc, intfw, cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {if}
|
|
if standardOut then
|
|
Gen1(pc_csp,16{woi})
|
|
else if errorOut then
|
|
Gen1(pc_csp,42{wei})
|
|
else begin
|
|
LoadFile;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp,9{wri});
|
|
end;
|
|
end
|
|
else if lsp = longptr then begin
|
|
if default then begin
|
|
Gen1t(pc_ldc, longfw, cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {if}
|
|
if standardOut then
|
|
Gen1(pc_csp,100{wol})
|
|
else if errorOut then
|
|
Gen1(pc_csp,101{wel})
|
|
else begin
|
|
LoadFile;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp,102{wrl});
|
|
end;
|
|
end
|
|
else if IsReal(lsp) then begin
|
|
if default then begin
|
|
Gen1t(pc_ldc, realfw, cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {if}
|
|
if defaultr then begin
|
|
Gen1t(pc_ldc, 0, cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {if}
|
|
if standardOut then
|
|
Gen1(pc_csp,62{wor})
|
|
else if errorOut then
|
|
Gen1(pc_csp,53{wer})
|
|
else begin
|
|
LoadFile;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp,10{wrr});
|
|
end; {else}
|
|
end {else if}
|
|
else if lsp = charptr then begin
|
|
if standardOut then
|
|
if default then
|
|
Gen1(pc_csp,40{wol})
|
|
else
|
|
Gen1(pc_csp,37{woc})
|
|
else if errorOut then
|
|
if default then
|
|
Gen1(pc_csp,41{wel})
|
|
else
|
|
Gen1(pc_csp,39{wec})
|
|
else begin
|
|
if default then begin
|
|
Gen1t(pc_ldc, 1, cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {if}
|
|
LoadFile;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp,8{wrc});
|
|
end;
|
|
end
|
|
else if lsp = boolptr then begin
|
|
if default then begin
|
|
Gen1t(pc_ldc, boolfw, cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {if}
|
|
if standardOut then
|
|
Gen1(pc_csp,29{wob})
|
|
else if errorOut then
|
|
Gen1(pc_csp,31{web})
|
|
else begin
|
|
LoadFile;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp,46{wrb});
|
|
end;
|
|
end
|
|
else if lsp <> nil then begin
|
|
if IsString(lsp) then begin
|
|
if default then begin
|
|
Gen1t(pc_ldc, $8000, cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
end; {if}
|
|
if standardOut then
|
|
Gen1(pc_csp,21{wos})
|
|
else if errorOut then
|
|
Gen1(pc_csp,25{wes})
|
|
else begin
|
|
LoadFile;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp,45{wrs});
|
|
end;
|
|
end
|
|
else Error(44);
|
|
end;
|
|
test := sy <> comma;
|
|
if not test then begin
|
|
InSymbol;
|
|
Expression(fsys + [comma,colon,rparent],fprocp)
|
|
end
|
|
until test;
|
|
end
|
|
else if not test then begin
|
|
|
|
{handle non-text files}
|
|
repeat
|
|
{assign the Expression to the file variable}
|
|
LoadFile;
|
|
tattr := gattr;
|
|
with tattr do begin
|
|
typtr := gattr.typtr^.filtype;
|
|
isPacked := false;
|
|
kind := varbl;
|
|
access := indrct;
|
|
idplmt := 0;
|
|
end;
|
|
if debug then
|
|
GenL2t(pc_chk, 1, maxaddr, cgULong);
|
|
Expression(fsys+[comma,colon,rparent],fprocp);
|
|
lsp := gattr.typtr;
|
|
if (lsp^.form <= subrange) or (lsp^.form = objects) then
|
|
Load
|
|
else
|
|
LoadAddress;
|
|
if not CompTypes(lsp,lattr.typtr^.filtype) then
|
|
if not CompObjects(lsp,lattr.typtr^.filtype) then
|
|
Error(44);
|
|
case tattr.typtr^.form of
|
|
scalar,subrange: begin
|
|
CheckBnds(tattr.typtr);
|
|
Store(tattr);
|
|
end;
|
|
pointerStruct,power,objects:
|
|
Store(tattr);
|
|
arrays,records:
|
|
Gen2(pc_mov, long(tattr.typtr^.size).msw, long(tattr.typtr^.size).lsw);
|
|
files: Error(71);
|
|
end; {case}
|
|
{write the file variable to the file}
|
|
LoadFile;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1(pc_csp,2{put});
|
|
test := sy<>comma;
|
|
if not test then InSymbol;
|
|
until test;
|
|
end; {else if not test}
|
|
Match(rparent,4);
|
|
end
|
|
else if lkey = 8{write} then Error(44);
|
|
if lkey = 14{writeln} then begin
|
|
if standardOut then begin
|
|
Gen0(pc_nop);
|
|
Gen1(pc_csp,26{wol});
|
|
end {if}
|
|
else if errorOut then begin
|
|
Gen0(pc_nop);
|
|
Gen1(pc_csp,27{wel});
|
|
end {else if}
|
|
else begin
|
|
LoadFile;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1(pc_csp,14{wln});
|
|
end;
|
|
end;
|
|
end; {DoWrite}
|
|
|
|
procedure DoPack(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to pack}
|
|
|
|
var
|
|
lsp,lsp1: stp;
|
|
elSize: longint; {element size}
|
|
lmin,lmax: longint; {subrange of unpacked array}
|
|
|
|
begin {DoPack}
|
|
{get the unpacked array}
|
|
Variable(fsys + [comma,rparent],fprocp);
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
if gattr.typtr <> nil then
|
|
with gattr.typtr^ do
|
|
if (form = arrays) and (ispacked = pkunpacked) then begin
|
|
Gen1t(pc_ldc, long(aeltype^.size).lsw, cgUWord);
|
|
Gen0t(pc_stk, cgUWord);
|
|
Gen0t(pc_bno, cgUWord);
|
|
GenLdcLong(size div aeltype^.size);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
lsp := inxtype;
|
|
lsp1 := aeltype;
|
|
GetBounds(lsp,lmin,lmax);
|
|
end
|
|
else Error(44);
|
|
Match(comma,20);
|
|
{get the staring index}
|
|
Expression(fsys + [comma,rparent],fprocp);
|
|
Load;
|
|
if CompTypes(longptr, lsp) then
|
|
if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgLong));
|
|
gattr.typtr := longptr;
|
|
end; {end}
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form <> scalar then
|
|
Error(44)
|
|
else if not CompTypes(lsp,gattr.typtr) then
|
|
Error(44);
|
|
if not CompTypes(longptr, gattr.typtr) then begin
|
|
Gen2(pc_cnv, ord(GetType(gattr.typtr, false)), ord(cgLong));
|
|
gattr.typtr := longptr;
|
|
end; {end}
|
|
Match(comma,20);
|
|
if lmin <> 0 then begin
|
|
GenLdcLong(lmin);
|
|
Gen0(pc_sbl);
|
|
end; {if}
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
{get the packed array}
|
|
Variable(fsys + [rparent],fprocp);
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
if gattr.typtr <> nil then
|
|
with gattr.typtr^ do
|
|
if (form = arrays) and (ispacked = pkpacked) then begin
|
|
if not CompTypes(aeltype,lsp1) then Error(44);
|
|
elSize := aelType^.size;
|
|
if (aelType = charptr) or (aelType = boolptr) then
|
|
elSize := packedCharSize;
|
|
Gen1t(pc_ldc, long(elSize).lsw, cgUWord);
|
|
Gen0t(pc_stk, cgUWord);
|
|
Gen0t(pc_bno, cgUWord);
|
|
GenLdcLong(size div elSize);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
end {if}
|
|
else Error(44);
|
|
{move the elements}
|
|
Gen1(pc_csp, 51{pak});
|
|
end; {DoPack}
|
|
|
|
procedure DoUnpack(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to unpack}
|
|
|
|
var
|
|
lsp,lsp1: stp;
|
|
elSize: longint; {element size}
|
|
lmin,lmax: longint; {subrange of unpacked array}
|
|
|
|
begin {DoUnpack}
|
|
Variable(fsys + [comma,rparent],fprocp);
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
if gattr.typtr <> nil then
|
|
with gattr.typtr^ do
|
|
if (form = arrays) and (ispacked = pkpacked) then begin
|
|
elSize := aelType^.size;
|
|
if (aelType = charptr) or (aelType = boolptr) then
|
|
elSize := packedCharSize;
|
|
lsp1 := aeltype;
|
|
Gen1t(pc_ldc, long(elSize).lsw, cgWord);
|
|
Gen0t(pc_stk, cgUWord);
|
|
Gen0t(pc_bno, cgUWord);
|
|
GenLdcLong(size div elSize);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
end
|
|
else Error(44);
|
|
Match(comma,20);
|
|
Variable(fsys + [comma,rparent],fprocp);
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
if gattr.typtr <> nil then
|
|
with gattr.typtr^ do
|
|
if (form = arrays) and (ispacked = pkunpacked) then begin
|
|
if not CompTypes(aeltype,lsp1) then Error(44);
|
|
Gen1t(pc_ldc, long(aeltype^.size).lsw, cgWord);
|
|
Gen0t(pc_stk, cgUWord);
|
|
Gen0t(pc_bno, cgUWord);
|
|
GenLdcLong(size div aeltype^.size);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
lsp := inxtype;
|
|
GetBounds(lsp,lmin,lmax);
|
|
end
|
|
else Error(44);
|
|
Match(comma,20);
|
|
Expression(fsys + [rparent],fprocp);
|
|
Load;
|
|
if CompTypes(longptr, lsp) then
|
|
if (gattr.typtr = intptr) or (gattr.typtr = bytePtr) then begin
|
|
Gen2(pc_cnv, ord(cgWord), ord(cgLong));
|
|
gattr.typtr := longptr;
|
|
end; {end}
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form <> scalar then
|
|
Error(44)
|
|
else if not CompTypes(lsp,gattr.typtr) then
|
|
Error(44);
|
|
if not CompTypes(longptr, gattr.typtr) then begin
|
|
Gen2(pc_cnv, ord(GetType(gattr.typtr, false)), ord(cgLong));
|
|
gattr.typtr := longptr;
|
|
end; {end}
|
|
if lmin <> 0 then begin
|
|
GenLdcLong(lmin);
|
|
Gen0(pc_sbl);
|
|
end; {if}
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp, 52{upk});
|
|
end; {DoUnpack}
|
|
|
|
|
|
procedure DoNew (fsys: setofsys; fprocp: ctp);
|
|
|
|
{ compile a call to new }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
{ fprocp - }
|
|
|
|
label 1;
|
|
|
|
var
|
|
lattr: attr; {pointer/object variable's gattr}
|
|
lsize: addrrange; {amount of memory to allocate}
|
|
lsp,lsp1: stp;
|
|
lval: valu;
|
|
ofld: ctp; {object field list}
|
|
varts: integer;
|
|
|
|
|
|
function InitMethods (lcp: ctp): unsigned;
|
|
|
|
{ Set the address for all methods in a new object }
|
|
{ }
|
|
{ parameters: }
|
|
{ lsp - head of object field tree }
|
|
{ }
|
|
{ returns: Number of methods }
|
|
|
|
var
|
|
count: unsigned;
|
|
|
|
begin {InitMethods}
|
|
count := 0;
|
|
if lcp^.llink <> nil then
|
|
count := InitMethods(lcp^.llink);
|
|
if lcp^.rlink <> nil then
|
|
count := count + InitMethods(lcp^.rlink);
|
|
if lcp^.klass in [proc,func] then begin
|
|
count := count + 1;
|
|
Gen0Name(pc_lad, lcp^.pfoname);
|
|
Gen0t(pc_stk, cgULong);
|
|
GenLdcLong(lcp^.pfaddr);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
end; {if}
|
|
InitMethods := count;
|
|
end; {InitMethods}
|
|
|
|
|
|
begin {DoNew}
|
|
{get the pointer to allocate}
|
|
Variable(fsys + [comma,rparent],fprocp);
|
|
lattr := gattr;
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
|
|
{examine the variable to see how much memory to allocate}
|
|
lsp := nil;
|
|
varts := 0;
|
|
lsize := 0;
|
|
ofld := nil;
|
|
if gattr.typtr <> nil then
|
|
with gattr.typtr^ do
|
|
if form = pointerStruct then begin
|
|
if eltype <> nil then begin
|
|
lsize := eltype^.size;
|
|
if eltype^.form = records then
|
|
lsp := eltype^.recvar;
|
|
end; {if}
|
|
end {if}
|
|
else if (form = objects) and objdef then begin
|
|
lsize := objsize;
|
|
ofld := objfld;
|
|
end {else if}
|
|
else
|
|
Error(44);
|
|
|
|
{handle the variant parts}
|
|
while sy = comma do begin
|
|
InSymbol;
|
|
DoConstant(fsys + [comma,rparent],lsp1,lval);
|
|
varts := varts+1;
|
|
if lsp = nil then
|
|
Error(82)
|
|
else if lsp^.form <> tagfld then
|
|
Error(86)
|
|
else if lsp^.tagfieldp <> nil then
|
|
if CompTypes(lsp^.tagfieldp^.idtype,lsp1) then begin
|
|
lsp1 := lsp^.fstvar;
|
|
while lsp1 <> nil do
|
|
with lsp1^ do
|
|
if varval = lval.ival then begin
|
|
lsize := size;
|
|
lsp := subvar;
|
|
goto 1;
|
|
end {if}
|
|
else
|
|
lsp1 := nxtvar;
|
|
end {if}
|
|
else
|
|
Error(44);
|
|
1: end {while} ;
|
|
|
|
{for objects, set up size, generation, and method addresses}
|
|
if ofld <> nil then begin
|
|
if lattr.typtr <> nil then begin
|
|
Gen1t(pc_ldc, lattr.typtr^.objlevel, cgUWord);
|
|
Gen0t(pc_stk, cgUWord);
|
|
Gen0t(pc_bno, cgUWord);
|
|
end; {if}
|
|
GenLdcLong(lsize);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1t(pc_ldc, InitMethods(ofld), cgUWord);
|
|
Gen0t(pc_stk, cgUWord);
|
|
Gen0t(pc_bno, cgUWord);
|
|
|
|
{generate the call to allocate memory}
|
|
Gen1(pc_csp,118{newobj});
|
|
end {if}
|
|
else if lsize < maxint then begin
|
|
Gen1t(pc_ldc, long(lsize).lsw, cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
Gen1(pc_csp,11{new});
|
|
end {if}
|
|
else begin
|
|
if lsize > $010000 then
|
|
if smallMemoryModel then
|
|
Error(122);
|
|
GenLdcLong(lsize);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp,116{new4});
|
|
end; {else}
|
|
|
|
{if this points to a file, zero the area}
|
|
gattr := lattr;
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form <> objects then
|
|
if gattr.typtr^.hasSFile then begin
|
|
Gen1t(pc_ldc, ord(gattr.typtr^.size), cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Load;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
Gen1(pc_csp,35{clr});
|
|
end; {if}
|
|
end; {DoNew}
|
|
|
|
|
|
procedure DoSizeof;
|
|
{compile a call to sizeof}
|
|
|
|
var
|
|
lcp: ctp;
|
|
|
|
begin {DoSizeof}
|
|
Match(lparent,9);
|
|
SearchId([types,varsm], lcp);
|
|
if lcp^.idtype^.size < maxint then begin
|
|
Gen1t(pc_ldc, ord(lcp^.idtype^.size), cgWord);
|
|
gattr.typtr := intptr;
|
|
end {if}
|
|
else begin
|
|
GenLdcLong(lcp^.idtype^.size);
|
|
gattr.typtr := longptr;
|
|
end; {else}
|
|
InSymbol;
|
|
end; {DoSizeof}
|
|
|
|
|
|
procedure DoDispose (fsys: setofsys; fprocp: ctp);
|
|
|
|
{ Compile a call to dispose }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
{ fprocp - }
|
|
|
|
label 1;
|
|
|
|
var
|
|
lsp,lsp1: stp;
|
|
lval: valu;
|
|
|
|
begin {DoDispose}
|
|
{get the pointer to dispose}
|
|
Expression(fsys+[rparent,comma],fprocp);
|
|
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form = pointerStruct then begin
|
|
{dispose of a pointer}
|
|
Load;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1(pc_csp,17{dsp});
|
|
lsp := nil;
|
|
with gattr.typtr^ do
|
|
if eltype <> nil then
|
|
if eltype^.form = records then
|
|
lsp := eltype^.recvar;
|
|
while sy = comma do begin
|
|
InSymbol;
|
|
DoConstant(fsys+[comma,rparent],lsp1,lval);
|
|
if lsp = nil then Error(82)
|
|
else if lsp^.form <> tagfld then
|
|
Error(86)
|
|
else if lsp^.tagfieldp <> nil then
|
|
if CompTypes(lsp^.tagfieldp^.idtype,lsp1) then begin
|
|
lsp1 := lsp^.fstvar;
|
|
while lsp1 <> nil do
|
|
with lsp1^ do
|
|
if varval = lval.ival then begin
|
|
lsp := subvar;
|
|
goto 1;
|
|
end {if}
|
|
else
|
|
lsp1 := nxtvar;
|
|
lsp := nil;
|
|
end {if}
|
|
else
|
|
Error(44);
|
|
1: end; {while}
|
|
end {if}
|
|
else if gattr.typtr^.form = objects then begin
|
|
{dispose of an object}
|
|
Load;
|
|
if debug then
|
|
GenL2t(pc_chk, 1, maxaddr, cgULong);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1(pc_csp,17{dsp});
|
|
end {else if}
|
|
else
|
|
Error(44);
|
|
end; {DoDispose}
|
|
|
|
procedure Abs;
|
|
{compile an absolute value function call}
|
|
|
|
begin {Abs}
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
|
|
Gen0(pc_abi)
|
|
else if IsReal(gattr.typtr) then
|
|
Gen0(pc_abr)
|
|
else if gattr.typtr = longptr then
|
|
Gen0(pc_abl)
|
|
else begin
|
|
Error(51);
|
|
gattr.typtr := intptr;
|
|
end;
|
|
end; {Abs}
|
|
|
|
procedure Sqr;
|
|
{compile a call to the square function}
|
|
|
|
begin {Sqr}
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
|
|
Gen0(pc_sqi)
|
|
else if IsReal(gattr.typtr) then
|
|
Gen0(pc_sqr)
|
|
else if gattr.typtr = longptr then
|
|
Gen0(pc_sql)
|
|
else begin
|
|
Error(51);
|
|
gattr.typtr := intptr;
|
|
end;
|
|
end; {Sqr}
|
|
|
|
procedure TruncRound;
|
|
{compile trunc and round calls}
|
|
|
|
begin {TruncRound}
|
|
if gattr.typtr <> nil then
|
|
if not IsReal(gattr.typtr) then
|
|
Error(51);
|
|
if lkey = 3{trunc} then begin
|
|
Gen2(pc_cnv,ord(cgReal),ord(cgWord));
|
|
gattr.typtr := intptr;
|
|
end {if}
|
|
else if lkey = 42{trunc4} then begin
|
|
Gen2(pc_cnv,ord(cgReal),ord(cgLong));
|
|
gattr.typtr := longptr;
|
|
end {else if}
|
|
else if lkey = 43{round4} then begin
|
|
Gen0(pc_rn4);
|
|
gattr.typtr := longptr;
|
|
end {else if}
|
|
else begin
|
|
Gen0(pc_rnd);
|
|
gattr.typtr := intptr;
|
|
end; {else}
|
|
end; {TruncRound}
|
|
|
|
procedure DoOdd;
|
|
{compile a call to the odd function}
|
|
|
|
begin {DoOdd}
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
|
|
Gen0(pc_odd)
|
|
else if gattr.typtr = longptr then
|
|
Gen0(pc_odl)
|
|
else
|
|
Error(51);
|
|
gattr.typtr := boolptr;
|
|
end; {DoOdd}
|
|
|
|
procedure DoOrd;
|
|
{compile the ord function}
|
|
|
|
begin {DoOrd}
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form > pointerStruct then
|
|
Error(51)
|
|
else if (gattr.typtr^.form = pointerStruct) or (gattr.typtr = longptr) then
|
|
begin
|
|
if iso then Error(112);
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgWord));
|
|
end
|
|
else if not (GetType(gattr.typtr, gattr.isPacked)
|
|
in [cgByte,cgUByte,cgWord,cgUWord]) then
|
|
Error(51);
|
|
gattr.typtr := intptr;
|
|
end; {DoOrd}
|
|
|
|
procedure DoOrd4;
|
|
|
|
{ compile the ord4 function }
|
|
|
|
begin {DoOrd4}
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form > pointerStruct then
|
|
Error(51)
|
|
else if GetType(gattr.typtr, gattr.isPacked)
|
|
in [cgByte,cgUByte,cgWord,cgUWord] then
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgLong))
|
|
else if not (GetType(gattr.typtr, gattr.isPacked) in [cgLong,cgULong]) then
|
|
Error(51);
|
|
gattr.typtr := longptr;
|
|
end; {DoOrd4}
|
|
|
|
procedure DoPointer;
|
|
{compile the Pointer function}
|
|
|
|
begin {DoPointer}
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form > pointerStruct then
|
|
Error(51)
|
|
else if (gattr.typtr^.form <> pointerStruct) and (gattr.typtr <> longptr)
|
|
then
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgLong));
|
|
{else the value is already 4 bytes}
|
|
gattr.typtr := nilptr;
|
|
end; {DoPointer}
|
|
|
|
procedure DoChr;
|
|
{compile a call to the chr function}
|
|
|
|
begin {DoChr}
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(51);
|
|
{gen0(59( chr ));}
|
|
gattr.typtr := charptr;
|
|
end; {DoChr}
|
|
|
|
procedure PredSucc;
|
|
{compile a call to pred or succ}
|
|
|
|
begin {PredSucc}
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr^.form <> scalar) or IsReal(gattr.typtr) then
|
|
Error(51);
|
|
if lkey = 8{pred} then
|
|
Gen1t(pc_dec, 1, GetType(gattr.typtr, gattr.isPacked))
|
|
else
|
|
Gen1t(pc_inc, 1, GetType(gattr.typtr, gattr.isPacked));
|
|
CheckBnds(gattr.typtr);
|
|
end; {PredSucc}
|
|
|
|
procedure DoEOF (fsys: setofsys; fprocp: ctp);
|
|
|
|
{ compile a call to eof or eoln }
|
|
{ }
|
|
{ Parameters: }
|
|
{ fsys - }
|
|
{ fprocp - }
|
|
|
|
begin {DoEOF}
|
|
if sy = lparent then begin
|
|
|
|
{handle a call for a given file}
|
|
InSymbol;
|
|
Variable(fsys + [rparent],fprocp);
|
|
Match(rparent,4);
|
|
if lkey = 11{eoln} then
|
|
if gattr.typtr <> textptr then
|
|
Error(44);
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr^.form <> files then
|
|
Error(51);
|
|
if glcp = inptr then
|
|
if lkey=10{eof} then
|
|
Gen1tName(pc_ldo, 0, cgUWord, @'~EOFINPUT')
|
|
else
|
|
Gen1tName(pc_ldo, 0, cgUWord, @'~EOLNINPUT')
|
|
else begin
|
|
Load;
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1t(pc_csp, 38+lkey{eof,eol}, cgUByte);
|
|
end; {else}
|
|
end {if}
|
|
else begin
|
|
|
|
{handle a call for standard in}
|
|
if noinput then
|
|
Error(91);
|
|
Gen0(pc_nop);
|
|
Gen1t(pc_csp, 175+lkey{eof,eol}, cgUByte);
|
|
end; {else}
|
|
gattr.typtr := boolptr;
|
|
end; {DoEOF}
|
|
|
|
|
|
procedure trans;
|
|
{compile transendental functions}
|
|
|
|
var
|
|
tkey: keyrange; {so we can change the number}
|
|
|
|
begin {trans}
|
|
tkey := lkey;
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
|
|
gen2(pc_cnv,ord(cgWord),ord(cgReal));
|
|
gattr.typtr := realptr;
|
|
end
|
|
else if gattr.typtr = longptr then begin
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgReal));
|
|
gattr.typtr := realptr;
|
|
end;
|
|
if not IsReal(gattr.typtr) then
|
|
Error(59);
|
|
case tkey of
|
|
12: Gen0(pc_sin);
|
|
13: Gen0(pc_cos);
|
|
14: Gen0(pc_exp);
|
|
15: Gen0(pc_sqt);
|
|
16: Gen0(pc_log);
|
|
17: Gen0(pc_atn);
|
|
36: Gen0(pc_tan);
|
|
37: Gen0(pc_acs);
|
|
38: Gen0(pc_asn);
|
|
otherwise:
|
|
Error(113);
|
|
end; {case}
|
|
end; {trans}
|
|
|
|
procedure DoArctan2(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to Arctan2}
|
|
|
|
begin {DoArctan2}
|
|
Match(lparent,9);
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
Load;
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
|
|
gen2(pc_cnv,ord(cgWord),ord(cgReal));
|
|
gattr.typtr := realptr;
|
|
end
|
|
else if gattr.typtr = longptr then begin
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgReal));
|
|
gattr.typtr := realptr;
|
|
end;
|
|
if not IsReal(gattr.typtr) then
|
|
Error(59);
|
|
Match(comma,20);
|
|
Expression(fsys+[rparent],fprocp);
|
|
Load;
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
|
|
gen2(pc_cnv,ord(cgWord),ord(cgReal));
|
|
gattr.typtr := realptr;
|
|
end
|
|
else if gattr.typtr = longptr then begin
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgReal));
|
|
gattr.typtr := realptr;
|
|
end;
|
|
if not IsReal(gattr.typtr) then
|
|
Error(59);
|
|
Gen0(pc_at2);
|
|
end; {DoArctan2}
|
|
|
|
procedure DoUserID;
|
|
{compile a call to UserID}
|
|
|
|
begin {DoUserID}
|
|
Gen1tName(pc_ldo, 0, cgUWord, @'~USER_ID');
|
|
gattr.typtr := intptr;
|
|
end; {DoUserID}
|
|
|
|
procedure ToolError;
|
|
{compile a call to tollerror}
|
|
|
|
begin {ToolError}
|
|
Gen1tName(pc_ldo, 0, cgUWord, @'~TOOLERROR');
|
|
gattr.typtr := intptr;
|
|
end; {ToolError}
|
|
|
|
procedure Cnvfs(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to Cnvrs or Cnvds}
|
|
|
|
begin {Cnvfs}
|
|
{load the value to convert}
|
|
Match(lparent,9);
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
Load;
|
|
if gattr.typtr <> nil then
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then begin
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgReal));
|
|
gattr.typtr := realptr;
|
|
end
|
|
else if (gattr.typtr = longptr) then begin
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgReal));
|
|
gattr.typtr := realptr;
|
|
end;
|
|
if not IsReal(gattr.typtr) then
|
|
Error(59);
|
|
Gen0t(pc_stk, cgExtended);
|
|
{load the two required field widths}
|
|
Match(comma,20);
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
if gattr.typtr <> nil then begin
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
|
|
end
|
|
else Error(44);
|
|
Match(comma,20);
|
|
Expression(fsys+[rparent],fprocp);
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
if gattr.typtr <> nil then begin
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
|
|
end
|
|
else Error(44);
|
|
Gen1t(pc_csp,77{cfs},cgString);
|
|
gattr.typtr := stringptr;
|
|
gattr.kind := expr;
|
|
stringHeap := true;
|
|
end; {Cnvfs}
|
|
|
|
procedure Cnvis;
|
|
{compile a call to Cnvis}
|
|
|
|
begin {Cnvis}
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgLong))
|
|
else if gattr.typtr <> longptr then Error(44);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen1t(pc_csp,78{cis},cgString);
|
|
gattr.typtr := stringptr;
|
|
gattr.kind := expr;
|
|
stringHeap := true;
|
|
end; {Cnvis}
|
|
|
|
procedure CnvSF(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to CnvSR or CnvSD}
|
|
|
|
begin {Cnvsf}
|
|
Match(lparent,9);
|
|
Expression(fsys+[rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then
|
|
LoadStringAddress
|
|
else Error(44)
|
|
else Error(44);
|
|
gattr.typtr := realptr;
|
|
Gen1t(pc_csp,79{csf},cgReal);
|
|
end; {Cnvsf}
|
|
|
|
procedure CnvSI(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to CnvSI}
|
|
|
|
begin {Cnvsi}
|
|
Match(lparent,9);
|
|
Expression(fsys+[rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then
|
|
LoadStringAddress
|
|
else Error(44)
|
|
else Error(44);
|
|
gattr.typtr := intptr;
|
|
Gen1t(pc_csp,80{csi},cgWord);
|
|
end; {Cnvsi}
|
|
|
|
procedure CnvSL(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to CnvSL}
|
|
|
|
begin {Cnvsl}
|
|
Match(lparent,9);
|
|
Expression(fsys+[rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then
|
|
LoadStringAddress
|
|
else Error(44)
|
|
else Error(44);
|
|
gattr.typtr := longptr;
|
|
Gen1t(pc_csp,81{csl},cgLong);
|
|
end; {Cnvsl}
|
|
|
|
procedure Randomf;
|
|
{generate a random real or double}
|
|
|
|
begin {Randomf}
|
|
Gen0(pc_nop);
|
|
gattr.typtr := realptr;
|
|
Gen1t(pc_csp,82{rnf},cgReal);
|
|
end; {Randomf}
|
|
|
|
procedure RandomInteger;
|
|
{generate a random integer}
|
|
|
|
begin {RandomInteger}
|
|
Gen0(pc_nop);
|
|
gattr.typtr := intptr;
|
|
Gen1t(pc_csp,83{rni},cgWord);
|
|
end; {RandomInteger}
|
|
|
|
procedure RandomLongInt;
|
|
{generate a random longint}
|
|
|
|
begin {RandomLongInt}
|
|
Gen0(pc_nop);
|
|
gattr.typtr := longptr;
|
|
Gen1t(pc_csp,83{rni},cgLong);
|
|
end; {RandomLongint}
|
|
|
|
procedure Concat(fsys: setofsys; fprocp: ctp);
|
|
{concatonate a series of strings}
|
|
|
|
var
|
|
numStrings: integer; {# of strings to concatonate}
|
|
stop: boolean; {loop termination var}
|
|
|
|
begin {Concat}
|
|
stringHeap := true;
|
|
numStrings := 0;
|
|
{mark stack so parameters are tagged}
|
|
{load the strings}
|
|
Match(lparent,9);
|
|
repeat
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then
|
|
LoadStringAddress
|
|
else if gattr.typtr = charptr then begin
|
|
Load;
|
|
Gen0t(pc_stk, cgUWord);
|
|
GenLdcLong(-1);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
end
|
|
else Error(44)
|
|
else Error(44);
|
|
stop := sy <> comma;
|
|
if not stop then InSymbol;
|
|
numStrings := numStrings+1;
|
|
if numStrings <> 1 then
|
|
Gen0t(pc_bno, cgULong);
|
|
until stop or eofl;
|
|
Match(rparent,4);
|
|
Gen1t(pc_ldc, numStrings, cgWord);
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
{call the concat function}
|
|
Gen1t(pc_csp,85{cat},cgString);
|
|
gattr.typtr := stringptr;
|
|
gattr.kind := expr;
|
|
end; {Concat}
|
|
|
|
procedure Copy(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to copy characters from a string}
|
|
|
|
begin {Copy}
|
|
stringHeap := true;
|
|
{load the string to copy characters from}
|
|
Match(lparent,9);
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then
|
|
LoadStringAddress
|
|
else Error(44)
|
|
else Error(44);
|
|
{load the index}
|
|
Match(comma,20);
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
if gattr.typtr <> nil then begin
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
|
|
end
|
|
else Error(44);
|
|
{load the number of chars to copy}
|
|
Match(comma,20);
|
|
Expression(fsys+[rparent],fprocp);
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
Gen0t(pc_bno, cgWord);
|
|
if gattr.typtr <> nil then begin
|
|
if (gattr.typtr <> intptr) and (gattr.typtr <> byteptr) then Error(44);
|
|
end
|
|
else Error(44);
|
|
{call the copy function}
|
|
Gen1t(pc_csp,86{cpy},cgString);
|
|
gattr.typtr := stringptr;
|
|
gattr.kind := expr;
|
|
end; {Copy}
|
|
|
|
procedure DoLength(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to Length}
|
|
|
|
begin {DoLength}
|
|
{load the string}
|
|
Match(lparent,9);
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then
|
|
LoadStringAddress
|
|
else if gattr.typtr = charptr then begin
|
|
Load;
|
|
Gen0t(pc_stk, cgUWord);
|
|
GenLdcLong(-1);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
end
|
|
else Error(44)
|
|
else Error(44);
|
|
gattr.typtr := intptr;
|
|
Gen1t(pc_csp,87{lgt},cgWord);
|
|
end; {DoLength}
|
|
|
|
procedure Pos(fsys: setofsys; fprocp: ctp);
|
|
{compile a call to find the position of one string in another}
|
|
|
|
begin {Pos}
|
|
{load the strings}
|
|
Match(lparent,9);
|
|
Expression(fsys+[comma,rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then
|
|
LoadStringAddress
|
|
else if gattr.typtr = charptr then begin
|
|
Load;
|
|
Gen0t(pc_stk, cgUWord);
|
|
GenLdcLong(-1);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
end
|
|
else Error(44)
|
|
else Error(44);
|
|
Match(comma,20);
|
|
Expression(fsys+[rparent],fprocp);
|
|
if gattr.typtr <> nil then
|
|
if IsString(gattr.typtr) then
|
|
LoadStringAddress
|
|
else if gattr.typtr = charptr then begin
|
|
Load;
|
|
Gen0t(pc_stk, cgUWord);
|
|
GenLdcLong(-1);
|
|
Gen0t(pc_stk, cgULong);
|
|
Gen0t(pc_bno, cgULong);
|
|
end
|
|
else Error(44)
|
|
else Error(44);
|
|
Gen0t(pc_bno, cgWord);
|
|
{call the pos function}
|
|
Gen1t(pc_csp,88{pos},cgWord);
|
|
gattr.typtr := intptr;
|
|
end; {Pos}
|
|
|
|
|
|
procedure DoMember (fsys: setofsys; fprocp: ctp);
|
|
|
|
{ Compile a call to the member function }
|
|
{ }
|
|
{ paremeters: }
|
|
{ fsys - follow symbols }
|
|
{ fprocp - identifier for program or program-level }
|
|
{ subroutine contining this statement }
|
|
|
|
var
|
|
lcp: ctp; {work identifier}
|
|
|
|
begin {DoMember}
|
|
Match(lparent, 9);
|
|
Expression(fsys+[comma], fprocp);
|
|
Load;
|
|
Match(comma,20);
|
|
if sy = ident then begin
|
|
SearchId([types], lcp);
|
|
InSymbol;
|
|
if lcp <> nil then
|
|
if lcp^.idtype <> nil then
|
|
if gattr.typtr <> nil then begin
|
|
Gen0t(pc_stk, cgULong);
|
|
if CompObjects(lcp^.idtype, gattr.typtr) then
|
|
Gen1t(pc_ldc, lcp^.idtype^.objlevel, cgUWord)
|
|
else
|
|
Gen1t(pc_ldc, 0, cgUWord);
|
|
Gen0t(pc_stk, cgUWord);
|
|
Gen0t(pc_bno, cgUWord);
|
|
Gen1t(pc_csp, 117{mbr}, cgUWord);
|
|
end; {if}
|
|
end {if}
|
|
else
|
|
Error(2);
|
|
gattr.typtr := boolptr;
|
|
end; {DoMember}
|
|
|
|
{-- Externally available subroutines ------------------------------------------}
|
|
|
|
procedure Call {fsys: setofsys; fcp,fprocp: ctp};
|
|
|
|
{ generate a call to a procedure or function }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - follow symbols }
|
|
{ fcp - }
|
|
{ fprocp - }
|
|
|
|
var
|
|
tkey: keyrange; {for saving lkey on recursive fn calls}
|
|
|
|
begin {Call}
|
|
tkey := lkey;
|
|
if fcp^.pfdeckind = standard then begin
|
|
lkey := fcp^.key;
|
|
if fcp^.klass = proc then begin
|
|
|
|
{compile standard procedure calls}
|
|
if iso then
|
|
if lkey in [3,4,12,16,18..29] then
|
|
Error(112);
|
|
if not(lkey in [7,8,13..15,28,29]) then
|
|
Match(lparent,9);
|
|
case lkey of
|
|
1,2,4: getputclose(fsys,fprocp);
|
|
3,5,6: resetrewriteopen(fsys,fprocp);
|
|
7,13: DoRead(fsys,fprocp);
|
|
8,14: DoWrite(fsys,fprocp);
|
|
9: DoPack(fsys,fprocp);
|
|
10: DoUnpack(fsys,fprocp);
|
|
11: DoNew(fsys,fprocp);
|
|
17: DoDispose(fsys,fprocp);
|
|
15: page(fsys,fprocp);
|
|
19: seek(fsys,fprocp);
|
|
20,21: HaltSeed(fsys,fprocp);
|
|
22: Delete(fsys,fprocp);
|
|
23: Insert(fsys,fprocp);
|
|
24,25: CommandLineShellID(fsys,fprocp);
|
|
26,27: StartGraphDesk(fsys,fprocp);
|
|
28,29: EndGraphDesk;
|
|
end; {case}
|
|
if not(lkey in [7,8,13..15,28,29]) then
|
|
Match(rparent,4);
|
|
end
|
|
else begin
|
|
|
|
{compile standard function calls}
|
|
if iso then
|
|
if lkey in [18..44] then
|
|
Error(112);
|
|
if not(lkey in [10,11,19,21..34,39..41,44]) then begin
|
|
Match(lparent, 9);
|
|
Expression(fsys+[rparent], fprocp);
|
|
Load;
|
|
end; {if}
|
|
case lkey of
|
|
1: abs;
|
|
2: sqr;
|
|
3,4,42,43: truncround;
|
|
5: DoOdd;
|
|
6: DoOrd;
|
|
7: DoChr;
|
|
8,9: predsucc;
|
|
10,11: DoEOF(fsys,fprocp);
|
|
12,13,14,15,16,17,36,37,38: trans;
|
|
18: DoOrd4;
|
|
19,32: Cnvfs(fsys,fprocp);
|
|
20: Cnvis;
|
|
21,33: Cnvsf(fsys,fprocp);
|
|
22: Cnvsi(fsys,fprocp);
|
|
23: Cnvsl(fsys,fprocp);
|
|
24,31: Randomf;
|
|
25: RandomInteger;
|
|
26: RandomLongInt;
|
|
27: Concat(fsys,fprocp);
|
|
28: Copy(fsys,fprocp);
|
|
29: DoLength(fsys,fprocp);
|
|
30: Pos(fsys,fprocp);
|
|
34: DoUserID;
|
|
35: DoPointer;
|
|
39: DoArctan2(fsys,fprocp);
|
|
40: ToolError;
|
|
41: DoSizeof;
|
|
44: DoMember(fsys, fprocp);
|
|
end;
|
|
if not (lkey in [10,11,24..27,31,34,40]) then
|
|
Match(rparent,4);
|
|
end;
|
|
end {else}
|
|
else
|
|
CallNonStandard(fsys, fcp, fprocp, 0, cStandard);
|
|
lkey := tkey;
|
|
end; {Call}
|
|
|
|
|
|
procedure CallNonStandard {fsys: setofsys; fcp,fprocp: ctp; odisp: longint;
|
|
callKind: callKinds};
|
|
|
|
{ Handle a call to a user defined procedure/function }
|
|
{ }
|
|
{ parameters: }
|
|
{ fsys - }
|
|
{ fcp - }
|
|
{ fprocp - }
|
|
{ odisp - disp in object for method calls; else 0 }
|
|
{ callKind - type of this call }
|
|
|
|
label 1,2,3;
|
|
|
|
var
|
|
nxt,lcp: ctp;
|
|
lattr: attr; {for forming fake parm types}
|
|
lsp: stp;
|
|
i: integer;
|
|
typeNum: baseTypeEnum;
|
|
pcount: unsigned; {number of parameters processed}
|
|
|
|
|
|
procedure CheckParm (lcp1,lcp2: ctp);
|
|
|
|
{ insure that the parm list matches the definition }
|
|
{ }
|
|
{ parameters: }
|
|
{ lcp1, lcp2 - parameter lists to check }
|
|
|
|
label 1;
|
|
|
|
begin {CheckParm}
|
|
if lcp1 = nil then begin
|
|
if lcp2 <> nil then Error(52);
|
|
end
|
|
else begin
|
|
while lcp1 <> nil do begin
|
|
if lcp2 = nil then begin Error(52); goto 1; end;
|
|
if (lcp1^.idtype <> lcp2^.idtype) or (lcp1^.klass<>lcp2^.klass)
|
|
then begin Error(59); goto 1; end
|
|
else begin
|
|
if lcp1^.klass = varsm then begin
|
|
if (lcp1^.vkind <> lcp2^.vkind) or
|
|
(lcp1^.vitem <> lcp2^.vitem) then
|
|
begin Error(59); goto 1; end
|
|
end
|
|
else {lcp1^.klass = proc or func} begin
|
|
CheckParm(lcp1^.pfnext,lcp2^.pfnext);
|
|
if lcp1^.klass = func then
|
|
if lcp1^.idtype <> lcp2^.idtype then Error(53);
|
|
end;
|
|
end;
|
|
lcp1 := lcp1^.next;
|
|
lcp2 := lcp2^.next;
|
|
end;
|
|
if lcp2 <> nil then begin Error(52); goto 1; end;
|
|
end;
|
|
1: end; {CheckParm}
|
|
|
|
|
|
begin {CallNonStandard}
|
|
{get the head of the parameter list; preload indirect call addresses}
|
|
with fcp^ do
|
|
if pfkind = formal then begin
|
|
nxt := pfnext;
|
|
if callKind = cStandard then begin
|
|
Gen3t(pc_lod, pflabel, 0, level-pflev, cgULong);
|
|
Gen3t(pc_lod, pflabel, 4, level-pflev, cgUWord);
|
|
Gen0t(pc_bno, cgUWord);
|
|
end; {if}
|
|
end {if}
|
|
else begin
|
|
nxt := pfparms;
|
|
if callKind <> cStandard then
|
|
nxt := nxt^.next; {skip SELF}
|
|
end; {else}
|
|
|
|
{for methods, the 'SELF' parameter has already been pushed}
|
|
if callKind in [cMethod,cInherited] then
|
|
pcount := 1
|
|
else
|
|
pcount := 0;
|
|
|
|
{compile the call's parameter list}
|
|
if sy = lparent then begin
|
|
repeat
|
|
InSymbol;
|
|
{check for too many parms}
|
|
if nxt = nil then begin
|
|
Error(52);
|
|
goto 1;
|
|
end;
|
|
{handle procs and funcs in parm list}
|
|
if nxt^.klass in [proc,func] then begin
|
|
if sy <> ident then begin
|
|
Error(2);
|
|
Skip(fsys + [comma,rparent]);
|
|
end
|
|
else begin
|
|
if nxt^.klass = proc then
|
|
SearchId([proc],lcp)
|
|
else begin
|
|
SearchId([func],lcp);
|
|
if lcp^.idtype <> nxt^.idtype then
|
|
Error(53);
|
|
end; {else}
|
|
if lcp <> nil then with lcp^ do begin
|
|
if pfkind = formal then begin
|
|
CheckParm(pfnext,nxt^.pfnext);
|
|
Gen3t(pc_lod, pflabel, 4, level-pflev, cgUWord);
|
|
Gen0t(pc_stk, cgUWord);
|
|
if pcount <> 0 then
|
|
Gen0t(pc_bno, cgUWord);
|
|
pcount := pcount+1;
|
|
Gen3t(pc_lod, pflabel, 0, level-pflev, cgULong);
|
|
end {if}
|
|
else begin
|
|
CheckParm(pfparms, nxt^.pfnext);
|
|
Gen1(pc_lsl, level-pflev);
|
|
Gen0t(pc_stk, cgUWord);
|
|
if pcount <> 0 then
|
|
Gen0t(pc_bno, cgUWord);
|
|
pcount := pcount+1;
|
|
if pflev = 1 then
|
|
Gen0Name(pc_lad,lcp^.name)
|
|
else
|
|
Gen1(pc_lla, pfname);
|
|
end;
|
|
Gen0t(pc_stk, cgULong);
|
|
end;
|
|
InSymbol;
|
|
if not (sy in fsys + [comma,rparent]) then begin
|
|
Error(6);
|
|
Skip(fsys + [comma,rparent]);
|
|
end;
|
|
end;
|
|
goto 2;
|
|
end;
|
|
{handle expressions in parm list}
|
|
if sy = stringConst then
|
|
if nxt <> nil then
|
|
if nxt^.vkind = actual then
|
|
if IsString(nxt^.idtype) then begin
|
|
if StrLen(nxt^.idtype) < 0 then
|
|
LoadString(lengthString)
|
|
else
|
|
LoadString(nullString);
|
|
InSymbol;
|
|
goto 3;
|
|
end; {if}
|
|
1: Expression(fsys + [comma,rparent],fprocp);
|
|
3: if gattr.typtr <> nil then
|
|
if nxt <> nil then begin
|
|
lsp := nxt^.idtype;
|
|
if lsp <> nil then begin
|
|
if (nxt^.vkind = actual) then begin
|
|
if lsp^.form <= power then begin
|
|
if gattr.typtr^.form <= power then
|
|
Load
|
|
else
|
|
LoadAddress;
|
|
CheckBnds(lsp);
|
|
if IsReal(lsp) then begin
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
|
|
begin
|
|
Gen2(pc_cnv,ord(cgWord),ord(cgExtended));
|
|
gattr.typtr := realptr;
|
|
end
|
|
else if gattr.typtr = longptr then begin
|
|
Gen2(pc_cnv,ord(cgLong),ord(cgExtended));
|
|
gattr.typtr := realptr;
|
|
end;
|
|
end
|
|
else if lsp = longptr then begin
|
|
if (gattr.typtr = intptr) or (gattr.typtr = byteptr) then
|
|
begin
|
|
Gen2(pc_cnv, ord(cgWord), ord(cgLong));
|
|
gattr.typtr := longptr;
|
|
end;
|
|
end {else if}
|
|
else if nxt^.vuniv then
|
|
if ParmSize(lsp, actual) = 4 then
|
|
if ParmSize(gattr.typtr, actual) = 2 then begin
|
|
Gen2(pc_cnv, ord(cgWord), ord(cgLong));
|
|
gattr.typtr := longptr;
|
|
end; {if}
|
|
case GetType(gattr.typtr, gattr.isPacked) of
|
|
cgByte,cgUByte,cgWord,cgUWord:
|
|
Gen0t(pc_stk, cgWord);
|
|
cgLong,cgULong,cgString:
|
|
Gen0t(pc_stk, cgLong);
|
|
cgReal,cgDouble,cgComp,cgExtended:
|
|
Gen0t(pc_stk, cgExtended);
|
|
cgSet:
|
|
Gen1(pc_siz, ord(lsp^.size));
|
|
otherwise: ;
|
|
end; {case}
|
|
end
|
|
else if gattr.typtr^.form = objects then begin
|
|
Load;
|
|
if debug then
|
|
GenL2t(pc_chk, 1, maxaddr, cgULong);
|
|
Gen0t(pc_stk, cgULong);
|
|
end {else if}
|
|
else if gattr.typtr^.form = records then begin
|
|
{value records <= 4 bytes passed by value; otherwise }
|
|
{ pass an address }
|
|
if gattr.typtr^.size <= 4 then
|
|
if gattr.typtr^.size <= 2 then begin
|
|
lattr := gattr;
|
|
gattr.typtr := intptr;
|
|
Load;
|
|
Gen0t(pc_stk, cgWord);
|
|
gattr := lattr;
|
|
end {if}
|
|
else begin
|
|
lattr := gattr;
|
|
gattr.typtr := longptr;
|
|
Load;
|
|
Gen0t(pc_stk, cgLong);
|
|
gattr := lattr;
|
|
end {else}
|
|
else begin
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
end;
|
|
end {else if}
|
|
else if IsString(lsp) then begin
|
|
if gattr.kind = expr then begin
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
if StrLen(lsp) < 0 then
|
|
Gen1t(pc_csp, 119{fxp}, cgULong)
|
|
else
|
|
Gen1t(pc_csp, 120{fxc}, cgULong);
|
|
end {if}
|
|
else
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
end {else if}
|
|
else begin
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
end; {else}
|
|
if not CompTypes(lsp,gattr.typtr) then
|
|
if (ParmSize(lsp,actual) <> ParmSize(gattr.typtr,actual)) then
|
|
Error(67);
|
|
end
|
|
else begin
|
|
if lsp <> gattr.typtr then
|
|
if not nxt^.vuniv then
|
|
Error(67);
|
|
if gattr.kind = varbl then begin
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
end {if}
|
|
else
|
|
Error(78);
|
|
if glcp <> nil then with glcp^ do begin
|
|
if klass = varsm then begin
|
|
if vcontvar then Error(97);
|
|
if vlev <> level then vrestrict := true;
|
|
end
|
|
else if klass = field then
|
|
if fldvar then Error(95);
|
|
end;
|
|
if gispacked then Error(95);
|
|
end;
|
|
end
|
|
end;
|
|
2: {next parm in definition}
|
|
if nxt <> nil then
|
|
nxt := nxt^.next;
|
|
if pcount <> 0 then
|
|
Gen0t(pc_bno, cgWord);
|
|
pcount := pcount+1;
|
|
until sy <> comma;
|
|
Match(rparent,4);
|
|
end; {if}
|
|
if pcount = 0 then
|
|
Gen0(pc_nop);
|
|
|
|
{check for not enough parameters}
|
|
if nxt <> nil then
|
|
Error(52);
|
|
|
|
{generate the call}
|
|
with fcp^ do begin
|
|
if klass <> func then
|
|
typeNum := cgVoid
|
|
else begin
|
|
if idtype = realptr then
|
|
typeNum := cgReal
|
|
else if idtype = doubleptr then
|
|
typeNum := cgDouble
|
|
else if idtype = compptr then
|
|
typeNum := cgComp
|
|
else if idtype = extendedptr then
|
|
typeNum := cgExtended
|
|
else if idtype = longptr then
|
|
typeNum := cgLong
|
|
else if idtype^.form = pointerStruct then
|
|
typeNum := cgULong
|
|
else
|
|
typeNum := cgWord;
|
|
end; {else}
|
|
if callKind = cMethod then
|
|
GenL1t(pc_cum, odisp, typeNum)
|
|
else if pfkind = formal then
|
|
Gen0t(pc_cui, typeNum)
|
|
else {if pfkind = actual then}
|
|
case pfdirective of
|
|
drnone,drforw,drextern: {standard calls}
|
|
if pflev = 1 then
|
|
Gen1tName(pc_cup, level-pflev, typeNum, fcp^.pfoname)
|
|
else
|
|
Gen2t(pc_cup, pfname, level-pflev, typeNum);
|
|
drprodos: {in line prodos call}
|
|
Gen1(pc_pds, pfcallnum);
|
|
drtool1,drtool2,drvector: begin {in line tool call with passed parms}
|
|
if pfdirective = drtool1 then
|
|
Gen2t(pc_tl1, pftoolnum, pfcallnum, typeNum)
|
|
else if pfdirective = drtool2 then
|
|
Gen2t(pc_tl2, pftoolnum, pfcallnum, typeNum)
|
|
else
|
|
Gen1L1t(pc_vct, pfcallnum, pfaddr, typeNum);
|
|
if klass = func then
|
|
if idtype = boolptr then begin
|
|
Gen1t(pc_ldc, 0, cgWord);
|
|
Gen0t(pc_neq, cgWord);
|
|
end; {if}
|
|
end;
|
|
end; {case}
|
|
end;
|
|
{for functions, set the return type}
|
|
gattr.typtr := fcp^.idtype
|
|
end; {CallNonStandard}
|
|
|
|
|
|
procedure CheckBool;
|
|
{load a value, insuring that it is boolean}
|
|
|
|
begin {CheckBool}
|
|
load;
|
|
if gattr.typtr <> nil then
|
|
if gattr.typtr <> boolptr then Error(60);
|
|
end; {CheckBool}
|
|
|
|
procedure CheckBnds{fsp: stp};
|
|
{generate range checking code (if needed)}
|
|
|
|
var
|
|
lmin,lmax: integer;
|
|
|
|
begin {CheckBnds}
|
|
if debug then
|
|
if fsp <> nil then
|
|
if fsp = charptr then
|
|
Gen2t(pc_chk, ordminchar, ordmaxchar, cgUWord)
|
|
else if fsp^.form = subrange then
|
|
if fsp^.rangetype = longptr then
|
|
GenL2t(pc_chk, fsp^.min, fsp^.max, cgULong)
|
|
else
|
|
Gen2t(pc_chk, long(fsp^.min).lsw, long(fsp^.max).lsw, cgUWord);
|
|
end; {CheckBnds}
|
|
|
|
|
|
procedure FreeTemp{labelNum, size: integer};
|
|
|
|
{ place a temporary label in the available label list }
|
|
{ }
|
|
{ parameters: }
|
|
{ labelNum - number of the label to free }
|
|
{ size - size of the variable }
|
|
{ }
|
|
{ variables: }
|
|
{ tempList - list of free labels }
|
|
|
|
var
|
|
tl: tempPtr; {work pointer}
|
|
|
|
begin {FreeTemp}
|
|
new(tl);
|
|
tl^.next := tempList;
|
|
tl^.last := nil;
|
|
tl^.labelNum := labelNum;
|
|
tl^.size := size;
|
|
if tempList <> nil then
|
|
tempList^.last := tl;
|
|
tempList := tl;
|
|
end; {FreeTemp}
|
|
|
|
|
|
function GetTemp{size: integer): integer};
|
|
|
|
{ find a temporary work variable }
|
|
{ }
|
|
{ parameters: }
|
|
{ size - size of the variable }
|
|
{ }
|
|
{ variables: }
|
|
{ tempList - list of free labels }
|
|
{ }
|
|
{ Returns the label number. }
|
|
|
|
label 1;
|
|
|
|
var
|
|
ln: integer; {label number}
|
|
tl: tempPtr; {work pointer}
|
|
|
|
begin {GetTemp}
|
|
{try to find a temp from the existing list}
|
|
tl := tempList;
|
|
while tl <> nil do begin
|
|
if tl^.size = size then begin
|
|
|
|
{found an old one - use it}
|
|
if tl^.last = nil then
|
|
tempList := tl^.next
|
|
else
|
|
tl^.last^.next := tl^.next;
|
|
if tl^.next <> nil then
|
|
tl^.next^.last := tl^.last;
|
|
GetTemp := tl^.labelNum;
|
|
goto 1;
|
|
end; {if}
|
|
tl := tl^.next;
|
|
end; {while}
|
|
|
|
{none found - get a new one}
|
|
ln := GetLocalLabel;
|
|
GetTemp := ln;
|
|
Gen2(dc_loc, ln, size);
|
|
1:
|
|
end; {GetTemp}
|
|
|
|
|
|
procedure Load;
|
|
{load a value onto the evaluation stack}
|
|
|
|
var
|
|
lmt: addrrange; {temp disp}
|
|
ltype: stp; {base type}
|
|
|
|
begin {Load}
|
|
with gattr do
|
|
if typtr <> nil then begin
|
|
ltype := typtr;
|
|
if ltype^.form = subrange then
|
|
ltype := ltype^.rangetype;
|
|
case kind of
|
|
cst: if (ltype^.form = scalar) and (not IsReal(ltype)) then
|
|
if ltype = boolptr then
|
|
Gen1t(pc_ldc, cval.ival, cgUWord)
|
|
else if ltype=charptr then
|
|
Gen1t(pc_ldc, cval.ival, cgUWord)
|
|
else if ltype = longptr then
|
|
GenLdcLong(cval.valp^.lval)
|
|
else if cval.ival >= 0 then
|
|
Gen1t(pc_ldc, cval.ival, cgUWord)
|
|
else
|
|
Gen1t(pc_ldc, cval.ival, cgWord)
|
|
else if ltype = nilptr then
|
|
GenLdcLong(0)
|
|
else if IsReal(ltype) then
|
|
GenLdcReal(cval.valp^.rval)
|
|
else
|
|
GenLdcSet(cval.valp^);
|
|
varbl: begin
|
|
if access = drct then
|
|
if dpdisp > maxint then begin
|
|
lmt := dpdisp;
|
|
if vlevel <= 1 then
|
|
Gen1Name(pc_lao, 0, aname)
|
|
else
|
|
Gen3(pc_lda, gattr.dplab, 0, 0);
|
|
access := indrct;
|
|
idplmt := lmt;
|
|
end; {if}
|
|
case access of
|
|
drct: if ltype^.form = power then begin
|
|
if vlevel<=1 then
|
|
Gen2tName(pc_ldo, long(dpdisp).lsw, ord(typtr^.size),
|
|
cgSet, aname)
|
|
else
|
|
Gen4t(pc_lod, gattr.dplab, long(dpdisp).lsw,
|
|
level-vlevel, ord(typtr^.size), cgSet);
|
|
end {if}
|
|
else begin
|
|
if vlevel<=1 then
|
|
Gen1tName(pc_ldo, long(dpdisp).lsw,
|
|
GetType(typtr, isPacked), aname)
|
|
else
|
|
Gen3t(pc_lod, gattr.dplab, long(dpdisp).lsw,
|
|
level-vlevel, GetType(typtr, isPacked));
|
|
end; {else}
|
|
indrct: begin
|
|
if idplmt >= maxint then begin
|
|
GenLdcLong(idplmt);
|
|
Gen0(pc_adl);
|
|
idplmt := 0;
|
|
end; {if}
|
|
if ltype^.form = power then
|
|
Gen2t(pc_ind, ord(idplmt), ord(typtr^.size), cgSet)
|
|
else
|
|
Gen1t(pc_ind, ord(idplmt), GetType(typtr, isPacked));
|
|
end;
|
|
inxd: Error(113)
|
|
end; {case}
|
|
end;
|
|
otherwise:
|
|
end;
|
|
typtr := ltype;
|
|
kind := expr;
|
|
end;
|
|
end; {Load}
|
|
|
|
procedure LoadAddress;
|
|
{load the address of a variable onto the top of the stack}
|
|
|
|
var
|
|
lmt: addrrange; {temp disp}
|
|
|
|
begin {LoadAddress}
|
|
with gattr do
|
|
if typtr <> nil then begin
|
|
if typtr^.form = subrange then
|
|
typtr := typtr^.rangetype;
|
|
case kind of
|
|
cst: if IsString(typtr) then
|
|
GenPS(pc_lca, @cval.valp^.sval)
|
|
else
|
|
Error(113);
|
|
varbl: begin
|
|
if access = drct then
|
|
if dpdisp > maxint then begin
|
|
lmt := dpdisp;
|
|
if vlevel <= 1 then
|
|
Gen1Name(pc_lao, 0, aname)
|
|
else
|
|
Gen3(pc_lda, gattr.dplab, 0, 0);
|
|
access := indrct;
|
|
idplmt := lmt;
|
|
end; {if}
|
|
case access of
|
|
drct: if vlevel <= 1 then
|
|
Gen1Name(pc_lao, long(dpdisp).lsw, aname)
|
|
else
|
|
Gen3(pc_lda, dplab, level-vlevel, long(dpdisp).lsw);
|
|
indrct: begin
|
|
if idplmt >= maxint then begin
|
|
GenLdcLong(idplmt);
|
|
Gen0(pc_adl);
|
|
end {if}
|
|
else
|
|
Gen1t(pc_inc,ord(idplmt),cgULong);
|
|
end;
|
|
inxd: Error(113)
|
|
end; {case}
|
|
end;
|
|
expr: if typtr <> stringPtr then Error(113);
|
|
end;
|
|
kind := varbl;
|
|
access := indrct;
|
|
idplmt := 0;
|
|
end
|
|
end; {LoadAddress}
|
|
|
|
procedure LoadStringAddress;
|
|
{load the address and length of a string}
|
|
|
|
var
|
|
lattr: attr;
|
|
|
|
begin {LoadStringAddress}
|
|
lattr := gattr;
|
|
LoadAddress;
|
|
Gen0t(pc_stk, cgULong);
|
|
if lattr.kind <> expr then begin
|
|
Gen1t(pc_ldc, StrLen(gattr.typtr), cgUWord);
|
|
Gen0t(pc_stk, cgUWord);
|
|
Gen0t(pc_bno, cgUWord);
|
|
end; {if}
|
|
end; {LoadStringAddress}
|
|
|
|
procedure LoadString {kind: stringKind};
|
|
|
|
{ load the address of a string constant }
|
|
{ }
|
|
{ parameters: }
|
|
{ kind - string kind }
|
|
|
|
var
|
|
i: unsigned; {loop variable}
|
|
len: unsigned; {length of the string}
|
|
tch: char; {temp for building string from char}
|
|
|
|
begin {LoadString}
|
|
if lgth = 1 then begin {if the length is 1, make a string }
|
|
tch := chr(val.ival); { from a character }
|
|
val.valp := pointer(Malloc(sizeof(constantRec)));
|
|
with val.valp^ do begin
|
|
cclass := strg;
|
|
sval[0] := chr(1);
|
|
sval[1] := tch;
|
|
end; {with}
|
|
end; {if}
|
|
with val.valp^ do begin
|
|
if lgth = 0 then begin {for a nul string, use two zeros}
|
|
sval[0] := chr(2);
|
|
sval[1] := chr(0);
|
|
sval[2] := chr(0);
|
|
end {if}
|
|
else if kind = lengthString then begin {add the length byte}
|
|
len := length(sval);
|
|
for i := len downto 1 do
|
|
sval[i+1] := sval[i];
|
|
sval[1] := sval[0];
|
|
sval[0] := chr(len+2);
|
|
end {else}
|
|
else {bump the length for the null terminator}
|
|
sval[0] := succ(sval[0]);
|
|
sval[ord(sval[0])] := chr(0); {place a trailing nul on the string}
|
|
gattr.cval := val; {set up for the load}
|
|
gattr.typtr := stringptr;
|
|
gattr.kind := cst;
|
|
gattr.isPacked := false;
|
|
end; {with}
|
|
end; {LoadString}
|
|
|
|
|
|
function ParmSize {lsp: stp; vkind: idkind): integer};
|
|
|
|
{ find the length of a parameter }
|
|
{ }
|
|
{ parameters: }
|
|
{ lsp - }
|
|
{ vkind - }
|
|
{ }
|
|
{ Returns: stack size of parameter, in bytes }
|
|
|
|
begin {ParmSize}
|
|
ParmSize := ptrsize;
|
|
if lsp <> nil then
|
|
with lsp^ do
|
|
if vkind = actual then
|
|
if form <= power then begin
|
|
ParmSize := ord(size);
|
|
if IsReal(lsp) then
|
|
ParmSize := extSize
|
|
else if lsp = byteptr then
|
|
ParmSize := intSize;
|
|
end {if}
|
|
else if form = records then
|
|
if size <= 2 then
|
|
ParmSize := 2;
|
|
end; {ParmSize}
|
|
|
|
|
|
procedure ResetTemp;
|
|
|
|
{ forget all of the temporary work variables }
|
|
|
|
var
|
|
tl: tempPtr; {work pointer}
|
|
|
|
begin {ResetTemp}
|
|
while tempList <> nil do begin
|
|
tl := tempList;
|
|
tempList := tl^.next;
|
|
dispose(tl);
|
|
end; {while}
|
|
end; {ResetTemp}
|
|
|
|
|
|
procedure Store{var fattr: attr};
|
|
{store the value on top of stack}
|
|
|
|
var
|
|
lmt: addrrange; {temp disp}
|
|
|
|
begin {Store}
|
|
with fattr do
|
|
if typtr <> nil then begin
|
|
case access of
|
|
drct: if typtr^.form = power then begin
|
|
if vlevel <= 1 then
|
|
Gen2tName(pc_sro, long(dpdisp).lsw, ord(typtr^.size), cgSet,
|
|
aname)
|
|
else
|
|
Gen4t(pc_str, dplab, long(dpdisp).lsw, level-vlevel,
|
|
ord(typtr^.size), cgSet);
|
|
end
|
|
else begin
|
|
if vlevel <= 1 then
|
|
Gen1tName(pc_sro, long(dpdisp).lsw, GetType(typtr, isPacked),
|
|
aname)
|
|
else
|
|
Gen3t(pc_str, dplab, long(dpdisp).lsw, level-vlevel,
|
|
GetType(typtr, isPacked));
|
|
end;
|
|
indrct: begin
|
|
if typtr^.form = power then
|
|
Gen1t(pc_sto, ord(typtr^.size), cgSet)
|
|
else
|
|
Gen0t(pc_sto, GetType(typtr, isPacked));
|
|
end;
|
|
inxd: Error(113)
|
|
end; {case}
|
|
end; {if}
|
|
end; {Store}
|
|
|
|
end.
|