Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2024-12-28 16:30:59 +00:00
Code Issues Projects Releases Wiki Activity
f815c1bda6
ORCA-C/CCommon.pas
Stephen Heumann 1aa654628a Update ORCA/C version number to 2.2.0 final.
2023-07-16 22:51:16 -05:00

1054 lines
41 KiB
ObjectPascal
Raw Blame History

{$optimize 7}
{---------------------------------------------------------------}
{ }
{ CCommon }
{ }
{ Common declarations and global data for the compiler. }
{ }
{ Variables: }
{ }
{ bofPtr - pointer to the start of sourceFile }
{ chPtr - pointer to the next character in the file }
{ codegenStarted - have we started the code generator? }
{ debugType - line number debug types }
{ doingFunction - true if processing a function }
{ doingParameters - are we processing parm definitions? }
{ doingPartial - are we doing a partial compile? }
{ enterEditor - enter editor on terminal errors? }
{ expandMacros - should macros be expanded? }
{ firstPtr - points to first char in current line }
{ gotoList - list of goto labels }
{ includeFile - include file name (for return from includes) }
{ infoString - language specific command line info }
{ lastLine - last line number used by pc_nam }
{ liDCB - get/set LInfo DCB }
{ lineNumber - source line number }
{ lint - lint flags }
{ list - generate source listing? }
{ memoryCompile - memory based compile? }
{ nameFound - has a pc_nam been generated? }
{ numErrors - number of errors in the program }
{ objFile - object file name }
{ oldincludeFile - previous includeFile value }
{ partialFile - partial compile list }
{ sourceFile - source file name }
{ terminalErrors - are all errors terminal? }
{ traceBack - generate traceback code? }
{ useGlobalPool - use global (or local) string pool? }
{ wait - wait for keypress after errors? }
{ }
{ doDispose - dispose of the expression tree as we go? }
{ expressionValue - the expression evaluator returns the }
{ value of constant expressions in this variable }
{ expressionType - the type of the expression }
{ expressionTree - for non-constant initializers }
{ isConstant - is the initializer expression constant? }
{ typeSpec - type given by the last declaration specifiers, }
{ specifier-qualifier list, or type name evaluated }
{ }
{ External Subroutines: }
{ }
{ CheckGotoList - Make sure all labels have been defined }
{ ClearHourGlass - Erase the hourglass from the screen }
{ CopyLongString - copy a long string }
{ CopyString - copy a string }
{ DrawHourGlass - Draw the hourglass on the screen }
{ ExitToEditor - do an error exit to the editor }
{ GetLocalLabel - get the next local label number }
{ Hash - find hash displacement }
{ InitCCommon - Initialize this module }
{ ReadFile - read a file }
{ Spin - Spin the spinner }
{ StopSpin - Stop the spinner }
{ SystemError - intercept run time compiler errors }
{ TermError - flag a terminal error }
{ }
{---------------------------------------------------------------}
unit CCommon;
interface
{$segment 'CC'}
const
{hashsize appears in CCOMMON.ASM}
hashSize = 876; {# hash buckets - 1}
{NOTE: hashsize2 is used in Symbol.asm}
hashSize2 = 1753; {# hash buckets * 2 - 1}
maxLine = 255; {max length of a line}
maxPath = 255; {max length of a path name}
{NOTE: maxPath is used in Scanner.asm}
longstringlen = 32760; {max length of a string constant}
minChar = 0; {min ordinal value of source character}
maxChar = 255; {max ordinal value of source character}
{lint masks}
{----------}
lintUndefFn = $0001; {flag use of undefined functions}
lintNoFnType = $0002; {flag functions with no type}
lintNotPrototyped = $0004; {flag functions with no prototypes}
lintPragmas = $0008; {flag unknown pragmas}
lintPrintf = $0010; {check printf/scanf format flags}
lintOverflow = $0020; {check for overflows}
lintC99Syntax = $0040; {check for syntax that C99 disallows}
lintReturn = $0080; {flag issues with how functions return}
lintUnused = $0100; {check for unused variables}
lintConstantRange = $0200; {check for out-of-range constants}
{bit masks for GetLInfo flags}
{----------------------------}
flag_d = $10000000; {generate debug code?}
flag_e = $08000000; {abort to editor on terminal error?}
flag_f = $04000000; {print filenames in error messages?}
flag_i = $00800000; {ignore symbol files?}
flag_l = $00100000; {list source lines?}
flag_m = $00080000; {memory based compile?}
flag_o = $00020000; {optimize?}
flag_p = $00010000; {print progress info?}
flag_r = $00004000; {rebuild symbol files?}
flag_s = $00002000; {list symbol tables?}
flag_t = $00001000; {treat all errors as terminal?}
flag_w = $00000200; {wait when an error is found?}
versionStr = '2.2.0'; {compiler version}
type
{Misc.}
{-----}
long = record lsw,msw: integer; end; {for extracting words from longints}
longlong = record lo,hi: longint; end; {64-bit integer representation}
cString = packed array [1..256] of char; {null terminated string}
cStringPtr = ^cString;
longString = record {long null terminated string}
length: integer;
str: packed array [1..longstringlen] of char;
end;
longStringPtr = ^longString;
pString = packed array [0..maxLine] of char; {length string}
stringPtr = ^pString;
ptr = ^byte; {general purpose pointer}
handle = ^ptr; {general purpose handle}
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;
{ C language standards }
cStandardEnum = (c89,c95,c99,c11,c17,c23);
{ The base types include two main categories. The values starting }
{ with cg are defined in the code generator, and may be passed to the }
{ code generator for resolution. The cc types are used internally in }
{ the compiler. Any values whose type is cc must be resolved to one }
{ of the cg types before the code generator is called. }
baseTypeEnum = (cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,
cgReal,cgDouble,cgComp,cgExtended,cgString,
cgVoid,cgQuad,cgUQuad,ccPointer);
{ Basic types (plus the void type) as defined by the C language. }
{ This differs from baseTypeEnum in that different types with the }
{ same representation are distinguished from each other. }
{ (ctInt32/ctUInt32 are 32-bit int types when using #pragma unix 1.) }
cTypeEnum = (ctChar, ctSChar, ctUChar, ctShort, ctUShort, ctInt, ctUInt,
ctLong, ctULong, ctFloat, ctDouble, ctLongDouble, ctComp,
ctVoid, ctInt32, ctUInt32, ctBool, ctLongLong, ctULongLong);
{tokens}
{------}
{Note: tokenEnum is duplicated in }
{ Table.asm }
tokenEnum = ( {enumeration of the tokens}
ident, {identifiers}
{constants}
{Note: compconst and charconst, etc. }
{ are not found in program code. }
{ They are created only by casts. }
intconst,uintconst,longconst,ulongconst,longlongconst,
ulonglongconst,floatconst,doubleconst,extendedconst,compconst,
charconst,scharconst,ucharconst,ushortconst,stringconst,
{reserved words}
_Alignassy,_Alignofsy,_Atomicsy,_Boolsy,_Complexsy,
_Genericsy,_Imaginarysy,_Noreturnsy,_Static_assertsy,_Thread_localsy,
autosy,asmsy,breaksy,casesy,charsy,
continuesy,constsy,compsy,defaultsy,dosy,
doublesy,elsesy,enumsy,externsy,extendedsy,
floatsy,forsy,gotosy,ifsy,intsy,
inlinesy,longsy,pascalsy,registersy,restrictsy,
returnsy,shortsy,sizeofsy,staticsy,structsy,
switchsy,segmentsy,signedsy,typedefsy,unionsy,
unsignedsy,voidsy,volatilesy,whilesy,
{reserved symbols}
excch,percentch,carotch,andch,asteriskch,
minusch,plusch,eqch,tildech,barch,
dotch,ltch,gtch,slashch,questionch,
lparench,rparench,lbrackch,rbrackch,lbracech,
rbracech,commach,semicolonch,colonch,poundch,
minusgtop,plusplusop,minusminusop,ltltop,gtgtop,
lteqop,gteqop,eqeqop,exceqop,andandop,
barbarop,pluseqop,minuseqop,asteriskeqop,slasheqop,
percenteqop,ltlteqop,gtgteqop,andeqop,caroteqop,
bareqop,poundpoundop,dotdotdotsy,
otherch, {other non-whitespace char (pp-token)}
eolsy,eofsy, {control characters}
typedef, {user types}
{converted operations}
uminus,uplus,uand,uasterisk,
parameteroper,castoper,opplusplus,opminusminus,compoundliteral,
macroParm); {macro language}
{Note: this enumeration also }
{ appears in TABLE.ASM, }
{ SCANNER.asm }
charEnum = {character kinds}
(illegal,ch_special,ch_dash,ch_plus,ch_lt,ch_gt,ch_eq,ch_exc,
ch_and,ch_bar,ch_dot,ch_white,ch_eol,ch_eof,ch_char,ch_string,
ch_asterisk,ch_slash,ch_percent,ch_carot,ch_pound,ch_colon,
ch_backslash,ch_other,letter,digit);
{prefixes of a character/string literal}
charStrPrefixEnum = (prefix_none,prefix_L,prefix_u16,prefix_U32,prefix_u8);
tokenSet = set of tokenEnum;
tokenClass = (reservedWord,reservedSymbol,identifier,intConstant,longConstant,
longlongConstant,realConstant,stringConstant,otherCharacter,
macroParameter);
identPtr = ^identRecord; {^ to a symbol table entry}
tokenType = record {a token}
kind: tokenEnum; {kind of token}
numString: stringPtr; {chars in number (macros only)}
case class: tokenClass of {token info}
reservedWord : ();
reservedSymbol: (isDigraph: boolean);
identifier : (name: stringPtr;
symbolPtr: identPtr);
intConstant : (ival: integer);
longConstant : (lval: longint);
longlongConstant: (qval: longlong);
realConstant : (rval: extended);
stringConstant: (sval: longstringPtr;
ispstring: boolean;
prefix: charStrPrefixEnum);
otherCharacter: (ch: char); {used for preprocessing tokens only}
macroParameter: (pnum: integer);
end;
{expressions}
{-----------}
expressionKind = ( {kinds of expressions}
preprocessorExpression, {used by preprocessor commands}
arrayExpression, {array subscripts, case labels,
bit-field lengths, enum values}
initializerExpression, {static variable initializers}
autoInitializerExpression, {auto variable initializers}
normalExpression); {for run-time evaluation}
typePtr = ^typeRecord;
tokenPtr = ^tokenRecord;
tokenRecord = record {for operation, operand stacks}
next: tokenPtr; {next token on the stack}
left,middle,right: tokenPtr; {operand paths for operations}
token: tokenType; {token at this node/leaf}
case boolean of
true : (id: identPtr;); {^symbol table entry for this operand}
false: (castType: typePtr;); {cast type (for type casts only)}
end;
{goto label list}
{---------------}
gotoPtr = ^gotoRecord;
gotoRecord = record
{Note: if the size changes, see gotoSize}
next: gotoPtr;
name: stringPtr;
lab: integer;
defined: boolean;
end;
{symbol tables}
{-------------}
{classes of variables in the sym. tbl}
spaceType = (tagSpace,variableSpace,allSpaces,fieldListSpace);
parameterPtr = ^parameterRecord; {prototype parameter list}
parameterRecord = record
next: parameterPtr;
parameter: identPtr;
parameterType: typePtr;
end;
typeQualifierEnum = (tqConst, tqVolatile, tqRestrict);
typeQualifierSet = set of typeQualifierEnum;
typeKind = (scalarType,arrayType,pointerType,functionType,enumType,
enumConst,structType,unionType,definedType);
typeRecord = record {type}
size: longint; {size of the type in bytes}
qualifiers: typeQualifierSet; {type qualifiers}
saveDisp: longint; {disp in symbol file}
case kind: typeKind of {NOTE: aType,pType and fType must overlap}
scalarType : (baseType: baseTypeEnum; {our internal type representation}
cType: cTypeEnum); {type in the C type system}
arrayType : (aType: typePtr;
elements: longint;
);
pointerType : (pType: typePtr;);
functionType: (fType: typePtr; {return type}
varargs, {are there a variable # of args?}
prototyped: boolean; {is it prototyped?}
overrideKR: boolean; {K&R overrides to prototypes?}
parameterList: parameterPtr; {prototyped parameter list}
isPascal: boolean; {pascal parameters?}
toolNum: integer; {non-zero for tool functions}
dispatcher: longint; {dispatch addr}
);
enumConst : (eval: integer;);
enumType : ();
definedType : (dType: typePtr;);
structType,
unionType : (fieldList: identPtr; {field list}
sName: stringPtr; {struct name; for forward refs}
constMember: boolean; {does it have a const member?}
flexibleArrayMember: boolean; {does it have a FAM?}
);
end;
initializerPtr = ^initializerRecord; {initializers}
initializerRecord = record
next: initializerPtr; {next record in the chain}
disp: longint; {disp within overall object being initialized}
count: integer; {# of duplicate records (>1 for bytes only)}
bitdisp: integer; {disp in byte (field lists only)}
bitsize: integer; {width in bits; 0 for byte sizes}
case isConstant: boolean of {is this a constant initializer?}
false: (
iType: typePtr; {type being initialized}
iTree: tokenPtr; {initializer expression}
);
true : ( {Note: qVal.lo must overlap iVal}
case basetype: baseTypeEnum of
cgByte,
cgUByte,
cgWord,
cgUWord,
cgLong,
cgULong : (iVal: longint);
cgQuad,
cgUQuad : (qVal: longlong);
cgString : (sVal: longstringPtr);
cgReal,
cgDouble,
cgComp,
cgExtended: (rVal: extended);
cgVoid,
ccPointer: (
pVal: longint;
pPlus: boolean;
case isName: boolean of
true : (pName: stringPtr);
false: (pStr : longstringPtr);
);
);
end;
storageType = (stackFrame,parameter,external,global,none,private);
stateKind = (declared,defined,initialized);
identRecord = record {identifier}
next: identPtr; {next symbol in this hash bucket}
saved: boolean; {has the symbol been saved (hashed) in the symbol file?}
name: stringPtr; {symbol name}
itype: typePtr; {symbol type}
disp: longint; {disp past start of struct (field lists only)}
bitDisp: integer; {disp in byte (field lists only)}
{parameter number (K&R parms only)}
bitsize: integer; {width in bits; 0 for byte sizes}
state: stateKind; {state of the definition}
iPtr: initializerPtr; {pointer to the first initializer}
isForwardDeclared: boolean; {does this var use a forward declared type?}
class: tokenEnum; {storage class}
used: boolean; {is this identifier used?}
case storage: storageType of
stackFrame: (lln: integer; {local label #}
clnext: identPtr); {next compound literal}
parameter: (pln: integer; {paramater label #}
pdisp: integer; {disp of parameter}
pnext: identPtr); {next parameter}
external: (inlineDefinition: boolean); {(potential) inline definition of function?}
global,private: ();
none: (
case anonMemberField: boolean of {field from an anonymous struct/union member?}
true : (anonMember: identPtr); {containing anonymous struct/union}
false: ();
);
end;
{mini-assembler}
{--------------}
{opcodes}
opcode = (o_adc,o_and,o_asl,o_bit,o_cmp,o_cop,o_cpx,o_cpy,o_dec,o_eor,
o_inc,o_jml,o_jmp,o_jsl,o_jsr,o_lda,o_ldx,o_ldy,o_lsr,o_ora,
o_pea,o_pei,o_rep,o_rol,o_ror,o_sbc,o_sep,o_sta,o_stx,o_sty,
o_stz,o_trb,o_tsb,
o_dcb,o_dcw,o_dcl,
o_brk,o_wdm,
o_mvn,o_mvp,
o_bcc,o_bcs,o_beq,o_bmi,o_bne,o_bpl,o_bra,o_brl,o_per,o_bvc,
o_bvs,
o_clc,o_cld,o_cli,o_clv,o_dex,o_dey,o_inx,o_iny,o_nop,o_pha,
o_phb,o_phd,o_phk,o_php,o_phx,o_phy,o_pla,o_plb,o_pld,o_plp,
o_plx,o_ply,o_rti,o_rtl,o_rts,o_sec,o_sed,o_sei,o_stp,o_tax,
o_tay,o_tcd,o_tcs,o_tdc,o_tsc,o_tsx,o_txa,o_txs,o_txy,o_tya,
o_tyx,o_wai,o_xba,o_xce);
{addressing modes}
operands = (acc,imm,dp,dp_x,dp_y,op,op_x,op_y,i_dp_x,i_dp_y,dp_s,li_dp,la,
i_dp,i_op,i_la,i_op_x,i_dp_s_y,li_dp_y,long_x);
{work variables}
{--------------}
tempPtr = ^tempRecord;
tempRecord = record
last,next: tempPtr; {doubly linked list}
labelNum: integer; {label number}
size: integer; {size of the variable}
end;
{ORCA Shell and ProDOS}
{---------------------}
timeField = array[1..8] of byte;
optionListRecord = record
totalSize: integer;
requiredSize: integer;
fileSysID: integer;
theData: packed array [1..100] of char;
end;
optionListPtr = ^optionListRecord;
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;
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;
getPrefixOSDCB = record
pcount: integer;
prefixNum: integer;
prefix: gsosOutStringPtr;
end;
versionDCBGS = record
pcount: integer;
version: packed array[1..4] of char;
end;
{---------------------------------------------------------------}
var
{misc}
{----}
bofPtr: ptr; {pointer to the start of sourceFile}
chPtr: ptr; {pointer to the next character in the file}
changedSourceFile: boolean; {source file changed in function?}
cStd: cStandardEnum; {selected C standard}
debugSourceFileGS: gsosOutString; {debug source file name}
{debugType is also in SCANNER.ASM}
debugType: (stop,break,autogo); {line number debug types}
doingParameters: boolean; {are we processing parm definitions?}
expandMacros: boolean; {should macros be expanded?}
ffDCBGS: fastFileDCBGS; {fast file DCB}
firstPtr: ptr; {points to first char in current line}
gotoList: gotoPtr; {list of goto labels}
includeFileGS: gsosOutString; {include file name (for return from includes)}
infoStringGS: gsosOutString; {language specific command line info}
intLabel: integer; {last used label number}
languageNumber: integer; {our language number}
lastLine: 0..maxint4; {last line number used by pc_nam}
liDCBGS: getLInfoDCBGS; {get/set LInfo DCB}
lineNumber: 0..maxint4; {source line number}
nameFound: boolean; {has a pc_nam been generated?}
nextLocalLabel: integer; {next available local data label number}
numErrors: integer; {number of errors in the program}
objFile: gsosOutString; {object file name}
oldincludeFileGS: gsosOutString; {previous includeFile value}
outFileGS: gsosOutString; {keep file name}
partialFileGS: gsosOutString; {partial compile list}
pragmaKeepFile: gsosOutStringPtr; {filename specified in #pragma keep}
sourceFileGS: gsosOutString; {presumed source file name}
strictMode: boolean; {strictly follow standard, without extensions?}
tempList: tempPtr; {list of temp work variables}
longlong0: longlong; {the value 0 as a longlong}
longlong1: longlong; {the value 1 as a longlong}
{expression results}
{------------------}
doDispose: boolean; {dispose of the expression tree as we go?}
realExpressionValue: extended; {value of the last real constant expression}
llExpressionValue: longlong; {value of the last long long constant expression}
expressionValue: longint; {value of the last constant expression}
expressionType: typePtr; {the type of the expression}
initializerTree: tokenPtr; {for non-constant initializers}
isConstant: boolean; {is the initializer expression constant?}
expressionIsLongLong: boolean; {is the last constant expression long long?}
{flags}
{-----}
codegenStarted: boolean; {have we started the code generator?}
doingFunction: boolean; {are we processing a function?}
doingPartial: boolean; {are we doing a partial compile?}
enterEditor: boolean; {enter editor on terminal errors?}
filenamesInErrors: boolean; {print filenames in error messages?}
foundFunction: boolean; {has a function been found?}
lint: integer; {lint flags}
list: boolean; {generate source listing?}
ignoreSymbols: boolean; {ignore .sym file?}
memoryCompile: boolean; {memory based compile?}
printSymbols: boolean; {+s flag set?}
progress: boolean; {write progress info?}
rebuildSymbols: boolean; {rebuild .sym file?}
switchLanguages: boolean; {switch languages on exit?}
terminalErrors: boolean; {are all errors terminal?}
traceBack: boolean; {generate traceback code?}
unix_1: boolean; {is int 32 bits? (or 16 bits)}
useGlobalPool: boolean; {use global (or local) string pool?}
wait: boolean; {wait for keypress after errors?}
lintIsError: boolean; {treat lint messages as errors?}
fIsNoreturn: boolean; {is the current function _Noreturn?}
doingMain: boolean; {are we processing the main function?}
fenvAccess: boolean; {is the FENV_ACCESS pragma on?}
fenvAccessInFunction: boolean; {was FENV_ACCESS on anywhere in current function?}
{syntactic classes of tokens}
{---------------------------}
specifierQualifierListElement: tokenSet;
topLevelDeclarationStart: tokenSet;
{---------------------------------------------------------------}
{ORCA Shell and ProDOS}
{---------------------}
procedure GetLInfoGS (var parms: getLInfoDCBGS); prodos ($0141);
procedure FastFileGS (var parms: fastFileDCBGS); prodos ($014E);
procedure SetLInfoGS (var parms: getLInfoDCBGS); prodos ($0142);
procedure GetPrefixGS (var parms: getPrefixOSDCB); prodos ($200A);
procedure VersionGS (var parms: versionDCBGS); prodos ($0147);
{---------------------------------------------------------------}
procedure CheckGotoList;
{ Make sure all labels have been defined }
procedure ClearHourGlass;
{ Erase the hourglass from the screen }
procedure CopyLongString (toPtr, fromPtr: longStringptr);
{ copy a long string }
{ }
{ parameters: }
{ toPtr - location to copy to }
{ fromPtr - location to copy from }
procedure CopyString (toPtr, fromPtr: ptr); extern;
{ copy a string }
{ }
{ parameters: }
{ toPtr - location to copy to }
{ fromPtr - location to copy from }
procedure DrawHourGlass;
{ Draw the hourglass on the screen }
procedure ExitToEditor (msg: stringPtr; 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 }
function GenLabel: integer;
{ generate the next local label, checking for too many }
function GetLocalLabel: integer;
{ get the next local label number }
function Hash (sPtr: stringPtr): integer; extern;
{ find hash displacement }
{ }
{ Finds the displacement into an array of pointers using a }
{ hash function. }
{ }
{ parameters: }
{ sPtr - points to string to find hash for }
procedure InitCCommon;
{ Initialize this module }
procedure ReadFile;
{ read a file }
{ }
{ variables: }
{ bofPtr - pointer to the start of the file }
{ ffDCB.file_length - length of the file }
{ includeFile - source file name }
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 (errnum: integer);
{ flag a terminal error }
{---------------------------------------------------------------}
implementation
const
{Note: maxLabel is also defined in cgi.pas}
{Note: maxlabel is also defined in CGC.asm}
maxLabel = 3275; {max # compiler generated labels}
{spinner}
{-------}
spinSpeed = 8; {calls before one spinner move}
type
consoleOutDCBGS = record
pcount: integer;
ch: char;
end;
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 Error (err: integer); extern; {in scanner.pas}
{ flag an error }
{ }
{ err - error number }
{procedure Error2 (loc, err: integer); extern; {debug} {in scanner.pas}
{ flag an error }
{ }
{ loc - error location }
{ err - error number }
procedure MMQuit; extern; {in mm.pas}
{ Dispose of memory allocated with private user IDs }
procedure ConsoleOutGS (var parms: consoleOutDCBGS); prodos ($015A);
{---------------------------------------------------------------}
procedure CheckGotoList;
{ Make sure all labels have been defined }
var
gt: gotoPtr; {work pointer}
msg: stringPtr; {work string}
begin {CheckGotoList}
gt := gotoList;
while gt <> nil do begin
if not gt^.defined then begin
numErrors := numErrors+1;
new(msg);
msg^ := concat('Undefined label: ', gt^.name^);
writeln(msg^);
if terminalErrors then begin
if enterEditor then
ExitToEditor(msg, ord4(firstPtr)-ord4(bofPtr))
else
TermError(0);
end; {if}
dispose(msg);
end; {if}
gt := gt^.next;
end; {while}
end; {CheckGotoList}
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 CopyLongString {toPtr, fromPtr: longStringPtr};
{ copy a long string }
{ }
{ parameters: }
{ toPtr - location to copy to }
{ fromPtr - location to copy from }
var
i: integer; {loop variable}
begin {CopyLongString}
toPtr^.length := fromPtr^.length; {set the length}
for i := 1 to fromPtr^.length do
toPtr^.str[i] := fromPtr^.str[i];
end; {CopyLongString}
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 ExitToEditor {msg: stringPtr; 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}
if disp < 0 then {sanity check disp}
disp := 0;
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}
MMQuit; {dispose of the memory pools}
halt(-1); {return to the shell}
end; {ExitToEditor}
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(58);
end;
GenLabel := intLabel;
end; {GenLabel}
function GetLocalLabel{: integer};
{ get the next local label number }
begin {GetLocalLabel}
GetLocalLabel := nextLocalLabel;
nextLocalLabel := nextLocalLabel+1;
end; {GetLocalLabel}
procedure InitCCommon;
{ Initialize this module }
begin {InitCCommon}
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] := '\';
longlong0.hi := 0;
longlong0.lo := 0;
longlong1.hi := 0;
longlong1.lo := 1;
end; {InitCCommon}
procedure ReadFile;
{ read a file }
{ }
{ variables: }
{ bofPtr - pointer to the start of the file }
{ ffDCB.file_length - length of the file }
{ includeFile - source file name }
const
SRC = $B0; {source file type}
begin {ReadFile}
with ffDCBGS do begin {read the source file}
pCount := 14;
action := 0;
flags := $C000;
pathName := @includeFileGS.theString;
end; {with}
FastFileGS(ffDCBGS);
if ToolError <> 0 then begin
sourceFileGS := includeFileGS;
includeFileGS := oldincludeFileGS;
TermError(1);
end; {if}
if ffDCBGS.fileType <> SRC then begin
includeFileGS := oldincludeFileGS;
TermError(6);
end; {if}
bofPtr := ffDCBGS.fileHandle^; {set beginning of file pointer}
end; {ReadFile}
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(5)
else
TermError(3);
end; {SystemError}
procedure TermError {errnum: integer};
{ flag a terminal error }
var
msg: pString; {terminal error message}
begin {TermError}
case errnum of {print the error}
0 : msg := '' ;
1 : msg := concat('Error reading ', sourceFileGS.theString.theString);
2 : msg := concat('Error purging ', sourceFileGS.theString.theString);
3 : msg := 'terminal compiler error';
4 : msg := 'user termination';
5 : msg := 'out of memory';
6 : msg := 'source files must have a file type of SRC';
7 : msg := 'you cannot change languages with an include directive';
8 : msg := 'you cannot change languages from an included file';
9 : msg := concat('Error writing ', objFile.theString.theString);
10: msg := 'ORCA/C requires version 2.0 or later of the shell';
{11: msg := 'The program is too large to compile to memory -- use Compile to Disk';}
12: msg := 'Invalid sym file detected. Re-run ORCA/C to proceed.';
13: msg := 'file name or command-line parameter is too long';
otherwise: begin
msg := '';
Error(57);
end;
end; {case}
with ffDCBGS do begin {purge the source file}
pCount := 5;
action := 7;
pathName := @includeFileGS.theString;
end; {with}
FastFileGS(ffDCBGS);
writeln('Terminal error: ', msg); {write the error to stdout}
if enterEditor then {error exit to editor}
ExitToEditor(@msg, ord4(chPtr) - ord4(bofPtr))
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}
MMQuit; {dispose of the memory pools}
halt(-1); {return to the shell}
end; {else}
end; {TermError}
end.
{$append 'ccommon.asm'}
Reference in New Issue View Git Blame Copy Permalink