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

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


interface
uses  SysUtils,Classes, LCLProc,
    variabl,arithmet,mathc;


function reservedwordfnc:TPrincipal;

type
  TMiscInt=class(TPrincipal)
     // evalLongInt;を定義することによって定義されるoperation
     CharacterByte:boolean;
    constructor create;
      function evalF:double;override;
      procedure evalC(var x:complex);override;
      function QueryInteger:TSubstanceList;override;   // Integer型となるための条件。nilのとき不可。
   end;

type
  TMiscReal=class(TPrincipal)
     // evalXを定義することによって定義されるoperation
     // 数値の変換によって桁あふれが発生するような場合には適用しない。
      function evalF:double;override;
      procedure evalC(var x:complex);override;
   end;



implementation
uses
    myutils,float,base0,
    base,express,struct,texthand,
    helpctex,math2,math2sub{,graphsys},sconsts,matexpr;

function ABSfnc:TPrincipal;
begin
    ABSfnc:=Unary({arithmet.absolute,}FABS,1003,'ABS')
end ;

function EPSfnc:TPrincipal;
begin
  if ProgramUnit.arithmetic=PrecisionNormal then
    EPSfnc:=Unary({arithmet.EpsDecimal,}FEPS,1003,'EPS')
  else
    EPSfnc:=Unary({arithmet.EpsNative,}FEPS,1003,'EPS')
end ;

procedure FFP(var x:double);
begin
   x:=x-INT(x);
end;

function FPfnc:TPrincipal;
begin
     FPfnc:=Unary({arithmet.FractPart,}FFP,1003,'FRAC')
end ;

procedure FIP(var x:double);
begin
    x:=int(x) ;
end;

function IPfnc:TPrincipal;
begin
  if OptimizeInteger
     and (ProgramUnit.arithmetic in [PrecisionNative, PrecisionComplex]) then
  IPfnc:=Unary({Arithmet.intpart,}FIP,1003,'trunc')
  else
    IPfnc:=Unary({Arithmet.intpart,}FIP,1003,'INT')
end ;


function INTfnc:TPrincipal;
begin
  if OptimizeInteger
     and (ProgramUnit.arithmetic in [PrecisionNative, PrecisionComplex]) then
     INTfnc:=Unary({arithmet.BASICINT,}FFloor,1003,'floor')
   else
     INTfnc:=Unary({arithmet.BASICINT,}FFloor,1003,'BINT')
end ;


function CEILfnc:TPrincipal;
begin
  if OptimizeInteger
     and (ProgramUnit.arithmetic in [PrecisionNative, PrecisionComplex]) then
     CEILfnc:=Unary({arithmet.ceil,}FCEIL,1003,'ceil')
  else
     CEILfnc:=Unary({arithmet.ceil,}FCEIL,1003,'BCEIL')
end ;




function MAXfnc:TPrincipal;
begin
   MAXfnc:=Binary({arithmet.max,}FMAX,1003,'BMAX')
end;



function MINfnc:TPrincipal;
begin
   MINfnc:=Binary({arithmet.min,}FMIN,1003,'BMIN')
end;


function MODfnc:TPrincipal;
begin
   MODfnc:=Binary({arithmet.BasicMOD,}Float.BasicMod,3006,'BMOD')
end;

procedure FRemainder(var x,y:double);
begin
   x:=x-y*int(x/y)
end;

function REMAINDERfnc:TPrincipal;
begin
   REMAINDERfnc:=Binary({arithmet.remainder,}FRemainder,3006,'REMAINDER')
end;


function power10(i:integer):extended;
var
   x,y:extended;
begin
    x:=10.;
    y:=1.;
    if i<0 then begin x:=1./x ; i:=-i end;
    while i>0 do
        begin
           if i mod 2 =1 then
              y:=y*x;
           i:=i div 2;
           if i>0 then x:=x*x;
        end;
    power10:=y
end;

procedure round2(var x,n:double);
var
   e:extended;
begin
     e:=power10(LongIntRound(n));
     x:=x*e+0.5;
     FFLOOR(x);
     x:=x/e;
end;

procedure truncate(var x,n:double);
var
   e:extended;
begin
     e:=power10(LongIntRound(n));
     x:=x*e;
     x:=int(x);
     x:=x/e;
end;

function ROUNDfnc:TPrincipal;
var
   svcp:^tokensave;
   exp:TPrincipal;
   token1:string;
begin
   new(svcp);
   savetoken(svcp^);
   check('(',IDH_FUNCTIONS);
   exp:=NExpression;
   exp.free;
   token1:=token;
   try
     restoretoken(svcp^);
     if token1=')' then
       if OptimizeInteger
          and (ProgramUnit.arithmetic in [PrecisionNative, PrecisionComplex]) then
           ROUNDfnc:=Unary({arithmet.intround,}float.FROUND,1002,'system.round')
       else
           ROUNDfnc:=Unary({arithmet.intround,}float.FROUND,1002,'ROUND')
     else
       ROUNDfnc:=Binary({arithmet.round,}round2,1002,'ROUND');
   finally
     dispose(svcp);
   end;
end;

procedure FSIGN(var x:double);
begin
  x:=float.fsign(x)
end;

function SGNfnc:TPrincipal;
begin
    SGNfnc:=Unary({sgn,}FSIGN,1002,'SGN')
end ;


function TRUNCATEfnc:TPrincipal;
begin
    TRUNCATEfnc:=Binary({Arithmet.truncate,}truncate,1002,'TRUNCATE')
end ;


{*********}
{extension}
{*********}
function permX(n,r:double):double;
var
   i,k:longint;
begin
   k:=LongIntRound(r);
   if k<0 then
      begin
         result:=0;
         setexception(3000)
      end
   else
      begin
         result:=1;
         for i:=1 to k do
             begin
                result:=result*n;
                n:=n-1;
             end;
      end;
end;

function combX(n,r:double):double;
var
   i,k:longint;
   m:double;
   x:extended;
begin
   FROUND(r);
   k:=LongIntRound(r);
   if k<0 then
     x:=0
   else if (k>n/2) and (n=int(n)) and (n>0) then
     x:=combX(n,n-r)
   else
     begin
        x:=1;
        m:=1;
        for i:=1 to k do
           begin
             x:=x*n/m;
             n:=n-1;
             m:=m+1;
          end;
     end;
   result:=x;
end;

function factX(n:double):double;
begin
   result:=permX(n,n)
end;

procedure Fperm(var n,r:double);
begin
   n:=permX(n,r)
end;

procedure Fcomb(var n,r:double);
begin
   n:=combX(n,r)
end;

procedure Ffact(var n:double);
begin
   n:=factX(n)
end;

function FACTfnc:TPrincipal;
begin
    FACTfnc:=Unary({fact,}Ffact,4000,'FACT')
end ;

function PERMfnc:TPrincipal;
begin
   PERMfnc:=Binary({perm,}Fperm,4000,'PERM')
end;

function COMBfnc:TPrincipal;
begin
   COMBfnc:=Binary({comb,}Fcomb,4000,'COMB')
end;

{*************}
{reserved word}
{*************}



function reservedwordfnc:TPrincipal;
begin
     seterr(prevtoken+s_IsReserved,IDH_RESERVED);
     reservedwordfnc:=nil
end;

{************}
{SQR function}
{************}
function MySqrt(x:double):double;
begin
  result:=sqrt(x)
end;

function SQRfnc1:TPrincipal;
begin
   SQRfnc1:=UnaryX(MySqrt,3005,'SQRT')
end;

function SQRfnc2:TPrincipal;
begin
     SQRfnc2:=Unary({arithmet.sqrlong,}FSQRT,3005,'SQRT')
end;

{***********************}
{miscellaneous Functions}
{***********************}
function TMiscReal.evalF:double;
begin
   result:=evalX;
end;

procedure TMiscReal.evalC(var x:complex);
begin
     x.x:=evalX; x.y:=0;
end;


type
  RealFunction=function:double;

  TNoArgReal=class(TMiscReal)
     op:Realfunction;
     name:ansistring;
    constructor create(f:realFunction; const name1:string);
    function evalX:extended;override;
    function code:AnsiString;override;
  end;

constructor TNoArgReal.create(f:realFunction; const name1:string);
begin
   inherited create;
   op:=f;
   name:=name1

end;

function TNoArgReal.evalX:extended;
begin
   result:=op ;
end;

function TNoArgReal.code:ansistring;
begin
  result:=name + ' '
end;


function DATEfnc:TPrincipal;
begin
   DATEfnc:=NOperation(TNoArgReal.create(mydate,'mydate'))
end;

function TIMEfnc:TPrincipal;
begin
   TIMEfnc:=NOperation(TNoArgReal.create(myTime,'mytime'))
end;

function RNDfnc:TPrincipal;
begin
   if token='(' then
      seterr(s_RND, IDH_RANDOM);
   if precisionMode in [PrecisionNative,PrecisionComplex] then
      RNDfnc:=NOperation(TNoArgReal.create(Math2Sub.random52,'random52'))
   else
      RNDfnc:=NOperation(TNoArgReal.create(Math2Sub.random50,'random50'))
end;

{********}
{TMiscInt}
{********}

constructor TMiscInt.create;
begin
   Inherited create;
   CharacterByte:=ProgramUnit.CharacterByte;
end;

function TMiscInt.evalF:double;
begin
     result:=evalLongInt;
end;

procedure TMiscInt.evalC(var x:complex);
begin
   x.x:=evalLongInt;
   x.y:=0
end;

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


{*************}
{lbound,ubound}
{*************}

type
   TLbound=class(TMiscInt)
       mat:TMatrix;
       exp:TPrincipal;
       dir:char;
    constructor create(k:char);
    destructor destroy;override;
    function code:ansistring;override;
    end;

function  LBOUNDfnc:TPrincipal;
begin
    LBOUNDfnc:=NOperation(TLBound.create('L'))
end;

function UBOUNDfnc:TPrincipal;
begin
     UBOUNDfnc:=NOperation(TLBound.create('U'))
end;

constructor TLBound.create(k:char);
begin
    inherited create;
    dir:=k;
    check('(',IDH_ARRAY_FUNCTION);
    mat:=matrix;
    if token=',' then
        begin
           gettoken;
           exp:=Nexpression;
        end;
   check(')',IDH_ARRAY_FUNCTION);
   if (mat.idr.dim>1) and (exp=nil) then
                   seterrdimension(IDH_ARRAY_FUNCTION) ;
end;

destructor TLBound.destroy;
begin
     mat.free;
     exp.free;
    inherited destroy;
end;

function TLBound.code:ansistring;
begin
   result:=mat.code;
   case dir of
       'L':result:=result+'.LBOUND';
       'U':result:=result+'.UBOUND';
   end;
   if exp<>nil then
      result:=result + '('+exp.code+')';
end;



{**************}
{SIZE functions}
{**************}

type
   TSize=class(TMiscInt)
       mat:TMatrix;
       exp:TPrincipal;
    constructor create;
    destructor destroy;override;
    function code:ansistring;override;
    end;

constructor TSize.create;
begin
    inherited create;
    check('(',IDH_ARRAY_FUNCTION);
    mat:=matrix;
    if token=',' then
        begin
           gettoken;
           exp:=Nexpression;
        end;
   check(')',IDH_ARRAY_FUNCTION);
end;

destructor TSize.destroy;
begin
     mat.free;
     exp.free;
    inherited destroy;
end;

function TSize.code:ansistring;
begin
   if exp=nil then
      result:=mat.code+'.size '
   else
      result:=mat.code+'.size('+exp.code+')'

end;


function SIZEfnc:TPrincipal;
begin
     SIZEfnc:=NOperation(TSize.create)
end;


{*************}
{LEN functions}
{*************}

type
    TLEN=class(TMiscInt)
       exp:TPrincipal;
      constructor create;
      //function  evalLongInt:LongInt;override;
      destructor destroy;override;
      function code:ansistring;override;
    end;

    TBLEN=class(TLEN)
      //function  evalLongInt:LongInt;override;
      function code:ansistring;override;
    end;

constructor TLEN.create;
begin
    inherited create;
    check('(',IDH_STRING_FUNCTIONS);
    exp:=SExpression;
    check(')',IDH_STRING_FUNCTIONS);
end;

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

(*
function TLEN. evalLongInt:LongInt;
begin
   result:=Length(exp.evalS);
end;

function TBLEN. evalLongInt:LongInt;
begin
    result:=length(exp.evalS);
end;
*)

function  BLENfnc:TPrincipal;
begin
    BLENfnc:=NOperation(TBLEN.create)
end;

function  LENfnc:TPrincipal;
begin
   if ProgramUnit.CharacterByte then
      Lenfnc:=BLENFnc
   else
      LENfnc:=NOperation(TLEN.create)
end;

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

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



type
   TMAXLEN=class(TMiscInt)
        mat:TSubstance;
      constructor create;
      function Code:Ansistring;override;
    end;

function  MAXLENfnc:TPrincipal;
begin
    MAXLENfnc:=NOperation(TMAXLEN.create)
end;

constructor TMAXLEN.create;
var
  idr:TIdRec;
begin
    inherited create;
    check('(',IDH_STRING_FUNCTIONS);
    idr:=IdRecord(true);
    if (idr=nil) or (idr.kindchar<>'s') then seterrExpected(s_StringVariable,480);
    Gettoken;
    check(')',IDH_STRING_FUNCTIONS);
    mat:=idr.subs;
end;

function TMaxLen.Code:ansistring;
begin
   result:='MaxInt '
end;




{********}
{ MAXSIZE}
{********}

type
   TMAXSIZE=class(TMiscInt)
       mat:TMatrix;
    constructor create;
    destructor destroy;override;
    //function  evalLongInt:LongInt;override;
    function code:ansistring;override;
    end;

constructor TMAXSIZE.create;
begin
    inherited create;
    check('(',IDH_ARRAY_FUNCTION);
    mat:=matrix;
    check(')',IDH_ARRAY_FUNCTION);
end;

destructor TMAXSIZE.destroy;
begin
     mat.free;
     inherited destroy;
end;

function TMAXSIZE.code:ansistring;
begin
  result:=mat.Code+'.MaxSize ';
end;

function  MAXSIZEfnc:TPrincipal;
begin
    MAXSIZEfnc:=NOperation(TMAXSIZE.create)
end;


{************}
{ORD function}
{************}


{
function BasicOrd(s:AnsiString; CharacterByte:boolean):longint;
var
   i:integer;
   charlen:integer;
begin
   if Length(s)=1 then
      BasicOrd:=ord(s[1])
   else if (Length(s)=3) and (byte(s[1])<128) then
      begin
         s:=AnsiUpperCase(s);
         if (length(s)=3) and (copy(s,1,2)='LC') then
             BasicOrd:=ord(s[3])+32
         else
         begin
             for i:=0 to 39 do
                 if s=CharNameTBL1[i] then begin BasicOrd:=CharNameTBL2[i]; exit end;
             BasicOrd:=0;
             setexceptionwith('ORD',4003);
         end ;
      end
    else if characterbyte then
      begin
             basicORD:=0;
             setexceptionwith('basicORD',4003);
      end
    else
      begin
         BASICOrd:=UTF8CharacterToUnicode(PChar(s),charlen);
         if charlen<length(s) then  setexceptionwith('basicORD',4003);
      end;
end;
}

type
   TORD=class(TLEN)
      //function  evalLongInt:LongInt;override;
      function code:ansistring;override;
     end;

function  ORDfnc:TPrincipal;
begin
    ORDfnc:=NOperation(TORD.create)
end;

{
function TORD. evalLongInt:LongInt;
begin
    result:=BasicOrd(exp.evalS,CharacterByte);
end;
}

function TOrd.Code:ansistring;
begin
   result:='basicORD('+exp.code+ ',' + TruthLiteral(characterbyte) +')';
   if exp is TStrConstant then
   try
      result := strint(evalLongInt)
   except
   end;
end;

{************}
{POS function}
{************}

type
   TPos=class(TMiscInt)
      exp1,exp2,exp3:TPrincipal;
      constructor create;
      //function  evalLongInt:LongInt;override;
      destructor destroy;override;
      function Code:ansistring;override;
    end;

   TPosByte=class(TPos)
      function Code:ansistring;override;
   end;

constructor TPos.create;
begin
    inherited create;
    check('(',IDH_STRING_FUNCTIONS);
    exp1:=SExpression;
    check(',',IDH_STRING_FUNCTIONS);
    exp2:=SExpression;
    if token=',' then
        begin
             gettoken;
             exp3:=NExpression;
        end;
    check(')',IDH_STRING_FUNCTIONS);
end;

destructor TPos.destroy;
begin
     exp1.free;
     exp2.free;
     exp3.free;
end;

(*
function pos2(const a,b:ansistring):integer;
begin
   if b<>'' then
      pos2:=pos(b,a)
   else
      pos2:=1;
end;

function pos3(const a,b:ansistring; m:integer):integer;
var
   temp1,temp3:integer;
   temp2:ansistring;
begin
   if m<=length(a) then
     begin
       temp1:=max(1,min(m,length(a)+1));
       temp2:=copy(a,temp1,maxint);
       temp3:=pos2(temp2,b);
       if temp3=0 then
          pos3:=0
       else
          pos3:=temp3+temp1-1
     end
   else
     pos3:=0;
end;

function UTF8Pos2(const a,b:ansistring):integer;
begin
   if b<>'' then
      result:=Pos(b,a)
   else
      result:=1;
end;

function UTF8Pos3(const a,b:ansistring; m:integer):integer;
var
   temp1,temp3:integer;
   temp2:ansistring;
begin
   if m<=Length(a) then
     begin
       temp1:=max(1,min(m,Length(a)+1));
       temp2:=Copy(a,temp1,maxint);
       temp3:=UTF8Pos2(temp2,b);
       if temp3=0 then
          Result:=0
       else
          Result:=temp3+temp1-1
     end
   else
     result:=0;
end;

function TPos. evalLongInt:LongInt;
var
   a,b:ansistring;
   m:longint;
begin
    //m:=1;
    result:=0;
    a:=exp1.evalS;
    b:=exp2.evalS;
    if exp3=nil then
           begin
              if CharacterByte then
                result:=pos2(a,b)
              else
           end
    else
          begin
             m:=exp3.evalInteger;
             if CharacterByte then
                 result:=pos3(a,b,m)
             else

          end;
end;
*)


function TPosByte.Code:AnsiString;
begin
  if exp3=nil then
     result:='pos2('+exp1.code+','+exp2.code+')'
  else
     result:='pos3('+exp1.code+','+exp2.code+','+exp3.code+')';
end;

function TPos.Code:AnsiString;
begin
  if exp3=nil then
     result:='UTF8Pos2('+exp1.code+','+exp2.code+')'
  else
     result:='UTF8Pos3('+exp1.code+','+exp2.code+','+exp3.code+')';
end;

function  POSfnc:TPrincipal;
begin
   if ProgramUnit.CharacterByte then
       POSfnc:=NOperation(TPosByte.create)
   else
       POSfnc:=NOperation(TPos.create)
end;

{****}
{BVAL}
{****}
type
   TBVAL=class(TMiscReal)
      exp:TPrincipal;
      bin:boolean;
      constructor create;
      function evalX:Extended;override;
      destructor destroy;override;
      function Code:AnsiString;override;
    end;

function  BVALfnc:TPrincipal;
begin
    BVALfnc:=NOperation(TBVAL.create)
end;

constructor TBVAL.create;
begin
    inherited create;
    check('(',IDH_STRING_FUNCTIONS);
    exp:=SExpression;
    check(',',IDH_STRING_FUNCTIONS);
    if token='2' then
       begin gettoken; bin:=true end
    else
       checkToken1('16',IDH_STRING_FUNCTIONS);
    check(')',IDH_STRING_FUNCTIONS);
end;


function TBVAL.evalX:extended;
var
  s:ansistring;
  i:integer;
  t:extended;
  c:char;
Label
  ErrorExit;
begin
    s:=exp.evalS;
    if bin then
       begin
          result:=0.;
          t:=1.;
          i:=length(s);
          while i>0 do
            begin
               case s[i] of
                  '0' : ;
                  '1' : result:=result + t;
                  else  goto ErrorExit;
               end;
               t:=t*2.;
               dec(i)
            end;
       end
    else
       begin
          result:=0;
          t:=1.;
          i:=length(s);
          while i>0 do
            begin
               c:=s[i];
               case c of
                  '0'..'9' : result:=result + t * (ord(c)-ord('0'));
                  'A'..'F' : result:=result + t * (ord(c)-ord('A')+10);
                  'a'..'f' : result:=result + t * (ord(c)-ord('a')+10);
                  else  goto ErrorExit;
               end;
               t:=t*16.;
               dec(i)
            end;
       end;
    exit;

 ErrorExit:
    setexceptionwith('BVAL',4201);
end;


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

function TBVAL.Code:ansistring;
begin
  if bin then result:='BVAL2(' else result:='BVAL16(';
  result:=result+exp.code+')' ;
  if exp is TStrConstant then
  try
     result:=Format20(evalX)
  except
  end;
end;


{************}
{VAL function}
{************}
type
   TVAL=class(TLEN)       //TLENのconstructorを流用する
     function OverflowErCode:integer;override;
     function OpName:string;override;
     function Code:Ansistring;override;
     function QueryInteger:TSubstanceList;override;   // Integer型となるための条件。nilのとき不可。
   end;

function  VALfnc:TPrincipal;
begin
    VALfnc:=NOperation(TVAL.create)
end;

function TVAL.OverflowErCode:integer;
begin
  result:=1004
end;

function TVal.OpName:string;
begin
  result:='VAL'
end;

function TVAL.Code:AnsiString;
begin
   result:='baslib.VAL('+exp.Code+')'
end;

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

{******}
{EXTYPE}
{******}
type
    TEXTYPE=class(TMiscInt)
          whenBlock:TWhenException;
        constructor create;
        function Code:AnsiString;override;
      end;

constructor TEXTYPE.create;
begin
   inherited create;
   with WhenUseStack do WhenBlock:=items[count-1];
   if WhenBlock=nil then seterr(prevtoken+s_CantBelongHere,IDH_WHEN);
end;

function TEXTYPE.Code:AnsiString;
begin
   result:='EXTYPE(E,ExcodeRec)'
end;

type
    TEXTYPEinHandler=class(TMiscInt)
          Handler:THandler;
        constructor create;
        function Code:AnsiString;override;
      end;

constructor TEXTYPEinHandler.create;
begin
   inherited create;
   handler:=LocalRoutine as THandler;
end;

function TEXTYPEinHandler.Code:AnsiString;
begin
   result:='EXTYPE(E,ExcodeRec)'
end;


function EXTYPEfnc:TPrincipal;
begin
  if (LocalRoutine=nil) or not (LocalRoutine is THandler) then
     EXTYPEfnc:=NOperation(TEXTYPE.create)
  else
     EXTYPEfnc:=NOperation(TEXTYPEinHandler.create);
  EXTYPEAppear:=true;
end;


type
   TEXLINE=class(TEXTYPE)
        function Code:AnsiString;override;
        constructor create;
   end;

constructor TEXLINE.create;
begin
   inherited create;
   WhenBlock.HaveExline:=true;
   EXLineAppear:=True;
end;

type
   TEXLINEinHandler=class(TEXTYPEinHandler)
        constructor create;
        function Code:AnsiString;override;
   end;

constructor TEXLINEinHandler.create;
begin
  inherited create;
  Handler.HaveExline:=true;
  EXLineAppear:=True;
end;

function EXLINEfnc:TPrincipal;
begin
  if (LocalRoutine=nil) or not (LocalRoutine is THandler) then
     EXLINEfnc:=NOperation(TEXLINE.create)
  else
     EXLINEfnc:=NOperation(TEXLINEinHandler.create)
end;

function TEXLINE.Code:AnsiString;
begin
   result:='LabelNumbers[ExLineNumb]'
end;

function TEXLINEinHandler.Code:AnsiString;
begin
   result:='LabelNumbers[ExLineNumb]'
end;

{*************}
{DOT function }
{*************}


type
   TDOT=class(TPrincipal)
       mat1,MAT2:TMatrix;
    constructor create;
    destructor destroy;override;
    function overflowErCode:integer;override;
    function Code:AnsiString;override;
    end;

function  DOTfnc:TPrincipal;
begin
    DOTfnc:=NOperationMaybeComplex(TDOT.create)
end;

constructor TDOT.create;
begin
    inherited create;
    check('(',IDH_ARRAY_FUNCTION);
    mat1:=Nmatrix;
    check(',',IDH_ARRAY_FUNCTION);
    mat2:=Nmatrix;
    check(')',IDH_ARRAY_FUNCTION);
    if (mat1=nil) or (mat2=nil) or (mat1.idr.dim<>1) or (mat2.idr.dim<>1) then
                              begin seterrDimension(IDH_ARRAY_FUNCTION);{done;fail} end;
end;

destructor TDoT.destroy;
begin
     mat1.free;
     mat2.free;
    inherited destroy;
end;
function TDOT.overflowErCode:integer;
begin
  result:=1009
end;

function TDot.Code:Ansistring;
begin
   result:='dot(' + mat1.code +','+ mat2.code + ')';
end;

{*************}
{DET function }
{*************}

type
  TDET=class(TPrincipal)
       //mat:TMatrix;
       matexp1:TMatExp;                                         //ver.8.1.5.0
    constructor create;
    destructor destroy;override;
    function overflowErCode:integer;override;

    function Code:AnsiString;override;
  end;

function  DETfnc:TPrincipal;
begin
    DETfnc:=NOperationMaybeComplex(TDET.create)
end;

constructor TDET.create;
begin
    inherited create;
    check('(',IDH_ARRAY_FUNCTION);
    matexp1:=matexp;
    // if (mat.idr.dim<>2) then
    //            begin seterrdimension(IDH_ARRAY_FUNCTION) ;{done;fail} end;
    check(')',IDH_ARRAY_FUNCTION);
end;

destructor TDET.destroy;
begin
    matexp1.free;
    inherited destroy;
end;
function TDET.overflowErCode:integer;
begin
  result:=1009
end;

function TDET.Code:Ansistring;
begin
  result:='DET('+matexp1.code+')'
end;

{**********}
{ColorIndex}
{**********}
type
   TColorIndex=class(TMiscInt)
      exp1,exp2,exp3:TPrincipal;
      constructor create;
      //function  evalLongInt:LongInt;override;
      destructor destroy;override;
      function Code:AnsiString;override;
    end;

constructor TColorIndex.create;
begin
    inherited create;
    check('(',IDH_STRING_FUNCTIONS);
    exp1:=NExpression;
    check(',',IDH_STRING_FUNCTIONS);
    exp2:=NExpression;
    check(',',IDH_STRING_FUNCTIONS);
    exp3:=NExpression;
    check(')',IDH_STRING_FUNCTIONS);
end;

destructor TColorIndex.destroy;
begin
     exp1.free;
     exp2.free;
     exp3.free;
  inherited destroy;
end;



function TColorIndex.Code:AnsiString;
begin
  result:='ColorIndex(' + exp1.code + ',' + exp2.code + ',' + exp3.code +')';
end;



function  ColorIndexfnc:TPrincipal;
begin
    ColorIndexfnc:=NOperation(TColorIndex.create)
end;




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


procedure  FunctionTableInit;
begin
   if (PrecisionMode=PrecisionNormal) then
       SuppliedFunctionTableInit('SQR' , SQRfnc1)
   else if PrecisionMode in [PrecisionNative] then
       SuppliedFunctionTableInit('SQR' , SQRfnc2);
   if precisionMode in [PrecisionNormal, PrecisionNative] then
       SuppliedFunctionTableInit('ABS',ABSfnc );

   if precisionMode in [PrecisionNormal,PrecisionNative,PrecisionComplex] then
    begin
       SuppliedFunctionTableInit('CEIL' ,  CEILfnc);
       SuppliedFunctionTableInit('FP', FPfnc);
       SuppliedFunctionTableInit('INT' ,INTfnc );
       SuppliedFunctionTableInit('IP' ,IPfnc );
       SuppliedFunctionTableInit('MAX' , MAXfnc);
       SuppliedFunctionTableInit('MIN' ,  MINfnc);
       SuppliedFunctionTableInit('MOD' ,  MODfnc );
       SuppliedFunctionTableInit('REMAINDER' , REMAINDERfnc);
       SuppliedFunctionTableInit('SGN',SGNfnc );
       SuppliedFunctionTableInit('ROUND' ,ROUNDfnc );
       SuppliedFunctionTableInit('TRUNCATE',TRUNCATEfnc );
       SuppliedFunctionTableInit('EPS' ,  EPSfnc);

       SuppliedFunctionTableInit('FACT',FACTfnc );
       SuppliedFunctionTableInit('PERM',PERMfnc );
       SuppliedFunctionTableInit('COMB',COMBfnc );
     end;



       SuppliedFunctionTableInit('POS',POSfnc );
       SuppliedFunctionTableInit('VAL',VALfnc );
       SuppliedFunctionTableInit('LEN',LENfnc );
       SuppliedFunctionTableInit('BLEN',BLENfnc );
       SuppliedFunctionTableInit('MAXLEN',MAXLENfnc );
       SuppliedFunctionTableInit('MAXSIZE',MAXSIZEfnc );
       SuppliedFunctionTableInit('ORD',ORDfnc );
       SuppliedFunctionTableInit('BVAL',BVALfnc );

       SuppliedFunctionTable.accept('LBOUND',LBOUNDfnc);
       SuppliedFunctionTable.accept('UBOUND',UBOUNDfnc);
       SuppliedFunctionTable.accept('SIZE',  SIZEfnc);

       SuppliedFunctionTable.accept('DET',   DETfnc);
       SuppliedFunctionTable.accept('DOT',   DOTfnc);

       SuppliedFunctionTableInit('COLORINDEX',ColorIndexfnc );

    {**************}
    {reserved words}
    {**************}
       ReservedWordTableInit('TIME', TIMEfnc);
       ReservedWordTableInit('DATE', DATEfnc);
       ReservedWordTableInit('RND' , RNDfnc );

       ReservedWordTableInit('EXTYPE', EXTYPEfnc );
       ReservedWordTableInit('EXLINE', EXLINEfnc);

       ReservedWordTableInit('NOT',  RESERVEDWORDfnc);
       ReservedWordTableInit('ELSE' ,RESERVEDWORDfnc);
       ReservedWordTableInit('PRINT',RESERVEDWORDfnc);
       ReservedWordTableInit('REM',  RESERVEDWORDfnc);
       ReservedWordTableInit('CON',  RESERVEDWORDfnc);
       ReservedWordTableInit('IDN',  RESERVEDWORDfnc);
       ReservedWordTableInit('ZER',  RESERVEDWORDfnc);
       ReservedWordTableInit('NUL$', RESERVEDWORDfnc);
       ReservedWordTableInit('TRANSFORM',RESERVEDWORDfnc);

end;

begin
   tableInitProcs.accept(FunctionTableInit);
end.
