mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-11-19 18:31:43 +00:00
8c81b23b6f
This allows functions that require an OMF segment byte count of up to 128K to be compiled, although the length in memory at run time is still limited to 64K. (The OMF segment byte count is usually larger, due to the size of relocation records, etc.) This is useful for compiling large functions, e.g. the main interpreter loop in git. It also fixes the bug shown in the compca23 test case, where functions that require a segment of over 64K may appear to compile correctly but generate corrupted OMF segment headers. This related to tracking sizes with 16-bit values that could roll over. This patch increases the memory needed at run time by 64K. This shouldn’t generally be a problem on systems with sufficient memory, although it does increase the minimum memory requirement a bit. If behavior in low-memory configurations is a concern, buffSize could be made into a run-time option.
596 lines
18 KiB
ObjectPascal
596 lines
18 KiB
ObjectPascal
{$optimize 7}
|
|
{---------------------------------------------------------------}
|
|
{ }
|
|
{ ObjOut }
|
|
{ }
|
|
{ This unit has the primitive routines used to actually }
|
|
{ create and write to object modules. A few low-level }
|
|
{ subroutines that need to be in assembly language for speed }
|
|
{ are also included here. }
|
|
{ }
|
|
{ External Subroutines: }
|
|
{ }
|
|
{ CloseObj - close the current obj file }
|
|
{ CloseSeg - close out the current segment }
|
|
{ COut - write a code byte to the object file }
|
|
{ CnOut - write a byte to the constant buffer }
|
|
{ CnOut2 - write a word to the constant buffer }
|
|
{ DestroySuffixes - destroy the .a, .b, etc suffixes }
|
|
{ FindSuffix - find the next available alphabetic suffix }
|
|
{ Header - write a segment header to the output file }
|
|
{ OpenObj - open a new obj file with the indicated file name }
|
|
{ OpenSeg - create a new segment and mark its beginning }
|
|
{ Out - write a byte to the output file }
|
|
{ Out2 - write a word to the output file }
|
|
{ Purge - write any constant bytes to the output buffer }
|
|
{ }
|
|
{---------------------------------------------------------------}
|
|
|
|
unit CCommon;
|
|
|
|
interface
|
|
|
|
{$LibPrefix '0/obj/'}
|
|
|
|
uses CCommon, CGI, CGC;
|
|
|
|
{$segment 'CodeGen'}
|
|
|
|
|
|
procedure CloseObj;
|
|
|
|
{ close the current obj file }
|
|
{ }
|
|
{ Note: Declared as extern in CGI.pas }
|
|
|
|
|
|
procedure COut (b: integer); extern;
|
|
|
|
{ write a code byte to the object file }
|
|
{ }
|
|
{ parameters: }
|
|
{ b - byte to write }
|
|
|
|
|
|
procedure CnOut (i: integer); extern;
|
|
|
|
{ write a byte to the constant buffer }
|
|
{ }
|
|
{ parameters: }
|
|
{ i - byte to write }
|
|
|
|
|
|
procedure CnOut2 (i: integer); extern;
|
|
|
|
{ write a word to the constant buffer }
|
|
{ }
|
|
{ parameters: }
|
|
{ i - word to write }
|
|
|
|
|
|
procedure DestroySuffixes (var name: gsosOutString);
|
|
|
|
{ destroy the .a, .b, etc suffixes }
|
|
{ }
|
|
{ parameters: }
|
|
{ name - root name of file sequence to destroy }
|
|
|
|
|
|
procedure CloseSeg;
|
|
|
|
{ close out the current segment }
|
|
|
|
|
|
procedure FindSuffix (var name: gsosOutString; var ch: char);
|
|
|
|
{ find the next available alphabetic suffix }
|
|
{ }
|
|
{ parameters: }
|
|
{ ch - addr to place suffix character }
|
|
{ name - root name of suffix to find }
|
|
|
|
|
|
procedure Header (name: stringPtr; kind: integer; lengthCode: integer);
|
|
|
|
{ write a segment header to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ name - name of the segment }
|
|
{ kind - segment kind }
|
|
{ lengthCode - code bank size code; bank size div $10000 }
|
|
|
|
|
|
procedure OpenSeg;
|
|
|
|
{ create a new segment and mark its beginning }
|
|
|
|
|
|
procedure OpenObj (var name: gsosOutString);
|
|
|
|
{ open a new obj file with the indicated file name }
|
|
{ }
|
|
{ parameters: }
|
|
{ name - object file name }
|
|
|
|
|
|
procedure Out (b: integer); extern;
|
|
|
|
{ write a byte to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ b - byte to write }
|
|
|
|
|
|
procedure Out2 (w: integer); extern;
|
|
|
|
{ write a word to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ w - word to write }
|
|
|
|
|
|
procedure Purge;
|
|
|
|
{ write any constant bytes to the output buffer }
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
implementation
|
|
|
|
const
|
|
{NOTE: OutByte and Outword assume }
|
|
{ buffSize is 128K }
|
|
buffSize = 131072; {size of the obj buffer}
|
|
maxCBuffLen = 191; {length of the constant buffer}
|
|
OBJ = $B1; {object file type}
|
|
|
|
type
|
|
closeOSDCB = record {Close DCB}
|
|
pcount: integer;
|
|
refNum: integer;
|
|
end;
|
|
|
|
createOSDCB = record {Create DCB}
|
|
pcount: integer;
|
|
pathName: gsosInStringPtr;
|
|
access: integer;
|
|
fileType: integer;
|
|
auxType: longint;
|
|
storageType: integer;
|
|
dataEOF: longint;
|
|
resourceEOF: longint;
|
|
end;
|
|
|
|
destroyOSDCB = record {Destroy DCB}
|
|
pcount: integer;
|
|
pathName: gsosInStringPtr;
|
|
end;
|
|
|
|
getFileInfoOSDCB = record {GetFileInfo DCB}
|
|
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;
|
|
|
|
openOSDCB = record {Open DCB}
|
|
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 {WriteGS DCB}
|
|
pcount: integer;
|
|
refNum: integer;
|
|
dataBuffer: ptr;
|
|
requestCount: longint;
|
|
transferCount: longint;
|
|
cachePriority: integer;
|
|
end;
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
var
|
|
cBuff: array[0..maxCBuffLen] of byte; {constant buffer}
|
|
|
|
objLen: longint; {# bytes used in obj buffer}
|
|
objHandle: handle; {handle of the obj buffer}
|
|
objPtr: ptr; {pointer to the next spot in the obj buffer}
|
|
|
|
segStart: ptr; {points to first byte in current segment}
|
|
spoolRefnum: integer; {reference number for open file}
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
{memory manager calls}
|
|
{--------------------}
|
|
|
|
procedure BlockMove (sourcPtr, destPtr: ptr; count: longint); tool ($02, $2B);
|
|
|
|
function NewHandle (blockSize: longint; userID, memAttributes: integer;
|
|
memLocation: ptr): handle; tool($02, $09);
|
|
|
|
procedure SetHandleSize (newSize: longint; theHandle: handle); tool ($02, $19);
|
|
|
|
procedure HUnLock (theHandle: handle); tool ($02, $22);
|
|
|
|
procedure HLock (theHandle: handle); tool ($02, $20);
|
|
|
|
{ProDOS calls}
|
|
{------------}
|
|
|
|
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 OpenGS (var parms: openOSDCB); prodos ($2010);
|
|
|
|
procedure WriteGS (var parms: readWriteOSDCB); prodos ($2013);
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
procedure PurgeObjBuffer;
|
|
|
|
{ Spool any completed segments to the object file }
|
|
|
|
var
|
|
len: longint; {# bytes to write}
|
|
sPtr: ptr; {start of object buffer}
|
|
wrRec: readWriteOSDCB; {WriteGS record}
|
|
|
|
|
|
procedure InitSpoolFile;
|
|
|
|
{ Set up the spool file }
|
|
|
|
var
|
|
dsRec: destroyOSDCB; {DestroyGS record}
|
|
crRec: createOSDCB; {CreateGS record}
|
|
opRec: openOSDCB; {OpenGS record}
|
|
|
|
begin {InitSpoolFile}
|
|
if memoryCompile then {make sure this is a disk-based compile}
|
|
TermError(11);
|
|
dsRec.pCount := 1; {destroy any old file}
|
|
dsRec.pathname := @objFile.theString;
|
|
DestroyGS(dsRec);
|
|
crRec.pCount := 5; {create a new file}
|
|
crRec.pathName := @objFile.theString;
|
|
crRec.access := $C3;
|
|
crRec.fileType := OBJ;
|
|
crRec.auxType := $0000;
|
|
crRec.storageType := 1;
|
|
CreateGS(crRec);
|
|
if ToolError <> 0 then
|
|
TermError(9);
|
|
opRec.pCount := 3; {open the file}
|
|
opRec.pathname := @objFile.theString;
|
|
opRec.requestAccess := 3;
|
|
OpenGS(opRec);
|
|
if ToolError <> 0 then
|
|
TermError(9);
|
|
spoolRefnum := opRec.refnum;
|
|
end; {InitSpoolFile}
|
|
|
|
|
|
begin {PurgeObjBuffer}
|
|
if spoolRefnum = 0 then {make sure the spool file exists}
|
|
InitSpoolFile;
|
|
sPtr := objHandle^; {determine size of completed segments}
|
|
len := ord4(segStart) - ord4(sPtr);
|
|
if len <> 0 then begin
|
|
wrRec.pcount := 4; {write completed segments}
|
|
wrRec.refnum := spoolRefnum;
|
|
wrRec.dataBuffer := pointer(sPtr);
|
|
wrRec.requestCount := len;
|
|
WriteGS(wrRec);
|
|
if ToolError <> 0 then {check for write errors}
|
|
TermError(9);
|
|
objLen := 0; {adjust file pointers}
|
|
BlockMove(segStart, sPtr, segDisp);
|
|
objPtr := sPtr;
|
|
segStart := sPtr;
|
|
end; {if}
|
|
end; {PurgeObjBuffer}
|
|
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
procedure CloseObj;
|
|
|
|
{ close the current obj file }
|
|
{ }
|
|
{ Note: Declared as extern in CGI.pas }
|
|
|
|
var
|
|
clRec: closeOSDCB; {CloseGS record}
|
|
ffDCBGS: fastFileDCBGS; {dcb for fastfile call}
|
|
i: integer; {loop/index variable}
|
|
|
|
begin {CloseObj}
|
|
if spoolRefnum <> 0 then begin
|
|
PurgeObjBuffer;
|
|
clRec.pCount := 1;
|
|
clRec.refnum := spoolRefnum;
|
|
CloseGS(clRec);
|
|
end {if}
|
|
else if objLen <> 0 then begin
|
|
{resize the buffer}
|
|
HUnLock(objHandle);
|
|
SetHandleSize(objLen, objHandle);
|
|
HLock(objHandle);
|
|
|
|
{save the file}
|
|
ffDCBGS.pCount := 14;
|
|
ffDCBGS.fileHandle := objHandle;
|
|
ffDCBGS.pathName := @objFile.theString;
|
|
ffDCBGS.access := $C3;
|
|
ffDCBGS.fileType := OBJ;
|
|
ffDCBGS.auxType := 0;
|
|
ffDCBGS.storageType := 1;
|
|
for i := 1 to 8 do
|
|
ffDCBGS.createDate[i] := 0;
|
|
ffDCBGS.modDate := ffDCBGS.createDate;
|
|
ffDCBGS.option := nil;
|
|
ffDCBGS.fileLength := objLen;
|
|
if memoryCompile then begin
|
|
ffDCBGS.flags := 0;
|
|
ffDCBGS.action := 4;
|
|
end {if}
|
|
else begin
|
|
ffDCBGS.flags := $C000;
|
|
ffDCBGS.action := 3;
|
|
end; {else}
|
|
FastFileGS(ffDCBGS);
|
|
if ToolError <> 0 then
|
|
TermError(9)
|
|
else begin
|
|
ffDCBGS.PATHName := @objFile.theString;
|
|
ffDCBGS.action := 7;
|
|
FastFileGS(ffDCBGS);
|
|
end; {else}
|
|
end; {if}
|
|
end; {CloseObj}
|
|
|
|
|
|
procedure DestroySuffixes {var name: gsosOutString};
|
|
|
|
{ destroy the .a, .b, etc suffixes }
|
|
{ }
|
|
{ parameters: }
|
|
{ name - root name of file sequence to destroy }
|
|
|
|
var
|
|
done: boolean; {loop termination flag}
|
|
dsDCBGS: destroyOSDCB; {dcb for destroy call}
|
|
giDCBGS: getFileInfoOSDCB; {dcb for Get_File_Info call}
|
|
suffix: char; {current suffix character}
|
|
|
|
fName: gsosInString; {work file name}
|
|
|
|
begin {DestroySuffixes}
|
|
suffix := 'a';
|
|
done := false;
|
|
repeat
|
|
fName := name.theString;
|
|
if fName.size > maxPath-2 then
|
|
fName.size := maxPath-2;
|
|
fName.theString[fName.size+1] := '.';
|
|
fName.theString[fName.size+2] := suffix;
|
|
fName.size := fName.size + 2;
|
|
giDCBGS.pCount := 12;
|
|
giDCBGS.optionList := nil;
|
|
giDCBGS.pathName := @fName;
|
|
GetFileInfoGS(giDCBGS);
|
|
if ToolError = 0 then begin
|
|
if giDCBGS.fileType = OBJ then begin
|
|
dsDCBGS.pCount := 1;
|
|
dsDCBGS.pathName := @fName;
|
|
DestroyGS(dsDCBGS);
|
|
end; {if}
|
|
end {if}
|
|
else
|
|
done := true;
|
|
suffix := succ(suffix);
|
|
until done;
|
|
end; {DestroySuffixes}
|
|
|
|
|
|
procedure CloseSeg;
|
|
|
|
{ close out the current segment }
|
|
{ }
|
|
{ variables: }
|
|
{ objHandle - segment handle }
|
|
{ objLen - used bytes in the segment }
|
|
{ objPtr - set to point to a fresh segment }
|
|
|
|
var
|
|
longPtr: ^longint; {used to set the block count}
|
|
|
|
begin {CloseSeg}
|
|
longPtr := pointer(objPtr); {set the block count}
|
|
longPtr^ := segDisp;
|
|
objLen := objLen + segDisp; {update the length of the obj file}
|
|
objPtr := pointer(ord4(objHandle^)+objLen); {set objPtr}
|
|
segStart := objPtr;
|
|
if objLen = buffSize then
|
|
PurgeObjBuffer;
|
|
currentSegment := defaultSegment; {revert to default segment name}
|
|
end; {CloseSeg}
|
|
|
|
|
|
procedure FindSuffix {var name: gsosOutString; var ch: char};
|
|
|
|
{ find the next available alphabetic suffix }
|
|
{ }
|
|
{ parameters: }
|
|
{ ch - addr to place suffix character }
|
|
{ name - root name of suffix to find }
|
|
|
|
var
|
|
done: boolean; {loop termination test}
|
|
giDCBGS: getFileInfoOSDCB; {dcb for Get_File_Info call}
|
|
|
|
fName: gsosInString; {work file name}
|
|
|
|
begin {FindSuffix}
|
|
ch := 'a';
|
|
done := false;
|
|
repeat
|
|
fName := name.theString;
|
|
if fName.size > maxPath-2 then
|
|
fName.size := maxPath-2;
|
|
fName.theString[fName.size+1] := '.';
|
|
fName.theString[fName.size+2] := ch;
|
|
fName.size := fName.size + 2;
|
|
giDCBGS.pCount := 12;
|
|
giDCBGS.optionList := nil;
|
|
giDCBGS.pathName := @fName;
|
|
GetFileInfoGS(giDCBGS);
|
|
if ToolError = 0 then
|
|
ch := succ(ch)
|
|
else
|
|
done := true;
|
|
until done;
|
|
end; {FindSuffix}
|
|
|
|
|
|
procedure Header {name: stringPtr; kind: integer; lengthCode: integer};
|
|
|
|
{ write a segment header to the output file }
|
|
{ }
|
|
{ parameters: }
|
|
{ name - name of the segment }
|
|
{ kind - segment kind }
|
|
{ lengthCode - code bank size code; bank size div $10000 }
|
|
|
|
|
|
var
|
|
i: integer; {loop var}
|
|
len: integer; {length of string}
|
|
|
|
begin {Header}
|
|
OpenSeg; {start the new segment}
|
|
blkcnt := 0; segdisp := 0;
|
|
for i := 1 to 12 do {blkcnt,resspc,length}
|
|
Out(0);
|
|
Out(0); {unused}
|
|
Out(0); {lablen}
|
|
Out(4); {numlen}
|
|
Out(2); {version}
|
|
Out2(0); Out2(ord(lengthcode=0)); {cbanksize}
|
|
Out2(kind|segmentKind); {kind}
|
|
for i := 1 to 9 do {unused,org,align,numsex,unused,segnum,entry}
|
|
Out2(0);
|
|
len := length(name^); {dispname,dispdata}
|
|
Out2($30); Out2($3B+len);
|
|
Out2(0); Out2(0); {temporg}
|
|
for i := 1 to 10 do {write the segment name}
|
|
Out(ord(currentSegment[i]));
|
|
Out(len); {segname}
|
|
for i := 1 to len do
|
|
Out(ord(name^[i]));
|
|
end; {Header}
|
|
|
|
|
|
procedure OpenSeg;
|
|
|
|
{ create a new segment and mark its beginning }
|
|
|
|
begin {OpenSeg}
|
|
segDisp := 0;
|
|
segStart := objPtr;
|
|
end; {OpenSeg}
|
|
|
|
|
|
procedure OpenObj {var name: gsosOutString};
|
|
|
|
{ open a new obj file with the indicated file name }
|
|
{ }
|
|
{ parameters: }
|
|
{ name - object file name }
|
|
|
|
var
|
|
dsDCBGS: destroyOSDCB; {dcb for Destroy call}
|
|
giDCBGS: getFileInfoOSDCB; {dcb for Get_File_Info call}
|
|
|
|
begin {OpenObj}
|
|
{the file is not spooled (yet)}
|
|
spoolRefnum := 0;
|
|
|
|
{if there is an existing file, delete it}
|
|
if memoryCompile then begin
|
|
giDCBGS.pCount := 3;
|
|
giDCBGS.pathName := @name.theString;
|
|
GetFileInfoGS(giDCBGS);
|
|
if ToolError = 0 then
|
|
if giDCBGS.fileType = OBJ then begin
|
|
dsDCBGS.pCount := 1;
|
|
dsDCBGS.pathName := @name.theString;
|
|
DestroyGS(dsDCBGS);
|
|
end; {if}
|
|
end; {if}
|
|
|
|
{allocate memory for an initial buffer}
|
|
objHandle := pointer(NewHandle(buffSize, userID, $8000, nil));
|
|
|
|
{set up the buffer variables}
|
|
if ToolError = 0 then begin
|
|
objLen := 0;
|
|
objPtr := objHandle^;
|
|
end {if}
|
|
else
|
|
TermError(5);
|
|
|
|
{save the object file name}
|
|
objFile := name;
|
|
end; {OpenObj}
|
|
|
|
|
|
procedure Purge;
|
|
|
|
{ write any constant bytes to the output buffer }
|
|
|
|
var
|
|
i: integer; {loop variable}
|
|
|
|
begin {Purge}
|
|
if cBuffLen <> 0 then begin
|
|
Out(cBuffLen);
|
|
for i := 0 to cBuffLen-1 do
|
|
COut(cBuff[i]);
|
|
cBuffLen := 0;
|
|
end; {if}
|
|
end; {Purge}
|
|
|
|
end.
|
|
|
|
{$append 'objout.asm'}
|