000
06.12.2009, 13:11 Uhr
Ralph
|
Hallo,
wer kann mir eine Pascal Programm als CP / M 2.2 COM-Datei kompilieren?
Leider weiß ich nicht genau, was für ein Quelltext das ist .. deshalb hier mal ein der Code der zu übersetzen wäre.
Ich möchte gern dieses Tool auf den AC1 anpassen. Vielen Dank Euch!
| Quellcode: | program IDE_Test_Programm;
(* written Q&D 920308 by Tilmann Reh *)
(* some modifications during 1992 & 1993 *)
(* translated and adapted to GIDE 950403 Tilmann Reh *)
(* variable base address added 951015 Tilmann Reh *)
(* an AC1 angepasst 05.12.2009 Ralph Haensel *)
const signon = ^m^j'IDE Harddisk Utility V0.4 TR 951015'^m^j;
(* default geometry of connected SSD harddisk *)
(* here: default mode SSD *)
(* enter real dimension, not greatest value! *)
const cylinders : integer = 984;
heads : integer = 16;
sectors : integer = 32;
(* I/O addresses and commands of the IDE interface/drive *)
(* The I/O addresses are user selectable in steps of $10 *)
GIDEbase : integer = $80; (* GIDE base address *)
cmd_readsector = $20;
cmd_writesector = $30;
cmd_seek = $70;
cmd_diagnostics = $90;
cmd_initialize = $91;
cmd_identify = $EC;
(* variables *)
type workstr = string[30];
buftype = array[0..511] of byte;
str = string[80];
IDRecord = record
config : integer;
NumCyls : integer;
NumCyls2 : integer;
NumHeads : integer;
BytesPerTrk : integer;
BytesPerSec : integer;
SecsPerTrack : integer;
d1,d2,d3 : integer;
SerNo : array [0..19] of char;
CtrlType : integer;
BfrSize : integer;
ECCBytes : integer;
CtrlRev : array [0..7] of char;
CtrlModl : array [0..39] of char;
SecsPerInt : integer;
DblWordFlag : Integer;
WrProtect : integer;
end;
var Alt_Status,IDE_Data,IDE_Error,
IDE_SecCnt,IDE_SecNum,IDE_CylLow,
IDE_CylHigh,IDE_SDH,IDE_CmdStat : integer;
secbuf,bakbuf : buftype;
i,j,k,l,m : integer;
func,c : char;
err : boolean;
s : workstr;
(* use our own console status routine, since the one implemented in *)
(* Turbo-Pascal won't detect the "keypressed" status properly. *)
function ConStat:boolean;
begin
ConStat:=BIOS(1)>0;
end;
(* translate numbers into their hex representation (as string). *)
function hexbyte(x:byte):workstr;
const nib : array[0..15] of char = '0123456789ABCDEF';
begin
hexbyte:=nib[x shr 4]+nib[x and 15];
end;
function hexword(x:integer):workstr;
begin
hexword:=hexbyte(hi(x))+hexbyte(lo(x));
end;
(* Set the port addresses for the various interface registers. *)
(* The addresses are kept in variables since they can be *)
(* changed during run-time. *)
procedure SetPorts(var base:integer);
begin
base:=base and $F0;
Alt_Status:=base+6;
IDE_Data:=base+8;
IDE_Error:=base+9;
IDE_SecCnt:=base+10;
IDE_SecNum:=base+11;
IDE_CylLow:=base+12;
IDE_CylHigh:=base+13;
IDE_SDH:=base+14;
IDE_CmdStat:=base+15;
writeln('Ports setup for base ',HexByte(base),'h.');
end;
(* Translate an ARRAY OF CHAR from the drive into a Pascal-usable string. *)
(* (character pairs must be swapped for this.) *)
function st(s:str):str;
var s1 : str;
i : byte;
begin
s1[0]:=s[0];
for i:=0 to pred(length(s)) do s1[i+1]:=s[(i xor 1)+1];
st:='>'+s1+'<';
end;
(* display error status *)
procedure Error(s:workstr; flag:boolean);
begin
writeln(' ',s,'; Status: ',hexbyte(port[ide_cmdstat]),
' ',hexbyte(port[ide_error]));
if flag then halt;
end;
(* Wait until the drive is ready to accept a command. *)
(* The timeout value may be changed according to the drive. *)
(* Remove the "i:=succ(i)" instruction to disable timeout. *)
procedure wait_ready;
const timeout = 30000;
var i : integer;
begin
i:=0;
while (port[ide_cmdstat]>128) and (i<timeout) do i:=succ(i);
if i=timeout then Error('WaitReady TimeOut',true);
end;
(* Wait for the drive's Data Request (DRQ). *)
(* For the timeout, see above. *)
procedure wait_drq;
const timeout = 30000;
var i : integer;
begin
i:=0;
while (port[ide_cmdstat] and 8=0) and (i<timeout) do i:=succ(i);
if i=timeout then Error('WaitDRQ TimeOut',true);
end;
(* write a command to the drive *)
procedure ide_command(cmd:byte);
begin
wait_ready;
port[ide_cmdstat]:=cmd;
wait_ready;
end;
(* Read the sector buffer from the drive. *)
function read_secbuf(var buf:buftype):boolean;
var i : integer;
begin
wait_drq;
for i:=0 to 511 do buf[i]:=port[ide_data];
read_secbuf:=port[ide_cmdstat] and $89=0;
end;
(* Write the sector buffer to the drive. *)
function write_secbuf(var buf:buftype):boolean;
var i : integer;
begin
wait_drq;
for i:=0 to 511 do port[ide_data]:=buf[i];
wait_ready;
write_secbuf:=port[ide_cmdstat] and $89=0;
end;
(* position the drive on the desired cylinder (seek) *)
function hd_seek(cyl:integer):boolean;
begin
wait_ready;
port[ide_cyllow]:=lo(cyl);
port[ide_cylhigh]:=hi(cyl);
port[ide_sdh]:=$A0;
ide_command(cmd_seek);
hd_seek:=port[ide_cmdstat] and $89=0;
end;
(* Read a single sector from the drive. Retry up to 5 times on error. *)
(* Print the number of tries if above 1, and report errors. *)
procedure hd_readsector(cyl,head,sec:integer; var buf:buftype);
var n : byte;
b : boolean;
begin
n:=0;
repeat
wait_ready;
port[ide_error]:=$AA;
port[ide_seccnt]:=1;
port[ide_secnum]:=sec;
port[ide_cyllow]:=lo(cyl);
port[ide_cylhigh]:=hi(cyl);
port[ide_sdh]:=$A0+head;
ide_command(cmd_readsector);
b:=read_secbuf(buf);
n:=succ(n);
until b or (n>5);
if not b then Error('Read Sector',false) else if n>1 then writeln(n:5);
end;
(* Write a single sector to the drive. No need for retries yet, *)
(* until now it was just a go/nogo behaviour. *)
procedure hd_writesector(cyl,head,sec:integer; var buf:buftype);
begin
wait_ready;
port[ide_seccnt]:=1;
port[ide_secnum]:=sec;
port[ide_cyllow]:=lo(cyl);
port[ide_cylhigh]:=hi(cyl);
port[ide_sdh]:=$A0+head;
ide_command(cmd_writesector);
if not write_secbuf(buf) then Error('Write Sector',false);
end;
(* initialise the harddisk drive and set the desired geometry *)
procedure hd_init(cyls,hds,secs:integer);
begin
writeln('Initialising the drive...');
port[alt_status]:=6;
delay(10); (* Drive Software Reset *)
port[alt_status]:=2;
wait_ready;
writeln(port[ide_error]:4,port[ide_seccnt]:4,port[ide_secnum]:4,
port[ide_cyllow]:4,port[ide_cylhigh]:4,port[ide_sdh]:4);
port[ide_seccnt]:=secs;
port[ide_cyllow]:=lo(cyls);
port[ide_cylhigh]:=hi(cyls);
port[ide_sdh]:=pred(hds)+$A0;
ide_command(cmd_initialize);
writeln('Mode : ',cyls,'x',hds,'x',secs);
end;
(* read and show drive ID data *)
procedure hd_identify;
var buffer : IDRecord absolute secbuf;
Words : array[0..255] of integer absolute secbuf;
i,j : integer;
secs : real;
begin
writeln('Reading ID information...');
ide_command(cmd_identify);
if not read_secbuf(secbuf) then Error('Read Identify',false);
with buffer do begin
writeln('ID constant : ',config,' (',hexword(config),')');
writeln('cylinders fixed : ',NumCyls);
writeln('cylinders removable : ',NumCyls2);
writeln('number of heads : ',NumHeads);
writeln('bytes per track phys. : ',BytesPerTrk);
writeln('bytes per sector phys. : ',BytesPerSec);
writeln('sectors per track : ',SecsPerTrack);
writeln('serial number : ',st(SerNo));
writeln('controller revision : ',st(CtrlRev));
writeln('buffer size (sectors) : ',BfrSize);
writeln('number of ECC bytes : ',ECCBytes);
writeln('controller model : ',st(CtrlModl));
secs := int(NumCyls) * NumHeads * SecsPerTrack;
writeln('total sector count : ',secs:1:0);
writeln('capacity (MByte) : ',int(secs / 2048):1:1);
end;
write(^m^j'press ENTER ');
readln;
end;
(* execute drive diagnostics (self test) *)
procedure hd_diagnostics;
begin
writeln(^m^j'Drive Self-Test...');
ide_command(cmd_diagnostics);
writeln('Result Code: ',hexbyte(port[ide_error]),^m^j);
end;
(* Random Seek Test *)
procedure hd_seekrandom;
begin
writeln('Seek Test. Press any key to abort.');
repeat
i:=random(cylinders);
write(^m,i:4);
if not hd_seek(i) then error('Seek',false);
until keypressed;
read(kbd,c);
writeln(' ** Aborted **');
end;
(* Read the complete drive, linear access *)
procedure hd_readlinear;
begin
writeln('Disk is being read. Press any key to abort.');
for i:=0 to pred(cylinders) do
for j:=0 to pred(heads) do
for k:=1 to sectors do begin
write(^m,i:4,j:3,k:3);
hd_readsector(i,j,k,secbuf);
if keypressed then begin
read(kbd,c);
writeln(' ** Aborted **');
exit; end;
end;
end;
(* randomly read the harddisk drive *)
procedure hd_readrandom;
begin
writeln('Disk is being read. Press any key to abort.');
repeat
i:=random(cylinders); j:=random(heads); k:=succ(random(sectors));
write(^m,i:4,j:3,k:3);
hd_readsector(i,j,k,secbuf);
until keypressed;
read(kbd,c);
writeln(' ** Aborted **');
end;
(* read and write-back the entire drive, linear *)
procedure hd_rw_linear;
begin
writeln('Test running. Press any key to abort.');
for i:=0 to pred(cylinders) do
for j:=0 to pred(heads) do
for k:=1 to sectors do begin
write(^m,i:4,j:3,k:3);
hd_readsector(i,j,k,secbuf);
hd_writesector(i,j,k,secbuf);
if keypressed then begin
read(kbd,c);
writeln(' ** Aborted **');
exit; end;
end;
end;
(* randomly read and write-back drive data *)
procedure hd_rw_random;
begin
writeln('Test running. Press any key to abort.');
repeat
i:=random(cylinders); j:=random(heads); k:=succ(random(sectors));
write(^m,i:4,j:3,k:3);
hd_readsector(i,j,k,secbuf);
hd_writesector(i,j,k,secbuf);
until keypressed;
read(kbd,c);
writeln(' ** Aborted **');
end;
(* Write random data to a sector, then read back and compare. *)
(* Repeat this linearly for the complete drive. All data is *)
(* destroyed by this test, so be careful! *)
procedure hd_test_linear;
begin
write('All data will be destroyed! Continue? (Y/N) ');
repeat read(kbd,c); c:=upcase(c) until (c='Y') or (c='N');
writeln(c); if c='N' then exit;
writeln('Test running. Press any key to abort.');
for i:=0 to pred(cylinders) do
for j:=0 to pred(heads) do
for k:=1 to sectors do begin
write(^m,i:4,j:3,k:3);
for l:=0 to 511 do bakbuf[l]:=random(256);
hd_writesector(i,j,k,bakbuf);
hd_readsector(i,j,k,secbuf);
err:=false;
for l:=0 to 511 do if secbuf[l]<>bakbuf[l] then err:=true;
if err then Error('Sector R/W Verify',false);
if keypressed then begin
read(kbd,c);
writeln(' ** Aborted **');
exit; end;
end;
end;
(* Write random data to a sector, then read back and compare. *)
(* Repeat this randomly for the complete drive. All data is *)
(* destroyed by this test, so be careful! *)
procedure hd_test_random;
begin
write('All data will be destroyed! Continue? (Y/N) ');
repeat read(kbd,c); c:=upcase(c) until (c='Y') or (c='N');
writeln(c); if c='N' then exit;
writeln('Test running. Press any key to abort.');
repeat
i:=random(cylinders); j:=random(heads); k:=succ(random(sectors));
write(^m,i:4,j:3,k:3);
for l:=0 to 511 do bakbuf[l]:=random(256);
hd_writesector(i,j,k,bakbuf);
hd_readsector(i,j,k,secbuf);
err:=false;
for l:=0 to 511 do if secbuf[l]<>bakbuf[l] then err:=true;
if err then Error('Sector R/W Verify',false);
until keypressed;
read(kbd,c);
writeln(' ** Aborted **');
end;
(* MAIN *)
begin
constptr:=addr(constat);
writeln(signon);
SetPorts(GIDEbase);
{ hd_init(cylinders,heads,sectors); } (* option *)
repeat
write(^m^j'Functions:'^m^j,
'(0) Initialise drive (5) Read disk randomly'^m^j,
'(1) Read drive''s ID data (6) Read/rewrite linear'^m^j,
'(2) Execute drive''s selftest (7) Read/rewrite randomly'^m^j,
'(3) Random seek test (8) Write/read linear (destructive)'^m^j,
'(4) Read disk linear (9) Write/read randomly (destructive)'^m^j,
'(p) Set port address (x) Exit program'^m^j,
'Input: ');
repeat read(kbd,func); func:=upcase(func)
until func in ['0'..'9','P','X'];
write(func,^m^j^m^j);
case func of
'0' : begin
write('No. of Cylinders (',cylinders:4,') : '); readln(cylinders);
write('No. of Heads (',heads:4,') : '); readln(heads);
write('No. of Sectors (',sectors:4,') : '); readln(sectors);
hd_init(cylinders,heads,sectors);
end;
'1' : hd_identify;
'2' : hd_diagnostics;
'3' : hd_seekrandom;
'4' : hd_readlinear;
'5' : hd_readrandom;
'6' : hd_rw_linear;
'7' : hd_rw_random;
'8' : hd_test_linear;
'9' : hd_test_random;
'P' : begin
write('GIDE base adress in hex (',HexByte(GIDEbase),') : ');
readln(s);
if length(s)>0 then begin
val('$'+s,i,j);
if j=0 then GIDEbase:=i;
end;
SetPorts(GIDEbase);
end;
end;
until func='X';
|
--
Es geht alles erst richtig los ! 
Dieser Beitrag wurde am 06.12.2009 um 13:16 Uhr von Ralph editiert. |
