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   
Pascal/Delphi Source File  |  1992-04-11  |  12KB  |  374 lines
  1. const str_size=65519;max_strings=4095;hash_prime=877;max_nam=1023;
  2.       max_model=1023;
  3.  
  4. type ndat=array[0..str_size] of byte;
  5.      p_ndat=^ndat;
  6.      pbyte=^byte;
  7.      dword=record loword,hiword:word;end;
  8.      find_buf=record sys_dat:array[0..20] of byte;
  9.                           attr:byte;
  10.                           time,date:word;
  11.                           size:longint;
  12.                           name:array[0..12] of char;
  13.                           marker:byte;
  14.               end;
  15. var
  16.      dirbuf:find_buf;
  17.      mav,namct,i,j,jj,k,fi:word;adr10:pointer;inname:string;fname:string[15];
  18.      dirname:string;
  19.      names:p_ndat;namep,name_hash,aux_hash:array[0..max_strings] of word;
  20.      nameh,namek,namekk:word;
  21.      nam_m:array[1..max_nam] of word;
  22.      model:array[0..max_model] of word;modelct:word;
  23.      _m_:array[0..15,0..9] of word;
  24.      all_mm,old_mm,mm:word;
  25.      mmm,mxm:word;
  26.      fin,fout:text;
  27.      nmode:boolean;
  28. label 30,40,50,60;
  29. function dir_scan:word;
  30. (* ## star_scan  *)
  31.  inline(186/inname+1/185/255/0/184/0/78/205/33);
  32. function keypressed:boolean;
  33. (* ## key_pressed  *)
  34.  inline(180/11/205/33);
  35. function readkey:char;
  36. (* ## _pressed  *)
  37.  inline(180/8/205/33);
  38. procedure movv(var a,b;n:word); {moves n bytes from a to b, like TP move
  39. but does not check whether reverse direction is required}
  40. (* ## movv  *)
  41.      inline(
  42. $59/$5F/$07/$8C/$DA/$5E/$1F/$FC/$F3/$A4/$8E/$DA);
  43. procedure abort(st:string);
  44. begin writeln('! ',st);{$I-}close(fin);{$I+}halt;end;
  45.  
  46. procedure keycheck;
  47. begin
  48.   while keypressed do if upcase(readkey)='Q' then abort('Quitting');
  49. end;
  50.  
  51.  
  52. function is_directory:boolean;var i:integer;
  53. begin
  54.   is_directory:=false;
  55.   (* ## set transfer address  *)
  56.  inline(184/0/26/186/dirbuf/205/33);
  57.  inname[length(inname)+1]:=#0;
  58.  if dir_scan<>0 then exit;
  59.   if dirbuf.attr and $10=0 then exit;
  60.   is_directory:=true;
  61. end;
  62.  
  63. {Hash code name search: the name of zero length is assigned 0. For
  64. i>0, the name corresponding to i is stored in names^[namep[i-1]] to
  65. names^[namep[i]-1] }
  66. procedure append_model(n:word);
  67. begin
  68. {  writeln('model ',n);}
  69.   if n=0 then exit;
  70.   if modelct>=max_model then abort('batch_mo.del too big');
  71.   model[modelct]:=n;inc(modelct);
  72. end;
  73. procedure start_infile;
  74. begin
  75.   assign(fin,dirname+fname);{$I-}reset(fin);{$I+}
  76.   if IOresult<>0 then abort('Cannot open '+fname);
  77.   keycheck;
  78. end;
  79.  
  80. function mem_alloc(k:longint):pointer;{memory allocation on
  81. segment boundaries}
  82. begin
  83.   k:=(k+15)shr 4;
  84.   { k is the number of paragraphs}
  85.   if k>mav then abort('Insufficient RAM');
  86.   dec(mav,k);mem_alloc:=adr10;inc(dword(adr10).hiword,k);
  87. end;
  88. function find_hash(n:word;var nmer):word;var h,i,j:word;
  89. function fh:word;(* ## hash code  *)
  90.      inline(
  91. $33/$C0/$33/$D2/$8B/$4E/<n/$E3/$17/$1E/$BF/hash_prime/$FC/$C5/$76/<nmer/
  92. $AC/$D1/$E2/$03/$D0/$2B/$D7/$79/$FC/$03/$D7/$E2/$F3/$1F/$92);
  93. function compare:boolean;
  94. (* ## compare  *)
  95.      inline(
  96. $33/$C0/$FC/$8B/$4E/<n/$8B/$5E/<i/$4B/$D1/$E3/$C4/$9F/namep/$8C/$C2/$2B/
  97. $D3/$3B/$D1/$75/$10/$C4/$3E/names/$03/$FB/$1E/$C5/$76/<nmer/$F3/$A6/$1F/
  98. $75/$01/$40);
  99. begin
  100. if (n=0)or(n>255) then begin find_hash:=0;exit;end;
  101. h:=fh;  {write(' ',h,' ');}
  102. i:=name_hash[h];
  103. while i>0 do
  104. begin
  105.   if compare then
  106.   begin
  107.     find_hash:=i;    {write(' ',h,' ');}
  108. {    writeln('already exists ',i);}
  109.     exit;
  110.   end;
  111.   i:=aux_hash[h];
  112.   if i>0 then
  113.   begin
  114.     h:=i;
  115.     i:=name_hash[h];
  116.   end else
  117.   begin
  118.     while name_hash[nameh]>0 do
  119.     begin
  120.       if nameh=0 then abort('Hash full');
  121.       dec(nameh);
  122.     end;
  123.     aux_hash[h]:=nameh;
  124.     h:=nameh;
  125.   end;
  126.     {write(' ',h,' ');}
  127. end;
  128.  
  129.   inc(namek);
  130.   if namek>max_strings then abort('Too many strings');
  131.   if longint(n)+namekk>str_size then
  132.      abort('Insufficient string character space');
  133.   name_hash[h]:=namek;find_hash:=namek;{writeln('####',namek);}
  134.   movv(nmer,names^[namekk],n);
  135.   i:=namekk;
  136.   inc(namekk,n);
  137.   namep[namek]:=namekk;
  138.   {while i<namekk do
  139.   begin write(char(names^[i]));inc(i);end;writeln;}
  140. end;
  141. procedure string_out(i:word);var j,k:word; {writes to standard output,
  142. the name indexed by i, not checked}
  143. begin
  144.   if i=0 then j:=0 else begin j:=namep[i];i:=namep[i-1];end;
  145.   while i<j do begin write(char(names^[i]));inc(i);end;
  146.   writeln;
  147. end;
  148. procedure append_string(n:word); var i,j:word;
  149. begin
  150.   if n=0 then exit;
  151.   i:=namep[n-1];j:=namep[n]-i;
  152.   if length(inname)+j>255 then j:=255-length(inname);
  153.   movv(names^[i],inname[length(inname)+1],j);inc(byte(inname[0]),j);
  154. end;
  155.  
  156. procedure batch_entry(i,k:word);var g,j:word;
  157. begin
  158. {      write(k,' ');string_out(i);}
  159.       j:=0;inname:='';
  160.       while j<modelct do
  161.       begin
  162.         g:=model[j];
  163.         case g of
  164.         1..max_strings:append_string(g);
  165.         32767:begin writeln(fin,inname);inname:='';end;
  166.         32768:append_string(i);
  167.         32816..32825:append_string(_m_[k,g-32816]);
  168.         else writeln('??? model ',g);
  169.         end{cases};
  170.        inc(j);
  171.       end;
  172.   keycheck;
  173. end;
  174. procedure scan_next;
  175. begin
  176.     while ((inname[i]=' ')or(inname[i]=#9))and(i<=length(inname)) do inc(i);
  177.     j:=i;
  178.     while ((inname[i]<>' ')and(inname[i]<>#9))and(i<=length(inname)) do inc(i);
  179. end;
  180. function scan_mmm:word;var h:char;
  181. begin
  182.   h:=#0;
  183.   repeat
  184.   while (inname[i]<>'_')and(i<=length(inname)) do inc(i);
  185.   if ((i+3)>length(inname)) then
  186.   begin i:=length(inname)+1;h:='?';end else
  187.   if (inname[i+1]<>'m')or(inname[i+3]<>'_') then inc(i) else
  188.   if inname[i+2] in ['0'..'9'] then h:=inname[i+2] else h:='?';
  189.   until h<>#0;
  190.   scan_mmm:=byte(h);
  191. end;
  192. function process_parameters:boolean;var i:integer;
  193. label set_directory;
  194. {returns true unless a name and at least one hex digit given}
  195. begin
  196.   nmode:=true;mm:=0;
  197.   process_parameters:=true;
  198.   dirname[0]:=#0;fname[0]:=#0;
  199.  
  200.   for i:=1 to paramcount do
  201.   begin
  202.     inname:=paramstr(i);
  203.     if (inname[1]='-') then
  204.     begin
  205.       if (inname[0]=#2)and(upcase(fname[2])='N')then
  206.        nmode:=false else write('??? ');
  207.        writeln(inname);
  208.     end else if inname[0]=#1 then
  209.     begin
  210.       if ((inname[1]='\')or(inname[1]='\'))and(dirname[0]=#0) then
  211.         goto set_directory;
  212.         case inname[1] of
  213.           '0'..'9':mm:=mm or(1 shl (byte(inname[1])-48));
  214.           'A'..'F':mm:=mm or(1 shl (byte(inname[1])-55));
  215.           'a'..'f':mm:=mm or(1 shl (byte(inname[1])-87));
  216.         else write('??? ');end{cases};
  217.         writeln(inname);
  218.     end else
  219.     begin
  220.       if (pos('\',inname)>0)or(pos('/',inname)>0) then
  221.       begin
  222.       if dirname[0]>#0 then write('??? ') else
  223.       begin
  224.         while (inname[length(inname)]='\')or(inname[length(inname)]='/') do
  225.             dec(inname[0]);
  226.         if is_directory then
  227.         begin
  228.           inc(inname[0]);inname[length(inname)]:='\';
  229.           set_directory:dirname:=inname;
  230.         end;
  231.       end;
  232.     end else if fname[0]<>#0 then write('??? ') else fname:=inname;
  233.       writeln(inname);
  234.   end;
  235.   end;
  236.   if (fname[0]=#0)or(mm=0) then exit;
  237.    if find_hash(length(fname),fname[1])<>1 then
  238.    begin write('??? ');writeln(fname);exit;end;
  239.   namct:=1;nam_m[1]:=mm;all_mm:=mm;
  240.   process_parameters:=false;
  241. end;
  242. begin {MAIN}
  243. writeln(#13#10'         This is SBMKBAT, Version 0.1');
  244. writeln(      '              Press  Q  to abort');
  245.   mav:=memavail shr 4;adr10:=heapptr;
  246.   names:=mem_alloc(sizeof(ndat));namep[0]:=0;namek:=0;namekk:=0;
  247.   fillchar(name_hash,(max_strings+1) shl 1,0);nameh:=max_strings;
  248.   namct:=0;old_mm:=0;all_mm:=0;modelct:=0;
  249.   fillchar(aux_hash,(max_strings+1) shl 1,0);
  250.   filemode:=0;
  251.  
  252. if process_parameters then
  253. begin
  254.   fname:='_name_._m_';start_infile;
  255. 30:  while not eof(fin) do
  256.   begin
  257.     readln(fin,inname);
  258.     if (length(inname)>0) and (inname[1]='%') then goto 30;
  259.     i:=1;
  260.     scan_next;
  261.     if i>j then
  262.     begin
  263.       jj:=find_hash(i-j,inname[j]);
  264.       if jj>0 then
  265.       begin
  266.         if jj>namct then begin inc(namct);nam_m[jj]:=0;end;
  267.         if namct>max_nam then abort('Too many entries in '+'_name_._m_');
  268.         mm:=0;
  269.         while i<length(inname) do
  270.         begin
  271.           scan_next;
  272.           if j+1=i then
  273.           case inname[j] of
  274.           '0'..'9':mm:=mm or(1 shl (byte(inname[j])-48));
  275.           'A'..'F':mm:=mm or(1 shl (byte(inname[j])-55));
  276.           'a'..'f':mm:=mm or(1 shl (byte(inname[j])-87));
  277.           else goto 60;
  278.         end{cases}else 60:writeln('??? ',inname);
  279.         end;
  280.         if mm>0 then old_mm:=mm;
  281.         nam_m[jj]:=nam_m[jj] or old_mm;
  282.         all_mm:=all_mm or old_mm;
  283.  
  284.       end;
  285.     end;
  286.   end; close(fin);
  287. end;
  288.   fillchar(_m_,sizeof(_m_),0);{zero the _m?_ table}
  289.   fname:='_0_._m_';
  290.   for k:=0 to 15 do
  291.   begin
  292.     if (all_mm and (1 shl k))<>0 then
  293.     begin
  294.       start_infile;
  295. 40:      while not eof(fin) do
  296.       begin
  297.         readln(fin,inname);
  298.         if (length(inname)>0) and (inname[1]='%') then goto 40;
  299.         while (inname[length(inname)]=#32)or(inname[length(inname)]=#9 )do
  300.             dec(inname[0]);{remove trailing spaces}
  301.         i:=1;
  302.         while (i<length(inname))and((inname[i]=#32)or(inname[i]=#9))do inc(i);
  303.         if i<length(inname) then
  304.         begin
  305.           if ((i+3)>length(inname))or(inname[i]<>'_')
  306.             or(inname[i+1]<>'m')or(inname[i+3]<>'_')
  307.             or(not (inname[i+2] in ['0'..'9']) ) then
  308.             writeln('! Invalid line in ',fname,#13#10,inname) else
  309.             begin
  310.               mxm:=byte(inname[i+2]);
  311.               repeat
  312.               mmm:=mxm-48;
  313.               inc(i,4);j:=i;
  314.               mxm:=scan_mmm;
  315.               _m_[k,mmm]:=find_hash(i-j,inname[j]);
  316.               until (mxm<48)or(mxm>57);
  317.             end;
  318.         end;
  319.       end;         close(fin);
  320.     end;
  321.     if fname[2]='9' then fname[2]:='A' else inc(fname[2]);
  322. {    for i:=0 to 9 do begin write(i,' ');string_out(_m_[k,i]);end;}
  323.   end;
  324.  
  325.    fname:='batch_mo.del';start_infile;
  326. 50:   while not eof(fin) do
  327.    begin
  328.      readln(fin,inname);
  329.      if (length(inname)>0) and (inname[1]='%') then goto 50;
  330.      while (inname[length(inname)]=#32)or(inname[length(inname)]=#9 )do
  331.             dec(inname[0]);{remove trailing white space}
  332.      i:=1;j:=1;
  333.      while i<=length(inname) do
  334.      begin
  335.        if (inname[i]='_') and (length(inname)>i+2) then
  336.        begin
  337.          case inname[i+1] of
  338.          'm':if (inname[i+2] in ['0'..'9']) and (inname[i+3]='_')then
  339.              begin
  340.                append_model(find_hash(i-j,inname[j]));
  341.                append_model(32768+byte(inname[i+2]));
  342.                inc(i,4);j:=i;
  343.               end else inc(i);
  344.          'n':if (length(inname)>i+4)and(inname[i+2]='a')
  345.              and(inname[i+3]='m')and(inname[i+4]='e')and(inname[i+5]='_')then
  346.              begin
  347.                append_model(find_hash(i-j,inname[j]));
  348.                append_model(32768);
  349.                inc(i,6);j:=i;
  350.               end else inc(i);
  351.            else inc(i);
  352.           end {cases};
  353.      end else inc(i);
  354.     end;
  355.     append_model(find_hash(i-j,inname[j]));
  356.     append_model(32767);
  357.   end;
  358.   close(fin);
  359.   assign(fin,'mkmf.bat');{$I-}rewrite(fin);{$I+}
  360.   if IOresult<>0 then abort('Cannot open MKMF.BAT for writing');
  361.   if nmode then
  362.   begin
  363.   for k:=0 to 15 do if (all_mm and (1 shl k))<>0 then
  364.   begin
  365.     for i:=1 to namct do if (nam_m[i] and (1 shl k))<>0 then
  366.     batch_entry(i,k);
  367.   end;
  368.   end else
  369.   begin
  370.     for i:=1 to namct do for k:=0 to 15 do
  371.     if (nam_m[i] and (1 shl k))<>0 then batch_entry(i,k);
  372.   end;
  373.   close(fin);
  374. end.