mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-23 08:24:18 +00:00
306 lines
8.3 KiB
ObjectPascal
306 lines
8.3 KiB
ObjectPascal
(*************************************************************************)
|
|
(* *)
|
|
(* CPMJOB v1.00 (c) Copyright 1992-2009, S.J.Kay *)
|
|
(* *)
|
|
(* Support utility for IBM Z80 Emulator CP/M 3 *)
|
|
(* *)
|
|
(*************************************************************************)
|
|
|
|
{ WARNING - Make sure the END address is lowered to say about $8000 }
|
|
{ before compiling to disk otherwise it will crash when used from }
|
|
{ within a SUBMIT file. This happens to any TURBO v2.00a compiled }
|
|
{ program because it does not check the TPA size !. }
|
|
|
|
{
|
|
ChangeLog
|
|
---------
|
|
20 February 2009, SJK
|
|
- In EmulatorParameter procedure remove any options passed to z80em86.
|
|
|
|
27 April 1995, SJK
|
|
- Undocumented changes.
|
|
}
|
|
|
|
{$C-} { turn off ^C and ^S checking }
|
|
|
|
type
|
|
registers = record
|
|
case boolean of
|
|
true : (AL, AH, BL, BH, CL, CH, DL, DH : byte);
|
|
false : (AX, BX, CX, DX,
|
|
BP, SI, DI, DS, ES, FLAGS : integer)
|
|
end;
|
|
|
|
String80 = string[80];
|
|
|
|
const
|
|
ENDBUF = $1FFF;
|
|
FLENME = 'CPMJOB.SUB';
|
|
|
|
var
|
|
R : registers;
|
|
ComLne : string[80] absolute $0080;
|
|
CpmPth : string[80];
|
|
DosPth : string[128];
|
|
DosSpc : array [0..79] of byte;
|
|
Buffer : array [0..ENDBUF] of char;
|
|
|
|
|
|
procedure ProcZ80 (Fn, Ax : byte; BCx, DEx, HLx : integer);
|
|
begin
|
|
inline
|
|
(
|
|
$3A/Fn/ { ld a,(Fn) }
|
|
$32/* + 17/ { ld (FNCNMB),a }
|
|
$3A/Ax/ { ld a,(Ax) }
|
|
$ED/$4B/BCx/ { ld bc,(BCx) }
|
|
$ED/$5B/DEx/ { ld de,(DEx) }
|
|
$2A/HLx/ { ld hl,(HLx) }
|
|
$D3/$FF { out (FNCNMB),a }
|
|
)
|
|
end;
|
|
|
|
|
|
function FuncZ80 (Fn, Ax : byte; BCx, DEx, HLx : integer) : byte;
|
|
const
|
|
BytVal : byte = 0;
|
|
begin
|
|
inline
|
|
(
|
|
$3A/Fn/ { ld a,(Fn) }
|
|
$32/* + 17/ { ld (FNCNMB),a }
|
|
$3A/Ax/ { ld a,(Ax) }
|
|
$ED/$4B/BCx/ { ld bc,(BCx) }
|
|
$ED/$5B/DEx/ { ld de,(DEx) }
|
|
$2A/HLx/ { ld hl,(HLx) }
|
|
$D3/$FF/ { out (FNCNMB),a }
|
|
$32/BytVal { ld (BYTVAL),a }
|
|
);
|
|
FuncZ80 := BytVal
|
|
end;
|
|
|
|
|
|
function GetByt (Seg, Off : integer) : byte;
|
|
begin
|
|
GetByt := FuncZ80($B0, 0, 0, Seg, Off)
|
|
end;
|
|
|
|
|
|
procedure Intr (Int : byte; var R : registers);
|
|
begin
|
|
ProcZ80($A1, Int, $AA55, $55AA, addr(R))
|
|
end;
|
|
|
|
|
|
procedure Msdos (var R : registers);
|
|
begin
|
|
Intr($21, R)
|
|
end;
|
|
|
|
|
|
function Seg (var Dummy) : integer;
|
|
const
|
|
SegAdr : integer = 0;
|
|
begin
|
|
ProcZ80($A0, 0, 0, 0, addr(SegAdr));
|
|
Seg := SegAdr
|
|
end;
|
|
|
|
|
|
function Ofs (var VarTyp) : integer;
|
|
begin
|
|
Ofs := addr(VarTyp)
|
|
end;
|
|
|
|
|
|
procedure ReportError (ErrStr : String80);
|
|
begin
|
|
ProcZ80($FB, 0, 0, 0, 0); { turn video on }
|
|
writeln('CPMJOB.COM Error, ', ErrStr)
|
|
end;
|
|
|
|
|
|
procedure WriteSubmitFile (FleSze : integer);
|
|
var
|
|
F : text;
|
|
i, Error : integer;
|
|
begin
|
|
assign(F, CpmPth);
|
|
{$I-}
|
|
rewrite(F); { open CP/M file for writing }
|
|
Error := ioresult;
|
|
if Error = 0 then
|
|
begin
|
|
i := 0;
|
|
if FleSze <> 0 then
|
|
begin
|
|
writeln(F, 'video on');
|
|
Error := ioresult
|
|
end;
|
|
while (i < FleSze) and (Error = 0) do
|
|
begin
|
|
write(F, Buffer[i]);
|
|
Error := ioresult;
|
|
i := i + 1
|
|
end;
|
|
if FleSze <> 0 then
|
|
begin
|
|
writeln(F, 'exit');
|
|
Error := ioresult
|
|
end;
|
|
if Error = 0 then
|
|
begin
|
|
close(F); { close CP/M file }
|
|
Error := ioresult;
|
|
if Error <> 0 then
|
|
ReportError('Could not close destination file')
|
|
end
|
|
else
|
|
ReportError('Destination disk full error')
|
|
end
|
|
else
|
|
ReportError('Could not create destination file')
|
|
{$I-}
|
|
end;
|
|
|
|
|
|
procedure MakeSubmitFile;
|
|
begin
|
|
if DosPth <> '' then
|
|
begin
|
|
DosPth := DosPth + ^M^J;
|
|
move(DosPth[1], Buffer, length(DosPth))
|
|
end;
|
|
WriteSubmitFile(length(DosPth))
|
|
end;
|
|
|
|
|
|
procedure CopySubmitFile;
|
|
var
|
|
FleHnd, FleSze, Error : integer;
|
|
begin
|
|
move(DosPth[1], DosSpc[0], length(DosPth));
|
|
DosSpc[length(DosPth)] := 0;
|
|
R.AH := $3D; { open file function }
|
|
R.AL := $00; { read access }
|
|
R.DS := seg(DosSpc);
|
|
R.DX := ofs(DosSpc);
|
|
Msdos(R); { open DOS file for reading }
|
|
FleHnd := R.AX; { file handle }
|
|
Error := R.Flags and 1;
|
|
if Error = 0 then
|
|
begin
|
|
R.AH := $3F; { read file or device function }
|
|
R.BX := FleHnd; { file handle }
|
|
R.CX := ENDBUF+1; { bytes to read }
|
|
R.DS := seg(Buffer);
|
|
R.DX := ofs(Buffer);
|
|
Msdos(R); { read data from DOS file }
|
|
FleSze := R.AX; { number of bytes read from file }
|
|
if R.AX > ENDBUF then
|
|
Error := 2
|
|
else
|
|
Error := (R.Flags and 1) * 3
|
|
end;
|
|
if Error = 0 then
|
|
begin
|
|
R.AH := $3E; { close file function }
|
|
R.BX := FleHnd; { file handle }
|
|
Msdos(R); { close DOS file }
|
|
Error := (R.Flags and 1) * 4
|
|
end;
|
|
if Error <> 0 then
|
|
begin
|
|
case Error of
|
|
1 : ReportError('Could not open source submit file');
|
|
2 : ReportError('Source submit file is too big');
|
|
3 : ReportError('Reading source submit file');
|
|
4 : ReportError('Could not close source submit file')
|
|
end;
|
|
DosPth := 'exit';
|
|
MakeSubmitFile
|
|
end
|
|
else
|
|
WriteSubmitFile(FleSze)
|
|
end;
|
|
|
|
|
|
procedure EmulatorParameter;
|
|
const
|
|
SegOff : array [0..1] of integer = (0, 0);
|
|
var
|
|
CpyPth : string[80];
|
|
Seg : integer;
|
|
Off : integer;
|
|
i : integer;
|
|
options : boolean;
|
|
begin
|
|
CpyPth := '';
|
|
ProcZ80($F9, 0, 0, 0, addr(SegOff)); { seg:off of parameter }
|
|
Seg := SegOff[0];
|
|
Off := SegOff[1];
|
|
for i := 1 to GetByt(Seg, Off) do
|
|
DosPth := DosPth + chr(GetByt(Seg, Off + i));
|
|
|
|
repeat
|
|
while pos(' ', DosPth) = 1 do { delete leading spaces }
|
|
delete(DosPth, 1, 1);
|
|
options := pos('-', DosPth) = 1; { any emulator options specified ? }
|
|
if options then { deleted any leading option }
|
|
begin
|
|
delete(DosPth, 1, 1);
|
|
while (DosPth <> '') and (DosPth[1] <> ' ') do
|
|
delete(DosPth, 1, 1);
|
|
end
|
|
until not options;
|
|
|
|
while pos(' ', DosPth) = length(DosPth) do
|
|
DosPth[0] := chr(length(DosPth) - 1);
|
|
for i := 1 to length(DosPth) do
|
|
CpyPth := CpyPth + upcase(DosPth[i]);
|
|
if pos(' ', CpyPth) = 0 then { possibly a SUB file }
|
|
begin
|
|
i := pos('.SUB', CpyPth);
|
|
if (i > 0) and (i = (length(CpyPth) - 3)) then
|
|
CopySubmitFile
|
|
else
|
|
MakeSubmitFile
|
|
end
|
|
else
|
|
MakeSubmitFile
|
|
end;
|
|
|
|
|
|
function CpmParameter : boolean;
|
|
var
|
|
GotPrm : boolean;
|
|
begin
|
|
while pos(' ', CpmPth) = 1 do
|
|
delete(CpmPth, 1, 1);
|
|
GotPrm := (CpmPth <> '') and (length(CpmPth) <= 2);
|
|
if GotPrm then
|
|
begin
|
|
if length(CpmPth) = 2 then
|
|
GotPrm := CpmPth[2] = ':'
|
|
else
|
|
CpmPth := CpmPth + ':'
|
|
end;
|
|
CpmPth := CpmPth + FLENME;
|
|
CpmParameter := GotPrm
|
|
end;
|
|
|
|
|
|
begin
|
|
CpmPth := ComLne;
|
|
DosPth := '';
|
|
if CpmParameter then
|
|
begin
|
|
if FuncZ80($F8, 0, 0, 0, 0) <> 0 then { parameter to Z80.EXE ? }
|
|
EmulatorParameter
|
|
else
|
|
MakeSubmitFile
|
|
end
|
|
else
|
|
ReportError('CP/M path error')
|
|
end.
|