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

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

{$X+}


{********}
interface
{********}
uses Classes,SysUtils, Graphics, Forms, Dialogs, Controls,
     base,base0,listcoll, objlist,texthand,arithmet,variabl,dataseqv2,base2;

procedure setPrecisionMode(precMode:tpPrecision; initial:boolean);
var MixedArithmetic:boolean;

procedure KeyWordTablesFreeAll;


{*********}
{TIdTable}
{*********}

type
   TIdTable =class(TObjectList)
      function KeyOf(item:TObject):AnsiString;override;
      function inquire(const name:AnsiString; var index:integer;
                                    var dim:integer):boolean;
      function search2(const mnam,nam:AnsiString; var index:integer):boolean;
      procedure InitComplete(arith:tpPrecision);
      // For Code Generate
      function ParametersLiteralFunc:AnsiString;
      function ParametersLiteralSub:AnsiString;
      function LocalVariablesLiteral:AnsiString;
      function ShareVariablesLiteral:AnsiString;
      function PublicVariablesLiteral:AnsiString;
      function ArraysInitializeCode:AnsiString;
      function ArraysFinalizeCode:ansistring;
      function ShareChannelHandoverCode:AnsiString;
     private
   end;


const
   MaxNumberOfParams=256;

{******************}
{LabelNumbers Table}
{******************}
type
    TStatement=class;
    PLabelNumberPair =^LabelNumberPair;
    LabelNumberPair=record
          Labelnumb:integer;
          statement:TStatement;
          prefect  :TStatement;
    end;


    TLabelNumberTable=class(TSortedListCollection)
       procedure FreeItem(Item:pointer);override;
       function Compare(key1,key2:pointer):integer;override;
       procedure AddItem(p:TStatement);
   end;


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

      TRoutine=class;
      TProgramUnit=class;
      TModule=class;
      TWhenException=class;

      TStatement=class(TMyObject)
               linenumb:  integer;
               labelnumb: integer;
               next:      TStatement;
               previous:  TStatement;
               eldest:    TStatement;
               WhenBlock: TWhenException;
               proc:      TRoutine;
               PUnit:     TProgramUnit;
               StopKeySence:procedure of Object;

             //for code gen.
               haveBranchLabel:boolean;

            constructor create(prev,eld:TStatement) ;
            constructor TStatementCreate(prev,eld:TStatement);
            procedure CollectLabelInfo(t:TLabelNumberTable);virtual;
            function insideofwhen:LongBool;
            destructor destroy;override;

            function Code:AnsiString; virtual;
            function TraceCode:AnsiString; virtual;
            //function TraceResultCode:Ansistring; virtual;
            function GenCode(PreLabel,AfterLabel:TStringList; HaveEXLINE:boolean):AnsiString;
            function BlockCode(PreLabel,AfterLabel:TStringList; HaveEXLINE:boolean):AnsiString;virtual;abstract;
            function MakeLabel:Ansistring;

          private
            function NotSubStatement:boolean;
      end;

     TStatementNoTrace=class(TStatement)
            function TraceCode:AnsiString; override;
      end;


     TWhenException=class(TStatement)
            block:TStatement;
            UseBlock:TStatement;
            svextype:integer;
            svStatementEx:TStatement;
            // Gen Code
            HaveRetry:boolean;
            HaveContinue:boolean;
            HaveEXLINE:boolean;
            ReturnLables:TStringList;
          constructor create(prev,eld:TStatement);
          procedure CollectLabelInfo(t:TLabelNumberTable);override;
          destructor destroy;override;
          //Gen Code
          function BlockCode(Prelabel0,Afterlabel0:TstringList; HaveEXLINE0:boolean):AnsiString; override;
          function JumpCode(Prelabel, AfterLabel:TstringList):Ansistring;
          function HandlerCode:Ansistring;virtual;
        private
     end;


   TTerminal=class(TStatement)
      statement:TStatement;
   end;


{*******}
{routine}
{*******}
   TypeProcedure=Procedure;
   TRunProcedure =procedure(params:TObjectList; DoAfter:TypeProcedure) of object;
   TEvalProcedure =procedure(params:TObjectList; DoAfter:TypeProcedure ) of object;

   TRoutine=class(TObject)
          resultVar :TIdrec;
          name      :AnsiString;
          VarTable  :TIdTable;
          paramcount:integer;
          block     :TStatement;
          GotoList  :TList;
          kind      :char;      {#0:MainProgram, M:module, D:def, F:function, S:sub, P:picture, H:Handler, A:PARACT}
          ByVal     :boolean;
          NoBeamOff:boolean;

          // For Code Generate
          HaveMissing:boolean;
          HaveEXITst:boolean;
          HaveWhenException:boolean;
          HaveRETRYst:boolean;
          HaveCONTINUEst:boolean;
          MaxNumArgDouble:byte;
          MaxNumArgComplex:byte;
          MaxNumArgNumber:byte;
          MaxNumArgString:byte;
          LabelsList:TStringList;
          ReturnLables:TStringList;

        constructor create(const n:Ansistring; k:char; maxlen:integer);
        destructor  destroy;override;
        procedure SetResultVar(arith:tpPrecision);
        procedure ResultVarGetVar;virtual;abstract;
        procedure MakeParameter;
        procedure RoutineBody;virtual;
        procedure deleteStatements;
        procedure VarTablesRebuild;virtual;abstract;
        procedure LabelComplete;
        function  isfunction:boolean;

        // For Code Generate
        function HeaderCode(withModuleName:boolean):AnsiString;
        function BodyCode:Ansistring;
        function ParametersLiteral:Ansistring;
        function LocalVariablesLiteral:Ansistring;virtual;
        function VariablesInitializeCode:Ansistring;virtual;
        function VariablesFinalizeCode:Ansistring;virtual;
        function NameCode:Ansistring;
        function LabelsCode:Ansistring;
        function CallBackCode:string;
       private
        CallBack:char;
        Cdecl:boolean;
        function PrepareCallback:char;
        function procCallCode:string;
        function CallBackParameters:string;
     end;


{*******************}
{External procedures}
{*******************}
   OptionAppearance=(ApNone,ApUnit,ApModule);

   TProgramUnit=class(TRoutine)
          LineNumb:integer;
          parent:TModule;
          ExternalVarTable:TIdTable;
          ExternalSubTable:TIdTable;
          DataSeq  :TDataSeqV2;
          ImageList:TStringList;
          Arithmetic:tpPrecision;
          ArrayBase:shortint;
          AngleDegrees:boolean;
          CharacterByte:boolean;
          debug:boolean;
          optionArithmet:OptionAppearance;
          optionAngle   :OptionAppearance;
          OptionBase    :OptionAppearance;
          OptionCollate :OptionAppearance;
          DimAppeared:boolean;
          urgency:TUrgency;
          HaveChannelExpression:boolean;
          HaveTraceSt:boolean;
          HaveDebugSt:boolean;

        function LocalVariablesLiteral:Ansistring;override;
        function VariablesInitializeCode:Ansistring;override;
        function VariablesFinalizeCode:Ansistring;override;

       constructor create(const n:Ansistring; k:char; maxlen:integer; p:TModule);
       destructor destroy;override;
       procedure RoutineBody;override;
       procedure VarTablesRebuild;override;

      private

   end;


{*********}
 {Module}
{*********}

   TModule=class(TProgramUnit)
        ShareVarTable:TidTable;
        ShareSubTable:TidTable;
       constructor create(const n:Ansistring;k:char);
       procedure RoutineBody;override;
       procedure VarTablesRebuild;override;
       destructor destroy;override;

        function VariablesInitializeCode:Ansistring;override;
        function ShareVariablesFinalizeCode:Ansistring;

   end;


function module(const nam:AnsiString):TModule;

{****************}
{Local Procedures}
{****************}

Type
   TLocalProc=class(TRoutine)
         parent:TProgramUnit;
      constructor create(const n:Ansistring; k:char; maxlen:integer);
      procedure VarTablesRebuild;override;
      // for code generate
      function Code:Ansistring;
    end;

{ ********* }
{ THandler  }
{********** }


   THandler=class(TLocalProc)
          WhenUseBlockStack:TObjectList;
          // for code gen.
          HaveRetry:Boolean;
          HaveContinue:Boolean;
          HaveEXLINE:boolean;

      constructor create(const n:Ansistring; k:char);
      destructor destroy;override;
   end;



{*****************}
{ Procedures Table}
{*****************}
type
    TProcTbl=class(TObjectList)
          function inquire(const name:AnsiString; var p:TRoutine ):boolean;
          function keyof(Item:TObject):AnsiString;override;
          procedure deleteStatements;
          procedure VarTablesRebuild;

          function Code:AnsiString;
          procedure ModuleCode(var i:integer; Decls, impls, inits, dones: TStringList);
    end;

 {**********************}
 {Parallel section Table}
 {**********************}
 type
   TParactTbl=class(TStringList);

 Var
     ParactTbl:TParactTbl;



{******************}
{Control Exceptions}
{******************}

type
    EReturn=class(EControlException);

    EExitHandler=class(EControlException)
       When:TWhenException;
       constructor create(when1:TWhenException);
    end;

    EExitDo=class(EControlException)
         NextSt:TStatement;
       constructor create(St:TStatement);
    end;


{*******}
{GOTO st}
{*******}

type
   TGOTO=class(Tstatement)
           numb:integer;
           prefect:TStatement;
           statement:TStatement;
       constructor create(prev,eld:TStatement);
       procedure FillInfo(LabelNumbertable:TLabelNumberTable);virtual;
       function Code:Ansistring;override;
    end;

type
   TControlException=class of EControlException;

type
     TEXIT=class(TStatement)
          typ:TControlException;
        constructor create(prev,eld:TStatement; t:TControlException);
        function Code:AnsiString;override;
     end;

{****************}
{Global Variables}
{****************}
var
    CurrentProgram:TProcTbl;
    MainProgram:TModule;

{翻訳時}
var
    LocalRoutine:TLocalProc ;
    ProgramUnit:TProgramUnit ;
    CurModule:TModule;

{実行時}
var
   CurrentStatement:TStatement;
   NextStatement:TStatement;
   CurrentOperation:TMyObject;




{****************}
{select procedure}
{****************}
type
   string10=string[10];
   StatementFunction = function(prev,eld:TStatement) :TStatement;
   statementspec=(declative,imperative,structural,terminal,singular);
   PrcSelectee = record
        name : string10;
        spec : statementspec;
        prc  : StatementFunction;
   end;

   PPrcSelectee = ^PrcSelectee;

   TPrcSelection = class(TstringCollection)
         procedure accept(n:string10; s:statementspec; f:StatementFunction );
         function find(s:String ;  var prc:StatementFunction ; var sp:statementspec):boolean;
         procedure freeItem(item:pointer);override;
   end;

var
   statementTable        : TprcSelection;

procedure statementtableInitDeclative (n:string10 ; f:StatementFunction);
procedure statementtableInitImperative(n:string10 ; f:StatementFunction);
procedure statementtableInitStructural(n:string10 ; f:StatementFunction);
procedure statementtableInitTerminal  (n:string10 ; f:StatementFunction);
procedure statementtableInitSingular  (n:string10 ; f:StatementFunction);

{*****************}
{supplied function}
{*****************}


type
   string11 = string[11];
   Simplefunction = function :TPrincipal;
   PFncSelectee = ^TFncSelectee;
   TFncSelectee = record
        name : string11;
        Fnc  : Simplefunction;
   end;


   TFncselection = class(TstringCollection)
         function find(s:String ; var Func:simplefunction):boolean;
         procedure accept(const n:string11; f:simplefunction);
         procedure freeitem(item:pointer);override;
   end;


var
   suppliedFunctionTable : TFncSelection;
   reservedWordTable : TFncSelection;

procedure  SuppliedFunctionTableInit(n:string11; f:simplefunction);
procedure  reservedWordTableInit(n:string11; f:simplefunction);

{*****************************************}
{ Table Initializing procedures Collection}
{*****************************************}
type
   proc = procedure;
   TProcsCollection=class(TListCollection)
       procedure call;
       procedure accept(f:proc);
       procedure freeItem(Item:pointer);override;
   end;

var
  TableInitProcs:TProcsCollection=nil;

{********}
{compiler}
{********}


procedure compile;
function routineHeadLocal:TLocalProc;
function block(prev:TStatement):TStatement;
function last(p:TStatement):TStatement;
function LabelStatement(prev,eld:TStatement):TStatement;


var
   USEnest:integer =0;

var
   DoStack:Tlist;
   ForStack:TList;
   WhenStack:Tlist;
   WhenUseStack:Tlist;

procedure MaxLenDeclaration(sp:SetOfTokenSpec; var maxlen:integer);
procedure DoNothing;


type
   ECodeNotYet=class(Exception)
     st:TStatement;
     constructor create(st0:Tstatement);
   end;

var
   EXLINEAppear:boolean=false;
   EXTYPEAppear:boolean=false;
   DebugVariables:TStringList;

function ThreadPriorityCode(i:integer):AnsiString;


{*************}
implementation
{*************}
uses
     MainFrm,helpctex,control,statemen,
     express,expressn,expressf,expressc,extensio,confopt,
     debug,sconsts,merge,compiler,extdll;
var
    RecentLabelNumber:integer;

{*******************}
{TNonSortedCollection}
{*******************}


{********}
{TIdTable}
{********}





function TIdTable.KeyOf(item:TObject):AnsiString;
begin
    keyOf:=TIdRec(item).name
end;

function TIdTable.inquire(const name:AnsiString; var index:integer;
                              var dim:integer):boolean;
var
    rec:TIdRec;
    s:boolean;
begin
    s:=search(name,index);
    inquire:=s;
    if s then
          begin
              rec:=TIdRec(items[index]);
              dim:=rec.dim
          end;
end;

function TIdTable.search2(const mnam,nam:AnsiString; var index:integer):boolean;
var
   found:boolean;
begin
   index:=0;
   found:=false;
   while (index<count) and not found do
      with TIdRec(items[index]) do
           if (mnam=modulename) and (nam=name) then
                found:=true
            else
                index:=index+1;
   search2:=found;
end;

procedure TIdTable.InitComplete(arith:tpPrecision);
var
  i:integer;
begin
  for i:=0 to count-1 do
      TIdrec(items[i]).InitComplete(arith)
end;



{************}
{TProgramUnit}
{************}


{**********}
{TStatement}
{**********}

constructor TStatement.create(prev,eld:TStatement);
begin
    inherited create;
    PUnit:=ProgramUnit;
    if localRoutine<>nil then
                proc:=LocalRoutine
    else
                proc:=ProgramUnit;
    linenumb:=lineNumber;
    labelnumb:=labelnumber;
    if (LabelNumber>0) and (LabelNumber<RecentLabelNumber) then
        seterrOnLine(LineNumber, s_LineNumberDescent, IDH_LINENUMBER);
    RecentLabelNumber:=LabelNumber;
    previous:=prev;
    if eld=nil then
       eldest:=self
    else
       eldest:=eld;
    with WhenStack do WhenBlock:=items[count-1];
end;

constructor TStatement.TStatementCreate(prev,eld:TStatement);
begin
    create(prev,eld);
end;


destructor TStatement.destroy;
begin
   next.free;
   inherited destroy
end;

procedure TStatement.CollectLabelInfo(t:TlabelNumberTable);
begin
  t.addItem(self);
  if next<>nil then next.CollectlabelInfo(t);
end;

{*****}
{Block}
{*****}


function TStatement.NotSubStatement:boolean;
begin
   if (previous=nil) or (previous.lineNumb<>linenumb) then
      NotSubStatement:=true
   else
      NotSubStatement:=false
end;



{******************}
{LabelNumbers Table}
{******************}

procedure TLabelNumberTable.FreeItem(Item:pointer);
begin
    if item<>nil then
        begin
            dispose(PLabelNumberPair(item))
        end
end;

function TLabelNumberTable.Compare(key1,key2:pointer):integer;
var
  i:integer;
begin
    i:=LabelNumberPair(key2^).labelNumb - LabelNumberPair(key1^).LabelNumb;
    if i<0 then Compare:=-1 else if i=0 then Compare:=0 else Compare:=1;
end;

procedure TLabelNumberTable.AddItem(p:TStatement);
var
   pair:^LabelNumberPair;
   i:integer;
begin
  if (p.labelnumb>0) and (p.NotsubStatement) then
     if Search(@p.labelnumb,i)then
         begin
            if PLabelNumberPair(items[i])^.statement.LineNumb <> p.linenumb then
                  seterrOnLine(p.linenumb,s_DuplicatedLineNumber,IDH_LINENUMBER);
         end
     else
         begin
            new(pair);
            pair^.labelnumb:=p.labelnumb;
            pair^.prefect:=p.eldest;
            pair^.statement:=p;
            insert(pair);
         end;
end;


{********}
{TRoutine}
{********}

type
   TDEF=class(TLocalProc)
      constructor create(const n:Ansistring; k:char; maxlen:integer);
   end;

constructor TRoutine.create(const n:ansistring; k:char; maxlen:integer);
begin
    inherited create;
    vartable:=TIdTable.create(0);
    GotoList:=TList.create;
    name:=n;
    kind:=k;
    ByVal:=(kind='F') or (JISDef and (Kind='D')) ;
    block:=nil;

    LabelsList:=TStringList.Create;
    LabelsList.Sorted:=true;
    labelsList.Duplicates:=dupIgnore;
    LabelsList.CaseSensitive:=false;

    ReturnLables:=TStringList.create;
    ReturnLables.sorted:=true;
    ReturnLables.Duplicates:=dupIgnore;
    {$IFNDEF Windows}
    {$IFDEF CPUx86}
    cdecl:=true;
    {$ENDIF}
    {$ENDIF}
end;

procedure TRoutine.SetResultVar(arith:tpPrecision);
begin
 if ResultVar<>nil then
    begin
       ResultVar.initComplete(arith);
    end;
end;

destructor  TRoutine.destroy;
begin
    OnIdTableFree:=true;
    vartable.free;
    ResultVar.free;
    OnIdTableFree:=false;
    GotoList.free;          //2011.3.8
    with LabelsList do begin clear;free end;
    with ReturnLables do begin clear;Free end;
    inherited destroy;

end;

procedure TRoutine.deleteStatements;
begin
   block.free;
   block:=nil
end;


constructor TLocalProc.create(const n:ansistring; k:char; maxlen:integer);
begin
    inherited create(n,k,maxlen);
    parent:=ProgramUnit;
end;

constructor TDEF.create(const n:Ansistring; k:char; maxlen:integer);
begin
    inherited create(n,k,maxlen);
end;

constructor TProgramUnit.create(const n:ansistring; k:char; maxlen:integer; p:TModule);
begin
    inherited create(n,k,maxlen);
    Urgency:=4; {tpNormal}
    parent:=p;

    LineNumb:=lineNumber;
    ExternalVarTable:=TIdTable.create(0);
    ExternalSubTable:=TIdTable.create(0);
    DataSeq:=TDataSeqV2.create;
    ImageList:=TStringList.create;
    Arithmetic:=InitialPrecisionMode;
    // ver.2.1.4.2
     case DefaultOptionArith of
           MainProgramArith:
              if kind<>#0{main program} then arithmetic:=MainProgram.arithmetic;
           ToolBarArith:
               ;
           ArithDecimal:
              arithmetic:=PrecisionNormal;
     end;
     //
    if MinimalBasic then ArrayBase:=0
                    else ArrayBase:=1;
    AngleDegrees:=false;
    CharacterByte:=InitialCharacterByte;
    if parent<>nil then
       begin
          if parent.OptionArithmet=ApModule then
                begin
                    OptionArithmet:=ApUnit;
                    arithmetic:=parent.arithmetic; //ver. 4.10で追加 ,99/9/24
                end;
          if parent.OptionBase=ApModule then
                begin
                    OptionBase:=ApUnit;
                    ArrayBase:=parent.ArrayBase;
                end;
          if parent.OptionAngle=ApModule then
                begin
                    OptionAngle:=ApUnit;
                    AngleDegrees:=parent.AngleDegrees;
                end;
          if parent.OptionCollate=ApModule then
                begin
                    OptionCollate:=ApUnit;
                    CharacterByte:=parent.CharacterByte;
                end;
       end;
end;

procedure TRoutine.LabelComplete;
var
   LabelNumberTable:TLabelNumberTable;
   i:integer;
begin
    LabelNumberTable:=TLabelNumberTable.create;
    block.CollectLabelInfo(LabelNumberTable);
    with GotoList do
       for i:=0 to count-1 do
            (TObject(items[i]) as TGOTO).FillInfo(LabelNumbertable);
    LabelNumberTable.free;

end;

procedure TLocalProc.VarTablesRebuild;
begin
   setResultVar(parent.arithmetic);
   VarTable.initcomplete(parent.arithmetic);
end;

procedure TProgramUnit.VarTablesRebuild;
begin
   setResultVar(arithmetic);
   VarTable.initcomplete(arithmetic);

end;


procedure TModule.VarTablesRebuild;
begin
  inherited VarTablesRebuild;
  ShareVarTable.initcomplete(arithmetic);
end;


procedure TGOTO.FillInfo(LabelNumbertable:TLabelNumberTable);
var
  i:integer;
  p:TStatement;
begin
   if LabelNumberTable.search(@numb,i) then
      with LabelNumberpair(LabelNumberTable.items[i]^) do
           begin
               p:=self.eldest;
               while (p<>nil) and (p<>prefect) and (p.previous<>nil) do
                  begin
                    if (p.previous is TWhenException)
                        and  (MessageDlg ('Notice',
                                       'Current version does not allow Exiting from a WHEN-block.',
                                       mtConfirmation, [mbOk,mbCancel],0)=mrOk) then
                        p:=nil
                    else
                        p:=p.previous.eldest;
                 end;
               if p=prefect then
                  begin
                        self.statement:=statement;
                        self.prefect:=prefect;
                        statement.haveBranchLabel:=true;
                  end
               else
                   seterrOnLine(self.linenumb,
                             Format(s_CanNotBrachLine,[strint(numb)]),IDH_CONTROL);
           end
    else
       begin
          seterronLine(self.linenumb,Format(s_LineNotFound,[strint(numb)]),IDH_JIS_8);
       end;
end;

destructor TProgramUnit.Destroy;
begin
    DataSeq.free;
    ExternalVarTable.free;
    ExternalSubTable.free;
    //GotoList.free;    //2011.3.8
    with ImageList do begin clear; free; end;
    inherited  destroy;
end;



Var
  DummyParameter:TObjectList;


function TRoutine.isfunction:boolean;
begin
   isfunction:=ResultVar<>nil;
end;


constructor THandler.create(const n:ansistring; k:char);
begin
    inherited create(n,k,maxint);
    WhenUseBlockStack:=TObjectList.create(4);
end;

destructor THandler.destroy;
begin
    WhenUseBlockStack.free;
    inherited destroy;
end;

constructor TModule.create(const n:ansistring;k:char);
begin
   inherited create(n,k,maxint,self);
   ShareVarTable:=TIdTable.create(0);
   ShareSubTable:=TIdTable.create(0);
end;

destructor TModule.destroy;
begin
  ShareVarTable.free;
  ShareSubTable.free;
  inherited destroy;
end;


function module(const nam:AnsiString):TModule;
var
  routine:TRoutine;
begin
  module:=nil;
  if nam='' then
     module:=MainProgram
  else if CurrentProgram.inquire(nam,routine) and (routine.kind='M') then
     module:=routine as TModule
  else if nam=MainProgram.name then
     module:=MainProgram
  else
     seterr('MODULE ' + nam + s_IsNotFound,IDH_MODULE);
end;

{***************}
{procedure table}
{***************}

function TProcTbl.inquire(const name:AnsiString; var p:TRoutine ):boolean;
var
    index:integer;
    s:AnsiString;
    c:boolean;
begin
    c:=false;
    if pos('.',name)=0 then
       begin
         s:=programunit.name + '.' + name;
         c:=search(s,index);
         if (not c) and (CurModule<>nil)  and (CurModule.kind='M') then
            begin
              s:=CurModule.name + '.' + name;
              c:=search(s,index) ;
            end;
       end;
    if not c then
        c:=search(name,index);
        
    //非互換プログラム
    {
    if not c and (pos('.',name)=0) and  (CurModule=MainProgram) then
       begin
           s:=CurModule.name + '.' + name;
           c:=search(s,index)
              and ( (pass=1)
                   or (MessageDlg(s_AllowGlobalInternalProc + EOL + name,
                                     mtWarning,
                                    [mbOk],
                                     IDH_PUBLIC                 ) =  mrYes))
       end;
    }

    if c then p:=TRoutine(items[index]) else p:=nil;
    inquire:=c
end;

function TProcTbl.keyof(item:TObject):AnsiString;
begin
    keyof:=TRoutine(item).name;
end;

procedure TProcTbl.deleteStatements;
var
   i:integer;
   p:TObject;
begin
   for i:=0 to count-1 do
      begin
          p:=items[i];
          (p as TRoutine).deleteStatements
      end;
end;

procedure TProcTbl.VarTablesRebuild;
var
   i:integer;
   p:TObject;
begin
   for i:=0 to count-1 do
      begin
          p:=items[i];
          (p as TRoutine).VarTablesRebuild;
      end;
end;



{*************}
{TPrcSeleciton}
{*************}
procedure TPrcSelection.accept(n:string10; s:statementspec; f:StatementFunction );
var
   p   :PPrcSelectee;
begin
       new(p);
       p^.name:=n;
       p^.spec:=s;
       p^.prc:=f;
       insert(p);
end;


function TPrcSelection.find(s:String ;  var prc:StatementFunction ; var sp:statementspec):boolean;
var
   i:integer;
   c:boolean;
   ss:string[31];
begin
   ss:=s;
   c:=search(@ss,i);
   if c then
      begin
          prc:=PPrcSelectee(items[i])^.prc;
          sp:=PPrcSelectee(items[i])^.spec;
      end;
   find:=c
end;

procedure TPrcSelection.freeItem(item:pointer);
begin
    dispose(PPrcSelectee(item))
end;

{*************}
{TFncSelection}
{*************}


function TFncSelection.find;
var
   i:integer;
   t:boolean;
   ss:string[31];
begin
   ss:=s;
   t:=search(@ss,i);
   if t then Func:=PFncSelectee(items[i])^.Fnc;
   find:=t
end;

procedure TFncSelection.accept(const n:string11; f:simplefunction);
var
       p       :PfncSelectee;
begin
       new(p);
       p^.name:=n;
       p^.fnc:=f;
       insert(p);
end;

procedure TFncSelection.freeitem(item:pointer);
begin
   dispose(PfncSelectee(item))
end;

{*******}
{compile}
{*******}
function LabelStatement(prev,eld:TStatement):TStatement;
begin
   if (pass=2) and (LabelNumber>0) then
      LabelStatement:=TStatementNoTrace.create(prev,eld)
   else
      LabelStatement:=nil
end;



function statement(prev,eld:TStatement):TStatement;
var
    prc:StatementFunction;
    p:TStatement;
    sp:statementspec;
    s:boolean;
    svcp:TokenSave;
begin
    p:=nil;
    s:=true;
    sp:=declative;  //2000.3.18
    while (not outoftext)  and  (p=nil)  and s do
    begin
        statusmes.clear;               //2001.1.9
        HelpContext:=0;                //2001.3.4
        if statementTable.find(token,prc,sp) then
            begin
                 savetoken(svcp);
                 gettoken;
                 p:=prc(prev,eld);
                 if (sp=terminal) then
                    restoretoken(svcp)
                 else
                    nextline;
            end
        else if (token='') then
            begin
              p:=LabelStatement(prev,eld);
              nextline
            end
        else
            begin
               p:=tryLETst(prev,eld);
               IF p<>nil then
                  nextline
               else
                  s:=false   ;
            end;
    end;

    if (p<>nil) and (sp<>terminal) then
      try
         if pass=1 then
            statement(p,p.eldest).free   //メモリの断片化防止
         else
            Last(p).next:=statement(p,p.eldest);
      except
         p.free;
         raise
      end;
   statement:=p;
end;

function block(prev:TStatement):TStatement;
var
    p:TStatement;
begin
   inc(indent);
   p:=statement(prev,nil);
   block:=p;
   dec(indent);
end;

{**************}
{last statement}
{**************}

function last(p:TStatement):TStatement;
 begin
            if p=nil then
               last:=nil
            else if p.next=nil then
               last:=p
            else
               last:=last(p.next)
 end;


{*******}
{routine}
{*******}

procedure MaxLenDeclaration(sp:SetOfTokenSpec; var maxlen:integer);
var
  c1:integer;
  n:number;
begin
  if (sp=[SIdf]) and (token='*') then
     begin
          gettoken;
          NumericConstant(n);
          maxlen:=IntegerVal(n,c1);
          if c1>0 then maxlen:=maxint;
     end;
end;



var
   routineindex:integer;

function routineHeadMain:TModule;
begin
  if (pass=1) then
     begin
       result:=TModule.create('',#0);
       CurrentProgram.add(result);
     end
  else
    begin
       result:=TModule(currentprogram.items[routineindex]);
       inc(routineindex);
    end;
end;



procedure RoutineHead(var routine:TProgramUnit; insideModule:boolean);
var
   name:AnsiString;
   name2:AnsiString;
   index:integer;
   maxlen:integer;
   kind:char;
begin
  kind:=PrevToken[1]; if (kind='P') and (PrevToken[2]='A') then kind:='A';
  name:=GetIdentifier;

  if insideModule then
      name2:=curmodule.name+'.'+name
  else
      name2:=name;

  maxlen:=maxint;
  MaxlenDeclaration([prevTokenSpec],maxlen);

  if (pass=1) then
    begin
      if CurrentProgram.search(name2,index) then
             seterr(s_DuplicaltedRoutineName,IDH_FUNCTION) ;

      if kind='M' then
            routine:=TModule.create(name,'M')
      else
            routine:=TProgramUnit.create(name2,kind,maxlen,CurModule);

      if (kind='F') or (kind='D') then
         begin
            Routine.ResultVar:=TIdRec.initpF(name,maxlen);
         end;

      CurrentProgram.add(routine);

    end
  else
    begin
            routine:=TProgramUnit(currentprogram.items[routineindex]);
            inc(routineindex);
    end;
end;

function routineHeadLocal:TLocalProc;
var
   name:AnsiString;
   name2:AnsiString;
   index:integer;
   maxlen:integer;
   kind:char;
begin
  result:=nil;
  kind:=PrevToken[1];
  name:=GetIdentifier;


  name2:=programunit.name+'.'+name;

  maxlen:=maxint;
  MaxlenDeclaration([prevTokenSpec],maxlen);

  if (pass=1) then
    begin
      if CurrentProgram.search(name2,index) then
             seterr(s_DuplicaltedRoutineName,IDH_FUNCTION) ;

      if kind='D' then
         result:=TDEF.create(name2,kind,maxlen)
      else if kind='H' then
         result:=THANDLER.create(name2,kind)
      else
         result:=TLocalProc.create(name2,kind,maxlen);

      CurrentProgram.add(Result);

      if kind in ['F','D'] then
         begin
            result.ResultVar:=TIdRec.initpF(name,maxlen);

            // EXTERNAL FUNCTION宣言をテスト　                         //2007.3.30　
            if ProgramUnit.ExternalVarTable.search2('',name,index)then
                         seterr(name+s_IsDeclaredAsExternalFunction,IDH_FUNCTION);

            with programunit.VarTable do
              if not search(name,index) then
                 add(TIdrec.initF('',name,intern))
              else
                 if TIdRec(items[index]).dim<>-1 then
                         seterr(name+s_DuplicatedVariableName,IDH_FUNCTION)
                 else if TIdRec(items[index]).tag=extern then
                         seterr(name+s_IsDeclaredAsExternalFunction,IDH_FUNCTION)
                 else if TIdRec(items[index]).tag=undeterm then
                         TIdRec(items[index]).tag:=intern;
        end;
    end
  else
    begin
            result:=TLocalProc(currentprogram.items[routineindex]);
            inc(routineindex);
    end;
end;

function ValidUrgency(i:integer):TUrgency;
begin
  result:=i;
  if (i<Low(Turgency)) or (High(Turgency)<i) then seterr(s_Urgency,0);
  if (i=1) and not AllowUrgency1 then  seterr(s_Urgency1,0);
end;

procedure TRoutine.MakeParameter;
var
   //paramcount:integer;
   index:integer;
   nam:AnsiString;
   dim:shortint;
   c:integer;
begin
  {parameters}
  paramcount:=0;
  if kind in [#0,'F','S','P','D'] then
    if token='(' then
       begin
           gettoken;
           repeat
              inc(paramcount);
             if (kind in ['S','P']) and test('#') then
                  begin
                     if (tokenspec=Nrep)
                         and (pos ('.',token)=0) and (pos ('E',token)=0)
                         and not isZero(@tokenValue) then
                        begin
                           while token[1]='0' do delete(token,1,1);
                           nam:=prevtoken+token;
                           gettoken;
                           if pass=1 then
                             with VarTable do
                               if not search(nam,index) then
                                   add(TIdRec.initpCh(nam))
                               else
                                   seterr(s_DuplicatedParameter+nam,IDH_FUNCTION)  ;
                        end
                       else
                           seterrExpected(s_Integer,IDH_FILE);
                  end
            else
                begin
                 nam:=getidentifier;
                 if test('(') then
                     begin
                        dim:=1;
                        while test(',') do inc(dim);
                        check(')',IDH_FUNCTION);
                        if pass=1 then
                           with VarTable do
                              if not search(nam,index) then
                                    add(TIdRec.initpA(nam,dim))
                              else
                                    seterr(s_DuplicatedParameter+nam,IDH_FUNCTION) ;
                     end
                 else
                     if pass=1 then
                           with VarTable do
                              if not search(nam,index) then
                                 add(TIdRec.initpSimple(nam))
                              else
                                    seterr(s_DuplicatedParameter+nam,IDH_FUNCTION)  ;
               end;
            until test(',')=false;
            check(')',IDH_FUNCTION);
       end;
   if kind='A' then
        if token='URGENCY' then
           begin
               gettoken;
               ProgramUnit.urgency:=ValidUrgency(IntegerVal(Tokenvalue, c));
               gettoken;
           end;                     ;
   if test(',') then
       begin
         case Kind of
         'P':
           begin
            check('NOBEAMOFF',IDH_PICTURE);
            NoBeamOff:=true;
           end;
         'F','S':
           begin
              if token='CALLBACK' then
                if (self is TProgramUnit) and not(self is TModule) then
                  begin
                    gettoken;
                    CallBack:=PrepareCallBack;
                    if test(',') then
                      begin
                        if token='CDECL' then
                          cdecl:=true
                        else if token='STDCALL' then
                          cdecl:=false;
                        gettoken;
                      end
                  end
                else
                  seterr('Internal procedures can not be CallBack',IDH_DLL);
             end;
         end;
       end;

end;

procedure checktoken2(const c:AnsiString; hc:integer);
begin
    if token=c then
        gettoken
    else if OutOfText then
         begin
            if not permitMicrosoft
               and (autocorrect[ac_end]
                      or confirm(c+s_IsExpected+s_ConfirmInsert,hc)) then
               inserttext(c)
            else                     //2022.1.3
               seterrExpected(c,hc)  //2022.1.3
         end
    else
           seterrIllegal(token,hc)
end;

procedure setPrecisionMode(precMode:tpPrecision; initial:boolean);
begin
   if (precisionmode<>precmode) or initial then
   begin
       if ProgramUnit<>MainProgram then
          MixedArithmetic:=not initial or (precisionmode<>precmode);
          
       precisionmode:=precmode;
       KeyWordTablesFreeAll;
       case PrecMode of
            PrecisionNormal:  begin SetOpModeDecimal; SwitchToDecimalMode  end;
            precisionNative:  begin SetOpModeNative;  SwitchToNativeMode   end;
            precisionComplex: begin SetOpModeNative;  SwitchToComplexMode  end;
       end;

       TableInitProcs.call;
   end;
end;

procedure KeyWordTablesFreeAll;
begin
       statementTable.freeall;
       suppliedFunctionTable.freeall;
       reservedwordTable.freeall;
end;

procedure TRoutine.routinebody;
begin
    block:=struct.block(nil);
    if (pass=2)  then
         LabelComplete;
    checktoken2('END',0);
end;

procedure TProgramUnit.routinebody;
begin
    setPrecisionMode(arithmetic, false);
    inherited routinebody ;
    if DataSeq.DataList.count=0 then
       begin
          //run:=RunWithNoData;
       end
     else
       begin
          //run:=RunWithData;
       end;
    if pass=1 then confirmArithmetic;
    if (ProgramUnit.kind='A') and (programUnit=mainProgram) then
       CheckToken('PARACT',0);
end;

procedure TModule.routinebody;
begin
   inherited routinebody;
   //ShareVartable.InitComplete
end;




{*********}
{FUNCTION }
{*********}

function PROCst(prev,eld:TStatement):TStatement;
var
   kind:string[9];
begin
  result:=nil;
  try
     if (LocalRoutine<>nil)
        or (indent>0) and (CurModule=MainProgram)
        or (indent>1)
        then seterrillegal(prevtoken,IDH_FUNCTION) ;
     if (ProgramUnit=CurModule) and (ProgramUnit<>MainProgram) then
        seterr(s_InternalRoutineCanntotbeInProcedure,IDH_MODULE);
     kind:=prevtoken;
     result:=Tstatement.create(prev,eld);
     LocalRoutine:=routineHeadLocal;
     LocalRoutine.MakeParameter;
     nextline;
     if kind[1]='H' then inc(usenest);
     LocalRoutine.routinebody;
     if kind[1]='H' then dec(usenest);
     checkToken(kind,IDH_FUNCTION);
     localroutine:=nil
  except
     result.free;
     raise
  end;
end;

procedure ExtPROCst(insideModule:boolean);
var
   SvProgramUnit:TProgramUnit;
   SvCurModule:TModule;
   kind:string[9];
begin
     kind:=prevtoken;
     SvProgramUnit:=ProgramUnit;
     SvCurModule:=CurModule;
     routineHead(ProgramUnit,insideModule);
     if ProgramUnit is TModule then
        CurModule:=ProgramUnit as TModule;
     ProgramUnit.MakeParameter;
     nextline;
     ProgramUnit.routinebody;
     checkToken(kind,IDH_FUNCTION);
     if kind='PARACT' then
        if pass=2 then
           ParactTbl.addObject(ProgramUnit.name, ProgramUnit);
     programunit:=SvProgramUnit;
     CurModule:=SvCurModule;
end;



{**************}
{when-exception}
{**************}

type
     TWhenUse=class(TWhenException)
          handler:THandler;
         constructor create(prev,eld:TStatement);
         //function ExecHandler:TStatement;override;
         // Code Gen.
         function HandlerCode:Ansistring;override;
         function BlockCode(Prelabel0,Afterlabel0:TstringList; HaveEXLINE0:boolean):AnsiString; override;
        private
      end;




function WHENst(prev,eld:TStatement):TStatement;
begin
    if usenest>0 then
           seterr(s_ProtectionBlockInsideExceptionHandler,IDH_WHEN_EXCEPTION);

    checktoken('EXCEPTION',IDH_WHEN_EXCEPTION);
    if token='USE' then
       WHENst:=TWhenUse.create(prev,eld)
    else
       WHENst:=TWhenException.create(prev,eld)
end;

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


constructor TWhenException.create(prev,eld:TStatement);
var
   dummy:integer;
begin
    inherited create(prev,eld);
    checkToken('IN',IDH_WHEN_EXCEPTION);
    nextline;
    dummy:=WhenStack.add(self);
    Block:=struct.block(self);
    checktoken1('USE',IDH_WHEN_EXCEPTION);
    nextline;
    inc(USEnest);
    with WhenStack do delete(count-1);
    dummy:=WhenUseStack.add(self);
    UseBlock:=struct.block(nil);     {1997.3.10  goto文で抜けられないように}
    dec(USEnest);
    with WhenUseStack do delete(count-1);
    checktoken1('END',IDH_WHEN_EXCEPTION);
    checktoken1('WHEN',IDH_WHEN_EXCEPTION);

    ReturnLables:=TStringList.create;
    ReturnLables.sorted:=true;
    ReturnLables.Duplicates:=dupIgnore;
    proc.HaveWhenException:=true;
end;

destructor TWhenException.destroy;
begin
   Block.free;
   UseBlock.free;
   if ReturnLables<>nil then
      with ReturnLables do begin clear;Free end;
   inherited destroy;
end;

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

constructor TWhenUse.create(prev,eld:TStatement);
var
   dummy:integer;
   name:AnsiString;
begin
    inherited TStatementcreate(prev,eld);
    checkToken('USE',IDH_WHEN_EXCEPTION);
    name:=GetIdentifier;
    if (pass=2) then
      if CurrentProgram.inquire(name,TRoutine(Handler)) then
         begin
             if handler.kind<>'H' then seterr(name+s_IsNotHandler,IDH_HANDLER);
         end
      else
         seterr('handler '+name+s_IsNotFound,IDH_HANDLER);

    nextline;
    {inc(WHENnest);}
    dummy:=WhenStack.add(self);
    Block:=struct.block(self);
    {dec(WHENnest);}
    with WhenStack do delete(count-1);
    checktoken1('END',IDH_WHEN_EXCEPTION);
    checktoken1('WHEN',IDH_WHEN_EXCEPTION);

    proc.HaveWhenexception:=true;
end;


{**************}
{END statements}
{**************}
constructor TEXIT.create(prev,eld:TStatement; t:TControlException);
begin
   inherited create(prev,eld);
   typ:=t
end;

var
  ENDline:integer=-1;

function ENDst(prev,eld:TStatement):TStatement;
begin
  if token='' then
    begin
      result:=TStatement.create(prev,eld);
      if indent>0 then
          begin
             //result.free;    1998.10.18
             if autocorrect[ac_end] and
                  confirm(s_ConfirmEndToStop,IDH_END) then
                begin
                   ReplacePrevToken('STOP');
                   result.free;    //1998.10.18
                   raise ERecompile.create('');
                end
          end
       else
          ENDline:=linenumber
    end
  else if (token='IF') or (token='SELECT')  or
       ((token='WHEN') and (eld<>nil) and (eld.previous is TWhenUse)) then
    begin
      result:=TTerminal.create(prev,eld);
      ENDline:=-1;
    end
  else
    begin
      result:=TStatement.create(prev,eld);
      ENDline:=-1;
    end;
end;
{
function ENDTABst(prev,eld:TStatement):TStatement;
begin
   if permitMicrosoft then
      begin
         result:=STOPst(prev,eld);
         if pass=2 then
                   replacePrevtoken('END');
      end
   else
       begin
          replacePrevtoken('END');
          ENDTABst:=ENDst(prev,eld);
       end;
end;
}

{****************}
{Parallel Section}
{****************}
{
procedure FirstParallelSection;
begin
   while token='REM' do
         begin skip; nextline end;
   if token='PARACT' then
   else
      seterrIllegal(token,0);
end;
}

{*******}
{compile}
{*******}
var
   confirmedDATAst:boolean=false;

procedure ExternalProcedures;
var
    s:ansistring;
begin
   if token='MODULE' then
      begin
          FrameForm.OptionChanged:=true;  //Debug
          gettoken;
          if (pass=2)
             and ParactMain
             and not confirm(s_Paract_Module_incompati,IDH_PARACT) then
                 seterr('',IDH_PARACT);
          ExtPROCst(false);
      end
   else if token='PARACT' then
       begin
          gettoken;
          ExtPROCst(false);
      end
 else
      begin
          if pass=2 then
                checktoken1('EXTERNAL',IDH_FUNCTION)
           else if token='EXTERNAL' then
                gettoken;

           if (token='FUNCTION') or (token='SUB') or (TOKEN='PICTURE') then
              begin
                 if (pass=1) and (prevtoken<>'EXTERNAL') and
                   confirm('EXTERNAL'+s_IsExpected+s_InquireInsert,
                                                  IDH_EXTERNAL_FUNCTION) then
                      inserttext('EXTERNAL ');

                 gettoken;
                 ExtPROCst(false);
              end
           else if (Token='END') and (nexttoken='')          //2018.09.05
                and (LineNumber=MemoLineCount-1)  then
              begin
                replacetoken('') ;
                GetToken;
              end
           else if permitMicrosoft and (ENDLine>0)  then
             begin
                  s:=texthand.GetMemoLine(ENDline);
                  insert(#9,s,pos('END',uppercase(s))+3);
                  texthand.setmemoLine(ENDline,s);
                 raise ERecompile.create('');
             end
           else if (token='DATA') and (ENDline>0) and (confirmedDATAst or
              confirm(s_ConfirmMoveDataLIne,IDH_END)) then
              begin
               //with texthand do
                   begin
                      s:=getMemoLine(ENDline);
                      deleteMemoLine(ENDline);
                      insertMemoLine(linenumber,s);
                   end;
               confirmedDATAst:=true;
               raise ERECompile.create('');
              end
          else if prevtoken<>'EXTERNAL' then
             if (ENDline>0) and (labelNumber>0) and
                 autocorrect[ac_end] and confirm(s_ConfirmEndToStop2,IDH_END) then
               begin
                  s:=texthand.getMemoline(ENDline);
                  insert('STOP !',s,pos('END',uppercase(s)));
                  texthand.setMemoLine(ENDline,s);
                 raise ERecompile.create('');
               end;
          end;
end;

procedure compile;
begin

  {main}
     routineindex:=0;
     linenumber:=-1;
     labelnumber:=0;
     RecentLabelNumber:=0;
     trying:=0;
     initline;
     CurModule:=nil;
     programunit:=nil;
     localroutine:=nil;
     MainProgram:=routineHeadMain;
     CurModule:=MainProgram ;
     programunit:=MainProgram;
     nextline;
     //if ParactMain then FirstParallelSection;
     MainProgram.routinebody;
     ProgramUnit:=nil;

  {external procedures}
     repeat
        labelnumber:=0;
        RecentLabelNumber:=0;
        NextLineGlobal;
        if token='' then break;
        while token='REM' do
           begin skip; NextLineGlobal; end;
        while token='MERGE' do
           begin MergeFile; NextLineGlobal; end;
        ExternalProcedures;
     until false;

end;

{******************}
{Control Exceptions}
{******************}

constructor EExitHandler.create(when1:TWhenException);
begin
  inherited create;
  When:=when1;
end;

constructor EExitdo.create(St:TStatement);
begin
  inherited create;
  NextSt:=st
end;

{*********}
{GOTO }
{*********}

constructor TGOTO.create(prev,eld:TStatement);
var
    long:longint;
    dummy:integer;
    routine:TRoutine;
begin
    inherited create(prev,eld);
    if nonnegativeintegralnumber(long) and (long>0) then
         numb:=long
    else
          seterrexpected(s_LineNumber,IDH_JIS_8);
    if pass=2 then
       begin
          routine:=localroutine;
          if routine=nil then routine:=programunit;
          dummy:=routine.GotoList.add(self);
       end;
end;



{********}
{ PARACT }
{********}
function PARACTst(prev,eld:TStatement):TStatement;
var
    c:integer;
begin
   //if not ParactMain then
   //  begin
   ParactMain:=true;
   //  raise ERecompile.create('');
   //  end;

   if (CurModule=nil) or (CurModule.kind<>'A') and not(ProgramUnit=MainProgram) then
           seterrIllegal(PrevToken,IDH_PARACT);
   if (eld=nil) or (prev is TProgram) then
   else
        if (pass=1) then
           seterrIllegal(PrevToken,IDH_PARACT);
   if pass=1 then
     with ProgramUnit do
      if   (PROGRAMStatement=nil) and (VarTable.Count>0)
        or (PROGRAMStatement<>nil) and (VarTable.count>PROGRAMStatement.params.Count)
        or (ExternalVarTable.count>0)
        or (ExternalSubTable.count>0)
        or (DataSeq.DataList.Count>0)
        or (ImageList.count>0)
        or (optionArithmet<>APNone)
        or (optionAngle<>APNone)
        or (OptionBase<>APNone)
        or (OptionCollate<>APNone)
        or DimAppeared
        or HaveChannelExpression
        or haveTraceSt then
        seterrIllegal(PrevToken,IDH_PARACT);

   PARACTst:=nil;
   ProgramUnit.kind:='A';
   ProgramUnit.name:=token;
   if pass=2 then ParactTbl.addObject(token, ProgramUnit);
   gettoken;
   if token='URGENCY' then
     begin
         gettoken;
         ProgramUnit.urgency:=IntegerVal(Tokenvalue, c) ;
         gettoken;
     end;
end;

{********}
{EXTERNAL}
{********}
function EXTERNALst(prev,eld:TStatement):TStatement;
begin
   if (ProgramUnit<>nil) and ((ProgramUnit=MainProgram)or not (ProgramUnit is TModule)) then
           seterrIllegal(PrevToken,IDH_FUNCTION);

   EXTERNALst:=nil;
   if (token='FUNCTION') or (token='SUB') or (TOKEN='PICTURE') then
     begin
        gettoken;
        ExtPROCst(true);
     end
end;


type PWord=^word;

function ExtypeOf(p:pointer):integer;
var
  opcode:word;
begin
    opcode:=Pword(p)^;
    if (opcode=$7cdc) or  (opcode=$fadc) then
       result:=3001
    else if (opcode and $30FF) = $10DB then
       result:=2001
    else
       result:=3000;
end;


function TStatement.insideofwhen:LongBool;
begin
   insideofWhen:=LongBool(WhenBlock)
end;



procedure DoNothing;
begin
end;



{****************}
{TProcsCollection}
{****************}
procedure TProcsCollection.accept(f:proc);
begin
    insert(@f)
end;

procedure TProcsCollection.call;
var
   i:integer;
   f:proc;
begin
   for i:=0 to count-1 do  begin  @f:=items[i];
                                                 f end
end;


procedure TProcsCollection.freeItem(item:pointer);
begin
   { do nothing}
end;

{*************}
{Gerenate Code}
{*************}

var
   RecentLineNumb:integer;





function LabelNumbers:Ansistring;
begin
  if EXLINEAppear then
     result:=textHand.LabelNumbers
  else
     result:=''
end;

function ThreadPriorityCode(i:integer):AnsiString;
begin
     result:= TThreadpriorityLiteral[ValidUrgency(i)];
 end;


const
UnitHeader='unit basicunit;'+EOL
+'{$mode delphi} {$H+}'+EOL
+'interface'+EOL
+'uses  Classes, SysUtils;'+EOL
+'Procedure ModulesInit;'+EOL
+'Procedure ModulesDone;'+EOL
+'procedure BASICmain;'+EOL;



const
 DefaultUsesBlock='uses Forms, math, graphics,'+EOL
 {$IFDEF windows}+' windows,winlib,'+EOL {$ENDIF}
 {$IFDEF Unix}+' Unix,dl,'+EOL {$ENDIF}
+'  base,base2,textfrm,textfile,arrays,affine,graphsys,'+EOL
+'  math2sub,datalist,baslib,graphlib,debugdg,paintfrm,'+EOL
+'  MyThread,assignlib,';

function  TProcTbl.Code:AnsiString;
var
  i,i0,i1:integer;
  r:TRoutine;
  rr:TprogramUnit;
  Locals:AnsiString;
  UsesBlock:Ansistring;
  Body:AnsiString;
  Forwarddecl:Ansistring;
  PublicDecl:String;
  PrgName:string;
  ModuleDecls,ModuleImpls,ModuleInits,ModuleDones:TStringList;
  //VirtualStackSize,
  SystemStackSize:int64;
  signiwidthRT:integer;
  AppName:Ansistring;
  ProgramUsesBlock:AnsiString;
  ComplexUsesBlock:AnsiString;
  DecimalUsesBlock:AnsiString;

  ExternalSection:Ansistring;   // External Procedures and Modules
  ModulesInitSection:Ansistring;
  MainProgramSection:AnsiString;
  InitializationSection:Ansistring;
  ConstSection:ansistring;
  ModulesSection:Ansistring;

begin
  AppName:=ChangeFileExt(ProgramOnRunning,'');   //FrameForm.OpenDialog1.FileName;

  if TargetCPU64 then
     begin
         //VirtualStackSize:=VirtualStackSize64;
         SystemStackSize:=SystemStackSize64;
     end
  else
     begin
         //VirtualStackSize:= VirtualStackSize32;
         SystemStackSize:=SystemStackSize32;
     end;

   if signiwidthmore then
      signiwidthRT:=17
   else
     {$IFEDF Windows}
     If TargetCPU64 then
        signiwidthRT:=13
     else
     {$END}
        signiwidthRT:=15;

   ConstSection:=
   'Const DrawTimeInterval='+DrawTimeIntervalLiteral[DrawTimeIntervalIndex]+';'+EOL+
   'Const DrawStartDelay='+DrawTimeIntervalLiteral[DrawTimeIntervalAheadIndex]+';'+EOL;

 InitializationSection:=EOL
 +'initialization'+EOL
 // +'  AppName:='''+AppName+''';'+EOL
 +'  AppName:='+AnsiQuotedStr(AppName,'''')+';'+EOL               //ver.2.1.4.1
 +'  SystemStackSize := '+inttostr(SystemStacksize)+';'+EOL
// +'  VirtualStackSize:='+IntToStr(VirtualStackSize)+';'+EOL
 +'  signiwidth0:='+IntToStr(signiWidthRT)+';'+EOL
 +'  TextMode :='+TruthLiteral(base0.TextMode)+';'+EOL
 +'  GraphMode:='+TruthLiteral(base0.GraphMode)+';'+EOL
 +'  BMPSize:='+BMPSizeLiteral[BMPsize]+';'+EOL
 +'  InitialBeamMode:='+Truthliteral(InitialBeamMode)+';'+EOL                 //ver.1.2.2
 //+'  TextProblemCoordinate:='+Truthliteral(TextProblemCoordinate)+';'+EOL   //ver.1.2.2
 +'  UseCharInput:='+Truthliteral(UseCharInput)+';'+EOL
 +'  FontCharSet:='+IntToStr(PaintFont.CharSet)+';'+EOL
 +'  FontSize:='+IntToStr(PaintFont.Size)+';'+EOL
 +'  FontName:='+''''+PaintFont.Name+''''+';'+EOL
 +'  FontStyle:=[];'+EOL
 +'  FirstThreadPriority:='+ThreadPriorityCode(TModule(items[0]).urgency)+';'+EOL;
 if  (TargetCPU64 and OldDialog64) or (not TargetCPU64 and OldDialog32) then
   InitializationSection:=InitializationSection
   +'   OldFileDialog:=true;'+EOL;
 {
 InitializationSection:=InitializationSection
   +'   AllThreadsList:=TAllThreadsList.create;'+EOL
   +'   BASICThread0 := TBASICFirstThread.Create('
   +ThreadPriorityCode(TModule(items[0]).urgency)
   +',SystemStackSize);'+EOL;
 }
 if ParactTbl.Count>=2 then
   for i:=1 to ParactTbl.Count-1 do
     InitializationSection:=InitializationSection
   + '  BASICThread'+inttostr(i)+ ' := nil;'+EOL;

  ModuleDecls:=TstringList.create;
  ModuleImpls:=TstringList.create;
  ModuleInits:=TStringList.create;
  ModuleDones:=TStringList.create;

  if EXTYPEAppear then
    begin
      ProgramUsesBlock:= DefaultUsesBlock  +' mathlib';
      ComplexUsesBlock:= DefaultUsesBlock  + EOL
                         +' mathc,arraysc,baslibc,graphlibc,'+EOL
                         +' mathlibc, mathlib';
      DecimalUsesBlock:= DefaultUsesBlock  +EOL
                         +' mathlib,arithmet,mathd,Arraysd,baslibd,graphlibd';
    end
  else
    begin
      ProgramUsesBlock:= DefaultUsesBlock  +' mathlib0';
      ComplexUsesBlock:= DefaultUsesBlock  + EOL
                         +' mathc,arraysc,baslibc,graphlibc,'+EOL
                         +' mathlib0c, mathlib0';
      DecimalUsesBlock:= DefaultUsesBlock  +EOL
                         +' mathlib0,arithmet,mathd,Arraysd,baslibd,graphlibd';
    end;

  if OptimizeInteger then
    begin
     ProgramUsesBlock:=ProgramUsesBlock+' ,intlib';
     ComplexUsesBlock:=ComplexUsesBlock+' ,intlib';
    end;

  UsesBlock := ProgramUsesBlock;  // Use部の決定
  i:=0;
  while (i<Count) do
  begin
     r:=TRoutine(items[i]);
     if (r is TProgramUnit)
       and (TProgramUnit(r).arithmetic=PrecisionComplex) then
        UsesBlock:=ComplexUsesBlock
     else if (r is TProgramUnit)
       and (TProgramUnit(r).arithmetic=PrecisionNormal) then
        UsesBlock:=DecimalUsesBlock ;
     inc(i)
  end;

  Locals:='';
  result:='';
  Forwarddecl:='';
  RecentLineNumb:=-1;

   CurModule:=TModule(items[0]);    //主プログラム
  //　主プログラムの内部手続きのforward宣言の作成
  r:=TRoutine(items[0]);
  i:=1;
  while (i<count)
     and  (TObject(items[i]) is TLocalProc)
     and  (TlocalProc(items[i]).parent = r) do
     begin
       Locals:=Locals
             + TlocalProc(items[i]).headerCode(false) +'overload; forward;'  +EOL ;
       inc(i);
     end;
  // 主プログラムの内部手続きの定義部本体
  i:=1;
  while (i<count)
     and  (TObject(items[i]) is TLocalProc)
     and  (TlocalProc(items[i]).parent = r) do
     begin
       Locals:=Locals
             + TlocalProc(items[i]).Code;
       inc(i);
     end;

  i1:=i;
  // 外部手続きのforward宣言
  while i<count do
    begin
        r:=TRoutine(items[i]);
        if r is TModule then
          begin
             inc(i);
             //モジュール内の外部手続きを読み飛ばす
               while (i<count)
                   and  (TObject(items[i]) is TProgramUnit)
                   and  (TProgramUnit(items[i]).parent = r) do
                   begin
                     rr:=TProgramUnit(items[i]);
                     inc(i);
                     //外部手続きrr内の内部手続きを読み飛ばす
                     while (i<count)
                         and  (TObject(items[i]) is TLocalProc)
                         and  (TlocalProc(items[i]).parent = rr) do
                         begin
                           inc(i);
                         end;
                   end;

          end
        else  if r is TProgramUnit then
          begin
               ForwardDecl:=ForwardDecl + r.HeaderCode(false) +'overload; forward;' + EOL;
               inc(i);
               //外部手続きの内部手続きを読み飛ばす
               while (i<count)
                   and  (TObject(items[i]) is TLocalProc)
                   and  (TlocalProc(items[i]).parent = r) do
                   begin
                     inc(i);
                   end;
          end;
    end;

  // 外部手続きの定義部本体
  i:=i1;
  while i<count do
    begin
        r:=TRoutine(items[i]);
        if r is TModule then
           ModuleCode(i,ModuleDecls,ModuleImpls,ModuleInits, ModuleDones)
        else  if r is TProgramUnit then
          begin
               body :='begin'+EOL
                     +'{$MAXFPUREGISTERS 0}'+EOL
                     + r.BodyCode+ 'end;' + EOL + r.CallBackCode;      // BodyCodeを先に評価する
               result:=result + r.HeaderCode(false)  +' overload;'+EOL
                              + r.LocalVariablesLiteral;
               inc(i);
               i0:=i;
               //内部手続きのforward宣言作成
               while (i<count)
                   and  (TObject(items[i]) is TLocalProc)
                   and  (TlocalProc(items[i]).parent = r) do
                   begin
                     result:=result
                           + TlocalProc(items[i]).headerCode(false) +'overload; forward;' +EOL ;
                     inc(i);
                   end;
               i:=i0;
                //内部手続きの本体部作成
               while (i<count)
                   and  (TObject(items[i]) is TLocalProc)
                   and  (TlocalProc(items[i]).parent = r) do
                   begin
                     result:=result
                           + TlocalProc(items[i]).Code;
                     inc(i);
                   end;
               result := result + body;
          end;
    end;

   // 主プログラム

   CurModule:=TModule(items[0]);
   Body := TRoutine(items[0]).BodyCode;    // BodyCodeを先に評価する
   (*
   //第2スレッド以降の終了を待つコードを主プログラムの末尾に追加する
   with ParactTbl do
      if count>1 then
          for i:=1 to count-1 do
            Body:=Body
                +'   if BASICThread'+inttostr(i)+'.suspended then '+EOL
                +'   else'+EOL
                +'      BASICThread'+inttostr(i)+'.WaitFor;'+EOL;
   *)

   PublicDecl:=TModule(items[0]).ShareVartable.PublicVariablesLiteral;
   if PublicDecl<>'' then
      PublicDecl:='var'+EOL
                  +PublicDecl;

   // プログラム名
   if TModule(items[0]).Name=''  then
      PrgName:='NoName'
   else
      PrgName:=TModule(items[0]).NameCode;

   // Modules  本体
   //ModulesSection:='';
   //if ModuleDecls.Count>0 then
   ModulesSection:=
              ModuleDecls.text
           +  ModuleImpls.text
           + EOL
           +'(* Modules initialize and dispose *)' +EOL
           +'Procedure ModulesInit;'+EOL
           +'begin'+EOL
           + ModuleInits.text
           +'end;'+EOL
           +'Procedure ModulesDone;'+EOL
           +'begin'+EOL
           + ModuleDones.text
           +'end;'+EOL
           +EOL  ;

   // プログラム全体
   result:= UnitHeader +EOL
           +ConstSection+EOL
           +'implementation'+EOL
           +UsesBlock+';'+EOL
           +'{$MAXFPUREGISTERS 0}'+EOL    //FPUレジスタを使わない
           +  SignalList.VarCode+EOL
           +  StructureDefs.Code+EOL
           +  ShareMessDefs.Code+EOL
           +  NamedSeizeList.DeclCode+EOL
           +  LabelNumbers
           +  DebugVariables.text

           +  ExternalDLLs.code

           +  PublicDecl
           +  ForwardDecl
           +  ModulesSection
           +  result
           +'(* Main Program *)'+EOL
           +'procedure BASICmain;' +EOL
           +  TRoutine(items[0]).LocalVariablesLiteral
           +  Locals
           +'begin'+EOL
           +  Body
           +'end;{end main}'
           +InitializationSection
           + ShareMessDefs.InitCode+EOL
           + NamedSeizeList.initcode+EOL
           + SignalList.IniCode+EOL
           +'Finalization'+EOL
           + SignalList.DestroyCode+EOL
           + ShareMessDefs.FinaCode+EOL
           + NamedSeizeList.Finacode+EOL
           +'end.';



 with ModuleDecls do begin clear;free end;
 with ModuleImpls do begin clear;free end;
 with ModuleInits do begin clear;free end;
 with ModuleDones do begin clear;Free end;
end;


procedure TProcTbl.ModuleCode(var i:integer; Decls, impls, inits, dones: TStringList);
var
   r:TRoutine;
   m:TModule;
   u:TProgramUnit;
  Decl:Ansistring;
  i1,i0:integer;
  j:integer;
  body:Ansistring;
  impl:ansistring;
  svCurModule:TModule;
begin

   svCurModule:=CurModule;
   m:=TModule(items[i]);
   CurModule:=m;
   //モジュールコードの生成
   Decl:=  '{$static on}'+EOL
          +'type t' +m.namecode+'=object'+EOL
          +'Public'+EOL
          +  m.ShareVartable.PublicVariablesLiteral
          +' procedure init;'+EOL
          +' procedure done;'+EOL ;

   inc(i);
   i1:=i;
   //モジュール内の外部手続きの一覧を作成
   while (i<count)
       and  (TObject(items[i]) is TProgramUnit)
       and  (TProgramUnit(items[i]).parent = m) do
       begin
         u:=TProgramUnit(items[i]);
         Decl:=Decl
              +u.HeaderCode(false) + EOL;
         inc(i);
         //外部手続きrr内の内部手続きを読み飛ばす
         while (i<count)
             and  (TObject(items[i]) is TLocalProc)
             and  (TlocalProc(items[i]).parent = u) do
             begin
               inc(i);
             end;
       end;

   decl:=decl
        +'private'+EOL
        +  m.ShareVarTable.ShareVariablesLiteral
        +' ModuleChannelList:TChannelList;'+EOL     // SHARE CHANNEL を管理する
        +'end;'+EOL
        +'var '+m.namecode+': t'+m.namecode+';';


   impl:='';
   i:=i1;
   //モジュール内の外部手続き
   while (i<count)
       and  (TObject(items[i]) is TProgramUnit)
       and  (TProgramUnit(items[i]).parent = m) do
       begin
         u:=TProgramUnit(items[i]);
         body :='begin'+EOL
               + '{$MAXFPUREGISTERS 0}'+EOL
               + u.BodyCode+ 'end;' + EOL + u.CallBackCode;
         impl:=impl + u.HeaderCode(m<>MainProgram) +EOL
                        + u.LocalVariablesLiteral;
         inc(i);
         i0:=i;
         //内部手続きのforward宣言作成
         while (i<count)
             and  (TObject(items[i]) is TLocalProc)
             and  (TlocalProc(items[i]).parent = u) do
             begin
               impl:=impl
                     + TlocalProc(items[i]).headerCode(false) +'overload; forward;' +EOL ;
               inc(i);
             end;
         i:=i0;
          //内部手続きの本体部作成
         while (i<count)
             and  (TObject(items[i]) is TLocalProc)
             and  (TlocalProc(items[i]).parent = u) do
             begin
               impl:=impl
                     + TlocalProc(items[i]).Code;
               inc(i);
             end;
         impl := impl + body;
       end;

     // モジュール本体
     body:= 'begin'+EOL
           +'ModuleChannelList:=TChannelList.create;'+EOL
           +m.BodyCode + 'end;' + EOL
           +'procedure  t'+ m.nameCode+  '.done;' +EOL
           +'begin'+EOL
           +'ModuleChannelList.free;'+EOL
           + m.ShareVariablesFinalizeCode
           +'end;'  ;
     body:= 'procedure t'+ m.nameCode+  '.init;' +EOL
          +  m.LocalVariablesLiteral
          +body;

    impl :=  impl
          +  body;

    decls.add(decl);
    impls.add(impl);
    inits.add(m.namecode+'.init;');
    dones.add(m.namecode+'.done;');

    CurModule:=svCurModule;
end;

function TIdTable.ParametersLiteralFunc:AnsiString;
var
   i:integer;
begin
  result:='';
  for i:=0 to count-1 do
    begin
      with TIdRec(items[i]) do
        if prm then
           begin
              case kindchar of
               'n':
                  if subs is TCVari then
                    case dim of
                      0: result := result + literal +':Complex';
                      1: result := result + literal +':TArray1C';
                      2: result := result + literal +':TArray2C';
                      3: result := result + literal +':TArray3C';
                      4: result := result + literal +':TArray4C';
                      else ;
                    end
                  else if subs is TFVari then
                       case dim of
                         0: result := result + literal +':double';
                         1: result := result + literal +':TArray1N';
                         2: result := result + literal +':TArray2N';
                         3: result := result + literal +':TArray3N';
                         4: result := result + literal +':TArray4N';
                         else ;
                       end
                  else if subs is TNVari then
                    case dim of
                      0: result := result + literal +':Number';
                      1: result := result + literal +':TArray1D';
                      2: result := result + literal +':TArray2D';
                      3: result := result + literal +':TArray3D';
                      4: result := result + literal +':TArray4D';
                      else ;
                    end           ;
               's': case dim of
                      0: result := result + literal +':Ansistring';
                      1: result := result + literal +':TArray1S';
                      2: result := result + literal +':TArray2S';
                      3: result := result + literal +':TArray3S';
                      4: result := result + literal +':TArray4S';
                      else ;
                    end;
               'c': ;
              end;
              result:=result + '; ';
           end;
    end;
      if length(result)>0 then
         result:='(' + copy(result,1,length(result)-2)   +')';
end;

function TIdTable.ParametersLiteralSub:AnsiString;
var
   i:integer;
begin
  result:='';
  for i:=0 to count-1 do
    begin
      with TIdRec(items[i]) do
        if prm then
           begin
              case kindchar of
               'n':
                   if subs is TCVari then
                    case dim of
                      0: result := result + 'var ' + literal + ':Complex';
                      1: result := result + literal + ':TArray1C';
                      2: result := result + literal + ':TArray2C';
                      3: result := result + literal + ':TArray3C';
                      4: result := result + literal + ':TArray4C';
                      else ;
                    end
                   else if subs is TFVari then
                        case dim of
                          0: result := result + 'var ' + literal + ':double';
                          1: result := result + literal + ':TArray1N';
                          2: result := result + literal + ':TArray2N';
                          3: result := result + literal + ':TArray3N';
                          4: result := result + literal + ':TArray4N';
                          else ;
                        end
                   else if subs is TNVari then
                        case dim of
                          0: result := result + 'var ' + literal + ':Number';
                          1: result := result + literal + ':TArray1D';
                          2: result := result + literal + ':TArray2D';
                          3: result := result + literal + ':TArray3D';
                          4: result := result + literal + ':TArray4D';
                          else ;
                        end   ;
               's': case dim of
                      0: result := result + 'var ' + literal + ':Ansistring';
                      1: result := result + literal + ':TArray1S';
                      2: result := result + literal + ':TArray2S';
                      3: result := result + literal + ':TArray3S';
                      4: result := result + literal + ':TArray4S';
                      else ;
                    end;
               'c': result := result + literal + ':TDeviceRef';
              end;
              result:=result+'; '
           end;
    end;
      if length(result)>0 then
         result:='(' + copy(result,1,length(result)-2)   +')';
end;

function TIdTable.LocalVariablesLiteral:AnsiString;
var
   i:integer;
begin
  result:='';
  for i:=0 to count-1 do
    begin
      with TIdRec(items[i]) do
        if not prm then
          case kindchar of
           'n','s': if dim>=0  then
                result := result + 'var ' + LiteralWithType(true) + ';' +EOL;
          end;
    end;
 end;

function TIdTable.ShareVariablesLiteral:AnsiString;
var
   i:integer;
begin
  result:='';
  for i:=0 to count-1 do
    begin
      with TIdRec(items[i]) do
        if not prm and (tag =IDShare) then
          case kindchar of
           'n','s': if dim>=0  then
                result := result + LiteralWithType(false) + ';' +EOL;
          end;
    end;
 end;

function TIdTable.ShareChannelHandoverCode:AnsiString;
var
   i:integer;
begin
  result:='';
  for i:=0 to count-1 do
    begin
      with TIdRec(items[i]) do
        if not prm and (tag =IDShare) then
          case kindchar of
           'c':result:=result+'ChannelList.SetRefference('+copy(name,2,length(name)-1)
              +',TDeviceRef.create(ModuleChannelList,'+copy(name,2,length(name)-1)+'));'+EOL;
          end;
    end;
 end;

function TIdTable.PublicVariablesLiteral:AnsiString;
var
   i:integer;
begin
  result:='';
  for i:=0 to count-1 do
    begin
      with TIdRec(items[i]) do
        if not prm and (tag = IdPublic) then
          case kindchar of
           'n','s': if dim>=0  then
                result := result + LiteralWithType(false) + ';' +EOL;
          end;
    end;
 end;

function TIdTable.ArraysInitializeCode:AnsiString;
  function TailChar(kindchar:char; subs:TSubstance):char;
  begin
     case kindchar of
     'n': if subs is TCVari then
           result:='C'
          else if subs is TNVari then
           result:='D'
          else if subs is TFVari then
           result:='N';
      's': result:='S';
     end;
  end;

var
   i:integer;
begin
  result:='';
  for i:=0 to count-1 do
    begin
      with TIdRec(items[i]) do
        if (KindChar='c') and (tag<>IdShare) then            // Channel
           result:='ChannelList.SetRefference('+copy(name,2,length(name)-1)+','+Literal+');'+EOL
        else if not prm then
           case dim of
             1: result := result
                      +  literal + ':=TArray1' + TailChar(kindchar, subs) + '.create('
                      +  strint(Lbound[1]) + ',' + strint(Ubound[1]) + ');' +EOL;
             2: result := result
                      +  literal + ':=TArray2' + TailChar(kindchar, subs) + '.create('
                      +  strint(Lbound[1]) + ',' + strint(Ubound[1]) + ','
                      +  strint(Lbound[2]) + ',' + strint(Ubound[2]) + ');' +EOL;
             3: result := result
                      +  literal + ':=TArray3' + TailChar(kindchar, subs) + '.create('
                      +  strint(Lbound[1]) + ',' + strint(Ubound[1]) + ','
                      +  strint(Lbound[2]) + ',' + strint(Ubound[2]) + ','
                      +  strint(Lbound[3]) + ',' + strint(Ubound[3]) + ');' +EOL;
             4: result := result
                      +  literal + ':=TArray4' + TailChar(kindchar, subs) + '.create('
                      +  strint(Lbound[1]) + ',' + strint(Ubound[1]) + ','
                      +  strint(Lbound[2]) + ',' + strint(Ubound[2]) + ','
                      +  strint(Lbound[3]) + ',' + strint(Ubound[3]) + ','
                      +  strint(Lbound[4]) + ',' + strint(Ubound[4]) + ');' +EOL;
           end;
    end;
end;

function TIdTable.ArraysFinalizeCode:AnsiString;
var
   i:integer;
begin
  result:='';
  for i:=0 to count-1 do
    begin
      with TIdRec(items[i]) do
        if not prm and (dim>0) then
           case kindchar of
           'n','s':  result := result
                            + literal + '.free;'+EOL ;
           end;
    end;
end;




function TRoutine.ParametersLiteral:Ansistring;
begin
 case kind of
  'D','F': result:=  VarTable.ParametersLiteralFunc ;
  'H'    : result:=  '(E:Exception; var Retry,Continue:integer; ExLineNumb:integer; ExcodeRec:LongWord)' ;
  else     result:=  VarTable.ParametersLiteralSub ;
 end;
end;

function TRoutine.LocalVariablesLiteral:Ansistring;
var
   i:integer;
begin
  result:= VarTable.LocalVariablesLiteral;
  for i:=1 to MaxNumArgDouble do
      result := result
              + 'var '+ArgNLiteral(i) + ':double;' +EOL;
  for i:=1 to MaxNumArgComplex do
      result := result
              + 'var '+ArgNLiteral(i) + ':Complex;' +EOL;
  for i:=1 to MaxNumArgNumber do
      result := result
              + 'var '+ArgNLiteral(i) + ':Number = (sig:0;exp:minexp);' +EOL;
  for i:=1 to MaxNumArgString do
      result := result
              + 'var '+ArgSLiteral(i) + ':Ansistring;' +EOL;
  if HaveMissing then
     result:=result
            +'var Missing:Boolean;'+EOL;

  if HaveWhenException  then
    result := result
            + 'var ExcodeRec:LongWord;' +EOL
            + 'var ExLineNumb:integer;' +EOL
            + 'var Retry:integer;' +EOL
            + 'var Continue:integer;' +EOL;
  result:=result+LabelsCode;
end;

function TProgramUnit.LocalVariablesLiteral:Ansistring;
begin
  result:= inherited LocalVariablesLiteral;
  if HaveChannelExpression then
    result := result
            + 'var ChannelList:TChannelList;' +EOL;
  if DataSeq.DataList.Count>0 then
     begin
       result:=result
            + 'var DataSeq:TDataSeq;' +EOL
            + DataSeq.LiteralCode ;
     end;
end;

function TRoutine.VariablesInitializeCode:Ansistring;
begin
  result:=VarTable.ArraysInitializeCode;
  if (kind='F') and (ResultVar.kindchar='n') then
     result:=Result+ 'result:=0;'+EOL;
end;


function TProgramUnit.VariablesInitializeCode:Ansistring;
begin
  result:='';
  if HaveChannelExpression then
     begin
       result := result
            + ' ChannelList:=TChannelList.create;' + EOL;
       if parent<>nil then
           result:=result+ parent.ShareVarTable.ShareChannelHandOverCode +EOL
     end;
  result := result
            +  inherited VariablesInitializeCode;
  if DataSeq.DataList.Count>0 then          // DATA statements
    result:=result
            + ' DataSeq:=TDataSeq.Create('+IntToStr(DataSeq.DataList.Count)+','
                                          + '@DataList, @DataLabels);'+EOL;
end;

function TModule.VariablesInitializeCode:Ansistring;
begin
   result:=ShareVarTable.ArraysInitializeCode+inherited VariablesInitializeCode
end;

function TModule.ShareVariablesFinalizeCode:Ansistring;
begin
   result:=ShareVarTable.ArraysFinalizeCode
end;

function TRoutine.VariablesFinalizeCode:Ansistring;
var
   i:integer;
begin
  result:=VarTable.ArraysFinalizeCode;
  // 関数のとき，値引数配列を除去する
  if kind='F' then
     with VarTable do
        for i:=0 to count -1 do
            with TIdRec(items[i]) do
               if prm and (dim>0) then result:=result + Literal + '.free;'+EOL;
end;


function TProgramUnit.VariablesFinalizeCode:Ansistring;
begin
  result:=inherited VariablesFinalizeCode;
  if HaveChannelExpression then
     result := result
            + 'ChannelList.free; ' +EOL;
  if DataSeq.DataList.Count>0 then
    result:=result
            + 'DataSeq.Free;' +EOL;
end;

function TRoutine.BodyCode:Ansistring;
var
  s:AnsiString;
begin
  result:= Block.GenCode(nil,nil,false) ;


  s:='';
  if HaveExitst then
       case kind of
        'S': s:='on EEXITSub do;'+EOL;
        'F': s:='on EEXITFunction do;'+EOL;
        'P': s:='on EEXITPicture do;'+EOL;
       end;

  if kind<>#0 then                    // 主プログラム以外
    begin
      result := 'try' + EOL
              + result
              + 'except' +EOL
              + s
              + 'on E:EMathError do begin'+EOL
      {$IFNDEF Windows}
              + '  RecoverFloatException; '+EOL
      {$ENDIF}
              + '  raise EExtype.create(PropagatedExtype( EXTYPE(E,ExCode))) end;'+EOL //伝達
              + 'on E:EDivByZero do begin'+EOL
      {$IFNDEF Windows}
              + '  RecoverFloatException; '+EOL
      {$ENDIF}
              + '   raise EExtype.create(PropagatedExtype( EXTYPE(E,ExCode))) end;'+EOL //伝達
              + 'on E:EExType do begin'+EOL
              + '   E.extype:=PropagatedExtype(E.Extype); raise end;'+EOL       //伝達
              + 'end;' +EOL;
    end;

   s:=VariablesFinalizeCode;
   if s<>'' then
      result := 'try' + EOL
              + result
              + 'finally' + EOL
              + s
              + 'end;' +EOL;

   result:= VariablesInitializeCode
          + result
end;


function TRoutine.NameCode:AnsiString;
begin
  result:=copy(name, pos('.',name)+1,length(name));
  result:=copy(result,pos('.',result)+1,length(result));
  if Copy(name,1,pos('.',name))=MainProgram.name+'.' then      // 主プログラムの内部手続き
     result:='_0'+result
  else
     result:='_'+result;

  if Pos('$',result)>0 then
     result:='s'+copy(result,1,length(result)-1);

  if (self is TProgramUnit) and not(self is TModule) and (TProgramUnit(self).parent <>MainProgram)
     and (TProgramUnit(self).parent <>CurModule) then
        result:=TProgramUnit(self).parent.namecode+'.'+result
end;

function TRoutine.HeaderCode(withModuleName:boolean):AnsiString;
var
   resultType:string;
begin
   case kind of
    'D','F':
      begin
        case ResultVar.kindchar of
          'n': if ResultVar.subs is TCVari then
                  resulttype:=':complex; '
               else if ResultVar.subs is TFVari then
                  resulttype:=':double; '
               else if ResultVar.subs is TNVari then
                  resulttype:=':Number; ';
          's': resulttype:=':string; ';
        end;
        if withModuleName then
           result:='function t'+ CurModule.NameCode+'.'+NameCode + ParametersLiteral + resulttype
        else
            result:='function '+ NameCode + ParametersLiteral + resulttype;
      end;
    'S', 'P', 'H':
        if withModuleName then
          result:='procedure t'+CurModule.NameCode+'.'+NameCode + ParametersLiteral + '; '
        else
          result:='procedure '+NameCode + ParametersLiteral + '; ';
    'A':
        result:='procedure '+nameCode + '; ';
     else
        result:='';
    end
end;

function TRoutine.LabelsCode:ansistring;
begin
  result:='';
  if LabelsList.count>0 then
     result:='Label '+LabelsList.CommaText +';'+EOL
end;

function  TRoutine.CallBackParameters:string;
var
   i:integer;
   c:integer;             //2025.09.03
begin
  result:='';
  c:=VarTable.count;
  if Kind='F' then dec(c);
  with VarTable do
    begin
      if c>0 then
        begin
          result:=result+'(';
          for i:=0 to c -1 do
            begin
              if i>0 then result:=result+'; ';
              result:=result+'a'+StrInt(i);
              case TIdRec(items[i]).kindchar of
               'n': result:=result+':NativeInt';
               's': result:=result+':PChar' ;
              end;
            end;
        result:=result+')'
      end;
    end;
end;

function TRoutine.procCallCode:string;
var
   i:integer;
   c:integer;      //2025.09.03
begin
  result:=NameCode;
  // module内のexternal procedureのときmodule名を付加する
  if (self is TProgramUnit) and not(self is TModule) and (TProgramUnit(self).parent <>MainProgram)
     and (TProgramUnit(self).parent = CurModule) then
        result:=TProgramUnit(self).parent.namecode+'.'+result ;

  c:=VarTable.count;
  if Kind='F' then dec(c);
  with VarTable do
    begin
      if c>0 then
        begin
          result:=result+'(';
          for i:=0 to c -1 do
            begin
              if i>0 then result:=result+', ';
              result:=result+'a'+StrInt(i);
            end;
        result:=result+')'
      end;
    end;
end;


function TRoutine.CallBackCode:string;
begin
  result:='';
  if CallBack<>#0 then
  begin
    case kind of
       'F': result:='function CallBack'+Callback+CallBackParameters+':NativeInt; ';
       'S': result:='procedure CallBack'+CallBack+CallBackParameters+'; ';
    end;
    if not targetCPU64 then
      if cdecl then
        result:=result+'cdecl; '
      {$IFDEF Windows}else
        result:=result+'stdcall; ' {$ENDIF};

    result:=result+EOL+'begin'+EOL;
    if kind='F' then
         result:=result+'Result:=Trunc('+ProcCallCode+')';
    result:=result+';'+EOL+'end;'+EOL
  end;
end;

function TRoutine.PrepareCallback:char;
var
   i:integer;
begin
  result:=#0;
  if (length(token)=1) and (token[1]>='0') and (token[1]<='9') then
     begin
       result:=token[1];
       i:=ord(token[1])-ord('0');
       if  Pass=1 then
         if ProcPtr[i]=nil then
            ProcPtr[i]:=self
         else
           seterr('Duplicate index',IDH_CALLBACK);
       gettoken;
     end;
end;

function TLocalProc.Code:Ansistring;
begin
  result:='begin'+EOL
         + '{$MAXFPUREGISTERS 0}' +EOL
         + BodyCode + 'end;'+EOL + CallBackCode;      //BodyCodeから先に評価する
  result:= HeaderCode(false) +'overload;'+EOL
         + LocalVariablesLiteral
         + result;

end;




function TStatement.Code:AnsiString;
begin
  result:='';
end;

function TStatement.TraceCode:Ansistring;
begin
   result:='';
   if PUnit.haveTraceSt then
       result:=result + 'if Trace' + IntToStr(PUNIT.LineNumb+1) + '<>nil then '+
       'Trace' + IntToStr(PUNIT.LineNumb+1) + '.PRINT([],rsNone, false ,[ '+
       QuotedStr(texthand.memo.lines[linenumb]) +  ', TNewLine.create ]);' + EOL;
end;

function TStatementNoTrace.TraceCode:Ansistring;
begin
   result:='';
end;


function TStatement.genCode(PreLabel,AfterLabel:TStringList; HaveEXLINE:boolean): AnsiString;
var
   s:string;
begin
  result:='';
  if self<>nil then
     begin
       if HaveBranchLabel then
          result:=inttostr(LabelNumb)+':'+EOL;

       if RecentLineNumb<>LineNumb then
          result:=result+ '//  ' + TextHand.memo.lines[linenumb] +EOL; // BASIC source code

       if (PreLabel<>nil) then
          begin
            s:='p'+IntToStr(LineNumb);
            result:=result+s+':'+EOL;
            Proc.LabelsList.add(s);
            PreLabel.add(IntToStr(LineNumb)+':begin retry:=0; goto '+s+' end;');
          end;

       if ((PreLabel<>nil) or (AfterLabel<>nil) or HaveEXLINE)
          and (RecentLineNumb<>LineNumb )
          and not (self is TWhenException)
          and not (self is TTerminal)
          and not (self.ClassType=TStatement)  then  // for RETRY , CONTINUE , EXLINE
          result:=result
                + 'ExLineNumb:='+InttoStr(LineNumb)+';'+EOL;

       RecentLineNumb:=LineNumb;

       result:=result + TraceCode;


       if self is TIFStatement then
          result:=result+BlockCode(nil,nil,false)+EOL
       else if (self is TDoStructure)
            or (self is TForStructure)
            or (self is TCustomIfStatement)
            or (self is TSelect)
            or (self is TWhenException)
            or (self is TSeize)
            then
               result:=result+BlockCode(PreLabel,AfterLabel,HaveEXLINE)+EOL
       else if not (self is TTerminal) then
            result:=result + Code +EOL;


         // result:=result + TraceResultCode + EOL;

       if (AfterLabel<>nil) then
          begin
            s:='a'+IntToStr(LineNumb);
            result:=result+s+':'+EOL;
            Proc.LabelsList.add(s);
            AfterLabel.add(IntToStr(LineNumb)+':begin continue:=0; goto '+s+' end;' );
          end;

        result:=result
              + next.genCode(PreLabel,AfterLabel,HaveEXLINE);
     end;
end;

function TStatement.MakeLabel:ansistring;
begin
   result:='L'+inttostr(LineNumb);
   Proc.LabelsList.add(result);
end;

function TWhenException.JumpCode(Prelabel, AfterLabel:TstringList):AnsiString;
var
  p:TStatement;
  i:integer;
begin
  result:='';
  if PreLabel<>nil then
     begin
        result:= 'Case Retry of'+EOL
                +'0: ;'+EOL
                + PreLabel.text
                +'end;'+EOL
     end;
  if AfterLabel<>nil then
     begin
        result:=Result
                +'Case Continue of'+EOL
                +'0: ;'+EOL
                + AfterLabel.text
                +'end;'+EOL
     end;
end;

function TWhenException.HandlerCode:ansistring;
var
  s:string;
begin
   result:=UseBlock.GenCode(nil,nil,false);
   if HaveRetry or HaveContinue then
      begin
        s:='h'+IntToStr(UseBlock.LineNumb);
        result:=result+EOL
               +s+':';
        Proc.LabelsList.add(s)
      end;
end;

function TWhenUse.BlockCode(Prelabel0,Afterlabel0:TstringList; HaveEXLINE0:boolean):AnsiString;
begin
  HaveRetry:=Handler.HaveRetry;
  HaveContinue:=Handler.HaveContinue;
  HaveEXLINE:=Handler.HaveEXLINE;
  result:=inherited BlockCode(PreLabel0,AfterLabel0,HaveEXLINE)
end;

function TWhenException.BlockCode(Prelabel0,Afterlabel0:TstringList; HaveEXLINE0:Boolean):AnsiString;
var
  Prelabel, AfterLabel:TstringList;
  s,s2:string;
begin

  Prelabel:=nil;
  Afterlabel:=nil;
  if HaveRetry or (PreLabel0<>nil) then begin
     Prelabel:=TStringList.create;
     PreLabel.sorted:=true;
  end;
  if HaveContinue or (AfterLabel0<>nil) then begin
     AfterLabel:=TStringList.create;
     AfterLabel.sorted:=true;
  end;
  try
    result:=Block.genCode(PreLabel,AfterLabel,HaveEXLINE or HaveEXLINE0)
          + 'except' +EOL
          + ' on E:EControlException do raise;' + EOL
          + ' on E:Exception do begin' + EOL
    {$IFNDEF Windows}
          + ' if (E is EMathError) or (E is EDivByZero) then' +EOL
          + ' RecoverFloatException; '+EOL
    {$ENDIF}
          + '  ExcodeRec:=Excode; Excode:=DefaultExcode;' +EOL
          + HandlerCode+EOL
          + ' end;' + EOL
          + 'end;' ;

    result:='try' + EOL
          + JumpCode(Prelabel, AfterLabel)
          + Result;

    if PreLabel<>nil then
       result:='repeat'+EOL
              +result +EOL
              +'until Retry=0;' ;

    if AfterLabel<>nil then
       result:='repeat'+EOL
              +result +EOL
              +'until Continue=0;' ;

    if (PreLabel0=nil) and HaveRetry then
       result:='Retry:=0;'+EOL
               +result;

    if (AfterLabel0=nil) and HaveContinue then
       result:='Continue:=0;'+EOL
               +result;

  s:=inttostr(block.linenumb)+'..'+inttostr(last(block).linenumb)+': ';
  if PreLabel0<>nil then
    begin
      s2:='p'+inttostr(LineNumb) ;      // このラベルはすでに存在するはず
      PreLabel0.add(s+'goto '+s2+';');
    end;
  if Afterlabel0<>nil then
    begin
      s2:='b'+inttostr(LineNumb) ;      // 重複を避けるため新種のラベルを用いる
      AfterLabel0.add(s+'goto '+s2+';');
      result:=s2+':'+EOL                //When行の直前にラベルを貼る
             +Result;
      Proc.LabelsList.add(s2);
    end;
  finally
    if PreLabel<>nil then with PreLabel do begin clear;free end;
    if AfterLabel<>nil then with AfterLabel do begin clear;Free end;
  end;
end;

function TWhenUse.HandlerCode:AnsiString;
begin
  result:=Handler.NameCode +'(E,retry,continue,ExLineNumb,ExCodeRec);'
end;

function TGOTO.code:AnsiString;
begin
  result:='goto '+ Inttostr(statement.labelnumb) + ';';
  proc.LabelsList.add(Inttostr(statement.labelnumb));
end;

function TEXIT.Code:AnsiString;
begin
   result:='raise '+typ.ClassName+'.Create;'
end;

constructor ECodeNotYet.create(st0:Tstatement);
begin
  inherited create('Not Implemented yet.');
  st:=st0
end;


{***********}
{initializer}
{***********}


procedure statementtableInitDeclative(n:string10 ; f:StatementFunction);
begin
       statementtable.accept(n,declative,f)
end;

procedure statementtableInitImperative(n:string10 ; f:StatementFunction);
begin
       statementtable.accept(n,imperative,f)
end;

procedure statementtableInitStructural(n:string10 ; f:StatementFunction);
begin
       statementtable.accept(n,structural,f)
end;

procedure statementtableInitTerminal(n:string10 ; f:StatementFunction);
begin
       statementtable.accept(n,terminal,f)
end;

procedure statementtableInitSingular(n:string10 ; f:StatementFunction);
begin
       statementtable.accept(n,singular,f)
end;

procedure  SuppliedFunctionTableInit(n:string11; f:simplefunction);
begin
       SuppliedFunctionTable.accept(n,f)
end;

procedure  reservedWordTableInit(n:string11; f:simplefunction);
begin
       reservedWordTable.accept(n,f)
end;

{**********}
{Initialize}
{**********}

procedure statementTableinit;
begin
  StatementTableInitStructural('PARACT',PARACTst);
  StatementTableInitStructural('EXTERNAL',EXTERNALst);
  statementtableInitStructural('FUNCTION',PROCst);
  statementtableInitStructural('SUB',PROCst);
  statementtableInitStructural('PICTURE',PROCst);
  statementtableInitStructural('HANDLER',PROCst);
  statementtableInitTerminal('END',ENDst);
  {statementTableinitImperative('END'#9,ENDTABst);}
  statementTableinitStructural('WHEN',WHENst);
  statementtableInitTerminal('USE',USEst);
end;



initialization


currentprogram:=TProctbl.create(4);

statementTable:=TprcSelection.create;
statementTable.capacity:=96;
if TableInitProcs=nil then
   TableInitProcs:=TProcsCollection.create;  //97.10.12 初期化順に疑念発生，express.pasに移動
TableInitProcs.accept(statementtableinit);

DummyParameter:=TObjectList.create(0);


DebugVariables:=TStringList.create;
with DebugVariables do
   begin
     sorted:=true;
     duplicates:=dupIgnore;
   end;


finalization
with DebugVariables do begin clear;free end;
statementTable.free;
currentprogram.free;
TableInitProcs.free;
DummyParameter.free;

end.



