home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
s
/
sbmf13.zip
/
MF
/
SBMKBAT.ZIP
/
SBMKBAT.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1992-04-11
|
12KB
|
374 lines
const str_size=65519;max_strings=4095;hash_prime=877;max_nam=1023;
max_model=1023;
type ndat=array[0..str_size] of byte;
p_ndat=^ndat;
pbyte=^byte;
dword=record loword,hiword:word;end;
find_buf=record sys_dat:array[0..20] of byte;
attr:byte;
time,date:word;
size:longint;
name:array[0..12] of char;
marker:byte;
end;
var
dirbuf:find_buf;
mav,namct,i,j,jj,k,fi:word;adr10:pointer;inname:string;fname:string[15];
dirname:string;
names:p_ndat;namep,name_hash,aux_hash:array[0..max_strings] of word;
nameh,namek,namekk:word;
nam_m:array[1..max_nam] of word;
model:array[0..max_model] of word;modelct:word;
_m_:array[0..15,0..9] of word;
all_mm,old_mm,mm:word;
mmm,mxm:word;
fin,fout:text;
nmode:boolean;
label 30,40,50,60;
function dir_scan:word;
(* ## star_scan *)
inline(186/inname+1/185/255/0/184/0/78/205/33);
function keypressed:boolean;
(* ## key_pressed *)
inline(180/11/205/33);
function readkey:char;
(* ## _pressed *)
inline(180/8/205/33);
procedure movv(var a,b;n:word); {moves n bytes from a to b, like TP move
but does not check whether reverse direction is required}
(* ## movv *)
inline(
$59/$5F/$07/$8C/$DA/$5E/$1F/$FC/$F3/$A4/$8E/$DA);
procedure abort(st:string);
begin writeln('! ',st);{$I-}close(fin);{$I+}halt;end;
procedure keycheck;
begin
while keypressed do if upcase(readkey)='Q' then abort('Quitting');
end;
function is_directory:boolean;var i:integer;
begin
is_directory:=false;
(* ## set transfer address *)
inline(184/0/26/186/dirbuf/205/33);
inname[length(inname)+1]:=#0;
if dir_scan<>0 then exit;
if dirbuf.attr and $10=0 then exit;
is_directory:=true;
end;
{Hash code name search: the name of zero length is assigned 0. For
i>0, the name corresponding to i is stored in names^[namep[i-1]] to
names^[namep[i]-1] }
procedure append_model(n:word);
begin
{ writeln('model ',n);}
if n=0 then exit;
if modelct>=max_model then abort('batch_mo.del too big');
model[modelct]:=n;inc(modelct);
end;
procedure start_infile;
begin
assign(fin,dirname+fname);{$I-}reset(fin);{$I+}
if IOresult<>0 then abort('Cannot open '+fname);
keycheck;
end;
function mem_alloc(k:longint):pointer;{memory allocation on
segment boundaries}
begin
k:=(k+15)shr 4;
{ k is the number of paragraphs}
if k>mav then abort('Insufficient RAM');
dec(mav,k);mem_alloc:=adr10;inc(dword(adr10).hiword,k);
end;
function find_hash(n:word;var nmer):word;var h,i,j:word;
function fh:word;(* ## hash code *)
inline(
$33/$C0/$33/$D2/$8B/$4E/<n/$E3/$17/$1E/$BF/hash_prime/$FC/$C5/$76/<nmer/
$AC/$D1/$E2/$03/$D0/$2B/$D7/$79/$FC/$03/$D7/$E2/$F3/$1F/$92);
function compare:boolean;
(* ## compare *)
inline(
$33/$C0/$FC/$8B/$4E/<n/$8B/$5E/<i/$4B/$D1/$E3/$C4/$9F/namep/$8C/$C2/$2B/
$D3/$3B/$D1/$75/$10/$C4/$3E/names/$03/$FB/$1E/$C5/$76/<nmer/$F3/$A6/$1F/
$75/$01/$40);
begin
if (n=0)or(n>255) then begin find_hash:=0;exit;end;
h:=fh; {write(' ',h,' ');}
i:=name_hash[h];
while i>0 do
begin
if compare then
begin
find_hash:=i; {write(' ',h,' ');}
{ writeln('already exists ',i);}
exit;
end;
i:=aux_hash[h];
if i>0 then
begin
h:=i;
i:=name_hash[h];
end else
begin
while name_hash[nameh]>0 do
begin
if nameh=0 then abort('Hash full');
dec(nameh);
end;
aux_hash[h]:=nameh;
h:=nameh;
end;
{write(' ',h,' ');}
end;
inc(namek);
if namek>max_strings then abort('Too many strings');
if longint(n)+namekk>str_size then
abort('Insufficient string character space');
name_hash[h]:=namek;find_hash:=namek;{writeln('####',namek);}
movv(nmer,names^[namekk],n);
i:=namekk;
inc(namekk,n);
namep[namek]:=namekk;
{while i<namekk do
begin write(char(names^[i]));inc(i);end;writeln;}
end;
procedure string_out(i:word);var j,k:word; {writes to standard output,
the name indexed by i, not checked}
begin
if i=0 then j:=0 else begin j:=namep[i];i:=namep[i-1];end;
while i<j do begin write(char(names^[i]));inc(i);end;
writeln;
end;
procedure append_string(n:word); var i,j:word;
begin
if n=0 then exit;
i:=namep[n-1];j:=namep[n]-i;
if length(inname)+j>255 then j:=255-length(inname);
movv(names^[i],inname[length(inname)+1],j);inc(byte(inname[0]),j);
end;
procedure batch_entry(i,k:word);var g,j:word;
begin
{ write(k,' ');string_out(i);}
j:=0;inname:='';
while j<modelct do
begin
g:=model[j];
case g of
1..max_strings:append_string(g);
32767:begin writeln(fin,inname);inname:='';end;
32768:append_string(i);
32816..32825:append_string(_m_[k,g-32816]);
else writeln('??? model ',g);
end{cases};
inc(j);
end;
keycheck;
end;
procedure scan_next;
begin
while ((inname[i]=' ')or(inname[i]=#9))and(i<=length(inname)) do inc(i);
j:=i;
while ((inname[i]<>' ')and(inname[i]<>#9))and(i<=length(inname)) do inc(i);
end;
function scan_mmm:word;var h:char;
begin
h:=#0;
repeat
while (inname[i]<>'_')and(i<=length(inname)) do inc(i);
if ((i+3)>length(inname)) then
begin i:=length(inname)+1;h:='?';end else
if (inname[i+1]<>'m')or(inname[i+3]<>'_') then inc(i) else
if inname[i+2] in ['0'..'9'] then h:=inname[i+2] else h:='?';
until h<>#0;
scan_mmm:=byte(h);
end;
function process_parameters:boolean;var i:integer;
label set_directory;
{returns true unless a name and at least one hex digit given}
begin
nmode:=true;mm:=0;
process_parameters:=true;
dirname[0]:=#0;fname[0]:=#0;
for i:=1 to paramcount do
begin
inname:=paramstr(i);
if (inname[1]='-') then
begin
if (inname[0]=#2)and(upcase(fname[2])='N')then
nmode:=false else write('??? ');
writeln(inname);
end else if inname[0]=#1 then
begin
if ((inname[1]='\')or(inname[1]='\'))and(dirname[0]=#0) then
goto set_directory;
case inname[1] of
'0'..'9':mm:=mm or(1 shl (byte(inname[1])-48));
'A'..'F':mm:=mm or(1 shl (byte(inname[1])-55));
'a'..'f':mm:=mm or(1 shl (byte(inname[1])-87));
else write('??? ');end{cases};
writeln(inname);
end else
begin
if (pos('\',inname)>0)or(pos('/',inname)>0) then
begin
if dirname[0]>#0 then write('??? ') else
begin
while (inname[length(inname)]='\')or(inname[length(inname)]='/') do
dec(inname[0]);
if is_directory then
begin
inc(inname[0]);inname[length(inname)]:='\';
set_directory:dirname:=inname;
end;
end;
end else if fname[0]<>#0 then write('??? ') else fname:=inname;
writeln(inname);
end;
end;
if (fname[0]=#0)or(mm=0) then exit;
if find_hash(length(fname),fname[1])<>1 then
begin write('??? ');writeln(fname);exit;end;
namct:=1;nam_m[1]:=mm;all_mm:=mm;
process_parameters:=false;
end;
begin {MAIN}
writeln(#13#10' This is SBMKBAT, Version 0.1');
writeln( ' Press Q to abort');
mav:=memavail shr 4;adr10:=heapptr;
names:=mem_alloc(sizeof(ndat));namep[0]:=0;namek:=0;namekk:=0;
fillchar(name_hash,(max_strings+1) shl 1,0);nameh:=max_strings;
namct:=0;old_mm:=0;all_mm:=0;modelct:=0;
fillchar(aux_hash,(max_strings+1) shl 1,0);
filemode:=0;
if process_parameters then
begin
fname:='_name_._m_';start_infile;
30: while not eof(fin) do
begin
readln(fin,inname);
if (length(inname)>0) and (inname[1]='%') then goto 30;
i:=1;
scan_next;
if i>j then
begin
jj:=find_hash(i-j,inname[j]);
if jj>0 then
begin
if jj>namct then begin inc(namct);nam_m[jj]:=0;end;
if namct>max_nam then abort('Too many entries in '+'_name_._m_');
mm:=0;
while i<length(inname) do
begin
scan_next;
if j+1=i then
case inname[j] of
'0'..'9':mm:=mm or(1 shl (byte(inname[j])-48));
'A'..'F':mm:=mm or(1 shl (byte(inname[j])-55));
'a'..'f':mm:=mm or(1 shl (byte(inname[j])-87));
else goto 60;
end{cases}else 60:writeln('??? ',inname);
end;
if mm>0 then old_mm:=mm;
nam_m[jj]:=nam_m[jj] or old_mm;
all_mm:=all_mm or old_mm;
end;
end;
end; close(fin);
end;
fillchar(_m_,sizeof(_m_),0);{zero the _m?_ table}
fname:='_0_._m_';
for k:=0 to 15 do
begin
if (all_mm and (1 shl k))<>0 then
begin
start_infile;
40: while not eof(fin) do
begin
readln(fin,inname);
if (length(inname)>0) and (inname[1]='%') then goto 40;
while (inname[length(inname)]=#32)or(inname[length(inname)]=#9 )do
dec(inname[0]);{remove trailing spaces}
i:=1;
while (i<length(inname))and((inname[i]=#32)or(inname[i]=#9))do inc(i);
if i<length(inname) then
begin
if ((i+3)>length(inname))or(inname[i]<>'_')
or(inname[i+1]<>'m')or(inname[i+3]<>'_')
or(not (inname[i+2] in ['0'..'9']) ) then
writeln('! Invalid line in ',fname,#13#10,inname) else
begin
mxm:=byte(inname[i+2]);
repeat
mmm:=mxm-48;
inc(i,4);j:=i;
mxm:=scan_mmm;
_m_[k,mmm]:=find_hash(i-j,inname[j]);
until (mxm<48)or(mxm>57);
end;
end;
end; close(fin);
end;
if fname[2]='9' then fname[2]:='A' else inc(fname[2]);
{ for i:=0 to 9 do begin write(i,' ');string_out(_m_[k,i]);end;}
end;
fname:='batch_mo.del';start_infile;
50: while not eof(fin) do
begin
readln(fin,inname);
if (length(inname)>0) and (inname[1]='%') then goto 50;
while (inname[length(inname)]=#32)or(inname[length(inname)]=#9 )do
dec(inname[0]);{remove trailing white space}
i:=1;j:=1;
while i<=length(inname) do
begin
if (inname[i]='_') and (length(inname)>i+2) then
begin
case inname[i+1] of
'm':if (inname[i+2] in ['0'..'9']) and (inname[i+3]='_')then
begin
append_model(find_hash(i-j,inname[j]));
append_model(32768+byte(inname[i+2]));
inc(i,4);j:=i;
end else inc(i);
'n':if (length(inname)>i+4)and(inname[i+2]='a')
and(inname[i+3]='m')and(inname[i+4]='e')and(inname[i+5]='_')then
begin
append_model(find_hash(i-j,inname[j]));
append_model(32768);
inc(i,6);j:=i;
end else inc(i);
else inc(i);
end {cases};
end else inc(i);
end;
append_model(find_hash(i-j,inname[j]));
append_model(32767);
end;
close(fin);
assign(fin,'mkmf.bat');{$I-}rewrite(fin);{$I+}
if IOresult<>0 then abort('Cannot open MKMF.BAT for writing');
if nmode then
begin
for k:=0 to 15 do if (all_mm and (1 shl k))<>0 then
begin
for i:=1 to namct do if (nam_m[i] and (1 shl k))<>0 then
batch_entry(i,k);
end;
end else
begin
for i:=1 to namct do for k:=0 to 15 do
if (nam_m[i] and (1 shl k))<>0 then batch_entry(i,k);
end;
close(fin);
end.