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

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


{********}
interface
{********}
uses Classes, SysUtils, Forms, Dialogs, Controls,
   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;


type
  TSeize=class(TStatement)
             SeizeItems : TStringList;  //copy pointers of TSharedDef
             Name:string;
             TimeOut:TPrincipal;
             Block : TStatement;
        constructor create(prev,eld:TStatement);
        procedure CollectLabelInfo(t:TLabelNumberTable);override;
        destructor destroy;override;
        function BlockCode(Prelabel,Afterlabel:TStringList; HaveEXLINE:boolean):Ansistring;override;
        private
            HaveExitSeize:boolean;
   end;

type
  TNamedSeizeList=class(TStringList)
       constructor create;
       function declcode:ansistring;
       function initcode:ansistring;
       function finacode:ansistring;
  end;

var
  NamedSeizeList:TNamedSeizeList;
var
  CurrentSeizeBlock:TSeize;
  SeizeBlock:TSeize;


function GOTOst(prev,eld:TStatement):TStatement;
function EXITst(prev,eld:TStatement):TStatement;
function PARSTOPst(prev,eld:TStatement):TStatement;
function  STOPst(prev,eld:TStatement):TStatement;
{************}
implementation
{************}
uses
    base0,helpctex,base,texthand,math2sub,sconsts,io,compiler,statemen;

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

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

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

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

procedure TGosub.FillInfo(LabelNumbertable:TLabelNumberTable);
begin
  inherited FillInfo(LabelNumbertable);
  if next<>nil then next0:=next else next0:=previous.next;
  next0.haveBranchLabel:=true;
  if WhenBlock=nil then
         begin
           proc.ReturnLables.add(inttostr(next0.LabelNumb));
           proc.LabelsList.add(InttoStr(next0.LabelNumb));
         end
  else
         begin
           WhenBlock.ReturnLables.add(inttostr(next0.LabelNumb));
           proc.LabelsList.add(InttoStr(next0.LabelNumb));
         end;
end;

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

function GOst(prev,eld:TStatement):TStatement;
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;
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;
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;
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);
        Own1.AddQueryInteger(Initial.QueryInteger);
        Own1.AddQueryInteger(Limit.QueryInteger);
        if increment<>nil then
           begin
             ControlVar.AddQueryInteger(Increment.QueryInteger);
             Own1.AddQueryInteger(Increment.QueryInteger);
             Own2.AddQueryInteger(Increment.QueryInteger);
           end;
      end;
end;


function NEXTst(prev,eld:TStatement):TStatement;
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;
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;
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;

type
TEXITSEIZE=class(TStatement)
     constructor create(prev,eld:TStatement);
     function Code:AnsiString; override;
   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 if token='SEIZE' then
          EXITst:=TEXITSEIZE.create(prev,eld)
    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;
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;

{*******}
{ SEIZE }
{*******}


function SEIZEst(prev,eld:TStatement):TStatement;
 begin
     SEIZEst:=TSeize.create(prev,eld)
 end;

constructor TSeize.create(prev,eld:TStatement);
var
   SharedDef:TSharedDef;
begin
 if CurrentSeizeBlock<>nil then
    seterr(s_nestedSEIZE,IDH_PARACT);
 inherited create(prev,eld);
 CurrentSeizeBlock:=self;

 SeizeItems:=TstringList.create;
 with SeizeItems do
     begin
       sorted:=true;
       duplicates:=duperror;
     end;

 repeat
     if token='SHARED' then
        begin
           gettoken;
           try
              SharedDef:=ShareMessDefs.Objects[ShareMessDefs.IndexOf(token)] as TSharedDef;
           except
              seterr(token+s_notDeclaredShared,IDH_PARACT)
           end;
           try
              SeizeItems.AddObject(token,SharedDef);
            except
              seterr('',IDH_PARACT);
           end;
          gettoken;
        end
     else
         if name='' then
         begin
            name:=token;
            if pass=2 then
                with NamedSeizeList do if indexof(name)<0 then Add(name);
            gettoken;
         end;
 until test(',')=false;
 if token='TIMEOUT' then
    begin
       seterr(Token+s_NotAvailable,0);  //Not Available in current version.
       gettoken;
       TimeOut:=NExpression;
    end;

 nextline;
 Block:=struct.block(self);
 checktoken1('END',IDH_PARACT);
 checktoken('SEIZE',IDH_PARACT);
 CurrentSeizeBlock:=nil;
end;

destructor TSeize.destroy;
begin
   SeizeItems.free;
   TimeOut.free;
   Block.free;
   inherited destroy;
end;

  procedure TSeize.CollectLabelInfo(t:TLabelNumberTable);
  begin
      t.additem(self);
      if Block<>nil then Block.CollectLabelInfo(t);
  end;

 function TSeize.BlockCode(Prelabel,Afterlabel:TStringList; HaveEXLINE:boolean):Ansistring;
 var
    i:integer;
  begin
   SeizeBlock:=self;
   result:='';
   if name<>'' then
     result:=result
            +'EnterCriticalSection(Seize_'+Name+'_CriticalSection);'+EOL;
   for i:=0 to SeizeItems.count-1 do
     result:=result
           + 'EnterCriticalSection('+SeizeItems.strings[i]+'_CriticalSection);'+EOL;

   result := result
           + 'try'+EOL
           +  Block.GenCode(PreLabel,AfterLabel,HaveEXLINE)
           + 'finally'+EOL;

   for i:=SeizeItems.count-1 downto 0 do
      result:=result
            + '  LeaveCriticalSection('+SeizeItems.strings[i]+'_CriticalSection);'+EOL;
   if name<>'' then
      result:=result
            + '  LeaveCriticalSection(Seize_'+Name+'_CriticalSection);'+EOL;

   result:=result
            + 'end;'+EOL;
   SeizeBlock:=nil;
   if HaveExitSeize then
      result:= 'try'+EOL
             + result+EOL
             + 'except'+EOL
             + ' on E:EExitSeize do ;' +EOL
             + 'end;'
 end;

constructor TNamedSeizeList.create;
begin
    inherited create;
    duplicates:=dupIgnore;
end;

function TNamedSeizeList.declcode:ansistring;
var
     i:integer;
begin
    result:='';
    for i:=0 to count-1 do
    result:=result
      + 'var Seize_'+strings[i]+'_CriticalSection:TRTLCriticalSection;'+EOL;
end;
function TNamedSeizeList.initcode:ansistring;
var
   i:integer;
begin
  result:='';
  for i:=0 to count-1 do
  result:=result
     + '  InitCriticalSection( Seize_'+strings[i]+'_CriticalSection);'+EOL;
end;
function TNamedSeizeList.finacode:ansistring;
var
   i:integer;
begin
  result:='';
  for i:=0 to count-1 do
  result:=result
     + '  DoneCriticalSection( Seize_'+strings[i]+'_CriticalSection);'+EOL;
end;



constructor TEXITSEIZE.create(prev,eld:TStatement);
begin
    inherited create(prev,eld);
    if CurrentSeizeBlock<>nil then
       CurrentSeizeBlock.HaveExitSeize:=true
    else
       seterr('',IDH_Paract);
end;

function TExitSeize.code:ansistring;
begin
   result:='Raise EExitSeize.create;'
end;

{*******}
{STOP st}
{*******}
function  PARSTOPst(prev,eld:TStatement):TStatement;
begin
   PARSTOPst:=TEXIT.create(prev,eld,EParStop)
end;

type
   TSTOP=class(TStatement)
        function code:ansistring;override;
   end;


function TSTOP.code:ansistring;
begin
  result:='   StopRequest:=true; TThread.CurrentThread.suspend;'+EOL
end;

function  STOPst(prev,eld:TStatement):TStatement;
begin
   if ParactMain then
      STOPst:=TSTOP.create(prev,eld)
   else
      STOPst:=PARSTOPst(prev,eld)
end;


{******}
{RETURN}
{******}

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

function  RETURNst(prev,eld:TStatement):TStatement;
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;
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;
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;
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;
}

constructor TON.create(prev,eld:TStatement);
var
   dummy:integer;
   p:TGOTO;
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
      p:=TGOTO.create(self,nil) ;
      dummy:=List.add(p);
      if gosub then
         if labelnumb=0 then
               seterrExpected('ON GOSUB must have a line number. ',0)
         else if p.NUMB <labelnumb then
               seterr('ON GOSUB not implemented yet. ',0);
  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;
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;


{*************}
{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 if PUnit.Arithmetic=precisionNormal then
          result := result+ 'TNumber.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+'else'+EOL+'setexception(10001);'+EOL+'end;'
     end;
 end;
 }

 function TOn.code:ansistring;
 var
    i:integer;
 begin
   result:='';
  if GOSUB then
     begin
       {raise ECodeNotYet.create(self);}
       next.haveBranchLabel:=true;
       result:='GosubStack.push('+ IntToStr(Next.LabelNumb)+');'+EOL;
        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;

  result:=result+'case System.Round('+ exp.code+') of'+EOL;
  for i:=1 to list.count do
   begin
      result:=result
          +inttostr(i)+':'+(TObject(list.items[i-1]) as TGOTO).code+EOL;
   end;
  if elsest=nil then
     result:=result+'else'+EOL+'setexception(10001);'
  else
     result:=result+'else'+EOL+elsest.code;
  result:=result+EOL+'end;'

 end;

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

function TReturn.Code:ansistring;
var
  i:integer;
  List:TStringList;
  s:string;
begin
  if WhenBlock=nil then
     List:=Proc.ReturnLables
  else
     List:=WhenBlock.ReturnLables;
  result:='case GosubStack.pop of'+EOL;
  if List.count=0 then
     result:=result+'0:;'+EOL
  else
     with List do
      for i:=0 to count -1 do
        begin
          s:=Strings[i];
          if s='0' then SetErrOnLine(linenumb,'A Program having RETURN must have line numbers.',0);
          result:=result + s +': goto '+s+';'+EOL;
        end;
  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;

{*********}
{ START st}
{*********}
type
   TSTART=class(Tstatement)
           name:string;
       constructor create(prev,eld:TStatement);
       function Code:Ansistring;override;
    end;

 constructor TSTART.create(prev,eld:TStatement);
 begin
   inherited create(prev,eld);
   name:=token;
   gettoken;
end;

 function TSTART.Code:Ansistring;
 var
   ThName:string;
   i:integer;
 begin
    i:=ParactTbl.IndexOf(name);
    if i<0 then seterr('PARACT '+name+ s_NotFound, idh_Paract);
    ThName:='BASICThread'+STRINT(i);
    result:='  if not(('+Thname+'=nil) or '+Thname+'.finished) then setexception(12001);'+EOL
           +'  '+ThName + ' := TMyThread.Create('+'_'+ParactTbl.strings[i]+','
           +ThreadPriorityCode((ParactTbl.Objects[i] as TProgramUnit).urgency)
           +',SystemStackSize);'+EOL
           +'  '+ThName+'.start;'
 end;

 function STARTst(prev,eld:TStatement):TStatement;
begin
    STARTst:=TSTART.create(prev,eld)
end;

{**********}
{initialize}
{**********}
procedure statementTableinit;
begin
       statementTableinitStructural('FOR',FORst);
       statementTableinitTerminal  ('NEXT',NEXTst);
       statementTableinitStructural('DO',DOst);
       statementTableinitStructural('WHILE',WHILEst);
       statementTableinitTerminal  ('LOOP',LOOPst);
       statementTableinitStructural('IF',IFst);
       statementTableinitTerminal  ('ELSE',ELSEst);
       statementTableinitTerminal  ('ELSEIF',ELSEst);
       statementTableinitStructural('SELECT',SELECTst);
       statementTableinitTerminal  ('CASE',ELSEst);
       statementTableinitStructural('SEIZE',SEIZEst);
       statementTableinitImperative('EXIT',EXITst);
       statementTableinitImperative('CALL',CALLst);
       statementTableinitImperative('STOP',STOPst);
       statementTableinitImperative('PARSTOP',PARSTOPst);
       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);
       StatementTableInitImperative('START',STARTst);
       SeqCounter:=0;
end;


initialization
 tableInitProcs.accept(statementTableinit);
 NamedSeizeList:=TNamedSeizeList.create;

finalization
  NamedSeizeList.free;
end.
