svn/view/control.pas

unit control;
{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}

(***************************************)
(* Copyright (C) 2006, SHIRAISHI Kazuo *)
(***************************************)


{********}
interface
{********}
uses Classes,
   variabl,base2,struct,express;

type
   TForStructure=class(TStatement)
           controlVar:TSubstance;//TVariable;
           own1,own2 :TSubstance;//TVariable;
           Block     :TStatement;
           initial   :TPrincipal;
           limit     :TPrincipal;
           increment :TPrincipal;
           variable  :AnsiString;
        constructor create(prev,eld:TStatement);
        procedure CollectLabelInfo(t:TLabelNumberTable);override;
        //function SetBreakPoint(i:integer; b:boolean):boolean;override;
        destructor destroy;override;
        //procedure  exec;override;
        //procedure  execloop;
        function BlockCode(PreLabel,AfterLabel:TStringList; HaveEXLINE:boolean):AnsiString; override;
     private
        HaveExitFor:boolean;
        HaveExitForInWhen:boolean;
   end;

   TDoStructure=class(TStatement)
             cond1 : TLogical;
             until1: boolean;
             Block : TStatement;
        constructor create(prev,eld:TStatement);
        procedure CollectLabelInfo(t:TLabelNumberTable);override;
        //function SetBreakPoint(i:integer; b:boolean):boolean;override;
        destructor destroy;override;
        //procedure  exec;override;
        function BlockCode(PreLabel,AfterLabel:TStringList; HaveEXLINE:boolean):AnsiString; override;
     private
        HaveExitDo:boolean;
        HaveExitDoInWhen:boolean;
   end;

type
   TCustomIfStatement=class(TSTatement)
          condition   :TLogical;
          thenBlock   :TStatement;
          ElseBlock   :TStatement;
      constructor create(prev,eld:TStatement; cond1:TLogical);
      destructor destroy;override;
      //procedure  exec;override;
      function BlockCode(PreLabel,AfterLabel:TStringList; HaveEXLINE:boolean):AnsiString; override;
    end;


   TIfStructure=class(TCustomIfStatement)
          InitialLine:TStatement;
      constructor create(prev,eld:TStatement; cond1:TLogical; ini:TStatement);
      //procedure  exec;override;
      procedure CollectLabelInfo(t:TLabelNumberTable);override;
      //function SetBreakPoint(i:integer; b:boolean):boolean;override;
   end;

   TIfStatement=class(TCustomIfSTatement)
      constructor create(prev,eld:TStatement; cond1:TLogical);
      //procedure  exec;override;
   end;

   TSelect=class(TStatement)
             exp:TPrincipal;
             own:TSubstance;
             caseblock:TStatement;
             OwnToFree:boolean;
        constructor create(prev,eld:TStatement);
        procedure CollectLabelInfo(t:TLabelNumberTable);override;
        //function SetBreakPoint(i:integer; b:boolean):boolean;override;
        destructor destroy;override;
        //procedure exec;override;
        function BlockCode(Prelabel,Afterlabel:TStringList; HaveEXLINE:boolean):Ansistring;override;
   end;


function GOTOst(prev,eld:TStatement):TStatement;
function EXITst(prev,eld:TStatement):TStatement;
function STOPst(prev,eld:TStatement):TStatement;

{************}
implementation
{************}
uses SysUtils, Forms, Dialogs, Controls,
    base0,helpctex,base,texthand,optina,math2sub,sconsts,io;

{*****************}
{control Structure}
{*****************}

function GOTOst(prev,eld:TStatement):TStatement;
begin
    GOTOst:=TGOTO.create(prev,eld)
end;

{********}
{GOSUB st}
{********}

type
   TGOSUB=class(TGOTO)
      procedure FillInfo(LabelNumbertable:TLabelNumberTable);override;
      //procedure exec;override;
      function Code:ansistring;override;
    end;

procedure TGosub.FillInfo(LabelNumbertable:TLabelNumberTable);
begin
  inherited FillInfo(LabelNumbertable);

  next.haveBranchLabel:=true;
  if WhenBlock=nil then
         begin
           proc.ReturnLables.add(inttostr(Next.LabelNumb));
           proc.LabelsList.add(InttoStr(Next.LabelNumb));
         end
  else
         begin
           WhenBlock.ReturnLables.add(inttostr(Next.LabelNumb));
           proc.LabelsList.add(InttoStr(Next.LabelNumb));
         end;
end;

function GOSUBst(prev,eld:TStatement):TStatement;far;
begin
    GOSUBst:=TGOSUB.create(prev,eld)
end;

function GOst(prev,eld:TStatement):TStatement;far;
begin
    if token='SUB' then
       begin
          gettoken;
          GOst:=GOSUBst(prev,eld)
       end
    else
      begin
        checkToken1('TO',IDH_CONTROL);
        GOst:=GOTOst(prev,eld);
      end;
end;


{************}
{if structure}
{************}


constructor TCustomIfStatement.create(prev,eld:TStatement; cond1:TLogical);
begin
   inherited create(prev,eld);
   condition:=cond1;
end;

destructor TCustomIfStatement.destroy;
begin
    ElseBlock.free;
    thenblock.free;
    condition.free;
    inherited destroy
end;

procedure TIfStructure.CollectLabelInfo(t:TLabelNumberTable);
begin
   t.additem(self);
   if ThenBlock<>nil then ThenBlock.CollectLabelInfo(t);
   if ElseBlock<>nil then  ElseBlock.CollectLabelInfo(t);
   if next<>nil then next.CollectLabelInfo(t);
end;
(*
function TIfStructure.SetBreakPoint(i:integer; b:boolean):boolean;
begin
  if i=LineNumb then
     result:=changeStopKeySence(b)
  else
    result:=(ThenBlock<>nil) and ThenBlock.SetBreakPoint(i,b)
          or (ElseBlock<>nil) and ElseBlock.SetBreakPoint(i,b)
          or (next<>nil) and next.SetBreakPoint(i,b)
end;
*)

{*******}
{compile}
{*******}

function imperativest(prev,eld:TStatement):TStatement;
var
    prc:StatementFunction;
    sp:statementspec;
    p:TStatement;
begin
    result:=nil;

    if (token='IF')  and not permitMicrosoft and (AutoCorrect[ac_multi] or
       confirm(s_IFTHENCorrectConfirm,IDH_MicroSoft_CONTROL) ) then
           NestedIfStatement;

    if (token='END') then
       if permitMicrosoft then
          begin result:=STOPst(prev,eld);gettoken;exit end
       else if (AutoCorrect[ac_end] or
        confirm(s_ENDCorrectConfirm,IDH_MICROSOFT_CONTROL)) then
        begin
           replaceToken('STOP');
           raise ERecompile.create('');
        end;

    if statementTable.find(token,prc,sp)
       and ((sp=imperative) or permitMicrosoft and (sp=structural) )then
       begin
          gettoken;
          result:=prc(prev,eld);
       end
    else
       result:=tryLETst(prev,eld);

    if (result<>nil) and (permitMicrosoft) and (token=':') then
          begin
             gettoken;
             result.next:=imperativest(result,eld);
          end;

end;

{************}
{IF Statement}
{************}

function IFstSub(prev,eld,ini:TStatement; elseifst:boolean):TCustomIfStatement;forward;
function IFst(prev,eld:TStatement):TStatement;far;
begin
   IFline:=true;
   IFst:=IFstSub(prev,eld,nil,false)
end;

function IFstSub(prev,eld,ini:TStatement; elseifst:boolean):TCustomIfStatement;
var
  condition:TLogical;
begin
  condition:=relationalExpression;
  checkToken('THEN',IDH_IF);
  SaveToken(SvThenBlockPos);
  result:=nil;
  try
    if (tokenspec<>tail)
       and not(permitMicrosoft and (token=':'))
       and not elseifst then
         result:=TIfStatement.create(prev,eld,condition)
    else
         result:=TIfStructure.create(prev,eld,condition,ini)
  except
    result.free;
    raise
  end;
end;

constructor TIfStatement.create(prev,eld:TStatement; cond1:TLogical);
begin
    inherited create(prev,eld,cond1);
    if tokenspec=NRep then
        begin
          thenBlock:=TGOTO.create(self,nil);
          //if thenBlock<>nil then thenBlock.eldest:=thenBlock;
          if (token='ELSE') and (NextTokenSpec=Nrep) then
             begin
                 gettoken;
                 ElseBlock:=TGOTO.create(self,nil);
                 //if ElseBlock<>nil then ElseBlock.Eldest:=ElseBlock;
             end;
       end
    else
       begin
          thenBlock:=imperativest(self,nil);
          //SetEldest(thenBlock);
          if token='ELSE' then
             begin
                 gettoken;
                 ElseBlock:=imperativest(self,nil);
                 //setEldest(ElseBlock);
             end;
       end;
end;

constructor TIfStructure.create(prev,eld:TStatement; cond1:TLogical; ini:TStatement);
var
  p:TStatement;
begin
  inherited create(prev,eld,cond1);
  if ini<>nil then
     InitialLine:=ini
  else
     InitialLine:=self ;
  nextline;
  thenblock:=block(self);
  p:=Last(ThenBlock);
  if p is TTerminal then
     TTerminal(p).statement:=initialLine;
  if token='ELSEIF' then
     begin
         gettoken;
         ElseBlock:=IFstSub(self,nil,initialLine,true) ;
         //if ElseBlock<>nil then setEldest(ElseBlock);
      end
  else
      begin
         if token ='ELSE' then
            begin
               gettoken;
               nextline ;
               ElseBlock:=block(self);
               p:=last(ElseBlock);
               if p is TTerminal then
               TTerminal(p).statement:=initialLine;
            end;
         checktoken1('END',IDH_IF);
         checktoken('IF',IDH_IF);
      end;
end;

function ELSEst(prev,eld:TStatement):TStatement;far;
begin
   result:=TTerminal.create(prev,eld)
end;

{********}
{FOR NEXT}
{********}
type
   TNEXT=class(TStatement)
        controlVar,own1,own2:TSubstance;//TVariable;   {copy pointer,������������}
        HaveIncrement:boolean;
        //procedure  exec;override;
        function Code:Ansistring;override;
   end;

   TFNEXT=class(TNEXT)
        //procedure  exec;override;
   end;

   TFsimpleNEXT=class(TNEXT)
        //procedure  exec;override;
   end;

   TCNEXT=class(TNEXT)
        //procedure  exec;override;
   end;


procedure TForStructure.CollectLabelInfo(t:TLabelNumberTable);
begin
   t.additem(self);
   if Block<>nil then Block.CollectLabelInfo(t);
   if next<>nil then next.CollectLabelInfo(t);
end;
(*
function TForStructure.SetBreakPoint(i:integer; b:boolean):boolean;
begin
  if i=LineNumb then
     result:=changeStopKeySence(b)
  else
       result:=(Block<>nil) and Block.SetBreakPoint(i,b)
             or (next<>nil) and next.SetBreakPoint(i,b)
end;
*)

destructor TForStructure.destroy;
begin
   controlVar.free;
   initial.free;
   limit.free;
   increment.free;
   Block.free;
   //own1.free;
   //own2.free;
   inherited destroy
end;


function  FORst(prev,eld:TStatement):TStatement;far;
begin
   Forst:=TForStructure.create(prev,eld)
end;

procedure checkForVariable;
var
   i:integer;
begin
   with ForStack do
       for i:=0 to count-1 do
           if (TObject(items[i]) as TForStructure).variable=token then
              seterr(s_NestedSameVarFOR,IDH_FOR_NEXT);
end;

var
   SeqCounter:cardinal=0;
function Own1Name:string;
begin
   result:='_own1_'+Format('%5.5u',[SeqCounter]);
   inc(SeqCounter)
end;
function Own2Name:string;
begin
   result:='_own2_'+Format('%5.5u',[SeqCounter])
end;


constructor TForStructure.create(prev,eld:TStatement);
var
      p:TStatement;
      idrec:TIdRec;
begin
       inherited create(prev,eld);
       {inc(ForNest);}
       if ForStack.count>0 then CheckForVariable;
       ForStack.add(self);
       {control variable}
       variable:=token;
       controlVar:=simpleVariable;
       checktoken('=',IDH_FOR_NEXT);
       initial:=NExpression;
       checktoken('TO',IDH_FOR_NEXT);
       limit:=NExpression;
       if token='STEP' then
          begin
              gettoken;
              increment:=NEXpression
          end;
       nextline;

       if pass=2 then
          begin
             idrec:=TIdRec.initSimple(Own1Name,intern,maxint);
             own1:=idrec.subs;
             if ForNextBroadOwn then
                ProgramUnit.VarTable.add(idrec)
             else
                Proc.VarTable.add(idrec);        //2008.4.2
             idrec:=TIdRec.initSimple(Own2name,intern,maxint);
             own2:=idrec.subs;
             if ForNextBroadOwn then
                ProgramUnit.VarTable.add(idrec)
             else
                Proc.VarTable.add(idrec);        //2008.4.2
          end;

       Block:=struct.block(self);
       with ForStack do delete(count-1); {Dec(ForNest);}
       checktoken1('NEXT',IDH_FOR_NEXT);

      if token=variable then
          gettoken
      else
          if permitMicrosoft then
          else
           if (autocorrect[ac_next] or
              confirm(variable+s_IsExpected+s_InquireInsert,IDH_FOR_NEXT))
              and (token='') then
              inserttext(variable)
           else
             seterrExpected(variable,IDH_FOR_NEXT);
       p:=last(Block);
       if p is TNEXT then
          begin
               TNEXT(p).controlvar:=controlvar;
               TNEXT(p).own1:=own1;
               TNEXT(p).own2:=own2;
               TNext(p).HaveIncrement:=(Increment<>nil);
          end;

   if pass=2 then
      begin
        ControlVar.AddQueryInteger(Initial.QueryInteger);
        if increment<>nil then
             ControlVar.AddQueryInteger(Increment.QueryInteger);
        Own1.AddQueryInteger(Limit.QueryInteger);
        if Increment<>nil then
              Own2.AddQueryInteger(Increment.QueryInteger);
     end;
end;


function NEXTst(prev,eld:TStatement):TStatement;far;
begin
   if (ProgramUnit.arithmetic=PrecisionNative) then
      if (eld<>nil) and (eld.previous <> nil)
         and (eld.previous is TForStructure)              //2010.07.02
         and ((eld.previous as TForStructure).increment=nil) then
          NEXTst:=TFsimpleNEXT.create(prev,eld)
      else
          NEXTst:=TFNEXT.create(prev,eld)
   else if (ProgramUnit.arithmetic=PrecisionComplex) then
      NEXTst:=TCNEXT.create(prev,eld)
   else
      NEXTst:=TNEXT.create(prev,eld)
end;


{**********}
{ DO block }
{**********}
type
   TLOOP=class(TStatement)
          cond2:TLogical;
          while2:Boolean;
        constructor create(prev,eld:TStatement);
        destructor destroy;override;
        //procedure  exec;override;
        function Code:AnsiString;override;
    end;

destructor TDoStructure.destroy;
begin
    cond1.free;
    Block.free;
    inherited destroy;
end;

destructor TLOOP.destroy;
begin
    cond2.free;
    inherited destroy;
end;

procedure TDoStructure.CollectLabelInfo(t:TLabelNumberTable);
begin
   t.additem(self);
   if Block<>nil then Block.CollectLabelInfo(t);
   if next<>nil then next.CollectLabelInfo(t);
end;
(*
function TDoStructure.SetBreakPoint(i:integer; b:boolean):boolean;
begin
   if i=LineNumb then
     result:=changeStopKeySence(b)
   else
      result:=(block<>nil) and Block.SetBreakPoint(i,b)
         or (next<>nil) and Next.SetBreakPoint(i,b)
end;
*)

function DOst(prev,eld:TStatement):TStatement;far;
begin
    DOst:=TDOstructure.create(prev,eld)
end;

constructor TDoStructure.create(prev,eld:TStatement);
var
   dummy:TStatement;
begin
    inherited create(prev,eld);
    DoStack.add(self);
    if token='UNTIL' then
       begin
           gettoken;
           until1:=true;
           cond1:=relationalexpression
       end
     else if token='WHILE' then
       begin
           gettoken;
           until1:=false;
           cond1:=relationalexpression
       end;

    nextline;
    Block:=struct.block(self);
    with DoStack do delete(count-1); {dec(DoNest);}
    checkToken1('LOOP',IDH_DO_LOOP);
    {skip;}
    {95.5.20}   dummy:=TLOOP.create(self,eld);
                dummy.free;
end;

function LOOPst(prev,eld:TStatement):TStatement;far;
begin
    LOOPst:=TLOOP.create(prev,eld)
end;


constructor TLOOP.create(prev,eld:TStatement);
begin
    inherited create(prev,eld);
    if token='UNTIL' then
       begin
           gettoken;
           while2:=false;
           cond2:=relationalexpression
       end
     else if token='WHILE' then
       begin
           gettoken;
           while2:=true;
           cond2:=relationalexpression
       end;
end;

{***************}
{EXIT statements}
{***************}

type
   TEXITHandlerU=class(TStatement)
          whenBlock0:TWhenException;
        constructor create(prev,eld:TStatement);
        //procedure   exec;override;
        function code:ansistring;override;
   end;

constructor TEXITHandlerU.create(prev,eld:TStatement);
begin
  inherited create(prev,eld);
  with WhenUseStack do WhenBlock0:=items[count-1];
end;

type
   TEXITHandlerH=class(TStatement)
          handler:THandler;
        constructor create(prev,eld:TStatement);
        //procedure exec;override;
        function code:ansistring;override;
   end;

constructor TEXITHandlerH.create(prev,eld:TStatement);
begin
  inherited create(prev,eld);
  handler:=LocalRoutine as THandler;
end;

type
   TEXITDO=class(TStatement)
      statement:TStatement;
      TryInside:boolean;
     constructor create(prev,eld:TStatement);
     //procedure exec;override;
     function Code:AnsiString; override;
   end;

   TEXITDO1=class(TStatement)   //USE������������������������������������������
      statement:TStatement;
     constructor create(prev,eld:TStatement);
     //procedure exec;override;
     function Code:AnsiString; override;
   end;


constructor TEXITDO.create(prev,eld:TStatement);
var
  p:TStatement;
begin
  inherited create(prev,eld);
  p:=self;
  repeat
    if p.eldest=nil then
                   raise Exception.create('');
    p:=p.eldest.previous;
    if p is TWhenException then TryInside:=true;
  until p is TDoStructure;
  Statement:=p;

  //if (prev is TReadInput) then  // IF MISSING THEN EXIT DO
  //   TryInside:=true;
  if TryInside then
    (TStatement(Statement) as TDoStructure).haveExitDoInWhen:=true
  else
    (TStatement(Statement) as TDoStructure).haveExitDo:=true;
end;

constructor TEXITDO1.create(prev,eld:TStatement);
begin
  inherited create(prev,eld);
  with DoStack do Statement:=items[count-1];
  //  (TStatement(Statement) as TDoStructure).haveExitDo:=true;
  (TStatement(Statement) as TDoStructure).haveExitDoInWhen:=true;
end;

type
   TEXITFOR=class(TStatement)
      statement:TStatement;
      TryInside:boolean;
     constructor create(prev,eld:TStatement);
     //procedure exec;override;
     function Code:AnsiString; override;
   end;

   TEXITFOR1=class(TStatement)   //USE���������������������������������������������
      statement:TStatement;
     constructor create(prev,eld:TStatement);
     //procedure exec;override;
     function Code:AnsiString; override;
   end;

constructor TEXITFOR.create(prev,eld:TStatement);
var
  p:TStatement;
begin
  inherited create(prev,eld);
  p:=self;
  repeat
    p:=p.eldest.previous;
    if p is TWhenException then TryInside:=true;
  until p is TForStructure;
  Statement:=p;

  //if (prev is TReadInput) then  // IF MISSING THEN EXIT DO
  //   TryInside:=true;
  if TryInside then
    (TStatement(Statement) as TForStructure).haveExitForInWhen:=true
  else
    (TStatement(Statement) as TForStructure).haveExitFor:=true;
end;

constructor TEXITFOR1.create(prev,eld:TStatement);
begin
  inherited create(prev,eld);
  with FORStack do Statement:=items[count-1];
  //(TStatement(Statement) as TForStructure).haveExitFor:=true;
  (TStatement(Statement) as TForStructure).haveExitForInWhen:=true;
end;

function  EXITst(prev,eld:TStatement):TStatement;
var
  exitkind:integer;
begin
    EXITst:=nil;
    if (token='DO') and (DoStack.count>0) then
       try
           EXITst:=TEXITDO.create(prev,eld)
       except
           EXITst:=TEXITDO1.create(prev,eld)
       end
    else if (token='FOR') and (ForStack.count>0) then
       try
           EXITst:=TEXITFOR.create(prev,eld)
       except
           EXITst:=TEXITFOR1.create(prev,eld)
       end
    else if ((token='FUNCTION') or (token='SUB')
                                or (token='PICTURE')) then
            if (LocalRoutine<>nil) and (LocalRoutine.kind=token[1]) then
                 begin
                    LocalRoutine.HaveExitst:=true;
                    case token[1] of
                       'F':EXITst:=TEXIT.create(prev,eld,EExitFunction);
                       'S':EXITst:=TEXIT.create(prev,eld,EExitSub);
                       'P':EXITst:=TEXIT.create(prev,eld,EExitPicture);
                    end;
                 end
             else if (ProgramUnit.kind=token[1]) then
                 begin
                     ProgramUnit.HaveExitst:=true;
                     case token[1] of
                        'F':EXITst:=TEXIT.create(prev,eld,EExitFunction);
                        'S':EXITst:=TEXIT.create(prev,eld,EExitSub);
                        'P':EXITst:=TEXIT.create(prev,eld,EExitPicture);
                     end;
                 end
             else
    else if token='HANDLER' then
       if (LocalRoutine<>nil) and (LocalRoutine.kind=token[1]) then {Handler���}
          EXITst:=TEXITHandlerH.create(prev,eld)
       else if usenest>0 then
          EXITst:=TEXITHandlerU.create(prev,eld)
       else
        seterrIllegal('EXIT '+token,IDH_CAUSE)
    else
        seterrIllegal('EXIT '+token,IDH_DO_LOOP);
    gettoken;
end;

{*****}
{Cause}
{*****}

type
   TCause=class(TStatement)
          typ:integer;
        constructor create(prev,eld:TStatement; t:integer);
        //procedure  exec;override;
        function Code:Ansistring;override;
   end;

constructor TCause.create(prev,eld:TStatement; t:integer);
begin
   inherited create(prev,eld);
   typ:=t
end;


{***********}
{SELECT CASE}
{***********}

type
   TCase=class(TCustomIFstatement)
        constructor create(prev,eld:TStatement;idrec:TIdRec);
   end;


function caseitem(idrec:TIdrec):TLogical;forward;

function caselist(idrec:TIDRec):TLogical;
var
   list:TLogical;
begin
   list:=caseItem(idrec);
   while token=',' do
         begin
             gettoken;
             list:=TDisjunction.create(list,caseitem(idrec));
         end;
   caselist:=list
end;

function caseitem(idrec:TIdRec):TLogical;
var
   exp:TPrincipal;
   f:comparefunction;
   s:boolean;
begin
   caseitem:=nil;
   s:=false;
   if token='IS' then
      begin
          s:=true;
          gettoken;
          findcomparefunction(token,f);
          gettoken;
      end
   else
         f:=Equals;
   if idrec.kindchar='n' then
      exp:=NConstant
   else
      exp:=SConstant   ;
   if exp=nil then exit;
   if (token='TO') and not s then
      begin
      gettoken;
        if idrec.kindchar='n' then
           caseitem:=TConjunction.create(
                     TComparisonN.create(exp,idrec.subs,NotGreater),
                     TComparisonN.create(idrec.subs,NConstant,NotGreater))
        else
           caseitem:=TConjunction.create(
                     TComparisonS.create(exp,idrec.subs,NotGreater),
                     TComparisonS.create(idrec.subs ,SConstant,NotGreater))
      end
   else
      if idrec.kindchar='n' then
         caseitem:=TComparisonN.create(idrec.subs,exp,f)
      else
         caseitem:=TComparisonS.create(idrec.subs,exp,f)
end;

{***********}
{SELECT CASE}
{***********}


function SELECTst(prev,eld:TStatement):TStatement;far;
begin
   checktoken('CASE',IDH_SELECT);
   SELECTst:=TSelect.create(prev,eld)
end;

constructor TSelect.create(prev,eld:TStatement);
var
   name:string[15];
   condition:TLogical;
   idr:TIdRec;
begin
    inherited create(prev,eld);
    exp:=NSExpression;
    name:=Own1Name;
    if exp.kind='s' then name:=name+'$';

    idr:=TIdRec.initSimple(name,intern,maxint);
    own:=idr.subs;
    if pass=2 then
       begin
           ProgramUnit.VarTable.add(idr) ;
           Own.AddQueryInteger(exp.QueryInteger);
        end
    else
       OwnToFree:=true;


   nextline;
   checktoken1('CASE',IDH_SELECT);
   caseblock:=TCase.create(self,nil,idr);
   //SetEldest(CaseBlock);
    checktoken1('END',IDH_SELECT);
   checktoken('SELECT',IDH_SELECT);


end;


constructor TCASE.create(prev,eld:TStatement; idrec:TIdRec);
begin
   inherited create(prev,eld,caselist(idrec));
   nextline;
   thenblock:=block(self);
   if token='CASE' then
      begin
         gettoken;
         if token='ELSE' then
            begin
                gettoken;
                nextline;
                elseblock:=block(self)
            end
         else
            begin
             elseblock:=TCase.create(self,nil,idrec);
             //SetEldest(ElseBlock);
            end;
      end
   else
      begin
       elseblock:=TCause.create(self,nil,10004);  {END SELECT line}
      end;
end;

procedure TSelect.CollectLabelInfo(t:TLabelNumberTable);
begin
   t.additem(self);
   if caseBlock<>nil then CaseBlock.CollectLabelInfo(t);
   if next<>nil then next.CollectLabelInfo(t);
end;
(*
function TSelect.SetBreakPoint(i:integer; b:boolean):boolean;
begin
    if i=LineNumb then
       result:=changeStopKeySence(b)
    else
       result:=(CaseBlock<>nil) and CaseBlock.setBreakPoint(i,b)
            or (next<>nil) and next.setBreakPoint(i,b)
end;
*)


destructor TSelect.destroy;
begin
    exp.free;
    caseblock.free;
    //if pass=1 then
    if OwnToFree then
       own.idr.free;
    inherited destroy
end;


{*******}
{STOP st}
{*******}

function  STOPst(prev,eld:TStatement):TStatement;far;
begin
   STOPst:=TEXIT.create(prev,eld,EStop)
end;
{******}
{RETURN}
{******}

type
   TReturn=Class(TExit)
        function Code:AnsiString;override;
   end;

function  RETURNst(prev,eld:TStatement):TStatement;far;
begin
   RETURNst:=TRETURN.create(prev,eld,EReturn)
end;


{**************}
{RETRY CONTINUE}
{**************}

Type
   TRetry=Class(TExit)
        WhenBlock0:TWhenException;
        constructor create(prev,eld:TStatement; t:TControlException);
        function Code:AnsiString;override;
   end;

constructor TRetry.create(prev,eld:TStatement; t:TControlException);
begin
  inherited create(prev,eld,t);
   with WhenUseStack do WhenBlock0:=items[count-1];
  if WhenBlock0<>nil then
    begin
      WhenBlock0.HaveRetry:=true;
      proc.HaveRETRYst:=true;
    end
  else if (localRoutine<>nil) and (LocalRoutine is THandler) then
    (LocalRoutine as Thandler).HaveRetry:=true;
end;

Function RETRYst(prev,eld:TStatement):TStatement;far;
begin
   if usenest=0 then
      begin
          RETRYst:=nil;
          seterrillegal(prevtoken,IDH_WHEN_EXCEPTION)
      end
   else
      RETRYst:=TRETRY.create(prev,eld,ERetry)
end;

Type
   TContinue=Class(TExit)
        WhenBlock0:TWhenException ;
        constructor create(prev,eld:TStatement; t:TControlException);
        function Code:AnsiString;override;
   end;

constructor TContinue.create(prev,eld:TStatement; t:TControlException);
begin
  inherited create(prev,eld,t);
   with WhenUseStack do WhenBlock0:=items[count-1];
   if WhenBlock0<>nil then
    begin
        WhenBlock0.HaveContinue:=true;
        proc.HaveContinuest:=true;
    end
  else if (localRoutine<>nil) and (LocalRoutine is THandler) then
    (LocalRoutine as Thandler).HaveContinue:=true;

end;

Function CONTINUEst(prev,eld:TStatement):TStatement;far;
begin
   if usenest=0 then
      begin
          CONTINUEst:=nil;
          seterrillegal(prevtoken,IDH_WHEN_EXCEPTION)
      end
   else
   CONTINUEst:=TContinue.create(prev,eld,EContinue)
end;


{***************}
{CALL statement }
{***************}


function CALLst(prev,eld:TStatement):TStatement;far;
begin
    CALLst:=TCALL.create(prev,eld,'S');
end;

{***************}
{Cause Exception}
{***************}
type
TCauseException=class(TStatement)
   exp:TPrincipal;
   constructor create(prev,eld:TStatement);
   //procedure exec;override;
   destructor destroy;override;
   function Code:Ansistring;override;
end;

function CauseExceptionst(prev,eld:TStatement):Tstatement;
begin
   checkToken('EXCEPTION',IDH_WHEN);
   CauseExceptionst:=TCauseException.create(prev,eld);
end;

constructor TCauseException.create(prev,eld:TStatement);
begin
    inherited create(prev,eld);
    exp:=NExpression;
end;

destructor TCauseException.destroy;
begin
    exp.free;
    inherited destroy;
end;

{************}
{On statement}
{************}

type
   TON=class(TStatement)
      exp:TPrincipal;
      list:TList;
      elsest:TStatement;
      gosub:boolean;
    constructor create(prev,eld:TStatement);
    //procedure exec;    override;
    destructor destroy;override;
   function Code:Ansistring;override;
end;

function ONst(prev,eld:TStatement):TStatement;
begin
   ONst:=TON.create(prev,eld);
end;

constructor TON.create(prev,eld:TStatement);
var
   dummy:integer;
   p:TStatement;
begin
  inherited create(prev,eld);
  list:=TList.create;
  exp:=NExpression;
  if token='GO' then
     begin
        gettoken;
        if token='SUB' then
           begin
             gettoken;
             gosub:=true;
           end;
        checktoken1('TO',IDH_CONTROL);
     end
  else if token='GOSUB' then
     begin
        gettoken;
        gosub:=true;
     end
  else
    checkToken1('GOTO',IDH_CONTROL);

  repeat
       if gosub=false then
          p:=TGOTO.create(self,nil)
       else
          p:=TGOSUB.create(self,nil);
       //p.eldest:=p;
       dummy:=List.add(p)
  until test(',')=false;

  if token='ELSE' then
     begin
        gettoken;
        elsest:=imperativest(self,nil);
        if elsest<>nil then elsest.eldest:=elsest;
     end;
end;


destructor TON.destroy;
var
   i:integer;
begin
    exp.free;
    elsest.free;
    for i:=0 to list.count-1 do TObject(list.items[i]).free;
    list .free;
    inherited destroy;
end;

{*************}
{WHILE ...WEND}
{*************}

type
   TWHILE=class(TDoStructure)
        constructor create(prev,eld:TStatement);
  end;

function WHILEst(prev,eld:TStatement):TStatement;
begin
  if (token='1') and ((nexttoken='') or (nextToken=':')) then
     begin
        if permitMicrosoft then
           begin
              gettoken;
              whilest:=Dost(prev,eld);
           end
        else if autocorrect[ac_while] or
        confirm(s_ConfirmWHILE1toDO,IDH_MICROSOFT_CONTROL) then
          begin
             ReplacePrevToken('DO');
             ReplaceToken('');
             raise ERecompile.create('');
          end
        else
        seterr('',IDH_MICROSOFT_CONTROL)
     end
  else
     begin
       if permitMicrosoft then
           begin
              Whilest:=TWHILE.create(prev,eld);
           end
        else if autocorrect[ac_while] or
        confirm(s_ConfirmWHILEtoDOWHILE,IDH_MICROSOFT_CONTROL) then
          begin
              ReplacePrevToken('DO WHILE');
              raise ERecompile.create('');
          end
        else
          seterr('',IDH_MICROSOFT_CONTROL)
     end;

end;

function WENDst(prev,eld:TStatement):TStatement;
begin
    if permitMicrosoft then
        WENDst:=LOOPst(prev,eld)
    else if autocorrect[ac_while] or
    confirm(s_ConfirmWENDtoLOOP,IDH_MICROSOFT_CONTROL) then
      begin
       ReplacePrevToken('LOOP');
       raise ERecompile.create('');
      end
    else
       seterr('',IDH_MICROSOFT_CONTROL)
end;

constructor TWHILE.create(prev,eld:TStatement);
var
   dummy:TStatement;
begin
    inherited Tstatementcreate(prev,eld);
    DoStack.add(self);
    until1:=false;
    cond1:=relationalexpression;

    nextline;
    Block:=struct.block(self);
    with DoStack do delete(count-1); {dec(DoNest);}
    checkToken1('WEND',IDH_DO_LOOP);
    {skip;}
    {95.5.20}   dummy:=TLOOP.create(self,eld);
                dummy.free;
end;

{*********}
{RANDOMIZE}
{*********}

type
  TRandomize=class(TStatement)
        routine:TProgramUnit;
        exp:TPrincipal;
     constructor create(prev,eld:TStatement);
     //procedure exec;override;
     function Code:AnsiString;override;
  end;


function RANDOMIZEst(prev,eld:TStatement):TStatement;far;
begin
    RANDOMIZEst:=TRandomize.create(prev,eld)
end;

constructor TRandomize.create(prev,eld:TStatement);
begin
    inherited  create(prev,eld);
    routine:=programunit;
   if (tokenspec<>tail) and (token<>'ELSE') then
      exp:=NExpression;
end;

{****************}
{Execute Routines}
{****************}
(*
procedure TGOSUB.exec;
var
  svCurrentStatement,svNextStatement:TStatement;
begin
  if stacksize1>=StackLimit1 then
            setexception(stackoverflow);
  idle;

  svCurrentStatement:=CurrentStatement;
  svNextStatement:=NextStatement;
  try
     RunBlock(statement)
  except
     on EExtype do
        if Extype=10002 then
           begin
              extype:=0;
              CurrentStatement:=svCurrentStatement;
              NextStatement:=svNextStatement;
           end
        else
           raise;
  end;
end;

procedure TIfStatement.exec;
begin
     if condition.evalBool then
        ThenBlock.SequentiallyExecute
     else
        ElseBlock.SequentiallyExecute;
end;

procedure TIfStructure.exec;
begin
  if condition.evalBool then
     if ThenBlock<>nil then
        NextStatement:=ThenBlock
     else
        NextStatement:=InitialLine.next   //ExecutiveNext
  else
     if ELSEBlock<>nil then
        NextStatement:=ELSEBlock
     else
        NextStatement:=InitialLine.next   //ExecutiveNext;
end;

procedure TCustomIfStatement.exec;
begin
  if condition.evalBool then
     if ThenBlock<>nil then
        NextStatement:=ThenBlock
     else
        NextStatement:=ExecutiveNext
  else
     if ELSEBlock<>nil then
        NextStatement:=ELSEBlock
     else
        NextStatement:=ExecutiveNext;
end;

procedure TForStructure.exec;
begin
    own1.assign(limit) ;
    if (increment=nil) then
      own2.substone
    else
      own2.assign(increment) ;
    ControlVar.assign(initial);
    execloop ;
end;

procedure TForStructure.execloop;
begin
   if (ControlVar.compare(own1) * Own2.sign  <= 0) then
      NextStatement:=Block;
end;


procedure TNEXT.exec;
begin
    idle;
    ControlVar.add(Own2);
    if (ControlVar.compare(Own1) * Own2.sign <= 0) then
       NextStatement:=eldest
    else
       NextStatement:=eldest.previous.next;
end;

procedure TFNEXT.exec;
var
   p,q:PDouble;
begin
    idle;
    p:=TbasisFVar(ControlVar.ptr).GetPValue;
    q:=@(TorthoFVar(Own2.ptr).value);
    p^:=p^+q^;
    if (p^-TorthoFVar(Own1.ptr).value) * q^ <= 0 then
       NextStatement:=eldest
    else
       NextStatement:=eldest.previous.next;
end;

procedure TFsimpleNEXT.exec;
var
   p:PDouble;
begin
    idle;
    p:=TbasisFVar(ControlVar.ptr).GetPValue;
    p^:=p^+1;
    if (p^-TorthoFVar(Own1.ptr).value) <= 0 then
       NextStatement:=eldest
    else
       NextStatement:=eldest.previous.next;
end;

procedure TCNEXT.exec;
var
   p,q:PDouble;
begin
    idle;
    PComplex(p):=TbasisCVar(ControlVar.ptr).GetPValue;
    q:=@(TorthoCVar(Own2.ptr).value.x);
    p^:=p^+q^;
    if (p^-TorthoCVar(Own1.ptr).value.x) * q^ <= 0 then
       NextStatement:=eldest
    else
       NextStatement:=eldest.previous.next;
end;

procedure   TDoStructure.exec;
begin
    if ((cond1=nil) or  (cond1.evalbool xor until1)) then
       nextStatement:=Block ;
end;

procedure TLOOP.exec;
var
    s:boolean;
begin
    idle;
    if (cond2<>nil) and (cond2.evalbool xor while2)
       then NextStatement:=eldest.previous.next
    else
       NextStatement:=eldest.previous
end;

procedure TEXITHandlerU.exec;
begin
  with whenblock0 do
        extype:=svextype;
  raise EExitHandler.create(WhenBlock0);
end;

procedure TEXITHandlerH.exec;
var
    p:TWhenException;
begin
  with handler.WhenUseBlockStack do TObject(p):=items[count-1];
  with p do
        extype:=svextype;
  raise EExitHandler.create(p);
end;


procedure TEXITDO.exec;
begin
  NextStatement:=statement.next
end;

procedure TEXITDO1.exec;
begin
  raise EExitDo.create(statement.next)
end;

procedure TEXITFOR.exec;
begin
   NextStatement:=Statement.next
end;

procedure TEXITFOR1.exec;
begin
  raise EExitDo.create(statement.next)
end;

procedure TCause.exec;
begin
    setexception(typ);
end;

procedure TSelect.exec;
begin
   own.ptr.assign(exp);
   caseBlock.exec;
end;

procedure TCauseException.exec;
begin
   setexceptionwith('CAUSE EXCEPTION',exp.evalInteger);
end;


procedure TRandomize.exec;
begin
    if exp=nil then
       MyRandomize
    else
       MyRandomize2(exp.evalInteger)
end;
*)
(*
Procedure TON.exec;
var
  i:longint;
begin
  i:=exp.evalInteger;
  if (i>0) and (i<=list.count) then
         (TObject(list.items[i-1]) as TGOTO).exec
  else if elsest<>nil then
         elsest.exec
  else
         setexception(10001)
end;
*)
{*************}
{Generate Code}
{*************}


function TRandomize.code:ansistring;
begin
  if exp=nil then
     result:='MyRandoMize;'
  else
     result:='MyRandomize2('+exp.code+');'
end;

function TCustomIfStatement.Blockcode(Prelabel,AfterLabel:TstringList; HaveEXLINE:boolean):AnsiString;
begin
  result := 'if ' + condition.code + ' then' + EOL
          + ' begin' + EOL
          + thenblock.gencode(Prelabel,Afterlabel,haveEXLINE)
          + ' end'+EOL
          + ' else' + EOL
          + ' begin' + EOL
          + elseblock.gencode(Prelabel,Afterlabel,HaveEXLINE)
          + ' end;'
end;


function TForStructure.BlockCode(PreLabel,AfterLabel:TstringList; HaveEXLINE:boolean):AnsiString;
begin
  if increment<>nil then
        result:= own1.Code  + ' := '  + limit.Code +' ;' +EOL
               + own2.Code + ' := '   + increment.Code +' ;'+ EOL
               + ControlVar.Code + ' := ' + initial.Code +' ;' +EOL
               + 'while sign(' + ControlVar.Code + ' - ' + own1.Code
               +  ') * sign('  + own2.Code +')<=0 do begin' + EOL
               + block.gencode(PreLabel,AfterLabel,HaveEXLINE)

               + 'end;'

  else
        result:= own1.Code + ' := ' + limit.Code +' ;' +EOL
               + ControlVar.Code+ ' := ' + initial.Code +' ;' +EOL
               + 'while (' + ControlVar.Code + ' <= '  + own1.Code + ') do begin' + EOL
               + block.gencode(PreLabel,AfterLabel,HaveEXLINE)

               + 'end;';

  if HaveExitFor then
     result:=result
             +MakeLabel+':'+EOL;

  if HaveExitForInWhen then
     result:= 'try' + EOL
             + result + EOL
             + 'except' + EOL
             + ' on E:EExitFor do ;' +EOL
             + 'end;'

end;

function TNext.code:ansistring;
begin
  if HaveIncrement then
     result:= ControlVar.Code + ' := '+ ControlVar.Code +' + ' +own2.Code + ' ;'
  else
     result:= ControlVar.Code + ' := ' + ControlVar.Code +' + 1 ;' ;

  // TRACE
  if PUnit.haveTraceSt then
     begin
       result:=result + EOL +
       'if Trace' + IntToStr(PUNIT.LineNumb+1) + '<>nil then '+
       'Trace' + IntToStr(PUNIT.LineNumb+1) + '.PRINT([],rsNone, false ,['' ' +
       ControlVar.idr.name + '='' ,';
       if PUnit.Arithmetic=precisionComplex then
          result := result+ 'TComplex.create('+ControlVar.Code+')'
       else
          result := result + ControlVar.Code;
       result:=result+ ', TNewLine.create ]);' + EOL;
     end;
end;


function TDoStructure.BlockCode(PreLabel,AfterLabel:TStringList; HaveEXLINE:boolean):AnsiString;
var
   s:string;
begin
  if Cond1<>nil then
     begin
        s:=Cond1.Code;
        if until1 then s:= 'not( ' + s + ')';
        result:='while ' + s + ' do begin '+EOL
               + Block.GenCode(PreLabel,AfterLabel,HaveEXLINE)
               + 'end;' ;
     end
  else
     result := 'repeat' + EOL
             + Block.GenCode(PreLabel,AfterLabel,HaveEXLINE) ;

  if HaveExitDo then
     result:=result
             +MakeLabel+':'+EOL;

  if HaveExitDoInWhen then
     result:= 'try' + EOL
             + result
             + 'except' + EOL
             + ' on E:EExitDo do ;' +EOL
             + 'end;'


end;

function TLoop.Code:AnsiString;
var
   s:string;
begin
   if Cond2<>nil then
      begin
         s:=Cond2.Code;
         if while2 then s:='not( ' + s+ ')'
      end
    else
         s:='false'  ;

   if (TStatement(eldest.previous) as TDoStructure).Cond1<>nil then
      if  Cond2<>nil then
          result:='if ' + s + ' then break;' +EOL
      else
          result:=''
   else
      result:='until ' + s + ';'
end;


function TExitDo.Code:AnsiString;
begin
  if TryInside then
     result:='raise EExitDo.create;'
  else
     result:='goto '+(TStatement(Statement) as TDoStructure).MakeLabel +';'
end;

function TExitDo1.Code:AnsiString;
begin
//  if TryInside then
     result:='raise EExitDo.create;'
//  else
//     result:='goto '+(TStatement(Statement) as TDoStructure).MakeLabel +';'
end;

function TExitFor.Code:AnsiString;
begin
  if TryInside then
     result:='raise EExitFor.create;'
  else
     result:='goto '+(TStatement(Statement) as TForStructure).MakeLabel +';'
end;

function TExitFor1.Code:AnsiString;
begin
  //if TryInside then
     result:='raise EExitFor.create;'
  //else
  //   result:='goto '+(TStatement(Statement) as TForStructure).MakeLabel +';'
end;

function TSelect.BlockCode(PreLabel,AfterLabel:TStringList; HaveEXLINE:boolean):AnsiString;
begin
  result:=CaseBlock.GenCode(PreLabel,AfterLabel,HaveEXLINE);
  result:= own.Code  + ' := '  + exp.Code +' ;' +EOL
         + result;
end;

function TCause.Code:Ansistring;
begin
  result:= ' raise EExtype.create('+ strint(typ) +');' ;
end;

function TCauseException.Code:Ansistring;
begin
  result:= ' raise EExtype.create('+ exp.Code +');' ;
end;

function TEXITHandlerU.Code:Ansistring;
 begin
   result:=' ExCode:=ExCodeRec; raise;'
 end;

function TEXITHandlerH.Code:Ansistring;
 begin
   result:=' ExCode:=ExCodeRec; raise E;'
 end;

 function TOn.code:ansistring;
 var
    i:integer;
 begin
   if Gosub then
       raise ECodeNotYet.create(self)
   else
     begin
      result:='case System.Round('+ exp.code+') of'+EOL;
      for i:=1 to list.count do
        result:=result
              +inttostr(i)+':'+(TObject(list.items[i-1]) as TGOTO).code+EOL;
      if elsest<>nil then
         result:=result+elsest.code+EOL;
      result:=result+'end;'
     end;
 end;


function TGoSub.code:ansistring;
 begin
   result:='GosubStack.push('+ IntToStr(Next.LabelNumb)+'); goto '+IntToStr(Numb)+';'+EOL;
   proc.LabelsList.add(Inttostr(Numb));
 end;

function TReturn.Code:ansistring;
var
  i:integer;
  List:TStringList;
begin
  if WhenBlock=nil then
     List:=Proc.ReturnLables
  else
     List:=WhenBlock.ReturnLables;
  result:='case GosubStack.pop of'+EOL;
  with List do
   for i:=0 to count -1 do
      result:=result
            + Strings[i]+': goto '+Strings[i]+';'+EOL;
  result:=result
         +'end;'
end;


function TRetry.Code:ansistring;
begin
  result:='Retry:=ExLineNumb;'+EOL  ;
  if WhenBlock0=nil then   //in Handler
     result:=result
            +'Exit;'
  else
     result:=result
            +'goto h'+IntToStr(WhenBlock0.UseBlock.LineNumb)+';'
end;

function TContinue.Code:ansistring;
begin
  result:='Continue:=ExLineNumb;'+EOL;
  if WhenBlock0=nil then   //in Handler
     result:=result
            +'Exit;'
  else
     result:=result
            +'goto h'+IntToStr(WhenBlock0.UseBlock.LineNumb)+';'
end;


{**********}
{initialize}
{**********}
procedure statementTableinit;far;
begin
       statementTableinitStructural('FOR',FORst);
       statementTableinitTerminal  ('NEXT',NEXTst);
       statementTableinitStructural('DO',DOst);
       statementTableinitStructural('WHILE',WHILEst);
       statementTableinitTerminal  ('LOOP',LOOPst);
       //statementTableinitTerminal  ('WEND',WENDst);
       statementTableinitStructural('IF',IFst);
       statementTableinitTerminal  ('ELSE',ELSEst);
       statementTableinitTerminal  ('ELSEIF',ELSEst);
       statementTableinitStructural('SELECT',SELECTst);
       statementTableinitTerminal  ('CASE',ELSEst);
       statementTableinitImperative('EXIT',EXITst);
       statementTableinitImperative('CALL',CALLst);
       statementTableinitImperative('STOP',STOPst);
       statementTableinitImperative('RETRY',RETRYst);
       statementTableinitImperative('CONTINUE',CONTINUEst);
       statementTableinitImperative('GOTO',GOTOst);
       statementTableinitImperative('GO',GOst);
       statementTableinitImperative('GOSUB',GOSUBst);
       statementTableinitImperative('RETURN',RETURNst);
       statementTableinitImperative('CAUSE',CauseExceptionst);
       statementTableinitImperative('ON',ONst);
       StatementTableInitImperative('RANDOMIZE',RANDOMIZEst);

       SeqCounter:=0;
end;


begin
 tableInitProcs.accept(statementTableinit);
end.