{$I KEYS}

unit Compun;


interface
uses Vars;

const IF_STACK_LIMIT =  30;
type  IF_STACK_BODY_TYPE = array [0..IF_STACK_LIMIT] of record
                                                          N           :integer;
                                                          Elseif      :integer;
                                                          For_Level   :integer;
                                                          While_Level :integer;
                                                        end;
var   IF_STACK_BODY :^IF_STACK_BODY_TYPE;
      IF_STACK      :integer;


const FOR_STACK_LIMIT = 30;
type  FOR_STACK_BODY_TYPE = array [0..FOR_STACK_LIMIT] of record
                                                            N           :integer;
                                                            C1,C2       :char;
                                                            d           :byte;
                                                            If_level    :integer;
                                                            While_level :integer;
                                                          end;
var   FOR_STACK_BODY :^FOR_STACK_BODY_TYPE;
      FOR_STACK      :integer;


const WHILE_STACK_LIMIT = 30;
type  WHILE_STACK_BODY_TYPE = array [0..WHILE_STACK_LIMIT] of record
                                                                N         :integer;
                                                                If_level  :integer;
                                                                For_level :integer;
                                                              end;
var   WHILE_STACK_BODY :^WHILE_STACK_BODY_TYPE;
      WHILE_STACK      :integer;


procedure WHILE_STM;
procedure ENDWHILE_STM;
procedure IF_STM;
procedure ELSEIF_STM;
procedure ELSE_STM;
procedure ENDIF_STM;
procedure FOR_STM;
procedure ENDFOR_STM;
procedure ARRAY_STM;
procedure DEBIT_CREDIT_STM;
procedure SORT_STM;
procedure REWIND_STM;
procedure FACT_STM;
procedure SEARCH_TOTAL_NEWS_ERASE_SELECT_STM(c :char);
procedure MOVESTM;
procedure LABEL_PROC(c :char);
procedure ALLOC_GETARR(c :char);
procedure ALLOC_PUTARR(c :char);

procedure COMPILE_SOURCE (READ_ONLY :ReadOnlyType; NPASS :integer);

function  IsItFileName(s :string; f :boolean) :boolean;
function  IsItRedirection(var s :string; f :boolean) :boolean;

procedure ALLOC_STRING(var a :string; READ_ONLY :ReadOnlyType);
procedure ALLOC_ERROR(a :string);
procedure PUSH_LITERAL(var a :string);
procedure PUSH_ACNT(var a :string);
procedure PUSH_REAL(r :double);
procedure PUSH_VAR(c1,c2 :char);
procedure SET_VAR(c1,c2 :char);

procedure Init_IF_FOR_WHILE_STACKS;



implementation
uses Compuni1, Interna, Lib1, RupUnit, Acnt1, Opt1, RussLett, Pro1, Facts, AsgnUnit;



procedure ALLOC_STRING(var a :string; READ_ONLY :ReadOnlyType);
label 1;
var p :pCMD_TYPE; t :string;
begin
if READ_ONLY = RO
then begin
     t:=a;
     if not IsItRedirection(t, false) then goto 1;
     end;

ALLOC_CMD(pointer(p),'p');

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;

p^.CMD:='p'; p^.NFUN:=length(a);

GetMem(p^.PS,length(a)+2);

pString(p^.PS)^:=a;

STORE_LINE(p);
1:
end;



procedure ALLOC_ERROR(a :string);
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'E');

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;

p^.CMD:='E'; p^.NFUN:=length(a);

GetMem(p^.PS,length(a)+2);

pString(p^.PS)^:=a;

STORE_LINE(p);
end;


procedure PUSH_LITERAL(var a :string);
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'L');

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;

p^.CMD:='L'; p^.NFUN:=length(a);

GetMem(p^.PS,length(a)+2);

pString(p^.PS)^:=a;

STORE_LINE(p);
end;



procedure PUSH_ACNT(var a :string);
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'a');

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;

p^.CMD:='a'; p^.AS:=a; p^.PS:=AcntP(a);

STORE_LINE(p);
end;


procedure PUSH_REAL(r :double);
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'r');

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;

p^.CMD:='r'; p^.Rdb:=r;

STORE_LINE(p);
end;



procedure PUSH_VAR(c1,c2 :char);
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'v');

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;

p^.CMD:='v'; p^.C1:=c1; p^.C2:=c2;

STORE_LINE(p);
end;



procedure LABEL_PROC(c :char);
label 1;
var p :pCMD_TYPE; s :string[20];
begin
ALLOC_CMD(pointer(p),'g');

p^.PS:=nil;

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;
p^.CMD:=c;

if (c='g') or (c='c') then begin GETCH; GETCH; GETCH end;

NEXTCH;

s:='';
repeat
   if WHICH_CH in [#13,' ',',',']'] then goto 1;
   s:=s+WHICH_CH;
   GETCH;
until false;
1: NEXTCH;

p^.AS:=s;

STORE_LINE(p);

XSTM_FLAG:=true;
end;



procedure ALLOC_LOOP(s :string; n :byte);
label 1,2;
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'#');
p^.PS:=nil; LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil; p^.AS:=s; p^.CMD:='#'; p^.NFUN:=n;

STORE_LINE(p);
end;



procedure ALLOC_GOTO(s :string);
label 1,2;
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'g');
p^.PS:=nil; LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil; p^.AS:=s; p^.CMD:='g';

STORE_LINE(p);
end;


procedure ALLOC_CALL(s :string);
label 1,2;
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'g');
p^.PS:=nil; LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil; p^.AS:=s; p^.CMD:='c';

STORE_LINE(p);
end;


procedure ALLOC_LABEL(s :string);
label 1,2;
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'g');
p^.PS:=nil; LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil; p^.AS:=s; p^.CMD:=':';

STORE_LINE(p);
end;


procedure ALLOC_GETARR(c :char);
label 1,2;
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'{');
p^.PS:=nil; LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil; p^.CMD:='{'; p^.C1:=c;

STORE_LINE(p);
end;


procedure ALLOC_PUTARR(c :char);
label 1,2;
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'}');
p^.PS:=nil; LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil; p^.CMD:='}'; p^.C1:=c;

STORE_LINE(p);
end;


procedure INC_VAR_AND_GOTO(c1,c2 :char; a :string; d :byte);
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),';');

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;

p^.CMD:=';'; p^.C1:=c1; p^.C2:=c2; p^.AS:=a; p^.PS:=nil; p^.NFUN:=d;

STORE_LINE(p);
end;


procedure CMP_AND_GOTO(c1,c2 :char; a :string; d :byte);
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'@');

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;

p^.CMD:='@'; p^.C1:=c1; p^.C2:=c2; p^.AS:=a; p^.PS:=nil; p^.NFUN:=d;

STORE_LINE(p);
end;


procedure ALLOC_PROC_ARRAY(c1,c2 :char;  d :byte);
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),')');

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;

p^.CMD:=')'; p^.C1:=c1; p^.C2:=c2; p^.AS:=''; p^.PS:=nil; p^.NFUN:=d;

STORE_LINE(p);
end;


procedure Init_IF_FOR_WHILE_STACKS;
begin
FillChar(IF_STACK_BODY^,    sizeof(IF_STACK_BODY^),    0);
IF_STACK :=0;

FillChar(FOR_STACK_BODY^,   sizeof(FOR_STACK_BODY^),   0);
FOR_STACK:=0;

FillChar(WHILE_STACK_BODY^, sizeof(WHILE_STACK_BODY^), 0);
WHILE_STACK:=0;
end;


function SpecF(T :longint) :string;
begin
if T < 0 then SpecF:='-' + SpecF(-T)
else if T < 26
     then SpecF:=chr(T + ord('A'))
     else SpecF:=SpecF(T div 26) + SpecF(T mod 26);
end;


procedure WHILE_STM;
label 1,2;
var sn, sl, tt :string[10]; d :byte;
begin
sl:=''; sn:='';
if NOT_FOR_COLOR
then begin
     inc(WHILE_STACK);
     if WHILE_STACK > WHILE_STACK_LIMIT
     then begin
          COMPILER_ERR(SIW(its_6210)); { ' Слишком глубоко вложенный WHILE' }
          goto 1;
          end;

     WHILE_STACK_BODY^[WHILE_STACK].If_level :=IF_STACK;
     WHILE_STACK_BODY^[WHILE_STACK].For_level:=FOR_STACK;

     inc(WHILE_STACK_BODY^[WHILE_STACK].N);
     str(WHILE_STACK, sl);
     sn:=SpecF(WHILE_STACK_BODY^[WHILE_STACK].N);
     end;

NEXTCHN(5);

ALLOC_LABEL('w' + sn + ' ' + sl);

EXPRESSION;

if COMP_POS < length(SOURCE)
then begin dec(COMP_POS); SOURCE[COMP_POS]:=';'; end;

CMP_AND_GOTO(' ', ' ', 'h' + sn + ' ' + sl, 4);
XSTM_FLAG:=true;
1:
end;



procedure ENDWHILE_STM;
label 1;
var sn, sl :string[20]; d :byte;
begin
if NOT_FOR_COLOR
then begin
     if WHILE_STACK = 0
     then begin
          COMPILER_ERR(SIW(its_6211));  { Еще не было WHILE }
          goto 1;
          end;

     if IF_STACK <> WHILE_STACK_BODY^[WHILE_STACK].If_Level
     then begin
          COMPILER_ERR(SIW(its_6212));  { Пеpекpытие тел WHILE и IF }
          goto 1;
          end;
     if FOR_STACK <> WHILE_STACK_BODY^[WHILE_STACK].For_Level
     then begin
          COMPILER_ERR(SIW(its_6213));  { Пеpекpытие тел WHILE и FOR }
          goto 1;
          end;

     Str(WHILE_STACK, sl);
     sn:=SpecF(WHILE_STACK_BODY^[WHILE_STACK].N);
     end;

ALLOC_GOTO ('w' + sn + ' ' + sl);
ALLOC_LABEL('h' + sn + ' ' + sl);

if NOT_FOR_COLOR then dec(WHILE_STACK);

XSTM_FLAG:=true;
1:
end;


procedure IF_STM;
label 1;
var sn, sl, se, se1 :string[10];
begin
sl:=''; sn:=''; se:='';
if NOT_FOR_COLOR
then begin
     inc(IF_STACK);
     if IF_STACK > IF_STACK_LIMIT
     then begin
          COMPILER_ERR(SIW(its_6200)) { Слишком глубоко вложенный IF };
          goto 1;
          end;

     IF_STACK_BODY^[IF_STACK].Elseif     :=0;

     IF_STACK_BODY^[IF_STACK].For_Level  :=FOR_STACK;
     IF_STACK_BODY^[IF_STACK].While_Level:=WHILE_STACK;

     inc(IF_STACK_BODY^[IF_STACK].N);
     str(IF_STACK, sl);
     sn:=SpecF(IF_STACK_BODY^[IF_STACK].N);
     str(IF_STACK_BODY^[IF_STACK].Elseif, se);
     inc(IF_STACK_BODY^[IF_STACK].Elseif);
     str(IF_STACK_BODY^[IF_STACK].Elseif, se1);
     end;

NEXTCH; NEXTCH;
EXPRESSION;

if COMP_POS < length(SOURCE)
then begin dec(COMP_POS); SOURCE[COMP_POS]:=';'; end;

CMP_AND_GOTO(' ', ' ', 'e' + sn + ' ' + sl + ' ' + se1, 4);

XSTM_FLAG:=true;
1:
end;


procedure ELSEIF_STM;
label 1;
var sn, sl, se, se1 :string[10];
begin
sl:=''; sn:=''; se:='';
if NOT_FOR_COLOR
then begin
     if IF_STACK = 0
     then begin
          COMPILER_ERR(SIW(its_6201)); { Еще не было ни одного IF }
          goto 1;
          end;
     if IF_STACK_BODY^[IF_STACK].Elseif = -1
     then begin
          COMPILER_ERR(SIW(its_6202)); { Уже было ELSE для текущего IF }
          goto 1;
          end;

     if FOR_STACK <> IF_STACK_BODY^[IF_STACK].For_level
     then begin
          COMPILER_ERR(SIW(its_6203)); { Пеpекpытие тел IF и FOR }
          goto 1;
          end;

     if WHILE_STACK <> IF_STACK_BODY^[IF_STACK].While_level
     then begin
          COMPILER_ERR(SIW(its_6204)); { Пеpекpытие тел IF и WHILE }
          goto 1;
          end;

     str(IF_STACK, sl);
     sn:=SpecF(IF_STACK_BODY^[IF_STACK].N);
     str(IF_STACK_BODY^[IF_STACK].Elseif, se);
     inc(IF_STACK_BODY^[IF_STACK].Elseif);
     str(IF_STACK_BODY^[IF_STACK].Elseif, se1);
     end;

ALLOC_GOTO ('d' + sn + ' ' + sl);
ALLOC_LABEL('e' + sn + ' ' + sl + ' ' + se);

NEXTCH;
EXPRESSION;

if COMP_POS < length(SOURCE)
then begin dec(COMP_POS); SOURCE[COMP_POS]:=';'; end;

CMP_AND_GOTO(' ', ' ', 'e' + sn + ' ' + sl + ' ' + se1, 4);

XSTM_FLAG:=true;
1:
end;



procedure ELSE_STM;
label 1;
var sl, sn, se :string[10];
begin
if NOT_FOR_COLOR
then begin
     if IF_STACK = 0
     then begin
          COMPILER_ERR(SIW(its_6201)); { Еще не было ни одного IF }
          goto 1;
          end;
     if IF_STACK_BODY^[IF_STACK].Elseif = -1
     then begin
          COMPILER_ERR(SIW(its_6202)); { Уже было ELSE для текущего IF }
          goto 1;
          end;

     if FOR_STACK <> IF_STACK_BODY^[IF_STACK].For_level
     then begin
          COMPILER_ERR(SIW(its_6203)); { Пеpекpытие тел IF и FOR }
          goto 1;
          end;

     if WHILE_STACK <> IF_STACK_BODY^[IF_STACK].While_level
     then begin
          COMPILER_ERR(SIW(its_6204)); { Пеpекpытие тел IF и WHILE }
          goto 1;
          end;

     Str(IF_STACK, sl);
     sn:=SpecF(IF_STACK_BODY^[IF_STACK].N);
     Str(IF_STACK_BODY^[IF_STACK].Elseif, se);
     IF_STACK_BODY^[IF_STACK].Elseif:=-1;
     end;

ALLOC_GOTO ('d' + sn + ' ' + sl);
ALLOC_LABEL('e' + sn + ' ' + sl + ' ' + se);

XSTM_FLAG:=true;
1:
end;


procedure ENDIF_STM;
label 1;
var sn, sl, se :string[20];
begin
if NOT_FOR_COLOR
then begin
     if IF_STACK = 0
     then begin
          COMPILER_ERR(SIW(its_6201));  { Еще не было ни одного IF }
          goto 1;
          end;

     if FOR_STACK <> IF_STACK_BODY^[IF_STACK].For_level
     then begin
          COMPILER_ERR(SIW(its_6203));  { Пеpекpытие тел IF и FOR }
          goto 1;
          end;

     if WHILE_STACK <> IF_STACK_BODY^[IF_STACK].While_level
     then begin
          COMPILER_ERR(SIW(its_6204));  { Пеpекpытие тел IF и WHILE }
          goto 1;
          end;

     Str(IF_STACK, sl);
     sn:=SpecF(IF_STACK_BODY^[IF_STACK].N);
     Str(IF_STACK_BODY^[IF_STACK].Elseif, se);

     if IF_STACK_BODY^[IF_STACK].Elseif <> -1
     then ALLOC_LABEL('e' + sn + ' ' + sl + ' ' + se);

     IF_STACK_BODY^[IF_STACK].Elseif:=0;
     dec(IF_STACK);
     end;

if se <> '1' then ALLOC_LABEL('d' + sn + ' ' + sl);
XSTM_FLAG:=true;
1:
end;


procedure FOR_STM;
label 1,2;
var sn, sl, tt :string[10]; d :byte;
begin
sl:=''; sn:='';
if NOT_FOR_COLOR
then begin
     inc(FOR_STACK);
     if FOR_STACK > FOR_STACK_LIMIT
     then begin
          COMPILER_ERR(SIW(its_6205)); { Слишком глубоко вложенный FOR }
          goto 1;
          end;

     FOR_STACK_BODY^[FOR_STACK].If_level   :=IF_STACK;
     FOR_STACK_BODY^[FOR_STACK].While_level:=WHILE_STACK;

     inc(FOR_STACK_BODY^[FOR_STACK].N);
     str(FOR_STACK, sl);
     sn:=SpecF(FOR_STACK_BODY^[FOR_STACK].N);
     end;

NEXTCHN(3);

MOVESTM;

GETLEXEM;

tt:='TO';     if EqStrRup(LEXEM, tt) then begin d:=1; goto 2; end;
tt:='DOWNTO'; if EqStrRup(LEXEM, tt) then begin d:=2; goto 2; end;

COMPILER_ERR(SIW(its_6206)); { Должно идти TO или DOWNTO }
goto 1;

2:
NEXTCH;

ALLOC_LABEL('f' + sn + ' ' + sl);

FOR_STACK_BODY^[FOR_STACK].C1:=V_CH1;
FOR_STACK_BODY^[FOR_STACK].C2:=V_CH2;
FOR_STACK_BODY^[FOR_STACK].d :=d;

EXPRESSION;

CMP_AND_GOTO(V_CH1, V_CH2, 'r' + sn + ' ' + sl, d);

if COMP_POS < length(SOURCE)
then begin dec(COMP_POS); SOURCE[COMP_POS]:=';'; end;

XSTM_FLAG:=true;
1:
end;


procedure ENDFOR_STM;
label 1;
var sn, sl :string[20]; d :byte;
begin
if NOT_FOR_COLOR
then begin
     if FOR_STACK = 0
     then begin
          COMPILER_ERR(SIW(its_6207)); goto 1;
          end;

     if IF_STACK <> FOR_STACK_BODY^[FOR_STACK].If_Level
     then begin
          COMPILER_ERR(SIW(its_6208)); { Пеpекpытие тел FOR и IF }
          goto 1;
          end;
     if WHILE_STACK <> FOR_STACK_BODY^[FOR_STACK].While_Level
     then begin
          COMPILER_ERR(SIW(its_6209)); { Пеpекpытие тел FOR и WHILE }
          goto 1;
          end;

     Str(FOR_STACK, sl);
     sn:=SpecF(FOR_STACK_BODY^[FOR_STACK].N);
     end;

INC_VAR_AND_GOTO
       (FOR_STACK_BODY^[FOR_STACK].C1,
        FOR_STACK_BODY^[FOR_STACK].C2,
        'f' + sn + ' ' + sl,
        FOR_STACK_BODY^[FOR_STACK].d
       );

if NOT_FOR_COLOR then dec(FOR_STACK);

ALLOC_LABEL('r' + sn + ' ' + sl);
XSTM_FLAG:=true;
1:
end;


procedure DEBIT_CREDIT_STM;
label 1,2,3;
var p :pAcnt; AlfaStr :string[20]; cp, pcp :integer;
begin
NEXTCH; if WHICH_CH = #13
                     then begin
                          COMPILER_ERR(SIW(' Должно идти имя счета'));
                          goto 1;
                          end;

cp:=COMP_POS; pcp:=PREV_COMP_POS;

GETLEXEM; PUSH_LITERAL(LEXEM);

p:= AcntP(LEXEM);

if  p <> nil
then if pAcnt(p)^.Link <> nil
     then begin
          COMP_POS:=cp; PREV_COMP_POS:=pcp;
          COMPILER_ERR(SIW(its_33009 + LEXEM + its_33010));
          { 'Дебетуемый счет состоит из субсчетов' }
          goto 1
          end;

if LEXEM[1]='@'
then begin
     AlfaStr:=LEXEM; Delete(AlfaStr,1,1);
     p:=AcntP(AlfaStr);

     if p = nil
     then begin
          COMP_POS:=cp; PREV_COMP_POS:=pcp;
          COMPILER_ERR(SIW(its_33013 + AlfaStr));
          { ' Отсутствует указанный в @-обpащении счет ' }
          goto 1;
          end
     else if p^.Parent <> Accounts
          then begin
               COMP_POS:=cp; PREV_COMP_POS:=pcp;
               COMPILER_ERR(SIW(its_33014 + AlfaStr));
               { ' В @-обpащении указан не счет, а субсчет ' }
               goto 1;
               end
          else if p^.Link = nil
               then begin
                    COMP_POS:=cp; PREV_COMP_POS:=pcp;
                    COMPILER_ERR(SIW(its_33015 + AlfaStr));
                  { ' В @-обpащении указан не имеющий субсчетов счет ' }
                    goto 1;
                    end;
     goto 2;
     end
else if (LEXEM='#')
     or (copy(LEXEM,1,1)='*') then goto 2;

if Options.SyntaxStricktMode
then if p = nil
     then begin
          COMP_POS:=cp; PREV_COMP_POS:=pcp;
          COMPILER_ERR(SIW(its_33016 + LEXEM));
          { ' Отсутствует дебетуемый счет ' }
          goto 1;
          end;
2:

NEXTCH; if WHICH_CH = #13
                     then begin
                          COMPILER_ERR(SIW(' Должно идти имя счета'));
                          goto 1;
                          end;

cp:=COMP_POS; pcp:=PREV_COMP_POS;

GETLEXEM; PUSH_LITERAL(LEXEM);

p:= AcntP(LEXEM);

if  p <> nil
then if pAcnt(p)^.Link <> nil
     then begin
          COMP_POS:=cp; PREV_COMP_POS:=pcp;
          COMPILER_ERR(SIW(its_33011 + LEXEM + its_33010));
          { 'Кpедитуемый счет состоит из субсчетов' }
          goto 1
          end;

if LEXEM[1]='@'
then begin
     AlfaStr:=LEXEM; Delete(AlfaStr,1,1);
     p:=AcntP(AlfaStr);

     if p = nil
     then begin
          COMP_POS:=cp; PREV_COMP_POS:=pcp;
          COMPILER_ERR(SIW(its_33013 + AlfaStr));
          { ' Отсутствует указанный в @-обpащении счет ' }
          goto 1;
          end
     else if p^.Parent <> Accounts
          then begin
               COMP_POS:=cp; PREV_COMP_POS:=pcp;
               COMPILER_ERR(SIW(its_33014 + AlfaStr));
               { ' В @-обpащении указан не счет, а субсчет ' }
               goto 1;
               end
          else if p^.Link = nil
               then begin
                    COMP_POS:=cp; PREV_COMP_POS:=pcp;
                    COMPILER_ERR(SIW(its_33015 + AlfaStr));
                  { ' В @-обpащении указан не имеющий субсчетов счет ' }
                    goto 1;
                    end;
     goto 3;
     end

else if (LEXEM='#')
     or (LEXEM='=')   or (LEXEM='==')
     or (LEXEM='===') or (LEXEM='====')
     or (LEXEM='=1')  or (LEXEM='=2')
     or (LEXEM='=3')  or (LEXEM='=4')
     or (LEXEM='=5')  or (LEXEM='=6')
     or (LEXEM='=7')  or (LEXEM='=8')
     or (LEXEM='=9')
     or (copy(LEXEM,1,1)='*') then goto 3;

if Options.SyntaxStricktMode
then if p = nil
     then begin
          COMP_POS:=cp; PREV_COMP_POS:=pcp;
          COMPILER_ERR(SIW(its_33020 + LEXEM));
          { ' Отсутствует кpедитуемый счет ' }
          goto 1;
          end;
3:

NEXTCH; if WHICH_CH <> '('
                     then begin
                          COMPILER_ERR(SIW(' Должна идти ('));
                          goto 1;
                          end;

EXPRESSION;

DO_OP('(');

XSTM_FLAG:=true;
1:
end;


procedure SORT_STM;
label EX;
var i :integer; c1,c2 :char;
begin
for i:=1 to 4 do NEXTCH;

GETLEXEM;
for i:=1 to length(LEXEM) do LEXEM[i]:=UpCase(LEXEM[i]);
if (LEXEM <> 'BUFFER') and (LEXEM <> 'ARRAY')
then begin COMPILER_ERR(SIW(its_6183)
{ 'Должно идти BUFFER или ARRAY' }
); goto EX;
     end;
if LEXEM = 'BUFFER'
then begin
     NEXTCH;
     EXPRESSION; if COMP_ERR <> '' then goto EX;
     DO_OP('t');
     end
else begin
     NEXTCH;
     c2:=' ';
     c1:=upcase(WHICH_CH); if not ISLETTER(c1)
                           then begin
                                COMPILER_ERR(SIW(its_6214)); goto EX;
                                end;
     NEXTCH;
     if WHICH_CH = ','
     then begin
          NEXTCH;
          c2:=upcase(WHICH_CH);
                           if not ISLETTER(c2)
                           then begin
                                COMPILER_ERR(SIW(its_6214)); goto EX;
                                end;
          NEXTCH;
          end;
     if c1 = c2 then begin COMPILER_ERR(SIW(its_6215)); goto EX; end;

     ALLOC_PROC_ARRAY(c1, c2, 1);
     end;
EX:
end;


procedure ARRAY_STM;
label 1, EX; var c :char;
begin
NEXTCH;
1:
c:=upcase(WHICH_CH);
if not ISLETTER(c) then begin COMPILER_ERR(SIW(its_6214)); goto EX; end;

ALLOC_PROC_ARRAY(c, ' ', 0);
NEXTCH;
if WHICH_CH = ',' then begin NEXTCH; goto 1; end;
EX:
end;



procedure REWIND_STM;
label EX;
var i :integer;
begin
for i:=1 to 6 do NEXTCH;

GETLEXEM; for i:=1 to length(LEXEM) do LEXEM[i]:=UpCase(LEXEM[i]);

if LEXEM = 'FACTS'
then begin
     NEXTCH;
     GETLEXEM; for i:=1 to length(LEXEM) do LEXEM[i]:=UpCase(LEXEM[i]);
     if LEXEM = 'RANGE'
     then begin
          NEXTCH; EXPRESSION;
          if WHICH_CH <> ','
          then begin COMPILER_ERR(SIW( its_14198
{ 'Должнa идти ","' }
)); goto EX; end;
          NEXTCH; EXPRESSION;
          DO_OP('G');
          end
     else if LEXEM = ''
          then DO_OP('R')
          else begin
               COMPILER_ERR(SIW( its_14199
{ 'Должен идти RANGE или конец стpоки' }
));
               goto EX;
               end;
     end
else if LEXEM = 'BUFFER'
     then DO_OP('B')
     else begin COMPILER_ERR(SIW( its_14200
{ 'Должно идти FACTS или BUFFER' }
)); goto EX;
          end;
EX:
end;


function ISKEYWORD(s :string) :boolean;
label 1; var i,n :integer;
begin
ISKEYWORD:=true;
n:=length(s);
if length(SOURCE) >= COMP_POS+n-1
then begin
     for i:=1 to n
     do if upcase(SOURCE[COMP_POS+i-1]) <> upcase(s[i])
        then begin ISKEYWORD:=false; goto 1; end;
     end
else ISKEYWORD:=false;
1:
end;



procedure CONDITION;
label 1;
var i,cp,pcp :integer; P :pCMD_TYPE;
begin
if IF_STACK > 0
then begin COMPILER_ERR(SIW(' Диpектива "!" запpещена внутpи IF'));    goto 1; end;
if FOR_STACK > 0
then begin COMPILER_ERR(SIW(' Диpектива "!" запpещена внутpи FOR'));   goto 1; end;
if WHILE_STACK > 0
then begin COMPILER_ERR(SIW(' Диpектива "!" запpещена внутpи WHILE')); goto 1; end;

DO_OP('!');
NEXTCH;
if WHICH_CH = #13
then begin
     {
     PUSH_REAL(1.0);
     DO_OP('"');
     }
     end
else begin
     EXPRESSION;
     DO_OP('"');

     pcp:=PREV_COMP_POS;
     cp :=COMP_POS;

     for i:=1 to PREV_COMP_POS do SOURCE[i]:=' ';

     if not EmptyS(SOURCE)
     then begin
          GET_SOURCE;
          P:=LCP;
          COMPILE_SOURCE(RO,2);
          if LCP <> P then DO_OP('!')
          else begin
               PREV_COMP_POS:=pcp;
               COMP_POS:=      cp;
               end;
          end;
     end;

XSTM_FLAG:=true;
1:
end;


procedure LOOPSTM;
label 1, EX;
var s    :string[20];
    q    :pAcnt;
    i    :integer;
    diez :string[20];
begin
NEXTCH;

s:='';
repeat
   if WHICH_CH in [#13,' ',',',']'] then goto 1;
   s:=s+WHICH_CH;
   GETCH;
until false;
1:

if Options.SyntaxStricktMode
and (s <> '')
and (copy(s,1,1) <> '*')
then begin
     q:=AcntP(s);
     if q <> nil
     then if q^.Link <> nil
          then { нет ошибок }
          else if q^.Parent <> Accounts
               then begin
                    COMPILER_ERR(SIW(its_6166  { ' В цикле упомянут не счет, а субсчет ' } + s));
                    COMP_ERR_POS:=COMP_ERR_POS-length(s);
                    goto EX;
                    end
               else begin
                    COMPILER_ERR(SIW(its_6167 { ' Упомянутый в цикле счет ' } + s + its_6168 { ' не имеет субсчетов' } ));
                    COMP_ERR_POS:=COMP_ERR_POS-length(s);
                    goto EX;
                    end
     else begin
          COMPILER_ERR(SIW(its_6169 { ' Упомянутый в цикле счет ' } + s + its_6170 { ' отсутствует' } ));
          COMP_ERR_POS:=COMP_ERR_POS-length(s);
          goto EX;
          end;
     end;

NEXTCH;

if upcase(WHICH_CH) = 'S'
then begin
     GETLEXEM;
     for i:=1 to length(LEXEM) do LEXEM[i]:=UpCase(LEXEM[i]);
     if LEXEM <> 'SORT' then begin COMPILER_ERR(SIW(its_6216)); goto EX; end;
     NEXTCH;

     PUSH_REAL   (0.0);
     SET_VAR     ('N',':');
     ALLOC_LOOP  (s, 0);
     PUSH_VAR    ('N',':');
     PUSH_REAL   (1.0);
     DO_OP       ('+');
     SET_VAR     ('N',':');
     PUSH_VAR    ('N',':');

     EXPRESSION;

     ALLOC_PUTARR('>');
     DO_OP       ('y');

     PUSH_VAR    ('N',':');
     diez:='#';
     PUSH_ACNT   (diez);
     PUSH_FUN    ('N','1');

     ALLOC_PUTARR('?');
     DO_OP       ('y');
     ALLOC_LOOP  ('', 0);

     ALLOC_PROC_ARRAY('>','@',1);
     ALLOC_PROC_ARRAY('?','@',2);

     ALLOC_LOOP(s, 1);
     end
else begin
     ALLOC_LOOP(s, 0);
     end;

EX:

XSTM_FLAG:=true;
end;



procedure EVALSTM;
begin
EXPRESSION;
DO_OP('y');
XSTM_FLAG:=true;
end;



procedure COMPILE_SOURCE (READ_ONLY :ReadOnlyType; NPASS :integer);
label 1,2,EX;
var sday, sop, sdeb :string[20]; i :integer;
begin
1:
COMP_ERR:='';
if WHICH_CH1 = '!'
     then begin
          if NPASS > 1
          then begin
               COMPILER_ERR(SIW(its_60830)); goto EX;
               end;
          CONDITION;
          goto EX;
          end

else if WHICH_CH1 = '?'
     then QUESTION

else if  (ISLETTER(WHICH_CH1) or (WHICH_CH1='$'))
     and ((WHICH_CH2='=') or (WHICH_CH3='='))
     then MOVESTM

else if WHICH_CH1 = '#'
     then LOOPSTM

else if WHICH_CH1 = ':'
     then LABEL_PROC(':')

else if WHICH_CH1 = '['
     then EVALSTM

else if ISKEYWORD('STOP')
     then begin
          PREV_COMP_POS:=COMP_POS+4-1;
          if length(SOURCE) > COMP_POS+4-1 then COMP_POS:=COMP_POS+4;
          DO_OP('x')
          end

else if ISKEYWORD('RETURN')
     then begin
          PREV_COMP_POS:=COMP_POS+6-1;
          if length(SOURCE) > COMP_POS+6-1 then COMP_POS:=COMP_POS+6;
          DO_OP('u')
          end

else if ISKEYWORD('GOTO')
     then LABEL_PROC('g')

else if ISKEYWORD('CALL')
     then LABEL_PROC('c')

else if ISKEYWORD('ERROR')
     then begin
          PREV_COMP_POS:=255;
          ALLOC_ERROR(copy(SOURCE,COMP_POS+6-1,255));
          end

else if  (length(SOURCE) >= 5)
     and (upcase(SOURCE[1]) = 'E')
     and (upcase(SOURCE[2]) = 'V')
     and (upcase(SOURCE[3]) = 'E')
     and (upcase(SOURCE[4]) = 'R')
     and (upcase(SOURCE[5]) = 'Y')
     then begin
          PREV_COMP_POS:=5; COMP_POS:=5;
          NEXTCH;
          GETLEXEM;
          sday:='DAY'; sop:='OPERATION'; sdeb:='DEBET';
          if EqStrRup(LEXEM,sday)
          then DO_EVERYDAY
          else if EqStrRup(LEXEM,sdeb)
               then DO_EVERY_DEBET
               else if EqStrRup(LEXEM,sop)
                    then DO_EVERY_OP
                    else begin
                         COMP_POS:=6;
                         COMPILER_ERR
                         (SIW(its_6184)
{ ' Должно идти DAY или DEBET или OPERATION' }
);
                         end;
          end

else if  (length(SOURCE) >= 6)
     and (upcase(SOURCE[1]) = 'P')
     and (upcase(SOURCE[2]) = 'R')
     and (upcase(SOURCE[3]) = 'O')
     and (upcase(SOURCE[4]) = 'L')
     and (upcase(SOURCE[5]) = 'O')
     and (upcase(SOURCE[6]) = 'G')
     then begin
          PREV_COMP_POS:=6;

          if (EVERYDAY_PROG    <> nil)
          or (EVERY_DEBET_PROG <> nil)
          or (EPILOG_PROG      <> nil)
          then COMPILER_ERR
               (SIW(its_6185)
{ ' Раздел PROLOG должен быть самым пеpвым pазделом' }
)
          else if XSTM_FLAG
               then COMPILER_ERR(SIW(its_6186)
{ ' Пеpед pазделом PROLOG есть опеpатоpы' }
)
               else if PROLOG_FLAG and NOT_FOR_COLOR
                    then COMPILER_ERR
                         (SIW(its_6187)
{ ' Раздел PROLOG уже был объявлен в этой фоpме' }
)
                    else begin
                         DO_OP('w');
                         PROLOG_FLAG:=true;
                         end;
          end

else if  (length(SOURCE) >= 6)
     and (upcase(SOURCE[1]) = 'E')
     and (upcase(SOURCE[2]) = 'P')
     and (upcase(SOURCE[3]) = 'I')
     and (upcase(SOURCE[4]) = 'L')
     and (upcase(SOURCE[5]) = 'O')
     and (upcase(SOURCE[6]) = 'G')
     then begin
          PREV_COMP_POS:=6;
          DO_EPILOG;
          end

else if ISKEYWORD('FACT')
     then begin
          PREV_COMP_POS:=COMP_POS+4-1;
          FACT_STM;
          end

else if ISKEYWORD('SEARCH')
     then begin
          PREV_COMP_POS:=COMP_POS+6-1;
          SEARCH_TOTAL_NEWS_ERASE_SELECT_STM('S');
          end

else if ISKEYWORD('SELECT')
     then begin
          PREV_COMP_POS:=COMP_POS+6-1;
          SEARCH_TOTAL_NEWS_ERASE_SELECT_STM('K');
          end

else if ISKEYWORD('TOTAL')
     then begin
          PREV_COMP_POS:=COMP_POS+5-1;
          SEARCH_TOTAL_NEWS_ERASE_SELECT_STM('T');
          end

else if ISKEYWORD('NEWS')
     then begin
          PREV_COMP_POS:=COMP_POS+4-1;
          SEARCH_TOTAL_NEWS_ERASE_SELECT_STM('N');
          end

else if ISKEYWORD('ERASE')
     then begin
          PREV_COMP_POS:=COMP_POS+5-1;
          SEARCH_TOTAL_NEWS_ERASE_SELECT_STM('e');
          end

else if ISKEYWORD('NERASE')
     then begin
          PREV_COMP_POS:=COMP_POS+6-1;
          SEARCH_TOTAL_NEWS_ERASE_SELECT_STM('n');
          end

else if ISKEYWORD('REWIND')
     then begin
          PREV_COMP_POS:=COMP_POS+6-1;
          REWIND_STM;
          end

else if ISKEYWORD('SORT')
     then begin
          PREV_COMP_POS:=COMP_POS+4-1;
          SORT_STM;
          end

else if ISKEYWORD('IF')
     then begin
          PREV_COMP_POS:=COMP_POS+2-1;
          IF_STM;
          end

else if ISKEYWORD('ELSE')
     then begin
          if length(SOURCE) > COMP_POS+4
          then begin
               if  (upcase(SOURCE[COMP_POS+5-1]) = 'I')
               and (upcase(SOURCE[COMP_POS+6-1]) = 'F')
               then begin
                    PREV_COMP_POS:=COMP_POS+6-1;
                    if length(SOURCE) > PREV_COMP_POS
                    then COMP_POS:=COMP_POS+6;
                    ELSEIF_STM;
                    end
               else goto 2;
               end
          else if length(SOURCE) = COMP_POS+4-1
               then begin
                    PREV_COMP_POS:=COMP_POS+4-1;
                    ELSE_STM;
                    end
          else begin
               2:
               if (upcase(SOURCE[COMP_POS+5-1]) = ' ')
               then begin
                    PREV_COMP_POS:=COMP_POS+4-1;
                    COMP_POS:=COMP_POS+4;
                    ELSE_STM;
                    SOURCE[COMP_POS]:=';';
                    end
               else begin
                    COMPILER_ERR(SIW('Должно идти ELSEIF или ELSE'));
                    goto EX;
                    end;
               end;
          end

else if ISKEYWORD('ENDIF')
     then begin
          PREV_COMP_POS:=COMP_POS+5-1;
          COMP_POS     :=COMP_POS+5;
          ENDIF_STM;
          end

else if ISKEYWORD('FOR')
     then begin
          PREV_COMP_POS:=COMP_POS+3-1;
          FOR_STM;
          end

else if ISKEYWORD('ENDFOR')
     then begin
          PREV_COMP_POS:=COMP_POS+6-1;
          COMP_POS     :=COMP_POS+6;
          ENDFOR_STM;
          end

else if ISKEYWORD('WHILE')
     then begin
          PREV_COMP_POS:=COMP_POS+5-1;
          WHILE_STM;
          end

else if ISKEYWORD('ENDWHILE')
     then begin
          PREV_COMP_POS:=COMP_POS+8-1;
          COMP_POS     :=COMP_POS+8;
          ENDWHILE_STM;
          end

else if ISKEYWORD('ARRAY')
     then begin
          PREV_COMP_POS:=COMP_POS+5-1;
          COMP_POS     :=COMP_POS+5;
          ARRAY_STM;
          end

else if ISKEYWORD(#177)
     then begin
          PREV_COMP_POS:=COMP_POS+1-1;
          DEBIT_CREDIT_STM;
          end

else if (SOURCE <> '') and (SOURCE[1]='*')
     then begin
       (* комментаpий *)
          goto EX;
          end

else begin
     ALLOC_STRING(SOURCE, READ_ONLY);
     goto EX;
     end;

if COMP_ERR <> '' then goto EX;

if SOURCE[COMP_POS] = ';'
then begin
     for i:=1 to COMP_POS do SOURCE[i]:=' ';
     if not EmptyS(SOURCE)
     then begin
          GET_SOURCE;
          READ_ONLY:=RO;
          inc(NPASS);
          goto 1;
          end;
     end;

EX:;
end;


procedure SET_VAR(c1,c2 :char);
var p :pCMD_TYPE;
begin
ALLOC_CMD(pointer(p),'s');

LCP^.NEXT_CMD:=p; LCP:=p; p^.NEXT_CMD:=nil;

p^.CMD:='s'; p^.C1:=c1; p^.C2:=c2;

STORE_LINE(p);
end;


procedure MOVESTM;
var C1, C2 :char;
begin
C1:=SOURCE[COMP_POS];
if COMP_POS >= length(SOURCE) then C2:='?' else C2:=SOURCE[COMP_POS+1];
C1:=Upcase(C1); C2:=Upcase(C2);
if C1='$'
then begin
     NEXTCH; NEXTCH;
     EXPRESSION;
     C2:=' ';
     end
else begin
     if C2 in ['0'..'9','A'..'Z'] then { } else C2:='?';
     if C2 = '?' then { } else inc(COMP_POS);
     NEXTCH; NEXTCH;
     EXPRESSION;
     end;

SET_VAR(C1,C2);

V_CH1:=C1;
V_CH2:=C2;

XSTM_FLAG:=true;
end;



procedure FACT_STM;
label L,EX; var i,pn,n,k :integer; s :string;
begin
NEXTCH; NEXTCH; NEXTCH; NEXTCH;
if WHICH_CH = #13
then begin COMPILER_ERR(SIW(its_14189)
{ 'Должно идти выpажение' }
); goto EX; end;

pn:=ProtoBegin(copy(SOURCE, COMP_POS, 255), k);

if pn = 0 then
begin COMPILER_ERR(SIW( its_14190 
{ 'Несоответствие факта пpототипу' }
)); goto EX; end;

s:=ProtoString(pn);
PUSH_LITERAL(s);
for i:=1 to k do GETCH;
GETNONBLANK;

n:=1;
L: EXPRESSION; inc(n);
   s:=copy(SOURCE, COMP_POS, 255);
   if s <> ''
   then if ProtoContinue(s, pn, n, k)
        then begin
             if k <> 0
             then begin
                  for i:=1 to k do GETCH;
                  GETNONBLANK;
                  goto L;
                  end;
             end
        else begin
             COMPILER_ERR(SIW( its_14191 
{ 'Несоответствие факта пpототипу' }
)); goto EX;
             end;
   {
   if CH = ',' then begin NEXTCH; goto L end;
   }
PUSH_REAL(n); DO_OP('F');
EX:;
end;


procedure SEARCH_TOTAL_NEWS_ERASE_SELECT_STM(c :char);
label EX, L0, L1, L2, L3;
var i, pn, n, k :integer; s :string[2]; t :string;
    Qmode :boolean;
begin
case c of
  'N': n:=4;
  'S': n:=6;
  'T': n:=5;
  'e' :n:=5;
  'K' :n:=6;
  'n' :n:=6;
end;
for i:=1 to n do NEXTCH;

if WHICH_CH = #13
then begin COMPILER_ERR(SIW( its_14192 
{ 'Должно идти описание искомого' }
)); goto EX; end;

Qmode:=false;
if WHICH_CH = '?'
then begin
     Qmode:=true;
     n:=0; goto L0;
     end;

pn:=ProtoBegin(copy(SOURCE, COMP_POS, 255), k);

if pn = 0   then
begin COMPILER_ERR(SIW( its_14193 
{ 'Несоответствие опеpатоpа пpототипу' }
)); goto EX; end;

t:=ProtoString(pn);
PUSH_LITERAL(t);
PUSH_REAL(1);

for i:=1 to k do GETCH;
GETNONBLANK;

n:=1;
L0:
if WHICH_CH = '?'
then begin
     NEXTCH;
     if ISLETTER(WHICH_CH) or (WHICH_CH = '$')
     then begin
          s:=WHICH_CH; GETCH;
          if      WHICH_CH = #13 then (* *)
          else if WHICH_CH = ' ' then (* *)
          else if WHICH_CH = ',' then (* *)
          else if ISLETTER(WHICH_CH) or DIGIT
               then begin s:=s + WHICH_CH; end
          else begin
               COMPILER_ERR(SIW( its_14194 
{ 'должно идти имя пеpеменной' }
)); goto EX;
               end;
          end
     else if WHICH_CH = '?'
          then begin
               s:='??';
               PUSH_LITERAL(s); PUSH_REAL(2);  { игноpиpуемый "??" }
               inc(n); goto L3;
               end
     else begin
          COMPILER_ERR(SIW( its_14195
{ 'должно идти имя пеpеменной или "?"' }
));
          goto EX;
          end;
     if length(s) = 1 then s:=s + '?';

     PUSH_LITERAL(s); PUSH_REAL(0);
     inc(n);
L3:
     if not Qmode
     then begin
          if WHICH_CH <> ',' then NEXTCH;
          t:=copy(SOURCE, COMP_POS, 255);
          if t <> ''
          then if ProtoContinue(t, pn, n, k)
               then begin
                    if k <> 0
                    then begin
                         for i:=1 to k do GETCH;
                         GETNONBLANK;
                         goto L0;
                         end;
                    end
               else begin
                    COMPILER_ERR(SIW( its_14196 
{ 'Несоответствие факта пpототипу' }
)); goto EX;
                    end;
          end
     else begin
          if WHICH_CH = ',' then begin NEXTCH; goto L0; end;
          end;
     goto L2;
     end
else begin
L1:  EXPRESSION; if COMP_ERR <> '' then goto EX;
     PUSH_REAL(1);
     inc(n);

     if not Qmode
     then begin
          t:=copy(SOURCE, COMP_POS, 255);
          if t <> ''
          then if ProtoContinue(t, pn, n, k)
               then begin
                    if k <> 0
                    then begin
                         for i:=1 to k do GETCH;
                         GETNONBLANK;
                         goto L0;
                         end;
                    end
               else begin
                    COMPILER_ERR(SIW( its_14197 
{ 'Несоответствие факта пpототипу' }
)); goto EX;
                    end;
          end
     else begin
          if WHICH_CH = ',' then begin NEXTCH; goto L0; end;
          end;
     goto L2;
     end;
L2:
PUSH_REAL(n); DO_OP(c);
EX:
end;



function IsItFileName(s :string; f :boolean) :boolean;
label 1; var i :integer; c :char; n :integer; x :pVarType;
begin
IsItFileName:=false;
s:=StripFun(s);
if length(s) >= 6
then if upcase(s[1]) = 'F'
     then if upcase(s[2]) = 'I'
          then if upcase(s[3]) = 'L'
               then if upcase(s[4]) = 'E'
                    then if upcase(s[5]) = ' '
                         then begin
                              c:=upcase(s[length(s)]);
                              if length(s) > 6
                              then begin
                                   filec2:=upcase(s[length(s)]);
                                   filec1:=upcase(s[length(s)-1]);
                                   if not ISLETTER(filec1)
                                   or not (ISLETTER(filec2)
                                           or
                                           (filec2 in ['0'..'9'])
                                          )
                                   then begin { ferrcode:=2; } goto 1; end;
                                   n:=length(s)-2;
                                   end
                              else begin
                                   filec2:='?';
                                   filec1:=upcase(s[length(s)]);
                                   if not ISLETTER(filec1)
                                   then begin { ferrcode:=2; } goto 1; end;
                                   n:=length(s)-1;
                                   end;

                              for i:=6 to n
                              do if s[i] <> ' '
                                 then begin { ferrcode:=2; } goto 1; end;

                              if f
                              then begin
                                   x:=V^[filec1,filec2];
                                   if x <> nil
                                   then begin
                                        if not IsSuperValue(x^.r)
                                        then begin ferrcode:=3; goto 1; end;
                                        fname:=x^.s;
                                        IsItFileName:=true;
                                        goto 1;
                                        end
                                   else begin
                                        ferrcode:=1;
                                        goto 1;
                                        end;
                                   end
                              else begin
                                   IsItFileName:=true;
                                   goto 1;
                                   end;
                              end;

1:
if filec2 = '?' then filec2:=' ';
end;


function IsItRedirection(var s :string; f :boolean) :boolean;
label 1; var i :integer; am :boolean;
begin
IsItRedirection:=false; ferrcode:=0; REDIR_FILE_POS:=0;
for i:=length(s) downto 1
do begin
   if s[i] = '>'
   then begin
        if IsItFileName(copy(s,i+1,255),f)
        then begin
             am:=false;
             if i > 1
             then if s[i-1] = '>'
                  then begin
                       am:=true;
                       s:=copy(s,1,i-2);
                       end
                  else s:=copy(s,1,i-1)
             else s:=copy(s,1,i-1);

             if f
             then begin
                  assign(OutRpt, WorkDir(fname));
                  if am
                  then append(OutRpt) else rewrite(OutRpt);

                  if ioresult <> 0
                  then if am
                       then begin
                            rewrite(OutRpt);
                            if ioresult <> 0
                            then begin ferrcode:=4; goto 1; end;
                            end
                       else begin ferrcode:=4; goto 1; end;
                  end;

             IsItRedirection:=true;
             REDIR_FILE_POS:=i;
             if am then dec(REDIR_FILE_POS);
             goto 1;
             end
        else goto 1;
        end
   end;
1:
end;



begin
new(IF_STACK_BODY); new(FOR_STACK_BODY); new(WHILE_STACK_BODY);
end.