(* COVR_FMS использует: COMP_FMS *)
(* CRUF_FMS *)
(* EXEC_FMS *)
(* FILE_FMS *)
(* IMPL_FMS *)
(* STAK_FMS *)
(* TYPE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F-,G-,I+,L+,N-,O+,R+,S+,V+,X-}
{$M 16384,0,65000}
unit COVR_FMS; { Оверлейная часть ex-Ucomp.tpu }
INTERFACE
uses DOS, FILE_FMS, COMP_FMS, STAK_FMS, UNIF_FMS, CRUF_FMS,
CRT, EXEC_FMS, TYPE_FMS;
procedure InitTabl(Fmess : String); { Constuctor }
procedure DoneTabl; { Destructor }
procedure InitCTEK(Temp : String);
procedure DoneCTEK;
{ Закачать параметры Config.sfm }
function ConfStr (Termi : char; var S : String) : boolean;
function ConTake (Termi : char ) : String;
function ConTake_Read(Termi : char ) : String;
function ConCler : String;
procedure ConSave;
IMPLEMENTATION
{ MECTA : Обменять местами элементы UcompTabl^AR[H] и UcompTabl^AR[K] }
procedure MECTA(H,K : integer);
var XX : eTABL;
begin with UcompTab^ do begin
XX:=AR[K];
AR[K]:=AR[H];
AR[H]:=XX
end end;
procedure InitTabl(Fmess : String);
var I,J,HHH : word;
FS : LongInt;
begin if UcompTab = NIL then
if OpenComp(Fmess) then begin
FS:=FileSize(_Fcmp_);
if SeekFile(_Fcmp_, FS-2) then
if ReadFile(_Fcmp_,_FileCount_,2) then begin
I:=17*_FileCount_;
GetMem(UcompTab,I+258);
if SeekFile(_Fcmp_, FS-I-2) then
if ReadFile(_Fcmp_,UcompTab^.Ar,I) then
end;
if Pconfi then begin
HHH:=SizeOf(rTARR)*_FileCount_;
GetMem(UcompArr,HHH);
FillChar(UcompArr^,HHH,0)
end;
for HHH:=1 to _FileCount_ do
with UcompTab^.AR[HHH] do
for I:=Length(Fname)+1 to 8 do Fname[I]:=chr(0);
with UcompTab^ do begin
CompName:=Fmess;
KOL:=0; { Отработать MTYPES }
HHH:=_FileCount_+1;
while KOL < HHH-1 do begin
KOL:=KOL+1;
if not Memb_PLT(AR[KOL].Fname,MTypes) then begin
HHH:=HHH-1;
MECTA(KOL,HHH);
KOL:=KOL-1
end
end;
for I:= 1 to KOL do { Упорядочить типы. NB: KOL! без -1 }
for J:=I+1 to KOL do
if AR[J].Fname < AR[I].Fname then MECTA(I,J)
end;
Cls_File(_Fcmp_)
end end;
procedure DoneTabl;
begin if UcompTab <> NIL then begin
FreeMem(UcompTab,17*_FileCount_+256+2);
UcompTab:=NIL;
if Pconfi then FreeMem(UcompArr,SizeOf(rTARR)*_FileCount_);
Pconfi:=false;
FillChar(MTypes,SizeOf(MTypes),$FF)
end end;
{ InitCTEK : открыть стек на диске }
{ Temp = Полное имя стека | Каталог временных файлов }
procedure InitCTEK(Temp : String);
var S : String;
begin if _Ostk_ then Exit;
S:=NameFile(Temp);
TEMPO_DIR:=NumbStr(1,S); { Настройка CRUN_FMS }
S:=NumbStr(2,S)+NumbStr(3,S);
if S <> '' then S:=Temp
else if Create_Unic_File(S) <> 0 then S:='';
if S <> '' then begin
Assign(_Fstk_,S);
{$I-} Rewrite(_Fstk_,1);
{$I+} _Ostk_:=(IOresult = 0)
end end;
{ DoneCTEK : Закрыть стек на диске }
procedure DoneCTEK;
begin if _Ostk_ then ClerFile(_Fstk_);
_Ostk_:=false end;
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;; Оверлейная часть обработки Config.sfm ;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{$I IMPL_FMS.PAS } { ConMacro }
{ ConfStr : Чтение очередной строки из Config.sfm }
{ Code - код терминала }
{ Res = FALSE if S = '' }
{ TRUE if S = Имя + Значение + }
{ Vermi = Termi | * }
function ConUnis(Termi : char; var Vermi : char; var S : String) : boolean;
var P,C : String;
M : integer;
begin S:='';
{$I-} Readln(F_text,C); {$I+}
if IOresult = 0 then begin
TwoPress(C);
if 2 <= Length(C) then begin
Vermi:=Termi;
if C[1] = Termi then Delete(C,1,1)
else Vermi:='*';
if C[1] = '_' then begin
M:=Pos('=',C);
if 1 < M then begin
P:=Copy(C,2,M-2);
TwoPress(P);
if P <> '' then begin
{ Если имя имеет } if Pos(' ',P) <> 0 then begin
{ пробелы } P:=P+' ';
Psps(P)
end;
SummStr(S,P);
P:=Copy(C,M+1,255);
LefPress(P);
SummStr(S,P)
end
end
end
end
end;
ConUnis:=(S <> '') end;
{ ConfStr : Чтение очередной строки из Config.sfm }
{ Code - код терминала }
{ Res = FALSE if S = '' }
{ TRUE if S = Имя + Значение + }
function ConfStr(Termi : char; var S : String) : boolean;
var A : char;
begin ConfStr:=ConUnis(Termi,A,S) end;
{ TakeConf_Read : Termi - код терминала }
{ *** CONFIG.SFM -> Add Memory *** }
function ConTake_Read(Termi : char) : String;
var Vermi : char;
R,S : String;
L : integer;
N : NameStr;
E : ExtStr;
begin FSplit(Fexpand(ParamStr(0)),DIRS[OWN],N,E); { Make_OWN }
R:='Не хватает оперативной памяти.';
if OpnNewInd(true) then begin
R:='Не могу открыть Config.sfm';
if OpenText(DIRS[OWN]+'CONFIG.SFM') then begin
R:='';
while (R = '') and (not eof(F_text)) do
if ConUnis(Termi,Vermi,S) then begin
L:=Length(S)+2;
S[L-1]:=Vermi;
if L+128 < AddMaxAvail
then PutNewVal(S,L) { EXEC_FMS }
else R:='Не хватает оперативной памяти.'
end;
Cls_Text(F_text)
end
end;
ConTake_Read:=R end;
{ Napa : имя параметра номер N }
function Napa(N : integer) : String;
var S : ^String;
begin S:=AdrIndMem^[N];
Napa:=NumbStr(1,S^) end;
{ PRESET : Собрать вверху все параметры SET }
{ Res = количество макроподстановок }
function PRESET(L : integer) : integer;
var I,J,K : integer;
P : pointer;
C : String;
begin K:=0;
for I:=1 to L do begin
C:=Napa(I);
if Pos('SET ',C) = 1 then
if QuanStr(C) = 2 then begin
P:=AdrIndMem^[I];
K:=K+1;
for J:=I-1 downto K do AdrIndMem^[J+1]:=AdrIndMem^[J];
AdrIndMem^[K]:=P
end
end;
PRESET:=K end;
{ ConCler : Отобрать действующие параметры в ExtMemory }
function ConCler : String;
var I,J,K,L,N : integer;
C,E : String;
P : ^String;
function EE : boolean;
var J : integer;
begin EE:=true;
for J:=I+1 to L do
if C = Napa(J) then Exit;
EE:=false
end;
procedure MAPK(N : integer; A : char);
var S : ^String;
L : integer;
begin S:=AdrIndMem^[N];
L:=Length(S^);
if L < 255 then S^[L+1]:=A
end;
procedure OTME(N : integer; A : char);
var S,Q : String;
G : ^String;
I : integer;
begin G:=AdrIndMem^[N];
Q:=NumbStr(1,G^); { Имя параметра }
S:='F6(*)';
S[4]:=Q[4];
I:= MembStr(Q,'F2MENU.INFIELDS.ALT+F3.');
if (0 < I) or (Q = S) then
else Exit;
S:=NumbStr(2,G^)+' ';
Psps(S);
while Fin_Str(Q,S) do
for I:=1 to L do
if Q = Napa(I) then MAPK(I,A)
end;
function Me(N : integer) : char;
var S : ^String;
L : integer;
begin S:=AdrIndMem^[N];
L:=Length(S^);
if L < 255 then ME:=S^[L+1]
else ME:=' '
end;
begin L:=CkoIndMem;
I:=0;
while I < L-1 do begin { Недействующие параметры убрать в L..CkoIndMem }
I:=I+1;
C:=Napa(I);
if EE then begin
P:=AdrIndMem^[I];
for J:=I+1 to L do AdrIndMem^[J-1]:=AdrIndMem^[J];
AdrIndMem^[L]:=P;
L:=L-1;
I:=I-1
end
end;
K:=PRESET(L); { Выделить группу параметров макроподстановок }
for I:= 1 to L do MAPK(I,' ');
for I:=L+1 to CkoIndMem do OTME(I,'-'); { Отметить лишние параметры }
for I:= 1 to L do OTME(I,' '); { Переотметить нужные парам }
J:=0;
E:='';
for I:=1 to L do
if ME(I) <> '-' then begin
J:=J+1;
P:=AdrIndMem^[I];
if 0 < K then
if K < I then
if E = '' then begin
C:=NumbStr(2,P^);
ConMacro(C);
if 253 < Length(NumbStr(1,P^))+Length(C)
then E:=NumbStr(1,P^)+' = cлишком длинное значение'
end;
AdrIndMem^[J]:=P
end;
ConCler:=E;
CkoIndMem:=J end;
{ TakeConf : Termi - код терминала }
{ *** CONFIG.SFM -> Add Memory *** }
function ConTake(Termi : char) : String;
var R : String;
begin R:=ConTake_Read(Termi);
if R = '' then R:=ConCler;
ConTake:=R end;
{ ConSave : переписать Config из AddMemory в СТЕК }
{ Вычислить значение SP_config }
procedure ConSave;
var C,S : String;
L : integer;
R : ^String;
begin S:='';
PUSH(S,1);
for L:=1 to CkoIndMem do begin
R:=AdrIndMem^[L];
C:=R^;
S:=NumbStr(2,C);
ConMacro(S);
ExchStr(2,C,S);
PUSH(C,Length(C)+1)
end;
SP_Config:=Get_SP end;
END.
|