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

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


interface
uses SysUtils,  math,
    variabl,express,arithmet,float;

procedure SwitchToNativeMode;

function MicrosoftNExpression:TPrincipal;


implementation
uses
  objlist,struct,base,base0,texthand,helpctex,sconsts;

 type
    TNExpression=class(TPrincipal)
       constructor create;
       function  evalLongInt:LongInt;override;
       function kind:char;override;
    end;


type
   TUnaryOp=class(TNExpression)
             exp:TPrincipal;
             opF:FloatFunction1;
             opX:doublefunction1;
             overflowcode:smallint;
             invalidcode:smallint;
             name:ansistring;
          constructor create(e:TPrincipal;
                                 op1:FloatFunction1;op2:doublefunction1;
                                       er1,er2:smallint;const n:ansistring);virtual;
          function evalF:double;override;
          function OverflowErCode:integer;override;
          function InvalidErCode:integer;override;
          function OpName:string;override;
          function Code:Ansistring;override;
          destructor destroy;override;
          function QueryInteger:TSubstanceList;override;   // Integer型となるための条件。nilのとき不可。
     end;

   TBinaryOp=class(TNExpression)
             exp1,exp2:TPrincipal;
             opF:FloatFunction2;
             opX:doublefunction2;
             overflowcode:smallint;
             invalidcode:smallint;
             name:ansistring;
          constructor create(e1,e2:TPrincipal;
                              op1:FloatFunction2;op2:doublefunction2;
                                        er1,er2:smallint;const n:ansistring);virtual;
          function evalF:double;override;
          function OverflowErCode:integer;override;
          function InvalidErCode:integer;override;
          function OpName:string;override;
          function Code:Ansistring;override;
          destructor destroy;override;
          function QueryInteger:TSubstanceList;override;   // Integer型となるための条件。nilのとき不可。
     end;

type
   TNConstant=class(TNExpression)
              valueF:double;
           constructor create(var n:number);
           constructor create2(x:double);
           function evalF:double;override;
           destructor destroy;override;
           function isConstant:boolean;override;
           function Code:AnsiString;override;
           function QueryInteger:TSubstanceList;override;
       end;

type
   TNFunction=class(TNExpression)
          exe   :TCALL;
          constructor create(idr:TIdrec);
          function Code:Ansistring;override;
          destructor destroy;override;
     end;

type
     TUnaryOpClass = class of TUnaryOp;
     TBinaryOpClass = class of TBinaryOp;

{*****************}
{numeric expresion}
{*****************}

constructor TNExpression.create;
begin
   inherited create;
end;

function TNexpression.kind:char;
begin
   kind:='n'
end;

constructor TNFunction.create(idr:TIdrec);
begin
   inherited Create;
   exe:=TCALL.createF(idr) ;
end;

destructor TNFunction.destroy;
begin
   exe.free;
   inherited destroy
end;

type
  TFpuSave = record
    p:array [0..6] of Cardinal;
    f:array [0..7] of extended;
  end;

{*********}
{TNConstant}
{*********}

constructor TNConstant.create(var n:number);
var
  flag:boolean;
begin
  inherited create;
  flag:=false;
  {$IFNDEF WINDOWS}setFPUmask(NormalCW);{$ENDIF}
  try
    valueF:=extendedval(N);
     {$IFDEF FPUX87} asm fwait end; {$ENDIF}
  except
    flag:=true;
   {$IFNDEF Windows}RecoverFloatException;{$ENDIF}
  end;
  {$IFNDEF WINDOWS}setFPUmask(OriginalCW);{$ENDIF}

  if flag then
      seterr(s_TooLargeConstant,IDH_JIS_5);
end;

constructor TNConstant.create2(x:double);
begin
    inherited create;
    valueF:=x;
end;

destructor TNConstant.destroy;
begin
   inherited destroy;
end;

function TNConstant.isConstant:boolean;
begin
   isConstant:=true
end;


{*****************}
{numeric operation}
{*****************}


constructor TunaryOp.create(e:TPrincipal; op1:FloatFunction1; op2:doublefunction1;
                            er1,er2:smallint;const n:ansistring);
begin
    inherited  create;
    exp:=e;
    opF:=op1;
    opX:=op2;
    overflowcode:=er1;
    invalidcode:=er2;
    name:=n;
end;

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

constructor TBinaryOp.create(e1,e2:TPrincipal; op1:FloatFunction2; op2:doublefunction2;
                              er1,er2:smallint;const n:ansistring );
begin
    inherited  create;
    exp1:=e1;
    exp2:=e2;
    opF:=op1;
    opX:=op2;
    overflowcode:=er1;
    invalidcode:=er2;
    name:=n;
end;

destructor TBinaryOp.destroy;
begin
   exp1.free;
   exp2.free;
   inherited destroy;
end;

function UnaryOp( e:TPrincipal;op1:FloatFunction1;op2:doublefunction1;
                   er1,er2:smallint;opclass:TUnaryOpClass;const name:ansistring):TPrincipal;
{$MAXFPUREGISTERS 0}
var
   p:TPrincipal;
   n:number;
   x:double;
   flag:boolean;
   cw,cw1:word;
begin
   p:=opClass.create(e,op1,op2,er1,er2,name);
   if e.isConstant then
     begin
       flag:=true;
       {$IFNDEF WINDOWS}setFPUmask(NormalCW);{$ENDIF}
       try
          x:=p.evalF;
           {$IFDEF FPUX87} asm fwait end; {$ENDIF}
        except
          flag:=false;
         {$IFNDEF Windows}RecoverFloatException;{$ENDIF}
       end;
      {$IFNDEF WINDOWS}setFPUmask(OriginalCW);{$ENDIF}
       if flag then
         begin
           p.free;
           p:=TNConstant.create2(x);
         end
       else
         //extype:=0;
     end;

   UnaryOp:=p
end;


function BinaryOp( e1,e2:TPrincipal;  op1:FloatFunction2; op2:doublefunction2;
                 er1,er2:smallint; opclass:TBinaryOpClass;const name:ansistring):TPrincipal;
{$MAXFPUREGISTERS 0}
var
   p:TPrincipal;
   n:number;
   x:double;
   flag:boolean;
begin
   p:=opClass.create(e1,e2,op1,op2,er1,er2,name);

   if e1.isConstant and e2.isConstant then
     begin
       flag:=true;
       {$IFNDEF WINDOWS}setFPUmask(NormalCW);{$ENDIF}
       try
         x:=p.evalF;
          {$IFDEF FPUX87} asm fwait end; {$ENDIF}
       except
         flag:=false;
         {$IFNDEF Windows}RecoverFloatException;{$ENDIF}
       end;
      {$IFNDEF WINDOWS}setFPUmask(OriginalCW);{$ENDIF}
       if flag then
         begin
            p.free;
            p:=TNConstant.create2(x);
         end
       else
         begin
           //extype:=0;
         end;
      end;
   BinaryOp:=p
end;


type
   TPower=class(TBinaryOp)
          function evalF:double;override;
          function Code:Ansistring;override;
   end;

   TOppose=class(TUnaryOp)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TSquare=class(TUnaryOp)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TMSYEN=class(TBinaryOp)
          function evalF:double;override;
   end;

   TMSMOD=class(TBinaryOp)
          function evalF:double;override;
   end;

function OpSquare(e1:TPrincipal):TPrincipal;
begin
  result:=UnaryOp(e1,nil{float.Square},nil,1002,1002,TSquare{TUnaryOp},'^')
end;

function  OpUnaryMinus(e1:TPrincipal):TPrincipal;
begin
     result:=UnaryOp(e1,nil,nil,1002,1002,TOppose,'-');
end;

function OpPower(e1,e2:TPrincipal):TPrincipal;
begin
   result:=BinaryOp(e1,e2,nil,nil,1002,3002,TPower,'^')
end;

function OpMSYen(e1,e2:TPrincipal):TPrincipal;
begin
    result:=BinaryOp(e1,e2, nil,nil,1002,1002,TMSYEN,'\');
end;

function OpMSMod(e1,e2:TPrincipal):TPrincipal;
begin
    result:=BinaryOp(e1,e2, nil,nil,1002,1002,TMSMOD,'MOD');
end;


type
   TFundBinOp=class(TNExpression)
          constructor create(e1,e2:TPrincipal);virtual;
          function OverflowErCode:integer;override;
          function InvalidErCode:integer;override;
     end;

type
   TFundBinOpClass=class of TFundBinOp;

constructor TFundBinOp.create(e1,e2:TPrincipal);
begin
   inherited create;
end;

function TFundBinOp.OverflowErCode:integer;
begin
   result:=1002;
end;

function TFundBinOp.InvalidErCode:integer;
begin
   result:=3001
end;

Type
   TFundBinOpNormal=class(TFundBinOp)
             exp1,exp2:TPrincipal;
          constructor create(e1,e2:TPrincipal);override;
          destructor destroy;override;
      end;

constructor TFundBinOpNormal.create(e1,e2:TPrincipal);
begin
   inherited create(e1,e2);
   exp1:=e1;
   exp2:=e2;
end;

destructor TFundBinOpNormal.destroy;
begin
   exp2.free;
   exp1.Free;
   inherited destroy;
end;

Type
   TFundBinOpwithConst=class(TFundBinOp)
             exp1:TPrincipal;
             ValueF:double;
          constructor create(e1,e2:TPrincipal);override;
          destructor destroy;override;
      end;

constructor TFundBinOpWithConst.create(e1,e2:TPrincipal);
begin
   inherited create(e1,e2);
   exp1:=e1;
   valueF:=TNConstant(e2).valueF;
   e2.free;
end;

destructor TFundBinOpwithConst.destroy;
begin
   exp1.free;
   inherited destroy;
end;

type
   TADD=class(TFundBinOpNormal)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TSUB=class(TFundBinOpNormal)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TMUL=class(TFundBinOpNormal)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TDIV=class(TFundBinOpNormal)
          function evalF:double;override;
          function Code:Ansistring;override;
   end;


type
   TADDNC=class(TFundBinOpWithConst)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TSUBNC=class(TFundBinOpWithConst)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TMULNC=class(TFundBinOpWithConst)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TDIVNC=class(TFundBinOpWithConst)
          function evalF:double;override;
          function Code:Ansistring;override;
   end;

type
   TADDCN=class(TFundBinOpWithConst)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TSUBCN=class(TFundBinOpWithConst)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TMULCN=class(TFundBinOpWithConst)
          function evalF:double;override;
          function Code:Ansistring;override;
          function QueryInteger:TSubstanceList;override;
   end;

   TDIVCN=class(TFundBinOpWithConst)
          function evalF:double;override;
          function Code:Ansistring;override;
   end;


function FundBinOp(e1,e2:TPrincipal;
             OpNN,OPNC,OPCN:TFundBinOpClass):TPrincipal;
var
   p:TPrincipal;
   x:double;
   flag:boolean;
begin
  if e1.isConstant then
     begin
        if e2.isConstant then
           begin
             p:=OpNN.create(e1,e2);
             flag:=true;
             {$IFNDEF WINDOWS}setFPUmask(NormalCW);{$ENDIF}
             try
                x:=p.evalF;
                 {$IFDEF FPUX87} asm fwait end; {$ENDIF}
             except
                flag:=false;
             {$IFNDEF Windows}RecoverFloatException;{$ENDIF}
             end;
             {$IFNDEF WINDOWS}setFPUmask(OriginalCW);{$ENDIF}
             if flag then
               begin
                  p.free;
                  p:=TNConstant.create2(x);
               end
             else
                begin
                 //extype:=0;
                end;
           end
        else
            p:=OpCN.create(e2,e1);
      end
   else
      begin
        if e2.isConstant then
            p:=OpNC.create(e1,e2)
        else
            p:=OpNN.create(e1,e2);
      end;
   FundBinOp:=p
end;


function OpTimes(e1,e2:TPrincipal):TPrincipal;
begin
  result:=FundBinOp(e1,e2,TMUL,TMULNC,TMULCN);
end;

function OpDivide(e1,e2:TPrincipal):TPrincipal;
begin
  result:=FundBinOp(e1,e2,TDIV,TDIVNC,TDIVCN);
end;

function OpPlus(e1,e2:TPrincipal):TPrincipal;
begin
  result:=FundBinOp(e1,e2,TADD,TADDNC,TADDCN);
end;

function OpMinus(e1,e2:TPrincipal):TPrincipal;
begin
  result:=FundBinOp(e1,e2,TSUB,TSUBNC,TSUBCN);
end;



function NConst(var n:number):TPrincipal;
begin
   NConst:=TNConstant.create(n)
end;

function NFunction(idr:TIdrec):TPrincipal;
begin
   NFunction:=TNFunction.create(idr)
end;


{*********}
{Micorsoft}
{*********}

procedure MSOR(var x,y:double);
begin
    x:= system.round(x) or system.round(y);
end;

procedure MSAND(var x,y:double);
begin
    x:= system.round(x) and system.round(y);
end;

procedure MSNOT(var x:double);
begin
    x:=not system.round(x);
end;

type
   TMSComparison=class(TNExpression)
       exp:TLogical;
    constructor create(x:TLogical);
    destructor destroy;override;
   end;

function MSComparison:TPrincipal;
var
   x:TPrincipal ;
   f:comparefunction;
   sp:tokenspecification;
begin
   sp:=tokenspec;
   if token='(' then sp:=nexttokenspec;
   case sp of
      SCon,Sidf:
        begin
          x:=SExpression;
          repeat
                findcomparefunction(token,f);
                gettoken;
                x:=TMSComparison.create(TComparisonS.create(x,SExpression,f)) ;
          until  tokenspec<>relational;
        end;
      else
        begin
          x:=JISNExpression;
          while tokenspec=relational do
              begin
                findcomparefunction(token,f);
                gettoken;
                x:=TMSComparison.create(TComparisonN.create(x,JISNExpression,f))
              end;
        end;
   end;
   while tokenspec=relational do
       begin
         findcomparefunction(token,f);
         gettoken;
         if x.kind='n' then
            x:=TMSComparison.create(TComparisonN.create(x,JISNExpression,f))
         else
            x:=TMSComparison.create(TComparisonS.create(x,SExpression,f)) ;
       end;
   result:=x;
end;

constructor TMSComparison.create(x:TLogical);
begin
   inherited create;
   exp:=x;
end;

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


function MSNotFactor:TPrincipal;
begin
   if token='NOT' then
         begin
          gettoken;
          result:=UnaryOp(MSNotFactor, MSNOT, nil,1002,1002,TUnaryOp,'NOT');
         end
   else
      result:=MSComparison;
end;


function MSAndTerm:TPrincipal;
var
    exp:TPrincipal ;
    op:char;
begin
    MSAndTerm:=nil;
    exp:=MSNotFactor;
    while (token='AND') and (exp<>nil)  do
       begin
           gettoken;
           exp:=BinaryOp(exp,MSNotFactor,MSAND,nil,1002,1002,TBinaryOp,'AND');
       end;
    MSAndTerm:=exp
end;

function MicrosoftNExpression:TPrincipal;
var
    exp:TPrincipal ;
    op:char;
begin
    MicrosoftNExpression:=nil;
    exp:=MSAndTerm;
    while (token='OR') and (exp<>nil)  do
       begin
           gettoken;
           exp:=BinaryOp(exp,MSAndTerm,MSOR, nil,1002,1002,TBinaryOp,'OR');
       end;
    MicrosoftNExpression:=exp
end;



{************}
{Unary Binary}
{************}

function Unary({op1:unaryoperation;} op2:floatfunction1;er2:smallint;const name:ansistring):TPrincipal;
begin
   Unary:=UnaryOp(argumentN1,op2,nil,1003,er2,ExpressF.TUnaryOp,name)
end;

function Binary({op1:binaryoperation;} op2:floatfunction2; er2:smallint;const name:ansistring):TPrincipal;
var
   a1:TPrincipal;
begin
   a1:=argumentN2a;
   Binary:=BinaryOp(a1,ArgumentN2b,op2,nil,1003,er2,ExpressF.TBinaryOp,name)

end;

type
  TUnaryX=class(TUnaryOp)
      function evalF:double;override;
   end;

  TBinaryX=class(TBinaryOp)
     function evalF:double;override;
   end;

function UnaryX(op2:doublefunction1;er2:smallint;const name:ansistring):TPrincipal;
begin
    UnaryX:=UnaryOp(argumentN1,nil,op2,1003,er2,TUnaryX,name)
end;

function BinaryX(op2:doublefunction2; er2:smallint;const name:ansistring):TPrincipal;
var
   a1:TPrincipal;
begin
   a1:=argumentN2a;
   BinaryX:=BinaryOp(a1,ArgumentN2b,nil,op2,1003,er2,TBinaryX,name)
end;

{**********}
{NOperation}
{**********}
type
  TNOperation=class(TNExpression)
       Op:TPrincipal;
    constructor Create(e1:TPrincipal);
    function evalF:double; override;
    destructor destroy;override;
    function code:AnsiString;override;
    function QueryInteger:TSubstanceList;override;   // Integer型となるための条件。nilのとき不可。
  end;

constructor TNOperation.Create(e1:TPrincipal);
begin
   inherited create;
   op:=e1;
end;

destructor TNOperation.destroy;
begin
   op.free;
   inherited destroy;
end;

function TNOperation.code:AnsiString;
begin
  result:=Op.Code
end;


function NOperation(op:TPrincipal):TPrincipal ;
begin
   result:=TNOperation.create(op);
end;

function TNExpression. evalLongInt:LongInt;
begin
   result:=LongIntRound(evalF);
end;




function TNConstant.evalF:double;
begin
    result:=valueF;
end;
const
    minstack=sizeof(Number)*6 ;


function TUnaryOp.evalF:double;
begin
   result:=exp.evalF;
   CurrentOperation:=self;
   opF(result);
   CurrentOperation:=nil;
end;

function TUnaryOp.OverflowErCode:integer;
begin
   result:=OverFlowCode
end;

function TUnaryOp.InvalidErCode:integer;
begin
   result:=InvalidCode;
end;

function TUnaryOp.OpName:string;
begin
   result:=name;
end;

function TBinaryOp.OverflowErCode:integer;
begin
   result:=OverFlowCode
end;

function TBinaryOp.InvalidErCode:integer;
begin
   result:=InvalidCode;
end;

function TBinaryOp.OpName:string;
begin
   result:=name;
end;


{$IFDEF FPC}

function TBinaryOp.evalF:double;
{$MAXFPUREGISTERS 0}
var
   y:double;
begin
   result:=exp1.evalF;
   y:=exp2.evalF;
   CurrentOperation:=self;
   opF(result,y);
   CurrentOperation:=nil;
end;

function TADD.evalF:double;
{$MAXFPUREGISTERS 0}
var
  x:double;
begin
   x:=exp1.evalF;
   result:=exp2.evalF;
   result:=x + result ;
end;

function TSUB.evalF:double;
{$MAXFPUREGISTERS 0}
var
   x:double;
begin
   x:=exp1.evalF;
   result:=exp2.evalF;
   result:= x - result;
end;


function TMUL.evalF:double;
{$MAXFPUREGISTERS 0}
var
  x,y:double;
begin
  x:=exp1.evalF;
  y:=exp2.evalF;
  result:=x*y;
end;

function TDIV.evalF:double;
{$MAXFPUREGISTERS 0}
var
  x,y:double;
begin
  x:=exp1.evalF;
  result:=exp2.evalF;
  if result=0.0 then
     setexception(3001);
  result:= x/result ;
end;

{$ELSE}

function TBinaryOp.evalF:double;
var
   y:double;
begin
   result:=exp1.evalF;
   y:=exp2.evalF;
   CurrentOperation:=self;
   opF(result,y);
   CurrentOperation:=nil;
end;

function TADD.evalF:double;
begin
   result:=exp1.evalF + exp2.evalF;
end;

function TSUB.evalF:double;
begin
   result:= exp1.evalF - exp2.evalF;
end;

function TMUL.evalF:double;
begin
   result:= exp1.evalF * exp2.evalF;
end;

function TDIV.evalF:double;
begin
   result:=exp1.evalF / exp2.evalF;
end;

{$ENDIF}


function TADDNC.evalF:double;
begin
   result:=exp1.evalF
          + ValueF;
end;

function TSUBNC.evalF:double;
begin
   result:=exp1.evalF
           - ValueF;
end;

function TMULNC.evalF:double;
begin
   result:=exp1.evalF
          * ValueF;
end;

function TDIVNC.evalF:double;
begin
{$IFDEF FPC}
   if ValueF=0.0 then
      setexception(3001);
{$ENDIF}
   result:=exp1.evalF
          / ValueF;
end;

function TADDCN.evalF:double;
begin
   result:=ValueF
           + exp1.evalF
end;

function TSUBCN.evalF:double;
begin
   result:=ValueF
           - exp1.evalF
end;

function TMULCN.evalF:double;
begin
   result:=ValueF
           * exp1.evalF
end;

{$IFDEF FPC}
function TDIVCN.evalF:double;
begin
   result:= exp1.evalF;
   if result=0.0 then
     setexception(3001);
   result:=ValueF
               / result;
end;
{$ELSE}
function TDIVCN.evalF:double;
begin
   result:=ValueF
           / exp1.evalF
end;
{$ENDIF}

function PowerSub(Base,Exponent:extended):double;
begin
     if ABS(BASE-1)>0.125 then
       Result :=NPXPower(Base,Exponent) {Exp(Exponent * Ln(Base)) }
    else
       Result:=NPXPower1Plus(Base-1,Exponent);
end;

function Power(Base, Exponent: Extended): double {結果を丸めて誤差を消去};
begin
  if Exponent = 0.0 then
     Result := 1.0
  else if Base>0 then
       result:=Powersub(base,exponent)
  else if Base=0 then
     begin
       if Exponent>0 then
          result:=0
       else if Exponent=0 then
          result:=1
       else
          begin
            result:=0;
            setexception(3003)
          end
     end
  else if Frac(Exponent)=0 then
       if Frac(Exponent/2)=0 then
          result:=power(-base,exponent)
       else
          result:=-power(-base,exponent)
  else
      begin
        result:=0.0;
        setexception(3002) ;
      end;
end;

function TPower.evalF:double;
begin
   result:=power(exp1.evalF,exp2.evalF);
end;

function TOppose.evalF:double;
begin
    result := - exp.evalF;
end;

function TSquare.evalF:double;
begin
   result:=system.sqr(exp.evalF);
end;

function TMSYEN.evalF:double;
var
    a,b:longint;
begin
    a:=LongIntRound(exp1.evalF);
    b:=LongIntRound(exp2.evalF);
    result:=a div b;
end;

function TMSMOD.evalF:double;
var
    a,b:longint;
begin
    a:=LongIntRound(exp1.evalF);
    b:=LongIntRound(exp2.evalF);
    result:=a mod b;
end;

function DstrX(x:extended):ansistring;
var
   n:number;
begin
   convert(x,n);
   result:=Dstr(n)
end;

function TUnaryX.evalF:double;
begin
   result:=exp.evalF;
   CurrentOperation:=self;
   result:=opX(result);
   CurrentOperation:=nil;
end;

function TBinaryX.evalF:double;
{$MAXFPUREGISTERS 0}
var
    m:double;
begin
   result:=exp1.evalF;
   m:=exp2.evalF;
   CurrentOperation:=self;
   result:=opX(result,m);
   CurrentOperation:=nil;
end;

function TNOperation.evalF:double;
begin
   result:=op.evalF
end;

{************}
{NSubscripted}
{************}

type
   TNSubscripted=class(TSubscripted)
   end;

   TNSubscripted1=class(TNSubscripted)
   end;

   TNSubscripted2=class(TNSubscripted)
   end;

   TNSubscripted3=class(TNSubscripted)
   end;

   TNSubscripted4=class(TNSubscripted)
   end;


function NSubscripted1(idr:TIdrec; p:Subscriptarray):TVariable;
begin
   result:=TNSubscripted1.create(idr,p);
end;

function NSubscripted2(idr:TIdrec; p:Subscriptarray):TVariable;
begin
   result:=TNSubscripted2.create(idr,p);
end;

function NSubscripted3(idr:TIdrec; p:Subscriptarray):TVariable;
begin
   result:=TNSubscripted3.create(idr,p);
end;

function NSubscripted4(idr:TIdrec; p:Subscriptarray):TVariable;
begin
   result:=TNSubscripted4.create(idr,p);
end;



{***********}
{NComparison}
{***********}

type
    TEqual=class(TLogicalBiOp)
          function Code:Ansistring;override;
    end;

    TNotEqual=class(TLogicalBiOp)
          function Code:Ansistring;override;
    end;

    TGreater=class(TLogicalBiOp)
          function Code:Ansistring;override;
    end;

    TGreaterOrEq=class(TLogicalBiOp)
          function Code:Ansistring;override;
    end;

    TSmaller=class(TLogicalBiOp)
          function Code:Ansistring;override;
    end;

    TSmallerOrEq=class(TLogicalBiOp)
          function Code:Ansistring;override;
    end;

type
    TLogicalSingle=class(TNegation)
          const0:double;
          constructor create(e1,e2:TPrincipal);
    end;

    TEqualConst=Class(TLogicalSingle)
          function Code:Ansistring;override;
    end;

    TNotEqualConst=Class(TLogicalSingle)
          function Code:Ansistring;override;
    end;

    TGreaterConst=Class(TLogicalSingle)
          function Code:Ansistring;override;
    end;

    TGreaterOrEqConst=Class(TLogicalSingle)
          function Code:Ansistring;override;
    end;

    TSmallerConst=Class(TLogicalSingle)
          function Code:Ansistring;override;
    end;

    TSmallerOrEqConst=Class(TLogicalSingle)
          function Code:Ansistring;override;
    end;

constructor TLogicalSingle.create(e1,e2:TPrincipal);
begin
    inherited create(e1);
    const0:=e2.evalF;
    e2.free;          //2011.3.9
end;


function NComparison(f:comparefunction; e1,e2:TPrincipal):TLogical;
begin
    if (@f=@Equals) then
       if e2.isConstant then
         NComparison:=TEqualConst.create(e1,e2)
       else
         NComparison:=TEqual.create(e1,e2)
    else if (@f=@NotEquals) then
       if e2.isConstant then
          NComparison:=TNotEqualConst.create(e1,e2)
       else
          NComparison:=TNotEqual.create(e1,e2)
    else if (@f=@Greater) then
       if e2.isConstant then
          NComparison:=TGreaterConst.create(e1,e2)
       else
          NComparison:=TGreater.create(e1,e2)
    else if (@f=@NotLess) then
       if e2.isConstant then
          NComparison:=TGreaterOrEqConst.create(e1,e2)
       else
          NComparison:=TGreaterOrEq.create(e1,e2)
    else if (@f=@Less) then
       if e2.isConstant then
          NComparison:=TSmallerConst.create(e1,e2)
       else
          NComparison:=TSmaller.create(e1,e2)
    else if (@f=@NotGreater) then
       if e2.isConstant then
          NComparison:=TSmallerOrEqConst.create(e1,e2)
       else
          Ncomparison:=TSmallerOrEq.create(e1,e2);
end;

{**************}
{ Generate Code}
{**************}


function TNConstant.Code:AnsiString;
begin
   result:=Format17(valueF);
end;

function TUnaryOp.Code:Ansistring;
begin
   result:= name + '('+ exp.code + ')'
end;

function TBinaryOp.Code:Ansistring;
begin
   result:= name + '('+ exp1.code + ' , ' + exp2.code + ')'
end;

function TNFunction.Code:AnsiString;
begin
   result:= exe.Code;
end;

 function TPower.Code:Ansistring;
 begin
    result := 'power(' + exp1.code + ',' + exp2.code + ')'
 end;

 function TOppose.Code:Ansistring;
 begin
   result := ' - (' + exp.code + ')'
 end;

function TSquare.Code:Ansistring;
begin
   result:='sqr(' + exp.code + ')'
end;

 function TADD.Code:Ansistring;
 begin
   result:=  exp1.code + '+' + exp2.code
 end;

function TSUB.Code:Ansistring;
 begin
   result:=  exp1.code + '-(' + exp2.code +')'
 end;

function TMUL.Code:Ansistring;
 begin
   result:= '(' + exp1.code + ')*(' + exp2.code +')'
 end;

function TDIV.Code:Ansistring;
 begin
   result:= '('+ exp1.code + ')/(' + exp2.code +')'
 end;


function TADDNC.Code:Ansistring;
begin
  result:=  exp1.code + '+' + FORMAT17(valueF)
end;

function TSUBNC.Code:Ansistring;
begin
  result:=  exp1.code + '-' + FORMAT17(valueF)
end;

function TMULNC.Code:Ansistring;
begin
  result:= '('+ exp1.code + ')*' + FORMAT17(valueF)
end;

function TDIVNC.Code:Ansistring;
begin
  result:= '('+ exp1.code + ')/' + FORMAT17(valueF)
end;

function TADDCN.Code:Ansistring;
begin
  result:=  FORMAT17(valueF) + '+(' + exp1.code  + ')'
end;

function TSUBCN.Code:Ansistring;
begin
   result:= FORMAT17(valueF) + '-(' + exp1.code  + ')'
end;

function TMULCN.Code:Ansistring;
begin
   result:=  FORMAT17(valueF) + '*(' + exp1.code + ')'
end;

function TDIVCN.Code:Ansistring;
begin
   result:= FORMAT17(valueF) + '/(' + exp1.code + ')'
end;

function TEqual.Code:Ansistring;
begin
  result:= exp1.code + '=' + exp2.code
end;

function TNotEqual.Code:Ansistring;
begin
  result:=exp1.code + '<>' + exp2.code
end;

function TGreater.Code:Ansistring;
begin
  result:= exp1.code + '>' + exp2.code
end;

function TGreaterOrEq.Code:Ansistring;
begin
  result:= exp1.code + '>=' + exp2.code
end;

function TSmaller.Code:Ansistring;
begin
  result:= exp1.code + '<' + exp2.code
end;

function TSmallerOrEq.Code:Ansistring;
begin
  result:= exp1.code + '<=' + exp2.code
end;

function TEqualConst.Code:Ansistring;
begin
  result:=exp.code + '=' + Format17(const0)
end;

function TNotEqualConst.Code:Ansistring;
begin
  result:=exp.code + '<>' + Format17(const0)
end;

function TGreaterConst.Code:Ansistring;
begin
  result:=exp.code + '>' + Format17(const0)
end;

function TGreaterOrEqConst.Code:Ansistring;
begin
  result:=exp.code + '>=' + Format17(const0)
end;

function TSmallerConst.Code:Ansistring;
begin
  result:=exp.code + '<' + Format17(const0)
end;

 function TSmallerOrEqConst.Code:Ansistring;
 begin
   result:=exp.code + '<=' + Format17(const0)
 end;

function TNConstant.QueryInteger:TSubstanceList;
begin
    if (Abs(ValueF)<=maxint div 16) and (System.Frac(ValueF)=0) then
      result:=TSubstanceList.create
    else
      result:=nil
end;

function TOppose.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
     result:=exp.QueryInteger;
end;

function TSquare.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
     result:=exp.QueryInteger;
end;

function TAddCN.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
  if (Abs(ValueF)<=maxint div 16) and (System.Frac(ValueF)=0) then
     result:=exp1.QueryInteger
  else
     result:=nil;
end;

function TAddNC.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
  if (Abs(ValueF)<=maxint div 16) and (System.Frac(ValueF)=0) then
     result:=exp1.QueryInteger
  else
     result:=nil;
end;

function TSubCN.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
  if (Abs(ValueF)<=maxint div 16) and (System.Frac(ValueF)=0) then
     result:=exp1.QueryInteger
  else
     result:=nil;
end;

function TSubNC.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
  if (Abs(ValueF)<=maxint div 16) and (System.Frac(ValueF)=0) then
     result:=exp1.QueryInteger
  else
     result:=nil;
end;

function TMulCN.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
  if (Abs(ValueF)<=16) and (System.Frac(ValueF)=0) then
     result:=exp1.QueryInteger
  else
     result:=nil;
end;

function TMulNC.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
  if (Abs(ValueF)<=16) and (System.Frac(ValueF)=0) then
     result:=exp1.QueryInteger
  else
     result:=nil;
end;


function TAdd.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
     result:=mergedList(exp1.QueryInteger, exp2.QueryInteger);
end;

function TSub.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
     result:=mergedList(exp1.QueryInteger, exp2.QueryInteger);
end;

function TMul.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
     result:=mergedList(exp1.QueryInteger, exp2.QueryInteger);
end;


function TUnaryOp.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
  if (name='floor') or  (name='ceil') or (name='system.round') or (name='trunc')
   or (name='SGN') then
      result:=TSubstanceList.create
  else if (name='ABS') then
      result:=exp.QueryInteger
  else
      result:=nil
end;


function TBinaryOp.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
   if (name='BMOD') or (name='REMAINDER') then
      result:=mergedList(exp1.QueryInteger, exp2.QueryInteger)
   else
      result:=nil
end;

function TNOperation.QueryInteger:TSubstanceList;   // integer型となるための条件。nilのとき不可。
begin
     result:=Op.QueryInteger
end;


{***********}
{Mode Switch}
{***********}

procedure SwitchToNativeMode;
begin
   Express.NConst:=NConst;
   EXpress.OpPower:=OpPower;
   EXpress.OpUnaryMinus:=OpUNaryMinus;
   EXpress.OpSquare:=OpSquare;
   Express.OpTimes:=OpTimes;
   Express.OpDivide:=OpDivide;
   Express.OpPlus:=OpPlus;
   Express.OpMinus:=OpMinus;
   Express.OpMSYen:=OpMsYen;
   Express.OpMsMod:=OpMsMod;
   Express.NFunction:=NFunction;
   Express.Unary:=Unary;
   Express.Binary:=Binary;
   Express.UnaryX:=UnaryX;
   Express.BinaryX:=BinaryX;
   Express.NOperation:=NOperation;
   Express.NOperationMaybeComplex:=NOperation;

   Express.NSubscripted1:=Nsubscripted1;
   Express.NSubscripted2:=Nsubscripted2;
   Express.NSubscripted3:=Nsubscripted3;
   Express.NSubscripted4:=Nsubscripted4;

   EXpress.NComparison:=NComparison;
end;

{******************}
{supplied functions}
{******************}


{**************}
{reserved words}
{**************}


type
    TMaxNum=class(TNExpression)
        function Code:AnsiString;override;
     end;

    TPi=class(TNExpression)
        function Code:AnsiString;override;
    end;

function TMaxNum.Code:ansistring;
begin
  result:='MaxNumberDouble'
end;

function TPI.code:ansistring;
begin
  result:='PI'
end;

function MAXNUMfnc:TPrincipal;
begin
   //MAXNUMfnc:=ExpressF.TNConstant.create2(maxnumberDouble)
   MaxNumfnc:=TMaxNum.create;
end;

function PIfnc:TPrincipal;
begin
   // PIfnc:=TNConstant.create2(pi) ;
   PIfnc:=TPI.create;
end;


{**********}
{initialize}
{**********}

procedure  FunctionTableInit;
begin
 if PrecisionMode=PrecisionNative then
   begin
       ReservedWordTableInit('MAXNUM' , MAXNUMfnc );
       if not permitMicrosoft  then
          ReservedWordTableInit(  'PI' ,  PIfnc);
   end;
end;

begin
if TableInitProcs=nil then
   TableInitProcs:=TProcsCollection.create;  //98.4.1 初期化順に疑念発生，express.pasに移動
   tableInitProcs.accept(FunctionTableInit);
end.

