Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2024-11-15 07:06:05 +00:00
Code Issues Projects Releases Wiki Activity
bb51e77193
ORCA-C/Scanner.pas
Stephen Heumann 5faf219eff Update comments about pragma flags.
2021-08-22 17:35:16 -05:00

4848 lines
160 KiB
ObjectPascal
Raw Blame History

{$optimize 7}
{---------------------------------------------------------------}
{ }
{ Scanner }
{ }
{ External Variables: }
{ }
{ ch - next character to process }
{ printMacroExpansions - print the token list? }
{ reportEOL - report eolsy as a token? }
{ token - next token to process }
{ }
{ External Subroutines: }
{ }
{ Error - flag an error }
{ IsDefined - see if a macro name is in the macro table }
{ InitScanner - initialize the scanner }
{ NextCh - Read the next character from the file, skipping }
{ comments. }
{ NextToken - read the next token from the file }
{ PutBackToken - place a token into the token stream }
{ TermScanner - Shut down the scanner. }
{ }
{---------------------------------------------------------------}
unit Scanner;
interface
{$LibPrefix '0/obj/'}
uses CCommon, Table, CGI, MM, Charset;
{$segment 'SCANNER'}
type
pragmas = {kinds of pragmas}
(p_startofenum,p_cda,p_cdev,p_float,p_keep,
p_nda,p_debug,p_lint,p_memorymodel,p_expand,
p_optimize,p_stacksize,p_toolparms,p_databank,p_rtl,
p_noroot,p_path,p_ignore,p_segment,p_nba,
p_xcmd,p_unix,p_line,p_fenv_access,p_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;
onOffEnum = (on,off,default); {on-off values in standard pragmas}
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?}
onOffValue: onOffEnum; {value of last on-off switch}
wroteLine: boolean; {has the current line already been written?}
numErr: 0..maxErr; {number of errors in this line}
oneStr: string[2]; {string form of __STDC__, etc.}
zeroStr: string[2]; {string form of __STDC_HOSTED__ when not hosted}
ispstring: boolean; {is the current string a p-string?}
saveNumber: boolean; {save the characters in a number?}
skipping: boolean; {skipping tokens?}
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. }
function CnvLLX (val: longlong): extended; extern;
{ convert a long long to a real number }
{ }
{ parameters: }
{ val - the long long value }
function CnvULLX (val: longlong): extended; extern;
{ convert an unsigned long long to a real number }
{ }
{ parameters: }
{ val - the unsigned long long value }
{-- Scanner support --------------------------------------------}
procedure CheckDelimiters (var name: pString);
{ Check for delimiters, making sure they are ':' }
{ }
{ parameters: }
{ name - path name to check }
label 1;
var
dc: char; {delimiter character}
i: 0..255; {loop/index variable}
begin {CheckDelimiters}
dc := ':'; {determine what the delimiter is}
for i := 1 to length(name) do
if name[i] in [':','/'] then begin
dc := name[i];
goto 1;
end; {if}
1: ;
if dc = '/' then {replace '/' delimiters with ':'}
for i := 1 to length(name) do
if name[i] = '/' then
name[i] := ':';
end; {CheckDelimiters}
procedure AddPath (name: pString);
{ Add a path name to the path name table }
{ }
{ parameters: }
{ name - path name to add }
var
pp, ppe: pathRecordPtr; {work pointers}
begin {AddPath}
if length(name) <> 0 then begin
CheckDelimiters(name); {make sure ':' is used}
if name[length(name)] <> ':' then {make sure there is a trailing delimiter}
name := concat(name, ':');
{create the new path record}
pp := pathRecordPtr(GMalloc(sizeof(pathRecord)));
pp^.next := nil;
pp^.path := stringPtr(GMalloc(length(name)+1));
pp^.path^ := name;
if pathList = nil then {add the path to the path list}
pathList := pp
else begin
ppe := pathList;
while ppe^.next <> nil do
ppe := ppe^.next;
ppe^.next := pp;
end; {else}
end; {if}
end; {AddPath}
function Convertsl(var str: pString): longint; extern;
{ Return the integer equivalent of the string. Assumes a valid }
{ 4-byte integer string; supports unsigned values. }
procedure Convertsll(var qval: longlong; var str: pString); extern;
{ Save the integer equivalent of the string to qval. Assumes a }
{ valid 8-byte integer string; supports unsigned values. }
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 := @'unknown or malformed standard pragma';
158: msg := @'_Generic expression includes two compatible types';
159: msg := @'_Generic expression includes multiple default cases';
160: msg := @'no matching association in _Generic expression';
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}
str: string[23]; {temp string}
begin {PrintToken}
case token.kind of
typedef,
ident: write(token.name^);
charconst,
scharconst,
ucharconst,
intconst,
uintconst: write(token.ival:1);
longConst,
ulongConst: write(token.lval:1);
longlongConst: begin
str := cnvds(CnvLLX(token.qval),1,1);
str[0] := chr(ord(str[0]) - 2);
write(str);
end;
ulonglongConst: begin
str := cnvds(CnvULLX(token.qval),1,1);
str[0] := chr(ord(str[0]) - 2);
write(str);
end;
compConst,
floatConst,
doubleConst,
extendedConst: 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 OnOffSwitch;
{ Process an of-off-switch, as used in standard pragmas. }
var
flaggedError: boolean; {did we flag an error already?}
begin {OnOffSwitch}
onOffValue := off;
flaggedError := false;
NextToken; {skip the standard pragma name}
if token.kind = typedef then
token.kind := ident;
if token.kind <> ident then begin
Error(157);
flaggedError := true;
end {if}
else if token.name^ = 'ON' then
onOffValue := on
else if token.name^ = 'OFF' then
onOffValue := off
else if token.name^ = 'DEFAULT' then
onOffValue := default
else begin
Error(157);
flaggedError := true;
end; {else}
if not flaggedError then begin
NextToken;
if token.kind <> eolsy then
Error(11);
end; {if}
end; {OnOffSwitch}
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;
realConstant:
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 }
{ 32768 - generate inline function names }
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 }
{ 64 - remove stack checks for vararg calls}
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 }
{ 32 - treat char and unsigned char as compatible }
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 token.name^ = 'STDC' then begin
expandMacros := false;
NextToken;
if token.name^ = 'FP_CONTRACT' then
OnOffSwitch
else if token.name^ = 'CX_LIMITED_RANGE' then
OnOffSwitch
else if token.name^ = 'FENV_ACCESS' then begin
OnOffSwitch;
FlagPragmas(p_fenv_access);
fenvAccess := (onOffValue = on);
if fenvAccess then
if doingFunction then
fenvAccessInFunction := true;
end
else
Error(157);
expandMacros := true;
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?}
isFloat: boolean; {is the value a number of type float?}
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;
isFloat := 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}
isFloat := true;
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}
if isFloat then
token.kind := floatConst
else if isLong then
token.kind := extendedConst
else
token.kind := doubleConst;
token.class := realConstant;
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}
fenvAccess := false; {not accessing fp environment}
{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,realConstant];
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;
realConstant : 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 begin
StopSpin;
writeln;
end {if}
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'}
Reference in New Issue View Git Blame Copy Permalink