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


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

procedure SwitchToDecimalMode;

{********************}
{numerical expression}
{********************}
 type
    TNexpression=class(TPrincipal)
      constructor create;
      function evalX:extended;override;
      //function evalInteger:integer;override;
      function  evalLongInt:LongInt;override;
      //function str:ansistring;override;
      //function str2:ansistring;override;
      //function compare(p:TPrincipal):integer;override;
      function kind:char;override;
      //function substance0(ByVal:boolean):TVar;override;
      //procedure disposeSubstance0(p:TVar; ByVal:boolean);override;
      //function substance1:TVar;override;
      //procedure disposeSubstance1(p:TVar);override;
    end;


type
   TUnaryOpOrdinal=class(TNExpression)
             exp:TPrincipal;
             opN:unaryoperation;
             name:ansistring;
          constructor create(e:TPrincipal;
                                   op1:unaryoperation;op2:doublefunction1;
                                        er1,er2:smallint;const n:ansistring);virtual;
          //procedure evalN(var n:number);override;
          destructor destroy;override;
          function Code:Ansistring;override;
     end;

   TBinaryOpOrdinal=class(TNExpression)
             exp1,exp2:TPrincipal;
             opN:binaryoperation;
             name:ansistring;
         constructor create(e1,e2:TPrincipal;
                             op1:binaryoperation;op2:doublefunction2;
                                        er1,er2:smallint;const n:ansistring);virtual;
          //procedure evalN(var n:number);override;
          destructor destroy;override;
          function Code:Ansistring;override;
     end;

   TUnaryOp=class(TUnaryOpOrdinal)
             opX:doublefunction1;
             overflowcode:smallint;
             invalidcode:smallint;
            // name:ansistring;
          constructor create(e:TPrincipal;
                             op1:unaryoperation;op2:doublefunction1;
                             er1,er2:smallint;const n:ansistring);override;
          //procedure evalN(var n:number);override;
          function OverflowErCode:integer;override;
          function InvalidErCode:integer;override;
          function OpName:string;override;
          function Code:Ansistring;override;
     end;

   TBinaryOp=class(TBinaryOpOrdinal)
             opX:doublefunction2;
             overflowcode:smallint;
             invalidcode:smallint;
           //  name:ansistring;
          constructor create(e1,e2:TPrincipal;
                            op1:binaryoperation;op2:doublefunction2;
                            er1,er2:smallint;const n:ansistring);override;
          //procedure evalN(var n:number);override;
          function OverflowErCode:integer;override;
          function InvalidErCode:integer;override;
          function OpName:string;override;
          function Code:Ansistring;override;
     end;

{
function UnaryOp( e:TPrincipal;op1:unaryoperation;op2:doublefunction1;
                  er1,er2:smallint; opclass:TUnaryOpClass; name:ansistring):TPrincipal;
function BinaryOp( e1,e2:TPrincipal; op1:binaryoperation;op2:doublefunction2;
                 er1,er2:smallint; opclass:TBinaryOpClass; name:ansistring):TPrincipal;
}

implementation
uses
      struct,math,base,base0,objlist,texthand,helpctex,moddlg,optina;
      
type
   TNConstant=class(TNExpression)
              valueN:Pnumber;
           constructor create(var n:number);
           procedure evalN(var n:number);override;
           destructor destroy;override;
           function isConstant:boolean;override;
           function Code:AnsiString;override;
       end;

type
   TNFunction=class(TNExpression)
          exe   :TCALL;
          constructor create(idr:TIdrec);
          //procedure evalN(var n:number);override;
          function Code:AnsiString;override;
          destructor destroy;override;
     end;

type
     TUnaryOpClass = class of TUnaryOpOrdinal;
     TBinaryOpClass = class of TBinaryOpOrdinal;

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

constructor TNExpression.create;
begin
   inherited create;
end;

function TNexpression.kind:char;
begin
   kind:='n'
end;
{
function TNExpression.str:ansistring;
var
    n:number;
begin
    evalN(n);
    checkrangedecimal(n,OverflowErCode);
    str:=Dstr(n)+' '
end;

function TNExpression.str2:ansistring;
begin
    str2:=str
end;

function TNExpression.evalInteger:integer;
var
   c:integer;
   n:number;
begin
   evalN(n);
   result:=IntegerVal(n,c);
   if c>0 then result:=maxint
   else if c<0 then result:=MinInt;
end;
}
function TNExpression.EvalLongInt:LongInt;
var
   c:integer;
   n:number;
begin
   evalN(n);
   result:=longintval(n,c);
   if c<>0 then SetException(2001);
end;

function TNExpression.evalX:extended;
var
   n:number;
begin
   evalN(n);
   result:=extendedval(n)
end;

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

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


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



constructor TNConstant.create(var n:number);
var
   m:number;
begin

    inherited  create;
    m.init(@n);
    roundexpression(m);
    roundprecision(m);
    subst(valueN,m);

end;

procedure TNConstant.evalN(var n:number);
begin
    n.init(valueN);
    checkrangedecimal(n,1001);
end;


destructor TNConstant.destroy;
begin

   disposeNumber(valueN);
   inherited destroy;

end;

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




{*****************}
{numeric operation}
{*****************}
const
    minstack=sizeof(Number)*6 ;



constructor TunaryOpOrdinal.create(e:TPrincipal; op1:unaryoperation;
                         op2:doublefunction1; er1,er2:smallint;const n:ansistring);
begin
    inherited  create;
    exp:=e;
    opN:=op1;
    name:=n
end;

constructor TunaryOp.create(e:TPrincipal; op1:unaryoperation;
                         op2:doublefunction1; er1,er2:smallint;const n:ansistring);
begin
    inherited  create(e,op1,op2,er1,er2,n);
    opX:=op2;
    overflowcode:=er1;
    invalidcode:=er2;
    name:=n;
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;

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

constructor TBinaryOpOrdinal.create(e1,e2:TPrincipal; op1:binaryoperation;
                        op2:doublefunction2; er1,er2:smallint;const n:ansistring );
begin
    inherited  create;
    exp1:=e1;
    exp2:=e2;
    opN:=op1;
    name:=n
end;

constructor TBinaryOp.create(e1,e2:TPrincipal; op1:binaryoperation;
                        op2:doublefunction2; er1,er2:smallint;const n:ansistring );
begin
    inherited  create(e1,e2,op1,op2,er1,er2,n);
    opX:=op2;
    overflowcode:=er1;
    invalidcode:=er2;
    name:=n;
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;

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




function UnaryOp( e:TPrincipal;op1:unaryoperation;op2:doublefunction1;
                   er1,er2:smallint;opclass:TUnaryOpClass;const name:ansistring):TPrincipal;
var
   p:TPrincipal;
   n:number;
   flag:boolean;
begin
   p:=opClass.create(e,op1,op2,er1,er2,name);
   UnaryOp:=p
end;


function BinaryOp( e1,e2:TPrincipal; op1:binaryoperation; op2:doublefunction2;
                  er1,er2:smallint; opclass:TBinaryOpClass;const name:ansistring):TPrincipal;
var
   p:TPrincipal;
   n:number;
   flag:boolean;
begin
   p:=opClass.create(e1,e2,op1,op2,er1,er2,name);
   BinaryOp:=p
end;

function OpPower(e1,e2:TPrincipal):TPrincipal;
begin
  case ProgramUnit.arithmetic of
    PrecisionNormal:
      result:=BinaryOp(e1,e2,arithmet.power,nil,1002,3002,TBinaryOp,'dpower');
   end;
end;

function OpSquare(e1:TPrincipal):TPrincipal;
begin
  result:=UnaryOp(e1,arithmet.Square,nil,1002,1002,TUnaryOpOrdinal,'dsquare')
end;

function  OpUnaryMinus(e1:TPrincipal):TPrincipal;
begin
     result:=UnaryOp(e1,arithmet.opposite,nil,1002,1002,TUnaryOpOrdinal,'opposite');
end;

function OpTimes(e1,e2:TPrincipal):TPrincipal;
begin
    result:=BinaryOp(e1,e2, nil,nil,  1002,1002,TBinaryOpOrdinal,'dmlt');
end;

function OpDivide(e1,e2:TPrincipal):TPrincipal;
begin
    result:=BinaryOp(e1,e2,nil,nil,  1002,3001,TBinaryOpOrdinal,'ddiv');
end;

function OpPlus(e1,e2:TPrincipal):TPrincipal;
begin
    result:=BinaryOp(e1,e2,nil,nil, 1002,1002,TBinaryOpOrdinal,'dadd');
end;

function OpMinus(e1,e2:TPrincipal):TPrincipal;
begin
    result:=BinaryOp(e1,e2, nil,nil, 1002,1002,TBinaryOpOrdinal,'dsbt');
end;

function OpMSYen(e1,e2:TPrincipal):TPrincipal;
begin
    setErr('',COMPILE_OPTION_SYNTAX);
end;

function OpMSMod(e1,e2:TPrincipal):TPrincipal;
begin
    setErr('',COMPILE_OPTION_SYNTAX);
end;

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

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





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

function Unary({op1:unaryoperation;} op2:floatfunction1;er2:smallint;const name:ansistring):TPrincipal;
begin
    Unary:=UnaryOp(argumentN1,nil{op1},nil,1003,er2,ExpressN.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,nil{op1},nil,1003,er2,ExpressN.TBinaryOp,name)
end;


type
  TUnaryX=class(TUnaryOp)
     //procedure evalN(var n:number);override;
   end;

  TBinaryX=class(TBinaryOp)
    //procedure evalN(var n:number);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);
    //procedure evalN(var n:number); override;
    destructor destroy;override;
    function code:AnsiString;override;
  end;

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



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

function NOperation(op:TPrincipal):TPrincipal ;
begin
   result:=TNOperation.create(op);
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}
{***********}

function NComparison(f:comparefunction; e1,e2:TPrincipal):TLogical;
begin
   NComparison:=TComparisonN.create(e1,e2,f)
end;


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

procedure SwitchToDecimalMode;
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}
{**************}

function MAXNUMfnc:TPrincipal;
var
   n:number;
begin
      MAXNUMfnc:=ExpressN.TNConstant.create(arithmet.constMAXNUM)
end;

function PIfnc:TPrincipal;
begin
    PIfnc:=TNConstant.create(arithmet.decimalPI^) ;
end;


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


procedure  FunctionTableInit;
begin
 if PrecisionMode in [PrecisionNormal]  then
   begin
       ReservedWordTableInit('MAXNUM', MAXNUMfnc );
       ReservedWordTableInit('PI'    , PIfnc);
   end;
end;

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


function TNConstant.Code:AnsiString;
begin
  with ValueN^ do
  result:='initNumber('+ FloatToStr(sig)+','+IntToStr(exp)+')'
end;

function TUnaryOpOrdinal.Code:Ansistring;
begin
   result:='ValidDecimal('+ name + '('+ exp.code + '),1002)'
end;

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

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

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

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

function TNOperation.code:AnsiString;
begin
  result:=Op.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 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;
}
begin
   tableInitProcs.accept(FunctionTableInit);
   SwitchToDecimalMode;
end.
