ORCA-Pascal/objout.pas
2018-03-12 14:15:39 -04:00

562 lines
17 KiB
ObjectPascal

{$optimize -1}
{---------------------------------------------------------------}
{ }
{ 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. }
{ }
{---------------------------------------------------------------}
unit ObjOut;
interface
{$LibPrefix '0/obj/'}
uses PCommon, CGI, CGC;
{$segment 'CodeGen'}
procedure CloseObj;
{ close the current obj file }
{ }
{ Note: Declared as extern in CGI.pas }
procedure CloseSeg;
{ close out the current segment }
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 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: pStringPtr; 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 OpenObj (var name: gsosOutString);
{ open a new obj file with the indicated file name }
{ }
{ parameters: }
{ name - object file name }
procedure OpenSeg;
{ create a new segment and mark its beginning }
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 TokenOut (b: byte); extern;
{ Write a byte to the interface file }
{ }
{ parameters: }
{ b - byte to write }
{ }
{ Notes: Also declared as extern in cgi.pas }
procedure Purge;
{ write any constant bytes to the output buffer }
{---------------------------------------------------------------}
implementation
const
{NOTE: OutByte and Outword assume }
{ buffSize is 64K }
buffSize = 65536; {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;
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}
objFile: gsosOutString; {object file name}
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}
{---------------------------------------------------------------}
{ProDOS calls}
{------------}
procedure CloseGS (var parms: closeOSDCB); prodos ($2014);
procedure CreateGS (var parms: createOSDCB); prodos ($2001);
procedure OpenGS (var parms: openOSDCB); prodos ($2010);
procedure WriteGS (var parms: readWriteOSDCB); prodos ($2013);
{memory manager calls}
{--------------------}
procedure BlockMove (sourcPtr, destPtr: ptr; count: longint); tool ($02, $2B);
procedure HUnLock (theHandle: handle); tool ($02, $22);
procedure HLock (theHandle: handle); tool ($02, $20);
function NewHandle (blockSize: longint; userID, memAttributes: integer;
memLocation: ptr): handle; tool($02, $09);
procedure SetHandleSize (newSize: longint; theHandle: handle); tool ($02, $19);
{---------------------------------------------------------------}
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 memoryFlag then {make sure this is a disk-based compile}
TermError(5, nil);
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(8, nil);
opRec.pCount := 3; {open the file}
opRec.pathname := @objFile.theString;
opRec.requestAccess := 3;
OpenGS(opRec);
if ToolError <> 0 then
TermError(8, nil);
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(13, nil);
objLen := 0; {adjust file pointers}
BlockMove(segStart, sPtr, ord4(segDisp) & $00FFFF);
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 memoryFlag 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(13, nil)
else begin
ffDCBGS.PATHName := @objFile.theString;
ffDCBGS.action := 7;
FastFileGS(ffDCBGS);
end; {else}
end; {if}
end; {CloseObj}
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^ := ord4(segDisp) & $00FFFF;
objLen := objLen + (ord4(segDisp) & $00FFFF); {update the length of the obj file}
objPtr := pointer(ord4(objHandle^)+objLen); {set objPtr}
segStart := objPtr;
if objLen = buffSize then
PurgeObjBuffer;
end; {CloseSeg}
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}
ffDCBGS: fastFileDCBGS; {dcb for fastfile calls}
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 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: pStringPtr; 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]));
currentSegment := defaultSegment; {revert to default segment name}
Out(len); {segname}
for i := 1 to len do
Out(ord(name^[i]));
end; {Header}
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 memoryFlag 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 begin
TermError(3, nil);
end;
{save the object file name}
objFile := name;
end; {OpenObj}
procedure OpenSeg;
{ create a new segment and mark its beginning }
begin {OpenSeg}
segDisp := 0;
segStart := objPtr;
end; {OpenSeg}
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'}