unit statemen;
{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}
(***************************************)
(* Copyright (C) 2006, SHIRAISHI Kazuo *)
(***************************************)


interface
uses Classes,SysUtils,
     base,base0,listcoll,struct;

Var
  ChainFile:string='';
var
  ChainParams:TStringList;

type
    TStructureDefs=class(TStringList)
        constructor Create;
        procedure clear;override;
        destructor destroy;override;
        function Code:Ansistring;
    end;
var
   StructureDefs:TStructureDefs;

type
    TShareMessDefs=class(TStringList)
        constructor Create;
        procedure clear;override;
        destructor destroy;override;
        function code:ansistring;
        function initcode:ansistring;
        function finacode:ansistring;
    end;
var
   ShareMessDefs:TShareMessDefs;

type
    TStructItem=Class(TCollectionItem)
        private
           kind:char;
           dim:shortint;
           size:integer;
        function VarTypeCode:ansistring;
        function ParTypeCode:ansistring;
    end;

    TStructure=Class(TCollection)
     private
        name:string;
       function code:Ansistring;
    end;

type
    TShareMessDef=class
       Name:string;
       Structure:TStructure;   //copy pointer, do not free.
      function code:ansistring;virtual;abstract;
      function initcode:ansistring;virtual;abstract;
      function finacode:ansistring;virtual;abstract;
    end;
type
    TSharedDef=class(TShareMessDef)
        dim:integer;
        lbound,ubound:array4;
        function code:ansistring;override;
        function initcode:ansistring;override;
        function finacode:ansistring;override;
    end;
type
    TMessageDef=class(TShareMessDef)
       function code:ansistring;override;
       function initcode:ansistring;override;
       function finacode:ansistring;override;
     end;

type
   tpProcessOutIn=(ProcOut,ProcIn{,ProcEvent});
type
    TProcessDef=class(TSharedDef)
         ProcessOutIn:set of tpProcessOutIn;
         AccessInfo:TStringList;
       constructor create;
       destructor destroy;override;
       function code:ansistring;override;
       //function initcode:ansistring;override;
       //function finacode:ansistring;override;
    end;

function  GETst(prev,eld:TStatement):TStatement;

type
    TPROGRAM=class(TStatement)
          params:TListCollection;
          ProgramName:string;            //paract BASICのための変更
        constructor create(prev,eld:TStatement);
        //procedure exec;override;
        destructor destroy;override;
        function Code:AnsiString;override;
    end;
 // 2004.1.7修正
var PROGRAMStatement:TPROGRAM = nil;

implementation
uses
      variabl,express,
      helpctex,arithmet,
      texthand,control,mat,sconsts,format;


{*************}
{DIM statement}
{*************}

function NewId(const nam:AnsiString):boolean;
var
  index: integer;
begin
   if (localRoutine<>nil) and
           Localroutine.VarTable.search(nam,index)
    or (LocalRoutine=nil) and
           ( ProgramUnit.Vartable.search(nam,index)
             or ProgramUnit.ExternalVarTable.search2('',nam,index) )
    or (ProgramUnit is TModule)
            and (ProgramUnit as TModule).ShareVarTable.search(nam,index) then
         seterr(s_DuplicatedIdetifier + nam,IDH_ARRAY);
    newId:=not reservedword(nam);
end;

function NewId2(const mnam,nam:AnsiString):boolean;
var
  index: integer;
begin
  NewId2:=false;
  if mnam='' then
     NewId2:=NewId(nam)
  else if ProgramUnit.ExternalVarTable.search2(mnam,nam,index) then
             seterr(s_DuplicatedIdetifier + nam,IDH_ARRAY)
       else
             newid2:=true;
end;


procedure setSubscriptRangeErr;
begin
   seterr(s_SubscriptRange,IDH_ARRAY)
end;

type
    TDIM=class(TStatement)
          mat:TMatrix;
          lb,ub:array[1..4] of TPrincipal;
          optionbase:shortint;
          Imperative:boolean;
          another: TDIM;
        constructor create(prev,eld:TStatement);
        destructor destroy;override;
        //procedure exec;override;
        function Code:AnsiString;override;
        function TraceCode:Ansistring;override;
      end;


function DIMst(prev,eld:TStatement):TStatement;
begin
   DIMst:=TDIM.create(prev,eld)
end;

constructor TDIM.create(prev,eld:TStatement);
var
    nam:AnsiString;
    i,d:integer;
    lbound,ubound:Array4;
    s:boolean;
begin
    inherited  create(prev,eld);

    if (programunit.optionbase=ApNone) and (base0.initialOptionbase=0) then
       begin
         insertline(LineNumber,'OPTION BASE 0');
         raise ERecompile.create('');
       end;

    optionbase:=programunit.ArrayBase;

    if pass=1 then
        nam:=getidentifier
    else
       mat:=matrix;
    check('(',IDH_ARRAY);
    d:=0;
    repeat
      inc(d);
      ub[d]:=nexpression;
      if token='TO' then
         begin
            gettoken;
            lb[d]:=ub[d];
            ub[d]:=nil;   //   2012.2.26
            ub[d]:=nexpression;
         end
      else
          ProgramUnit.DimAppeared:=true;
    until (d=4) or (test(',')=false) ;
    check(')',IDH_ARRAY);

    for i:=1 to 4 do lbound[i]:=optionbase;
    for i:=1 to 4 do ubound[i]:=lbound[i] - 1 ; //2000.2.7

    s:=true;
    for i:=1 to d do
        s:=s and ((lb[i]=nil) or lb[i].isConstant)
             and  ub[i].isConstant;

    if s then
       try
         for i:=1 to d do
             begin
                 if lb[i]<>nil then
                        lbound[i]:=lb[i].evalLongInt
                 else
                        lbound[i]:=programunit.ArrayBase;
                 ubound[i]:=ub[i].evalLongInt;
             end
       except
          seterr(s_SubscriptRange,IDH_JIS_7)
       end
    else if JISDim then
           seterr(s_DimParameter,COMPATIBILITY_OPTION)
         //else if LocalRoutine<>nil then
         //  seterr(s_ImperativeDIM,IDH_IMPERATIVE_DIM)
         else
           Imperative:=true;

    if imperative and (LocalRoutine<>nil) then                //2008.2.11
          seterr(s_DimParameter,IDH_IMPERATIVE_DIM) ;

    if pass=1 then
       if newId(nam) then
          programUnit.Vartable.add(TIdRec.initArray(nam,d,lbound,ubound,intern,maxint)) ;

    if token=',' then
       begin
           gettoken;
           another:=TDIM.create(self,nil)
       end;
end;

destructor TDIM.destroy;
var
   i:integer;
begin
    //mat.free;
    for i:=1 to 4 do
       begin
          lb[i].free;
          ub[i].free;
       end;
    another.free;
    inherited destroy;
end;
(*
procedure TDIM.exec;
var
   i:integer;
   lbound,ubound,size:array3;
   s,results:boolean;
begin
  if Imperative then
    begin
       for i:=1 to mat.idr.dim do
           try
               ubound[i]:=ub[i].evalLongInt;;
               if lb[i]<>nil then
                   lbound[i]:=lb[i].evalLongInt;
               else
                   lbound[i]:=optionbase;
           except
               on EInvalidOp do SetException(2001);        
           end;
       s:=true;
       calcsize(mat.idr.dim,lbound,ubound,size);
       for i:=1 to mat.idr.dim do
           s:=s and (lbound[i]=TArray(mat.point).lbound[i])
                and (size[i]=TArray(mat.point).size[i]);
       if s then
          //results:=true
       else
          TArray(mat.point).redim0(lbound,ubound);
    end;
  if another<>nil then another.exec
end;
*)
function TDIM.Code:ansistring;
var
   i:integer;
begin
  result:='';
  if imperative then
     begin
       result:=mat.Code+'.dim(';
       for i:=1 to mat.idr.dim do
         begin
           if i>1 then result:=result+',';
           if lb[i]<>nil then
              result:=result+lb[i].code+','+ub[i].code
           else
              result:=result+inttostr(optionbase)+','+ub[i].code;
         end;
       result:=result+');';
     end;
  if another<>nil then
     result:=result+another.code
end;

function TDIM.TraceCode:ansistring;
begin
   if imperative then
      result:=inherited TraceCode
   else
      result:=''
end;

{**********}
{DECLARE st}
{**********}


procedure DeclareNS(VarTable:TIdTable; sp:SetOfTokenSpec; IdTag:TIdTag);
var
    nam:AnsiString;
    i,d:integer;
    lbound,ubound:Array4;
    c1,c2:integer;
    optionbase:integer;
    n:number;
    maxlen0:integer;
    maxlen:integer;
begin
  optionbase:=programunit.ArrayBase;


  maxlen0:=maxint;
  MaxLenDeclaration(sp,maxlen0);
  {
  if (sp=[SIdf]) and (token='*') then
     begin
          gettoken;
          NumericConstant(n);
          maxlen0:=IntegerVal(n,c1);
          if c1>0 then maxlen0:=maxint;
     end;
  }
  repeat
    if not (tokenspec in sp) then seterr('',IDH_DECLARE);
    nam:=getidentifier;
    d:=0;
    if token='(' then
        begin
           gettoken;
           for i:=1 to 4 do lbound[i]:=optionbase;
           for i:=1 to 4 do ubound[i]:=lbound[i];
           c1:=0;
           c2:=0;
           repeat
             NumericConstant(n);
             inc(d);
             ubound[d]:=IntegerVal(n,c1);
             if token='TO' then
                begin
                   gettoken;
                   NumericConstant(n);
                   lbound[d]:=ubound[d];
                   ubound[d]:=IntegerVal(n,c2);
                end
             else
                ProgramUnit.DimAppeared:=true;
             if (c1<>0) or (c2<>0) then setSubscriptRangeErr;
           until (d=4) or (test(',')=false) ;
           check(')',IDH_DECLARE);
        end;
    maxlen:=maxlen0;
    MaxLenDeclaration(sp,maxlen);
    {
    if (sp=[SIdf]) and (token='*') then
       begin
          gettoken;
          NumericConstant(n);
          maxlen:=IntegerVal(n,c1);
          if c1>0 then maxlen:=maxint;
       end;
     }
    if pass=1 then
      if newId(nam) then
         if d>0 then
            Vartable.add(TIdRec.initArray(nam,d,lbound,ubound,IdTag,maxlen))
         else
            Vartable.add(TIdRec.initSimple(nam,IdTag,maxlen));

  until test(',')=false;
end;

procedure DeclareExternalNS(VarTable:TIdTable; sp:SetOfTokenSpec);
var
    nam,mnam:AnsiString;
    d:integer;
    idr:TIdRec;
    module1:TModule;
    index1:integer;
    token1:string;
begin
  repeat

    if not (tokenspec in sp) then seterr('',IDH_MODULE);

    token1:=token;
    mnam:=modifier(token);
    if (mnam='') and (ProgramUnit.kind=#0)  then
         seterr(s_ModifiedIdentifierExpected,IDH_MODULE);
    nam:=identifier(token);
    gettoken;
    d:=0;

    if token='(' then
        begin
           gettoken;
           repeat
             inc(d);
           until (d=4) or (test(',')=false) ;
           check(')',IDH_ARRAY);

           if pass=1 then
              if newId2(mnam,nam) then
                 VarTable.add(TIdRec.initAExt(mnam,nam,d))     ;
        end
    else
        begin
            if pass=1 then
               if newID2(mnam,nam) then
                     Vartable.add(TIdRec.initSimpleExt(mnam,nam));
        end;

    if pass=2 then
      begin
        module1:=module(mnam);
        if (module1<>nil) and module1.ShareVarTable.search(nam,index1) then
           begin
              Idr:=TIdRec(module1.ShareVartable.items[index1]);
              if (idr=nil) or (idr.tag<>idPublic) then
                 seterr(SysUtils.Format(s_NotPublicDeclaredIn,[mnam,nam]),IDH_MODULE);
              if idr.dim<>d then
                 seterr(SysUtils.Format(s_ModuleDimemsion,[mnam,nam,strint(idr.dim)]),IDH_MODULE);
              if (prevtokenspec=Nidf) and (module1.arithmetic<>programunit.arithmetic) then
                 seterr(s_DisAgreeArithmetic,IDH_MODULE);
           end
        else
                 seterr(token1+s_IsNotFound,IDH_MODULE);

      end;

  until test(',')=false;
end;

procedure DeclareRoutine(VarTable:TIdTable; idtag:TIdTag; kind:char);
var
    nam,mnam:AnsiString;
    index:integer;
    idr:TIdrec;
    module1:TModule;
begin
       repeat
          mnam:=modifier(token);
          if (idtag<>extern) and (mnam<>'') then
             seterr('',IDH_MODULE);
          nam:=identifier(token);
          gettoken;

          case pass of
           1:
               if idtag=extern then
                  if (Kind='F') or (mnam<>'')
                     or ForceSubPictDeclare and (Kind in ['S','P']) then   //2013.12.7
                       if NewId2(mnam,nam) then
                          Vartable.add(TIdRec.initF(mnam,nam,extern))
                       else
                  else
               else if (kind='F')
                   or ForceSubPictDeclare and (Kind in ['S','P'])then    //2013.12.7
                    if newId(nam) then
                      if newId(nam) then
                          if idtag=intern then                        //2007.3.30
                             Vartable.add(TIdRec.initF('',nam,idtag)) //2007.3.30
                          else                                        //2007.3.30
                             Vartable.add(TIdRec.initF(Curmodule.name,nam,idtag))
                       else
                     else   ;

           2:
             if kind='F' then
               case IdTag of
                extern:
                  if (mnam<>'') then
                    begin
                      module1:=module(mnam);
                      if (module1<>nil) and module1.ShareVarTable.search(nam,index)         //2013.12.16
                        and (TIdRec(module1.ShareVarTable.items[index]).tag=IdPublic) then
                        else
                           seterr(mnam+'.'+nam+s_IsNotPublicDeclared,IDH_MODULE)
                   end ;
                idShare,idPublic:
                    if (prevtokenspec=NIdf) and VarTable.search(nam,index) then
                       begin
                           idr:=TIdrec(VarTable.items[index]);
                           if (getroutine(idr,'F') as TProgramUnit).arithmetic
                                  <>CurModule.Arithmetic then
                                        seterr(s_DisAgreeArithmetic,IDH_MODULE);
                       end;
               end;
          end;

       until test(',')=false;
end;

{*********}
{STRUCTURE}
{*********}

 function TStructItem.VarTypeCode:ansistring;
 begin
   case kind of
     'N':
       case mainprogram.Arithmetic of
         PrecisionNative:
           result:='double';
         PrecisionComplex:
           result:='Complex';
         PrecisionNormal:
           result:='Number';
       end;
     'S':  result:='string';
   end;
   if dim>0 then
     result:='array[0..'+inttostr(size-1)+'] of '+result;
 end;

 function TStructItem.ParTypeCode:ansistring;
 begin
   if dim=0 then
     case kind of
       'N':
         case mainprogram.Arithmetic of
           PrecisionNative:
             result:='double';
           PrecisionComplex:
             result:='Complex';
           PrecisionNormal:
             result:='Number';
         end;
       'S':  result:='string';
     end
   else
   if dim>0 then
     case kind of
       'N':
         case mainprogram.Arithmetic of
           PrecisionNative:
             result:='TArray'+inttostr(dim)+'N';
           PrecisionComplex:
             result:='TArray'+inttostr(dim)+'C';
           PrecisionNormal:
             result:='TArray'+inttostr(dim)+'D';
         end;
       'S':  result:='TArray'+inttostr(dim)+'S';
     end;
 end;

 function TStructure.code:ansistring;
 var
     i:integer;
     StructName,vars,params,subst:string;
begin
  StructName:='Struct_'+Name;
  vars:='';
  for i:=0 to count-1 do
    begin
       vars:=vars
             +'   v'+IntToStr(i)+':'+(items[i] as TStructItem).VarTypeCode+';'+EOL;
    end;

  params:='';
   for i:=0 to count-1 do
    begin
      params:=params
        +'p'+inttostr(i)+':'+(items[i] as TStructItem).ParTypeCode;
      if i<count-1 then
        params:=params+';'
    end;

  subst:='';
  for i:=0 to count-1 do
   begin
     if (items[i] as TStructItem).dim=0 then
       subst:=subst+'   v'+IntToStr(i)+':='+'p'+inttostr(i)+';'+EOL
     else
       subst:=subst+'      p'+inttostr(i)+'.WriteTo(@v'+IntToStr(i)+','
                      +inttostr((items[i] as TStructItem).size)+');'+EOL;
   end;
  result:=
   'type '+StructName+ '=object(TMyStruct)'+EOL
   + Vars
   + '  procedure read('+params+');'+EOL
   + 'end;'+EOL
   + 'procedure '+StructName+'.read('+params+');'+EOL
   + 'begin'+EOL
   + subst
   + 'end;'+EOL
   +EOL
end;


 Constructor  TStructureDefs.create;
 begin
   inherited create;
   sorted:=true;
   Duplicates:=DupError;
 end;

 procedure TStructureDefs.clear;
 var
     i:integer;
begin
  for i:=0 to count-1 do
    (Objects[i] as TStructure).free;
  inherited clear;
end;

 destructor TStructureDefs.destroy;
 var
     i:integer;
begin
  for i:=0 to count-1 do
    (Objects[i] as TStructure).free;
  inherited destroy;
end;

function TStructureDefs.code:ansistring;
var
   i:integer;
begin
   result:='';
   for i:=0 to count -1 do
      result:=result
      +(Objects[i] as TStructure).code;
end;



procedure DeclStructure;
var
   StructName:string;
   Structure:TStructure;
   StructItem:TStructItem;
   i,c:longint;
   optionbase:shortint;
   d:shortint;
   lbound,ubound,TotalSize:longint;
   k:string;
begin
   if tokenspec=NIdf then
      begin
        StructName:=token;
        gettoken;
      end
   else
      seterrexpected( s_Identifier,IDH_PARACT);
  checktoken(':',IDH_PARACT);

  Structure:=TStructure.Create(TStructItem);
  Structure.name:=StructName;

  repeat
      if NonNegativeIntegralNumber(c) then
         checkToken('OF',IDH_PARACT)
        else c:=1;

        optionbase:=1; //programunit.ArrayBase;
        k:=getidentifier;
        if (k='NUMERIC') or (k='STRING') then
        else
           seterrExpected('NUMERIC or STRING', IDH_PARACT);

        d:=0;
        TotalSize:=1;
        if token='(' then
           begin
              gettoken;
              repeat
                inc(d);
                lbound:=optionbase;
                NonNegativeIntegralNumber(ubound);
                if token='TO' then
                   begin
                      gettoken;
                      lbound:=ubound;
                      NonNegativeIntegralNumber(ubound);
                   end;
                TotalSize:=TotalSize*(ubound-lbound+1);
             until (d=4) or (test(',')=false) ;
             check(')',IDH_ARRAY);
           end;
        for i:=1 to c do
          begin
              StructItem:=TStructItem.Create(Structure);
              with StructItem do
                 begin
                   kind:=k[1];
                   dim:=d;
                   size:=TotalSize;
                 end;
          end;
   until test(',')=false;
   if pass=1 then
      StructureDefs.AddObject(StructName,Structure)
   else
      Structure.free;
end;

{****************}
{SHARED & MESSAGE}
{****************}


 Constructor TShareMessDefs.create;
 begin
   inherited create;
   sorted:=true;
   Duplicates:=DupError;
 end;

 procedure TShareMessDefs.clear;
 var
     i:integer;
begin
  for i:=0 to count-1 do
    (Objects[i] as TShareMessDef).free;
  inherited clear;
end;

 destructor TShareMessDefs.destroy;
 var
     i:integer;
begin
  for i:=0 to count-1 do
    (Objects[i] as TShareMessDef).free;
  inherited destroy;
end;

 function TShareMessDefs.code:ansistring;
  var
    i:integer;
  begin
    result:='';
    for i:=0 to count-1 do
       result:=result+(Objects[i] as TShareMessDef).code;
  end;

 function TMessageDef.code:ansistring;
  begin
   result:=
        'var '+'Mess_'+Name+':'+'Struct_'+structure.name+';'+EOL
       +'var '+name+'_CriticalSection: TRTLCriticalSection;'+EOL
       +'var Send'+name+'_CriticalSection: TRTLCriticalSection;'+EOL;
 end;

 function TSharedDef.code:ansistring;
 var
  indices:string;
  i:integer;
 begin
   indices:='';
   for i:=1 to dim do
        indices:=indices+'Array['+inttostr(lbound[i])+'..'+inttostr(ubound[i])+'] of ';

   result:=
        'var '+'Shared_'+name+':'+ indices+'Struct_'+structure.name+';'+EOL
       +'var '+name+'_CriticalSection: TRTLCriticalSection;'+EOL

 end;

 function TShareMessDefs.initcode:ansistring;
 var
    i:integer;
 begin
   result:='';
   for i:=0 to count-1 do
     result:=result
     + (Objects[i] as TShareMessDef).initcode;
 end;

 function TShareMessDefs.finacode:ansistring;
 var
    i:integer;
 begin
   result:='';
   for i:=0 to count-1 do
     result:=result
     + (Objects[i] as TShareMessDef).finacode;
 end;

 function TMessageDef.initcode:ansistring;
 begin
   result:='  '+'Mess_'+name+'.valid:=false;'+EOL
          +'  InitCriticalSection('+name+'_CriticalSection);'+EOL
          +'  InitCriticalSection( Send'+name+'_CriticalSection);'+EOL;
  end;

 function TSharedDef.initcode:ansistring;
 begin
   result:='  InitCriticalSection('+name+'_CriticalSection);'+EOL
  end;

  function TMessageDef.finacode:ansistring;
 begin
   result:='  DoneCriticalSection('+name+'_CriticalSection);'+EOL
          +'  DoneCriticalSection( Send'+name+'_CriticalSection);'+EOL;
  end;

 function TSharedDef.finacode:ansistring;
 begin
   result:='  DoneCriticalSection('+name+'_CriticalSection);'+EOL
  end;

{***********}
{TProcessDef}
{***********}

 constructor TProcessDef.create;
 begin
   inherited create;
   AccessInfo:=TStringList.create;
 end;

 destructor TProcessDef.destroy;
 begin
   AccessInfo.free;
   inherited destroy;
 end;

function TProcessDef.code:ansistring;
 var
  indices:string;
  i:integer;
 begin
   indices:='';
   for i:=1 to dim do
        indices:=indices+'Array['+inttostr(lbound[i])+'..'+inttostr(ubound[i])+'] of ';

   result:=
        'var '+name+':'+ indices+'Struct_'+structure.name+';'+EOL
       +'var '+name+'_CriticalSection: TRTLCriticalSection;'+EOL

 end;
//function TProcessDef.initcode:ansistring;
//function TProcessDef.finacode:ansistring;


{******}
{SHARED}
{******}

procedure DeclShared;
var
   ShareName:string;
   Structname:string;
   d,optionbase:integer;
   Lbound,Ubound:Array4;
   SharedDef:TSharedDef;
   Structure:TStructure;
begin
   if tokenspec=NIdf then
      begin
        ShareName:=token;
        gettoken;
      end
   else
      seterrexpected( s_Identifier,IDH_PARACT);

   d:=0;
   optionbase:=1;
   if token='(' then
     begin
        gettoken;
        repeat
          inc(d);
          lbound[d]:=optionbase;
          NonNegativeIntegralNumber(ubound[d]);
          if token='TO' then
             begin
                gettoken;
                lbound[d]:=ubound[d];
                NonNegativeIntegralNumber(ubound[d]);
             end;
         until (d=4) or (test(',')=false) ;
        check(')',IDH_ARRAY);
     end;

     CheckToken('OF',IDH_PARACT);
     StructName:=token;
     gettoken;

     SharedDef:=TSharedDef.create;
     SharedDef.name:=ShareName;
     SharedDef.dim:=d;
     SharedDef.ubound:=ubound;
     SharedDef.lbound:=lbound;
     try
        SharedDef.structure:=StructureDefs.Objects[StructureDefs.IndexOf(StructName)] as TStructure;
     except
        seterr(StructName+s_notfound,IDH_PARACT)
     end;
   if pass=1 then
     try
       ShareMessDefs.AddObject(ShareName,SharedDef)
     except
       seterr(ShareName+s_Dup,IDH_PARACT)
     end
   else
      SharedDef.free;
end;

{*******}
{PROCESS}
{*******}

procedure DeclProcess;
var
   ProcessName:string;
   Structname:string;
   d,optionbase:integer;
   Lbound,Ubound:Array4;
   ProcessDef:TProcessDef;
   Structure:TStructure;
   ProcOutIn:set of tpProcessOutIn;
   i,j,k:integer;
   n:Number;
   c:integer;
const zero:Array4=(0,0,0,0);
begin
   LBound:=zero;
   UBound:=zero;

   if token='INPUT' then
     ProcOutIn:=[ProcIn]
   else if token='OUTPUT' then
     ProcOutIn:=[ProcOut]
   else if token='OUTIN' then
     ProcOutIn:=[ProcIn,ProcOut]
   else if token='EVENT' then
   //
   else
     seterr('',IDH_Paract);
   gettoken;

   if tokenspec=NIdf then
      begin
        ProcessName:=token;
        gettoken;
      end
   else
      seterrexpected( s_Identifier,IDH_PARACT);



   d:=0;
   optionbase:=1;
   if token='(' then
     begin
        gettoken;
        repeat
          inc(d);
          lbound[d]:=optionbase;
          NonNegativeIntegralNumber(ubound[d]);
          if token='TO' then
             begin
                gettoken;
                lbound[d]:=ubound[d];
                NonNegativeIntegralNumber(ubound[d]);
             end;
         until (d=4) or (test(',')=false) ;
        check(')',IDH_ARRAY);
     end;

     CheckToken('OF',IDH_PARACT);
     StructName:=token;
     gettoken;

     ProcessDef:=TProcessDef.create;
     ProcessDef.name:=ProcessName;
     ProcessDef.dim:=d;
     ProcessDef.ubound:=ubound;
     ProcessDef.lbound:=lbound;
     if (d=0) and (token<>'') then
       begin
           if pass=1 then ProcessDEf.AccessInfo.Add(token);
           Gettoken;
       end;
     try
        ProcessDef.structure:=StructureDefs.Objects[StructureDefs.IndexOf(StructName)] as TStructure;
     except
        seterr(StructName+s_notfound,IDH_PARACT)
     end;

   if pass=1 then
     try
       ShareMessDefs.AddObject(ProcessName,ProcessDef)
     except
       seterr(ProcessName+s_Dup,IDH_PARACT)
     end
   else
      ProcessDef.free;

   if d=0 then exit;
   if d>=1 then
     begin
       for i:=LBound[1] to UBound[1] do
         for j:=Lbound[2] to Ubound[2] do
           for k:=Lbound[3] to Ubound[3] do
              begin
                nextline;
                CheckToken(ProcessName,IDH_Paract);
                CheckToken('(',IDH_Paract);
                NumericConstant(n);
                if Longintval(n,c)<>i then seterrExpected(strint(i),IDH_Paract);
                if d>=2 then
                  begin
                    CheckToken(',',IDH_Paract);
                    NumericConstant(n);
                    if Longintval(n,c)<>j then seterrExpected(strint(i),IDH_Paract);
                  end;
                if d>=3 then
                  begin
                    CheckToken(',',IDH_Paract);
                    NumericConstant(n);
                    if Longintval(n,c)<>k then seterrExpected(strint(i),IDH_Paract);
                  end;
                checkToken(')',IDH_Paract);
                checkToken(':',IDH_Paract);
                if pass=1 then ProcessDEf.AccessInfo.Add(token);
                gettoken;
              end;
       nextline;
       checkToken('END',IDH_PARACT);
       checkToken('PROCESS',Idh_Paract);
     end;
end;

{**********}
{ MESSAGE  }
{**********}

type
    TMessageDefs=class(TStringList)
        constructor Create;
        destructor destroy;override;
    end;

 Constructor TMessageDefs.create;
 begin
   inherited create;
   sorted:=true;
   Duplicates:=DupError;
 end;

 destructor TMessageDefs.destroy;
 var
     i:integer;
begin
  for i:=0 to count-1 do
    (Objects[i] as TMessageDef).free;
  inherited destroy;
end;


procedure DeclMessage;
var
   MessName:string;
   Structname:string;
   d,optionbase:integer;
   MessageDef:TMessageDef;
   Structure:TStructure;
begin
   if tokenspec=NIdf then
      begin
        MessName:=token;
        gettoken;
      end
   else
      seterrexpected( s_Identifier,IDH_PARACT);

     CheckToken('OF',IDH_PARACT);
     StructName:=token;
     gettoken;

     MessageDef:=TMessageDef.create;
     with MessageDef do
           begin
             name:=Messname;
             //dim:=0;
             //size:=ubound;
             try
                  structure:=StructureDefs.Objects[StructureDefs.IndexOf(StructName)] as TStructure;
             except
                  seterr(StructName+s_notfound,IDH_PARACT)
             end;
           end;
   if pass=1 then
      try
         ShareMessDefs.AddObject(MessName,MessageDef)
      except
       seterr(MessName+s_Dup,IDH_PARACT)
     end
   else
      MessageDef.free;
end;

{*********}
{ DECLARE }
{*********}

function DECLAREst(prev,eld:TStatement):TStatement;
var
   idtag:TIdTag;
begin
  DECLAREst:=LabelStatement(prev,eld);

  if token='STRUCTURE' then
     begin
       gettoken;
       DeclStructure;
       exit
     end;
   if token='SHARED' then
     begin
       gettoken;
       DeclShared;
       exit
     end;
  if token='MESSAGE' then
     begin
       gettoken;
       DeclMessage;
       exit
     end;
   if token='PROCESS' then
     begin
       gettoken;
       DeclProcess;
       exit
     end;                     ;

  idtag:=intern;
  if token='EXTERNAL' then
     begin
          idtag:=extern;
          gettoken;
     end;

  if token='NUMERIC' then
     begin
         gettoken;
         if IdTag=Extern then
            DeclareExternalNS(ProgramUnit.ExternalVartable, [NIdf])
         else
            DeclareNS(ProgramUnit.Vartable, [NIdf],IdTag);
     end
  else if token='STRING' then
     begin
         gettoken;
         if IdTag=Extern then
            DeclareExternalNS(ProgramUnit.ExternalVartable, [SIdf])
         else
         DeclareNS(ProgramUnit.Vartable, [SIdf],IdTag);
     end
  else if (token='FUNCTION') or (token='DEF') then
     begin
       gettoken;
       if idtag=extern then
         DeclareRoutine(ProgramUnit.ExternalVarTable, idtag, 'F')
       else
         DeclareRoutine(ProgramUnit.VarTable, idtag, 'F');
     end
  else if (token='SUB') or (token='PICTURE') then
     begin
       gettoken;
       if idtag=extern then
          DeclareRoutine(ProgramUnit.ExternalSubTable, extern, prevtoken[1]) //2013.12.7
       else
          skipLogical   ;
     end;
end;

function SharePublic(prev,eld:TStatement;Idtag:TIdtag):TStatement;
var
   name:AnsiString;
begin
  if (programunit.kind='M') or
     ((programunit.kind=#0) and (Idtag=IdPublic)
                            and ((token='NUMERIC')or(token='STRING')))   then
  else
      seterrIllegal(prevtoken,IDH_Module);

  result:=LabelStatement(prev,eld);

  if token='NUMERIC' then
     begin
         gettoken;
         DeclareNS(CurModule.ShareVartable, [NIdf],IdTag);
         exit
     end
  else if token='STRING' then
     begin
         gettoken;
         DeclareNS(CurModule.ShareVartable, [SIdf],IdTag);
         exit
     end
  else if token='FUNCTION' then
     begin
        gettoken;
        DeclareRoutine(CurModule.ShareVartable,IdTag,'F')  ;
     end
  else if (token='SUB') or (token='PICTURE') then
     begin
          gettoken;
          DeclareRoutine(CurModule.ShareSubTable,IdTag,prevtoken[1]) //2013.12.7
     end
  else if (token='CHANNEL') and (idtag=IdShare) then
     begin
       gettoken;
       repeat
          checktoken('#',0);
          if (tokenspec=Nrep)  and  (pos ('.',token)=0) then
             begin
                   name:=prevtoken+token;
                   gettoken;
             end;
          case pass of
           1:if newId(name) then
                CurModule.ShareVartable.add(TIdRec.initCh(Curmodule.name,name,idtag));
           2:begin
             end ;
          end;
       until test(',')=false;
     end;
end;

function SHAREst(prev,eld:TStatement):TStatement;
begin
   result:=SharePublic(prev,eld,IdShare)
end;

function PUBLICst(prev,eld:TStatement):TStatement;
begin
   result:=SharePublic(prev,eld,IdPublic)
end;


function LOCALst(prev,eld:TStatement):TStatement;
var
   idtag:TIdTag;
begin
  idtag:=intern;
  LOCALst:=LabelStatement(prev,eld);
  if LocalRoutine<>nil then
     DeclareNS(LocalRoutine.Vartable, [NIdf,SIdf],IdTag)
  else
     //DeclareNS(ProgramUnit.Vartable, [NIdf,SIdf],IdTag)
end;

{**********}
{PROGRAM st}
{**********}



function PROGRAMst(prev,eld:TStatement):TStatement;
begin
    PROGRAMstatement:=TPROGRAM.CREATE(prev,eld);
    PROGRAMst:=PROGRAMstatement;
end;

function FormalArray:TSubstance;
var
    nam:AnsiString;
    i,d:integer;
    lbound,ubound:Array4;
    c:integer;
    idr:TIdRec;
begin
    if pass=1 then
        nam:=getidentifier
    else
        result:=matrix;

    check('(',IDH_ARRAY);
    d:=0;
    repeat
      inc(d);
    until (d=4) or (test(',')=false) ;
    check(')',IDH_ARRAY);

    for i:=1 to 4 do lbound[i]:=1;
    for i:=1 to 4 do ubound[i]:=lbound[i] - 1;

    if pass=1 then
       if newId(nam) then
          begin
            idr:=TIdRec.initArray(nam,d,lbound,ubound,intern,maxint);
            programUnit.Vartable.add(idr) ;
            result:=idr.subs
          end
       else
    else

end;

constructor TPROGRAM.create(prev,eld:TStatement);
var
  i:integer;
begin
    inherited create(prev,eld);
    params:=TListCollection.create;

    if linenumber<>0 then seterrIllegal(prevtoken,IDH_JIS_DETAIL);
    if tokenspec<>Nidf then seterrIllegal(token,IDH_JIS_DETAIL);
    //mainProgram.name:=token;
    ProgramName:=Token;     // for PARACT program
    gettoken;
   if token='(' then
       begin
          gettoken;
          repeat
             if  NextToken='(' then
                params.insert(FormalArray)
             else
                params.insert(variable);
          until test(',')=false;
          check(')',IDH_CHAIN);
       end;
   with params do
     for i:=0 to count-1 do
       TSubstance(items[i]).AddQueryInteger(nil);
end;

destructor TPROGRAM.destroy;
begin
   params.free;
   inherited destroy;
end;


function TPROGRAM.Code:AnsiString;
var
  i:integer;
begin
  result:='';
  with Params do
    for i:=0 to Count-1 do
      case TSubstance(params[i]).kind of
        'S','s':result:=result+TSubstance(params[i]).Code+':= ParamStr('+IntToStr(i+1)+');' ;
        'N','n':result:=result+TSubstance(params[i]).Code+':= FloatVal(ParamStr('+IntToStr(i+1)+'));'  ;
      end;
end;

{*********}
{OPTION st}
{*********}
function PreciMode(const s:string):tpPrecision;
var
   i:TpPrecision;
begin
// revised for Code gen.

   for i:=low(i) to high(i) do
      if s=PrecisionLiteral[i] then
         begin result:=i; exit end;
   seterrExpected('DECIMAL or NATIVE',IDH_JIS_9);
end;

procedure testValidOptionArithmetic;
var
   i,i0:integer;
   s:boolean;
begin
     s:=not (programunit is TModule) or ((programunit as TModule).shareVarTable.count=0);
     //PROGRAM文の引数を無視
     i0:=0;
     if (ProgramUnit=MainProgram) and (PROGRAMstatement<>nil) then
     i0:= PROGRAMstatement.params.count;
     with programunit.vartable do
          for i:=i0 to count-1 do
              s:=s and (TIdRec(items[i]).prm or (TIdRec(items[i]).kindchar<>'n'));
     if not s then
        seterr(s_OPTION_ARITHMETIC,IDH_OPTION_ARITHMETIC)
end;

function  OPTIONsub(prev,eld:TStatement; OptionLevel:OptionAppearance):TStatement;
var
  PrecMode:tpPrecision;
  Switch:boolean;
begin
   OPTIONsub:=LabelStatement(prev,eld);
   repeat
       if token='ANGLE' then
            begin
                if permitMicrosoft then
                         seterr(s_JISmode,COMPILE_OPTION_SYNTAX);

                gettoken;

                if (pass=1) then
                   if programunit.optionangle=apNone then
                      programunit.optionAngle:=OptionLevel
                   else
                      seterr( s_OnlyOneOPTION_ANGLE,IDH_TRIGONOMETRIC);

                if token='DEGREES' then
                   programunit.AngleDegrees:=true
                else if token='RADIANS' then
                   programunit.AngleDegrees:=false
                else
                   seterrExpected('DEGREES',IDH_TRIGONOMETRIC);
                gettoken;
            end
        else if token='ARITHMETIC' then
            begin
                if permitMicrosoft then
                         seterr(s_JISmode,COMPILE_OPTION_SYNTAX);

                gettoken;

                if (pass=1) then testValidOptionArithmetic;
                if (pass=1) then
                   if programunit.optionarithmet=ApNone then
                      programunit.optionArithmet:=OptionLevel
                   else
                      seterr(s_OnlyOneOPTION_ARITHMETIC,IDH_JIS_4);

                precMode:=PreciMode(token);

                // DECIMAL, NATIVE または COMPLEX のみ許す (BASICAcc2)
                if not (precMode in [PrecisionNormal, PrecisionNative, PrecisionComplex]) then
                        seterrExpected('NATIVE or COMPLEX',IDH_JIS_9);


                Switch:=false;                      //2008.5.2
                programUnit.arithmetic:=precMode;
                setPrecisionMode(precMode,Switch);
                gettoken;
            end
       else if token='BASE' then
            begin
                 if pass=1 then
                    if programunit.DimAppeared then
                       seterr(s_OPTION_BASE,IDH_ARRAY);
                 gettoken;
                 programunit.optionbase:=OptionLevel;
                 if token='0' then
                     begin
                       programUnit.ArrayBase:=0;
                       gettoken;
                     end
                 else if token='1' then
                     begin
                       programUnit.ArrayBase:=1;
                       gettoken;
                     end
                 else
                    seterrRestricted('0 or 1',IDH_ARRAY);
            end
       else if token='COLLATE' then
            begin
                gettoken;
                programUnit.optionCollate:=OptionLevel;
                if token='STANDARD' then
                   ProgramUnit.CharacterByte:=false
                else if token='NATIVE' then
                   ProgramUnit.CharacterByte:=true
                else
                   seterr('',IDH_SUBSTRING);
                gettoken;
            end
       else if token='CHARACTER' then
            begin
                gettoken;
                programUnit.optionCollate:=OptionLevel;
                if token='BYTE' then
                   ProgramUnit.CharacterByte:=true
                else if (token='MULTIBYTE') or (token='UTF8') or (token='KANJI') then
                   ProgramUnit.CharacterByte:=false
                else
                   seterr('',IDH_SUBSTRING);
                gettoken;
            end
       else
            seterr('',IDH_SUBSTRING)  ;
   until test(',')=false
end;

function  OPTIONst(prev,eld:TStatement):TStatement;
begin
    OPTIONst:=OPTIONsub(prev,eld,ApUnit);
end;

function MODULEst(prev,eld:TStatement):TStatement;
begin
   result:=nil;
   if (ProgramUnit.kind='M') and (token='OPTION') then
       begin
          gettoken;
          MODULEst:=OPTIONsub(prev,eld,ApModule);
       end
   else
       seterrIllegal(prevtoken,IDH_STATEMENTS);
end;

{**********}
{DATA statement}
{**********}

function DATAst(prev,eld:TStatement):TStatement;
var
   cont:boolean;
   p:ansiString;
begin
   DATAst:=LabelStatement(prev,eld);
   resettoken1;
   if pass=1 then programunit.DataSeq.setlabelNumber(Labelnumber);
   cont:=true;
   while cont do
       begin
          p:=datum;
          if pass=1 then
              programunit.DataSeq.DataList.append(p);
          gettoken;
          if nexttoken=',' then
              cont:=true
          else
              cont:=false;
       end;
   gettoken;
end;



{*******}
{RESTORE}
{*******}
type
    TRestore=class(TStatement)
           LabelNumber:integer;
        constructor create(prev,eld:TStatement);
        //procedure exec;override;
        function Code:AnsiString;override;
    end;

constructor TRestore.create(prev,eld:TStatement);
var
   long:longint;
begin
    inherited create(prev,eld);
    if token<>'' then
       begin
       if nonnegativeintegralnumber(long) and (long>0) then
           Labelnumber:=long
       else
          seterrexpected(s_LineNumber,IDH_READ_DATA);
       if (pass=2) and (Punit.dataseq.labelNumbers.indexof(strint(long))<0) then
          seterr(SysUtils.Format(s_LineNotFound,[strint(long)]),IDH_READ_DATA);
       end;
end;


function TRestore.Code:ansistring;
begin
  result:='DataSeq.RESTORE('+InttoStr(LabelNumber)+');';
end;



function  RESTOREst(prev,eld:TStatement):TStatement;
begin
    RESTOREst:=TRestore.create(prev,eld)
end;

{***************}
{IMAGE statement}
{***************}

function IMAGEst(prev,eld:TStatement):TStatement;
var
   svcp:TokenSave;
   s:ansistring;
   dummy:integer;
begin
   if labelNumber=0 then seterr(s_IMAGEstatement,IDH_PRINT_USING);
   IMAGEst:=TStatement.create(prev,eld);
   savetoken(svcp);
   check(':',IDH_PRINT_USING);
   skip;
   if pass=1 then
     begin
       s:=extract(svcp);
       delete(s,1,1);
       s:=trimright(s);
       if not TestFormatString(s) then
          seterr('Illegal format string',IDH_PRINT_USING);
       dummy:=programunit.ImageList.addObject(s,TObject(labelnumber));
     end;  
end;

{******}
{REM st}
{******}

function  REMst(prev,eld:TStatement):TStatement;
begin
   REMst:=LabelStatement(prev,eld) ;
   skip;
end;

{**************}
{InOutStructure}
{**************}
type
  TInOutStructure=Class
        exp:TPrincipal;
        next:TInOutStructure;
      constructor create(exp1:TPrincipal; StructItem1:TStructItem);
      destructor destroy;override;
      function ArgsCode:AnsiString;
   end;

 type
    TInStructure=Class(TInOutStructure)
         constructor create(exp1:TPrincipal; StructItem1:TStructItem);
    end;

 type
    TOutStructure=Class(TInOutStructure)
    end;

 constructor TInOutStructure.create(exp1:TPrincipal; StructItem1:TStructItem);
  begin
     inherited create;
     exp:=exp1;
     next:=nil;
     if UpperCase(exp1.kind)<>StructItem1.kind then
         SetErr('',IDH_PARACT);
     if (exp1 is TSubstance) and ((TSubstance(exp1).idr.dim)<>StructItem1.dim) then
         SetErr('',IDH_PARACT);

  end;

  constructor TInStructure.create(exp1:TPrincipal; StructItem1:TStructItem);
  begin
     inherited create(exp1,StructItem1);
     if exp is  TCVari then
        TCVari(exp).AddQueryDouble(nil);
     if exp is TSubstance then
        TSubstance(exp).AddQueryInteger(nil)
     else
        seterr('',IDH_PARACT);
  end;
  destructor TInOutStructure.destroy;
  begin
     exp.free;
     if next<>nil then next.free;
     inherited destroy;
  end;

  function TInOutStructure.Argscode:ansistring;
  begin
    result:=exp.code;
    if next<>nil then
      result:=result+','+next.ArgsCode;
  end;


{*******}
{SEND TO}
{*******}
type
    TSendTo=class(TStatement)
           MessageName:string;
           MessageDef:TMessageDef;
           OutStructure:TOutStructure;
           TimeOut:Tprincipal;
        constructor create(prev,eld:TStatement);
        function Code:AnsiString;override;
    end;

type
    POutStructure=^TOutStructure;
constructor TSendTo.create(prev,eld:TStatement);
var
   temp:POutStructure;
   i:integer;
begin
    inherited create(prev,eld);
    checktoken('TO',IDH_PARACT);
    MessageName:=token;
    try
       MessageDef:=ShareMessDefs.Objects[ShareMessDefs.indexof(MessageName)] as TMessageDef;
    except
       seterr(MessageName+s_notFound,IDH_Paract);
    end;
    gettoken;

    checktoken('FROM',IDH_PARACT);
    temp:=@OutStructure;
    i:=0;
    repeat
       temp^:=TOutStructure.create(article, MessageDef.Structure.Items[i] as TStructItem);
       //gettoken;
       temp:=@(temp^.next);
       inc(i);
    until test(',')=false;

    if token='TIMEOUT' then
      begin
        gettoken;
        TimeOut:=NExpression;
      end;
end;

function TSendTo.Code:ansistring;
var
   TimeOutparam:string;
begin
   TimeOutParam:='';
   if timeout<>nil then
     TimeOutparam:='TimeOut('+Timeout.Code+')';
  result:=
     ' EnterCriticalSection(Send'+MessageName+'_CriticalSection);'+EOL
   + ' try'+EOL
   + '    '+'Mess_'+MessageName+'.read('+OutStructure.ArgsCode+');'+EOL
   + '    '+'Mess_'+MessageName+'.valid:=true;'+EOL
   + '    '+'Mess_'+MessageName+'.WaitForReady'+TimeOutParam+';'+EOL
   + ' finally'+EOL
   + '    LeaveCriticalSection(Send'+MessageName+'_CriticalSection);'+EOL
   + ' end;'+EOL
end;

function  Sendst(prev,eld:TStatement):TStatement;
begin
    Sendst:=TSendTo.create(prev,eld)
end;

{************}
{RECEIVE FROM}
{************}
type
    TReceiveFrom=class(TStatement)
          MessageName:string;
          MessageDef:TMessageDef;
          InStructure:TInStructure;
          TimeOut:Tprincipal;
        constructor create(prev,eld:TStatement);
        function Code:AnsiString;override;
    end;
type
    PInStructure=^TInStructure;
constructor TReceiveFrom.create(prev,eld:TStatement);
var
   temp:PInStructure;
   i:integer;
begin
    inherited create(prev,eld);
    checktoken('FROM',IDH_PARACT);
    MessageName:=token;
    try
       MessageDef:=ShareMessDefs.Objects[ShareMessDefs.indexof(MessageName)] as TMessageDef;
    except
       seterr(MessageName+s_notFound,IDH_Paract);
    end;
    gettoken;
    checktoken('TO',IDH_PARACT);
    temp:=@InStructure;
    i:=0;
    repeat
       temp^:=TInStructure.create(article, MessageDef.Structure.Items[i] as TStructItem);
       //gettoken; //不要
       temp:=@(temp^.next);
       inc(i);
    until test(',')=false;

    if token='TIMEOUT' then
      begin
        gettoken;
        TimeOut:=NExpression;
      end;
end;


function TReceiveFrom.Code:ansistring;
var
   i:integer;
   temp:TInOutStructure;
   structure:TStructure;
   substcode:ansistring;
   TimeOutparam:string;
begin
   TimeOutParam:='';
   if timeout<>nil then
      TimeOutparam:='TimeOut('+Timeout.Code+')';

   structure:=MessageDef.Structure;
   substcode:='';
   i:=0;
   temp:=InStructure;
   while temp<>nil do
      begin
       if  (structure.Items[i] as  TStructItem).dim>0 then
         substcode:=substcode
         +'       '+temp.exp.Code+'.ReadFrom(@v'+inttostr(i)+','
                +inttostr((structure.items[i] as TStructItem).size)+');'+EOL
       else
         substcode:=substcode
         +'       '+temp.exp.Code+':=v'+inttostr(i)+';'+EOL;
       inc(i);
       temp:=Temp.next;
      end;

   result:=
     'EnterCriticalSection('+MessageName+'_CriticalSection);'+EOL
   + 'try'+EOL
   + '    '+'Mess_'+MessageName+'.WaitForValid'+TimeOutparam+';'+EOL
   + '    with '+'Mess_'+MessageName+' do'+EOL
   + '      begin'+EOL
   +          substcode
   + '        valid:=false;'+EOL
   + '      end;'+EOL
   + 'finally'+EOL
   + '   LeaveCriticalSection('+MessageName+'_CriticalSection);'+EOL
   + 'end;'+EOL
end;

function  RECEIVEst(prev,eld:TStatement):TStatement;
begin
    RECEIVEst:=TReceiveFrom.create(prev,eld)
end;


{*******}
{PUT TO }
{*******}
type
    TPutTo=class(TStatement)
         Sharedname:string;
         SharedDef:TSharedDef;
         dim:integer;
         index:array[1..4] of Tprincipal;
         OutStructure:TOutStructure;
         TimeOut:Tprincipal;
       constructor create(prev,eld:TStatement);
       function Code:AnsiString;override;
    end;

constructor TPutTo.create(prev,eld:TStatement);
var
  temp:POutStructure;
  i:integer;
begin
    inherited create(prev,eld);
    checktoken('TO',IDH_PARACT);
    SharedName:=token;
    try
       SharedDef:=ShareMessDefs.Objects[ShareMessDefs.indexof(SharedName)] as TSharedDef;
    except
       seterr(token+s_notFound,IDH_Paract);
    end;
    gettoken;
    dim:=0;
    if token='(' then
      begin
        gettoken;
        repeat
          inc(dim);
          index[dim]:=NExpression;
        until test(',')=false;
        checktoken(')',IDH_PARACT);
      end;

    checktoken('FROM',IDH_PARACT);
    temp:=@OutStructure;
    i:=0;
    repeat
       temp^:=TOutStructure.create(article, SharedDef.Structure.Items[i] as TStructItem);
       //gettoken;
       temp:=@(temp^.next);
       inc(i)
    until test(',')=false;

    if token='TIMEOUT' then
      begin
        gettoken;
        TimeOut:=NExpression;
      end;
end;


function TPutTo.Code:ansistring;
var
  indices:string;
  i:integer;
begin
  indices:='';
  for i:=1 to dim do
     indices:=indices+'[SysIntRound('+index[i].code+')]';

  result:=
    '    {$R+}'+'Shared_'+Sharedname+indices+'{$R-}.read('+OutStructure.ArgsCode+');'+EOL;

  if (SeizeBlock=nil) {or (SeizeBlock.SeizeItems.IndexOf(Sharedname)<0)} then
  result:=
     ' EnterCriticalSection('+Sharedname+'_CriticalSection);'+EOL
   + ' try'+EOL
   + result
   + ' finally'+EOL
   + '    LeaveCriticalSection('+Sharedname+'_CriticalSection);'+EOL
   + ' end;'+EOL
end;

function  PUTst(prev,eld:TStatement):TStatement;
begin
    PUTst:=TPutTo.create(prev,eld)
end;

{********}
{GET FROM}
{********}
type
    TGetFrom=class(TStatement)
           Sharedname:string;
           SharedDef:TShareMessDef;
           dim:integer;
           index:array[1..4] of Tprincipal;
           InStructure:TInStructure;
           TimeOut:Tprincipal;
        constructor create(prev,eld:TStatement);
        function Code:AnsiString;override;
    end;

constructor TGetFrom.create(prev,eld:TStatement);
var
   temp:PInStructure;
   i:integer;
begin
    inherited create(prev,eld);
    checktoken('FROM',IDH_PARACT);
    SharedName:=token;
    try
       SharedDef:=ShareMessDefs.Objects[ShareMessDefs.indexof(SharedName)] as TSharedDef;
    except
       seterr(token+s_notFound,IDH_Paract);
    end;
    gettoken;
    dim:=0;
    if token='(' then
      begin
        gettoken;
        repeat
          inc(dim);
          index[dim]:=NExpression;
        until test(',')=false;
        checktoken(')',IDH_PARACT);
      end;

    checktoken('TO',IDH_PARACT);
    temp:=@InStructure;
    i:=0;
    repeat
      temp^:=TInStructure.create(article, SharedDef.Structure.Items[i] as TStructItem);
       //gettoken; //不要
       temp:=@(temp^.next);
       inc(i)
    until test(',')=false;

    if token='TIMEOUT' then
      begin
        gettoken;
        TimeOut:=NExpression;
      end;
end;


function TGetFrom.Code:ansistring;
var
   i:integer;
   temp:TInOutStructure;
   structure:TStructure;
   substcode:ansistring;
   indices:string;
begin
   indices:='';
   for i:=1 to dim do
     indices:=indices+'[SysIntRound('+index[i].code+')]';

   structure:=SharedDef.Structure;
   substcode:='';
   i:=0;
   temp:=InStructure;
   while temp<>nil do
      begin
       if  (structure.Items[i] as  TStructItem).dim>0 then
         substcode:=substcode
         +'       '+temp.exp.Code+'.ReadFrom(@v'+inttostr(i)+','
                +inttostr((structure.items[i] as TStructItem).size)+');'+EOL
       else
         substcode:=substcode
         +'       '+temp.exp.Code+':=v'+inttostr(i)+';'+EOL;
       inc(i);
       temp:=Temp.next;
      end;

   result:=
     '   {$R+}'+EOL
   + '    with '+'Shared_'+Sharedname+indices+' do'+EOL
   + '   {$R-}'+EOL
   + '      begin'+EOL
   +          substcode
   + '      end;'+EOL;

   if (SeizeBlock=nil) or (SeizeBlock.SeizeItems.IndexOf(Sharedname)<0) then

   result:=
     'EnterCriticalSection('+Sharedname+'_CriticalSection);'+EOL
   + 'try'+EOL
   + result
   + 'finally'+EOL
   + '   LeaveCriticalSection('+Sharedname+'_CriticalSection);'+EOL
   + 'end;'+EOL;

end;

function  GETst(prev,eld:TStatement):TStatement;
begin
    GETst:=TGetFrom.create(prev,eld)
end;

{*******}
{OUT TO }
{*******}
type
    TOutTo=class(TStatement)
         ProcessName:string;
         ProcessDef:TProcessDef;
         dim:integer;
         index:array[1..4] of Tprincipal;
         OutStructure:TOutStructure;
         TimeOut:Tprincipal;
       constructor create(prev,eld:TStatement);
       function Code:AnsiString;override;
    end;

constructor TOutTo.create(prev,eld:TStatement);
var
  temp:POutStructure;
  i:integer;
begin
    inherited create(prev,eld);
    checktoken('TO',IDH_PARACT);
    ProcessName:=token;
    try
       ProcessDef:=ShareMessDefs.Objects[ShareMessDefs.indexof(ProcessName)] as TProcessDef;
    except
       seterr(token+s_notFound,IDH_Paract);
    end;
    gettoken;
    dim:=0;
    if token='(' then
      begin
        gettoken;
        repeat
          inc(dim);
          index[dim]:=NExpression;
        until test(',')=false;
        checktoken(')',IDH_PARACT);
      end;

    checktoken('FROM',IDH_PARACT);
    temp:=@OutStructure;
    i:=0;
    repeat
       temp^:=TOutStructure.create(article, ProcessDef.Structure.Items[i] as TStructItem);
       //gettoken;
       temp:=@(temp^.next);
       inc(i)
    until test(',')=false;

    if token='TIMEOUT' then
      begin
        gettoken;
        TimeOut:=NExpression;
      end;
end;


function TOutTo.Code:ansistring;
var
  indices:string;
  i:integer;
begin
  indices:='';
  for i:=1 to dim do
     indices:=indices+'[SysIntRound('+index[i].code+')]';
   result:=
    '    {$R+}'+ProcessName+indices+'{$R-}.read('+OutStructure.ArgsCode+');'+EOL;

   result:=
     ' EnterCriticalSection('+ProcessName+'_CriticalSection);'+EOL
   + ' try'+EOL
   + result
   + ' finally'+EOL
   + '    LeaveCriticalSection('+ProcessName+'_CriticalSection);'+EOL
   + ' end;'+EOL
end;

function  OUTst(prev,eld:TStatement):TStatement;
begin
    OUTst:=TOutTo.create(prev,eld)
end;

{********}
{IN FROM}
{********}
type
    TInFrom=class(TStatement)
           ProcessName:string;
           ProcessDef:TShareMessDef;
           dim:integer;
           index:array[1..4] of Tprincipal;
           InStructure:TInStructure;
           TimeOut:Tprincipal;
        constructor create(prev,eld:TStatement);
        function Code:AnsiString;override;
    end;

constructor TInFrom.create(prev,eld:TStatement);
var
   temp:PInStructure;
   i:integer;
begin
    inherited create(prev,eld);
    checktoken('FROM',IDH_PARACT);
    ProcessName:=token;
    try
       ProcessDef:=ShareMessDefs.Objects[ShareMessDefs.indexof(ProcessName)] as TProcessDef;
    except
       seterr(token+s_notFound,IDH_Paract);
    end;
    gettoken;
    dim:=0;
    if token='(' then
      begin
        gettoken;
        repeat
          inc(dim);
          index[dim]:=NExpression;
        until test(',')=false;
        checktoken(')',IDH_PARACT);
      end;

    checktoken('TO',IDH_PARACT);
    temp:=@InStructure;
    i:=0;
    repeat
      temp^:=TInStructure.create(article, ProcessDef.Structure.Items[i] as TStructItem);
       //gettoken; //不要
       temp:=@(temp^.next);
       inc(i)
    until test(',')=false;

    if token='TIMEOUT' then
      begin
        gettoken;
        TimeOut:=NExpression;
      end;
end;


function TInFrom.Code:ansistring;
var
   i:integer;
   temp:TInOutStructure;
   structure:TStructure;
   substcode:ansistring;
   indices:string;
begin
   indices:='';
   for i:=1 to dim do
     indices:=indices+'[SysIntRound('+index[i].code+')]';

   structure:=ProcessDef.Structure;
   substcode:='';
   i:=0;
   temp:=InStructure;
   while temp<>nil do
      begin
       if  (structure.Items[i] as  TStructItem).dim>0 then
         substcode:=substcode
         +'       '+temp.exp.Code+'.ReadFrom(@v'+inttostr(i)+','
                +inttostr((structure.items[i] as TStructItem).size)+');'+EOL
       else
         substcode:=substcode
         +'       '+temp.exp.Code+':=v'+inttostr(i)+';'+EOL;
       inc(i);
       temp:=Temp.next;
      end;

   result:=
     '   {$R+}'+EOL
   + '    with '+ProcessName+indices+' do'+EOL
   + '   {$R-}'+EOL
   + '      begin'+EOL
   +          substcode
   + '      end;'+EOL;

   result:=
     'EnterCriticalSection('+ProcessName+'_CriticalSection);'+EOL
   + 'try'+EOL
   + result
   + 'finally'+EOL
   + '   LeaveCriticalSection('+ProcessName+'_CriticalSection);'+EOL
   + 'end;'+EOL;
end;

function  INst(prev,eld:TStatement):TStatement;
begin
    INst:=TInFrom.create(prev,eld)
end;

{*************}
{registeration}
{*************}

procedure statementTableinit;
begin
   PROGRAMstatement:=nil;   //2004.1.7
   StatementTableInitDeclative ('PROGRAM',PROGRAMst);
   StatementTableInitDeclative ('REM',REMst);
   StatementTableInitDeclative ('DATA',DATAst);
   StatementTableInitImperative('RESTORE',RESTOREst);
   StatementTableInitDeclative ('IMAGE',IMAGEst);
   StatementTableInitSingular  ('DIM',DIMst);
   StatementTableInitDeclative ('DECLARE',DECLAREst);
   StatementTableInitDeclative ('SHARE',SHAREst);
   StatementTableInitDeclative ('PUBLIC',PUBLICst);
   StatementTableInitDeclative ('OPTION',OPTIONst);
   StatementTableInitDeclative ('MODULE',MODULEst);
   StatementTableInitDeclative ('LOCAL',LOCALst);
   //StatementTableInitImperative('PUT',PUTst);
   //StatementTableInitImperative('GET',GETst);
   //StatementTableInitImperative('SEND',SENDst);
   //StatementTableInitImperative('RECEIVE',RECEIVEst);
   //StatementTableInitImperative('IN',INst);
   //StatementTableInitImperative('OUT',OUTst);

end;

procedure functiontableInit;
begin
end;


initialization
   tableInitProcs.accept(statementTableinit);
   tableInitProcs.accept(FunctionTableInit);

   ChainParams:=TStringList.Create;


finalization
    With ChainParams do begin Clear;Free end;


end.


