ORCA-C/Scanner.pas
Stephen Heumann 69320cd4d8 Detect some erroneous numeric constants that were being allowed.
These include tokens like 0x, 0b, and 1.2LL.
2024-04-23 22:07:19 -05:00

6014 lines
203 KiB
ObjectPascal

{$optimize 7}
{---------------------------------------------------------------}
{ }
{ Scanner }
{ }
{ External Variables: }
{ }
{ ch - next character to process }
{ printMacroExpansions - print the token list? }
{ reportEOL - report eolsy as a token? }
{ token - next token to process }
{ }
{ External Subroutines: }
{ }
{ Error - flag an error }
{ IsDefined - see if a macro name is in the macro table }
{ InitScanner - initialize the scanner }
{ NextCh - Read the next character from the file, skipping }
{ comments. }
{ NextToken - read the next token from the file }
{ PutBackToken - place a token into the token stream }
{ TermScanner - Shut down the scanner. }
{ }
{---------------------------------------------------------------}
unit Scanner;
interface
{$LibPrefix '0/obj/'}
uses CCommon, Table, CGI, MM, Charset;
{$segment 'SCANNER'}
type
pragmas = {kinds of pragmas}
(p_startofenum,p_cda,p_cdev,p_float,p_keep,
p_nda,p_debug,p_lint,p_memorymodel,p_expand,
p_optimize,p_stacksize,p_toolparms,p_databank,p_rtl,
p_noroot,p_path,p_ignore,p_segment,p_nba,
p_xcmd,p_unix,p_line,p_fenv_access,p_extensions,
p_endofenum);
{preprocessor types}
{------------------}
tokenListRecordPtr = ^tokenListRecord;
tokenListRecord = record {element of a list of tokens}
next: tokenListRecordPtr; {next element in list}
token: tokenType; {token}
expandEnabled: boolean; {can this token be macro expanded?}
suppressPrint: boolean; {suppress printing with #pragma expand?}
tokenStart,tokenEnd: ptr; {token start/end markers}
end;
macroRecordPtr = ^macroRecord;
macroRecord = record {preprocessor macro definition}
next: macroRecordPtr;
saved: boolean;
name: stringPtr;
parameters: integer;
isVarargs: boolean;
tokens: tokenListRecordPtr;
readOnly: boolean;
algorithm: integer;
end;
macroTable = array[0..hashSize] of macroRecordPtr; {preprocessor macro list}
{path name lists}
{---------------}
pathRecordPtr = ^pathRecord;
pathRecord = record
next: pathRecordPtr;
path: stringPtr;
end;
var
ch: char; {next character to process}
macros: ^macroTable; {preprocessor macro list}
pathList: pathRecordPtr; {additional search paths}
printMacroExpansions: boolean; {print the token list?}
preprocessing: boolean; {doing pp directive or macro params?}
suppressMacroExpansions: boolean; {suppress printing even if requested?}
reportEOL: boolean; {report eolsy as a token?}
token: tokenType; {next token to process}
doingFakeFile: boolean; {processing tokens from fake "file" in memory?}
{#pragma ignore flags}
{--------------------}
allowLongIntChar: boolean; {allow long int char constants?}
allowSlashSlashComments: boolean; {allow // comments?}
allowTokensAfterEndif: boolean; {allow tokens after #endif?}
skipIllegalTokens: boolean; {skip flagging illegal tokens in skipped code?}
{Note: The following two are set together}
allowMixedDeclarations: boolean; {allow mixed declarations & stmts (C99)?}
c99Scope: boolean; {follow C99 rules for block scopes?}
looseTypeChecks: boolean; {loosen some standard type checks?}
{#pragma extensions flags}
{------------------------}
extendedKeywords: boolean; {recognize ORCA/C-specific keywords?}
extendedParameters: boolean; {change all floating params to extended?}
{---------------------------------------------------------------}
procedure DoDefaultsDotH;
{ Handle the defaults.h file }
procedure Error (err: integer);
{ flag an error }
{ }
{ err - error number }
procedure ErrorWithExtraString (err:integer; extraStr: stringPtr);
{ flag an error, with an extra string to be attached to it }
{ }
{ err - error number }
{ extraStr - extra string to include in error message }
{ }
{ Note: }
{ extraStr must point to a pString allocated with new. }
{ This call transfers ownership of it. }
{procedure Error2 (loc, err: integer); {debug}
{ flag an error }
{ }
{ loc - error location }
{ err - error number }
procedure InitScanner (start, endPtr: ptr);
{ initialize the scanner }
{ }
{ start - pointer to the first character in the file }
{ endPtr - points one byte past the last character in the file }
function IsDefined (name: stringPtr): boolean;
{ See if a macro name is in the macro table }
{ }
{ The returned value is true if the macro exists, else false. }
{ }
{ parameters: }
{ name - name of the macro to search for }
procedure NextCh; extern;
{ Read the next character from the file, skipping comments. }
{ }
{ Globals: }
{ ch - character read }
{ currentChPtr - pointer to ch in source file }
procedure NextToken;
{ Read the next token from the file. }
procedure PutBackToken (var token: tokenType; expandEnabled: boolean;
suppressPrint: boolean);
{ place a token into the token stream }
{ }
{ parameters: }
{ token - token to put back into the token stream }
{ expandEnabled - can macro expansion be performed? }
{ suppressPrint - suppress printing with #pragma expand? }
procedure TermScanner;
{ Shut down the scanner. }
procedure WriteLine;
{---------------------------------------------------------------}
implementation
const
{special key values}
{------------------}
ALERT = 7; {alert (bell)}
BS = 8; {backspace}
FF = 12; {form feed}
HT = 9; {horizontal tab}
NEWLINE = 10; {newline}
RETURN = 13; {RETURN key code}
VT = 11; {vertical tab}
{misc}
{----}
defaultName = '13:ORCACDefs:Defaults.h'; {default include file name}
maxErr = 10; {max errors on one line}
maxLint = 186; {maximum lint error code}
type
errorType = record {record of a single error}
num: integer; {error number}
line: longint; {line number}
col: integer; {column number}
extraStr: stringPtr; {extra text to include in message}
end;
{file inclusion}
{--------------}
filePtr = ^fileRecord;
fileRecord = record {NOTE: used in scanner.asm}
next: filePtr; {next file in include stack}
name: gsosOutString; {name of the file}
sname: gsosOutString; {name of the file for __FILE__}
lineNumber: longint; {line number at the #include}
disp: longint; {disp of next character to process}
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;
expandDevicesDCBGS = record
pcount: integer;
inName: gsosInStringPtr;
outName: gsosOutStringPtr;
end;
{conditional compilation parsing}
{-------------------------------}
ifPtr = ^ifRecord;
ifRecord = record
next: ifPtr; {next record in if stack}
status: {what are we doing?}
(processing,skippingToEndif,skippingToElse);
elseFound: boolean; {has an #else been found?}
theFile: filePtr; {file containing the #if}
end;
onOffEnum = (on,off,default); {on-off values in standard pragmas}
var
charStrPrefix: charStrPrefixEnum; {prefix of character/string literal}
currentChPtr: ptr; {pointer to current character in source file}
customDefaultName: stringPtr; {name of custom pre-included default file}
dateStr: longStringPtr; {macro date string}
doingCommandLine: boolean; {are we processing the cc= command line?}
doingDigitSequence: boolean; {do we want a digit sequence (for #line)?}
doingPPExpression: boolean; {are we processing a preprocessor expression?}
doingStringOrCharacter: boolean; {used to suppress comments in strings}
errors: array[1..maxErr] of errorType; {errors in this line}
eofPtr: ptr; {points one byte past the last char in the file}
fileList: filePtr; {include file list}
flagOverflows: boolean; {flag numeric overflows?}
gettingFileName: boolean; {are we in GetFileName?}
lastWasReturn: boolean; {was the last character an eol?}
lineStr: string[10]; {string form of __LINE__}
ifList: ifPtr; {points to the top prep. parse record}
includeChPtr: ptr; {chPtr at start of current token}
includeCount: 0..maxint; {nested include files (for EndInclude)}
macroFound: macroRecordPtr; {last macro found by IsDefined}
mergingStrings: boolean; {is NextToken trying to merge strings?}
needWriteLine: boolean; {is there a line that needs to be written?}
octHexEscape: boolean; {octal/hex escape in char/string?}
onOffValue: onOffEnum; {value of last on-off switch}
wroteLine: boolean; {has the current line already been written?}
numErr: 0..maxErr; {number of errors in this line}
oneStr: string[2]; {string form of __STDC__, etc.}
zeroStr: string[2]; {string form of __STDC_HOSTED__ when not hosted}
ispstring: boolean; {is the current string a p-string?}
saveNumber: boolean; {save the characters in a number?}
skipping: boolean; {skipping tokens?}
stdcVersionStr: string[8]; {string form of __STDC_VERSION__}
timeStr: longStringPtr; {macro time string}
tokenColumn: 0..maxint; {column number at start of this token}
tokenLine: 0..maxint4; {line number at start of this token}
tokenList: tokenListRecordPtr; {token putback buffer}
tokenStart: ptr; {pointer to the first char in the token}
tokenEnd: ptr; {pointer to the first char past the token}
tokenExpandEnabled: boolean; {can token be macro expanded? (only for ident)}
versionStrL: longStringPtr; {macro version string}
workString: pstring; {for building strings and identifiers}
ucnString: string[10]; {string of a UCN}
lintErrors: set of 1..maxLint; {lint error codes}
spaceStr: string[2]; {string ' ' (used in stringization)}
quoteStr: string[2]; {string '"' (used in stringization)}
numericConstants: set of tokenClass; {token classes for numeric constants}
{-- External procedures; see expression evaluator for notes ----}
procedure EndInclude (chPtr: ptr); extern;
{ Saves symbols created by the include file }
{ }
{ Parameters: }
{ chPtr - chPtr when the file returned }
{ }
{ Notes: }
{ 1. Call this subroutine right after processing an }
{ include file. }
{ 2. Fron Header.pas }
procedure ExpandDevicesGS (var parms: expandDevicesDCBGS); prodos ($0154);
procedure Expression (kind: expressionKind; stopSym: tokenSet); extern;
{ handle an expression }
function FindSymbol (var tk: tokenType; class: spaceType; oneLevel: boolean;
staticAllowed: boolean): identPtr; extern;
{ locate a symbol in the symbol table }
{ }
{ parameters: }
{ tk - token record for the identifier to find }
{ class - the kind of variable space to search }
{ oneLevel - search one level only? (used to check for }
{ duplicate symbols) }
{ staticAllowed - can we check for static variables? }
{ }
{ returns: }
{ A pointer to the symbol table entry is returned. If }
{ there is no entry, nil is returned. }
procedure FlagPragmas (pragma: pragmas); extern;
{ record the effects of a pragma }
{ }
{ parameters: }
{ pragma - pragma to record }
{ }
{ Notes: }
{ 1. From Header.pas }
procedure GetFileInfoGS (var parms: getFileInfoOSDCB); prodos ($2006);
procedure StartInclude (name: gsosOutStringPtr); extern;
{ Marks the start of an include file }
{ }
{ Notes: }
{ 1. Call this subroutine right after opening an include }
{ file. }
{ 2. From Header.pas }
function StringType(prefix: charStrPrefixEnum): typePtr; extern;
{ returns the type of a string literal with specified prefix }
{ }
{ parameters: }
{ prefix - the prefix }
procedure TermHeader; extern;
{ Stop processing the header file }
{ }
{ Note: This is called when the first code-generating }
{ subroutine is found, and again when the compile ends. It }
{ closes any open symbol file, and should take no action if }
{ called twice. }
function CnvLLX (val: longlong): extended; extern;
{ convert a long long to a real number }
{ }
{ parameters: }
{ val - the long long value }
function CnvULLX (val: longlong): extended; extern;
{ convert an unsigned long long to a real number }
{ }
{ parameters: }
{ val - the unsigned long long value }
{-- Scanner support --------------------------------------------}
procedure CheckDelimiters (var name: pString);
{ Check for delimiters, making sure they are ':' }
{ }
{ parameters: }
{ name - path name to check }
label 1;
var
dc: char; {delimiter character}
i: 0..255; {loop/index variable}
begin {CheckDelimiters}
dc := ':'; {determine what the delimiter is}
for i := 1 to length(name) do
if name[i] in [':','/'] then begin
dc := name[i];
goto 1;
end; {if}
1: ;
if dc = '/' then {replace '/' delimiters with ':'}
for i := 1 to length(name) do
if name[i] = '/' then
name[i] := ':';
end; {CheckDelimiters}
procedure AddPath (name: pString);
{ Add a path name to the path name table }
{ }
{ parameters: }
{ name - path name to add }
var
pp, ppe: pathRecordPtr; {work pointers}
begin {AddPath}
if length(name) <> 0 then begin
CheckDelimiters(name); {make sure ':' is used}
if name[length(name)] <> ':' then {make sure there is a trailing delimiter}
name := concat(name, ':');
{create the new path record}
pp := pathRecordPtr(GMalloc(sizeof(pathRecord)));
pp^.next := nil;
pp^.path := stringPtr(GMalloc(length(name)+1));
pp^.path^ := name;
if pathList = nil then {add the path to the path list}
pathList := pp
else begin
ppe := pathList;
while ppe^.next <> nil do
ppe := ppe^.next;
ppe^.next := pp;
end; {else}
end; {if}
end; {AddPath}
function Convertsl(var str: pString): longint; extern;
{ Return the integer equivalent of the string. Assumes a valid }
{ 4-byte integer string; supports unsigned values. }
procedure Convertsll(var qval: longlong; var str: pString); extern;
{ Save the integer equivalent of the string to qval. Assumes a }
{ valid 8-byte integer string; supports unsigned values. }
function ConvertHexFloat(var str: pString): extended; extern;
{ Return the extended equivalent of the hexadecimal floating- }
{ point string. }
procedure SetDateTime; extern;
{ set up the macro date/time strings }
function KeyPress: boolean; extern;
{ Has a key been pressed? }
{ }
{ 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. }
function IsDefined {name: stringPtr): boolean};
{ See if a macro name is in the macro table }
{ }
{ The returned value is true if the macro exists, else false. }
{ }
{ parameters: }
{ name - name of the macro to search for }
{ }
{ outputs: }
{ macroFound - pointer to the macro found }
label 1;
var
bPtr: ^macroRecordPtr; {pointer to hash bucket}
mPtr: macroRecordPtr; {for checking list of macros}
begin {IsDefined}
IsDefined := false;
bPtr := pointer(ord4(macros) + Hash(name));
mPtr := bPtr^;
while mPtr <> nil do begin
if mPtr^.name^ = name^ then begin
if mPtr^.algorithm <> 8 then {if not _Pragma pseudo-macro}
IsDefined := true;
goto 1;
end; {if}
mPtr := mPtr^.next;
end; {while}
1:
macroFound := mPtr;
end; {IsDefined}
procedure PutBackToken {var token: tokenType; expandEnabled: boolean;
suppressPrint: boolean};
{ place a token into the token stream }
{ }
{ parameters: }
{ token - token to put back into the token stream }
{ expandEnabled - can macro expansion be performed? }
{ suppressPrint - suppress printing with #pragma expand? }
var
tPtr: tokenListRecordPtr; {work pointer}
begin {PutBackToken}
new(tPtr);
tPtr^.next := tokenList;
tokenList := tPtr;
tPtr^.token := token;
tPtr^.expandEnabled := expandEnabled;
tPtr^.suppressPrint := suppressPrint;
tPtr^.tokenStart := tokenStart;
tPtr^.tokenEnd := tokenEnd;
end; {PutBackToken}
procedure WriteLine;
{ Write the current line and any error messages to the screen. }
{ }
{ Global Variables: }
{ firstPtr - points to the first char in the line }
{ chPtr - points to the end of line character }
label 1;
var
cl: integer; {column number loop index}
cp: ptr; {work pointer}
i: 1..maxErr; {error loop index}
msg: stringPtr; {pointer to the error message}
begin {WriteLine}
if list or (numErr <> 0) then begin
if not wroteLine and not doingCommandLine then begin
if numErr <> 0 then
if filenamesInErrors then
writeln('In ',sourceFileGS.theString.theString,':');
if doingFakeFile then begin
if numErr = 0 then
goto 1
else begin
writeln('In expansion of _Pragma on line ', fileList^.lineNumber:1, ':');
write(' ');
end; {else}
end {if}
else
write(lineNumber:4, ' '); {write the line #}
cp := firstPtr; {write the characters in the line}
while (cp <> eofPtr) and (charKinds[ord(cp^)] <> ch_eol) do begin
write(chr(cp^));
cp := pointer(ord4(cp) + 1);
end; {while}
writeln; {write the end of line character}
wroteLine := true;
end; {if}
for i := 1 to numErr do {write any errors}
with errors[i] do begin
if line = lineNumber then begin
write(' ');
while lineNumber >= 10000 do begin
lineNumber := lineNumber div 10;
write(' ');
end; {while}
lineNumber := line;
cp := firstPtr;
for cl := 1 to col-1 do begin
if cp^ = HT then
write(chr(HT))
else
write(' ');
cp := pointer(ord4(cp) + 1);
end; {for}
write('^ ');
end {if}
else if doingCommandLine then
write(' Error in command line: ')
else
write(' Error in column ', col:1, ' of line ', line:1, ': ');
case num of
1 : msg := @'illegal character';
2 : msg := @'invalid character constant';
3 : msg := @'no end was found to the string';
4 : msg := @'further errors suppressed';
5 : msg := @'cannot redefine a macro';
6 : msg := @'integer overflow';
7 : msg := @'''8'' and ''9'' cannot be used in octal constants';
8 : msg := @'unknown preprocessor command';
9 : msg := @'identifier expected';
10: msg := @'cannot undefine standard macros';
11: msg := @'end of line expected';
12: msg := @''')'' expected';
13: msg := @'''('' expected';
14: msg := @'incorrect number of macro parameters';
15: msg := @'''>'' expected';
16: msg := @'file name is too long';
17: msg := @'keep must appear before any functions';
18: msg := @'integer constant expected';
19: msg := @'only one #else may be used per #if';
20: msg := @'there is no #if for this directive';
21: msg := @'an #if had no closing #endif';
22: msg := @''';'' expected';
23: msg := @'''}'' expected';
24: msg := @''']'' expected';
25: msg := @'the else has no matching if';
26: msg := @'type expected';
27: msg := @'''{'' expected';
28: msg := @'a function cannot be defined here';
29: msg := @''':'' expected';
30: msg := @'''while'' expected';
31: msg := @'undeclared identifier';
32: msg := @'the last if statement was not finished';
33: msg := @'the last do statement was not finished';
34: msg := @'the last compound statement was not finished';
35: msg := @'expression expected';
36: msg := @'expression syntax error';
37: msg := @'operand expected';
38: msg := @'operation expected';
39: msg := @'no matching ''?'' found for this '':'' operator';
40: msg := @'illegal type cast';
41: msg := @'illegal operand in a constant expression';
42: msg := @'duplicate symbol';
{43: msg := @'the function''s type must match the previous declaration';}
44: msg := @'too many initializers';
45: msg := @'the number of array elements must be greater than 0';
46: msg := @'you must initialize the individual elements of a struct, union, or non-char array';
47: msg := @'type conflict';
48: msg := @'pointer initializers must resolve to an integer, address or string';
49: msg := @'the size could not be determined';
50: msg := @'only parameters or types may be declared here';
51: msg := @'lint: undefined function';
52: msg := @'you cannot initialize a type';
53: msg := @'the struct, union, or enum has already been defined';
54: msg := @'bit fields must be less than 32 bits wide';
55: msg := @'a value cannot be zero bits wide';
{56: msg := @'bit fields in unions are not supported by ORCA/C';}
57,otherwise: msg := @'compiler error';
58: msg := @'implementation restriction: too many local labels';
59: msg := @'file name expected';
60: msg := @'implementation restriction: string space exhausted';
61: msg := @'implementation restriction: run-time stack space exhausted';
62: msg := @'auto or register can only be used in a function body';
63: msg := @'token merging produced an illegal token';
64: msg := @'assignment to an array is not allowed';
65: msg := @'assignment to void is not allowed';
66: msg := @'the operation cannot be performed on operands of the type given';
67: msg := @'the last else clause was not finished';
68: msg := @'the last while statement was not finished';
69: msg := @'the last for statement was not finished';
70: msg := @'the last switch statement was not finished';
71: msg := @'switch expressions must evaluate to integers';
72: msg := @'case and default labels must appear in a switch statement';
73: msg := @'duplicate case label';
74: msg := @'only one default label is allowed in a switch statement';
75: msg := @'continue must appear in a while, do or for loop';
76: msg := @'break must appear in a while, do, for or switch statement';
77: msg := @'duplicate label';
78: msg := @'l-value required';
79: msg := @'illegal operand for the indirection operator';
80: msg := @'the selection operator must be used on a structure or union';
81: msg := @'the selected field does not exist in the structure or union';
82: msg := @'''('', ''['' or ''*'' expected';
83: msg := @'string constant expected';
84: msg := @'''dynamic'' expected';
85: msg := @'the number of parameters does not agree with the prototype';
86: msg := @''','' expected';
87: msg := @'invalid storage type for a parameter';
88: msg := @'you cannot initialize a parameter';
89: msg := @'''.'' expected';
90: msg := @'string too long';
91: msg := @'real constants cannot be unsigned';
92: msg := @'statement expected';
93: msg := @'assignment to const is not allowed';
94: msg := @'pascal qualifier is only allowed on functions';
95: msg := @'unidentified operation code';
96: msg := @'incorrect operand size';
97: msg := @'operand syntax error';
98: msg := @'invalid operand';
{99: msg := @'comp data type is not supported by the 68881';}
100: msg := @'integer constants cannot use the f designator';
101: msg := @'digits expected in the exponent';
{102: msg := @'extern variables cannot be initialized';}
103: msg := @'functions cannot return functions or arrays';
104: msg := @'lint: missing function type';
105: msg := @'lint: parameter list not prototyped';
106: msg := @'cannot take the address of a bit field';
107: msg := @'illegal use of forward declaration';
108: msg := @'unknown or invalid cc= option';
109: msg := @'illegal math operation in a constant expression';
110: msg := @'lint: unknown pragma';
{111: msg := @'the & operator cannot be applied to arrays';}
{112: msg := @'segment buffer overflow';}
113: msg := @'all parameters must have a name';
114: msg := @'a function call was made to a non-function';
115: msg := @'illegal bit field declaration';
116: msg := @'missing field name';
117: msg := @'field cannot have incomplete or function type';
118: msg := @'flexible array must be last member of structure';
119: msg := @'inline specifier is only allowed on functions';
{120: msg := @'inline functions without ''static'' or ''extern'' are not supported';}
121: msg := @'invalid digit for binary constant';
122: msg := @'arithmetic is not allowed on a pointer to an incomplete or function type';
123: msg := @'array element type may not be an incomplete or function type';
124: msg := @'lint: invalid format string or arguments';
{125: msg := @'lint: format string is not a string literal';}
126: msg := @'scope rules may not be changed within a function';
127: msg := @'illegal storage class for declaration in for loop';
128: msg := @'lint: integer overflow in expression';
129: msg := @'lint: division by zero';
130: msg := @'lint: invalid shift count';
131: msg := @'numeric constant is too long';
132: msg := @'static assertion failed';
133: msg := @'incomplete or function types may not be used here';
{134: msg := @'''long long'' types are not supported by ORCA/C';}
{135: msg := @'the type _Bool is not supported by ORCA/C';}
136: msg := @'complex or imaginary types are not supported by ORCA/C';
137: msg := @'atomic types are not supported by ORCA/C';
138: msg := @'unsupported alignment';
{139: msg := @'thread-local storage is not supported by ORCA/C';}
{140: msg := @'unexpected token';}
141: msg := @'_Noreturn specifier is only allowed on functions';
142: msg := @'_Alignas may not be used in this declaration or type name';
143: msg := @'only object pointer types may be restrict-qualified';
{144: msg := @'generic selection expressions are not supported by ORCA/C';}
145: msg := @'invalid universal character name';
146: msg := @'Unicode character cannot be represented in execution character set';
147: msg := @'lint: not all parameters were declared with a type';
148: msg := @'all parameters must have a complete type';
149: msg := @'invalid universal character name for use in an identifier';
{150: msg := @'designated initializers are not supported by ORCA/C';}
151: msg := @'lint: type specifier missing';
152: msg := @'lint: return with no value in non-void function';
153: msg := @'lint: return statement in function declared _Noreturn';
154: msg := @'lint: function declared _Noreturn can return or has unreachable code';
155: msg := @'lint: non-void function may not return a value or has unreachable code';
156: msg := @'invalid suffix on numeric constant';
157: msg := @'unknown or malformed standard pragma';
158: msg := @'_Generic expression includes two compatible types';
159: msg := @'_Generic expression includes multiple default cases';
160: msg := @'no matching association in _Generic expression';
161: msg := @'illegal operator in a constant expression';
162: msg := @'invalid escape sequence';
163: msg := @'pointer assignment discards qualifier(s)';
{164: msg := @'compound literals within functions are not supported by ORCA/C';}
165: msg := @'''\p'' may not be used in a prefixed string';
166: msg := @'string literals with these prefixes may not be merged';
167: msg := @'''L''-prefixed character or string constants are not supported by ORCA/C';
168: msg := @'malformed hexadecimal floating constant';
169: msg := @'struct or array may not contain a struct with a flexible array member';
170: msg := @'lint: no whitespace after macro name';
171: msg := @'use of an incomplete enum type is not allowed';
172: msg := @'macro replacement list may not start or end with ''##''';
173: msg := @'''#'' must be followed by a macro parameter';
174: msg := @'''__VA_ARGS__'' may only be used in a variadic macro';
175: msg := @'duplicate macro parameter name';
176: msg := @'declarator expected';
177: msg := @'_Thread_local may not be used with the specified storage class';
178: msg := @'_Thread_local may not appear in a function declaration';
179: msg := @'_Pragma requires one string literal argument';
180: msg := @'decimal digit sequence expected';
181: msg := @'''main'' may not have any function specifiers';
182: msg := @'''='' expected';
183: msg := @'array index out of bounds';
184: msg := @'segment exceeds bank size';
185: msg := @'lint: unused variable: ';
186: msg := @'lint: implicit conversion changes value of constant';
187: msg := @'expression has incomplete struct or union type';
188: msg := @'local variable used in asm statement is out of range for addressing mode';
189: msg := @'malformed numeric constant';
end; {case}
if extraStr <> nil then begin
extraStr^ := concat(msg^,extraStr^);
msg := extraStr;
end; {if}
writeln(msg^);
if terminalErrors and (numErrors <> 0)
and (lintIsError or not (num in lintErrors)) then begin
if enterEditor then begin
if doingFakeFile then
ExitToEditor(msg, fileList^.disp-1)
else if line = lineNumber then
ExitToEditor(msg, ord4(firstPtr)+col-ord4(bofPtr)-1)
else
ExitToEditor(msg, ord4(firstPtr)-ord4(bofPtr)-1);
end {if}
else
TermError(0);
end; {if}
if extraStr <> nil then
dispose(extraStr);
end; {with}
{handle pauses}
if ((numErr <> 0) and wait) or KeyPress then begin
DrawHourglass;
while not KeyPress do {nothing};
ClearHourglass;
end; {if}
numErr := 0; {no errors on next line...}
end {if}
else
if KeyPress then begin {handle pauses}
DrawHourglass;
while not KeyPress do {nothing};
ClearHourglass;
end; {if}
Spin; {twirl the spinner}
1:
end; {WriteLine}
procedure PrintToken (token: tokenType);
{ Write a token to standard out }
{ }
{ parameters: }
{ token - token to print }
label 1;
var
ch: char; {work character}
i: integer; {loop counter}
str: string[23]; {temp string}
c16ptr: ^integer; {pointer to char16_t value}
c32ptr: ^longint; {pointer to char32_t value}
procedure PrintHexDigits(i: longint; count: integer);
{ Print a digit as a hex character }
{ }
{ Parameters: }
{ i: value to print in hexadecimal }
{ count: number of digits to print }
var
digit: integer; {hex digit value}
shift: integer; {amount to shift by}
begin {PrintHexDigits}
shift := 4 * (count-1);
while shift >= 0 do begin
digit := ord(i >> shift) & $000F;
if digit < 10 then
write(chr(digit | ord('0')))
else
write(chr(digit + ord('A') - 10));
shift := shift - 4;
end; {while}
end; {PrintHexDigits}
begin {PrintToken}
case token.kind of
typedef,
ident: write(token.name^);
charconst,
scharconst,
ucharconst,
intconst: write(token.ival:1);
ushortconst,
uintconst: write(token.ival:1,'U');
longConst: write(token.lval:1,'L');
ulongConst: write(token.lval:1,'UL');
longlongConst: begin
str := cnvds(CnvLLX(token.qval),1,1);
str[0] := chr(ord(str[0]) - 2);
write(str,'LL');
end;
ulonglongConst: begin
str := cnvds(CnvULLX(token.qval),1,1);
str[0] := chr(ord(str[0]) - 2);
write(str,'ULL');
end;
compConst,
doubleConst: write(token.rval:24);
floatConst: write(token.rval:16,'F');
extendedConst: write(token.rval:29,'L');
stringConst: begin
if token.prefix = prefix_u16 then begin
write('u"');
i := 1;
while i < token.sval^.length-2 do begin
write('\x');
c16Ptr := pointer(@token.sval^.str[i]);
PrintHexDigits(c16Ptr^, 4);
i := i + 2;
end; {while}
end {if}
else if token.prefix = prefix_U32 then begin
write('U"');
i := 1;
while i < token.sval^.length-4 do begin
write('\x');
c32Ptr := pointer(@token.sval^.str[i]);
PrintHexDigits(c32Ptr^, 8);
i := i + 4;
end; {while}
end {else if}
else begin
write('"');
for i := 1 to token.sval^.length-1 do begin
ch := token.sval^.str[i];
if ch in [' '..'~'] then begin
if ch in ['"','\','?'] then
write('\');
write(ch);
end {if}
else begin
write('\');
write((ord(ch)>>6):1);
write(((ord(ch)>>3) & $0007):1);
write((ord(ch) & $0007):1);
end; {else}
end; {for}
end; {else}
write('"');
end;
_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:
write(reservedWords[token.kind]);
tildech,questionch,lparench,rparench,commach,semicolonch,colonch:
begin
for i := minChar to maxChar do
if charSym[i] = token.kind then begin
write(chr(i));
goto 1;
end; {if}
end;
lbrackch: if not token.isDigraph then
write('[')
else
write('<:');
rbrackch: if not token.isDigraph then
write(']')
else
write(':>');
lbracech: if not token.isDigraph then
write('{')
else
write('<%');
rbracech: if not token.isDigraph then
write('}')
else
write('%>');
poundch: if not token.isDigraph then
write('#')
else
write('%:');
minusch: write('-');
plusch: write('+');
ltch: write('<');
gtch: write('>');
eqch: write('=');
excch: write('!');
andch: write('&');
barch: write('|');
percentch: write('%');
carotch: write('^');
asteriskch: write('*');
slashch: write('/');
dotch: write('.');
minusgtop: write('->');
opplusplus,
plusplusop: write('++');
opminusminus,
minusminusop: write('--');
ltltop: write('<<');
gtgtop: write('>>');
lteqop: write('<=');
gteqop: write('>=');
eqeqop: write('==');
exceqop: write('!=');
andandop: write('&&');
barbarop: write('||');
pluseqop: write('+=');
minuseqop: write('-=');
asteriskeqop: write('*=');
slasheqop: write('/=');
percenteqop: write('%=');
ltlteqop: write('<<=');
gtgteqop: write('>>=');
andeqop: write('&=');
caroteqop: write('^=');
bareqop: write('!=');
uminus: write('-');
uplus: write('+');
uand: write('&');
uasterisk: write('*');
poundpoundop: if not token.isDigraph then
write('##')
else
write('%:%:');
dotdotdotsy: write('...');
otherch: write(token.ch);
ppNumber: write(token.numString^);
macroParm: write('$', token.pnum:1);
parameteroper,
castoper,
eolsy,
eofsy: ;
end; {case}
1:
write(' ');
end; {PrintToken}
{ copy 'Scanner.debug'} {debug}
{-- The Preprocessor -------------------------------------------}
procedure CheckIdentifier; forward;
{ See if an identifier is a reserved word, macro or typedef }
procedure DoNumber; forward;
{ Scan a number from workString }
{ }
{ Globals: }
{ workString - string to take numbers from }
function GetFileType (var name: pString): integer; forward;
{ 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 OpenFile (doInclude, default: boolean): boolean; forward;
{ Open a new file and start scanning it }
{ }
{ Parameters: }
{ doInclude - are we doing a #include? }
{ default - use the name <defaults.h>? }
{ }
{ Returns: result from GetFileName }
procedure PreProcess; forward;
{ Handle preprocessor commands }
procedure CheckConditionals;
{ Check that preprocessor conditionals were balanced at the end }
{ of an include file. }
var
ip: ifPtr;
begin {CheckConditionals}
while (ifList <> nil) and (ifList^.theFile = fileList) do begin
Error(21);
ip := ifList;
ifList := ifList^.next;
dispose(ip);
end; {while}
end; {CheckConditionals}
function FindMacro (name: stringPtr): macroRecordPtr;
{ If the current token is a macro, find the macro table entry }
{ }
{ Parameters: }
{ name - name of the suspected macro }
{ }
{ Returns: }
{ Pointer to macro table entry; nil for none }
label 1;
var
bPtr: ^macroRecordPtr; {pointer to hash bucket}
mPtr: macroRecordPtr; {pointer to macro entry}
begin {FindMacro}
FindMacro := nil;
bPtr := pointer(ord4(macros)+Hash(name));
mPtr := bPtr^;
while mPtr <> nil do begin
if mPtr^.name^ = name^ then begin
if mPtr^.parameters = -1 then
FindMacro := mPtr
else if tokenList = nil then begin
while charKinds[ord(ch)] in [ch_white, ch_eol] do begin
if printMacroExpansions and not suppressMacroExpansions then
if charKinds[ord(ch)] = ch_eol then
writeln
else
write(ch);
NextCh;
end; {while}
if ch = '(' then
FindMacro := mPtr;
end {else if}
else if tokenList^.token.kind = lparench then
FindMacro := mPtr;
goto 1;
end; {if}
mPtr := mPtr^.next;
end; {while}
1:
end; {FindMacro}
procedure LongToPString (pstr: stringPtr; lstr: longStringPtr);
{ Convert a long string into a p string }
{ }
{ The long string is assumed to include a terminating null byte,}
{ which is not copied to the p-string. }
{ }
{ Parameters: }
{ pstr - pointer to the p-string }
{ lstr - pointer to the long string }
var
i: integer; {loop variable}
len: integer; {string length}
begin {LongToPString}
len := lstr^.length-1;
if len > 255 then
len := 255;
pstr^[0] := chr(len);
for i := 1 to len do
pstr^[i] := lstr^.str[i];
if len < 255 then
pstr^[len+1] := chr(0);
end; {LongToPString}
procedure ConvertString (var str: tokenType; prefix: charStrPrefixEnum);
{ Convert unprefixed string literal str to a prefixed one }
var
sPtr: longStringPtr; {new string}
i,j,k: integer; {loop counters}
codePoint: ucsCodePoint; {Unicode code point}
c16ptr: ^integer; {pointer to char16_t value}
c32ptr: ^longint; {pointer to char32_t value}
utf8: utf8Rec; {UTF-8 encoding of character}
utf16: utf16Rec; {UTF-16 encoding of character}
begin {ConvertString}
sPtr := pointer(Malloc(str.sval^.length*4));
k := 0;
for i := 1 to str.sval^.length do begin
codePoint := ConvertMacRomanToUCS(str.sval^.str[i]);
if prefix = prefix_u8 then begin
UTF8Encode(codePoint, utf8);
for j := 1 to utf8.length do begin
sPtr^.str[k+1] := chr(utf8.bytes[j]);
k := k+1;
end; {for}
end {if}
else if prefix = prefix_u16 then begin
UTF16Encode(codePoint, utf16);
c16Ptr := pointer(@sPtr^.str[k+1]);
c16Ptr^ := utf16.codeUnits[1];
k := k+2;
if utf16.length = 2 then begin
c16ptr := pointer(@sPtr^.str[k+1]);
c16Ptr^ := utf16.codeUnits[2];
k := k+2;
end; {if}
end {else if}
else if prefix = prefix_U32 then begin
c32Ptr := pointer(@sPtr^.str[k+1]);
c32Ptr^ := codePoint;
k := k+4;
end; {else if}
end; {for}
sPtr^.length := k;
str.sval := sPtr;
str.prefix := prefix;
end; {ConvertString}
procedure Merge (var tk1: tokenType; tk2: tokenType);
{ Merge two tokens (implementing ##) }
{ }
{ Parameters: }
{ tk1 - first token; result is stored here }
{ tk2 - second token }
label 1;
var
class1,class2: tokenClass; {token classes}
i: integer; {loop variable}
kind1,kind2: tokenEnum; {token kinds}
lsaveNumber: boolean; {local copy of saveNumber}
lt: tokenType; {local copy of token}
str1,str2: stringPtr; {identifier strings}
begin {Merge}
kind1 := tk1.kind;
class1 := tk1.class;
kind2 := tk2.kind;
class2 := tk2.class;
if class1 in [identifier,reservedWord] then begin
if class1 = identifier then
str1 := tk1.name
else
str1 := @reservedWords[kind1];
if class2 = identifier then
str2 := tk2.name
else if class2 = reservedWord then
str2 := @reservedWords[kind2]
else if class2 in numericConstants then
str2 := tk2.numString
else if (class2 = stringConstant) and (tk2.prefix = prefix_none) then begin
if str1^ = 'u' then
ConvertString(tk2, prefix_u16)
else if str1^ = 'U' then
ConvertString(tk2, prefix_U32)
else if str1^ = 'u8' then
ConvertString(tk2, prefix_u8)
else
Error(63);
tk1 := tk2;
goto 1;
end {else if}
else begin
Error(63);
goto 1;
end; {else}
workString := concat(str1^, str2^);
for i := 1 to length(workString) do
if not (charKinds[ord(workString[i])] in [letter,digit]) then begin
Error(63);
goto 1;
end; {if}
lt := token;
token.kind := ident;
token.class := identifier;
token.numString := nil;
token.symbolPtr := nil;
token.name := pointer(Malloc(length(workString)+1));
CopyString(pointer(token.name), @workString);
tk1 := token;
token := lt;
goto 1;
end {class1 in [identifier,reservedWord]}
else if class1 in numericConstants then begin
if class2 in numericConstants then
str2 := tk2.numString
else if class2 = identifier then
str2 := tk2.name
else if class2 = reservedWord then
str2 := @reservedWords[kind2]
else if kind2 = dotch then
str2 := @'.'
else if (kind2 = plusch)
and (tk1.numString^[length(tk1.numString^)] in ['e','E','p','P']) then
str2 := @'+'
else if (kind2 = minusch)
and (tk1.numString^[length(tk1.numString^)] in ['e','E','p','P']) then
str2 := @'-'
else begin
Error(63);
goto 1;
end; {else}
workString := concat(tk1.numString^, str2^);
lt := token;
lsaveNumber := saveNumber;
saveNumber := true;
DoNumber;
saveNumber := lsaveNumber;
tk1 := token;
token := lt;
goto 1;
end {else if class1 in numericConstants}
else if kind1 = dotch then begin
if class2 in numericConstants then
if charKinds[ord(tk2.numString^[1])] = digit then begin
workString := concat('.', tk2.numString^);
lt := token;
DoNumber;
tk1 := token;
token := lt;
goto 1;
end; {if}
end {else if class1 in numericConstants}
else if kind1 = poundch then begin
if (kind2 = poundch) and (tk1.isDigraph = tk2.isDigraph) then begin
tk1.kind := poundpoundop;
goto 1;
end; {if}
end {else if}
else if kind1 = minusch then begin
if kind2 = gtch then begin
tk1.kind := minusgtop;
goto 1;
end {if}
else if kind2 = minusch then begin
tk1.kind := minusminusop;
goto 1;
end {else if}
else if kind2 = eqch then begin
tk1.kind := minuseqop;
goto 1;
end; {else if}
end {else if}
else if kind1 = plusch then begin
if kind2 = plusch then begin
tk1.kind := plusplusop;
goto 1;
end {else if}
else if kind2 = eqch then begin
tk1.kind := pluseqop;
goto 1;
end; {else if}
end {else if}
else if kind1 = ltch then begin
if kind2 = ltch then begin
tk1.kind := ltltop;
goto 1;
end {if}
else if kind2 = lteqop then begin
tk1.kind := ltlteqop;
goto 1;
end {else if}
else if kind2 = eqch then begin
tk1.kind := lteqop;
goto 1;
end {else if}
else if kind2 = colonch then begin
tk1.kind := lbrackch;
tk1.isDigraph := true;
goto 1;
end {else if}
else if kind2 = percentch then begin
tk1.kind := lbracech;
tk1.isDigraph := true;
goto 1;
end; {else if}
end {else if}
else if kind1 = ltltop then begin
if kind2 = eqch then begin
tk1.kind := ltlteqop;
goto 1;
end; {if}
end {else if}
else if kind1 = gtch then begin
if kind2 = gtch then begin
tk1.kind := gtgtop;
goto 1;
end {if}
else if kind2 = gteqop then begin
tk1.kind := gtgteqop;
goto 1;
end {else if}
else if kind2 = eqch then begin
tk1.kind := gteqop;
goto 1;
end; {else if}
end {else if}
else if kind1 = gtgtop then begin
if kind2 = eqch then begin
tk1.kind := gtgteqop;
goto 1;
end; {if}
end {else if}
else if kind1 = eqch then begin
if kind2 = eqch then begin
tk1.kind := eqeqop;
goto 1;
end; {if}
end {else if}
else if kind1 = excch then begin
if kind2 = eqch then begin
tk1.kind := exceqop;
goto 1;
end; {if}
end {else if}
else if kind1 = andch then begin
if kind2 = andch then begin
tk1.kind := andandop;
goto 1;
end {if}
else if kind2 = eqch then begin
tk1.kind := andeqop;
goto 1;
end; {else if}
end {else if}
else if kind1 = barch then begin
if kind2 = barch then begin
tk1.kind := barbarop;
goto 1;
end {if}
else if kind2 = eqch then begin
tk1.kind := bareqop;
goto 1;
end; {else if}
end {else if}
else if kind1 = percentch then begin
if kind2 = eqch then begin
tk1.kind := percenteqop;
goto 1;
end {if}
else if kind2 = gtch then begin
tk1.kind := rbracech;
tk1.isDigraph := true;
goto 1;
end {else if}
else if kind2 = colonch then begin
tk1.kind := poundch;
tk1.isDigraph := true;
goto 1;
end; {else if}
end {else if}
else if kind1 = carotch then begin
if kind2 = eqch then begin
tk1.kind := caroteqop;
goto 1;
end; {if}
end {else if}
else if kind1 = asteriskch then begin
if kind2 = eqch then begin
tk1.kind := asteriskeqop;
goto 1;
end; {if}
end {else if}
else if kind1 = slashch then begin
if kind2 = eqch then begin
tk1.kind := slasheqop;
goto 1;
end; {if}
end {else if}
else if kind1 = colonch then begin
if kind2 = gtch then begin
tk1.kind := rbrackch;
tk1.isDigraph := true;
goto 1;
end; {if}
end; {else if}
Error(63);
1:
end; {Merge}
procedure MergeStrings (var tk1: tokenType; tk2: tokenType);
{ Merge two string constant tokens }
{ }
{ Parameters: }
{ tk1 - first token; result is stored here }
{ tk2 - second token }
var
cp: longstringPtr; {pointer to work string}
i: integer; {loop variable}
len,len1: integer; {length of strings}
elementType: typePtr; {string element type}
begin {MergeStrings}
if tk1.prefix = tk2.prefix then
{OK - nothing to do}
else if tk1.prefix = prefix_none then
ConvertString(tk1, tk2.prefix)
else if tk2.prefix = prefix_none then
ConvertString(tk2, tk1.prefix)
else
Error(166);
elementType := StringType(tk1.prefix)^.aType;
len1 := tk1.sval^.length - ord(elementType^.size);
len := len1+tk2.sval^.length;
cp := pointer(Malloc(len+2));
for i := 1 to len1 do
cp^.str[i] := tk1.sval^.str[i];
for i := 1 to len-len1 do
cp^.str[i+len1] := tk2.sval^.str[i];
cp^.length := len;
if tk1.ispstring then
cp^.str[1] := chr(len-2);
tk1.sval := cp;
end; {MergeStrings}
procedure BuildStringToken (cp: ptr; len: integer; rawSourceCode: boolean);
{ Create a string token from a string }
{ }
{ Used to stringize macros. }
{ }
{ Parameters: }
{ cp - pointer to the first character }
{ len - number of characters in the string }
{ rawSourceCode - process trigraphs & line continuations? }
label 1;
var
i: integer; {loop variable}
ch: char; {work character}
begin {BuildStringToken}
token.kind := stringconst;
token.class := stringConstant;
token.ispstring := false;
token.sval := pointer(GMalloc(len+3));
token.prefix := prefix_none;
if rawSourceCode then begin
i := 1;
1: while i <= len do begin
ch := chr(cp^);
if ch = '?' then {handle trigraphs}
if i < len-1 then
if chr(ptr(ord4(cp)+1)^) = '?' then
if chr(ptr(ord4(cp)+2)^) in
['=','(','/',')','''','<','!','>','-'] then begin
case chr(ptr(ord4(cp)+2)^) of
'(': ch := '[';
'<': ch := '{';
'/': ch := '\';
'''': ch := '^';
'=': ch := '#';
')': ch := ']';
'>': ch := '}';
'!': ch := '|';
'-': ch := '~';
end; {case}
len := len-2;
cp := pointer(ord4(cp)+2);
end; {if}
if ch = '\' then {handle line continuations}
if i < len then
if charKinds[ptr(ord4(cp)+1)^] = ch_eol then begin
if i < len-1 then
if ptr(ord4(cp)+2)^ in [$06,$07] then begin
len := len-1; {skip debugger characters}
cp := pointer(ord4(cp)+1);
end; {if}
len := len-2;
cp := pointer(ord4(cp)+2);
goto 1;
end;
token.sval^.str[i] := ch;
cp := pointer(ord4(cp)+1);
i := i+1;
end; {while}
end {if}
else
for i := 1 to len do begin
token.sval^.str[i] := chr(cp^);
cp := pointer(ord4(cp)+1);
end; {for}
token.sval^.str[len+1] := chr(0);
token.sval^.length := len+1;
PutBackToken(token, true, false);
end; {BuildStringToken}
procedure DoInclude (default: boolean);
{ #include }
{ }
{ Parameters: }
{ default - open <defaults.h>? }
var
fp: filePtr; {pointer to an include file}
begin {DoInclude}
new(fp); {get a file record for the current file}
fp^.next := fileList;
fileList := fp;
fp^.name := includeFileGS;
fp^.sname := sourceFileGS;
if default then
fp^.lineNumber := lineNumber
else
fp^.lineNumber := lineNumber+1;
if OpenFile(true, default) then begin {open a new file and proceed from there}
lineNumber := 1;
if ifList <> nil then
if fp^.next = nil then
TermHeader;
StartInclude(@includeFileGS);
end {if}
else begin {handle a file name error}
fileList := fp^.next;
dispose(fp);
end; {else}
end; {DoInclude}
procedure FakeInclude(buf: ptr; offset, length: longint; prevCh: char);
{ Set up to process tokens from a buffer in memory, treating it }
{ similarly to an included file. }
{ }
{ Parameters: }
{ buf - the buffer }
{ offset - offset in buffer to start tokenizing from }
{ length - length of buffer }
{ prevCh - character considered to be the previous char }
var
fp: filePtr; {pointer to an include file record}
begin
new(fp); {get a file record for the current file}
fp^.next := fileList;
fileList := fp;
fp^.name := includeFileGS;
fp^.sname := sourceFileGS;
fp^.lineNumber := lineNumber;
fp^.disp := ord4(currentChPtr)-ord4(bofPtr);
needWriteLine := false;
bofPtr := buf;
chPtr := ptr(ord4(buf)+offset); {set the start, end pointers}
eofPtr := pointer(ord4(bofPtr)+length);
firstPtr := bofPtr; {first char in line}
ch := prevCh; {set the initial character}
currentChPtr := buf;
doingFakeFile := true;
end;
procedure Do_Pragma (str: tokenType);
{ Handle a _Pragma(...) preprocessing operator }
{ }
{ Parameters: }
{ str - the argument to _Pragma (a stringconst token) }
var
lfirstPtr: ptr; {local copy of firstPtr}
lSuppressMacroExpansions: boolean; {local copy of suppressMacroExpansions}
buf: longStringPtr; {buffer to hold #pragma directive}
i: 0..maxint; {index variable}
c8ptr: ^byte; {pointer to 8-bit char in input string}
c16ptr: ^integer; {pointer to char16_t in input string}
c32ptr: ^longint; {pointer to char32_t in input string}
endptr: ptr; {pointer to end of input string}
ch: integer;
procedure PutChar (ch: integer);
{ write string constant representation of ch to buf }
begin {PutChar}
if ch < 0 then
Error(146)
else if chr(ch) in [chr(HT),' '..'~',chr($80)..chr($ff)] then begin
if i > longstringlen then
Error(90)
else begin
buf^.str[i] := chr(ch);
i := i+1;
end; {else}
end {else if}
else if ch in [ALERT,BS,FF,NEWLINE,RETURN,VT] then begin
if i > longstringlen-1 then
Error(90)
else begin
buf^.str[i] := '\';
case ch of
ALERT: buf^.str[i+1] := 'a';
BS: buf^.str[i+1] := 'b';
FF: buf^.str[i+1] := 'f';
NEWLINE: buf^.str[i+1] := 'n';
RETURN: buf^.str[i+1] := 'r';
VT: buf^.str[i+1] := 'v';
end; {case}
i := i+2;
end; {else}
end {else if}
else begin
if i > longstringlen-3 then
Error(90)
else begin
buf^.str[i] := '\';
buf^.str[i+1] := chr(((ch >> 6) & $0007) + ord('0'));
buf^.str[i+2] := chr(((ch >> 3) & $0007) + ord('0'));
buf^.str[i+3] := chr(( ch & $0007) + ord('0'));
i := i+4;
end; {else}
end; {else}
end; {PutChar}
begin {Do_Pragma}
new(buf); {build a buffer with #pragma directive}
buf^.str := '#pragma ';
i := 9;
case str.prefix of
prefix_none, prefix_u8: begin
c8ptr := pointer(@str.sval^.str[1]);
endPtr := pointer(ord4(c8ptr) + str.sval^.length - 1);
while ord4(c8ptr) < ord4(endPtr) do begin
ch := c8ptr^;
if (str.prefix = prefix_u8) and (ch > 127) then
ch := -1;
PutChar(ch);
c8ptr := pointer(ord4(c8ptr)+1);
end; {while}
end;
prefix_u16: begin
c16ptr := pointer(@str.sval^.str[1]);
endPtr := pointer(ord4(c16ptr) + str.sval^.length - 2);
while ord4(c16ptr) < ord4(endPtr) do begin
ch := ConvertUCSToMacRoman(ord4(c16ptr^));
PutChar(ch);
c16ptr := pointer(ord4(c16ptr)+2);
end; {while}
end;
prefix_u32: begin
c32ptr := pointer(@str.sval^.str[1]);
endPtr := pointer(ord4(c32ptr) + str.sval^.length - 4);
while ord4(c32ptr) < ord4(endPtr) do begin
ch := ConvertUCSToMacRoman(c32ptr^);
PutChar(ch);
c32ptr := pointer(ord4(c32ptr)+4);
end; {while}
end;
end; {case}
buf^.length := i-1;
lfirstPtr := firstPtr; {include tokens from the buffer}
WriteLine;
wroteLine := false;
FakeInclude(@buf^.str[1], 1, buf^.length, ' ');
lSuppressMacroExpansions := suppressMacroExpansions;
suppressMacroExpansions := true;
PreProcess;
suppressMacroExpansions := lSuppressMacroExpansions;
wroteLine := true;
firstPtr := lfirstPtr;
dispose(buf);
end; {Do_Pragma}
procedure Expand (macro: macroRecordPtr);
{ Expand a preprocessor macro }
{ }
{ Expands a preprocessor macro by putting tokens from the macro }
{ definition into the scanner's putback buffer. }
{ }
{ Parameters: }
{ macro - pointer to the macro to expand }
{ }
{ Globals: }
{ macroList - scanner putback buffer }
label 1;
type
parameterPtr = ^parameterRecord;
parameterRecord = record {parameter list element}
next: parameterPtr; {next parameter}
tokens: tokenListRecordPtr; {token list}
tokenStart,tokenEnd: ptr; {source pointers (for stringization)}
end;
var
bPtr: ^macroRecordPtr; {pointer to hash bucket}
done: boolean; {used to check for loop termination}
expandEnabled: boolean; {can the token be expanded?}
i: integer; {loop counter}
inhibit: boolean; {inhibit parameter expansion?}
lexpandMacros: boolean; {local copy of expandMacros}
lPreprocessing: boolean; {local copy of preprocessing}
lSuppressMacroExpansions: boolean; {local copy of suppressMacroExpansions}
mPtr: macroRecordPtr; {for checking list of macros}
newParm: parameterPtr; {for building a new parameter entry}
tlPtr, tPtr, tcPtr, lastPtr: tokenListRecordPtr; {work pointers}
paramCount: integer; {# of parameters found in the invocation}
parenCount: integer; {paren count; for balancing parenthesis}
parmEnd: parameterPtr; {for building a parameter list}
parms: parameterPtr; {points to the list of parameters}
pptr: parameterPtr; {work pointer for tracing parms list}
sp: longStringPtr; {work pointer}
stringization: boolean; {are we stringizing a parameter?}
endParmTokens: tokenSet; {tokens that end a parameter}
begin {Expand}
lSuppressMacroExpansions := suppressMacroExpansions; {inhibit token printing}
suppressMacroExpansions := true;
lexpandMacros := expandMacros; {prevent expansion of parameters}
expandMacros := false;
saveNumber := true; {save numeric strings}
parms := nil; {no parms so far}
if macro^.parameters >= 0 then begin {find the values of the parameters}
NextToken; {get the '(' (we hope...)}
if token.kind = lparench then begin
lPreprocessing := preprocessing;
preprocessing := true;
NextToken; {skip the '('}
paramCount := 0; {process the parameters}
parmEnd := nil;
endParmTokens := [rparench,commach];
repeat
done := true;
parenCount := 0;
paramCount := paramCount+1;
if macro^.isVarargs then
if paramCount = macro^.parameters then
endParmTokens := endParmTokens - [commach];
new(newParm);
newParm^.next := nil;
if parmEnd = nil then
parms := newParm
else
parmEnd^.next := newParm;
parmEnd := newParm;
newParm^.tokens := nil;
while (token.kind <> eofsy)
and ((parenCount <> 0)
or (not (token.kind in endParmTokens))) do begin
new(tPtr);
tPtr^.next := newParm^.tokens;
newParm^.tokens := tPtr;
tPtr^.token := token;
tPtr^.tokenStart := tokenStart;
tPtr^.tokenEnd := tokenEnd;
tPtr^.expandEnabled := tokenExpandEnabled;
if token.kind = lparench then
parenCount := parenCount+1
else if token.kind = rparench then
parenCount := parenCount-1;
NextToken;
end; {while}
if token.kind = commach then begin
NextToken;
done := false;
end; {if}
until done;
if paramCount = 1 then
if macro^.parameters = 0 then
if parms^.tokens = nil then
paramCount := 0;
if paramCount <> macro^.parameters then
Error(14);
if token.kind <> rparench then begin {insist on a closing ')'}
if not gettingFileName then {put back the source stream token}
PutBackToken(token, true, false);
Error(12);
end; {if}
preprocessing := lPreprocessing;
end {if}
else begin
Error(13);
if not gettingFileName then {put back the source stream token}
PutBackToken(token, true, false);
end; {else}
end; {if}
if macro^.readOnly then begin {handle special macros}
case macro^.algorithm of
1: begin {__LINE__}
if lineNumber <= maxint then begin
token.kind := intconst;
token.class := intconstant;
token.ival := ord(lineNumber);
end {if}
else begin
token.kind := longconst;
token.class := longconstant;
token.lval := lineNumber;
end; {else}
token.numString := @lineStr;
lineStr := cnvis(lineNumber);
tokenStart := @lineStr[1];
tokenEnd := pointer(ord4(tokenStart)+length(lineStr));
end;
2: begin {__FILE__}
token.kind := stringConst;
token.class := stringConstant;
token.ispstring := false;
token.prefix := prefix_none;
sp := pointer(Malloc(3+sourceFileGS.theString.size));
sp^.length := sourceFileGS.theString.size+1;
for i := 1 to sourceFileGS.theString.size do
sp^.str[i] := sourceFileGS.theString.theString[i];
sp^.str[i+1] := chr(0);
token.sval := sp;
tokenStart := @sp^.str;
tokenEnd := pointer(ord4(tokenStart)+sp^.length);
end;
3: begin {__DATE__}
token.kind := stringConst;
token.class := stringConstant;
token.ispstring := false;
token.prefix := prefix_none;
token.sval := dateStr;
tokenStart := @dateStr^.str;
tokenEnd := pointer(ord4(tokenStart)+dateStr^.length);
TermHeader; {Don't save stale value in sym file}
end;
4: begin {__TIME__}
token.kind := stringConst;
token.class := stringConstant;
token.ispstring := false;
token.prefix := prefix_none;
token.sval := timeStr;
tokenStart := @timeStr^.str;
tokenEnd := pointer(ord4(tokenStart)+timeStr^.length);
TermHeader; {Don't save stale value in sym file}
end;
5: begin {__STDC__}
token.kind := intConst; {__ORCAC__}
token.numString := @oneStr; {__STDC_NO_...__}
token.class := intConstant; {__ORCAC_HAS_LONG_LONG__}
token.ival := 1; {__STDC_UTF_16__}
oneStr := '1'; {__STDC_UTF_32__}
tokenStart := @oneStr[1];
tokenEnd := pointer(ord4(tokenStart)+1);
end;
6: begin {__VERSION__}
token.kind := stringConst;
token.class := stringConstant;
token.ispstring := false;
token.prefix := prefix_none;
token.sval := versionStrL;
tokenStart := @versionStrL^.str;
tokenEnd := pointer(ord4(tokenStart)+versionStrL^.length);
end;
7: begin {__STDC_HOSTED__}
if isNewDeskAcc or isClassicDeskAcc or isCDev or isNBA or isXCMD then
begin
token.kind := intConst;
token.numString := @zeroStr;
token.class := intConstant;
token.ival := 0;
zeroStr := '0';
tokenStart := @zeroStr[1];
tokenEnd := pointer(ord4(tokenStart)+1);
end {if}
else begin
token.kind := intConst;
token.numString := @oneStr;
token.class := intConstant;
token.ival := 1;
oneStr := '1';
tokenStart := @oneStr[1];
tokenEnd := pointer(ord4(tokenStart)+1);
end {else}
end;
9: begin {__STDC_VERSION__}
token.kind := longconst;
token.class := longconstant;
token.lval := stdcVersion[cStd];
token.numString := @stdcVersionStr;
stdcVersionStr := concat(cnvis(token.lval),'L');
tokenStart := @stdcVersionStr[1];
tokenEnd := pointer(ord4(tokenStart)+length(stdcVersionStr));
end;
8: begin {_Pragma pseudo-macro}
if (parms <> nil) and (parms^.tokens <> nil)
and (parms^.tokens^.token.kind = stringconst)
and (parms^.tokens^.next = nil) then
Do_Pragma(parms^.tokens^.token)
else
Error(179);
end;
otherwise: Error(57);
end; {case}
if macro^.algorithm <> 8 then {if not _Pragma}
PutBackToken(token, true, false);
end {if}
else begin
{expand the macro}
tlPtr := macro^.tokens; {place the tokens in the buffer...}
lastPtr := nil;
while tlPtr <> nil do begin
if tlPtr^.token.kind = macroParm then begin
pptr := parms; {find the correct parameter}
for i := 1 to tlPtr^.token.pnum do
if pptr <> nil then
pptr := pptr^.next;
if pptr <> nil then begin
{see if the macro is stringized}
stringization := false;
if tlPtr^.next <> nil then
stringization := tlPtr^.next^.token.kind = poundch;
{handle macro stringization}
if stringization then begin
tcPtr := pptr^.tokens;
if tcPtr = nil then
BuildStringToken(nil, 0, false);
while tcPtr <> nil do begin
if tcPtr^.token.kind = stringconst then begin
BuildStringToken(@quoteStr[1], 1, false);
BuildStringToken(@tcPtr^.token.sval^.str,
tcPtr^.token.sval^.length-1, false);
BuildStringToken(@quoteStr[1], 1, false);
end {if}
else begin
if tcPtr <> pptr^.tokens then
if charKinds[tcPtr^.tokenEnd^] = ch_white then
BuildStringToken(@spaceStr[1], 1, false);
BuildStringToken(tcPtr^.tokenStart,
ord(ord4(tcPtr^.tokenEnd)-ord4(tcPtr^.tokenStart)),
true);
{hack because stringconst may not have proper tokenEnd}
if tcPtr^.next <> nil then
if tcPtr^.next^.token.kind = stringconst then
if charKinds[ptr(ord4(tcPtr^.tokenStart)-1)^] = ch_white then
BuildStringToken(@spaceStr[1], 1, false);
end;
tcPtr := tcPtr^.next;
end; {while}
tlPtr := tlPtr^.next;
end {if}
{expand a macro parameter}
else begin
tcPtr := pptr^.tokens;
if tcPtr = nil then begin
if tlPtr^.next <> nil then
if tlPtr^.next^.token.kind = poundpoundop then begin
tlPtr := tlPtr^.next;
goto 1;
end; {if}
if lastPtr <> nil then
if lastPtr^.token.kind = poundpoundop then
if tokenList <> nil then
if tokenList^.token.kind = poundpoundop then
tokenList := tokenList^.next;
end; {if}
while tcPtr <> nil do begin
tokenStart := tcPtr^.tokenStart;
tokenEnd := tcPtr^.tokenEnd;
if tcPtr^.token.kind = ident then begin
mPtr := FindMacro(tcPtr^.token.name);
inhibit := false;
if tlPtr^.next <> nil then
if tlPtr^.next^.token.kind = poundpoundop then
inhibit := true;
if lastPtr <> nil then
if lastPtr^.token.kind = poundpoundop then
inhibit := true;
if not tcPtr^.expandEnabled then
inhibit := true;
if tcPtr = pptr^.tokens then
if (mPtr <> nil) and (mPtr^.parameters >= 0) then
inhibit := true;
if (mPtr <> nil) and (not inhibit) then
Expand(mPtr)
else begin
expandEnabled := tcPtr^.expandEnabled;
if expandEnabled then
if tcPtr^.token.name^ = macro^.name^ then
expandEnabled := false;
PutBackToken(tcPtr^.token, expandEnabled, false);
end; {else}
end {if}
else
PutBackToken(tcPtr^.token, true, false);
tcPtr := tcPtr^.next;
end; {while}
end; {else}
end; {if pptr <> nil}
end {if tlPtr^.token.kind = macroParm}
else begin
{place an explicit parm in the token list}
expandEnabled := true;
if tlPtr^.token.kind = ident then
if tlPtr^.token.name^ = macro^.name^ then
expandEnabled := false;
tokenStart := tlPtr^.tokenStart;
tokenEnd := tlPtr^.tokenEnd;
PutBackToken(tlPtr^.token, expandEnabled, false);
end; {else}
1: lastPtr := tlPtr;
tlPtr := tlPtr^.next;
end; {while}
end; {else}
while parms <> nil do begin {dispose of the parameter list}
tPtr := parms^.tokens;
while tPtr <> nil do begin
tlPtr := tPtr^.next;
dispose(tPtr);
tPtr := tlPtr;
end; {while}
parmEnd := parms^.next;
dispose(parms);
parms := parmEnd;
end; {while}
expandMacros := lexpandMacros; {restore the flags}
suppressMacroExpansions := lSuppressMacroExpansions;
saveNumber := false; {stop saving numeric strings}
end; {Expand}
function GetFileName (mustExist: boolean): boolean;
{ Read a file name from a directive line }
{ }
{ parameters: }
{ mustExist - should we look for an existing file? }
{ }
{ Returns true if successful, false if not. }
{ }
{ Note: The file name is placed in workString. }
const
SRC = $B0; {source file type}
var
i,j: integer; {string index & loop vars}
tempString: stringPtr;
procedure Expand (var name: pString);
{ Expands a name to a full pathname }
{ }
{ parameters: }
{ name - file name to expand }
var
exRec: expandDevicesDCBGS; {expand devices}
begin {Expand}
exRec.pcount := 2;
new(exRec.inName);
exRec.inName^.theString := name;
exRec.inName^.size := length(name);
new(exRec.outName);
exRec.outName^.maxSize := maxPath+4;
ExpandDevicesGS(exRec);
if toolerror = 0 then
with exRec.outName^.theString do begin
if size < maxPath then
theString[size+1] := chr(0);
name := theString;
end; {with}
dispose(exRec.inName);
dispose(exRec.outName);
end; {Expand}
function GetLibraryName (var name: pstring): boolean;
{ See if a library pathname is available }
{ }
{ Parameters: }
{ name - file name; set to pathname if result is true }
{ }
{ Returns: True if a name is available, else false }
var
lname: pString; {local copy of name}
begin {GetLibraryName}
lname := concat('13:ORCACDefs:', name);
Expand(lname);
if GetFileType(lname) = SRC then begin
name := lname;
GetLibraryName := true;
end {if}
else
GetLibraryName := false;
end; {GetLibraryName}
function GetLocalName (var name: pstring): boolean;
{ See if a local pathname is available }
{ }
{ Parameters: }
{ name - file name; set to pathname if result is true }
{ }
{ Returns: True if a name is available, else false }
var
lname: pstring; {work string}
pp: pathRecordPtr; {used to trace the path list}
begin {GetLocalName}
lname := name;
Expand(lname);
if GetFileType(lname) = SRC then begin
GetLocalName := true;
name := lname;
end {if}
else begin
GetLocalName := false;
pp := pathList;
while pp <> nil do begin
lname := concat(pp^.path^, name);
if GetFileType(lname) = SRC then begin
GetLocalName := true;
name := lname;
Expand(name);
pp := nil;
end {if}
else
pp := pp^.next;
end; {while}
end; {else}
end; {GetLocalName}
procedure MakeLibraryName (var name: pstring);
{ Create the library path name for an error message }
{ }
{ Parameters: }
{ name - file name; set to pathname }
begin {MakeLibraryName}
name := concat('13:ORCACDefs:', name);
Expand(name);
end; {MakeLibraryName}
procedure MakeLocalName (var name: pstring);
{ Create the local path name for an error message }
{ }
{ Parameters: }
{ name - file name; set to pathname }
begin {MakeLocalName}
Expand(name);
end; {MakeLocalName}
begin {GetFileName}
GetFileName := true;
gettingFileName := true; {in GetFileName}
while charKinds[ord(ch)] = ch_white do {finish processing the current line}
NextCh;
if ch = '<' then begin {process a library file...}
NextToken; {skip the '<'}
token.kind := stringconst; {convert a <> style name to a string}
token.class := stringConstant;
token.ispstring := false;
token.prefix := prefix_none;
i := 0;
while not (charKinds[ord(ch)] in [ch_eol,ch_gt]) do begin
i := i+1;
if (i = maxLine) then begin
Error(16);
GetFileName := false;
i := 0;
end;
workString[i] := ch;
NextCh;
end; {while}
workString[0] := chr(i);
CheckDelimiters(workString);
if mustExist then begin
if not GetLibraryName(workString) then
if not GetLocalName(workString) then
MakeLibraryName(workString);
end {if}
else
MakeLibraryName(workString);
if ch = '>' then
NextCh
else begin
Error(15);
GetFileName := false;
end; {else}
end {if}
else begin
{handle file names that are strings or macro expansions}
expandMacros := true; {allow macros to be used in the name}
NextToken; {skip the command name}
if (token.kind = stringConst) and (token.prefix = prefix_none) then begin
LongToPString(@workString, token.sval);
CheckDelimiters(workString);
if mustExist then begin
if not GetLocalName(workString) then
if not GetLibraryName(workString) then
MakeLocalName(workString);
end {if}
else
MakeLocalName(workString);
end {if}
else if token.kind = ltch then begin
{expand a macro to create a <filename> form name}
NextToken;
new(tempString);
tempString^[0] := chr(0);
while
(token.class in ([reservedWord] + numericConstants))
or (token.kind in [dotch,ident]) do begin
if token.kind = ident then
tempString^ := concat(tempString^, token.name^)
else if token.kind = dotch then
tempString^ := concat(tempString^, '.')
else if token.class = reservedWord then
tempString^ := concat(tempString^, reservedWords[token.kind])
else {if token.class in numericConstants then}
tempString^ := concat(tempString^, token.numstring^);
NextToken;
end; {while}
workString := tempString^;
dispose(tempString);
CheckDelimiters(workString);
if mustExist then begin
if not GetLibraryName(workString) then
if not GetLocalName(workString) then
MakeLibraryName(workString);
end {if}
else
MakeLibraryName(workString);
if token.kind <> gtch then begin
Error(15);
GetFileName := false;
end; {if}
end {else if}
else begin
Error(59);
GetFileName := false;
end; {else}
end; {else}
while charKinds[ord(ch)] = ch_white {finish processing the current line}
do NextCh;
if charKinds[ord(ch)] <> ch_eol then {check for extra stuff on the line}
begin
Error(11);
GetFileName := false;
end; {if}
gettingFileName := false; {not in GetFileName}
end; {GetFileName}
function GetFileType {var name: pString): 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
pathname: gsosInString; {GS/OS style name}
giRec: getFileInfoOSDCB; {GetFileInfo record}
begin {GetFileType}
giRec.pcount := 3;
giRec.pathName := @pathname;
pathname.theString := name;
pathname.size := length(name);
GetFileInfoGS(giRec);
if ToolError = 0 then
GetFileType := giRec.fileType
else
GetFileType := -1;
end; {GetFileType}
function OpenFile {doInclude, default: boolean): boolean};
{ Open a new file and start scanning it }
{ }
{ Parameters: }
{ doInclude - are we doing a #include? }
{ default - use the name <defaults.h>? }
{ }
{ Returns: result from GetFileName }
var
gotName: boolean; {did we get a file name?}
begin {OpenFile}
if default then begin {get the file name}
if customDefaultName <> nil then
workString := customDefaultName^
else
workString := defaultName;
gotName := true;
end {if}
else
gotName := GetFileName(true);
if gotName then begin {read the file name from the line}
OpenFile := true; {we opened it}
if doInclude and progress then {note our progress}
writeln('Including ', workString);
if not default then {write the source line}
WriteLine;
wroteLine := false;
lineNumber := lineNumber+1;
firstPtr := pointer(ord4(chPtr)+2);
needWriteLine := false;
if doInclude then {set the disp in the file}
fileList^.disp := ord4(chPtr)-ord4(bofPtr);
with ffDCBGS do begin {purge the source file}
pCount := 5;
action := 7;
pathName := @includeFileGS.theString;
end; {with}
FastFileGS(ffDCBGS);
oldincludeFileGS := includeFileGS; {set the file name}
includeFileGS.theString.theString := workString;
includeFileGS.theString.size := length(workString);
sourceFileGS := includeFileGS;
changedSourceFile := true;
ReadFile; {read the file}