ORCA-Pascal/call.pas
2018-03-12 14:15:39 -04:00

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 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.