mirror of
https://github.com/byteworksinc/ORCA-C.git
synced 2024-05-28 12:41:35 +00:00
6857913daa
It will now grow as needed to accommodate large segments, subject to the constraints of available memory. In practice, this mostly affects the size of initialized static arrays that can be used. This also removes any limit apart from memory size on how large the object representation produced by a "compile to memory" can be, and cleans up error reporting regarding size limits.
618 lines
19 KiB
ObjectPascal
618 lines
19 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
|
|
initialBuffSize = $10000; {initial size of the obj buffer}
|
|
{NOTE: must be a power of two >= 64K}
|
|
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; {points to first byte in current segment}
|
|
minusBuffSize: longint; {size of obj buffer, negated}
|
|
|
|
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(3);
|
|
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(objPtr) - 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(objPtr, sPtr, segDisp);
|
|
objPtr := sPtr;
|
|
end; {if}
|
|
end; {PurgeObjBuffer}
|
|
|
|
|
|
procedure MakeSpaceInObjBuffer;
|
|
|
|
{ Make space in the object buffer (at least two bytes) by }
|
|
{ purging or expanding it. }
|
|
|
|
var
|
|
segOffset: longint; {offset into buffer of current segment}
|
|
|
|
begin {MakeSpaceInObjBuffer}
|
|
segOffset := ord4(objPtr) - ord4(objHandle^);
|
|
|
|
if (segOffset >= 2) and not memoryCompile then
|
|
PurgeObjBuffer
|
|
else begin
|
|
{resize the buffer}
|
|
minusBuffSize := minusBuffSize * 2;
|
|
HUnLock(objHandle);
|
|
SetHandleSize(-minusBuffSize, objHandle);
|
|
if ToolError <> 0 then
|
|
TermError(5);
|
|
HLock(objHandle);
|
|
objPtr := ptr(ord4(objHandle^) + segOffset);
|
|
end; {if}
|
|
end; {MakeSpaceInObjBuffer}
|
|
|
|
|
|
{---------------------------------------------------------------}
|
|
|
|
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}
|
|
segDisp := 0;
|
|
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;
|
|
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(initialBuffSize, userID, $8000, nil));
|
|
|
|
{set up the buffer variables}
|
|
if ToolError = 0 then begin
|
|
objLen := 0;
|
|
objPtr := objHandle^;
|
|
minusBuffSize := -initialBuffSize;
|
|
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'}
|