(* TEST_FMS использует: D_UNIT *)
(* EXEC_FMS *)
(* KEYS_FMS *)
(* LAYS_FMS *)
(* LOAD_FMS *)
(* STAK_FMS *)
(* TYPE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O+,R+,S+,V+,X-}
{$M 16384,0,655360}
Unit TEST_FMS; INTERFACE
Uses DOS, D_unit, UNIF_FMS, TYPE_FMS, STAK_FMS,
CRT, LAYS_FMS, KEYS_FMS, LOAD_FMS, EXEC_FMS;
procedure AHATOM(RH : pHead; var Lmax : integer; var Sucs : boolean);
procedure TestHead(H : pHead; N : integer);
procedure TestField;
function AfterPoint(var VER : String) : integer;
procedure Z_TstMed;
procedure ReTstMed;
{ Буфер передачи данных в программу }
TYPE Typ_Buf = record VER : String; { Inp: VER^, Out: сооб.об ош }
LEC : String; { LEft Context }
SUN : String; { Self UNo }
RIC : String; { Right Context }
DSK : array [0..15] of String[8];
RES : integer;
end;
IMPLEMENTATION
{ UnTST_All: TST:=false для всех подструктур }
{ используется в АНАТОМ }
procedure UnTST_All(H : pHead; N : integer);
var I : integer;
procedure Loop(H : pHead);
var I : integer;
begin if H <> NIL then
for I:=1 to H^.HSF do UnTST_All(H,I)
end;
begin with H^.BDS[N] do begin
Sset(BOS,TST,false);
if MN_MEM <> NIL then
if MN_MEM^.LON = '' then with MN_MEM^ do
for I:=1 to HSF do Loop(ELT[I].DTL);
if MN_MEM = NIL then Loop( DTL)
end end;
{ AHATOM: coxCB - строка символов }
{ RH - синтаксическая структура }
{ coxOT - используется как магазин }
{ результат= Lmax - max распознанная левая часть coxCB }
{ Sucs - True, если строка удовлетворяет синтаксису }
procedure AHATOM(RH : pHead; var Lmax : integer; var Sucs : boolean);
var Ltek,Lstk : integer;
{ TES: Проверка: Символ coxCB[Ltek+1] }
{ соответствует H^.BDS[N].RFT^[J] }
function TES(H : pHead; N,J : integer) : boolean;
begin TES:=false;
if Ltek = Length(coxCB) then Exit;
if not COOunp(H^.BDS[N].RFT^[J],coxCB[Ltek+1]) then Exit;
Ltek:=Ltek+1;
if Lmax < Ltek then Lmax:=Ltek;
OT[Ltek].H:=H;
OT[Ltek].Y:=N;
OT[Ltek].X:=J;
TES:=true
end;
{ NewTask: записать в магазин очередную задачу }
procedure NewTask(HH : pHead; N,I : integer);
begin Lstk:=Lstk+1;
with coxOT[Lstk] do begin
H:=HH; { Head }
Y:=N; { Number in Head }
X:=Ltek; { BasePos in String coxCB }
MIG:=I { Information 255 - nonOBS }
end
end;
procedure Inp_Head(H : pHead; N,B : integer); { Вспом. для TesTask }
var I,K,L,M : integer;
begin with H^.BDS[N] do begin { Записать в Head }
TEHT(H,N,L,M);
K:=LFT-L-M; { Длина RigthContext }
K:=Ltek-K;
for I:=L+1 to L+M do
if B+I <= K then CTP^[I]:=coxCB[B+I]
else CTP^[I]:=UNC;
if MN_MEM <> NIL then { Исправить (H,N) }
if DTL <> NIL then DTL:=NIL
end;
UnTST_All(H,N);
end;
{ TesTask: Проверяем выполнимость задачи }
{ для RFT[1..I]+RigthContext }
function TesTask(H : pHead; N,I : integer) : boolean;
var L,M,J,Lcox : integer;
W : boolean;
begin Lcox:=Ltek;
TEHT(H,N,L,J);
L:=L+J;
TesTask:=false;
with H^.BDS[N] do begin
if I < L then NewTask(H,N,I+1); { Ставим след задачу для not GES }
for J:=1 to LFT do
if (J <= I) or (L < J) then
if not TES(H,N,J) then begin Ltek:=Lcox; Exit end;
end;
{ Проверить доп.условия корректности }
Inp_Head(H,N,Lcox); { Переписать в (H,N) текст из coxCB }
W:=Test_Diag;
Test_Diag:=false;
TestHead(H,N);
Test_Diag:=W;
TesTask:=Lask(H,N,COF);
if not Lask(H,N,COF) then Ltek:=Lcox; { Откат }
end;
{ GenTask: Генератор очередных задач. }
{ По самой левой ветви. }
procedure GenTask(H : pHead; N : integer);
var L,M : integer;
begin repeat
with H^.BDS[N] do begin
if not Sask(BOS,OBS)
then NewTask(H,N,255); { Допускаем пропуск (H,N) }
if DTL = NIL then begin
TEHT(H,N,L,M);
if M = 0 then L:=LFT
else if Sask(BOS,GES) then L:=L+M
else L:=L+1;
NewTask(H,N,L) { Формулируем задачу }
end;
H:=DTL;
N:=1
end;
until H = NIL
end;
{ NexTask: Распознавание (H,N) закончилось успешно. }
{ Сформулировать и записать в стек след.задачу }
{ Поиск правого Uno. }
procedure NexTask(H : pHead; N : integer);
begin repeat
with H^ do begin
if N < HSF then begin
GenTask(H,N+1);
Exit
end;
N:=BK_POS;
H:=BK_PTR
end;
until H = NIL; { См. начало тела AHATOM }
if Ltek = Length(coxCB) then begin { Разбор закончен }
Lstk:=0;
Sucs:=true
end
end;
var SP_memory : LongInt; { Для надежности Only }
N,P,I : integer;
H : pHead;
begin PUSH(MEAD^.BDS[abs(FITEK)].DTL^,SizeOfField); { Save Field }
SP_memory:=savPUSH(MESSAGE^.DSK,SizeOf(MESSAGE^.DSK)); { Save DESK }
RH^.BK_PTR:=NIL; { Ограничить синтаксическую структуру }
Sucs:=false;
Lmax:=0;
Ltek:=0;
Lstk:=0;
GenTask(RH,1);
while 0 < Lstk do begin
H:=coxOT[Lstk].H; { Выбрать очередную задачу }
N:=coxOT[Lstk].Y;
Ltek:=coxOT[Lstk].X;
I:=coxOT[Lstk].MIG;
Dec(Lstk);
if I = 255 then NexTask(H,N) { Задача не обязательна }
else if TesTask(H,N,I) then NexTask(H,N)
end;
resPOP(MESSAGE^.DSK,SP_memory); { Rest DESK and Field }
POP(MEAD^.BDS[abs(FITEK)].DTL^) end;
{ c_MENU - Проверка на принадлежность меню }
function Inn_Menu(H : pHead; N,E : integer) : boolean; { Вспомогательная }
var M : integer; { для c_Menu }
W : boolean;
begin PUSH(coxCB,SizeOf(coxCB));
PUSH(coxOT,SizeOf(coxOT));
UnoStr(coxCB,H,N,true);
AHATOM(H^.BDS[N].MN_MEM^.ELT[E].DTL,M,W);
Inn_Menu:=W;
POP(coxOT);
POP(coxCB) end;
function c_MENU(H : pHead; N : integer) : boolean;
var I : integer;
S : String;
C : ^String;
begin c_MENU:=true;
with H^.BDS[N] do begin
if MN_MEM = NIL then Exit;
if not Sask(BOS,MN_GES) then Exit;
UnoStr(S,H,N,false); { TYPE_FMS.tpu }
if MN_MEM^.LON <> '' then begin { Внешнее меню }
c_MENU:=Ctrl_EXT_Menu(H,N,S); { LAYS_FMS.tpu }
Exit
end;
with MN_MEM^ do
for I:=1 to HSF do { Внутренне меню }
if ELT[I].DTL = NIL then begin
C:=addr(ELT[I].CTP^[1]);
if C^ = S then Exit;
end else begin
if Inn_Menu(H,N,I) then Exit
end;
c_MENU:=false
end end;
{ Import : выдает номер DSK для импорта аргументов }
{ -1 - нет такого номера }
{ усекает строку }
function Import(var S : String) : integer;
var I : integer;
C : String;
begin Import:=-1;
C:='/'+S+'/';
UpCaseStr(C);
I:=Pos('/IMP(',C);
if 0 < I then
if I = Pos('/IMP('+C[I+5]+')/',C) then begin
Import:=ValHex(C[I+5]);
Delete(S,I-1,8)
end end;
{ c_VERI - семантическая проверка (H,N) }
function AfterPoint(var VER : String) : integer; { К-во разрядов после запятой }
var K,L : integer;
begin K:=Import(VER);
if 0 <= K then Val_Int(MESSAGE^.DSK[K].CTP,K,L)
else L:=-1;
if L <> 0 then K:=-1;
AfterPoint:=K end;
{ LPC = TRUE , если S = mn...n | 0 + E = -1 }
{ FALSE, если S = только разделители | пустая S + E = -1 }
{ FALSE, если S = dd...d общего вида + E = поз.посл.разд }
function LPC( H : pHead; N : integer;
var S : String; var E : integer) : boolean;
var I,K,L,P : integer;
begin LPC:=false;
E:=-1;
UnoStr(S,H,N,false);
L:=Length(S);
K:=0;
for I:=1 to L do
if Cnumb(S[I]) then K:=K+1
else P:=I;
if S = '0' then LPC:=true
else if K = 0 then Terr_Gey(H,N,'Неправильное число')
else if K <> L then E:=P { Общий случай }
else if '0' < S[1] then LPC:=true
else Terr_Gey(H,N,'Неправильное начало числа') end;
{ LP3 = S[1..L] - правильная целая часть }
{ [с единым разделителем отличным от C] }
function LP3( H : pHead; N : integer;
var S : String; L : integer; C : char) : boolean;
var I,K,P : integer;
A : char;
begin LP3:=false;
if 1 < L then { Well .nnn 0.nnn }
if (S[1] < '1') or ('9' < S[1]) then begin
Terr_Gey(H,N,'Неправильное начало числа');
Exit
end;
K:=0; { Количество разделителей }
for I:=1 to L do
if not Cnumb(S[I]) then begin
if (0 < K) and (S[I] <> A) then K:=K+L; { Есть разные }
A:=S[I];
if A = C then K:=K+L; { Один совпал }
K:=K+1
end;
P:=(L+1) and 3;
if 0 < K then for I:=1 to L do
if (I and 3) = P then
if S[I] = A then K:=K-1
else K:=K+L;
if 0 < K
then Terr_Gey(H,N,'Ошибка в разделителях')
else LP3:=true end;
function SP3( H : pHead; N : integer;
var S : String; P : integer) : boolean;
var W : boolean;
begin SP3:=true;
W:=false;
if P = 1 then Exit; { Well .nnn }
if P = 2 then
if S[1] = '0' then Exit { Well 0.nnn }
else W:=true; { Bad m.nnn }
if P = 3 then W:=true; { Bad nn.nnn }
if P = 4 then W:=true; { Bad nnn.nnn }
SP3:=false;
if W then Terr_Gey(H,N,'Недопустимое число')
else SP3:=LP3(H,N,S,P-1,'0') end;
function c_NUM(H : pHead; N : integer; var S : String) : boolean;
var K,L,M,P : integer;
C : String;
begin c_NUM:=LPC(H,N,C,P);
if P < 1 then Exit; { c_NUM:=false; }
L:=Length(C);
M:=L-P;
K:=AfterPoint(S); { К-во разрядов после запятой; Число | -1 }
if K = 3 then begin
if M = 3 then c_NUM:=SP3(H,N,C,P)
else Terr_Gey(H,N,'Ошибка в разделителях')
end else begin
if M = 3 then c_NUM:=LP3(H,N,C,L , '0')
else if M = K then c_NUM:=LP3(H,N,C,P-1,C[P])
else Terr_Gey(H,N,'К-во знаков в дробной части = '
+NNN(M)+'. Требуется: '+NNN(K))
end end;
function c_NNB(H : pHead; N : integer) : boolean;
var L,P : integer;
C : String;
begin c_NNB:=LPC(H,N,C,P);
if P < 1 then Exit; { c_NNB:=false; }
L:=Length(C);
if C[P] = '.' then c_NNB:=LP3(H,N,C,P-1,'.')
else c_NNB:=LP3(H,N,C,L ,'.') end;
function c_REF(H : pHead; N : integer; var C : String) : boolean;
var S : String;
I,L : integer;
begin UnoStr(S,H,N,false);
c_REF:=true; if S = '' then Exit;
c_REF:=false; if S[1] = '/' then Exit;
L:=Length(S); if S[L] = '/' then Exit;
I:=Pos('//',S); if (1 < I) and (I+1 < L) then Exit;
c_REF:=true end;
(****
procedure Forw_Step(Hm : pHead; N : integer;
H : pHead; var TP : Typ_Buf);
var I : integer;
begin with TP do begin
if (Hm = H) and (RES = N) then begin
RES:=-10000;
UnoStr(SUN,Hm,N,true);
Exit
end;
with Hm^.BDS[N] do begin
if DTL = NIL then begin
UnoStr(VER,Hm,N,true);
if 1 <= RES then LEX:=LEX+VER
else RIC:=RIC+VER;
Exit
end;
for I:=1 to DTL^.HSF do Forw_Step(DTL,I,H,TP)
end
end end;
procedure Back_Step(H : pHead; N : integer; var TP : Typ_Buf);
var Hm : pHead;
begin TP.RES:=N;
Hm:=H;
while Hm^.KND = 8 do begin
N :=Hm^.BK_POS;
Hm:=Hm^.BK_PTR
end;
Forw_Step(Hm,N,H,TP) end;
***)
function c_RUN(H : pHead; N : integer) : boolean;
var Test_Prog : Typ_Buf;
LL,MM,I : integer;
C : Alfa;
P : pointer;
L : LongInt absolute P;
begin c_RUN:=false;
FillChar(Test_Prog,SizeOf(Test_Prog),0);
TEHT(H,N,LL,MM);
MM:=LL+MM;
with Test_Prog do begin { Сформировать буфер }
with H^.BDS[N] do begin
if 0 < LL then LEC:=Copy(RFT^, 1, LL);
if MM < LFT then RIC:=Copy(RFT^,MM+1,LFT-MM)
end;
UnoStr(SUN,H,N,false);
VER:=H^.BDS[N].VRF^;
RES:=0;
for I:=0 to 15 do DSK[I]:=MESSAGE^.DSK[I].CTP;
C:=VER;
I:=Pos('/',C);
if I = 0 then C:='' else begin
Delete(C,1,I);
C[0]:=chr(MinPos('/',C)-1)
end;
if C = '' then begin
Terr_Gey(H,N,'Нет программы проверки '+VER);
Exit
end;
P:=addr(Test_Prog);
I:=Call_Exec(DIRS[OWN]+C,NNN(L));
if I <> 0 then begin
Terr_Gey(H,N,'Ошибка DOS '+NNN(I)+' при запуске программы '+C);
Exit
end;
c_RUN:=(RES = 0);
LEC:=H^.BDS[N].VRF^; UpCaseStr(LEC);
RIC:=VER; UpCaseStr(RIC);
if LEC <> RIC then Terr_Gey(H,N,VER) { Диагностическое сообщение }
end end;
function c_DAT(H : pHead; N : integer; var C : String) : boolean;
var I,L,K,MO : integer;
VY,W : boolean;
S,E : String;
function DM : integer; { Количество дней в месяце No.MO }
begin case MO of
2 : if VY then DM:=29
else DM:=28;
4,6,9,11 : DM:=30;
else DM:=31;
end;
end;
procedure KHT(Ha,Ko : integer; G : NameStr);
begin W:=(Ha <= K) and (K <= Ko);
E:=E+' '+G+': '
end;
begin UnoStr(S,H,N,false);
VY:=true; { Високосный год по умолчанию }
MO:=1; { Январь - по умолчанию }
C[0]:=chr(MinPos('/',C)-1);
UpCaseStr(C);
I:=POS(C,'YYYYMMDDHHMMSS');
if (I = 3) or (C = 'YY') then begin { YY... -> YYYY... }
if S[1] = '9' then S:='19'+S
else S:='20'+S;
I:=1
end;
E:='';
if I = 1 then begin
E:=' Год: '+Copy(S,1,2);
Delete(S,1,2);
I:=3
end;
L:=Length(S);
c_DAT:=true;
if L = 0 then Exit;
if I = 0 then Exit;
if odd(L) then Exit;
if not odd(I) then Exit;
W:=true;
while (S <> '') and W do begin
Val_Int(Copy(S,1,2),K,L);
case I of
3 : VY:=((K mod 4) = 0); { год }
5 : begin KHT(1,12,'Месяц' ); MO:=K end;
7 : KHT(1,DM,'День' );
9 : KHT(0,23,'Часы' );
11 : KHT(0,59,'Минуты' );
13 : KHT(0,59,'Секунды');
end;
E:=E+Copy(S,1,2);
Delete(S,1,2);
I:=I+2
end;
if not W then Terr_Gey(H,N,E+' ???');
c_DAT:=W end;
function c_ISI(H : pHead; N : integer) : boolean;
var I,J,K : integer;
S : String;
B : boolean;
A : char;
begin UnoStr(S,H,N,false);
ComPress(S);
c_ISI:=false;
if Length(S) = 11 then S:=S+' ';
if Length(S) <> 12 then begin
Terr_Gey(H,N,'Ошибка в длине п/поля. '+
'Требуется 11 симв. + контроль.цифра');
Exit
end;
K:= 0; { Главный счетчик }
I:=12;
B:=true;
while 1 < I do begin
I:=I-1;
A:=S[I];
if ('A' <= A) and (A <= 'Z') then begin
J:=ord(A)-ord('A')+10;
S[I]:=chr(ord('0')+J div 10);
I:=I+1;
J:=J mod 10
end else
if Cnumb(A) then J:=ord(A)-ord('0')
else
begin Terr_Gey(H,N,'Недопустимый символ('+A+'). '+
'Допускаются: 0-9,A-Z');
Exit
end;
if B then J:=J+J;
if 9 < J then J:=J-9;
K:=K+J;
B:=not B;
end;
K:= K mod 10;
if K <> 0 then K:=10-K;
A:=chr(ord('0')+K); { 12-й разряд }
c_ISI:=(A = S[12]);
if A <> S[12] then
Terr_Gey(H,N,'Ошибка в контрольной цифре('+S[12]+'). '+
'Требуется '+A) end;
(*
function INN_LAST_CHAR(var C : String) : char;
const WT : array [1..9] of integer = (31,29,23,19,17,13,7,5,3);
var I,S : integer;
begin S:=0;
for I:=1 to 9 do
S:=S+WT[I]*(ord(C[I])-ord('0'));
S:=S mod 11;
if S <= 1 then S:=0
else S:=11-S;
INN_LAST_CHAR:=chr(ord('0')+S) end;
*)
{ v_INN : S - заданное значение ИНН }
{ Res = "правильное значение ИНН"| ''= если длина <> 10|12 }
function v_INN(var S : String) : String;
const WT : array [1..11] of integer = (41,37,31,29,23,19,17,13,7,5,3);
var C : String;
L : integer;
procedure CCH(N : integer);
var I,S : integer;
begin S:=0;
for I:=1 to N-1 do
S:=S+WT[12-N+I]*(ord(C[I])-ord('0'));
S:=S mod 11;
if S <= 1 then S:=0
else S:=11-S;
C[N]:=chr(ord('0')+S)
end;
begin L:=Length(S);
C:=S;
if L = 10 then CCH(10)
else if L = 12 then begin CCH(11); CCH(12) end
else C:='';
v_INN:=C end;
{ c_INN : Проверка на 10-ти или 12-ти значный ИНН }
{ TRUE : Если длина = 10 или 12 }
{ + [ Контрольное предупреждение ] }
function c_INN(H : pHead; N : integer) : boolean;
var S,C : String;
K : integer;
begin c_INN:=true;
UnoStr(S,H,N,false);
C:=v_INN(S);
c_INN:=(C <> '');
if C = '' then Exit;
if C = S then Exit;
if Length(S) = 10 then K:=9
else K:=10;
Delete(C,1,K);
Delete(S,1,K);
Terr_Gey(H,N,'В последних цифрах ИНН ('+S+'). Требуется '+C) end;
{ c_SWIFT : Символов на принадлежность допустимым значениям SWIFT-a }
function c_SWIFT(H : pHead; N : integer) : boolean;
var S : String;
I : integer;
begin UnoStr(S,H,N,false);
for I:=1 to Length(S) do
if not COOunp('y',S[I]) then begin
c_SWIFT:=false;
Terr_Gey(H,N,'Запрещенный символ: "'+S[I]+'"');
Exit
end;
c_SWIFT:=true end;
function c_VERI(H : pHead; N : integer) : boolean;
var S,C : String;
I : integer;
W : boolean;
begin W:=true;
with H^.BDS[N] do
if VRF <> NIL then begin
I:=MinPos('/',VRF^); { VRF^ --> S+'/'+C }
S:=Copy(VRF^, 1,I-1);
C:=Copy(VRF^,I+1,255);
UpCaseStr(S);
if S = '' then
else if S = 'NUMBER' then W:=c_NUM(H,N,C)
else if S = 'NORMNUMB' then W:=c_NNB(H,N)
else if S = 'REF' then W:=c_REF(H,N,C)
else if S = 'RUN' then W:=c_RUN(H,N )
else if S = 'DT' then W:=c_DAT(H,N,C)
else if S = 'ISIN' then W:=c_ISI(H,N )
else if S = 'INN' then W:=c_INN(H,N )
else if S = 'SWIFT' then W:=c_SWIFT(H,N)
end;
c_VERI:=W end;
{ Exec_Exp: Выполнить все exp(*) за исключением exp(*)frc(... }
procedure Exec_Exp(H : pHead; N : integer);
var S,C : Alfa;
K : integer;
function Find_Exp : boolean;
begin Find_Exp:=true;
K:=Pos('EXP(',S);
while K <> 0 do begin
Delete(S,1,K+3);
if Pos(')' ,S) = 2 then
if Pos('FRC(',S) <> 3 then Exit;
K:=Pos('EXP(',S);
end;
Find_Exp:=false
end;
begin with H^.BDS[N] do
if VRF = NIL then Exit
else S:=VRF^;
UpCaseStr(S);
while Find_Exp do begin
K:=ValHex(S[1]);
if 0 <= K then begin
UnoStr(C,H,N,false);
LimitStr(C,8);
with MESSAGE^.DSK[K] do begin
CTP := C ;
BKP[10]:='N'
end
end
end end;
{ Проверка корректности Body - структур }
{ Заполняются признаки TST, EMP, COF }
procedure TestBody(H : pHead; N : integer);
var I,L,M,C : integer;
begin if Lask(H,N,TST) then Exit; { Экономия проверок }
{ TST } Lset(H,N,TST,true);
TEHT(H,N,L,M);
{ EMP } with H^.BDS[N] do
if Sask(BOS,RP_BGN) then Sset(BOS,EMP,false) else begin
C:=0;
for I:=L+1 to L+M do
if (CTP^[I] <> UNC) and (CTP^[I] <> ' ') then Inc(C); { Only Spaces }
Sset(BOS,EMP,(C = 0) and (0 < M))
end;
{ COF } if Lask(H,N,EMP) then begin
Lset(H,N,COF,not Lask(H,N,OBS));
Exit
end;
Lset(H,N,COF,false); { COF:=false }
COHT(H,N,L,C);
if Lask(H,N,GES) then begin if M <> C then Exit end
else begin if (C = 0) and (0 < M) then Exit end;
if not c_MENU(H,N) then Exit;
if not c_VERI(H,N) then Exit;
Exec_Exp(H,N); { Исполнить экспортные операции }
Lset(H,N,COF,true); { COF:=true }
end;
{ Проверка корректности Head/Body - структур }
{ Заполняются признаки TST, EMP, COF }
procedure TestHead(H : pHead; N : integer);
var Wemp,Wcor : boolean;
I : integer;
begin with H^.BDS[N] do begin
IF DTL = NIL THEN begin { Выход из рекурсии }
TestBody(H,N);
Exit
end;
Wemp:=true;
Wcor:=true;
for I:=1 to DTL^.HSF do begin
TestHead(DTL,I);
Wemp:=Wemp and Lask(DTL,I,EMP);
Wcor:=Wcor and Lask(DTL,I,COF)
end;
if Wemp then Wcor:=not Sask(BOS,OBS); { Поправка }
Sset(BOS,TST,true);
Sset(BOS,EMP,Wemp);
Sset(BOS,COF,Wcor)
end end;
{ Расставить маркеры MKP и рассчитать корректность поля COF }
{ Без контроля FITEK }
procedure TestField;
var I,J,FN : integer;
FH : pHead;
W : boolean;
procedure SendTrue;
var I,J : integer;
begin for I:=1 to FH^.HSF do
with FH^.BDS[I] do
IF DTL^.KND = 8
THEN Lset(FH ,I,MKP,true)
ELSE for J:=1 to DTL^.HSF do Lset(DTL,J,MKP,true)
end;
procedure EMPandOBS;
var I,J : integer;
begin if not Lask(MEAD,FN,OBS) then Exit;
J:=0;
for I:=1 to FH^.HSF do { Attempt N 1 Mark OBS's }
with FH^.BDS[I] do
if Sask(BOS,OBS) then begin
J:=1;
if DTL^.KND = 8 then Sset(BOS ,MKP,false)
else Lset(DTL,1,MKP,false)
end;
if J <> 0 then Exit;
for I:=1 to FH^.HSF do { Attempt N 2 Mark All's }
with FH^.BDS[I] do
if DTL^.KND = 8 then Sset(BOS ,MKP,false)
else Lset(DTL,1,MKP,false)
end;
procedure A4(H : pHead; N : integer);
var I : integer;
begin with H^.BDS[N] do
IF Sask(BOS,EMP)
THEN Lset(DTL,1,MKP,not Sask(BOS,OBS)) { п/поле пусто }
ELSE
for I:=1 to DTL^.HSF do { п/поле не пусто }
if not Lask(DTL,I,EMP)
then Lset(DTL,I,MKP,Lask(DTL,I,COF)) { для непустых строк }
end;
begin FN:=abs(FITEK);
FH:=MEAD^.BDS[FN].DTL;
if FH = NIL then Exit;
SendTrue; { All MKP := true }
TestHead(MEAD,FN);
IF Lask(MEAD,FN,EMP)
THEN EMPandOBS { Case-1 Поле пусто }
ELSE { Case-2 Поле не пусто }
for I:=1 to FH^.HSF do
with FH^.BDS[I] do
if DTL^.KND = 8 then Sset(BOS,MKP,Sask(BOS,COF))
else A4(FH,I);
W:=true; { Выход - вычислить COF поля }
for I:=1 to FH^.HSF do
with FH^.BDS[I] do
IF DTL^.KND = 8
THEN W:=W and Sask(BOS ,MKP)
ELSE for J:=1 to DTL^.HSF do W:=W and Lask(DTL,J,MKP);
Lset(MEAD,FN,COF,W) end;
{ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; }
{ ;;;; Z_TstMed ;;;;;;;; Проверка сообщения ;;;;;;;;;;;;;;;;;;;;;;;;; }
{ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; }
{ ExiNo = true, если существует бит TST = 0 }
function ExiNo(H : pHead; N : integer) : boolean;
var I : integer;
begin ExiNo:=true;
with H^.BDS[N] do begin
if not Sask(BOS,TST) then Exit;
if DTL <> NIL then
for I:=1 to DTL^.HSF do
if ExiNo(DTL,I) then Exit;
ExiNo:=false
end end;
procedure Z_TstMed;
var I,K : integer;
begin Test_Diag:=false;
K:=0;
for I:=1 to MEAD^.HSF do begin { 1 тур }
LoadField(I);
LinkField;
(* **** MarkServ(I); **** *)
if MEAD^.BDS[I].DTL <> NIL then
if ExiNo(MEAD,I) then begin
K:=K+1;
FITEK:=-abs(FITEK);
TestField
end
end;
for I:=1 to MEAD^.HSF do begin { 2 тур }
(* **** MarkServ(MEAD^.HSF+I); **** *)
if (K <> 0) and (MEAD^.BDS[I].DTL <> NIL) then begin
LoadField(I);
if ExiNo(MEAD,I) then begin
FITEK:=-abs(FITEK);
TestField
end
end
end;
if FITEK < 0 then D_Write(abs(FITEK)); end;
{ Un_Tst_Head : Сбросит в 0 все биты TST терминальных п/полей }
procedure Un_Tst_Head(H : pHead);
var N : integer;
begin for N:=1 to H^.HSF do
with H^.BDS[N] do begin
if Sask(BOS,TST) then begin
Sset(BOS,TST,false);
FITEK:=-abs(FITEK)
end;
if DTL <> NIL then Un_Tst_Head(DTL)
end end;
{ ReTstMed - Перепроверка корректности сообщения }
procedure ReTstMed;
var I : integer;
H : pHead;
begin for I:=1 to MEAD^.HSF do begin
LoadField(I);
H:=MEAD^.BDS[I].DTL;
if H <> NIL then begin
Un_Tst_Head(H);
Lset(MEAD,I,TST,false)
end
end;
Z_TstMed end;
end.
Редактор mge.exe
Формат сообщения об ошибке (25-я строка)
°°°°°°°°°°°°°°°°°°° <Поле> НЕК: <ПодПоле> *** <Ошибка> °°°°°°°°°°°°°°°°°°°°
Где <Поле> - имя поля (DATE, ДАТА, 15, 20, 32, 32B и т.д.)
<ПодПоле> - текущее (неправильное) значение подполя
<Ошибка> - информационное сообщение об ошибке:
Ошибки в числах (суммах)
- К-во знаков в дробной части = n. Требуется: m
- Неправильное число
- Неправильное начало числа
- Ошибка в разделителях
Ошибки вызова внешней проверяющей со-программы
- Нет программы проверки Run/...
- Ошибка при запуске программы
Ошибки в датах
- Год = ???
- Месяц = ???
- День = ???
- Часы = ???
- Минуты = ???
- Секунды = ???
Ошибки в кодах ISIN
- Ошибка в длине п/поля. Требуется 11 симв. + контроль.цифра');
- Недопустимый символ(x). Допускаются: 0-9,A-Z
- Ошибка в контрольной цифре(x). Требуется y
(*
function c_DAT(H : pHead; N : integer; var C : String) : boolean;
var I,L,K,MO : integer;
VY,W : boolean;
S,E : String;
function DM : integer; { Количество дней в месяце No.MO }
begin case MO of
2 : if VY then DM:=29
else DM:=28;
4,6,9,11 : DM:=30;
else DM:=31;
end;
end;
procedure KHT(Ha,Ko : integer; G : NameStr);
begin W:=(Ha <= K) and (K <= Ko);
E:=E+' '+G+': '
end;
begin UnoStr(S,H,N,false);
VY:=true; { Високосный год по умолчанию }
MO:=1; { Январь - по умолчанию }
C[0]:=chr(MinPos('/',C)-1);
UpCaseStr(C);
I:=POS(C,'YYMMDDHHMMSS');
L:=Length(S);
c_DAT:=true;
if L = 0 then Exit;
if I = 0 then Exit;
if odd(L) then Exit;
if not odd(I) then Exit;
W:=true;
E:='';
while (S <> '') and W do begin
Val_Int(Copy(S,1,2),K,L);
case I of
1 : begin VY:=((K mod 4) = 0); { год }
if S[1] = '9' then E:=' Год: 19'
else E:=' Год: 20'
end;
3 : begin KHT(1,12,'Месяц' ); MO:=K end;
5 : KHT(1,DM,'День' );
7 : KHT(0,23,'Часы' );
9 : KHT(0,59,'Минуты' );
11 : KHT(0,59,'Секунды');
end;
E:=E+Copy(S,1,2);
Delete(S,1,2);
I:=I+2
end;
if not W then Terr_Gey(H,N,E+' ???');
c_DAT:=W end;
|