svn/view/expressc.pas

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


interface
uses variabl,express,struct,arithmet,{variabls,}mathc,{variablc,}float;

procedure SwitchToComplexMode;

{********************}
{numerical expression}
{********************}
 
type
    TNexpression=class(TPrincipal)
      constructor create;
      //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 evalX:extended;override;
      //procedure EvalN(var n:number);override;
     end;

type
   ComplexFunction1=procedure(var x:complex);
   ComplexFunction2=procedure(var x,y:complex);

type
   TUnaryOpOrdinal=class(TNExpression)
             exp:TPrincipal;
             opC:ComplexFunction1;
             name:ansistring;
          constructor create(e:TPrincipal; op1:FloatFunction1;
                             op2:extendedfunction1;op3:ComplexFunction1;
                             er1,er2:smallint;const n:ansistring);virtual;
          procedure evalC(var x:complex);override;
          function Code:Ansistring;override;
          destructor destroy;override;
          function QueryInteger:TSubstanceList;override;
          function QueryDouble:TSubstanceList;override;   // double������������������������������nil���������double���������
     end;

   TBinaryOpOrdinal=class(TNExpression)
             exp1,exp2:TPrincipal;
             opC:ComplexFunction2;
             name:ansistring;
          constructor create(e1,e2:TPrincipal;op1:FloatFunction2;
                              op2:extendedfunction2; op3:ComplexFunction2;
                              er1,er2:smallint;const n:ansistring);virtual;
          procedure evalC(var x:complex);override;
          function Code:Ansistring;override;
          destructor destroy;override;
          function QueryInteger:TSubstanceList;override;
          function QueryDouble:TSubstanceList;override;   // double������������������������������nil���������double���������
     end;


type
   TUnaryOp=class(TUnaryOpOrdinal)
             opF:FloatFunction1;
             opX:ExtendedFunction1;
             overflowcode:smallint;
             invalidcode:smallint;
          constructor create(e:TPrincipal; op1:FloatFunction1;
                             op2:extendedfunction1;op3:ComplexFunction1;
                             er1,er2:smallint;const n:ansistring);override;
          procedure evalC(var x:complex);override;
          function OverflowErCode:integer;override;
          function InvalidErCode:integer;override;
          function OpName:string;override;
          function QueryDouble:TSubstanceList;override;   // double������������������������������nil���������double���������
     end;

   TBinaryOp=class(TBinaryOpOrdinal)
             opF:FloatFunction2;
             opX:ExtendedFunction2;
             overflowcode:smallint;
             invalidcode:smallint;
          constructor create(e1,e2:TPrincipal;op1:FloatFunction2;
                              op2:extendedfunction2; op3:ComplexFunction2;
                              er1,er2:smallint;const n:ansistring);override;
          procedure evalC(var x:complex);override;
          function OverflowErCode:integer;override;
          function InvalidErCode:integer;override;
          function OpName:string;override;
          function QueryDouble:TSubstanceList;override;   // double������������������������������nil���������double���������
     end;


function UnaryCOrdinal(op2:complexfunction1;er2:smallint;const name:ansistring):TPrincipal;
function BinaryCOrdinal(op2:complexfunction2; er2:smallint;const name:ansistring):TPrincipal;
function UnaryC(op2:complexfunction1;er2:smallint;const name:ansistring):TPrincipal;
function BinaryC(op2:complexfunction2; er2:smallint;const name:ansistring):TPrincipal;

function ComplexExp(const c:complex):complex;

implementation

uses SysUtils,
  math,base,base0,objlist,texthand,helpctex,moddlg,optina,sconsts,suppliedc;


procedure CInit(var x:complex; a,b:double);
begin
   x.x:=a; x.y:=b
end;

procedure CAdd(var x,y:complex);
begin
      x.x:=x.x+y.x;
      x.y:=x.y+y.y;
end;

procedure CSub(var x,y:complex);
begin
      x.x:=x.x-y.x;
      x.y:=x.y-y.y;
end;

procedure CMultiply(var x,y:complex);assembler;
asm
   fld qword ptr [eax]      //x.x
   fld qword ptr [eax+$08]  //x.y
   fld qword ptr [edx]      //y.x
   fld qword ptr [edx+$08]  //y.y
   fld  st(3)              // x.x
   fmul st,st(1)           // x.x*y.y
   fld  st(3)              // x.y
   fmul st,st(3)           // x.y*y.x
   fadd                    // x.x*y.y+x.y*y.x
   fstp qword ptr [eax+$08]
   fmulp st(2),st          // x.y*y.y
   fmulp st(2),st          // x.x*y.x
   fsub                    // x.x*y.x-x.y*y.y
   fstp qword ptr [eax]
   wait
 end;


(*
procedure CMultiply(var x,y:complex);
var
  z:complex;
begin
   z.x:=x.x * y.x - x.y * y.y;
   z.y:=x.x * y.y + x.y * y.x;
   x:=z;
end;
*)

(*
procedure CDiv (var  x,y:complex);assembler;
asm
   fld qword ptr [eax]      //x.x
   fld qword ptr [eax+$08]  //x.y
   fld qword ptr [edx]      //y.x
   fld qword ptr [edx+$08]  //y.y
   fld st(1)               //y.x
   fmul st,st(0)           //y.x^2
   fld st(1)               //y.y
   fmul st,st(0)           //y.y^2
   fadd                    //y.x^2+y.y^2
   fdiv  st(2),st          // y.x���y.x/(y.x^2+y.y^2)
   fdivp st(1),st          // y.y���y.y/(y.x^2+y.y^2)
   fld  st(2)              // x.y
   fmul st,st(2)           // x.y*y.x
   fld  st(4)              // x.x
   fmul st,st(2)           // x.x*y.y
   fsub                    // x.y*y.x-x.x*y.y
   fstp qword ptr [eax+$08]
   fmulp st(2),st          // x.y*y.y
   fmulp st(2),st          // x.x*y.x
   fadd                    // x.x*y.x+x.y*y.y
   fstp qword ptr [eax]
   wait
 end;
*)


procedure CDiv (var  x,y:complex);
{$MAXFPUREGISTERS 0}
var
  z:complex;
  n:extended;
begin
   n:= sqr(y.x) + sqr(y.y);
   if n=0 then begin setexception(3001); exit end;
   z.x:=(x.x * y.x + x.y * y.y)/n;
   z.y:=(x.y * y.x - x.x * y.y)/n;
   x:=z;
end;


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


type
   TNConstant=class(TNExpression)
              valueC:complex;
           constructor create(var n:number);
           constructor create2(x:complex);
           procedure evalC(var x:complex);override;
           destructor destroy;override;
           function isConstant:boolean;override;
           function Code:AnsiString;override;
           function QueryInteger:TSubstanceList;override;
           function QueryDouble:TSubstanceList;override;
       end;

type
   TNFunction=class(TNExpression)
          exe   :TCALL;
          constructor create(idr:TIdrec);
          //procedure evalC(var x:complex);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;


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

destructor TNFunction.destroy;
begin
   exe.free;
   inherited destroy
end;
(*
procedure  TNFunction.evalC(var x:complex);
begin
   exe.evalC(x)
end;
*)

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


constructor TNConstant.create(var n:number);
begin
    inherited create;
    try
       CInit(valueC,extendedval(N),0);
    except
       seterr(s_TooLargeConstant,IDH_JIS_5);
    end;
end;

constructor TNConstant.create2(x:complex);
begin
    inherited create;
    valueC:=x;
end;

destructor TNConstant.destroy;
begin
   inherited destroy;
end;

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


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


constructor TunaryOpOrdinal.create(e:TPrincipal;op1:FloatFunction1;
                             op2:extendedfunction1;op3:ComplexFunction1;
                            er1,er2:smallint;const n:ansistring);
begin
    inherited  create;
    exp:=e;
    opC:=op3;
    name:=n;
end;

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

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

constructor TBinaryOpOrdinal.create(e1,e2:TPrincipal; op1:FloatFunction2;
                              op2:extendedfunction2; op3:ComplexFunction2;
                              er1,er2:smallint;const n:ansistring );
begin
    inherited  create;
    exp1:=e1;
    exp2:=e2;
    opC:=op3;
    name:=n;
end;

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

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


function UnaryOp( e:TPrincipal;op1:FloatFunction1;op2:extendedfunction1;
                            op3:ComplexFunction1;er1,er2:smallint;
                            opclass:TUnaryOpClass;const name:ansistring):TPrincipal;
var
   p:TPrincipal;
   n:number;
   x:complex;
   flag:boolean;
begin
   p:=opClass.create(e,op1,op2,op3,er1,er2,name);
   if e.isConstant then
        begin
          flag:=true;
          set8087cw($1372);
            try
              p.evalC(x);
            except
            {$IFNDEF Windows}
               asm finit end;
            {$ENDIF}
               extype:=0;
               flag:=false;
            end;
            set8087cw(OriginalCW);
            if flag then
               begin
                 p.free;
                 p:=TNConstant.create2(x);
               end;
       end;
   UnaryOp:=p
end;


function BinaryOp( e1,e2:TPrincipal;
                  op1:FloatFunction2;op2:extendedfunction2; op3:ComplexFunction2;
                  er1,er2:smallint; opclass:TBinaryOpClass;const name:ansistring):TPrincipal;
var
   p:TPrincipal;
   n:number;
   x:complex;
   flag:boolean;
begin
   p:=opClass.create(e1,e2,op1,op2,op3,er1,er2,name);
   if e1.isConstant and e2.isConstant then
      begin
         flag:=true;
         set8087cw($1372);
         try
            p.evalC(x)
         except
         {$IFNDEF Windows}
           asm finit end;
         {$ENDIF}
           flag:=false;
           extype:=0;
         end;
         set8087cw(OriginalCW);
         if flag then
            begin
               p.free;
               p:=TNConstant.create2(x);
            end;
       end;
   BinaryOp:=p
end;


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

type
   TUnaryF=class(TUnaryOP)
          procedure evalC(var c:complex);override;
     end;

   TBinaryF=class(TBinaryOP)
          procedure evalC(var c:complex);override;
     end;

type
  TUnaryX=class(TUnaryOp)
     procedure evalC(var x:complex); override;
   end;

  TBinaryX=class(TBinaryOp)
    procedure evalC(var x:complex);override;
   end;


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

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

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

function UnaryCOrdinal(op2:complexfunction1;er2:smallint;const name:ansistring):TPrincipal;
begin
   UnaryCOrdinal:=
      ExpressC.UnaryOp(argumentN1,nil,nil,op2,1003,er2,ExpressC.TUnaryOpOrdinal,name)
end;

function BinaryCOrdinal(op2:complexfunction2; er2:smallint;const name:ansistring):TPrincipal;
var
   a1:TPrincipal;
begin
   a1:=argumentN2a;
   BinaryCOrdinal:=
   ExpressC.BinaryOp(a1,ArgumentN2b,nil,nil,op2,1003,er2,ExpressC.TBinaryOpOrdinal,name)

end;

function UnaryC(op2:complexfunction1;er2:smallint;const name:ansistring):TPrincipal;
begin
   UnaryC:=ExpressC.UnaryOp(argumentN1,nil,nil,op2,1003,er2,ExpressC.TUnaryOp,name)
end;

function BinaryC(op2:complexfunction2; er2:smallint;const name:ansistring):TPrincipal;
var
   a1:TPrincipal;
begin
   a1:=argumentN2a;
   BinaryC:=ExpressC.BinaryOp(a1,ArgumentN2b,nil,nil,op2,1003,er2,ExpressC.TBinaryOp,name)

end;

{**********}
{NOperation}
{**********}
type
  TNOperation=class(TNExpression)
       Op:TPrincipal;
    constructor Create(e1:TPrincipal);
    procedure evalC(var x:complex); override;
    function code:AnsiString;override;
    function QueryInteger:TSubstanceList;override;   // Integer������������������������������nil������������������
    function QueryDouble:TSubstanceList;override;   // double���������������������������������������������������
    destructor destroy;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;

{****************}
{Execute Routines}
{****************}
function TNExpression.evalX:extended;
var
  c:complex;
begin
  evalC(c) ;
  if c.y<>0 then setExceptionNonReal;
  result:=c.x
end;

function TNExpression.evalLongint:longint;
begin
   result:={$IFDEF ver100}system.round{$ELSE}LongIntRound{$ENDIF}(evalX);
end;

procedure  TNConstant.evalC(var x:complex);
begin
    x:=valueC;
end;


procedure TUnaryOpOrdinal.evalC(var x:complex);
begin
    exp.evalC(x);
    opC(x);
end;

procedure TUnaryOp.evalC(var x:complex);
begin
    exp.evalC(x);
    CurrentOperation:=self;
    opC(x);
    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;

procedure  TBinaryOpOrdinal.evalC(var x:complex);
var
    m:complex;
begin
    exp1.evalC(x);
    exp2.evalC(m);
    opC(x,m);
end;

procedure  TBinaryOp.evalC(var x:complex);
var
    m:complex;
begin
    exp1.evalC(x);
    exp2.evalC(m);
    CurrentOperation:=self;
    opC(x,m);
    CurrentOperation:=nil;
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;


function IntPower(const c:complex; i: longint): complex;
var
  x,t:ExtComplex;
begin
  x.initC(c);
  if i<0 then
     begin
       i:=-i;
       x.inverse;
     end;
  t.init(1,0);             //Result := 1.0;
  while i > 0 do
   begin
     while not Odd(i) do
     begin
      i := i shr 1;
      x.square;            // X := X * X
     end;
     Dec(i);
     t.multiply(@x);       //Result := Result * X
  end;
  result.x:=t.x; result.y:=t.y
end;


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

function ComplexExp(const c:complex):complex;
var
    e:extended;
begin
    e:=system.exp(c.x);
    result.x:=e*cos(c.y);
    result.y:=e*sin(c.y);
end;

function ComplexPower(Base:extended; Exponent: complex): complex;
var
   t:extended;
   y:Complex;
begin
   if Exponent.y=0.0 then
      begin
        result.x:=PowerSub(base,Exponent.x);
        result.y:=0;
      end
   else
      begin
         t:=ln(Base);
         y.x:=t*Exponent.x;
         y.y:=t*Exponent.y;
         result:=ComplexExp(y)
      end;
end;

function Power(const Base, Exponent: complex): complex;
begin
  if (Exponent.x=0) and (exponent.y=0) then
     CInit(result,1.0,0)   //Result := 1.0
  else if (Base.x=0)and (Base.y=0) and ((Exponent.y<>0) or (exponent.x<0)) then
          setexception(3003)
  else if (Exponent.y=0) and  (frac(exponent.x)=0.0) and
          (Exponent.x > -Maxint) and (Exponent.x < MaxInt)   then
       Result := IntPower(Base, Trunc(Exponent.x))
  else if (Base.y=0.0) and (Base.x>0.0) then
         result:=ComplexPower(base.x, Exponent)
  else if (Base.x=0)and (Base.y=0) and (Exponent.y=0.0) and (Exponent.x>0) then
       CInit(result,0,0)
  else
     begin
        CInit(result,0,0);
        if (Base.x=0)and (Base.y=0) then
           setexception(3003)
        else
           setexception(3002) ;
      end;
end;

procedure CPower( var x,y:complex);
begin
    x:=Power(x,y)
end;

procedure CSquare(var x:complex);assembler;
asm
   fld qword ptr [eax]      //x.x
   fld qword ptr [eax+$08]  //x.y
   fld  st(1)              // x.x
   fmul st,st(0)           // x.x^2
   fld  st(1)              // x.y
   fmul st,st(0)           // x.y^2
   fsub                    // x.x^2-x.y^2
   fstp qword ptr [eax]
   fmulp st(1),st          // x.x*x.y
   fadd st,st(0)           // 2*x.x*x.y
   fstp qword ptr [eax+$08]
   wait
 end;

(*
procedure CSquare(var x:complex);
var
   z:complex;
begin
   z.x:= sqr(x.x)-sqr(x.y);
   z.y:=2*x.x * x.y;
   x:=z;
end;
*)

procedure COppose(var x:complex);
begin
    x.x:=-x.x; x.y:=-x.y
end;


function OpPower(e1,e2:TPrincipal):TPrincipal;
begin
   result:=BinaryOp(e1,e2,nil,nil,CPower,1002,3002,TBinaryOpOrdinal,'power')
end;

function OpSquare(e1:TPrincipal):TPrincipal;
begin
  result:=UnaryOp(e1,nil,nil,CSquare,1002,1002,TUnaryOpOrdinal,'CSqr')
end;

function  OpUnaryMinus(e1:TPrincipal):TPrincipal;
begin
     result:=UnaryOp(e1,nil,nil, COppose,1002,1002,TUnaryOpOrdinal,'COpo');
end;

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

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

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

function OpMinus(e1,e2:TPrincipal):TPrincipal;
begin
    result:=BinaryOp(e1,e2, nil,nil,CSub, 1002,1002,TBinaryOpOrdinal,'CSub');
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;


procedure TUnaryF.evalC(var c:complex);
begin
    exp.evalC(c);
    if (c.y=0) then
       try
          opF(c.x);
       except
          on EOverflow do
                setexceptionwith(name,overflowcode);
          on EMathError do
                setexceptionwith(name,invalidcode);
          on EDivByZero do
                setexceptionwith(name,invalidcode);
       end
    else
        setexceptionwith(name + '('+CStr(c)+')',3000)  ;
end;

procedure  TBinaryF.evalC(var c:complex);
var
    m:complex;
begin
    exp1.evalC(c);
    exp2.evalC(m);
    if (c.y=0) and (m.y=0) then
       try
           opF(c.x,m.x);
       except
          on EOverflow do
                setexceptionwith(name,overflowcode);
          on EMathError do
                setexceptionwith(name,invalidcode);
          on EDivByZero do
                setexceptionwith(name,invalidcode);
        end
    else
             setexceptionwith(name + '('+CStr(c)+','+CStr(m)+')',3000)  ;
end;

procedure TUnaryX.evalC(var x:complex);
var
   y:complex;
   b:bytebool;
begin
       exp.evalC(y);
       if y.y=0.0 then
         begin
            x.y:=0.0;
            try
              x.x:=opX(y.x);
            except
              on EOverflow do
                  setexceptionwith(name+'('+CStr(y)+')',overflowcode);
              on EMathError do
                  setexceptionwith(name+'('+CStr(y)+')',invalidcode);
              on EDivByZero do
                  setexceptionwith(name+'('+CStr(y)+')',invalidcode);
            end;
         end
        else
                  setexceptionwith(name+'('+CStr(y)+')',3000);
end;

procedure  TBinaryX.evalC(var x:complex);
var
    y,z:complex;
    b:bytebool;
begin
    exp1.evalC(y);
    exp2.evalC(z);
       if (y.y=0.0) and (z.y=0.0) then
         begin
            x.y:=0.0;
            try
              x.x:=opX(y.x,z.x);
            except
               on EOverflow do
                  setexceptionwith(name+'('+CStr(y)+','+CStr(z)+')',overflowcode);
               on EMathError do
                  setexceptionwith(name+'('+CStr(y)+','+CStr(z)+')',invalidcode);
               on EDivByZero do
                  setexceptionwith(name+'('+CStr(y)+','+CStr(z)+')',invalidcode);
            end;
         end
       else
         setexceptionwith(name+'('+CStr(y)+','+CStr(z)+')',3000);
end;

procedure TNOperation.evalC(var x:complex);
begin
   op.EvalC(x)
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;


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

{***********}
{Code Gen.  }
{***********}

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

function TNOperation.QueryInteger:TSubstanceList;   // integer������������������������������nil������������������
begin
     result:=Op.QueryInteger
end;

function TNOperation.QueryDouble:TSubstanceList;   // double���������������������������������������������������
begin
      result:=TSubstanceList.create
end;

function TNConstant.Code:AnsiString;
begin
   if valueC.y=0 then
     result:=Format17(valueC.x)
   else
     result:='CMPLX(' + Format17(valueC.x) + ',' + Format17(valueC.y) +')' ;
end;

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

function TNConstant.QueryDouble:TSubstanceList;
begin
  if ValueC.y=0 then
    result:=TSubstanceList.create
  else
    result:=nil
end;

function TUnaryOpOrdinal.Code:Ansistring;
begin
  if @opC=@COppose then
      result := ' - (' + exp.code + ')'
  else
      result:= name + '('+ exp.code + ')'
end;

function TBinaryOpOrdinal.Code:Ansistring;
begin
  if @opC=@CAdd then
       result:=  exp1.code + '+' + exp2.code
  else if @opC=@Csub then
       result:=  exp1.code + '-' + exp2.code
  else if @opC=@Cmultiply then
       result:= '(' + exp1.code + ')*(' + exp2.code +')'
  else if @opC=@Cdiv then
       result:= '(' + exp1.code + ')/(' + exp2.code +')'
  else
       result:= name + '('+ exp1.code + ' , ' + exp2.code + ')'
end;

function TUnaryOpOrdinal.QueryDouble:TSubstanceList;   // double������������������������������nil���������double���������
begin
  if (@opC=@CSQRT) or (@opC=@CSquare) or (@opC=@CConj) then
     result:=nil
  else
     result:=TSubstanceList.create;
end;

function TUnaryOp.QueryDouble:TSubstanceList;   // double������������������������������nil���������double���������
begin
  if  @opC=@CLOG  then result:=nil
  else if @opC=@CEXP then
    result:=exp.QueryDouble
 else
    result:=TSubstanceList.create;
end;

function TBinaryOpOrdinal.QueryDouble:TSubstanceList;   // double������������������������������nil���������double���������
begin
   if (@opC=@CCOMPLEX) or (@opC=@opPower) then
     result:=nil
  else
     result:=mergedList(exp1.QueryDouble, exp2.QueryDouble);
end;


function TBinaryOp.QueryDouble:TSubstanceList;   // double������������������������������nil���������double���������
begin
    result:=TSubstanceList.create;
end;

function TUnaryOpOrdinal.QueryInteger:TSubstanceList;   // Integer������������������������������nil������������������
begin
  if (@opC=@COppose) then
    result:=exp.QueryInteger
  else
     result:=nil
end;

function TBinaryOpOrdinal.QueryInteger:TSubstanceList;   // Integer������������������������������nil������������������
begin
   if (@opC=@CAdd) or (@opC=@CSub) then
     result:=mergedList(exp1.QueryInteger, exp2.QueryInteger)
  else
     result:=nil
end;


function TNFunction.Code:AnsiString;
begin
   result:= exe.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;


{***********}
{Mode Switch}
{***********}
procedure SwitchToComplexMode;
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.NSubscripted1:=Nsubscripted1;
   Express.NSubscripted2:=Nsubscripted2;
   Express.NSubscripted3:=Nsubscripted3;
   Express.NSubscripted4:=Nsubscripted4;

   EXpress.NComparison:=NComparison;
end;

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

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

function MAXNUMfnc:TPrincipal;far;
var
   c:complex;
begin
   c.x:=maxnumberDouble; c.y:=0;
   MAXNUMfnc:=expressC.TNConstant.create2(c)
end;

function PIfnc:TPrincipal;far;
var
   c:complex;
begin
    c.x:=pi; c.y:=0;
    PIfnc:=TNConstant.create2(c) ;
end;

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

procedure  FunctionTableInit;far;
begin
 if precisionMode=PrecisionComplex then
   begin
       ReservedWordTableInit('MAXNUM' , MAXNUMfnc );
       ReservedWordTableInit(  'PI' ,  PIfnc);
   end;
end;

begin
   tableInitProcs.accept(FunctionTableInit);
end.
