thorh@tekig1.UUCP (Thor Hallen) (05/12/84)
--------------------------------------------------------------
(* UCSD Pascal to CP/M transfer program *)
(* by Tor Sj0wall, published in Nov.1980 Dr.Dobbs *)
(* typed and debugged by Rod Hart Feb.21,1980 *)
(* Modified for the Apple by David Neumann March 1981 *)
(* Sector mapping, new check for valid CP/M *)
(* directory and disk_reset are main Apple additions. *)
program GETCPM;
const void=229;
cpmeof=26;
cr=13;
lf=10;
tab=9;
null=0;
drivea=4;
driveb=5;
indent=4;
autolf=8;
num_of_blk=0;
offset_in_blk=1;
VERSION = 'November 12, 1982';
type nametype=packed array[0..10] of char;
namestring=string[30];
byte=0..255;
dirtype=packed array[0..2047] of byte;
maptype=packed array[0..15] of byte;
nonotype='N'..'n';
illetype=' '..']';
secttype=packed array[0..127] of byte;
legaltypes=(textfile,datafile,illegal);
blktype=packed array[1..512] of byte;
var iscpm:boolean;
filetype:legaltypes;
sourcename,destname:namestring;
nono:set of nonotype;
illechar:set of illetype;
filename:nametype;
textdest:text;
datadest:file of secttype;
directbuf:dirtype;
bigsectbuf:dirtype;
sec_map : array[0..31,0..1] of integer;
current_blk_buf : blktype;
lastsect : integer;
procedure INITIALIZE;
begin
illechar:=[' ','<','>',',','.',';',':','=','?','*','[',']'];
nono:=['N','n'];
lastsect := -2;
sec_map[0,num_of_blk] := 0;
sec_map[0,offset_in_blk] := 1;
sec_map[1,num_of_blk] := 0;
sec_map[1,offset_in_blk] := 129;
sec_map[2,num_of_blk] := 4;
sec_map[2,offset_in_blk] := 257;
sec_map[3,num_of_blk] := 4;
sec_map[3,offset_in_blk] := 385;
sec_map[4,num_of_blk] := 1;
sec_map[4,offset_in_blk] := 257;
sec_map[5,num_of_blk] := 1;
sec_map[5,offset_in_blk] := 385;
sec_map[6,num_of_blk] := 6;
sec_map[6,offset_in_blk] := 1;
sec_map[7,num_of_blk] := 6;
sec_map[7,offset_in_blk] := 129;
sec_map[8,num_of_blk] := 3;
sec_map[8,offset_in_blk] := 1;
sec_map[9,num_of_blk] := 3;
sec_map[9,offset_in_blk] := 129;
sec_map[10,num_of_blk] := 7;
sec_map[10,offset_in_blk] := 257;
sec_map[11,num_of_blk] := 7;
sec_map[11,offset_in_blk] := 385;
sec_map[12,num_of_blk] := 0;
sec_map[12,offset_in_blk] := 257;
sec_map[13,num_of_blk] := 0;
sec_map[13,offset_in_blk] := 385;
sec_map[14,num_of_blk] := 5;
sec_map[14,offset_in_blk] := 1;
sec_map[15,num_of_blk] := 5;
sec_map[15,offset_in_blk] := 129;
sec_map[16,num_of_blk] := 2;
sec_map[16,offset_in_blk] := 1;
sec_map[17,num_of_blk] := 2;
sec_map[17,offset_in_blk] := 129;
sec_map[18,num_of_blk] := 6;
sec_map[18,offset_in_blk] := 257;
sec_map[19,num_of_blk] := 6;
sec_map[19,offset_in_blk] := 385;
sec_map[20,num_of_blk] := 3;
sec_map[20,offset_in_blk] := 257;
sec_map[21,num_of_blk] := 3;
sec_map[21,offset_in_blk] := 385;
sec_map[22,num_of_blk] := 4;
sec_map[22,offset_in_blk] := 1;
sec_map[23,num_of_blk] := 4;
sec_map[23,offset_in_blk] := 129;
sec_map[24,num_of_blk] := 1;
sec_map[24,offset_in_blk] := 1;
sec_map[25,num_of_blk] := 1;
sec_map[25,offset_in_blk] := 129;
sec_map[26,num_of_blk] := 5;
sec_map[26,offset_in_blk] := 257;
sec_map[27,num_of_blk] := 5;
sec_map[27,offset_in_blk] := 385;
sec_map[28,num_of_blk] := 2;
sec_map[28,offset_in_blk] := 257;
sec_map[29,num_of_blk] := 2;
sec_map[29,offset_in_blk] := 385;
sec_map[30,num_of_blk] := 7;
sec_map[30,offset_in_blk] := 1;
sec_map[31,num_of_blk] := 7;
sec_map[31,offset_in_blk] := 129;
end;
function UPPERCASE (inchar:char):char;
begin
if inchar in ['a'..'z']
then uppercase:=chr(ord(inchar)-32)
else uppercase:=inchar;
end;
procedure CHECKTYPE (var filename:namestring;
var filetype:legaltype);
var i:integer;
hlp:namestring;
begin
for i=1 oiname[i]:=uppercase(filename[i]);
if length(filename)<>0 then
begin
if (filename[1]='*') or (filename[1]=':')
then
delete(filename,1,1);
if pos(':',filename)=0
then
fil filetype:=illegal;
if help='.TEXT' then filetype:=textfile;
if help[5]=':' then filetype:=textfile;
if help='.DATA' then filetype:=datafile;
end;
procedure CPMNAME (var wantname:nametype;
wantfile:namestring);
var i,j:integer;
begin
fillchar(wantname,11,' ');
i:=1;j:=0;
while((j<=10)and(i<=length(wantfile))) do
begin
if not(wantfile[i] in illechar)
then wantname[j]:=uppercase(wantfile[i])
else if (wantfile[i]='.')and(j<=8)then j:=7
else j:=10;
j:=j+1;i:=i+1
end
end;
procedure WRI do if flenameof_blk];
end;
function OFFgin
offset := sec_map[seqsect mod 32,offset_in_blk];
end;
procedure GETSECT(var buf:dirtype; bufoff,seqsect:integer);
var
off : integer;
begin
(* check to see if sector requested is *)
(* already in core. *)
if NOT (odd(seqsect) AND (seqsect = lastsect+1))
then
unitread(drivea,current_blk_buf,512,blocknum(seqsect));
off := offset(seqsect);
moveleft(current_blk_buf[off],buf[bufoff],128);
lastsect := seqsect;
end;
procedure DIRECTORY (var directbuf:dirtype;
var iscpm:boolean);
var i,seqsect:integer;
begin
seqsect := 3 * 32;
iscpm:=true;
getsect(directbuf,0,seqsect);
for i:=0 to 3 do
iscpm:=iscpm
and(directbuf[i*32+1]>=ord(' '))
and((directbuf[i*32+1]<128) or (directbuf[i*32+1]=void))
and not(chr(directbuf[i*32+1]mod 128) in illechar);
if iscpm then for i:=1 to 15 do
getsect(directbuf,i*128,seqsect+i);
end;
procedure PRINTDIRECT (directbuf:dirtype);
var i,dirbufpoint,filecount:integer;
begin
writeln ('CP/M directory listing :');
writeln('user name .type');
dirbufpoint:=0;
filecount:=0;
repeat
if(directbuf[dirbufpoint]<>void)and(directbuf
[dirbufpoint+12]=0)
then
begin
write(directbuf[dirbufpoint]:4,' ');
for i:=1 to 8 do
write(chr(directbuf[i+dirbufpoint] mod
128));
write(' ');
for i:=9 to 11 do
write(chr(directbuf[i+dirbufpoint] mod
128));
filecount:=filecount+1;
if(filecount mod 2)=0 then writeln else
write(' | ')
end;
dirbufpoint:=dirbufpoint+32
until dirbufpoint>=2048;
writeln;writeln(filecount,' files in directory.')
end;
procedure SCANDIRECT (var diskmap:maptype;
var found:boolean;
var size:byte;
dirbuf:dirtype;
filename:nametype;
extension:byte);
var dirbufpoint,i:integer;
namebuf:nametype;
begin
found:=false;
fillchar(namebuf,11,' ');
dirbufpoint:=0;
repeat
if dirbuf[dirbufpoint]<>void then
begin
for i:=0 to 10 do
namebuf[i]:=chr(dirbuf[dirbufpoint+i+1]
mod 128);
found:=(namebuf=filename)and(extension=
dirbuf[dirbufpoint+12]);
end;
dirbufpoint:=dirbufpoint+32;
until found or (dirbufpoint>=2048);
if found then
begin
dirbufpoint:=dirbufpoint-32;
size:=dirbuf[dirbufpoint+15];
for i:=0 to 15 do
diskmap[i]:=dirbuf[dirbufpoint+i+16]
end
end;
procedure COPYFILE (filename:nametype;
filetype:legaltypes);
var linepos:integer;
size,extension:byte;
found:boolean;
diskmap:maptype;
procedure COPYSECT (sectbuf:secttype);
begin
datadest^ :=sectbuf;
put(datadest)
end;
procedure COPYCHAR (inchar:byte);
begin
inchar:=inchar mod 128;
if inchar>=32
then
begin
linepos:=linepos+1;
write(textdest,chr(inchar))
end
else
begin
case inchar of
tab:begin
repeat
write(textdest,' ');
linepos:=linepos+1
until(linepos mod 8)=0;
exit(copychar)
end;
cr:begin
writeln(textdest);
linepos:=0;
exit(copychar)
end;
lf,null:exit(copychar);
cpmeof:begin
writeln;
writeln('End of file');
exit(copyfile)
end
end;
write(textdest,'?');
linepos:=linepos+1
end
end;
procedure COPYPAGE (valsects:integer;
cpmpage:byte);
var seqsect,j,temp:integer;
sectbuf:secttype;
begin
if cpmpage<>0 then
begin
seqsect := (cpmpage * 8) + (3 * 32);
temp:=seqsect+valsects;
while seqsect<temp do
begin
getsect(bigsectbuf,0,seqsect);
moveleft(bigsectbuf,sectbuf,128);
seqsect:=seqsect+1;
if filetype=textfile
then for j:=0 to 127 do copychar(sectbuf[j])
else copysect(sectbuf)
end
end
end;
procedure COPYEXTENSION (diskmap:maptype;
size:byte);
var i:integer;
begin
for i:=0 to (size div 8) - 1 do copypage
(8,diskmap[i]);
if(size mod 8)<>0 then copypage (size mod 8
,diskmap[size div 8])
end;
begin
extension :=0;
linepos :=0;
lastsect := -2;
repeat
scandirect(diskmap,found,size,directbuf,filename,
extension);
if found
then
begin
if(extension=0)and(size=0)
then writeln('File is empty')
else copyextension(diskmap,size);
extension:=extension+1
end
until not found;
if extension=0
then
begin
writename(filename);
writeln(' not found')
end
else
begin
writeln;writeln('End of file')
end
end;
procedure disk_reset;
var
out : text;
begin
(*$i-*)
reset(out,'#5');
close(out);
reset(out,'#4');
close(out);
(*$i+*)
end;
procedure cleanup;
begin
write('Insert Pascal boot volume in #4 and hit <return>'); readln;
disk_reset;
exit(program);
end;
(*main program*)
begin
initialize;
page(output);
writeln;writeln;
writeln('CP/M to UCSD Pascal file transfer');
writeln(' ',VERSION);
writeln;
writeln('Pascal diskette in drive #5');
writeln('CP/M diskette in drive #4');
writeln;
write('Press <return> when ready ');readln;writeln;
disk_reset;
directory(directbuf,iscpm);
if not iscpm
then
begin
writeln ('Not CP/M floppy in drive #4');
cleanup;
end;
repeat
printdirect(directbuf);
writeln;
writeln('<RETURN> to end.');
writeln;
write('Source CP/M file : ');
readln(sourcename);
if length(sourcename)=0
then
cleanup;
cpmname(filename,sourcename);
filetype:=illegal;
repeat
write('Destination Pascal file : ');
readln(destname);
if length(destname)=0
then
cleanup;
checktype(destname,filetype);
if filetype=illegal
then
begin
writeln('Illegal file name. (.TEXT or .DATA)');
writeln('Volume names (i.e. PRINTER:) are legal');
writeln('and are treated as TEXT transfers.');
end;
until filetype<>illegal;
if filetype=textfile
then
begin
writeln;writeln('TEXT file transfer');
rewrite (textdest,destname);
copyfile (filename,filetype);
close (textdest,lock);
end
else
begin
writeln;writeln('DATA file transfer');
rewrite (datadest,destname);
copyfile (filename,filetype);
close (datadest,lock)
end;
until false;
cleanup;
end.