ORCA-C/Header.pas
Stephen Heumann 9036a98e1c Implement support for digraphs.
Specifically, the following six punctuator tokens are now supported:

<: :> <% %> %: %:%:

These behave the same as the existing tokens [, ], {, }, #, and ## (respectively), apart from their spelling.

This can be useful when the full ASCII character set cannot easily be displayed or input (e.g. on the IIgs text screen with certain language settings).
2020-01-04 21:49:50 -06:00

1974 lines
51 KiB
ObjectPascal

{$optimize 7}
{---------------------------------------------------------------}
{ }
{ Header }
{ }
{ Handles saving and reading precompiled headers. }
{ }
{---------------------------------------------------------------}
unit Header;
interface
{$LibPrefix '0/obj/'}
uses CCommon, MM, Scanner, Symbol, CGI;
{$segment 'SCANNER'}
const
symFileVersion = 5; {version number of .sym file format}
var
inhibitHeader: boolean; {should .sym includes be blocked?}
procedure EndInclude (chPtr: ptr);
{ 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. Declared externally in Symbol.pas }
procedure FlagPragmas (pragma: pragmas);
{ record the effects of a pragma }
{ }
{ parameters: }
{ pragma - pragma to record }
{ }
{ Notes: }
{ 1. Defined as extern in Scanner.pas }
{ 2. For the purposes of this unit, the segment statement is }
{ treated as a pragma. }
procedure InitHeader (var fName: gsosOutString);
{ look for a header file, reading it if it exists }
{ }
{ parameters: }
{ fName - source file name (var for efficiency) }
procedure TermHeader;
{ 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. }
procedure StartInclude (name: gsosOutStringPtr);
{ Marks the start of an include file }
{ }
{ Notes: }
{ 1. Call this subroutine right after opening an include }
{ file. }
{ 2. Defined externally in Scanner.pas }
{---------------------------------------------------------------}
implementation
const
symFiletype = $5E; {symbol file type}
symAuxtype = $008008;
{file buffer}
{-----------}
bufSize = 1024; {size of output buffer}
type
closeOSDCB = record
pcount: integer;
refNum: integer;
end;
createOSDCB = record
pcount: integer;
pathName: gsosInStringPtr;
access: integer;
fileType: integer;
auxType: longint;
storageType: integer;
dataEOF: longint;
resourceEOF: longint;
end;
destroyOSDCB = record
pcount: integer;
pathName: gsosInStringPtr;
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;
getMarkOSDCB = record
pcount: integer;
refNum: integer;
displacement: longint;
end;
openOSDCB = record
pcount: integer;
refNum: integer;
pathName: gsosInStringPtr;
requestAccess: integer;
resourceNumber: integer;
access: integer;
fileType: integer;
auxType: longint;
storageType: integer;
createDateTime: timeField;
modDateTime: timeField;
optionList: optionListPtr;
dataEOF: longint;
blocksUsed: longint;
resourceEOF: longint;
resourceBlocks: longint;
end;
readWriteOSDCB = record
pcount: integer;
refNum: integer;
dataBuffer: ptr;
requestCount: longint;
transferCount: longint;
cachePriority: integer;
end;
setMarkOSDCB = record
pcount: integer;
refNum: integer;
base: integer;
displacement: longint;
end;
{file buffer}
{-----------}
bufferType = array[0..bufSize] of byte; {output buffer}
var
codeStarted: boolean; {has code generation started?}
includeLevel: 0..maxint; {nexted include level}
includeMark: boolean; {has the mark field been written?}
savePragmas: set of pragmas; {pragmas to record}
saveSource: boolean; {save source streams?}
symChPtr: ptr; {chPtr at start of current source sequence}
symEndPtr: ptr; {points to first byte past end of file}
symMark: longint; {start of current block}
symName: gsosOutString; {symbol file name}
symStartPtr: ptr; {first byte in the symbol file}
symPtr: ptr; {next byte in the symbol file}
symRefnum: integer; {symName reference number}
tokenMark: longint; {start of last token list}
{file buffer}
{-----------}
buffer: ^bufferType; {output buffer}
bufPtr: ^byte; {next available byte}
bufLen: 0..bufSize; {bytes left in buffer}
{---------------------------------------------------------------}
procedure BlockMove (sourcPtr, destPtr: ptr; count: longint); tool ($02, $2B);
procedure CloseGS (var parms: closeOSDCB); prodos ($2014);
procedure CreateGS (var parms: createOSDCB); prodos ($2001);
procedure DestroyGS (var parms: destroyOSDCB); prodos ($2002);
procedure GetFileInfoGS (var parms: getFileInfoOSDCB); prodos ($2006);
procedure GetMarkGS (var parms: getMarkOSDCB); prodos ($2017);
procedure OpenGS (var parms: openOSDCB); prodos ($2010);
procedure SetEOFGS (var parms: setMarkOSDCB); prodos ($2018);
procedure SetMarkGS (var parms: setMarkOSDCB); prodos ($2016);
procedure WriteGS (var parms: readWriteOSDCB); prodos ($2013);
{---------------------------------------------------------------}
procedure DestroySymbolFile;
{ Delete any existing symbol file }
var
dsRec: destroyOSDCB; {DestroyGS record}
giRec: getFileInfoOSDCB; {GetFileInfoGS record}
begin {DestroySymbolFile}
giRec.pCount := 4;
giRec.pathname := @symName.theString;
GetFileInfoGS(giRec);
if (giRec.filetype = symFiletype) and (giRec.auxtype = symAuxtype) then begin
dsRec.pCount := 1;
dsRec.pathname := @symName.theString;
DestroyGS(dsRec);
end; {if}
end; {DestroySymbolFile}
procedure Purge;
{ Purge the output buffer }
var
clRec: closeOSDCB; {CloseGS record}
wrRec: readWriteOSDCB; {WriteGS record}
begin {Purge}
wrRec.pcount := 4;
wrRec.refnum := symRefnum;
wrRec.dataBuffer := pointer(buffer);
wrRec.requestCount := (bufSize - bufLen);
WriteGS(wrRec);
if ToolError <> 0 then begin
clRec.pCount := 1;
clRec.refnum := symRefnum;
CloseGS(clRec);
DestroySymbolFile;
saveSource := false;
end; {if}
bufLen := bufSize;
bufPtr := pointer(buffer);
end; {Purge}
procedure CloseSymbols;
{ Close the symbol file }
var
clRec: closeOSDCB; {CloseGS record}
begin {CloseSymbols}
Purge;
clRec.pCount := 1;
clRec.refnum := symRefnum;
CloseGS(clRec);
if numErrors <> 0 then
DestroySymbolFile;
end; {CloseSymbols}
function ReadDouble: double;
{ Read a double precision real from the symbol file }
{ }
{ Returns: value read }
type
doubleptr = ^double;
begin {ReadDouble}
ReadDouble := doubleptr(symPtr)^;
symPtr := pointer(ord4(symPtr)+8);
end; {ReadDouble}
function ReadLong: longint;
{ Read a long word from the symbol file }
{ }
{ Returns: long word read }
type
longptr = ^longint;
begin {ReadLong}
ReadLong := longptr(symPtr)^;
symPtr := pointer(ord4(symPtr)+4);
end; {ReadLong}
function ReadLongString: longStringPtr;
{ Read a long string from the symbol file }
{ }
{ Returns: string read }
var
len: 0..maxint; {string buffer length}
sp1, sp2: longStringPtr; {work pointers}
begin {ReadLongString}
sp1 := longStringPtr(symPtr);
len := sp1^.length + 2;
symPtr := pointer(ord4(symPtr) + len);
sp2 := pointer(GMalloc(len));
BlockMove(sp1, sp2, len);
ReadLongString := sp2;
end; {ReadLongString}
function ReadString: stringPtr;
{ Read a string from the symbol file }
{ }
{ Returns: string read }
var
len: 0..255; {string buffer length}
sp1, sp2: stringPtr; {work pointers}
begin {ReadString}
sp1 := stringptr(symPtr);
len := length(sp1^) + 1;
symPtr := pointer(ord4(symPtr) + len);
sp2 := pointer(GMalloc(len));
BlockMove(sp1, sp2, len);
ReadString := sp2;
end; {ReadString}
function ReadByte: integer;
{ Read a byte from the symbol file }
{ }
{ Returns: byte read }
type
intptr = ^integer;
begin {ReadByte}
ReadByte := (intptr(symPtr)^) & $00FF;
symPtr := pointer(ord4(symPtr)+1);
end; {ReadByte}
function ReadWord: integer;
{ Read a word from the symbol file }
{ }
{ Returns: word read }
type
intptr = ^integer;
begin {ReadWord}
ReadWord := intptr(symPtr)^;
symPtr := pointer(ord4(symPtr)+2);
end; {ReadWord}
procedure ReadChars (var p1, p2: ptr);
{ Read a character stream from the file }
{ }
{ parameters: }
{ p1 - (output) pointer to first char in stream }
{ p2 - (output) points one past last char in stream }
var
len: integer; {length of the stream}
begin {ReadChars}
len := ReadWord;
p1 := pointer(GMalloc(len));
p2 := pointer(ord4(p1) + len);
BlockMove(symPtr, p1, len);
symPtr := pointer(ord4(symPtr) + len);
end; {ReadChars}
procedure WriteDouble (d: double);
{ Write a double constant to the symbol file }
{ }
{ parameters: }
{ d - constant to write }
var
dPtr: ^double; {work pointer}
begin {WriteDouble}
if bufLen < 8 then
Purge;
dPtr := pointer(bufPtr);
dPtr^ := d;
bufPtr := pointer(ord4(bufPtr) + 8);
bufLen := bufLen - 8;
end; {WriteDouble}
procedure WriteLong (i: longint);
{ Write a long word to the symbol file }
{ }
{ parameters: }
{ i - long word to write }
var
lPtr: ^longint; {work pointer}
begin {WriteLong}
if bufLen < 4 then
Purge;
lPtr := pointer(bufPtr);
lPtr^ := i;
bufPtr := pointer(ord4(bufPtr) + 4);
bufLen := bufLen - 4;
end; {WriteLong}
procedure WriteByte (i: integer);
{ Write a byte to the symbol file }
{ }
{ parameters: }
{ i - byte to write }
var
iPtr: ^byte; {work pointer}
begin {WriteByte}
if bufLen = 0 then
Purge;
iPtr := pointer(bufPtr);
iPtr^ := i;
bufPtr := pointer(ord4(bufPtr) + 1);
bufLen := bufLen - 1;
end; {WriteByte}
procedure WriteWord (i: integer);
{ Write a word to the symbol file }
{ }
{ parameters: }
{ i - word to write }
var
iPtr: ^integer; {work pointer}
begin {WriteWord}
if bufLen < 2 then
Purge;
iPtr := pointer(bufPtr);
iPtr^ := i;
bufPtr := pointer(ord4(bufPtr) + 2);
bufLen := bufLen - 2;
end; {WriteWord}
procedure WriteLongString (s: longStringPtr);
{ Write a long string to the symbol file }
{ }
{ parameters: }
{ s - pointer to the string to write }
var
i: 0..maxint; {loop/index variables}
len: 0..maxint; {string length}
wrRec: readWriteOSDCB; {WriteGS record}
begin {WriteLongString}
len := s^.length;
if bufLen < len+2 then
Purge;
if bufLen < len+2 then begin
wrRec.pcount := 4;
wrRec.refnum := symRefnum;
wrRec.dataBuffer := pointer(s);
wrRec.requestCount := s^.length + 2;
WriteGS(wrRec);
if ToolError <> 0 then begin
CloseSymbols;
DestroySymbolFile;
saveSource := false;
end; {if}
end {if}
else begin
WriteWord(len);
for i := 1 to len do begin
bufPtr^ := ord(s^.str[i]);
bufPtr := pointer(ord4(bufPtr) + 1);
end; {for}
bufLen := bufLen - len;
end; {else}
end; {WriteLongString}
procedure WriteChars (p1, p2: ptr);
{ Write a stream of chars as a longString }
{ }
{ parameters: }
{ p1 - points to the first char to write }
{ p2 - points to the byte following the last char }
var
i: 0..maxint; {loop/index variables}
len: 0..maxint; {char length}
wrRec: readWriteOSDCB; {WriteGS record}
begin {WriteChars}
len := ord(ord4(p2) - ord4(p1));
WriteWord(len);
if bufLen < len then
Purge;
if bufLen < len then begin
if saveSource then begin
wrRec.pcount := 4;
wrRec.refnum := symRefnum;
wrRec.dataBuffer := pointer(p1);
wrRec.requestCount := ord4(p2) - ord4(p1);
WriteGS(wrRec);
if ToolError <> 0 then begin
CloseSymbols;
DestroySymbolFile;
saveSource := false;
end; {if}
end; {if}
end {if}
else begin
for i := 1 to len do begin
bufPtr^ := p1^;
bufPtr := pointer(ord4(bufPtr)+1);
p1 := pointer(ord4(p1)+1);
end; {for}
bufLen := bufLen - len;
end; {else}
end; {WriteChars}
procedure WriteString (s: stringPtr);
{ Write a string to the symbol file }
{ }
{ parameters: }
{ s - pointer to the string to write }
var
i: 0..255; {loop/index variable}
len: 0..255; {length of the string}
begin {WriteString}
len := length(s^);
if bufLen < len+1 then
Purge;
for i := 0 to len do begin
bufPtr^ := ord(s^[i]);
bufPtr := pointer(ord4(bufPtr)+1);
end; {for}
bufLen := bufLen - (len + 1);
end; {WriteString}
procedure MarkBlock;
{ Mark the length of the current block }
var
l: longint; {block length}
smRec: setMarkOSDCB; {SetMarkGS record}
gmRec: getMarkOSDCB; {GetMarkGS record}
wrRec: readWriteOSDCB; {WriteGS record}
begin {MarkBlock}
Purge; {purge the buffer}
gmRec.pCount := 2; {get the current EOF}
gmRec.refnum := symRefnum;
GetMarkGS(gmRec);
if ToolError = 0 then begin
smRec.pcount := 3; {set the mark to the block length field}
smRec.refnum := symRefnum;
smRec.base := 0;
smRec.displacement := symMark;
SetMarkGS(smRec);
if ToolError = 0 then begin
l := gmRec.displacement - smRec.displacement - 4;
wrRec.pcount := 4;
wrRec.refnum := symRefnum;
wrRec.dataBuffer := @l;
wrRec.requestCount := 4;
WriteGS(wrRec);
if ToolError <> 0 then begin
CloseSymbols;
DestroySymbolFile;
saveSource := false;
end; {if}
smRec.displacement := gmRec.displacement;
SetMarkGS(smRec);
end; {if}
end; {if}
if ToolError <> 0 then begin {for errors, delete the symbol file}
CloseSymbols;
DestroySymbolFile;
saveSource := false;
end; {if}
end; {MarkBlock}
function GetMark: longint;
{ Find the current file mark }
{ }
{ Returns: file mark }
var
gmRec: getMarkOSDCB; {GetMarkGS record}
begin {GetMark}
gmRec.pCount := 2;
gmRec.refnum := symRefnum;
GetMarkGS(gmRec);
GetMark := gmRec.displacement + (bufSize - bufLen);
if ToolError <> 0 then begin
CloseSymbols;
DestroySymbolFile;
saveSource := false;
end; {else}
end; {GetMark}
procedure SetMark;
{ Mark the start of a block }
begin {SetMark}
symMark := GetMark;
WriteLong(0);
end; {SetMark}
{---------------------------------------------------------------}
procedure EndInclude {chPtr: ptr};
{ 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. Declared externally in Scanner.pas }
procedure SaveMacroTable;
{ Save macros to the symbol file }
procedure SaveMacros;
{ Write the macros to the symbol file }
var
i: 0..hashSize; {loop/index variable}
mp: macroRecordPtr; {used to trace macro lists}
tp: tokenListRecordPtr; {used to trace token lists}
procedure WriteToken (var token: tokenType);
{ Write a token in the header file }
{ }
{ parameters: }
{ token - token to write }
begin {WriteToken}
WriteByte(ord(token.kind));
WriteByte(ord(token.class));
if token.numstring = nil then
WriteByte(0)
else begin
WriteByte(1);
WriteString(token.numstring);
end; {else}
case token.class of
identifier: WriteString(token.name);
intConstant: WriteWord(token.ival);
longConstant: WriteLong(token.lval);
doubleConstant: WriteDouble(token.rval);
stringConstant: begin
WriteLongString(token.sval);
WriteByte(ord(token.ispstring));
end;
macroParameter: WriteWord(token.pnum);
reservedSymbol: if token.kind in [lbracech,rbracech,lbrackch,
rbrackch,poundch,poundpoundop] then
WriteByte(ord(token.isDigraph));
otherwise: ;
end; {case}
end; {WriteToken}
begin {SaveMacros}
for i := 0 to hashSize do begin {loop over hash buckets}
mp := macros^[i]; {loop over macro records in hash bucket}
while mp <> nil do begin
if not mp^.saved then begin
mp^.saved := true; {mark this one as saved}
WriteString(mp^.name); {write the macroRecord}
WriteByte(mp^.parameters);
WriteByte(ord(mp^.readOnly));
WriteByte(mp^.algorithm);
tp := mp^.tokens; {loop over token list}
while tp <> nil do begin
WriteByte(1); {write tokenListRecord}
WriteLongString(tp^.tokenString);
WriteToken(tp^.token);
WriteByte(ord(tp^.expandEnabled));
WriteChars(tp^.tokenStart, tp^.tokenEnd);
tp := tp^.next;
end; {while}
WriteByte(0); {mark end of token list}
end; {if}
mp := mp^.next;
end; {while}
end; {for}
end; {SaveMacros}
begin {SaveMacroTable}
SetMark; {set the macro table length mark}
if saveSource then {write the macro table}
SaveMacros;
if saveSource then {mark the length of the table}
MarkBlock;
end; {SaveMacroTable}
procedure SavePragmaEffects;
{ Save the variables effected by any pragmas encountered }
var
count: 0..maxint; {number of path names}
i: 1..10; {loop/index variable}
p: pragmas; {loop variable}
pp: pathRecordPtr; {used to trace pathname list}
begin {SavePragmaEffects}
SetMark;
if saveSource then
for p := succ(p_startofenum) to pred(p_endofenum) do
if p in savePragmas then
if saveSource then begin
WriteByte(ord(p));
case p of
p_cda: begin
WriteString(@menuLine);
WriteString(openName);
WriteString(closeName);
end;
p_cdev: WriteString(openName);
p_float: begin
WriteWord(floatCard);
WriteWord(floatSlot);
end;
p_keep: WriteLongString(@outFileGS.theString);
p_line: begin
WriteWord(lineNumber);
WriteLongString(@sourceFileGS.theString);
end;
p_nda: begin
WriteString(openName);
WriteString(closeName);
WriteString(actionName);
WriteString(initName);
WriteWord(refreshPeriod);
WriteWord(eventMask);
WriteString(@menuLine);
end;
p_nba:
WriteString(openName);
p_xcmd:
WriteString(openName);
p_debug:
WriteWord(ord(rangeCheck)
| (ord(debugFlag) << 1)
| (ord(profileFlag) << 2)
| (ord(traceBack) << 3)
| (ord(checkStack) << 4)
| (ord(debugStrFlag) << 15));
p_lint: WriteWord(lint);
p_memorymodel: WriteByte(ord(smallMemoryModel));
p_expand: WriteByte(ord(printMacroExpansions));
p_optimize:
WriteByte(ord(peepHole)
| (ord(npeepHole) << 1)
| (ord(registers) << 2)
| (ord(saveStack) << 3)
| (ord(commonSubexpression) << 4)
| (ord(loopOptimizations) << 5)
| (ord(strictVararg) << 6));
p_stacksize: WriteWord(stackSize);
p_toolparms: WriteByte(ord(toolParms));
p_databank: WriteByte(ord(dataBank));
p_rtl: ;
p_noroot: ;
p_path: begin
pp := pathList;
count := 0;
while pp <> nil do begin
count := count+1;
pp := pp^.next;
end; {while}
WriteWord(count);
pp := pathList;
while pp <> nil do begin
WriteString(pp^.path);
pp := pp^.next;
end; {while}
end; {p_path}
p_ignore:
WriteByte(ord(skipIllegalTokens)
| (ord(allowLongIntChar) << 1)
| (ord(allowTokensAfterEndif) << 2)
| (ord(allowSlashSlashComments) << 3)
| (ord(allowMixedDeclarations) << 4));
p_segment: begin
for i := 1 to 10 do begin
WriteByte(defaultSegment[i]);
WriteByte(currentSegment[i]);
end; {for}
WriteWord(segmentKind);
end;
p_unix: WriteByte(ord(unix_1));
end; {case}
end; {if}
if saveSource then
MarkBlock;
savePragmas := [];
end; {SavePragmaEffects}
procedure SaveSourceStream;
{ Save the source stream for later compares }
var
wrRec: readWriteOSDCB; {WriteGS record}
begin {SaveSourceStream}
WriteLong(ord4(chPtr) - ord4(symChPtr));
Purge;
wrRec.pcount := 4;
wrRec.refnum := symRefnum;
wrRec.dataBuffer := pointer(symChPtr);
wrRec.requestCount := ord4(chPtr) - ord4(symChPtr);
WriteGS(wrRec);
symChPtr := chPtr;
if ToolError <> 0 then begin
CloseSymbols;
DestroySymbolFile;
saveSource := false;
end; {if}
end; {SaveSourceStream}
procedure SaveSymbolTable;
{ Save symbols to the symbol file }
procedure SaveSymbol;
{ Write the symbols to the symbol file }
var
abort: boolean; {abort due to initialized var?}
efRec: setMarkOSDCB; {SetEOFGS record}
i: 0..hashSize; {loop/index variable}
sp: identPtr; {used to trace symbol lists}
procedure WriteIdent (ip: identPtr);
{ write a symbol to the symbol file }
{ }
{ parameters: }
{ ip - pointer to symbol entry }
procedure WriteType (tp: typePtr);
{ write a type entry to the symbol file }
{ }
{ parameters: }
{ tp - pointer to type entry }
var
ip: identPtr; {for tracing field list}
procedure WriteParm (pp: parameterPtr);
{ write a parameter list to the symbol file }
{ }
{ parameters: }
{ pp - parameter pointer }
begin {WriteParm}
while pp <> nil do begin
WriteByte(1);
WriteType(pp^.parameterType);
pp := pp^.next;
end; {while}
WriteByte(0);
end; {WriteParm}
begin {WriteType}
if tp = bytePtr then
WriteByte(2)
else if tp = uBytePtr then
WriteByte(3)
else if tp = wordPtr then
WriteByte(4)
else if tp = uWordPtr then
WriteByte(5)
else if tp = longPtr then
WriteByte(6)
else if tp = uLongPtr then
WriteByte(7)
else if tp = realPtr then
WriteByte(8)
else if tp = doublePtr then
WriteByte(9)
else if tp = extendedPtr then
WriteByte(10)
else if tp = stringTypePtr then
WriteByte(11)
else if tp = voidPtr then
WriteByte(12)
else if tp = voidPtrPtr then
WriteByte(13)
else if tp = defaultStruct then
WriteByte(14)
else if tp^.saveDisp <> 0 then begin
WriteByte(1);
WriteLong(tp^.saveDisp);
end {if}
else begin
WriteByte(0);
tp^.saveDisp := GetMark;
WriteLong(tp^.size);
WriteByte(ord(tp^.isConstant));
WriteByte(ord(tp^.kind));
case tp^.kind of
scalarType:
WriteByte(ord(tp^.baseType));
arrayType: begin
WriteLong(tp^.elements);
WriteType(tp^.aType);
end;
pointerType:
WriteType(tp^.pType);
functionType: begin
WriteByte((ord(tp^.varargs) << 2)
| (ord(tp^.prototyped) << 1) | ord(tp^.isPascal));
WriteWord(tp^.toolnum);
WriteLong(tp^.dispatcher);
WriteType(tp^.fType);
WriteParm(tp^.parameterList);
end;
enumConst:
WriteWord(tp^.eval);
definedType:
WriteType(tp^.dType);
structType, unionType: begin
ip := tp^.fieldList;
while ip <> nil do begin
WriteByte(1);
WriteIdent(ip);
ip := ip^.next;
end; {while}
WriteByte(0);
end;
otherwise: ;
end; {case}
end; {else}
end; {WriteType}
begin {WriteIdent}
WriteString(ip^.name);
WriteType(ip^.itype);
if (ip^.disp = 0) and (ip^.bitDisp = 0) and (ip^.bitSize = 0) then
WriteByte(0)
else if (ip^.bitSize = 0) and (ip^.bitDisp = 0) then begin
if ip^.disp < maxint then begin
WriteByte(1);
WriteWord(ord(ip^.disp));
end {if}
else begin
WriteByte(2);
WriteLong(ip^.disp);
end; {else}
end {else if}
else begin
WriteByte(3);
WriteLong(ip^.disp);
WriteByte(ip^.bitDisp);
WriteByte(ip^.bitSize);
end; {else}
if ip^.iPtr <> nil then
abort := true;
WriteByte(ord(ip^.state));
WriteByte(ord(ip^.isForwardDeclared));
WriteByte(ord(ip^.class));
WriteByte(ord(ip^.storage));
end; {WriteIdent}
begin {SaveSymbol}
abort := false; {no reason to abort, yet}
for i := 0 to hashSize2 do begin {loop over hash buckets}
sp := globalTable^.buckets[i]; {loop over symbol records in hash bucket}
while sp <> nil do begin
if not sp^.saved then begin
sp^.saved := true; {mark this one as saved}
WriteWord(i); {save the symbol}
WriteIdent(sp);
end; {if}
sp := sp^.next;
end; {while}
end; {for}
if abort then begin
Purge;
efRec.pcount := 3;
efRec.refnum := symRefnum;
efRec.base := 0;
efRec.displacement := tokenMark;
SetEOFGS(efRec);
if ToolError <> 0 then begin
CloseSymbols;
DestroySymbolFile;
end; {if}
saveSource := false;
end; {if}
end; {SaveSymbol}
begin {SaveSymbolTable}
SetMark; {set the symbol table length mark}
if saveSource then {write the symbol table}
if globalTable <> nil then
SaveSymbol;
if saveSource then {mark the length of the table}
MarkBlock;
end; {SaveSymbolTable}
begin {EndInclude}
if not ignoreSymbols then begin
includeLevel := includeLevel-1;
if includeLevel = 0 then
if saveSource then begin
MarkBlock; {set the include name mark}
SaveSourceStream; {save the source stream}
SaveMacroTable; {save the macro table}
SaveSymbolTable; {save the symbol table}
SavePragmaEffects; {save the effects of pragmas}
tokenMark := GetMark; {record mark for early exit}
includeMark := false; {no include mark, yet}
end; {if}
end; {if}
end; {EndInclude}
procedure FlagPragmas {pragma: pragmas};
{ record the effects of a pragma }
{ }
{ parameters: }
{ pragma - pragma to record }
{ }
{ Notes: }
{ 1. Defined as extern in Scanner.pas }
{ 2. For the purposes of this unit, the segment statement }
{ and #line directive are treated as pragmas. }
begin {FlagPragmas}
savePragmas := savePragmas + [pragma];
end; {FlagPragmas}
procedure InitHeader {var fName: gsosOutString};
{ look for a header file, reading it if it exists }
{ }
{ parameters: }
{ fName - source file name (var for efficiency) }
type
typeDispPtr = ^typeDispRecord; {type displacement/pointer table}
typeDispRecord = record
next: typeDispPtr;
saveDisp: longint;
tPtr: typePtr;
end;
var
done: boolean; {for loop termination test}
typeDispList: typeDispPtr; {type displacement/pointer table}
procedure DisposeTypeDispList;
{ Dispose of the type displacement list }
var
tp: typeDispPtr; {work pointer}
begin {DisposeTypeDispList}
while typeDispList <> nil do begin
tp := typeDispList;
typeDispList := tp^.next;
dispose(tp);
end; {while}
end; {DisposeTypeDispList}
function EndOfSymbols: boolean;
{ See if we're at the end of the symbol file }
{ }
{ Returns: True if at the end, else false }
begin {EndOfSymbols}
EndOfSymbols := ord4(symPtr) >= ord4(symEndPtr);
end; {EndOfSymbols}
function OpenSymbols: boolean;
{ open and initialize the symbol file }
{ }
{ Returns: True if successful, else false }
var
crRec: createOSDCB; {CreateGS record}
opRec: openOSDCB; {OpenGS record}
begin {OpenSymbols}
OpenSymbols := false; {assume we will fail}
DestroySymbolFile; {destroy any existing file}
crRec.pCount := 5; {create a symbol file}
crRec.pathName := @symName.theString;
crRec.access := $C3;
crRec.fileType := symFiletype;
crRec.auxType := symAuxtype;
crRec.storageType := 1;
CreateGS(crRec);
if ToolError = 0 then begin
opRec.pCount := 3;
opRec.pathname := @symName.theString;
opRec.requestAccess := 3;
OpenGS(opRec);
if ToolError = 0 then begin
symRefnum := opRec.refnum;
OpenSymbols := true;
WriteWord(symFileVersion);
tokenMark := GetMark;
includeMark := false;
end; {if}
end; {if}
end; {OpenSymbols}
procedure PurgeSymbols;
{ Purge the symbol input file }
var
ffDCBGS: fastFileDCBGS; {fast file DCB}
begin {PurgeSymbols}
with ffDCBGS do begin {purge the file}
pCount := 5;
action := 7;
pathName := @symName.theString;
end; {with}
FastFileGS(ffDCBGS);
end; {PurgeSymbols}
function DatesMatch: boolean;
{ Make sure the create/mod dates have not changed }
var
giRec: getFileInfoOSDCB; {GetFileInfoGS record}
i: 1..maxint; {loop/index variable}
len: longint; {length of names}
match: boolean; {do the dates match?}
begin {DatesMatch}
match := true;
len := ReadLong;
while len > 0 do begin
giRec.pCount := 7;
giRec.pathname := pointer(ReadLongString);
len := len - (giRec.pathname^.size + 18);
GetFileInfoGS(giRec);
if ToolError = 0 then begin
for i := 1 to 8 do
match := match and (giRec.createDateTime[i] = ReadByte);
for i := 1 to 8 do
match := match and (giRec.modDateTime[i] = ReadByte);
end {if}
else begin
match := false;
len := 0;
end; {else}
if match and progress then begin
write('Including ');
for i := 1 to giRec.pathname^.size do
write(giRec.pathname^.theString[i]);
writeln;
end; {if}
end; {while}
DatesMatch := match;
end; {DatesMatch}
procedure ReadMacroTable;
{ Read macros from the symbol file }
var
bp: ^macroRecordPtr; {pointer to head of hash bucket}
ep: tokenListRecordPtr; {last token record}
mePtr: ptr; {end of macro table}
mp: macroRecordPtr; {new macro record}
tlen: integer; {length of the token name}
tp: tokenListRecordPtr; {new token record}
procedure ReadToken (var token: tokenType);
{ read a token }
{ }
{ parameters: }
{ token - (output) token read) }
begin {ReadToken}
token.kind := tokenEnum(ReadByte);
token.class := tokenClass(ReadByte);
if ReadByte = 0 then
token.numString := nil
else
token.numstring := ReadString;
case token.class of
identifier: token.name := ReadString;
intConstant: token.ival := ReadWord;
longConstant: token.lval := ReadLong;
doubleConstant: token.rval := ReadDouble;
stringConstant: begin
token.sval := ReadLongString;
token.ispstring := ReadByte <> 0;
end;
macroParameter: token.pnum := ReadWord;
reservedSymbol: if token.kind in [lbracech,rbracech,lbrackch,
rbrackch,poundch,poundpoundop] then
token.isDigraph := boolean(ReadByte);
otherwise: ;
end; {case}
end; {ReadToken}
begin {ReadMacroTable}
mePtr := symPtr; {read the block length}
mePtr := pointer(ord4(mePtr) + ReadLong + 4);
while ord4(symPtr) < ord4(mePtr) do {process the macros}
begin
Spin;
mp := pointer(GMalloc(sizeof(macroRecord)));
mp^.saved := false;
mp^.name := ReadString;
bp := pointer(ord4(macros) + Hash(mp^.name));
mp^.next := bp^;
bp^ := mp;
mp^.parameters := ReadByte;
if mp^.parameters & $0080 <> 0 then
mp^.parameters := mp^.parameters | $FF00;
mp^.readOnly := boolean(ReadByte);
mp^.algorithm := ReadByte;
mp^.tokens := nil;
ep := nil;
while ReadByte <> 0 do begin
tp := pointer(GMalloc(sizeof(tokenListRecord)));
tp^.next := nil;
tp^.tokenString := ReadLongString;
ReadToken(tp^.token);
tp^.expandEnabled := boolean(ReadByte);
ReadChars(tp^.tokenStart, tp^.tokenEnd);
if ep = nil then
mp^.tokens := tp
else
ep^.next := tp;
ep := tp;
end; {while}
end; {while}
symPtr := mePtr;
end; {ReadMacroTable}
procedure ReadPragmas;
{ Read pragma effects }
var
i: 0..maxint; {loop/index variable}
lsPtr: longStringPtr; {work pointer}
p: pragmas; {kind of pragma being processed}
pePtr: ptr; {end of pragma table}
pp, ppe: pathRecordPtr; {used to create a path name list}
sPtr: stringPtr; {work pointer}
val: integer; {temp value}
begin {ReadPragmas}
pePtr := symPtr; {read the block length}
pePtr := pointer(ord4(pePtr) + ReadLong + 4);
while ord4(symPtr) < ord4(pePtr) do {process the pragmas}
begin
Spin;
p := pragmas(ReadByte);
case p of
p_cda: begin
isClassicDeskAcc := true;
sPtr := ReadString;
menuLine := sPtr^;
openName := ReadString;
closeName := ReadString;
end;
p_cdev: begin
isCDev := true;
openName := ReadString;
end;
p_float: begin
floatCard := ReadWord;
floatSlot := ReadWord;
end;
p_keep: begin
liDCBGS.kFlag := 1;
lsPtr := ReadLongString;
outFileGS.theString.size := lsPtr^.length;
for i := 1 to outFileGS.theString.size do
outFileGS.theString.theString[i] := lsPtr^.str[i];
end;
p_line: begin
lineNumber := ReadWord;
lsPtr := ReadLongString;
sourceFileGS.theString.size := lsPtr^.length;
for i := 1 to sourceFileGS.theString.size do
sourceFileGS.theString.theString[i] := lsPtr^.str[i];
end;
p_nda: begin
isNewDeskAcc := true;
openName := ReadString;
closeName := ReadString;
actionName := ReadString;
initName := ReadString;
refreshPeriod := ReadWord;
eventMask := ReadWord;
sPtr := ReadString;
menuLine := sPtr^;
end;
p_nba: begin
isNBA := true;
openName := ReadString;
end;
p_xcmd: begin
isXCMD := true;
openName := ReadString;
end;
p_debug: begin
val := ReadWord;
rangeCheck := odd(val);
debugFlag := odd(val >> 1);
profileFlag := odd(val >> 2);
traceback := odd(val >> 3);
checkStack := odd(val >> 4);
debugStrFlag := odd(val >> 15);
end;
p_lint: lint := ReadWord;
p_memorymodel: smallMemoryModel := boolean(ReadByte);
p_expand: printMacroExpansions := boolean(ReadByte);
p_optimize: begin
val := ReadByte;
peepHole := odd(val);
npeepHole := odd(val >> 1);
registers := odd(val >> 2);
saveStack := odd(val >> 3);
commonSubexpression := odd(val >> 4);
loopOptimizations := odd(val >> 5);
strictVararg := odd(val >> 6);
end;
p_stacksize: stackSize := ReadWord;
p_toolparms: toolParms := boolean(ReadByte);
p_databank: dataBank := boolean(ReadByte);
p_rtl: rtl := true;
p_noroot: noroot := true;
p_path: begin
i := ReadWord;
pathList := nil;
ppe := nil;
while i <> 0 do begin
pp := pathRecordPtr(GMalloc(sizeof(pathRecord)));
pp^.path := ReadString;
pp^.next := nil;
if pathList = nil then
pathList := pp
else
ppe^.next := pp;
ppe := pp;
i := i-1;
end; {while}
end; {p_path}
p_ignore: begin
i := ReadByte;
skipIllegalTokens := odd(i);
allowLongIntChar := odd(i >> 1);
allowTokensAfterEndif := odd(i >> 2);
allowSlashSlashComments := odd(i >> 3);
allowMixedDeclarations := odd(i >> 4);
c99Scope := allowMixedDeclarations;
end;
p_segment: begin
for i := 1 to 10 do begin
defaultSegment[i] := chr(ReadByte);
currentSegment[i] := chr(ReadByte);
end; {for}
segmentKind := ReadWord;
end;
p_unix: unix_1 := boolean(ReadByte);
end; {case}
end; {while}
symPtr := pePtr;
end; {ReadPragmas}
procedure ReadSymbolTable;
{ Read symbols from the symbol file }
var
hashPtr: ^identPtr; {pointer to hash bucket in symbol table}
sePtr: ptr; {end of symbol table}
sp: identPtr; {identifier being constructed}
function ReadIdent: identPtr;
{ Read an identifier from the file }
{ }
{ Returns: Pointer to the new identifier }
var
format: 0..3; {storage format}
sp: identPtr; {identifier being constructed}
procedure ReadType (var tp: typePtr);
{ read a type from the symbol file }
{ }
{ parameters: }
{ tp - (output) type entry }
var
disp: longint; {disp read from symbol file}
ep: identPtr; {end of list of field names}
ip: identPtr; {for tracing field list}
tdisp: typeDispPtr; {used to trace, add to typeDispList}
val: integer; {temp word}
procedure ReadParm (var pp: parameterPtr);
{ read a parameter list from the symbol file }
{ }
{ parameters: }
{ pp - (output) parameter pointer }
var
ep: parameterPtr; {last parameter in list}
np: parameterPtr; {new parameter}
begin {ReadParm}
pp := nil;
ep := nil;
while ReadByte = 1 do begin
np := parameterPtr(GMalloc(sizeof(parameterRecord)));
np^.next := nil;
np^.parameter := nil;
ReadType(np^.parameterType);
if ep = nil then
pp := np
else
ep^.next := np;
ep := np;
end; {while}
end; {ReadParm}
begin {ReadType}
case ReadByte of
0: begin {read a new type}
tp := typePtr(GMalloc(sizeof(typeRecord)));
new(tdisp);
tdisp^.next := typeDispList;
typeDispList := tdisp;
tdisp^.saveDisp := ord4(symPtr) - ord4(symStartPtr);
tdisp^.tPtr := tp;
tp^.size := ReadLong;
tp^.saveDisp := 0;
tp^.isConstant := boolean(ReadByte);
tp^.kind := typeKind(ReadByte);
case tp^.kind of
scalarType:
tp^.baseType := baseTypeEnum(ReadByte);
arrayType: begin
tp^.elements := ReadLong;
ReadType(tp^.aType);
end;
pointerType:
ReadType(tp^.pType);
functionType: begin
val := ReadByte;
tp^.varargs := odd(val >> 2);
tp^.prototyped := odd(val >> 1);
tp^.isPascal := odd(val);
tp^.toolnum := ReadWord;
tp^.dispatcher := ReadLong;
ReadType(tp^.fType);
ReadParm(tp^.parameterList);
end;
enumConst:
tp^.eval := ReadWord;
definedType:
ReadType(tp^.dType);
structType, unionType: begin
tp^.fieldList := nil;
ep := nil;
while ReadByte = 1 do begin
ip := ReadIdent;
if ep = nil then
tp^.fieldList := ip
else
ep^.next := ip;
ep := ip;
end; {while}
end;
otherwise: ;
end; {case}
end; {case 0}
1: begin {read a type displacement}
tdisp := typeDispList;
disp := ReadLong;
tp := nil;
while tdisp <> nil do
if tdisp^.saveDisp = disp then begin
tp := tdisp^.tPtr;
tdisp := nil;
end {if}
else
tdisp := tdisp^.next;
if tp = nil then begin
PurgeSymbols;
DestroySymbolFile;
TermError(12);
end; {if}
end; {case 1}
2: tp := bytePtr;
3: tp := uBytePtr;
4: tp := wordPtr;
5: tp := uWordPtr;
6: tp := longPtr;
7: tp := uLongPtr;
8: tp := realPtr;
9: tp := doublePtr;
10: tp := extendedPtr;
11: tp := stringTypePtr;
12: tp := voidPtr;
13: tp := voidPtrPtr;
14: tp := defaultStruct;
end; {case}
end; {ReadType}
begin {ReadIdent}
sp := pointer(GMalloc(sizeof(identRecord)));
sp^.next := nil;
sp^.saved := false;
sp^.name := ReadString;
ReadType(sp^.itype);
format := ReadByte;
if format = 0 then begin
sp^.disp := 0;
sp^.bitDisp := 0;
sp^.bitSize := 0;
end {if}
else if format = 1 then begin
sp^.disp := ReadWord;
sp^.bitDisp := 0;
sp^.bitSize := 0;
end {else if}
else if format = 2 then begin
sp^.disp := ReadLong;
sp^.bitDisp := 0;
sp^.bitSize := 0;
end {else if}
else begin
sp^.disp := ReadLong;
sp^.bitDisp := ReadByte;
sp^.bitSize := ReadByte;
end; {else}
sp^.iPtr := nil;
sp^.state := stateKind(ReadByte);
sp^.isForwardDeclared := boolean(ReadByte);
sp^.class := tokenEnum(ReadByte);
sp^.storage := storageType(ReadByte);
ReadIdent := sp;
end; {ReadIdent}
begin {ReadSymbolTable}
sePtr := symPtr; {read the block length}
sePtr := pointer(ord4(sePtr) + ReadLong + 4);
while ord4(symPtr) < ord4(sePtr) do {process the symbols}
begin
Spin;
hashPtr := pointer(ord4(globalTable) + ReadWord*4);
sp := ReadIdent;
sp^.next := hashPtr^;
hashPtr^ := sp;
end; {while}
symPtr := sePtr;
end; {ReadSymbolTable}
function OpenSymbolFile (var fName: gsosOutString): boolean;
{ Look for and open a symbol file }
{ }
{ parameters: }
{ fName - source file name (var for efficiency) }
{ }
{ Returns: True if the file was found and opened, else false }
{ }
{ Notes: As a side effect, this subroutine creates the }
{ pathname for the symbol file (symName). }
var
ffDCBGS: fastFileDCBGS; {fast file DCB}
i: integer; {loop/index variable}
begin {OpenSymbolFile}
symName := fName; {create the symbol file name}
i := symName.theString.size - 1;
while not (symName.theString.theString[i] in [':', '/', '.']) do
i := i-1;
if symName.theString.theString[i] <> '.' then
i := symName.theString.size;
if i > maxPath-5 then
i := maxPath-5;
symName.theString.theString[i] := '.';
symName.theString.theString[i+1] := 's';
symName.theString.theString[i+2] := 'y';
symName.theString.theString[i+3] := 'm';
symName.theString.theString[i+4] := chr(0);
symName.theString.size := i+3;
if rebuildSymbols then begin {rebuild any existing symbol file}
DestroySymbolFile;
OpenSymbolFile := false;
end {if}
else begin
with ffDCBGS do begin {read the symbol file}
pCount := 14;
action := 0;
flags := $C000;
pathName := @symName.theString;
end; {with}
FastFileGS(ffDCBGS);
if ToolError = 0 then begin
if (ffDCBGS.filetype = symFiletype) and (ffDCBGS.auxtype = symAuxtype) then
OpenSymbolFile := true
else begin
OpenSymbolFile := false;
PurgeSymbols;
end; {else}
symPtr := ffDCBGS.fileHandle^;
symStartPtr := symPtr;
symEndPtr := pointer(ord4(symPtr) + ffDCBGS.fileLength);
end {if}
else
OpenSymbolFile := false;
end; {else}
end; {OpenSymbolFile}
function SymbolVersion: integer;
{ Read the symbol file version number }
{ }
{ Returns: version number }
begin {SymbolVersion}
SymbolVersion := ReadWord;
end; {SymbolVersion}
function SourceMatches: boolean;
{ Make sure the token streams match up to the next include }
type
intPtr = ^integer; {for faster compares}
var
len, len2: longint; {size of stream to compare}
match: boolean; {result flag}
p1, p2: ptr; {work pointers}
begin {SourceMatches}
match := true;
len := ReadLong;
len2 := len;
p1 := symPtr;
p2 := chPtr;
while len > 1 do
if intPtr(p1)^ <> intPtr(p2)^ then begin
match := false;
len := 0;
end {if}
else begin
len := len-2;
p1 := pointer(ord4(p1)+2);
p2 := pointer(ord4(p2)+2);
end; {else}
if len = 1 then
if p1^ <> p2^ then
match := false;
if match then begin
symPtr := pointer(ord4(symPtr)+len2);
symChPtr := pointer(ord4(chPtr)+len2);
while chPtr <> symChPtr do
NextCh;
end; {if}
SourceMatches := match;
end; {SourceMatches}
begin {InitHeader}
inhibitHeader := false; {don't block .sym files}
if not ignoreSymbols then begin
codeStarted := false; {code generation has not started}
new(buffer); {allocate an output buffer}
bufPtr := pointer(buffer);
bufLen := bufSize;
includeLevel := 0; {no nested includes}
symChPtr := chPtr; {record initial source location}
if OpenSymbolFile(fName) then begin {check for symbol file}
if SymbolVersion = symFileVersion then begin
done := EndOfSymbols; {valid file found - process it}
if done then
PurgeSymbols;
typeDispList := nil;
while not done do begin
if DatesMatch then begin
if SourceMatches then begin
ReadMacroTable;
ReadSymbolTable;
ReadPragmas;
if EndOfSymbols then begin
done := true;
PurgeSymbols;
end; {if}
end {if}
else begin
PurgeSymbols;
DestroySymbolFile;
done := true;
end; {else}
end {if}
else begin
PurgeSymbols;
DestroySymbolFile;
done := true;
end; {else}
end; {while}
DisposeTypeDispList;
saveSource := false;
if ord4(symPtr) > ord4(symEndPtr) then begin
PurgeSymbols;
DestroySymbolFile;
TermError(12);
end; {if}
end {if}
else begin
PurgeSymbols; {no file found}
saveSource := true;
end; {else}
end {if}
else
saveSource := true;
if saveSource then begin {start saving source}
saveSource := OpenSymbols;
savePragmas := [];
DoDefaultsDotH;
end; {if}
end {if}
else
DoDefaultsDotH;
end; {InitHeader}
procedure StartInclude {name: gsosOutStringPtr};
{ Marks the start of an include file }
{ }
{ Notes: }
{ 1. Call this subroutine right after opening an include }
{ file. }
{ 2. Defined externally in Scanner.pas }
var
giRec: getFileInfoOSDCB; {GetFileInfoGS record}
i: 1..8; {loop/index counter}
begin {StartInclude}
if inhibitHeader then
TermHeader;
if not ignoreSymbols then begin
includeLevel := includeLevel+1;
if saveSource then begin
if not includeMark then begin
includeMark := true;
SetMark;
end; {if}
giRec.pCount := 7;
giRec.pathname := pointer(ord4(name)+2);
GetFileInfoGS(giRec);
WriteLongString(pointer(giRec.pathname));
for i := 1 to 8 do
WriteByte(giRec.createDateTime[i]);
for i := 1 to 8 do
WriteByte(giRec.modDateTime[i]);
end {if}
else if not codeStarted then
DestroySymbolFile;
end; {if}
end; {StartInclude}
procedure TermHeader;
{ 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. }
begin {TermHeader}
if not ignoreSymbols then begin
codeStarted := true;
if saveSource then begin
CloseSymbols;
saveSource := false;
dispose(buffer);
end; {if}
end; {if}
end; {TermHeader}
end.