{$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.1 dev'; {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, ppnumber, {preprocessing number (pp-token)} 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, preprocessingNumber,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} preprocessingNumber: (errCode: integer); {used for pp 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'}