ORCA-Pascal/pcommon.pas
Kelvin Sherlock 7d6b083546 This patch allows forward object declarations, in the same manner as delphi. To pre-declare an object, use a semicolon after the object keyword.
Example:

Type

forwardObject = Object;  {forward declaration}
myObject = Object
  count: integer;
  procedure init;
  function createForwardObject: forwardObject;
end;

fowardObject = Object (myObject)
  procedure init; override;
end;

---
outstanding issues:

new(forward_declared_object); -> error 44, "error in type of standard procedure parameter"

OtherObject = Object (ForwardDeclaredObject) end; -> errror 129, "type of variable must be object"

debugger symbol tables
2018-03-25 21:57:41 -04:00

1055 lines
27 KiB
ObjectPascal

{$optimize -1}
{---------------------------------------------------------------}
{ }
{ PCommon }
{ }
{ Common variables and low-level utility subroutines used by }
{ by the compiler. }
{ }
{---------------------------------------------------------------}
unit PCommon;
interface
const
displimit = 20; {max # proc levels, nested records,}
{ with statements.}
maxaddr = maxint4; {max legal value for a pointer}
maxcnt = 256; {number of characters in a line+1}
maxLine = 255; {number of characters in a line}
maxLabel = 2400; {max # of compiler generated labels}
maxlevel = 10; {max # proc levels}
maxgoto = 10; {max nesting level for goto check}
{NOTE: maxPath also defined in scanner.asm}
maxPath = 255; {max length of a path name}
ordmaxchar = 127; {ord of largest char}
ordminchar = 0; {ord of smallest char}
sethigh = 2047; {number of bits in set variable - 1}
setlow = 0; {"ord" of lsb of set variable}
setsize = 256; {set size in bytes; (sethigh+1) div 8}
intsize = 2; {storage in bytes required for base}
realsize = 4; { types}
doublesize = 8;
compsize = 8;
extendedsize = 10;
bytesize = 1;
longsize = 4;
packedcharsize = 1;
charsize = 2;
boolsize = 2;
ptrsize = 4;
procsize = 6;
extSize = 10; {size of real when passed as parm}
constantRec_longC = 6; {partial sizes for constantRec}
constantRec_reel = 10;
constantRec_pset = 260;
constantRec_chset = 258;
constantRec_strg = 258;
{error reporting}
{---------------}
maxErr = 10; {max errors on one line}
{file types}
{----------}
BIN = $06; {binary file}
DVU = $5E; {developer utility data file}
AuxUnit = $008009; {Pascal unit Aux Type}
type
{misc}
{----}
disprange = 0..displimit; {nesting level for procs + withs}
markPtr = ^integer; {pointer type for mark, release}
ptr = ^byte; {general pointer}
handle = ^ptr; {general handle}
stringKind = (lengthString,nullString); {string formats}
pString = packed array [0..maxLine] of char; {length string}
pStringPtr = ^pString;
unsigned = 0..maxint; {unsigned integer}
where = (blck,crec,vrec,rec); {origin of a set of symbols}
long = record {for extracting words}
case boolean of
true: (lsw, msw: integer);
false: (l: longint);
end;
{error reporting}
{---------------}
{NOTE: disps defined in Scanner.asm}
errtype = record
nmr: unsigned; {error number}
pos: unsigned; {position in line}
end;
{basic symbols}
{-------------}
packedkinds = (pkpacked,pkunpacked,pkeither);
symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
colon,dotdot,becomes,labelsy,constsy,typesy,varsy,funcsy,
progsy,procsy,setsy,packedsy,arraysy,recordsy,filesy,nilsy,
beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,gotosy,
endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy,
othersy,otherwisesy,powersy,bitnot,usessy,stringsy,atsy,
longintconst,unitsy,interfacesy,implementationsy,univsy,
objectsy,inheritedsy);
setofsys = set of symbol;
operator = (noop,mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
neop,eqop,inop,band,bor,xor,rshift,lshift);
{data structures}
{---------------}
ctp = ^identifier;
addrrange = longint; {valid range for pointers}
declkind = (standard,declared);
structform = (scalar,subrange,pointerStruct,power,arrays,records,objects,
files,tagfld,variant);
stp = ^structure;
structure = record
size: addrrange;
ispacked: packedkinds;
hasSFile: boolean;
case form: structform of
scalar: (case scalkind: declkind of
declared: (fconst: ctp);
standard: ());
subrange: (rangetype: stp; min,max: longint);
pointerStruct: (eltype: stp);
power: (elset: stp);
arrays: (aeltype,inxtype: stp);
records: (fstfld: ctp; recvar: stp);
objects: (objfld: ctp; {object fields}
objsize: addrrange; {object size}
objname: pstringptr; {object name}
objlevel: integer; {generation level}
objparent: stp; {parent or nil}
objdef: boolean; {false if not defined}
);
files: (filtype: stp; filsize: addrrange);
tagfld: (tagfieldp: ctp; fstvar: stp);
variant: (nxtvar,subvar: stp; varval: integer)
end;
{constants}
{---------}
cstclass = (reel,pset,strg,chset,longC);
settype = set of setlow..sethigh;
csp = ^ constantRec;
{NOTE: Size in scanner.asm}
{NOTE: Partial sizes here and in scanner.asm}
constantRec = record
case cclass: cstclass of
longC:(lval: longint);
reel: (rval: double);
pset: (pval: settype;
pmax: setlow..sethigh);
chset:(ch: packed array[0..255] of char);
strg: (sval: pString);
end;
valu = record case boolean of
true :(ival: integer);
false: (valp: csp)
end;
{names}
{-----}
directive_type = (drnone,drforw,drextern,drprodos,drtool1,drtool2,drvector,
droverride);
idclass = (types,konst,varsm,field,proc,func,directive,prog);
setofids = set of idclass;
idkind = (actual,formal);
levrange = 0..maxlevel;
keyrange = 1..53; {range of std proc nums}
{NOTE: Disps in scanner.asm}
identifier = record
name: pStringPtr; {name of the identifier}
llink, rlink: ctp; {links for symbol tree}
idtype: stp; {type of identifier}
next: ctp;
hasIFile: boolean;
case klass: idclass of
konst: (values: valu); {constant value}
varsm: (vkind: idkind;
vlev: levrange; {declaration level}
vitem: integer;
vlabel: unsigned; {variable label}
vcontvar: boolean;
fromUses: boolean;
vrestrict: boolean;
vuniv: boolean; {for parameters, is it universal?}
vPrivate: boolean;
);
field: (fldaddr: addrrange;
fldvar: boolean;
);
prog,
proc,
func: (case pfdeckind: declkind of
standard: (key: keyrange);
declared: (pflev: levrange; {static level}
pfname: integer; {subroutine name}
pfoname: pStringPtr; {object.method name}
pfactualsize: integer; {size of parameters}
pflabel: unsigned;
pfset: boolean; {has func. return value been set?}
pfmark: markPtr; {memory mark}
pfPrivate: boolean;
pfaddr: addrrange; {method object disp}
pfparms: ctp; {parameter list}
case pfkind: idkind of
actual: (pfdirective: directive_type;
pfcallnum, pftoolnum: integer;
);
formal: (pflab: unsigned;
pfnext: ctp;
);
);
);
directive: (drkind: directive_type);
types: ();
end;
{NOTE: Disps in scanner.asm}
{NOTE: Size in scanner.asm}
lptr = ^ltype; {linked list of identifiers used from}
ltype = record { other levels}
next: lptr; {next record}
name: pStringPtr; {identifier that was used}
disx: disprange; {level of the identifier}
end;
partialptr = ^partialname; {partial compile ptr}
partialname = record {partial name}
next: partialptr;
pname: pStringPtr;
end;
{labels}
{------}
starrtype = array[1..maxgoto] of integer;
lbp = ^ labl;
labl = record
nextlab: lbp;
defined: boolean;
lstlevel: integer;
lstarray: starrtype;
labval, labname: integer;
end;
{expression attributes}
{---------------------}
attrkind = (cst,varbl,expr);
vaccess = (drct,indrct,inxd);
attrptr = ^attr;
attr = record
typtr: stp; {type of the expression}
isPacked: boolean; {is this value packed?}
case kind: attrkind of {form of the expression}
cst: (cval: valu); {... a constant}
expr: ();
varbl: (case access: vaccess of {... a variable}
drct: (vlevel: levrange;
dplab: unsigned;
dpdisp: addrrange;
aname: pStringPtr;
);
indrct: (idplmt: addrrange); {... a pointer to something}
inxd: ()
);
end;
{files}
{-----}
extfilep = ^filerec;
filerec = record
filename: pStringPtr;
nextfile: extfilep
end;
gsosInString = record
size: integer;
theString: packed array [1..maxPath] of char;
end;
gsosInStringPtr = ^gsosInString;
{GS/OS class 1 output string}
gsosOutString = record
maxSize: integer;
theString: gsosInString;
end;
gsosOutStringPtr = ^gsosOutString;
{ORCA Shell and ProDOS}
{---------------------}
consoleOutDCBGS = record
pcount: integer;
ch: char;
end;
destroyOSDCB = record {Destroy DCB}
pcount: integer;
pathName: gsosInStringPtr;
end;
timeField = array[1..8] of byte;
optionListRecord = record
totalSize: integer;
requiredSize: integer;
fileSysID: integer;
theData: packed array [1..100] of char;
end;
optionListPtr = ^optionListRecord;
errorDCBGS = record
pcount: integer;
error: integer;
end;
expandDevicesDCBGS = record
pcount: integer;
inName: gsosInStringPtr;
outName: gsosOutStringPtr;
end;
fastFileDCBGS = record
pcount: integer;
action: integer;
index: integer;
flags: integer;
fileHandle: handle;
pathName: gsosInStringPtr;
access: integer;
fileType: integer;
auxType: longint;
storageType: integer;
createDate: timeField;
modDate: timeField;
option: optionListPtr;
fileLength: longint;
blocksUsed: longint;
end;
getFileInfoOSDCB = record
pcount: integer;
pathName: gsosInStringPtr;
access: integer;
fileType: integer;
auxType: longint;
storageType: integer;
createDateTime: timeField;
modDateTime: timeField;
optionList: optionListPtr;
dataEOF: longint;
blocksUsed: longint;
resourceEOF: longint;
resourceBlocks: longint;
end;
getLInfoDCBGS = record
pcount: integer;
sFile: gsosOutStringPtr;
dFile: gsosOutStringPtr;
namesList: gsosOutStringPtr;
iString: gsosOutStringPtr;
merr: byte;
merrf: byte;
lops: byte;
kFlag: byte;
mFlags: longint;
pFlags: longint;
org: longint;
end;
versionDCBGS = record
pcount: integer;
version: packed array[1..4] of char;
end;
var
{misc}
{----}
chEndPtr: ptr; {pointer to the end of the current file}
chPtr: ptr; {pointer to the next line of the current file}
filePtr: ptr; {pointer to the start of the current file}
{counters:}
{---------}
intLabel: integer; {last label number used}
linecount: integer; {line number for current line}
{flags & switches}
{----------------}
wait: boolean; {wait for keypress on non-terminal error?}
allTerm: boolean; {treat all errors as terminal?}
dataBank: boolean; {save, restore data bank?}
debug: boolean; {generate range check code?}
doingUnit: boolean; {compiling a unit?}
goToEditor: boolean; {return to editor on a terminal error?}
iso: boolean; {iso only?}
liDCBGS: getLInfoDCBGS; {get/set LInfo DCB}
list: boolean; {list source?}
memoryFlag: boolean; {+M flag from command line?}
noGlobalLabels: boolean; {have any global labels been detected?}
noinput,nooutput,noerroroutput: boolean; {tells if stan. dev. are declared}
printer: boolean; {is the printer on?}
printSymbols: boolean; {print the symbol table?}
progfound: boolean; {tells if the code has started}
progress: boolean; {print progress information?}
prterr: boolean; {to allow forward references in pointer
type declaration by supressing error
messages}
stringHeap: boolean; {has the string heap been used?}
{error reporting}
{---------------}
errinx: 0..maxErr; {number of errors on this line}
errlist: array[1..maxErr] of errtype; {list of errors}
numerr: unsigned; {number of errors in the program}
{---------------------------------------------------------------}
{scanner}
{-------}
chCnt: unsigned; {character counter}
lCnt: unsigned; {# lines written on this page}
pageSize: unsigned; {printing lines on a page}
title: pString; {title}
{expression compilation:}
{-----------------------}
gattr: attr; {describes the expr currently compiled}
gispacked: boolean; {was last identifier a component of
a packed structure?}
glcp: ctp; {last identifier in an expression}
{structured constants:}
{---------------------}
na: array [1..77] of pStringPtr;
{file names}
{----------}
fNameGS: gsosOutString; {current source file name}
kNameGS: gsosOutString; {Keep file name}
subsGS: gsosOutString; {List of subroutines for partial compile}
ldInfoGS: gsosOutString; {language dependent parameters (not used)}
intPrefixGS: gsosOutString; {prefix to search for interface files}
usesFileNameGS: gsosOutString; {active uses file name}
{bookkeeping of declaration levels:}
{----------------------------------}
disx: disprange; {level of last id searched by searchid}
level: levrange; {current static level}
top: disprange; {top of display}
nextLocalLabel: unsigned; {next available local data label number}
{NOTE: Disps in scanner.asm}
{NOTE: Size in scanner.asm}
display: {where: means:}
array [disprange] of record
ispacked: boolean;
labsused: lptr; {list of labels used from other levels}
fname: ctp;
flabel: lbp;
case occur: where of {=blck: id is variable id}
crec: (clev: levrange; {=crec: id is field id in record with}
cdspl: addrrange; { constant address}
clab: unsigned;
cname: pStringPtr);
vrec: (vdsplab: unsigned); {=vrec: id is field id in record with}
{ variable address}
rec,blck:();
end; { --> procedure withstatement}
{---------------------------------------------------------------}
{ORCA Shell and ProDOS}
{---------------------}
procedure DestroyGS (var parms: destroyOSDCB); prodos ($2002);
procedure ErrorGS (var parms: errorDCBGS); prodos ($0145);
procedure GetFileInfoGS (var parms: getFileInfoOSDCB); prodos ($2006);
procedure GetLInfoGS (var parms: getLInfoDCBGS); prodos ($0141);
procedure ExpandDevicesGS (var parms: expandDevicesDCBGS); prodos ($0154);
procedure FastFileGS (var parms: fastFileDCBGS); prodos ($014E);
procedure SetLInfoGS (var parms: getLInfoDCBGS); prodos ($0142);
procedure VersionGS (var parms: versionDCBGS); prodos ($0147);
{---------------------------------------------------------------}
procedure Brk (code: integer); extern;
{ Break into the debugger }
{ }
{ parameters: }
{ code - BRK code }
function Calloc (size: integer): ptr; extern;
{ Allocate and clear memory }
{ }
{ parameters: }
{ size - number of bytes to reserve }
{ }
{ Returns: pointer to the memory }
procedure ClearHourGlass;
{ Erase the hourglass from the screen }
function CompNames (var name1,name2: pString): integer; extern;
{ Compare two identifiers }
{ }
{ parameters: }
{ name1, name2 - identifiers to compare }
{ }
{ Returns: -1 if name1 < name2 }
{ 0 if name1 = name2 }
{ 1 if name1 > name2 }
procedure CopyString (var s1,s2: pString; len: integer); extern;
{ copy a string from s2 to s1 }
{ }
{ parameters: }
{ s1 - string buffer to copy to }
{ s2 - string buffer to copy from }
{ len - length of the s1 string buffer }
procedure DrawHourGlass;
{ Draw the hourglass on the screen }
procedure Error (err: integer);
{ flag an error in the current line }
{ }
{ parameters: }
{ err - error number }
{procedure Error2 (loc, err: integer); {debug}
{ flag an error in the current line }
{ }
{ parameters: }
{ loc - error location }
{ err - error number }
procedure FlagError;
{ do all error processing except writing the message }
function GenLabel: integer;
{ generate the next local label, checking for too many }
function GetFileType (var name: gsosOutString): integer;
{ Checks to see if a file exists }
{ }
{ parameters: }
{ name - file name to check for }
{ }
{ Returns: File type if the file exists, or -1 if the file does }
{ not exist (or if GetFileInfo returns an error) }
function GetLocalLabel: integer;
{ get the next local label number }
procedure InitPCommon;
{ Initialize this module }
function KeyPress: boolean; extern;
{ Has a key been presed? }
{ }
{ If a key has not been pressed, this function returns }
{ false. If a key has been pressed, it clears the key }
{ strobe. If the key was an open-apple ., a terminal exit }
{ is performed; otherwise, the function returns true. }
procedure LineFeed;
{ generate a line feed }
function Malloc (size: integer): ptr; extern;
{ Allocate memory }
{ }
{ parameters: }
{ size - number of bytes to reserve }
{ }
{ Returns: pointer to the memory }
procedure MMInit; extern;
{ initialize the memory manager }
procedure Mark (var p: markPtr); extern;
{ mark the heap }
{ }
{ parameters: }
{ p - location to save mark pointer }
procedure PurgeSource;
{ Purge the current source file }
procedure Release (p: markPtr); extern;
{ release previously marked heap area }
{ }
{ parameters: }
{ p - release all memory from this point on }
procedure StdNames; extern;
{ initialize the na array }
procedure Spin;
{ Spin the spinner }
{ }
{ Notes: Starts the spinner if it is not already in use }
procedure StopSpin;
{ Stop the spinner }
{ }
{ Notes: The call is safe, and ignored, if the spinner is }
procedure SystemError (errNo: integer);
{ intercept run time compiler errors }
procedure TermError (err: unsigned; msg: pStringPtr);
{ Flag a terminal error }
{ }
{ parameters: }
{ err - terminal error number }
{ msg - error message, or nil for one of the standard errors }
{ }
{ Notes: err is not used if msg <> nil }
procedure WaitForKeyPress; extern;
{ If +w has been used, waits for a keypress }
{---------------------------------------------------------------}
implementation
const
{spinner}
{-------}
spinSpeed = 8; {calls before one spinner move}
var
{spinner}
{-------}
spinning: boolean; {are we spinning now?}
spinDisp: integer; {disp to the spinner character}
spinCount: integer; {spin loop counter}
spinner: array[0..3] of char; {spinner characters}
procedure ConsoleOutGS (var parms: consoleOutDCBGS); prodos ($015A);
procedure SystemQuitFlags (flags: integer); extern;
{---------------------------------------------------------------}
procedure ExitToEditor (msg: pStringPtr; disp: longint);
{ do an error exit to the editor }
{ }
{ parameters: }
{ msg - pointer to the error message }
{ disp - displacement into the error file }
{ }
{ variables: }
{ includeFile - source file name }
var
msgGS: gsosInString; {message}
begin {ExitToEditor}
msgGS.size := length(msg^); {set up the error message}
msgGS.theString := msg^;
liDCBGS.org := disp; {mark the error}
liDCBGS.namesList := @msgGS;
liDCBGS.lops := 0; {prevent re-entry}
liDCBGS.merrf := 255;
with liDCBGS do begin
sFile := pointer(ord4(sFile)+2);
dFile := pointer(ord4(dFile)+2);
iString := pointer(ord4(iString)+2);
end; {with}
SetLInfoGS(liDCBGS);
StopSpin; {stop the spinner}
halt(-1); {return to the shell}
end; {ExitToEditor}
{---------------------------------------------------------------}
procedure ClearHourGlass;
{ Erase the hourglass from the screen }
var
coRec: consoleOutDCBGS; {Console out record}
begin {ClearHourGlass}
coRec.pcount := 1;
coRec.ch := ' '; ConsoleOutGS(coRec);
coRec.ch := chr(8); ConsoleOutGS(coRec);
end; {ClearHourGlass}
procedure DrawHourGlass;
{ Draw the hourglass on the screen }
var
coRec: consoleOutDCBGS; {Console out record}
begin {DrawHourGlass}
coRec.pcount := 1;
coRec.ch := chr(27); ConsoleOutGS(coRec);
coRec.ch := chr(15); ConsoleOutGS(coRec);
coRec.ch := 'C'; ConsoleOutGS(coRec);
coRec.ch := chr(24); ConsoleOutGS(coRec);
coRec.ch := chr(14); ConsoleOutGS(coRec);
coRec.ch := chr(8); ConsoleOutGS(coRec);
end; {DrawHourGlass}
procedure Error {err: integer};
{ flag an error in the current line }
{ }
{ parameters: }
{ err - error number }
begin {Error}
if errinx >= maxErr - 1 then begin
errlist[maxErr].nmr := 109;
errinx := maxErr;
end {if}
else begin
errinx := errinx + 1;
errlist[errinx].nmr := err;
numerr := numerr + 1;
end; {else}
errlist[errinx].pos := chCnt;
if liDCBGS.merrf < 16 then
liDCBGS.merrf := 16;
end; {Error}
{procedure Error2 {loc, err: integer); {debug}
{ flag an error in the current line }
{ }
{ parameters: }
{ loc - error location }
{ err - error number }
{begin {Error2}
{writeln('Error ', err:1, ' flagged at ', loc:1);
Error(err);
end; {Error2}
procedure FlagError;
{ do all error processing except writing the message }
begin {FlagError}
LineFeed; {write the carriage return}
numerr := numerr+1; {increment the number of errors}
WaitForKeyPress; {wait for a keypress}
if liDCBGS.merrf < 16 then {set the error level}
liDCBGS.merrf := 16;
end; {FlagError}
function GenLabel{: integer};
{ generate the next local label, checking for too many }
begin {GenLabel}
if intLabel < maxLabel then
intLabel := intLabel+1
else begin
intLabel := 0;
Error(102);
end;
GenLabel := intLabel;
end; {GenLabel}
function GetFileType {var name: gsosOutString): integer};
{ Checks to see if a file exists }
{ }
{ parameters: }
{ name - file name to check for }
{ }
{ Returns: File type if the file exists, or -1 if the file does }
{ not exist (or if GetFileInfo returns an error) }
var
giRec: getFileInfoOSDCB; {GetFileInfo record}
begin {GetFileType}
giRec.pcount := 3;
giRec.pathName := @name.theString;
GetFileInfoGS(giRec);
if ToolError = 0 then
GetFileType := giRec.fileType
else
GetFileType := -1;
end; {GetFileType}
function GetLocalLabel{: integer};
{ get the next local label number }
begin {GetLocalLabel}
GetLocalLabel := nextLocalLabel;
nextLocalLabel := nextLocalLabel+1;
end; {GetLocalLabel}
procedure InitPCommon;
{ Initialize this module }
var
vDCBGS: versionDCBGS; {for checking the version number}
begin {InitPCommon}
SystemQuitFlags($4000); {make sure we quit with restart set}
vDCBGS.pCount := 1; {check the version number}
VersionGS(vDCBGS);
if vDCBGS.version[1] < '2' then
TermError(14, nil);
spinning := false; {not spinning the spinner}
spinDisp := 0; {start spinning with the first character}
spinner[0] := '|'; {set up the spinner characters}
spinner[1] := '/';
spinner[2] := '-';
spinner[3] := '\';
end; {InitPCommon}
procedure LineFeed;
{ generate a line feed }
begin {LineFeed}
writeln;
if printer then begin
lcnt := lcnt+1;
if lcnt = pageSize then begin
if length(title) = 0 then
lcnt := 0
else begin
lcnt := 2;
writeln(title);
writeln;
end; {else}
end; {if}
end; {if}
end; {LineFeed}
procedure PurgeSource;
{ Purge the current source file }
var
ffDCBGS: fastFileDCBGS; {FastFile record}
begin {PurgeSource}
with ffDCBGS do begin
pCount := 5;
action := 7;
pathName := @fNameGS.theString;
end; {with}
FastFileGS(ffDCBGS);
end; {PurgeSource}
procedure Spin;
{ Spin the spinner }
{ }
{ Notes: Starts the spinner if it is not already in use }
var
coRec: consoleOutDCBGS; {Console out record}
begin {Spin}
if not spinning then begin
spinning := true;
spinCount := spinSpeed;
end; {if}
spinCount := spinCount - 1;
if spinCount = 0 then begin
spinCount := spinSpeed;
spinDisp := spinDisp - 1;
if spinDisp < 0 then
spinDisp := 3;
coRec.pcount := 1;
coRec.ch := spinner[spinDisp];
ConsoleOutGS(coRec);
coRec.ch := chr(8);
ConsoleOutGS(coRec);
end; {if}
end; {Spin}
procedure StopSpin;
{ Stop the spinner }
{ }
{ Notes: The call is safe, and ignored, if the spinner is }
{ inactive. }
var
coRec: consoleOutDCBGS; {Console out record}
begin {StopSpin}
if spinning then begin
spinning := false;
coRec.pcount := 1;
coRec.ch := ' ';
ConsoleOutGS(coRec);
coRec.ch := chr(8);
ConsoleOutGS(coRec);
end; {if}
end; {StopSpin}
procedure SystemError {errNo: integer};
{ intercept run time compiler errors }
begin {SystemError}
if errNo = 5 then
TermError(3, nil)
else
TermError(7, nil);
end; {SystemError}
procedure TermError {err: unsigned; msg: pStringPtr};
{ Flag a terminal error }
{ }
{ parameters: }
{ err - terminal error number }
{ msg - error message, or nil for one of the standard errors }
{ }
{ Notes: err is not used if msg <> nil }
begin {TermError}
PurgeSource; {purge the source file}
if msg = nil then
case err of
0:msg := @'User termination';
1:msg := @'Not enough bank zero memory';
2:msg := @'Non-Pascal file opened at an inappropriate time';
3:msg := @'Out of memory';
4:msg := @'Tool or ProDOS error - see listing file';
5:msg := @'Segment buffer overflow';
6:msg := @'Error reading uses file';
{7:msg := @'Compiler error';}
8:msg := @'Could not open the object file';
9:msg := @'Could not delete interface file';
10:msg := @'Units cannot be compiled to memory';
11:msg := @'Source files must end with a return';
12:msg := @'Error writing uses file';
13:msg := @'Error writing object file';
14:msg := @'ORCA/Pascal requires version 2.0 or later of the shell';
otherwise:
msg := @'Compiler error';
end; {case}
writeln('Terminal error: ', msg^);
if gotoEditor then {error exit to editor}
ExitToEditor(msg, ord4(chPtr) - ord4(filePtr) + chCnt)
else begin
liDCBGS.lops := 0; {prevent re-entry}
liDCBGS.merrf := 127;
with liDCBGS do begin
sFile := pointer(ord4(sFile)+2);
dFile := pointer(ord4(dFile)+2);
namesList := pointer(ord4(namesList)+2);
iString := pointer(ord4(iString)+2);
end; {with}
SetLInfoGS(liDCBGS);
StopSpin; {stop the spinner}
halt(-1); {return to the shell}
end; {else}
end; {TermError}
end.
{$append 'pcommon.asm'}