{$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.