Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2024-09-09 20:54:26 +00:00
Code Issues Projects Releases Wiki Activity
46b6aa389f
ORCA-C/Scanner.pas
Stephen Heumann 46b6aa389f Change all text/source files to LF line endings.
2017-10-21 18:40:19 -05:00

4051 lines
130 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;
{$segment 'scanner'}
type
pragmas = {kinds of pragmas}
(p_startofenum,p_cda,p_cdev,p_float,p_keep,
p_nda,p_debug,p_lint,p_memorymodel,p_expand,
p_optimize,p_stacksize,p_toolparms,p_databank,p_rtl,
p_noroot,p_path,p_ignore,p_segment,p_nba,
p_xcmd,p_unix,p_line,p_endofenum);
{preprocessor types}
{------------------}
tokenListRecordPtr = ^tokenListRecord;
tokenListRecord = record {element of a list of tokens}
next: tokenListRecordPtr; {next element in list}
tokenString: longStringPtr; {string making up the token}
token: tokenType; {token}
expandEnabled: boolean; {can this token be macro expanded?}
tokenStart,tokenEnd: ptr; {token start/end markers}
end;
macroRecordPtr = ^macroRecord;
macroRecord = record {preprocessor macro definition}
next: macroRecordPtr;
saved: boolean;
name: stringPtr;
parameters: integer;
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?}
skipIllegalTokens: boolean; {skip flagging illegal tokens in skipped code?}
slashSlashComments: boolean; {allow // comments?}
token: tokenType; {next token to process}
{---------------------------------------------------------------}
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 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. }
{---------------------------------------------------------------}
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}
type
errorType = record {record of a single error}
num: integer; {error number}
line: integer; {line number}
col: integer; {column number}
end;
{file inclusion}
{--------------}
filePtr = ^fileRecord;
fileRecord = record {NOTE: used in scanner.asm}
next: filePtr; {next file in include stack}
name: gsosOutString; {name of the file}
sname: gsosOutString; {name of the file for __FILE__}
lineNumber: integer; {line number at the #include}
disp: longint; {disp of next character to process}
end;
getFileInfoOSDCB = record
pcount: integer;
pathName: gsosInStringPtr;
access: integer;
fileType: integer;
auxType: longint;
storageType: integer;
createDateTime: timeField;
modDateTime: timeField;
optionList: optionListPtr;
dataEOF: longint;
blocksUsed: longint;
resourceEOF: longint;
resourceBlocks: longint;
end;
expandDevicesDCBGS = record
pcount: integer;
inName: gsosInStringPtr;
outName: gsosOutStringPtr;
end;
{conditional compilation parsing}
{-------------------------------}
ifPtr = ^ifRecord;
ifRecord = record
next: ifPtr; {next record in if stack}
status: {what are we doing?}
(processing,skippingToEndif,skippingToElse);
elseFound: boolean; {has an #else been found?}
end;
var
dateStr: longStringPtr; {macro date string}
doingstring: boolean; {used to supress 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?}
numErr: 0..maxErr; {number of errors in this line}
oneStr: string[2]; {string form of __STDC__}
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}
versionStrL: longStringPtr; {macro version string}
workString: pstring; {for building strings and identifiers}
{-- External procedures; see expresssion 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 }
{-- 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; supporst unsigned values. }
procedure SetDateTime; extern;
{ set up the macro date/time strings }
function KeyPress: boolean; extern;
{ Has a key been presed? }
{ }
{ 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: 0..maxint; {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
write(lineNumber:4, ' '); {write the line #}
cp := firstPtr; {write the characters in the line}
while cp <> chPtr do begin
if cp^ <> RETURN then
write(chr(cp^));
cp := pointer(ord4(cp) + 1);
end; {while}
writeln; {write the end of line character}
for i := 1 to numErr do {write any errors}
with errors[i] do begin
if line = lineNumber then begin
for cl := 1 to col+4 do
write(' ');
write('^ ');
end {if}
else
write(' Error in column ', col:1, ' of line ', line:1, ': ');
case num of
1 : msg := @'illegal character';
2 : msg := @'a character constant must contain exactly one character';
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 array 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 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 := @'unions cannot have bit fields';
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';
otherwise: Error(57);
end; {case}
writeln(msg^);
if terminalErrors then begin
if enterEditor then
ExitToEditor(msg, ord4(firstPtr)+col-ord4(bofPtr)-1)
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}
procedure PrintHexDigit(i: integer);
{ Print a digit as a hex character }
{ }
{ Parameters: }
{ i: value to print in least significant 4 bits }
begin {PrintHexDigit}
i := i & $000F;
if i < 10 then
write(chr(i | ord('0')))
else
write(chr(i + ord('A') - 10));
end; {PrintHexDigit}
begin {PrintToken}
case token.kind of
typedef,
ident: write(token.name^);
intconst,
uintconst: write(token.ival:1);
longConst,
ulongConst: write(token.lval:1);
doubleConst: write(token.rval:1);
stringConst: begin
write('"');
for i := 1 to token.sval^.length do begin
ch := token.sval^.str[i];
if ch in [' '..'~'] then
write(ch)
else begin
write('\x0');
PrintHexDigit(ord(ch)>>4);
PrintHexDigit(ord(ch));
end; {else}
end; {for}
write('"');
end;
autosy,asmsy,breaksy,casesy,charsy,
continuesy,constsy,compsy,defaultsy,dosy,
doublesy,elsesy,enumsy,externsy,extendedsy,
floatsy,forsy,gotosy,ifsy,intsy,
inlinesy,longsy,pascalsy,registersy,returnsy,
shortsy,sizeofsy,staticsy,structsy,switchsy,
segmentsy,signedsy,typedefsy,unionsy,unsignedsy,
voidsy,volatilesy,whilesy:
write(reservedWords[token.kind]);
tildech,questionch,lparench,rparench,lbrackch,rbrackch,lbracech,
rbracech,commach,semicolonch,colonch,poundch:
begin
for i := minChar to maxChar do
if charSym[i] = token.kind then begin
write(chr(i));
goto 1;
end; {if}
end;
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 [intConstant,longConstant,doubleConstant] 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 [intConstant,longConstant,doubleConstant] then begin
if class2 in [intConstant,longConstant,doubleConstant] 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 [intConstant,longConstant,doubleConstant]}
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 [intConstant,longConstant,doubleConstant] 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 [intConstant,longConstant,doubleConstant]}
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;
fp^.lineNumber := lineNumber+1;
if OpenFile(true, default) then begin {open a new file and proceed from there}
lineNumber := 1;
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?}
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;
repeat
done := true;
if token.kind <> rparench then begin
parenCount := 0;
paramCount := paramCount+1;
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 [rparench,commach]))) do begin
new(tPtr);
tPtr^.next := newParm^.tokens;
newParm^.tokens := tPtr;
tPtr^.token := token;
tPtr^.tokenStart := tokenStart;
tPtr^.tokenEnd := tokenEnd;
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}
end; {if}
until done;
if paramCount <> macro^.parameters then
Error(14);
if token.kind = rparench then {insist on a closing ')'}
begin
if not gettingFileName then
NextToken
end {if}
else
Error(12);
end {if}
else
Error(13);
if not gettingFileName then {put back the source stream token}
PutBackToken(token, true);
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);
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);
end;
5: begin {__STDC__}
token.kind := intConst; {__ORCAC__}
token.numString := @oneStr;
token.class := intConstant;
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;
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;
while tcPtr <> nil do begin
if tcPtr^.token.kind = stringconst then
BuildStringToken(@tcPtr^.token.sval^.str,
tcPtr^.token.sval^.length)
else
BuildStringToken(tcPtr^.tokenStart,
ord(ord4(tcPtr^.tokenEnd)-ord4(tcPtr^.tokenStart)));
tcPtr := tcPtr^.next;
end; {while}
tlPtr := tlPtr^.next;
end {if}
{expand a macro parameter}
else begin
tcPtr := pptr^.tokens;
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 (mPtr <> nil) and (not inhibit) then
Expand(mPtr)
else
PutBackToken(tcPtr^.token, true);
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}
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;
workString[0] := chr(0);
while
(token.class in [reservedWord,intconstant,longconstant,doubleconstant])
or (token.kind in [dotch,ident]) do begin
if token.kind = ident then
workstring := concat(workstring, token.name^)
else if token.kind = dotch then
workstring := concat(workstring, '.')
else if token.class = reservedWord then
workstring := concat(workstring, reservedWords[token.kind])
else {if token.class in [intconst,longconst,doubleconst] then}
workstring := concat(workstring, token.numstring^);
NextToken;
end; {while}
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}
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}
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}
NextToken; {skip the directive name}
Expression(preprocessorExpression, []); {evaluate the expression}
end; {NumericDirective}
procedure ProcessIf (skip: boolean);
{ handle the processing for #if, #ifdef and #ifndef }
{ }
{ parameter: }
{ skip - should we skip to the #else }
var
ip: ifPtr; {used to create a new if record}
begin {ProcessIf}
if token.kind <> eolsy then {check for extra stuff on the line}
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}
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}
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;
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;
doubleConstant:
if tk1^.token.rval <> tk2^.token.rval then
goto 3;
stringConstant: begin
if tk1^.token.sval^.length <> tk2^.token.sval^.length
then goto 3;
for i := 1 to tk1^.token.sval^.length do
if tk1^.token.sval^.str[i] <>
tk2^.token.sval^.str[i] then
goto 3;
end;
macroParameter:
if tk1^.token.pnum <> tk2^.token.pnum then
goto 3;
otherwise:
Error(57);
end; {case}
tk1 := tk1^.next;
tk2 := tk2^.next;
end; {while}
if (tk1 = nil) and (tk2 = nil) then
goto 2;
end; {if}
3: Error(5);
goto 2;
end; {if}
{insert the macro in the macro list}
bPtr := pointer(ord4(macros) + Hash(mPtr^.name));
mPtr^.next := bPtr^;
bPtr^ := mPtr;
end {if}
else
Error(9); {identifier expected}
2:
expandMacros := true; {enable expansions}
while parameterList <> nil do begin {dump the parameter names}
np := parameterList;
parameterList := np^.next;
dispose(np);
end; {while}
charKinds[ord('#')] := illegal; {don't allow # as a token}
saveNumber := false; {stop saving numeric strings}
end; {DoDefine}
procedure DoElif;
{ #elif expression }
var
ip: ifPtr; {temp; for efficiency}
begin {DoElif}
ip := ifList;
if ip <> nil then begin
{decide if we should be skipping}
tSkipping := ip^.status <> skippingToElse;
if tSkipping then
ip^.status := skippingToEndif
else begin
{evaluate the condition}
NumericDirective; {evaluate the condition}
if token.kind <> eolsy then {check for extra stuff on the line}
Error(11);
if expressionValue = 0 then
ip^.status := skippingToElse
else
ip^.status := processing;
tSkipping := ip^.status <> processing; {decide if we should be skipping}
end; {else}
end
else
Error(20);
end; {DoElif}
procedure DoElse;
{ #else }
begin {DoElse}
NextToken; {skip the command name}
if token.kind <> eolsy then {check for extra stuff on the line}
Error(11);
if ifList <> nil then begin
if ifList^.elseFound then {check for multiple elses}
Error(19)
else
ifList^.elseFound := true;
{decide if we should be skipping}
tSkipping := ifList^.status <> skippingToElse;
if tSkipping then {set the status}
ifList^.status := skippingToEndif
else
ifList^.status := processing;
end
else
Error(20);
end; {DoElse}
procedure DoEndif;
{ #endif }
var
ip: ifPtr; {used to create a new if record}
begin {DoEndif}
NextToken; {skip the command name}
if token.kind <> eolsy then {check for extra stuff on the line}
Error(11);
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);
end; {DoEndif}
procedure DoError;
{ #error STRING }
var
i: integer; {loop variable}
len: integer; {string length}
msg: stringPtr; {error message ptr}
begin {DoError}
NextToken; {skip the command name}
if token.kind = stringConst then begin
numErrors := numErrors+1;
new(msg);
len := token.sval^.length;
if len > 246 then
len := 246;
msg^ := '#error: ';
for i := 1 to len do
msg^ := concat(msg^, token.sval^.str[i]);
writeln(msg^);
if terminalErrors then begin
if enterEditor then
ExitToEditor(msg, ord4(firstPtr)-ord4(bofPtr))
else
TermError(0);
end; {if}
end {if}
else
Error(83);
NextToken; {skip the command name}
if token.kind <> eolsy then {check for extra stuff on the line}
Error(11);
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;
NextCh; {skip the '#' char}
while charKinds[ord(ch)] = ch_white do {skip white space}
NextCh;
if ch in ['a','d','e','i','l','p','u'] then begin
NextToken;
case token.kind of
ifsy: begin
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;
goto 2;
end; {else if}
'i':
if token.name^ = 'if' then begin
NumericDirective;
ProcessIf(expressionValue = 0);
goto 2;
end {if}
else if token.name^ = 'ifdef' then begin
ProcessIf(not Defined);
goto 2;
end {else}
else if token.name^ = 'ifndef' then begin
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
lineNumber := token.ival;
NextToken;
end {if}
else
Error(18);
if lineNumber < 0 then
lineNumber := 0;
if token.kind = stringconst then begin
LongToPString(
pointer(ord4(@sourceFileGS.theString)+1),
token.sval);
sourceFileGS.theString.size := token.sval^.length;
NextToken;
end; {if}
if token.kind <> eolsy then
Error(11);
goto 2;
end; {if}
'p':
if token.name^ = 'pragma' then begin
if tskipping then goto 2;
NextToken;
if token.name^ = 'keep' then
DoKeep
else if token.name^ = 'debug' then begin
{ debug bits: }
{ 1 - range checking }
{ 2 - create debug code }
{ 4 - generate profiles }
{ 8 - generate traceback code }
{ 16 - check for stack errors }
FlagPragmas(p_debug);
NumericDirective;
val := long(expressionValue).lsw;
rangeCheck := odd(val);
debugFlag := odd(val >> 1);
profileFlag := odd(val >> 2);
traceBack := odd(val >> 3);
checkStack := odd(val >> 4);
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;
lint := long(expressionValue).lsw;
if token.kind <> eolsy then
Error(11);
goto 2;
end {else}
else if token.name^ = 'memorymodel' then begin
FlagPragmas(p_memorymodel);
NumericDirective;
smallMemoryModel := expressionValue = 0;
if token.kind <> eolsy then
Error(11);
end {else if}
else if token.name^ = 'expand' then begin
FlagPragmas(p_expand);
NumericDirective;
lPrintMacroExpansions := expressionValue <> 0;
if token.kind <> eolsy then
Error(11);
end {else if}
else if token.name^ = 'optimize' then begin
{ optimize bits: }
{ 1 - intermediate code peephole }
{ 2 - native peephole }
{ 4 - register value tracking }
{ 8 - remove stack checks }
{ 16 - common subexpression elimination }
{ 32 - loop invariant removal }
FlagPragmas(p_optimize);
NumericDirective;
val := long(expressionValue).lsw;
peepHole := odd(val);
npeepHole := odd(val >> 1);
registers := odd(val >> 2);
saveStack := not odd(val >> 3);
commonSubexpression := odd(val