mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-12-22 07:30:54 +00:00
6bb91d20e5
This allows headers or other code to test for the presence of this feature.
4743 lines
157 KiB
ObjectPascal
4743 lines
157 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_endofenum);
|
|
|
|
{preprocessor types}
|
|
{------------------}
|
|
tokenListRecordPtr = ^tokenListRecord;
|
|
tokenListRecord = record {element of a list of tokens}
|
|
next: tokenListRecordPtr; {next element in list}
|
|
tokenString: longStringPtr; {string making up the token}
|
|
token: tokenType; {token}
|
|
expandEnabled: boolean; {can this token be macro expanded?}
|
|
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?}
|
|
reportEOL: boolean; {report eolsy as a token?}
|
|
token: tokenType; {next token to process}
|
|
|
|
{#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?}
|
|
looseCharTypeChecks: boolean; {treat char and unsigned char as compatible?}
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
procedure DoDefaultsDotH;
|
|
|
|
{ Handle the defaults.h file }
|
|
|
|
|
|
procedure Error (err: integer);
|
|
|
|
{ flag an error }
|
|
{ }
|
|
{ err - error number }
|
|
|
|
|
|
{procedure Error2 (loc, err: integer); {debug}
|
|
|
|
{ flag an error }
|
|
{ }
|
|
{ loc - error location }
|
|
{ err - error number }
|
|
|
|
|
|
procedure UnexpectedTokenError (expectedToken: tokenEnum);
|
|
|
|
{ flag an error for an unexpected token }
|
|
{ }
|
|
{ expectedToken - what was expected }
|
|
|
|
|
|
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 }
|
|
|
|
|
|
procedure NextToken;
|
|
|
|
{ Read the next token from the file. }
|
|
|
|
|
|
procedure PutBackToken (var token: tokenType; expandEnabled: boolean);
|
|
|
|
{ place a token into the token stream }
|
|
{ }
|
|
{ parameters: }
|
|
{ token - token to put back into the token stream }
|
|
{ expandEnabled - can macro expansion be performed? }
|
|
|
|
|
|
procedure TermScanner;
|
|
|
|
{ Shut down the scanner. }
|
|
|
|
procedure WriteLine;
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
const
|
|
{special key values}
|
|
{------------------}
|
|
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 = 155; {maximum lint error code}
|
|
|
|
type
|
|
errorType = record {record of a single error}
|
|
num: integer; {error number}
|
|
line: integer; {line number}
|
|
col: integer; {column number}
|
|
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: integer; {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?}
|
|
end;
|
|
|
|
var
|
|
dateStr: longStringPtr; {macro date string}
|
|
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[5]; {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}
|
|
needWriteLine: boolean; {is there a line that needs to be written?}
|
|
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?}
|
|
timeStr: longStringPtr; {macro time string}
|
|
tokenColumn: 0..maxint; {column number at start of this token}
|
|
tokenLine: 0..maxint; {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 }
|
|
|
|
|
|
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. }
|
|
|
|
{-- 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. }
|
|
|
|
|
|
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
|
|
IsDefined := true;
|
|
goto 1;
|
|
end; {if}
|
|
mPtr := mPtr^.next;
|
|
end; {while}
|
|
1:
|
|
macroFound := mPtr;
|
|
end; {IsDefined}
|
|
|
|
|
|
procedure PutBackToken {var token: tokenType; expandEnabled: boolean};
|
|
|
|
{ place a token into the token stream }
|
|
{ }
|
|
{ parameters: }
|
|
{ token - token to put back into the token stream }
|
|
{ expandEnabled - can macro expansion be performed? }
|
|
|
|
var
|
|
tPtr: tokenListRecordPtr; {work pointer}
|
|
|
|
begin {PutBackToken}
|
|
new(tPtr);
|
|
tPtr^.next := tokenList;
|
|
tokenList := tPtr;
|
|
tPtr^.token := token;
|
|
tPtr^.expandEnabled := expandEnabled;
|
|
tPtr^.tokenStart := tokenStart;
|
|
tPtr^.tokenEnd := tokenEnd;
|
|
end; {PutBackToken}
|
|
|
|
|
|
procedure WriteLine;
|
|
|
|
{ Write the current character to the screen. }
|
|
{ }
|
|
{ Global Variables: }
|
|
{ firstPtr - points to the first char in the line }
|
|
{ chPtr - points to the end of line character }
|
|
|
|
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 then begin
|
|
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(' ');
|
|
if lineNumber >= 10000 then
|
|
write(' ');
|
|
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
|
|
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 structure or union 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: 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 cc= option on command line';
|
|
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 type';
|
|
118: msg := @'flexible array must be last member of structure';
|
|
119: msg := @'inline specifier is only allowed on functions';
|
|
120: msg := @'non-static inline functions 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 := @'ORCA/C cannot evaluate this constant expression with long long operand(s)';
|
|
otherwise: Error(57);
|
|
end; {case}
|
|
writeln(msg^);
|
|
if terminalErrors and (numErrors <> 0)
|
|
and (lintIsError or not (num in lintErrors)) then begin
|
|
if enterEditor then begin
|
|
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}
|
|
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}
|
|
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}
|
|
|
|
begin {PrintToken}
|
|
case token.kind of
|
|
typedef,
|
|
ident: write(token.name^);
|
|
|
|
intconst,
|
|
uintconst: write(token.ival:1);
|
|
|
|
longConst,
|
|
ulongConst: write(token.lval:1);
|
|
|
|
longlongConst,
|
|
ulonglongConst: write('0x...'); {TODO implement}
|
|
|
|
doubleConst: write(token.rval:1);
|
|
|
|
stringConst: begin
|
|
write('"');
|
|
for i := 1 to token.sval^.length 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}
|
|
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('-');
|
|
|
|
uand: write('+');
|
|
|
|
uasterisk: write('*');
|
|
|
|
macroParm: write('$', token.pnum:1);
|
|
|
|
poundpoundop,
|
|
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 (scanWork: boolean); forward;
|
|
|
|
{ The current character starts a number - scan it }
|
|
{ }
|
|
{ Parameters: }
|
|
{ scanWork - get characters from workString? }
|
|
{ }
|
|
{ Globals: }
|
|
{ ch - first character in sequence; set to first char }
|
|
{ after sequence }
|
|
{ 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 }
|
|
|
|
|
|
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 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 }
|
|
{ }
|
|
{ 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;
|
|
if len > 255 then
|
|
len := 255;
|
|
pstr^[0] := chr(len);
|
|
for i := 1 to len do
|
|
pstr^[i] := lstr^.str[i];
|
|
end; {LongToPString}
|
|
|
|
|
|
procedure Merge (var tk1: tokenType; tk2: tokenType);
|
|
|
|
{ Merge two tokens }
|
|
{ }
|
|
{ Parameters: }
|
|
{ tk1 - first token; result is stored here }
|
|
{ tk2 - second token }
|
|
|
|
label 1;
|
|
|
|
var
|
|
class1,class2: tokenClass; {token classes}
|
|
cp: longstringPtr; {pointer to work string}
|
|
i: integer; {loop variable}
|
|
kind1,kind2: tokenEnum; {token kinds}
|
|
len,len1: integer; {length of strings}
|
|
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 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.name := @workString;
|
|
token.symbolPtr := nil;
|
|
CheckIdentifier;
|
|
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 begin
|
|
Error(63);
|
|
goto 1;
|
|
end; {else}
|
|
workString := concat(tk1.numString^, str2^);
|
|
lt := token;
|
|
DoNumber(true);
|
|
tk1 := token;
|
|
token := lt;
|
|
goto 1;
|
|
end {else if class1 in numericConstants}
|
|
|
|
else if class1 = stringConstant then begin
|
|
if class2 = stringConstant then begin
|
|
len1 := tk1.sval^.length;
|
|
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-1);
|
|
tk1.sval := cp;
|
|
goto 1;
|
|
end; {if}
|
|
end {else if}
|
|
|
|
else if kind1 = dotch then begin
|
|
if class2 in numericConstants then begin
|
|
workString := concat(tk1.numString^, tk2.numString^);
|
|
lt := token;
|
|
DoNumber(true);
|
|
tk1 := token;
|
|
token := lt;
|
|
goto 1;
|
|
end; {if}
|
|
end {else if class1 in numericConstants}
|
|
|
|
else if kind1 = poundch then begin
|
|
if kind2 = poundch 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}
|
|
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}
|
|
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}
|
|
|
|
Error(63);
|
|
1:
|
|
end; {Merge}
|
|
|
|
|
|
procedure BuildStringToken (cp: ptr; len: integer);
|
|
|
|
{ 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 }
|
|
|
|
var
|
|
i: integer; {loop variable}
|
|
|
|
begin {BuildStringToken}
|
|
token.kind := stringconst;
|
|
token.class := stringConstant;
|
|
token.ispstring := false;
|
|
token.sval := pointer(GMalloc(len+2));
|
|
for i := 1 to len do begin
|
|
token.sval^.str[i] := chr(cp^);
|
|
cp := pointer(ord4(cp)+1);
|
|
end; {for}
|
|
token.sval^.length := len;
|
|
PutBackToken(token, true);
|
|
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 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 }
|
|
|
|
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}
|
|
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
|
|
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}
|
|
lPrintMacroExpansions := printMacroExpansions; {inhibit token printing}
|
|
printMacroExpansions := false;
|
|
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
|
|
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);
|
|
Error(12);
|
|
end; {if}
|
|
end {if}
|
|
else begin
|
|
Error(13);
|
|
if not gettingFileName then {put back the source stream token}
|
|
PutBackToken(token, true);
|
|
end; {else}
|
|
end; {if}
|
|
if macro^.readOnly then begin {handle special macros}
|
|
case macro^.algorithm of
|
|
|
|
1: begin {__LINE__}
|
|
token.kind := intconst;
|
|
token.numString := @lineStr;
|
|
token.class := intconstant;
|
|
token.ival := lineNumber;
|
|
lineStr := cnvis(token.ival);
|
|
tokenStart := @lineStr[1];
|
|
tokenEnd := pointer(ord4(tokenStart)+length(lineStr));
|
|
end;
|
|
|
|
2: begin {__FILE__}
|
|
token.kind := stringConst;
|
|
token.class := stringConstant;
|
|
token.ispstring := false;
|
|
sp := pointer(Malloc(5+sourceFileGS.theString.size));
|
|
sp^.length := sourceFileGS.theString.size;
|
|
for i := 1 to sourceFileGS.theString.size do
|
|
sp^.str[i] := sourceFileGS.theString.theString[i];
|
|
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.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.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;
|
|
oneStr := '1';
|
|
tokenStart := @oneStr[1];
|
|
tokenEnd := pointer(ord4(tokenStart)+1);
|
|
end;
|
|
|
|
6: begin {__VERSION__}
|
|
token.kind := stringConst;
|
|
token.class := stringConstant;
|
|
token.ispstring := false;
|
|
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;
|
|
|
|
otherwise: Error(57);
|
|
|
|
end; {case}
|
|
PutBackToken(token, true);
|
|
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);
|
|
while tcPtr <> nil do begin
|
|
if tcPtr^.token.kind = stringconst then begin
|
|
BuildStringToken(@quoteStr[1], 1);
|
|
BuildStringToken(@tcPtr^.token.sval^.str,
|
|
tcPtr^.token.sval^.length);
|
|
BuildStringToken(@quoteStr[1], 1);
|
|
end {if}
|
|
else begin
|
|
if tcPtr <> pptr^.tokens then
|
|
if charKinds[tcPtr^.tokenEnd^] = ch_white then
|
|
BuildStringToken(@spaceStr[1], 1);
|
|
BuildStringToken(tcPtr^.tokenStart,
|
|
ord(ord4(tcPtr^.tokenEnd)-ord4(tcPtr^.tokenStart)));
|
|
|
|
{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);
|
|
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
|
|
tlPtr^.next := tlPtr^.next^.next;
|
|
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);
|
|
end; {else}
|
|
end {if}
|
|
else
|
|
PutBackToken(tcPtr^.token, true);
|
|
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);
|
|
end; {else}
|
|
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}
|
|
printMacroExpansions := lPrintMacroExpansions;
|
|
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;
|
|
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 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}
|
|
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);
|
|
WriteLine; {write the source line}
|
|
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);
|
|
ReadFile; {read the file}
|
|
chPtr := bofPtr; {set the start, end pointers}
|
|
eofPtr := pointer(ord4(bofPtr)+ffDCBGS.fileLength);
|
|
firstPtr := chPtr; {first char in line}
|
|
ch := chr(RETURN); {set the initial character}
|
|
if languageNumber <> long(ffDCBGS.auxType).lsw then begin
|
|
switchLanguages := true; {switch languages}
|
|
chPtr := eofPtr;
|
|
if doInclude then
|
|
TermError(7);
|
|
if fileList <> nil then
|
|
TermError(8);
|
|
end; {if}
|
|
end {if}
|
|
else
|
|
OpenFile := false; {we failed to opened it}
|
|
end; {OpenFile}
|
|
|
|
|
|
procedure PreProcess;
|
|
|
|
{ Handle preprocessor commands }
|
|
|
|
label 2;
|
|
|
|
var
|
|
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
|
|
lReportEOL: boolean; {local copy of reportEOL}
|
|
tSkipping: boolean; {temp copy of the skipping variable}
|
|
val: integer; {expression value}
|
|
nextLineNumber: integer; {number for next line}
|
|
|
|
|
|
function Defined: boolean;
|
|
|
|
{ See if a macro is defined }
|
|
|
|
begin {Defined}
|
|
expandMacros := false; {block expansions}
|
|
NextToken; {skip the command name}
|
|
if token.class in [reservedWord,identifier] then begin
|
|
Defined := IsDefined(token.name); {see if the macro is defined}
|
|
expandMacros := true; {enable expansions}
|
|
NextToken; {skip the macro name}
|
|
if token.kind <> eolsy then {check for extra stuff on the line}
|
|
Error(11);
|
|
end {if}
|
|
else
|
|
Error(9);
|
|
end; {Defined}
|
|
|
|
|
|
procedure NumericDirective;
|
|
|
|
{ Process a constant expression for a directive that has a }
|
|
{ single number as the operand. }
|
|
{ }
|
|
{ Notes: The expression evaluator returns the value in the }
|
|
{ global variable expressionValue. }
|
|
|
|
begin {NumericDirective}
|
|
doingPPExpression := true;
|
|
NextToken; {skip the directive name}
|
|
Expression(preprocessorExpression, []); {evaluate the expression}
|
|
doingPPExpression := false;
|
|
end; {NumericDirective}
|
|
|
|
|
|
procedure ProcessIf (skip: boolean);
|
|
|
|
{ handle the processing for #if, #ifdef and #ifndef }
|
|
{ }
|
|
{ parameter: }
|
|
{ skip - should we skip to the #else }
|
|
|
|
var
|
|
ip: ifPtr; {used to create a new if record}
|
|
|
|
begin {ProcessIf}
|
|
if token.kind <> eolsy then {check for extra stuff on the line}
|
|
if not tSkipping then
|
|
Error(11);
|
|
new(ip); {create a new if record}
|
|
ip^.next := ifList;
|
|
ifList := ip;
|
|
if tSkipping then {set the status of the record}
|
|
ip^.status := skippingToEndif
|
|
else if skip then
|
|
ip^.status := skippingToElse
|
|
else
|
|
ip^.status := processing;
|
|
ip^.elseFound := false; {no else has been found...}
|
|
tSkipping := ip^.status <> processing; {decide if we should be skipping}
|
|
end; {ProcessIf}
|
|
|
|
|
|
procedure DoAppend;
|
|
|
|
{ #append }
|
|
|
|
var
|
|
tbool: boolean; {temp boolean}
|
|
|
|
begin {DoAppend}
|
|
tbool := OpenFile(false, false); {open a new file and proceed from there}
|
|
lineNumber := 1;
|
|
end; {DoAppend}
|
|
|
|
|
|
procedure DoCDA;
|
|
|
|
{ #pragma cda NAME START SHUTDOWN }
|
|
|
|
begin {DoCDA}
|
|
FlagPragmas(p_cda);
|
|
isClassicDeskAcc := true;
|
|
NextToken; {skip the command name}
|
|
if token.kind = stringconst then {get the name}
|
|
begin
|
|
LongToPString(@menuLine, token.sval);
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isClassicDeskAcc := false;
|
|
Error(83);
|
|
end; {else}
|
|
if token.kind = ident then begin {get the start name}
|
|
openName := token.name;
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isClassicDeskAcc := false;
|
|
Error(9);
|
|
end; {else}
|
|
if token.kind = ident then begin {get the shutdown name}
|
|
closeName := token.name;
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isClassicDeskAcc := false;
|
|
Error(9);
|
|
end; {else}
|
|
if token.kind <> eolsy then {make sure there is nothing else on the line}
|
|
Error(11);
|
|
end; {DoCDA}
|
|
|
|
|
|
procedure DoCDev;
|
|
|
|
{ #pragma cdev START }
|
|
|
|
begin {DoCDev}
|
|
FlagPragmas(p_cdev);
|
|
isCDev := true;
|
|
NextToken; {skip the command name}
|
|
if token.kind = ident then begin {get the start name}
|
|
openName := token.name;
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isCDev := false;
|
|
Error(9);
|
|
end; {else}
|
|
if token.kind <> eolsy then {make sure there is nothing else on the line}
|
|
Error(11);
|
|
end; {DoCDev}
|
|
|
|
|
|
procedure DoDefine;
|
|
|
|
{ #define }
|
|
{ }
|
|
{ The way parameters are handled is a bit obtuse. Parameters }
|
|
{ have their own token type, with the token having an }
|
|
{ associated parameter number, pnum. Pnum is the number of }
|
|
{ parameters to skip to get to the parameter in the parameter }
|
|
{ list. }
|
|
{ }
|
|
{ In the macro record, parameters indicates how many }
|
|
{ parameters there are in the definition. -1 indicates that }
|
|
{ there is no parameter list, while 0 indicates that a list }
|
|
{ must exist, but that there are no parameters in the list. }
|
|
|
|
label 1,2,3;
|
|
|
|
type
|
|
stringListPtr = ^stringList;
|
|
stringList = record {for the parameter list}
|
|
next: stringListPtr;
|
|
str: pString;
|
|
end;
|
|
|
|
var
|
|
bPtr: ^macroRecordPtr; {pointer to head of hash bucket}
|
|
done: boolean; {used to test for loop termination}
|
|
i: integer; {loop variable}
|
|
mf: macroRecordPtr; {pointer to existing macro record}
|
|
mPtr: macroRecordPtr; {pointer to new macro record}
|
|
np: stringListPtr; {new parameter}
|
|
parameterList: stringListPtr; {list of parameter names}
|
|
parameters: integer; {local copy of mPtr^.parameters}
|
|
ple: stringListPtr; {pointer to the last element in parameterList}
|
|
pnum: integer; {for counting parameters}
|
|
tPtr,tk1,tk2: tokenListRecordPtr; {pointer to a token}
|
|
|
|
{for building token strings}
|
|
sptr: longStringPtr; {token string work pointer}
|
|
tcp: ptr; {temp character pointer}
|
|
slen: integer; {token string length}
|
|
|
|
begin {DoDefine}
|
|
expandMacros := false; {block expansions}
|
|
saveNumber := true; {save characters in numeric tokens}
|
|
parameterList := nil; {no parameters yet}
|
|
NextToken; {get the token name}
|
|
{convert reserved words to identifiers}
|
|
if token.class = reservedWord then begin
|
|
token.name := @reservedWords[token.kind];
|
|
token.kind := ident;
|
|
token.class := identifier;
|
|
end {if}
|
|
else if token.kind = typedef then
|
|
token.kind := ident;
|
|
|
|
if token.kind = ident then begin {we have a name...}
|
|
mPtr := pointer(GMalloc(sizeof(macroRecord))); {create a macro record}
|
|
mPtr^.name := token.name; {record the name}
|
|
mPtr^.saved := false; {not saved in symbol file}
|
|
mPtr^.tokens := nil; {no tokens yet}
|
|
mPtr^.isVarargs := false; {not varargs (yet)}
|
|
charKinds[ord('#')] := ch_pound; {allow # as a token}
|
|
if ch = '(' then begin {scan the parameter list...}
|
|
NextToken; {done with the name token...}
|
|
NextToken; {skip the opening '('}
|
|
parameters := 0; {no parameters yet}
|
|
ple := nil;
|
|
repeat {get the parameter names}
|
|
done := true;
|
|
|
|
if token.class = reservedWord then begin
|
|
token.name := @reservedWords[token.kind];
|
|
token.kind := ident;
|
|
token.class := identifier;
|
|
end {if}
|
|
else if token.kind = typedef then
|
|
token.kind := ident;
|
|
|
|
if token.kind = ident then begin
|
|
new(np);
|
|
np^.next := nil;
|
|
np^.str := token.name^;
|
|
if ple = nil then
|
|
parameterList := np
|
|
else
|
|
ple^.next := np;
|
|
ple := np;
|
|
NextToken;
|
|
parameters := parameters+1;
|
|
if token.kind = commach then begin
|
|
NextToken;
|
|
done := false;
|
|
end; {if}
|
|
end {if}
|
|
else if token.kind = dotch then begin
|
|
NextToken;
|
|
if token.kind = dotch then begin
|
|
NextToken;
|
|
if token.kind = dotch then
|
|
NextToken
|
|
else
|
|
Error(89);
|
|
end
|
|
else
|
|
Error(89);
|
|
new(np);
|
|
np^.next := nil;
|
|
np^.str := '__VA_ARGS__';
|
|
if ple = nil then
|
|
parameterList := np
|
|
else
|
|
ple^.next := np;
|
|
ple := np;
|
|
parameters := parameters + 1;
|
|
mPtr^.isVarargs := true;
|
|
end; {else}
|
|
until done;
|
|
if token.kind = rparench then {insist on a matching ')'}
|
|
NextToken
|
|
else
|
|
Error(12);
|
|
end {if}
|
|
else begin
|
|
parameters := -1; {no parameter list exists}
|
|
NextToken; {done with the name token...}
|
|
end; {else}
|
|
mPtr^.parameters := parameters; {record the # of parameters}
|
|
while token.kind <> eolsy do begin {place tokens in the replace list...}
|
|
|
|
if token.class = reservedWord then begin
|
|
token.name := @reservedWords[token.kind];
|
|
token.kind := ident;
|
|
token.class := identifier;
|
|
end {if}
|
|
else if token.kind = typedef then
|
|
token.kind := ident;
|
|
|
|
if token.kind = ident then begin {special handling for identifiers}
|
|
np := parameterList; {change parameters to macroParm}
|
|
pnum := 0;
|
|
while np <> nil do begin
|
|
if np^.str = token.name^ then begin
|
|
token.kind := macroParm;
|
|
token.class := macroParameter;
|
|
token.pnum := pnum;
|
|
goto 1;
|
|
end; {if}
|
|
pnum := pnum+1;
|
|
np := np^.next;
|
|
end; {while}
|
|
end; {if}
|
|
1: tPtr := pointer(GMalloc(sizeof(tokenListRecord)));
|
|
tPtr^.next := mPtr^.tokens;
|
|
mPtr^.tokens := tPtr;
|
|
tPtr^.token := token;
|
|
tPtr^.tokenStart := tokenStart;
|
|
tPtr^.tokenEnd := tokenEnd;
|
|
tPtr^.expandEnabled := true;
|
|
slen := ord(ord4(chPtr) - ord4(tokenStart));
|
|
sptr := pointer(GMalloc(slen+2));
|
|
sptr^.length := slen;
|
|
tcp := tokenStart;
|
|
for i := 1 to slen do begin
|
|
sptr^.str[i] := chr(tcp^);
|
|
tcp := pointer(ord4(tcp)+1);
|
|
end; {for}
|
|
tPtr^.tokenString := sptr;
|
|
NextToken;
|
|
end; {while}
|
|
mPtr^.readOnly := false;
|
|
mPtr^.algorithm := 0;
|
|
if IsDefined(mPtr^.name) then begin
|
|
mf := macroFound;
|
|
if mf^.parameters = mPtr^.parameters then begin
|
|
tk1 := mf^.tokens;
|
|
tk2 := mPtr^.tokens;
|
|
while (tk1 <> nil) and (tk2 <> nil) do begin
|
|
if tk1^.token.kind <> tk2^.token.kind then
|
|
goto 3;
|
|
if tk1^.token.class = tk2^.token.class then
|
|
case tk1^.token.class of
|
|
reservedWord, reservedSymbol: ;
|
|
identifier:
|
|
if tk1^.token.name^ <> tk2^.token.name^ then
|
|
goto 3;
|
|
intConstant:
|
|
if tk1^.token.ival <> tk2^.token.ival then
|
|
goto 3;
|
|
longConstant:
|
|
if tk1^.token.lval <> tk2^.token.lval then
|
|
goto 3;
|
|
longlongConstant:
|
|
if (tk1^.token.qval.lo <> tk2^.token.qval.lo) or
|
|
(tk1^.token.qval.hi <> tk2^.token.qval.hi) then
|
|
goto 3;
|
|
doubleConstant:
|
|
if tk1^.token.rval <> tk2^.token.rval then
|
|
goto 3;
|
|
stringConstant: begin
|
|
if tk1^.token.sval^.length <> tk2^.token.sval^.length
|
|
then goto 3;
|
|
for i := 1 to tk1^.token.sval^.length do
|
|
if tk1^.token.sval^.str[i] <>
|
|
tk2^.token.sval^.str[i] then
|
|
goto 3;
|
|
end;
|
|
macroParameter:
|
|
if tk1^.token.pnum <> tk2^.token.pnum then
|
|
goto 3;
|
|
otherwise:
|
|
Error(57);
|
|
end; {case}
|
|
tk1 := tk1^.next;
|
|
tk2 := tk2^.next;
|
|
end; {while}
|
|
if (tk1 = nil) and (tk2 = nil) then
|
|
goto 2;
|
|
end; {if}
|
|
3: Error(5);
|
|
goto 2;
|
|
end; {if}
|
|
{insert the macro in the macro list}
|
|
bPtr := pointer(ord4(macros) + Hash(mPtr^.name));
|
|
mPtr^.next := bPtr^;
|
|
bPtr^ := mPtr;
|
|
end {if}
|
|
else
|
|
Error(9); {identifier expected}
|
|
2:
|
|
expandMacros := true; {enable expansions}
|
|
while parameterList <> nil do begin {dump the parameter names}
|
|
np := parameterList;
|
|
parameterList := np^.next;
|
|
dispose(np);
|
|
end; {while}
|
|
charKinds[ord('#')] := illegal; {don't allow # as a token}
|
|
saveNumber := false; {stop saving numeric strings}
|
|
end; {DoDefine}
|
|
|
|
|
|
procedure DoElif;
|
|
|
|
{ #elif expression }
|
|
|
|
var
|
|
ip: ifPtr; {temp; for efficiency}
|
|
|
|
begin {DoElif}
|
|
ip := ifList;
|
|
if ip <> nil then begin
|
|
{decide if we should be skipping}
|
|
tSkipping := ip^.status <> skippingToElse;
|
|
if tSkipping then
|
|
ip^.status := skippingToEndif
|
|
else begin
|
|
{evaluate the condition}
|
|
NumericDirective; {evaluate the condition}
|
|
if token.kind <> eolsy then {check for extra stuff on the line}
|
|
Error(11);
|
|
if expressionValue = 0 then
|
|
ip^.status := skippingToElse
|
|
else
|
|
ip^.status := processing;
|
|
tSkipping := ip^.status <> processing; {decide if we should be skipping}
|
|
end; {else}
|
|
end
|
|
else
|
|
Error(20);
|
|
end; {DoElif}
|
|
|
|
|
|
procedure DoElse;
|
|
|
|
{ #else }
|
|
|
|
begin {DoElse}
|
|
NextToken; {skip the command name}
|
|
if token.kind <> eolsy then {check for extra stuff on the line}
|
|
Error(11);
|
|
if ifList <> nil then begin
|
|
if ifList^.elseFound then {check for multiple elses}
|
|
Error(19)
|
|
else
|
|
ifList^.elseFound := true;
|
|
{decide if we should be skipping}
|
|
tSkipping := ifList^.status <> skippingToElse;
|
|
if tSkipping then {set the status}
|
|
ifList^.status := skippingToEndif
|
|
else
|
|
ifList^.status := processing;
|
|
end
|
|
else
|
|
Error(20);
|
|
end; {DoElse}
|
|
|
|
|
|
procedure DoEndif;
|
|
|
|
{ #endif }
|
|
|
|
var
|
|
ip: ifPtr; {used to create a new if record}
|
|
|
|
begin {DoEndif}
|
|
if ifList <> nil then begin
|
|
ip := ifList; {remove the top if record from the list}
|
|
ifList := ip^.next;
|
|
dispose(ip);
|
|
if ifList = nil then {decide if we should be skipping}
|
|
tSkipping := false
|
|
else
|
|
tSkipping := ifList^.status <> processing;
|
|
end {if}
|
|
else
|
|
Error(20);
|
|
NextToken; {skip the command name}
|
|
if token.kind <> eolsy then {check for extra stuff on the line}
|
|
if not allowTokensAfterEndif then
|
|
Error(11);
|
|
end; {DoEndif}
|
|
|
|
|
|
procedure DoError (isError: boolean);
|
|
|
|
{ #error pp-tokens(opt) }
|
|
|
|
var
|
|
i: integer; {loop variable}
|
|
len: integer; {string length}
|
|
msg: stringPtr; {error message ptr}
|
|
cp: ptr; {character pointer}
|
|
lFirstPtr: ptr; {local copy of firstPtr}
|
|
|
|
begin {DoError}
|
|
lFirstPtr := firstPtr;
|
|
if isError then
|
|
numErrors := numErrors+1;
|
|
new(msg);
|
|
if isError then
|
|
msg^ := '#error:'
|
|
else
|
|
msg^ := '#warning:';
|
|
NextToken; {skip the command name}
|
|
while not (token.kind in [eolsy, eofsy]) do begin
|
|
msg^ := concat(msg^, ' ');
|
|
if token.kind = stringConst then begin
|
|
len := token.sval^.length;
|
|
for i := 1 to len do
|
|
msg^ := concat(msg^, token.sval^.str[i]);
|
|
end {if}
|
|
else begin
|
|
len := ord(ord4(tokenEnd) - ord4(tokenStart));
|
|
cp := tokenStart;
|
|
for i := 1 to len do begin
|
|
msg^ := concat(msg^, chr(cp^));
|
|
cp := pointer(ord4(cp)+1);
|
|
end; {for}
|
|
end; {else}
|
|
NextToken;
|
|
end; {while}
|
|
writeln(msg^);
|
|
if isError and terminalErrors then begin
|
|
if enterEditor then
|
|
ExitToEditor(msg, ord4(lFirstPtr)-ord4(bofPtr))
|
|
else
|
|
TermError(0);
|
|
end; {if}
|
|
end; {DoError}
|
|
|
|
|
|
procedure DoFloat;
|
|
|
|
{ #pragma float NUMBER NUMBER }
|
|
|
|
begin {DoFloat}
|
|
FlagPragmas(p_float);
|
|
NextToken;
|
|
if token.kind in [intconst,uintconst] then begin
|
|
floatCard := token.ival;
|
|
NextToken;
|
|
end {if}
|
|
else
|
|
Error(18);
|
|
if token.kind in [intconst,uintconst] then begin
|
|
floatSlot := $C080 | (token.ival << 4);
|
|
NextToken;
|
|
end {if}
|
|
else
|
|
Error(18);
|
|
end; {DoFloat}
|
|
|
|
|
|
procedure DoKeep;
|
|
|
|
{ #pragma keep FILENAME }
|
|
|
|
begin {DoKeep}
|
|
FlagPragmas(p_keep);
|
|
if GetFileName(false) then begin {read the file name}
|
|
if foundFunction then
|
|
Error(17);
|
|
if liDCBGS.kFlag = 0 then begin {use the old name if there is one...}
|
|
liDCBGS.kFlag := 1;
|
|
outFileGS.theString.theString := workString;
|
|
outFileGS.theString.size := length(workString);
|
|
end; {if}
|
|
end; {if}
|
|
end; {DoKeep}
|
|
|
|
|
|
procedure DoNBA;
|
|
|
|
{ #pragma nba MAIN }
|
|
|
|
begin {DoNBA}
|
|
FlagPragmas(p_nba);
|
|
isNBA := true;
|
|
NextToken; {skip the command name}
|
|
if token.kind = ident then begin {get the open name}
|
|
openName := token.name;
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isNBA := false;
|
|
Error(9);
|
|
end; {else}
|
|
if token.kind <> eolsy then {make sure there is nothing else on the line}
|
|
Error(11);
|
|
end; {DoNBA}
|
|
|
|
|
|
procedure DoNDA;
|
|
|
|
{ #pragma nda OPEN CLOSE ACTION INIT PERIOD EVENTMASK MENULINE}
|
|
|
|
|
|
function GetInteger: integer;
|
|
|
|
{ Get a signed integer constant }
|
|
|
|
var
|
|
isNegative: boolean; {is the value negative?}
|
|
value: integer; {value to return}
|
|
|
|
begin {GetInteger}
|
|
isNegative := false;
|
|
value := 0;
|
|
if token.kind = plusch then
|
|
NextToken
|
|
else if token.kind = minusch then begin
|
|
NextToken;
|
|
isNegative := true;
|
|
end; {else if}
|
|
if token.kind in [intconst,uintconst] then begin
|
|
value := token.ival;
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isNewDeskAcc := false;
|
|
Error(18);
|
|
end; {else}
|
|
if isNegative then
|
|
GetInteger := -value
|
|
else
|
|
GetInteger := value;
|
|
end; {GetInteger}
|
|
|
|
|
|
begin {DoNDA}
|
|
FlagPragmas(p_nda);
|
|
isNewDeskAcc := true;
|
|
NextToken; {skip the command name}
|
|
if token.kind = ident then begin {get the open name}
|
|
openName := token.name;
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isNewDeskAcc := false;
|
|
Error(9);
|
|
end; {else}
|
|
if token.kind = ident then begin {get the close name}
|
|
closeName := token.name;
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isNewDeskAcc := false;
|
|
Error(9);
|
|
end; {else}
|
|
if token.kind = ident then begin {get the action name}
|
|
actionName := token.name;
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isNewDeskAcc := false;
|
|
Error(9);
|
|
end; {else}
|
|
if token.kind = ident then begin {get the init name}
|
|
initName := token.name;
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isNewDeskAcc := false;
|
|
Error(9);
|
|
end; {else}
|
|
refreshPeriod := GetInteger; {get the period}
|
|
eventMask := GetInteger; {get the event Mask}
|
|
if token.kind = stringconst then {get the name}
|
|
begin
|
|
LongToPString(@menuLine, token.sval);
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isNewDeskAcc := false;
|
|
Error(83);
|
|
end; {else}
|
|
if token.kind <> eolsy then {make sure there is nothing else on the line}
|
|
Error(11);
|
|
end; {DoNDA}
|
|
|
|
|
|
procedure DoUndef;
|
|
|
|
{ #undef }
|
|
|
|
label 1;
|
|
|
|
var
|
|
bPtr: ^macroRecordPtr; {hash bucket pointer}
|
|
mPtr,lastPtr: macroRecordPtr; {work pointers}
|
|
|
|
begin {DoUndef}
|
|
expandMacros := false; {block expansions}
|
|
NextToken; {get the token name}
|
|
{convert reserved words to identifiers}
|
|
if token.class = reservedWord then begin
|
|
token.name := @reservedWords[token.kind];
|
|
token.kind := ident;
|
|
token.class := identifier;
|
|
end; {if}
|
|
if token.kind = ident then begin
|
|
{find the bucket to search}
|
|
bPtr := pointer(ord4(macros)+Hash(token.name));
|
|
lastPtr := nil; {find and delete the macro entry}
|
|
mPtr := bPtr^;
|
|
while mPtr <> nil do begin
|
|
if mPtr^.name^ = token.name^ then begin
|
|
if mPtr^.readOnly then
|
|
Error(10)
|
|
else begin
|
|
if lastPtr = nil then
|
|
bPtr^ := mPtr^.next
|
|
else
|
|
lastPtr^.next := mPtr^.next;
|
|
end; {else}
|
|
goto 1;
|
|
end; {if}
|
|
lastPtr := mPtr;
|
|
mPtr := mPtr^.next;
|
|
end; {while}
|
|
end {if}
|
|
else
|
|
Error(9); {identifier expected}
|
|
1:
|
|
expandMacros := true; {enable expansions}
|
|
NextToken; {skip the macro name}
|
|
if token.kind <> eolsy then {make sure there's no junk on the line}
|
|
Error(11);
|
|
end; {DoUndef}
|
|
|
|
|
|
procedure DoXCMD;
|
|
|
|
{ #pragma xcmd MAIN }
|
|
|
|
begin {DoXCMD}
|
|
FlagPragmas(p_xcmd);
|
|
isXCMD := true;
|
|
NextToken; {skip the command name}
|
|
if token.kind = ident then begin {get the open name}
|
|
openName := token.name;
|
|
NextToken;
|
|
end {if}
|
|
else begin
|
|
isXCMD := false;
|
|
Error(9);
|
|
end; {else}
|
|
if token.kind <> eolsy then {make sure there is nothing else on the line}
|
|
Error(11);
|
|
end; {DoXCMD}
|
|
|
|
|
|
begin {PreProcess}
|
|
lPrintMacroExpansions := printMacroExpansions; {inhibit token printing}
|
|
printMacroExpansions := false;
|
|
lReportEOL := reportEOL; {we need to see eol's}
|
|
reportEOL := true;
|
|
tSkipping := skipping; {don't skip the directive name!}
|
|
skipping := false;
|
|
nextLineNumber := -1;
|
|
while charKinds[ord(ch)] = ch_white do {skip white space}
|
|
NextCh;
|
|
if ch in ['a','d','e','i','l','p','u','w'] then begin
|
|
NextToken;
|
|
case token.kind of
|
|
ifsy: begin
|
|
if not tSkipping then
|
|
NumericDirective;
|
|
ProcessIf(expressionValue = 0);
|
|
goto 2;
|
|
end;
|
|
elsesy: begin
|
|
DoElse;
|
|
goto 2;
|
|
end;
|
|
ident: begin
|
|
case token.name^[1] of
|
|
'a':
|
|
if token.name^ = 'append' then begin
|
|
if tskipping then goto 2;
|
|
DoAppend;
|
|
goto 2;
|
|
end; {if}
|
|
'd':
|
|
if token.name^ = 'define' then begin
|
|
if tskipping then goto 2;
|
|
DoDefine;
|
|
goto 2;
|
|
end; {if}
|
|
'e':
|
|
if token.name^ = 'endif' then begin
|
|
DoEndif;
|
|
goto 2;
|
|
end {if}
|
|
else if token.name^ = 'else' then begin
|
|
DoElse;
|
|
goto 2;
|
|
end {else if}
|
|
else if token.name^ = 'elif' then begin
|
|
DoElif;
|
|
goto 2;
|
|
end {else if}
|
|
else if token.name^ = 'error' then begin
|
|
if tskipping then goto 2;
|
|
DoError(true);
|
|
goto 2;
|
|
end; {else if}
|
|
'i':
|
|
if token.name^ = 'if' then begin
|
|
if not tSkipping then
|
|
NumericDirective;
|
|
ProcessIf(expressionValue = 0);
|
|
goto 2;
|
|
end {if}
|
|
else if token.name^ = 'ifdef' then begin
|
|
if tSkipping then
|
|
ProcessIf(false)
|
|
else
|
|
ProcessIf(not Defined);
|
|
goto 2;
|
|
end {else}
|
|
else if token.name^ = 'ifndef' then begin
|
|
if tSkipping then
|
|
ProcessIf(false)
|
|
else
|
|
ProcessIf(Defined);
|
|
goto 2;
|
|
end {else}
|
|
else if token.name^ = 'include' then begin
|
|
if tskipping then goto 2;
|
|
DoInclude(false);
|
|
goto 2;
|
|
end; {else}
|
|
'l':
|
|
if token.name^ = 'line' then begin
|
|
if tskipping then goto 2;
|
|
FlagPragmas(p_line);
|
|
NextToken;
|
|
if token.kind = intconst then begin
|
|
nextLineNumber := token.ival;
|
|
NextToken;
|
|
end {if}
|
|
else
|
|
Error(18);
|
|
if token.kind = stringconst then begin
|
|
LongToPString(
|
|
pointer(ord4(@sourceFileGS.theString)+1),
|
|
token.sval);
|
|
sourceFileGS.theString.size := token.sval^.length;
|
|
NextToken;
|
|
end; {if}
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
goto 2;
|
|
end; {if}
|
|
'p':
|
|
if token.name^ = 'pragma' then begin
|
|
if tskipping then goto 2;
|
|
NextToken;
|
|
if token.name^ = 'keep' then
|
|
DoKeep
|
|
else if token.name^ = 'debug' then begin
|
|
{ debug bits: }
|
|
{ 1 - range checking }
|
|
{ 2 - create debug code }
|
|
{ 4 - generate profiles }
|
|
{ 8 - generate traceback code }
|
|
{ 16 - check for stack errors }
|
|
FlagPragmas(p_debug);
|
|
NumericDirective;
|
|
if expressionType^.kind = scalarType then
|
|
if expressionType^.baseType in [cgQuad,cgUQuad] then
|
|
expressionValue := llExpressionValue.lo;
|
|
val := long(expressionValue).lsw;
|
|
rangeCheck := odd(val);
|
|
debugFlag := odd(val >> 1);
|
|
profileFlag := odd(val >> 2);
|
|
traceBack := odd(val >> 3);
|
|
checkStack := odd(val >> 4);
|
|
debugStrFlag := odd(val >> 15);
|
|
profileFlag := profileFlag or debugFlag;
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
goto 2;
|
|
end {else}
|
|
else if token.name^ = 'lint' then begin
|
|
FlagPragmas(p_lint);
|
|
NumericDirective;
|
|
if expressionType^.kind = scalarType then
|
|
if expressionType^.baseType in [cgQuad,cgUQuad] then
|
|
expressionValue := llExpressionValue.lo;
|
|
lint := long(expressionValue).lsw;
|
|
lintIsError := true;
|
|
if token.kind = semicolonch then begin
|
|
NumericDirective;
|
|
lintIsError := expressionValue <> 0;
|
|
end; {if}
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
goto 2;
|
|
end {else}
|
|
else if token.name^ = 'memorymodel' then begin
|
|
FlagPragmas(p_memorymodel);
|
|
NumericDirective;
|
|
smallMemoryModel := expressionValue = 0;
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if token.name^ = 'expand' then begin
|
|
FlagPragmas(p_expand);
|
|
NumericDirective;
|
|
lPrintMacroExpansions := expressionValue <> 0;
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if token.name^ = 'optimize' then begin
|
|
{ optimize bits: }
|
|
{ 1 - intermediate code peephole }
|
|
{ 2 - native peephole }
|
|
{ 4 - register value tracking }
|
|
{ 8 - remove stack checks }
|
|
{ 16 - common subexpression elimination }
|
|
{ 32 - loop invariant removal }
|
|
FlagPragmas(p_optimize);
|
|
NumericDirective;
|
|
if expressionType^.kind = scalarType then
|
|
if expressionType^.baseType in [cgQuad,cgUQuad] then
|
|
expressionValue := llExpressionValue.lo;
|
|
val := long(expressionValue).lsw;
|
|
peepHole := odd(val);
|
|
npeepHole := odd(val >> 1);
|
|
registers := odd(val >> 2);
|
|
saveStack := not odd(val >> 3);
|
|
commonSubexpression := odd(val >> 4);
|
|
loopOptimizations := odd(val >> 5);
|
|
strictVararg := not odd(val >> 6);
|
|
if saveStack then
|
|
npeepHole := false;
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if token.name^ = 'unix' then begin
|
|
{ unix bits: }
|
|
{ 1 - int is 32 bits }
|
|
FlagPragmas(p_unix);
|
|
NumericDirective;
|
|
val := long(expressionValue).lsw;
|
|
unix_1 := odd(val);
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if token.name^ = 'stacksize' then begin
|
|
FlagPragmas(p_stacksize);
|
|
NumericDirective;
|
|
stackSize := long(expressionValue).lsw;
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if token.name^ = 'cda' then
|
|
DoCDA
|
|
else if token.name^ = 'cdev' then
|
|
DoCDev
|
|
else if token.name^ = 'nda' then
|
|
DoNDA
|
|
else if token.name^ = 'nba' then
|
|
DoNBA
|
|
else if token.name^ = 'xcmd' then
|
|
DoXCMD
|
|
else if token.name^ = 'toolparms' then begin
|
|
FlagPragmas(p_toolparms);
|
|
NumericDirective;
|
|
toolParms := expressionValue <> 0;
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if token.name^ = 'databank' then begin
|
|
FlagPragmas(p_databank);
|
|
NumericDirective;
|
|
dataBank := expressionValue <> 0;
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if token.name^ = 'float' then
|
|
DoFloat
|
|
else if token.name^ = 'rtl' then begin
|
|
FlagPragmas(p_rtl);
|
|
rtl := true;
|
|
NextToken;
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if token.name^ = 'noroot' then begin
|
|
FlagPragmas(p_noroot);
|
|
noroot := true;
|
|
NextToken;
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
{ else if token.name^ = 'printmacros' then begin {debug}
|
|
{ PrintMacroTable;
|
|
NextToken;
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if token.name^ = 'path' then begin
|
|
NextToken;
|
|
if token.kind = stringConst then begin
|
|
LongToPString(workString, token.sval);
|
|
AddPath(workString);
|
|
NextToken;
|
|
end {if}
|
|
else
|
|
Error(83);
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if token.name^ = 'ignore' then begin
|
|
{ ignore bits: }
|
|
{ 1 - don't flag illegal tokens in skipped source }
|
|
{ 2 - allow long int character constants }
|
|
{ 4 - allow tokens after #endif }
|
|
{ 8 - allow // comments }
|
|
{ 16 - allow mixed decls & use C99 scope rules }
|
|
FlagPragmas(p_ignore);
|
|
NumericDirective;
|
|
if expressionType^.kind = scalarType then
|
|
if expressionType^.baseType in [cgQuad,cgUQuad] then
|
|
expressionValue := llExpressionValue.lo;
|
|
val := long(expressionValue).lsw;
|
|
skipIllegalTokens := odd(val);
|
|
allowLongIntChar := odd(val >> 1);
|
|
allowTokensAfterEndif := odd(val >> 2);
|
|
allowSlashSlashComments := odd(val >> 3);
|
|
allowMixedDeclarations := odd(val >> 4);
|
|
looseCharTypeChecks := odd(val >> 5);
|
|
if allowMixedDeclarations <> c99Scope then begin
|
|
if doingFunction then
|
|
Error(126)
|
|
else
|
|
c99Scope := allowMixedDeclarations;
|
|
end; {if}
|
|
if token.kind <> eolsy then
|
|
Error(11);
|
|
end {else if}
|
|
else if (lint & lintPragmas) <> 0 then
|
|
Error(110);
|
|
goto 2;
|
|
end; {if}
|
|
'u':
|
|
if token.name^ = 'undef' then begin
|
|
if tskipping then goto 2;
|
|
DoUndef;
|
|
goto 2;
|
|
end; {if}
|
|
'w':
|
|
if token.name^ = 'warning' then begin
|
|
if tskipping then goto 2;
|
|
DoError(false);
|
|
goto 2;
|
|
end; {if}
|
|
otherwise: Error(57);
|
|
end; {case}
|
|
end;
|
|
otherwise: ;
|
|
end; {case}
|
|
end {if}
|
|
else if charKinds[ord(ch)] = ch_eol {allow null commands}
|
|
then begin
|
|
NextToken;
|
|
goto 2;
|
|
end; {else if}
|
|
if not tSkipping then
|
|
Error(8); {bad preprocessor command}
|
|
2:
|
|
charKinds[ord('#')] := ch_pound; {allow # as a token}
|
|
expandMacros := false; {skip to the end of the line}
|
|
flagOverflows := false;
|
|
skipping := tSkipping;
|
|
while not (token.kind in [eolsy,eofsy]) do
|
|
NextToken;
|
|
flagOverflows := true;
|
|
expandMacros := true;
|
|
charKinds[ord('#')] := illegal; {don't allow # as a token}
|
|
reportEOL := lReportEOL; {restore flags}
|
|
printMacroExpansions := lPrintMacroExpansions;
|
|
skipping := tskipping;
|
|
if nextLineNumber >= 0 then
|
|
lineNumber := nextLineNumber;
|
|
end; {PreProcess}
|
|
|
|
{-- Externally available routines ------------------------------}
|
|
|
|
procedure DoDefaultsDotH;
|
|
|
|
{ Handle the defaults.h file }
|
|
|
|
var
|
|
name: pString; {name of the default file}
|
|
|
|
begin {DoDefaultsDotH}
|
|
name := defaultName;
|
|
if GetFileType(name) <> -1 then
|
|
DoInclude(true);
|
|
end; {DoDefaultsDotH}
|
|
|
|
|
|
procedure Error {err: integer};
|
|
|
|
{ flag an error }
|
|
{ }
|
|
{ err - error number }
|
|
|
|
begin {Error}
|
|
if lintIsError or not (err in lintErrors)
|
|
then begin
|
|
if (numErr <> maxErr) or (numErrors = 0) then
|
|
numErrors := numErrors+1;
|
|
liDCBGS.merrf := 16;
|
|
end {if}
|
|
else
|
|
TermHeader;
|
|
if numErr = maxErr then {set the error number}
|
|
errors[maxErr].num := 4
|
|
else begin
|
|
numErr := numErr+1;
|
|
errors[numErr].num := err;
|
|
end; {else}
|
|
with errors[numErr] do begin {record the position of the error}
|
|
line := tokenLine;
|
|
col := tokenColumn;
|
|
end; {with}
|
|
if numErrors <> 0 then
|
|
codeGeneration := false; {inhibit code generation}
|
|
end; {Error}
|
|
|
|
|
|
{procedure Error2 {loc, err: integer} {debug}
|
|
|
|
{ flag an error }
|
|
{ }
|
|
{ loc - error location }
|
|
{ err - error number }
|
|
|
|
{begin {Error2}
|
|
{writeln('Error ', err:1, ' flagged at location ', loc:1);
|
|
Error(err);
|
|
end; {Error2}
|
|
|
|
|
|
procedure UnexpectedTokenError {expectedToken: tokenEnum};
|
|
|
|
{ flag an error for an unexpected token }
|
|
{ }
|
|
{ expectedToken - what was expected }
|
|
|
|
begin {UnexpectedTokenError}
|
|
case expectedToken of
|
|
ident: Error(9);
|
|
rparench: Error(12);
|
|
lparench: Error(13);
|
|
gtch: Error(15);
|
|
intconst: Error(18);
|
|
semicolonch: Error(22);
|
|
rbracech: Error(23);
|
|
rbrackch: Error(24);
|
|
lbracech: Error(27);
|
|
colonch: Error(29);
|
|
whilesy: Error(30);
|
|
stringconst: Error(83);
|
|
commach: Error(86);
|
|
dotch: Error(89);
|
|
otherwise: Error(140);
|
|
end; {case}
|
|
end; {UnexpectedTokenError}
|
|
|
|
|
|
procedure DoNumber {scanWork: boolean};
|
|
|
|
{ The current character starts a number - scan it }
|
|
{ }
|
|
{ Parameters: }
|
|
{ scanWork - get characters from workString? }
|
|
{ }
|
|
{ Globals: }
|
|
{ ch - first character in sequence; set to first char }
|
|
{ after sequence }
|
|
{ workString - string to take numbers from }
|
|
|
|
label 1;
|
|
|
|
var
|
|
c2: char; {next character to process}
|
|
i: integer; {loop index}
|
|
isBin: boolean; {is the value a binary number?}
|
|
isHex: boolean; {is the value a hex number?}
|
|
isLong: boolean; {is the value a long number?}
|
|
isLongLong: boolean; {is the value a long long number?}
|
|
isReal: boolean; {is the value a real number?}
|
|
numIndex: 0..maxLine; {index into workString}
|
|
sp: stringPtr; {for saving identifier names}
|
|
stringIndex: 0..maxLine; {length of the number string}
|
|
unsigned: boolean; {is the number unsigned?}
|
|
val: integer; {value of a digit}
|
|
c1: char; {saved copy of last character}
|
|
|
|
numString: pString; {characters in the number}
|
|
|
|
|
|
procedure NextChar;
|
|
|
|
{ Return the next character that is a part of the number }
|
|
|
|
begin {NextChar}
|
|
if scanWork then begin
|
|
if ord(workString[0]) <> numIndex then begin
|
|
numIndex := numIndex+1;
|
|
c2 := workString[numIndex];
|
|
end {if}
|
|
else
|
|
c2 := ' ';
|
|
end {if}
|
|
else begin
|
|
NextCh;
|
|
c2 := ch;
|
|
end; {else}
|
|
end; {NextChar}
|
|
|
|
|
|
procedure FlagError (errCode: integer);
|
|
|
|
{ Handle an error when processing a number. Don't report }
|
|
{ errors when skipping code, because pp-numbers in skipped }
|
|
{ code never actually get converted to numeric constants. }
|
|
|
|
begin {FlagError}
|
|
if not skipping then
|
|
Error(errCode);
|
|
end; {FlagError}
|
|
|
|
|
|
procedure GetDigits;
|
|
|
|
{ Read in a digit stream }
|
|
{ }
|
|
{ Variables: }
|
|
{ c2 - next character to process }
|
|
{ numString - digit sequence added to this string }
|
|
{ stringIndex - length of the string }
|
|
|
|
begin {GetDigits}
|
|
while (charKinds[ord(c2)] = digit) or
|
|
(isHex and (c2 in ['a'..'f','A'..'F'])) do begin
|
|
if c2 in ['a'..'f'] then
|
|
c2 := chr(ord(c2) & $5F);
|
|
stringIndex := stringIndex+1;
|
|
if stringIndex > 255 then begin
|
|
FlagError(131);
|
|
stringIndex := 1;
|
|
end; {if}
|
|
numString[stringIndex] := c2;
|
|
NextChar;
|
|
end; {while}
|
|
end; {GetDigits}
|
|
|
|
|
|
procedure ShiftAndOrValue (shiftCount, nextDigit: integer);
|
|
|
|
{ Shift the 64-bit value of token.qval left by shiftCount, }
|
|
{ then binary-or it with nextDigit. }
|
|
|
|
begin {ShiftAndOrValue}
|
|
while shiftCount > 0 do begin
|
|
token.qval.hi := token.qval.hi << 1;
|
|
if (token.qval.lo & $80000000) <> 0 then
|
|
token.qval.hi := token.qval.hi | 1;
|
|
token.qval.lo := token.qval.lo << 1;
|
|
shiftCount := shiftCount - 1;
|
|
end; {while}
|
|
token.qval.lo := token.qval.lo | nextDigit;
|
|
end; {ShiftAndOrValue}
|
|
|
|
|
|
begin {DoNumber}
|
|
isBin := false; {assume it's not binary}
|
|
isHex := false; {assume it's not hex}
|
|
isReal := false; {assume it's an integer}
|
|
isLong := false; {assume a short integer}
|
|
isLongLong := false;
|
|
unsigned := false; {assume signed numbers}
|
|
stringIndex := 0; {no digits so far...}
|
|
if scanWork then begin {set up the scanner}
|
|
numIndex := 0;
|
|
NextChar;
|
|
end {if}
|
|
else
|
|
c2 := ch;
|
|
if c2 = '.' then begin {handle the case of no leading digits}
|
|
stringIndex := 1;
|
|
numString[1] := '0';
|
|
end {if}
|
|
else begin
|
|
GetDigits; {read the leading digit stream}
|
|
if c2 in ['x','X','b','B'] then {detect hex numbers}
|
|
if stringIndex = 1 then
|
|
if numString[1] = '0' then begin
|
|
stringIndex := 2;
|
|
c2 := chr(ord(c2) & $5f);
|
|
numString[2] := c2;
|
|
if c2 = 'X' then isHex := true;
|
|
if c2 = 'B' then isBin := true;
|
|
NextChar;
|
|
GetDigits;
|
|
goto 1;
|
|
end; {if}
|
|
end;
|
|
if c2 = '.' then begin {handle a decimal}
|
|
stringIndex := stringIndex+1;
|
|
numString[stringIndex] := '.';
|
|
NextChar;
|
|
isReal := true;
|
|
if charKinds[ord(c2)] = digit then
|
|
GetDigits
|
|
else if stringIndex = 2 then begin
|
|
numString[3] := '0';
|
|
stringIndex := 3;
|
|
end; {else}
|
|
end; {if}
|
|
if c2 in ['e','E'] then begin {handle an exponent}
|
|
stringIndex := stringIndex+1;
|
|
numString[stringIndex] := 'e';
|
|
NextChar;
|
|
isReal := true;
|
|
if c2 in ['+','-'] then begin
|
|
stringIndex := stringIndex+1;
|
|
numString[stringIndex] := c2;
|
|
NextChar;
|
|
end; {if}
|
|
if c2 in ['0'..'9'] then
|
|
GetDigits
|
|
else begin
|
|
stringIndex := stringIndex+1;
|
|
numString[stringIndex] := '0';
|
|
FlagError(101);
|
|
end; {else}
|
|
end; {if}
|
|
1:
|
|
while c2 in ['l','u','L','U'] do {check for long or unsigned}
|
|
if c2 in ['l','L'] then begin
|
|
if isLong or isLongLong then
|
|
FlagError(156);
|
|
c1 := c2;
|
|
NextChar;
|
|
if c2 = c1 then begin
|
|
NextChar;
|
|
isLongLong := true;
|
|
end {if}
|
|
else
|
|
isLong := true;
|
|
end {if}
|
|
else {if c2 in ['u','U'] then} begin
|
|
NextChar;
|
|
if unsigned then
|
|
FlagError(156)
|
|
else if isReal then
|
|
FlagError(91);
|
|
unsigned := true;
|
|
end; {else}
|
|
if c2 in ['f','F'] then begin {allow F designator on reals}
|
|
if unsigned then
|
|
FlagError(91);
|
|
if isLongLong then
|
|
FlagError(156);
|
|
if not isReal then begin
|
|
FlagError(100);
|
|
isReal := true;
|
|
end; {if}
|
|
NextChar;
|
|
end; {if}
|
|
numString[0] := chr(stringIndex); {set the length of the string}
|
|
if doingPPExpression then
|
|
isLongLong := true;
|
|
if isReal then begin {convert a real constant}
|
|
token.kind := doubleConst;
|
|
token.class := doubleConstant;
|
|
if stringIndex > 80 then begin
|
|
FlagError(131);
|
|
token.rval := 0.0;
|
|
end {if}
|
|
else
|
|
token.rval := cnvsd(numString);
|
|
end {if}
|
|
else if numString[1] <> '0' then begin {convert a decimal integer}
|
|
if (stringIndex > 5)
|
|
or (not unsigned and (stringIndex = 5) and (numString > '32767'))
|
|
or (unsigned and (stringIndex = 5) and (numString > '65535')) then
|
|
isLong := true;
|
|
if (stringIndex > 10)
|
|
or (not unsigned and (stringIndex = 10) and (numString > '2147483647'))
|
|
or (unsigned and (stringIndex = 10) and (numString > '4294967295')) then
|
|
isLongLong := true;
|
|
if (not unsigned and ((stringIndex > 19) or
|
|
((stringIndex = 19) and (numString > '9223372036854775807')))) or
|
|
(unsigned and ((stringIndex > 20) or
|
|
((stringIndex = 20) and (numString > '18446744073709551615')))) then begin
|
|
numString := '0';
|
|
if flagOverflows then
|
|
FlagError(6);
|
|
end; {if}
|
|
if isLongLong then begin
|
|
token.class := longlongConstant;
|
|
Convertsll(token.qval, numString);
|
|
if unsigned then
|
|
token.kind := ulonglongConst
|
|
else begin
|
|
token.kind := longlongConst;
|
|
end; {else}
|
|
end {if}
|
|
else if isLong then begin
|
|
token.class := longConstant;
|
|
token.lval := Convertsl(numString);
|
|
if unsigned then
|
|
token.kind := ulongConst
|
|
else
|
|
token.kind := longConst;
|
|
end {if}
|
|
else begin
|
|
if unsigned then
|
|
token.kind := uintConst
|
|
else
|
|
token.kind := intConst;
|
|
token.class := intConstant;
|
|
token.lval := Convertsl(numString);
|
|
end; {else}
|
|
end {else if}
|
|
else begin {hex, octal, & binary}
|
|
token.qval.lo := 0;
|
|
token.qval.hi := 0;
|
|
if isHex then begin
|
|
i := 3;
|
|
while i <= length(numString) do begin
|
|
if token.qval.hi & $F0000000 <> 0 then begin
|
|
i := maxint;
|
|
if flagOverflows then
|
|
FlagError(6);
|
|
end {if}
|
|
else begin
|
|
if numString[i] > '9' then
|
|
val := (ord(numString[i])-7) & $000F
|
|
else
|
|
val := ord(numString[i]) & $000F;
|
|
ShiftAndOrValue(4, val);
|
|
i := i+1;
|
|
end; {else}
|
|
end; {while}
|
|
end {if}
|
|
else if isBin then begin
|
|
i := 3;
|
|
while i <= length(numString) do begin
|
|
if token.qval.hi & $80000000 <> 0 then begin
|
|
i := maxint;
|
|
if flagOverflows then
|
|
FlagError(6);
|
|
end {if}
|
|
else begin
|
|
if not (numString[i] in ['0','1']) then
|
|
FlagError(121);
|
|
ShiftAndOrValue(1, ord(numString[i]) & $0001);
|
|
i := i+1;
|
|
end; {else}
|
|
end; {while}
|
|
end {if}
|
|
else begin
|
|
i := 1;
|
|
while i <= length(numString) do begin
|
|
if token.qval.hi & $E0000000 <> 0 then begin
|
|
i := maxint;
|
|
if flagOverflows then
|
|
FlagError(6);
|
|
end {if}
|
|
else begin
|
|
if numString[i] in ['8','9'] then
|
|
FlagError(7);
|
|
ShiftAndOrValue(3, ord(numString[i]) & $0007);
|
|
i := i+1;
|
|
end; {else}
|
|
end; {while}
|
|
end; {else}
|
|
if token.qval.hi <> 0 then
|
|
isLongLong := true;
|
|
if not isLongLong then
|
|
if long(token.qval.lo).msw <> 0 then
|
|
isLong := true;
|
|
if isLongLong then begin
|
|
if unsigned or (token.qval.hi & $80000000 <> 0) then
|
|
token.kind := ulonglongConst
|
|
else
|
|
token.kind := longlongConst;
|
|
token.class := longlongConstant;
|
|
end {if}
|
|
else if isLong then begin
|
|
if unsigned or (token.qval.lo & $80000000 <> 0) then
|
|
token.kind := ulongConst
|
|
else
|
|
token.kind := longConst;
|
|
token.class := longConstant;
|
|
end {if}
|
|
else begin
|
|
if (long(token.qval.lo).lsw & $8000) <> 0 then
|
|
unsigned := true;
|
|
if unsigned then
|
|
token.kind := uintConst
|
|
else
|
|
token.kind := intConst;
|
|
token.class := intConstant;
|
|
end; {else}
|
|
end; {else}
|
|
if saveNumber then begin
|
|
sp := pointer(GMalloc(length(numString)+1));
|
|
CopyString(pointer(sp), @numString);
|
|
token.numString := sp;
|
|
end; {if}
|
|
if scanWork then {make sure we read all characters}
|
|
if ord(workString[0]) <> numIndex then
|
|
Error(63);
|
|
end; {DoNumber}
|
|
|
|
|
|
function UniversalCharacterName : ucsCodePoint;
|
|
|
|
{ Scan a universal character name. }
|
|
{ The current character should be the 'u' or 'U'. }
|
|
{ }
|
|
{ Returns the code point value of the UCN. }
|
|
{ }
|
|
{ Globals: }
|
|
{ ucnString - string representation of this UCN }
|
|
|
|
var
|
|
digits: integer; {number of hex digits (4 or 8)}
|
|
codePoint: longint; {the code point specified by this UCN}
|
|
dig: 0..15; {value of a hex digit}
|
|
i: integer; {index for recording UCN string}
|
|
|
|
begin {UniversalCharacterName}
|
|
i := 1;
|
|
ucnString[i] := '\';
|
|
i := i + 1;
|
|
|
|
codePoint := 0;
|
|
if ch = 'u' then
|
|
digits := 4
|
|
else {if ch = 'U' then}
|
|
digits := 8;
|
|
ucnString[i] := ch;
|
|
i := i + 1;
|
|
NextCh;
|
|
|
|
while digits > 0 do begin
|
|
if ch in ['0'..'9','a'..'f','A'..'F'] then begin
|
|
if ch in ['0'..'9'] then
|
|
dig := ord(ch) & $0F
|
|
else begin
|
|
ch := chr(ord(ch)&$5F);
|
|
dig := ord(ch)-ord('A')+10;
|
|
end; {else}
|
|
codePoint := (codePoint << 4) | dig;
|
|
ucnString[i] := ch;
|
|
i := i + 1;
|
|
NextCh;
|
|
digits := digits - 1;
|
|
end {while}
|
|
else begin
|
|
Error(145);
|
|
codePoint := $0000C0;
|
|
digits := 0;
|
|
end; {else}
|
|
end; {while}
|
|
|
|
ucnString[0] := chr(i - 1);
|
|
|
|
if (codePoint < 0) or (codePoint > maxUCSCodePoint)
|
|
or ((codePoint >= $00D800) and (codePoint <= $00DFFF))
|
|
or ((codePoint < $A0) and not (ord(codePoint) in [$24,$40,$60]))
|
|
then begin
|
|
Error(145);
|
|
UniversalCharacterName := $0000C0;
|
|
end {if}
|
|
else
|
|
UniversalCharacterName := codePoint;
|
|
|
|
{Normalize UCN string to shorter form for codepoints that fit in 16 bits}
|
|
if (ord(ucnString[0]) = 10) and (codePoint <= $00FFFF) then begin
|
|
ucnString[2] := 'u';
|
|
ucnString[3] := ucnString[7];
|
|
ucnString[4] := ucnString[8];
|
|
ucnString[5] := ucnString[9];
|
|
ucnString[6] := ucnString[10];
|
|
ucnString[0] := chr(6);
|
|
end; {if}
|
|
end; {UniversalCharacterName}
|
|
|
|
|
|
procedure InitScanner {start, end: ptr};
|
|
|
|
{ initialize the scanner }
|
|
{ }
|
|
{ start - pointer to the first character in the file }
|
|
{ end - points one byte past the last character in the file }
|
|
|
|
var
|
|
chi: minChar..maxChar; {loop variable}
|
|
lch: char; {next command line character}
|
|
cp: ptr; {character pointer}
|
|
i: 0..hashSize; {loop variable}
|
|
negative: boolean; {is a number negative?}
|
|
|
|
mp: macroRecordPtr; {for building the predefined macros}
|
|
bp: ^macroRecordPtr;
|
|
|
|
timeString: packed array[1..20] of char; {time from misc. tools}
|
|
|
|
|
|
procedure NextCh;
|
|
|
|
{ Get the next character from the command line }
|
|
|
|
begin {NextCh}
|
|
lch := chr(cp^);
|
|
cp := pointer(ord4(cp)+1);
|
|
tokenColumn := tokenColumn+1;
|
|
if tokenColumn > infoStringGS.theString.size then
|
|
lch := chr(0);
|
|
end; {NextCh}
|
|
|
|
|
|
function GetWord: stringPtr;
|
|
|
|
{ Read a word from the command line }
|
|
|
|
var
|
|
i: integer; {string index}
|
|
sp: stringPtr; {string pointer}
|
|
|
|
begin {GetWord}
|
|
i := 0;
|
|
while not (lch in [' ', chr(0), chr(9), '=']) do begin
|
|
i := i+1;
|
|
workString[i] := lch;
|
|
NextCh;
|
|
end; {while}
|
|
workString[0] := chr(i);
|
|
sp := pointer(malloc(length(workString)+1));
|
|
CopyString(pointer(sp), @workString);
|
|
GetWord := sp;
|
|
end; {GetWord}
|
|
|
|
|
|
function EscapeCh: integer;
|
|
|
|
{ Find and return the next character in a string or char }
|
|
{ constant. Handle escape sequences if they are found. }
|
|
{ (The character is returned as an ordinal value.) }
|
|
{ }
|
|
{ Globals: }
|
|
{ lch - first character in sequence; set to first char }
|
|
{ after sequence }
|
|
|
|
label 1;
|
|
|
|
var
|
|
cnt: 0..3; {for counting octal escape sequences}
|
|
dig: 0..15; {value of a hex digit}
|
|
skipChar: boolean; {get next char when done?}
|
|
val: 0..4095; {hex escape code value (scaled to 0..255)}
|
|
|
|
begin {EscapeCh}
|
|
1: skipChar := true;
|
|
if lch = '\' then begin
|
|
NextCh;
|
|
if lch in ['0'..'7','a','b','t','n','v','f','p','r','x'] then
|
|
case lch of
|
|
'0','1','2','3','4','5','6','7': begin
|
|
val := 0;
|
|
cnt := 0;
|
|
while (cnt < 3) and (lch in ['0'..'7']) do begin
|
|
val := (val << 3) | (ord(lch) & 7);
|
|
cnt := cnt+1;
|
|
NextCh;
|
|
end; {while}
|
|
EscapeCh := val & $FF;
|
|
skipChar := false;
|
|
end;
|
|
'a': EscapeCh := 7;
|
|
'b': EscapeCh := 8;
|
|
't': EscapeCh := 9;
|
|
'n': EscapeCh := 10;
|
|
'v': EscapeCh := 11;
|
|
'f': EscapeCh := 12;
|
|
'p': begin
|
|
EscapeCh := ord('p');
|
|
ispstring := true;
|
|
end;
|
|
'r': EscapeCh := 13;
|
|
'x': begin
|
|
val := 0;
|
|
NextCh;
|
|
while lch in ['0'..'9','a'..'f','A'..'F'] do begin
|
|
if lch in ['0'..'9'] then
|
|
dig := ord(lch) & $0F
|
|
else begin
|
|
lch := chr(ord(lch)&$5F);
|
|
dig := ord(lch)-ord('A')+10;
|
|
end; {else}
|
|
val := (val << 4) | dig;
|
|
NextCh;
|
|
end; {while}
|
|
skipChar := false;
|
|
EscapeCh := val & $FF;
|
|
end;
|
|
otherwise: Error(57);
|
|
end {case}
|
|
else
|
|
EscapeCh := ord(lch);
|
|
end {if}
|
|
else
|
|
EscapeCh := ord(lch);
|
|
if skipChar then
|
|
NextCh;
|
|
end; {EscapeCh}
|
|
|
|
|
|
procedure GetString;
|
|
|
|
{ read a string token from the command line }
|
|
|
|
var
|
|
i: integer; {string length}
|
|
setLength: boolean; {is the current string a p-string?}
|
|
sPtr: longstringPtr; {work string pointer}
|
|
|
|
begin {GetString}
|
|
token.kind := stringconst; {set up the token}
|
|
token.class := stringConstant;
|
|
i := 0; {set up for the string scan}
|
|
ispstring := false;
|
|
setLength := false;
|
|
new(sPtr);
|
|
NextCh; {skip the opening "}
|
|
{read the characters}
|
|
while not (charKinds[ord(lch)] in [ch_string,ch_eol,ch_eof]) do begin
|
|
i := i+1;
|
|
if i = longstringlen then begin
|
|
i := 1001;
|
|
Error(90);
|
|
end; {if}
|
|
sPtr^.str[i] := chr(EscapeCh);
|
|
if (i = 1) and ispstring then
|
|
setLength := true;
|
|
end; {while}
|
|
if lch = '"' then {process the end of the string}
|
|
NextCh
|
|
else
|
|
Error(3);
|
|
if setLength then {check for a p-string}
|
|
sPtr^.str[1] := chr(i-1);
|
|
token.ispstring := setLength;
|
|
sPtr^.length := i; {set the string length}
|
|
token.sval := pointer(Malloc(i+3)); {put the string in the string pool}
|
|
CopyLongString(token.sval, pointer(sPtr));
|
|
dispose(sPtr);
|
|
token.sval^.str[i+1] := chr(0); {add null in case the string is extended}
|
|
end; {GetString}
|
|
|
|
|
|
begin {InitScanner}
|
|
printMacroExpansions := false; {don't print the token list}
|
|
skipIllegalTokens := false; {flag illegal tokens in skipped code}
|
|
allowLongIntChar := false; {allow long int char constants}
|
|
allowTokensAfterEndif := false; {allow tokens after #endif}
|
|
allowSlashSlashComments := true; {allow // comments}
|
|
allowMixedDeclarations := true; {allow mixed declarations & stmts (C99)}
|
|
c99Scope := true; {follow C99 rules for block scopes}
|
|
looseCharTypeChecks := true; {make char and unsigned char compatible}
|
|
foundFunction := false; {no functions found so far}
|
|
fileList := nil; {no included files}
|
|
gettingFileName := false; {not in GetFileName}
|
|
ifList := nil; {no conditional comp. records}
|
|
skipping := false; {not skipping tokens}
|
|
flagOverflows := true; {flag overflow errors?}
|
|
new(macros); {no preprocessor macros so far}
|
|
for i := 0 to hashSize do
|
|
macros^[i] := nil;
|
|
pathList := nil; {no additional search paths}
|
|
charKinds[ord('#')] := illegal; {don't allow # as a token}
|
|
tokenList := nil; {nothing in putback buffer}
|
|
saveNumber := false; {don't save numbers}
|
|
expandMacros := true; {enable macro expansion}
|
|
reportEOL := false; {report eolsy as a token?}
|
|
lineNumber := 1; {start the line counter}
|
|
chPtr := start; {set the start, end pointers}
|
|
eofPtr := endPtr;
|
|
firstPtr := start; {first char in line}
|
|
numErr := 0; {no errors so far}
|
|
numErrors := 0;
|
|
includeCount := 0; {no pending calls to EndInclude}
|
|
lint := 0; {turn off lint checks}
|
|
ch := chr(RETURN); {set the initial character}
|
|
needWriteLine := false; {no lines are pending}
|
|
wroteLine := false; {current line has not been written}
|
|
switchLanguages := false; {not switching languages}
|
|
lastWasReturn := false; {last char was not return}
|
|
doingStringOrCharacter := false; {not doing a string}
|
|
doingPPExpression := false; {not doing a preprocessor expression}
|
|
unix_1 := false; {int is 16 bits}
|
|
lintIsError := true; {lint messages are considered errors}
|
|
|
|
{error codes for lint messages}
|
|
{if changed, also change maxLint}
|
|
lintErrors := [51,104,105,110,124,125,128,129,130,147,151,152,153,154,155];
|
|
|
|
spaceStr := ' '; {strings used in stringization}
|
|
quoteStr := '"';
|
|
{set of classes for numeric constants}
|
|
numericConstants := [intConstant,longConstant,longlongConstant,doubleConstant];
|
|
|
|
new(mp); {__LINE__}
|
|
mp^.name := @'__LINE__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 1;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__FILE__}
|
|
mp^.name := @'__FILE__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 2;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__DATE__}
|
|
mp^.name := @'__DATE__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 3;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__TIME__}
|
|
mp^.name := @'__TIME__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 4;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__STDC__}
|
|
mp^.name := @'__STDC__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 5;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__ORCAC__}
|
|
mp^.name := @'__ORCAC__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 5;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__VERSION__}
|
|
mp^.name := @'__VERSION__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 6;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__ORCAC_HAS_LONG_LONG__}
|
|
mp^.name := @'__ORCAC_HAS_LONG_LONG__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 5;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__STDC_NO_ATOMICS__}
|
|
mp^.name := @'__STDC_NO_ATOMICS__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 5;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__STDC_NO_COMPLEX__}
|
|
mp^.name := @'__STDC_NO_COMPLEX__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 5;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__STDC_NO_THREADS__}
|
|
mp^.name := @'__STDC_NO_THREADS__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 5;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__STDC_NO_VLA__}
|
|
mp^.name := @'__STDC_NO_VLA__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 5;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
new(mp); {__STDC_HOSTED__}
|
|
mp^.name := @'__STDC_HOSTED__';
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := true;
|
|
mp^.algorithm := 7;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
SetDateTime; {set up the macro date/time strings}
|
|
{set up the version string}
|
|
versionStrL := pointer(GMalloc(3 + length(versionStr)));
|
|
versionStrL^.length := length(versionStr);
|
|
versionStrL^.str := versionStr;
|
|
|
|
{Scan the command line options}
|
|
cp := @infoStringGS.theString.theString;
|
|
tokenLine := 0;
|
|
tokenColumn := 0;
|
|
NextCh;
|
|
repeat
|
|
while lch in [' ', chr(9)] do {skip leading blanks}
|
|
NextCh;
|
|
if lch = '-' then begin {see if we have found one}
|
|
NextCh;
|
|
if lch in ['d','D'] then begin
|
|
NextCh; {yes -> get the name}
|
|
new(mp); {form the macro table entry}
|
|
mp^.name := GetWord;
|
|
mp^.parameters := -1;
|
|
mp^.tokens := nil;
|
|
mp^.readOnly := false;
|
|
bp := pointer(ord4(macros) + hash(mp^.name));
|
|
mp^.next := bp^;
|
|
bp^ := mp;
|
|
token.kind := intconst; {create the default value}
|
|
token.numString := nil;
|
|
token.class := intConstant;
|
|
token.ival := 1;
|
|
if lch = '=' then begin
|
|
NextCh; {record the value}
|
|
token.numString := nil;
|
|
if lch in ['a'..'z', 'A'..'Z', '_'] then begin
|
|
token.kind := ident;
|
|
token.class := identifier;
|
|
token.name := GetWord;
|
|
token.symbolPtr := nil;
|
|
end {if}
|
|
else if lch in ['+','-'] then begin
|
|
negative := lch = '-';
|
|
NextCh;
|
|
if lch in ['.','0'..'9'] then begin
|
|
token.name := GetWord;
|
|
DoNumber(true);
|
|
if negative then
|
|
case token.class of
|
|
intConstant : token.ival := -token.ival;
|
|
longConstant : token.lval := -token.lval;
|
|
doubleConstant: token.rval := -token.rval;
|
|
longlongConstant,otherwise: Error(108);
|
|
end; {case}
|
|
end {if}
|
|
else
|
|
Error(108);
|
|
end {else if}
|
|
else if lch in ['.','0'..'9'] then begin
|
|
token.name := GetWord;
|
|
DoNumber(true);
|
|
end {else if}
|
|
else if lch = '"' then
|
|
GetString
|
|
else
|
|
Error(108);
|
|
end; {if}
|
|
new(mp^.tokens); {add the value to the definition}
|
|
with mp^.tokens^ do begin
|
|
next := nil;
|
|
tokenString := @'';
|
|
expandEnabled := true;
|
|
tokenStart := nil;
|
|
tokenEnd := nil;
|
|
end; {with}
|
|
mp^.tokens^.token := token;
|
|
end {if}
|
|
else if lch in ['i','I'] then begin
|
|
NextCh; {gat the pathname}
|
|
if lch = '"' then begin
|
|
GetString;
|
|
LongToPString(workString, token.sval);
|
|
AddPath(workString);
|
|
end {if}
|
|
else
|
|
Error(103);
|
|
end {if}
|
|
else {not -p, -i: flag the error}
|
|
Error(108);
|
|
end {if}
|
|
else if lch <> chr(0) then begin
|
|
Error(108); {unknown option: flag the error}
|
|
lch := chr(0);
|
|
end; {else}
|
|
until lch = chr(0); {if more characters, loop}
|
|
end; {InitScanner}
|
|
|
|
|
|
procedure CheckIdentifier;
|
|
|
|
{ See if an identifier is a reserved word, macro or typedef }
|
|
|
|
label 1;
|
|
|
|
var
|
|
bPtr: ^macroRecordPtr; {pointer to hash bucket}
|
|
mPtr: macroRecordPtr; {for checking list of macros}
|
|
rword: tokenEnum; {loop variable}
|
|
sp: stringPtr; {for saving identifier names}
|
|
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
|
|
|
|
begin {CheckIdentifier}
|
|
if expandMacros then {handle macro expansions}
|
|
if not skipping then begin
|
|
mPtr := FindMacro(@workstring);
|
|
if mPtr <> nil then begin
|
|
Expand(mPtr);
|
|
lPrintMacroExpansions := printMacroExpansions;
|
|
printMacroExpansions := false;
|
|
NextToken;
|
|
printMacroExpansions := lPrintMacroExpansions;
|
|
goto 1;
|
|
end;
|
|
end; {if}
|
|
{see if it's a reserved word}
|
|
if workString[1] in ['_','a'..'g','i','l','p','r'..'w'] then
|
|
for rword := wordHash[ord(workString[1])-ord('_')] to
|
|
pred(wordHash[ord(succ(workString[1]))-ord('_')]) do
|
|
if reservedWords[rword] = workString then begin
|
|
token.kind := rword;
|
|
token.class := reservedWord;
|
|
goto 1;
|
|
end; {if}
|
|
token.symbolPtr := nil; {see if it's a typedef name}
|
|
if FindSymbol(token,allSpaces,false,false) <> nil then begin
|
|
if token.symbolPtr^.class = typedefsy then
|
|
token.kind := typedef;
|
|
token.name := token.symbolPtr^.name; {use the old name}
|
|
end {if}
|
|
else begin {record the name}
|
|
sp := pointer(Malloc(length(workString)+1));
|
|
CopyString(pointer(sp), @workString);
|
|
token.name := sp;
|
|
end; {else}
|
|
1:
|
|
end; {CheckIdentifier}
|
|
|
|
|
|
procedure NextToken;
|
|
|
|
{ Read the next token from the file. }
|
|
|
|
label 1,2,3,4,5;
|
|
|
|
type
|
|
three = (s100,s1000,s4000); {these declarations are used for a}
|
|
gstringPtr = ^gstringRecord; { variable length string record }
|
|
gstringRecord = record
|
|
case three of
|
|
s100: (len1: integer;
|
|
str1: packed array[1..100] of char;
|
|
);
|
|
s1000: (len2: integer;
|
|
str2: packed array[1..1000] of char;
|
|
);
|
|
s4000: (len3: integer;
|
|
str3: packed array[1..longstringlen] of char;
|
|
);
|
|
end;
|
|
|
|
var
|
|
done: boolean; {loop termination}
|
|
expandEnabled: boolean; {can a token be expanded?}
|
|
i,j: 0..maxint; {loop/index counter}
|
|
inhibit: boolean; {inhibit macro expansion?}
|
|
lExpandMacros: boolean; {local copy of expandMacros}
|
|
lPrintMacroExpansions: boolean; {local copy of printMacroExpansions}
|
|
mPtr: macroRecordPtr; {for checking list of macros}
|
|
setLength: boolean; {is the current string a p-string?}
|
|
tPtr: tokenListRecordPtr; {for removing tokens from putback buffer}
|
|
tToken: tokenType; {for merging tokens}
|
|
sPtr,tsPtr: gstringPtr; {for forming string constants}
|
|
lLastWasReturn: boolean; {local copy of lastWasReturn}
|
|
codePoint: ucsCodePoint; {Unicode code point from UCN}
|
|
chFromUCN: integer; {character given by UCN (converted)}
|
|
|
|
|
|
function EscapeCh: integer;
|
|
|
|
{ Find and return the next character in a string or char }
|
|
{ constant. Handle escape sequences if they are found. }
|
|
{ (The character is returned as an ordinal value.) }
|
|
{ }
|
|
{ Globals: }
|
|
{ ch - first character in sequence; set to first char }
|
|
{ after sequence }
|
|
|
|
label 1;
|
|
|
|
var
|
|
cnt: 0..3; {for counting octal escape sequences}
|
|
dig: 0..15; {value of a hex digit}
|
|
skipChar: boolean; {get next char when done?}
|
|
val: 0..4095; {hex escape code value (scaled to 0..255)}
|
|
codePoint: ucsCodePoint; {code point given by UCN}
|
|
chFromUCN: integer; {character given by UCN (converted)}
|
|
|
|
begin {EscapeCh}
|
|
1: skipChar := true;
|
|
if ch = '\' then begin
|
|
NextCh;
|
|
if ch in ['0'..'7','a','b','t','n','v','f','p','r','x','u','U'] then
|
|
case ch of
|
|
'0','1','2','3','4','5','6','7': begin
|
|
val := 0;
|
|
cnt := 0;
|
|
while (cnt < 3) and (ch in ['0'..'7']) do begin
|
|
val := (val << 3) | (ord(ch) & 7);
|
|
cnt := cnt+1;
|
|
NextCh;
|
|
end; {while}
|
|
EscapeCh := val & $FF;
|
|
skipChar := false;
|
|
end;
|
|
'a': EscapeCh := 7;
|
|
'b': EscapeCh := 8;
|
|
't': EscapeCh := 9;
|
|
'n': EscapeCh := 10;
|
|
'v': EscapeCh := 11;
|
|
'f': EscapeCh := 12;
|
|
'p': begin
|
|
EscapeCh := ord('p');
|
|
ispstring := true;
|
|
end;
|
|
'r': EscapeCh := 13;
|
|
'x': begin
|
|
val := 0;
|
|
NextCh;
|
|
while ch in ['0'..'9','a'..'f','A'..'F'] do begin
|
|
if ch in ['0'..'9'] then
|
|
dig := ord(ch) & $0F
|
|
else begin
|
|
ch := chr(ord(ch)&$5F);
|
|
dig := ord(ch)-ord('A')+10;
|
|
end; {else}
|
|
val := (val << 4) | dig;
|
|
NextCh;
|
|
end; {while}
|
|
skipChar := false;
|
|
EscapeCh := val & $FF;
|
|
end;
|
|
'u','U': begin
|
|
codePoint := UniversalCharacterName;
|
|
chFromUCN := ConvertUCSToMacRoman(codePoint);
|
|
skipChar := false;
|
|
if chFromUCN >= 0 then
|
|
EscapeCh := chFromUCN
|
|
else begin
|
|
EscapeCh := 0;
|
|
Error(146);
|
|
end; {else}
|
|
end;
|
|
otherwise: Error(57);
|
|
end {case}
|
|
else
|
|
EscapeCh := ord(ch);
|
|
end {if}
|
|
else
|
|
EscapeCh := ord(ch);
|
|
if skipChar then
|
|
NextCh;
|
|
end; {EscapeCh}
|
|
|
|
|
|
|
|
procedure CharConstant;
|
|
|
|
{ Scan a single-quote character constant }
|
|
|
|
var
|
|
cnt: integer; {number of characters scanned}
|
|
result: longint; {character value}
|
|
|
|
begin {CharConstant}
|
|
|
|
{set up locals}
|
|
cnt := 0;
|
|
result := 0;
|
|
|
|
doingStringOrCharacter := true;
|
|
|
|
{skip the leading quote}
|
|
NextCh;
|
|
|
|
{read the characters in the constant}
|
|
while (not (charKinds[ord(ch)] in [ch_char,ch_eol,ch_eof])) do begin
|
|
if cnt < maxint then
|
|
cnt := cnt + 1;
|
|
result := (result << 8) | EscapeCh;
|
|
end; {while}
|
|
doingStringOrCharacter := false;
|
|
|
|
{skip the closing quote}
|
|
if (charKinds[ord(ch)] = ch_char) then begin
|
|
if (cnt = 0) and ((not skipping) or (not skipIllegalTokens)) then
|
|
Error(2);
|
|
NextCh;
|
|
end {if}
|
|
else if (not skipping) or (not skipIllegalTokens) then
|
|
Error(2);
|
|
|
|
{create the token}
|
|
if allowLongIntChar and (cnt >= 3) then begin
|
|
token.kind := longconst;
|
|
token.class := longConstant;
|
|
token.lval := result;
|
|
end {if}
|
|
else begin
|
|
token.kind := intconst;
|
|
token.class := intConstant;
|
|
token.ival := long(result).lsw;
|
|
end {else}
|
|
end; {CharConstant}
|
|
|
|
|
|
begin {NextToken}
|
|
if ifList = nil then {do pending EndInclude calls}
|
|
while includeCount <> 0 do begin
|
|
EndInclude(includeChPtr);
|
|
includeCount := includeCount - 1;
|
|
end; {while}
|
|
includeChPtr := chPtr;
|
|
3:
|
|
token.numstring := nil; {wipe out old numstrings}
|
|
if tokenList <> nil then begin {get a token put back by a macro}
|
|
tPtr := tokenList;
|
|
tokenList := tPtr^.next;
|
|
expandEnabled := tPtr^.expandEnabled;
|
|
tokenExpandEnabled := expandEnabled;
|
|
token := tPtr^.token;
|
|
tokenStart := tPtr^.tokenStart;
|
|
tokenEnd := tPtr^.tokenEnd;
|
|
dispose(tPtr);
|
|
if token.kind = typedef then {allow for typedefs in a macro}
|
|
token.kind := ident;
|
|
if token.kind = ident then begin
|
|
CopyString(@workString, token.name);
|
|
lExpandMacros := expandMacros;
|
|
expandMacros := false;
|
|
CheckIdentifier;
|
|
expandMacros := lExpandMacros;
|
|
end; {if}
|
|
{ dead code
|
|
if token.kind = ident then
|
|
if FindSymbol(token,allSpaces,false,false) <> nil then
|
|
if token.symbolPtr^.class = typedefsy then
|
|
token.kind := typedef;
|
|
}
|
|
4:
|
|
while (token.kind = stringconst)
|
|
and (tokenList <> nil)
|
|
and (tokenList^.token.kind = stringconst) do begin
|
|
Merge(token, tokenList^.token);
|
|
tPtr := tokenList;
|
|
tokenList := tPtr^.next;
|
|
dispose(tPtr);
|
|
end; {while}
|
|
if expandMacros and expandEnabled and (not skipping) then
|
|
if token.kind = ident then begin {handle macro expansions}
|
|
inhibit := false;
|
|
if tokenList <> nil then
|
|
if tokenList^.token.kind = poundpoundop then
|
|
inhibit := true;
|
|
if not inhibit then begin
|
|
mPtr := FindMacro(token.name);
|
|
if mPtr <> nil then begin
|
|
Expand(mPtr);
|
|
goto 3;
|
|
end; {if}
|
|
end; {if}
|
|
end; {if}
|
|
if tokenList <> nil then
|
|
if tokenList^.token.kind = poundpoundop then begin
|
|
tPtr := tokenList;
|
|
tokenList := tPtr^.next;
|
|
dispose(tPtr);
|
|
if tokenList <> nil then begin
|
|
tPtr := tokenList;
|
|
tToken := token;
|
|
Merge(tToken, tPtr^.token);
|
|
tokenList := tPtr^.next;
|
|
token := tToken;
|
|
tokenExpandEnabled := true;
|
|
dispose(tPtr);
|
|
goto 4;
|
|
end; {if}
|
|
end; {if}
|
|
goto 2;
|
|
end; {if}
|
|
5: {skip white space}
|
|
while charKinds[ord(ch)] in [illegal,ch_white,ch_eol] do begin
|
|
if charKinds[ord(ch)] = illegal then begin
|
|
if (ch = '#') and (lastWasReturn or (token.kind = eolsy)) then begin
|
|
NextCh; {skip the '#' char}
|
|
PreProcess {call the preprocessor}
|
|
end {if}
|
|
else begin
|
|
tokenLine := lineNumber; {record a # token}
|
|
tokenColumn := ord(ord4(chPtr)-ord4(firstPtr));
|
|
tokenStart := pointer(ord4(chPtr)-1);
|
|
tokenEnd := chPtr;
|
|
if (not skipping) or (not (skipIllegalTokens or (ch = '#'))) then
|
|
Error(1);
|
|
NextCh;
|
|
end; {else}
|
|
end {if}
|
|
else if (charKinds[ord(ch)] = ch_eol) and reportEOL then begin
|
|
token.class := reservedSymbol; {record an eol token}
|
|
token.kind := eolsy;
|
|
tokenLine := lineNumber;
|
|
tokenColumn := ord(ord4(chPtr)-ord4(firstPtr));
|
|
tokenStart := pointer(ord4(chPtr)-1);
|
|
tokenEnd := chPtr;
|
|
NextCh;
|
|
goto 2;
|
|
end {if}
|
|
else begin {skip white space}
|
|
if printMacroExpansions then
|
|
if charKinds[ord(ch)] = ch_eol then
|
|
writeln
|
|
else
|
|
write(ch);
|
|
NextCh;
|
|
end;
|
|
end; {while}
|
|
tokenLine := lineNumber; {record the position of the token}
|
|
tokenColumn := ord(ord4(chPtr)-ord4(firstPtr));
|
|
tokenStart := pointer(ord4(chPtr)-1);
|
|
token.class := reservedSymbol; {default to the most common class}
|
|
case charKinds[ord(ch)] of
|
|
|
|
ch_special : begin
|
|
token.kind := charSym[ord(ch)];
|
|
token.isDigraph := false;
|
|
NextCh;
|
|
end;
|
|
|
|
ch_eof: {end of file}
|
|
token.kind := eofsy;
|
|
|
|
ch_pound : begin {tokens that start with '#'}
|
|
NextCh;
|
|
token.isDigraph := false;
|
|
if ch = '#' then begin
|
|
token.kind := poundpoundop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := poundch;
|
|
end;
|
|
|
|
ch_dash : begin {tokens that start with '-'}
|
|
NextCh;
|
|
if ch = '>' then begin
|
|
token.kind := minusgtop;
|
|
NextCh;
|
|
end
|
|
else if ch = '-' then begin
|
|
token.kind := minusminusop;
|
|
NextCh;
|
|
end
|
|
else if ch = '=' then begin
|
|
token.kind := minuseqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := minusch;
|
|
end;
|
|
|
|
ch_plus : begin {tokens that start with '+'}
|
|
NextCh;
|
|
if ch = '+' then begin
|
|
token.kind := plusplusop;
|
|
NextCh;
|
|
end
|
|
else if ch = '=' then begin
|
|
token.kind := pluseqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := plusch;
|
|
end;
|
|
|
|
ch_lt : begin {tokens that start with '<'}
|
|
NextCh;
|
|
if ch = '<' then begin
|
|
NextCh;
|
|
if ch = '=' then begin
|
|
token.kind := ltlteqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := ltltop;
|
|
end
|
|
else if ch = '=' then begin
|
|
token.kind := lteqop;
|
|
NextCh;
|
|
end
|
|
else if ch = ':' then begin
|
|
token.kind := lbrackch; { <: digraph }
|
|
token.isDigraph := true;
|
|
NextCh;
|
|
end
|
|
else if ch = '%' then begin
|
|
token.kind := lbracech; { <% digraph }
|
|
token.isDigraph := true;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := ltch;
|
|
end;
|
|
|
|
ch_gt : begin {tokens that start with '>'}
|
|
NextCh;
|
|
if ch = '>' then begin
|
|
NextCh;
|
|
if ch = '=' then begin
|
|
token.kind := gtgteqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := gtgtop;
|
|
end
|
|
else if ch = '=' then begin
|
|
token.kind := gteqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := gtch;
|
|
end;
|
|
|
|
ch_eq : begin {tokens that start with '='}
|
|
NextCh;
|
|
if ch = '=' then begin
|
|
token.kind := eqeqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := eqch;
|
|
end;
|
|
|
|
ch_exc : begin {tokens that start with '!'}
|
|
NextCh;
|
|
if ch = '=' then begin
|
|
token.kind := exceqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := excch;
|
|
end;
|
|
|
|
ch_and : begin {tokens that start with '&'}
|
|
NextCh;
|
|
if ch = '&' then begin
|
|
token.kind := andandop;
|
|
NextCh;
|
|
end
|
|
else if ch = '=' then begin
|
|
token.kind := andeqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := andch;
|
|
end;
|
|
|
|
ch_bar : begin {tokens that start with '|'}
|
|
NextCh;
|
|
if ch = '|' then begin
|
|
token.kind := barbarop;
|
|
NextCh;
|
|
end
|
|
else if ch = '=' then begin
|
|
token.kind := bareqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := barch;
|
|
end;
|
|
|
|
ch_percent: begin {tokens that start with '%'}
|
|
lLastWasReturn := lastWasReturn or (token.kind = eolsy);
|
|
NextCh;
|
|
if ch = '=' then begin
|
|
token.kind := percenteqop;
|
|
NextCh;
|
|
end
|
|
else if ch = '>' then begin
|
|
token.kind := rbracech; {%> digraph}
|
|
token.isDigraph := true;
|
|
NextCh;
|
|
end
|
|
else if ch = ':' then begin
|
|
NextCh;
|
|
token.isDigraph := true;
|
|
if (ch = '%') and (chPtr <> eofPtr) and (chr(chPtr^) = ':') then begin
|
|
token.kind := poundpoundop; {%:%: digraph}
|
|
if charKinds[ord('#')] = illegal then
|
|
Error(1);
|
|
NextCh;
|
|
NextCh;
|
|
end
|
|
else begin
|
|
token.kind := poundch; {%: digraph}
|
|
if lLastWasReturn then begin
|
|
PreProcess;
|
|
goto 5;
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
token.kind := percentch;
|
|
end;
|
|
|
|
ch_carot : begin {tokens that start with '^'}
|
|
NextCh;
|
|
if ch = '=' then begin
|
|
token.kind := caroteqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := carotch;
|
|
end;
|
|
|
|
ch_asterisk: begin {tokens that start with '*'}
|
|
NextCh;
|
|
if ch = '=' then begin
|
|
token.kind := asteriskeqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := asteriskch;
|
|
end;
|
|
|
|
ch_slash : begin {tokens that start with '/'}
|
|
NextCh;
|
|
if ch = '=' then begin
|
|
token.kind := slasheqop;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := slashch;
|
|
end;
|
|
|
|
ch_dot : begin {tokens that start with '.'}
|
|
if charKinds[chPtr^] = digit then
|
|
DoNumber(false)
|
|
else begin
|
|
NextCh;
|
|
token.kind := dotch;
|
|
end; {else}
|
|
end;
|
|
|
|
ch_colon : begin {tokens that start with ':'}
|
|
NextCh;
|
|
if ch = '>' then begin
|
|
token.kind := rbrackch; {:> digraph}
|
|
token.isDigraph := true;
|
|
NextCh;
|
|
end
|
|
else
|
|
token.kind := colonch;
|
|
end;
|
|
|
|
ch_char : CharConstant; {character constants}
|
|
|
|
ch_string: begin {string constants}
|
|
doingStringOrCharacter := true; {change character scanning}
|
|
token.kind := stringconst; {set up the token}
|
|
token.class := stringConstant;
|
|
i := 0; {set up for the string scan}
|
|
ispstring := false;
|
|
setLength := false;
|
|
new(sPtr,s100);
|
|
NextCh; {skip the opening "}
|
|
{read the characters}
|
|
while not (charKinds[ord(ch)] in [ch_string,ch_eol,ch_eof]) do begin
|
|
i := i+1;
|
|
if i = 101 then begin
|
|
sPtr^.len1 := 100;
|
|
new(tsPtr,s1000);
|
|
CopyLongString(pointer(tsPtr), pointer(sPtr));
|
|
dispose(sPtr);
|
|
sPtr := tsPtr;
|
|
end {if}
|
|
else if i = 1001 then begin
|
|
sPtr^.len2 := 1000;
|
|
new(tsPtr,s4000);
|
|
CopyLongString(pointer(tsPtr), pointer(sPtr));
|
|
dispose(sPtr);
|
|
sPtr := tsPtr;
|
|
end {else if}
|
|
else if i = longstringlen then begin
|
|
i := 1001;
|
|
Error(90);
|
|
end; {else if}
|
|
sPtr^.str1[i] := chr(EscapeCh);
|
|
if (i = 1) and ispstring then
|
|
setLength := true;
|
|
end; {while}
|
|
doingStringOrCharacter := false; {process the end of the string}
|
|
if ch = '"' then
|
|
NextCh
|
|
else
|
|
Error(3);
|
|
if setLength then {check for a p-string}
|
|
sPtr^.str1[1] := chr(i-1);
|
|
token.ispstring := setLength;
|
|
sPtr^.len1 := i; {set the string length}
|
|
token.sval := pointer(Malloc(i+3)); {put the string in the string pool}
|
|
CopyLongString(token.sval, pointer(sPtr));
|
|
dispose(sPtr);
|
|
token.sval^.str[i+1] := chr(0); {add null in case the string is extended}
|
|
end;
|
|
|
|
letter,ch_backslash: begin {reserved words and identifiers}
|
|
token.kind := ident;
|
|
token.class := identifier;
|
|
token.name := @workString;
|
|
tokenExpandEnabled := true;
|
|
i := 0;
|
|
while charKinds[ord(ch)] in [letter,digit,ch_backslash] do begin
|
|
i := i+1;
|
|
if ch = '\' then begin
|
|
NextCh;
|
|
if ch in ['u','U'] then begin
|
|
codePoint := UniversalCharacterName;
|
|
if not ValidUCNForIdentifier(codePoint, i=1) then
|
|
Error(149);
|
|
chFromUCN := ConvertUCSToMacRoman(codePoint);
|
|
if chFromUCN >= 0 then
|
|
workString[i] := chr(chFromUCN)
|
|
else begin
|
|
for j := 1 to ord(ucnString[0]) do
|
|
workString[i+j-1] := ucnString[j];
|
|
i := i + ord(ucnString[0]) - 1;
|
|
end; {else}
|
|
end {if}
|
|
else begin
|
|
Error(1);
|
|
workString[i] := '?';
|
|
end; {else}
|
|
end {if}
|
|
else begin
|
|
workString[i] := ch;
|
|
NextCh;
|
|
end; {if}
|
|
end; {while}
|
|
workString[0] := chr(i);
|
|
CheckIdentifier;
|
|
end;
|
|
|
|
digit : {numeric constants}
|
|
DoNumber(false);
|
|
|
|
otherwise: Error(57);
|
|
end; {case}
|
|
tokenEnd := pointer(ord4(chPtr)-1); {record the end of the token}
|
|
2:
|
|
if skipping then {conditional compilation branch}
|
|
if not (token.kind in [eofsy,eolsy]) then
|
|
goto 3;
|
|
if token.kind = stringconst then {handle adjacent strings}
|
|
repeat
|
|
if reportEOL then begin
|
|
while charKinds[ord(ch)] = ch_white do
|
|
NextCh;
|
|
if charKinds[ord(ch)] = ch_eol then
|
|
goto 1;
|
|
end; {if}
|
|
tToken := token;
|
|
lPrintMacroExpansions := printMacroExpansions;
|
|
printMacroExpansions := false;
|
|
NextToken;
|
|
printMacroExpansions := lPrintMacroExpansions;
|
|
if token.kind = stringconst then begin
|
|
Merge(tToken, token);
|
|
done := false;
|
|
end {if}
|
|
else begin
|
|
PutBackToken(token, tokenExpandEnabled);
|
|
done := true;
|
|
end; {else}
|
|
token := tToken;
|
|
until done;
|
|
1:
|
|
if doingPPExpression then begin
|
|
if token.class = reservedWord then begin
|
|
token.name := @reservedWords[token.kind];
|
|
token.kind := ident;
|
|
token.class := identifier;
|
|
end; {if}
|
|
if token.kind = typedef then
|
|
token.kind := ident;
|
|
end; {if}
|
|
if printMacroExpansions then {print the token stream}
|
|
PrintToken(token);
|
|
end; {NextToken}
|
|
|
|
|
|
procedure TermScanner;
|
|
|
|
{ Shut down the scanner. }
|
|
|
|
begin {TermScanner}
|
|
if ifList <> nil then
|
|
Error(21);
|
|
if numErr <> 0 then begin {write any pending errors}
|
|
firstPtr := chPtr;
|
|
WriteLine;
|
|
end; {if}
|
|
end; {TermScanner}
|
|
|
|
end.
|
|
|
|
{$append 'scanner.asm'}
|