compile_hss.pas

酒店管理VB源码

    Function  FunctionStackRead():string;         //

    function  ParameterListIn(const PName:string):integer;overload;  //将参数插入参数堆栈  返回序号
    function  GetParameterListConstIndex(const PName:string):integer;
    function  ParameterListIn(const dValue:Extended):string;overload; //将常数插入参数堆栈 并返回由系统定义的别名
    function  GetParameterIndex(const PName:string):integer;       //得到指定名称参数在ParameterList[]中的序号

    procedure T_PTrueNowListIN(const TP:TT_PTrue);  //管理   (编译优化常数时) 参数性质堆栈
    function  T_PTrueNowListOut():TT_PTrue;         //

    //传入参数str,通过s返回
    function  Dbxch(var s:string;var str:string):boolean; // 书写格式转换函数  f(x,y) => ((x)f(y))
    function  DbxchSYS_ff(var s:string;var str:string):boolean; // 书写格式转换函数 ff(a,b,x,N,g(x)) => ( (a) TCmSYS_FF_0 (b) TCmSYS_FF_1 (N) TCmSYS_FF_2 ( g(x) ) )

    function  DbxchSYS_FunctionIf(var s:string;var str:string):boolean; // 书写格式转换函数  If(a,b,c) =>TCmSYS_IF_1(TCmSYS_IF_0(b,c),a)

    function  DefineMarker(var Text:string;const Key,Value : string):boolean;  // 替换标识符 将Text 中 Key=>Value

    procedure DelStrNote(var str:string); // 去掉str注释部分



    function  ifSYS_ff(const fName:string):boolean;  // fName 中是否有 积分函数
    function  getSYS_ff(const fName:string):string;  // 返回积分函数名称

    {编译 函数}
    //约定:  单元函数 通过 st 传参数值 ,通过 st 返回结果值
    //       双元函数 通过 st 传第一参数值,通过 [ecx] 传第二个参数 ,通过 st 返回结果值
    //       函数可以 通过 [edx] 及以后的临时数据交换区来保存、修改或读取数据
    //       函数可以随意使用EAX

    //数学运算
    Procedure F_Add();
    Procedure F_Sub();
    Procedure F_Mul();
    Procedure F_Div();
    Procedure F_DivE();
    Procedure F_Mod();
    Procedure F_Power();
    Procedure F_IntPower();
    Procedure F_Max();
    Procedure F_Min();
    Procedure F_Bracket(); { ()函数 }
    Procedure F_Rev();
    Procedure F_Sqr();
    Procedure F_Sqr3();
    Procedure F_Sqr4();
    Procedure F_Sqrt();
    Procedure F_Sin();
    Procedure F_Cos();
    Procedure F_Tan();
    Procedure F_ArcSin();
    Procedure F_ArcCos();
    Procedure F_ArcTan();
    Procedure F_ArcTan2();
    Procedure F_Ln();
    Procedure F_Log();
    Procedure F_Log2();
    Procedure F_Abs();
    Procedure F_SqrAdd();
    Procedure F_Floor();
    Procedure F_Trunc();
    Procedure F_Round();
    Procedure F_Ceil();
    Procedure F_Sgn();
    Procedure F_exp();
    Procedure F_SinH();
    Procedure F_CosH();
    Procedure F_TanH();
    Procedure F_ArcSinH();
    Procedure F_ArcCosH();
    Procedure F_ArcTanH();
    procedure F_Rnd();
    procedure F_Ctg();
    procedure F_Sec();
    procedure F_Csc();
    procedure F_CscH();
    procedure F_SecH();
    procedure F_CtgH();
    procedure F_ArcCsc();
    procedure F_ArcSec();
    procedure F_ArcCtg();
    procedure F_ArcCscH();
    procedure F_ArcSecH();
    procedure F_ArcCtgH();
    procedure F_Hypot();


    procedure F_SYS_IF_0();   //IF函数0
    procedure F_SYS_IF_1();   //IF函数1

    procedure F_SYS_FF_0(const N:integer); //积分函数0
    procedure F_SYS_FF_1(const N:integer); //积分函数1
    procedure F_SYS_FF_2(const N:integer); //积分函数2

    procedure F_SYS_Fld_Value();//代码中载入值   相当于mov  st,[st]
    procedure F_SYS_Fstp_Value();//代码中传出值  相当于mov  [st],st(1)

    //布尔运算
    //True;  //常量 true 真=1
    //False; //常量 false 假=0
    procedure FB_AND();   //逻辑 与
    procedure FB_OR();    //逻辑 或
    procedure FB_XOR();   //逻辑 异或
    procedure FB_NOT();   //逻辑 非
    //关系运算(返回布尔值)
    procedure FB_EQ();    //相等
    procedure FB_NE();    //不等于
    procedure FB_LT();    //小于
    procedure FB_GT();    //大于
    procedure FB_LE();    //小于等于
    procedure FB_GE();    //大于等于



    Procedure FF_Fld_X(const x:extended); //载入x

    {有限状态自动机}

    //得到参数(常数)列表、函数转换
    function  Conversion0(var s:string;var str:string):boolean;

    // 得到字符串中标识符的位置(源字符串,标识符,起始位置);
    function  GetMarkerPos(const str:string;const key:string;const ifirst:integer):integer;
    // myPos=pos
    function  myPos(const str:string;const key:string;const ifirst:integer):integer;

    //含'@'、'&'取出标识符(源字符串，开始位置，返回结束位置)；失败返回0; Marker:=Copy(Str,iFirst,iEnd-iFirst+1);
    procedure GetMarker(const Str:string;const iFirst:integer;var iEnd:integer);

    //取出标识符的有限状态自动机(源字符串，开始位置，返回结束位置)；失败返回0; Marker:=Copy(Str,iFirst,iEnd-iFirst+1);
    procedure GetMarkerValue0(const Str:string;const iFirst:integer;var iEnd:integer);
    procedure GetMarkerValue1(const Str:string;const iFirst:integer;var iEnd:integer);

    //取出常数的有限状态自动机(源字符串，开始位置，返回结束位置)；失败返回0; FloatValue:=strtosloat(Copy(Str,iFirst,iEnd-iFirst+1));
    procedure GetFloatValue0(const Str:string;const iFirst:integer;var iEnd:integer);
    procedure GetFloatValue1(const Str:string;const iFirst:integer;var iEnd:integer);
    procedure GetFloatValue2(const Str:string;const iFirst:integer;var iEnd:integer);
    procedure GetFloatValue3(const Str:string;const iFirst:integer;var iEnd:integer);
    procedure GetFloatValue4(const Str:string;const iFirst:integer;var iEnd:integer);
    procedure GetFloatValue5(const Str:string;const iFirst:integer;var iEnd:integer);
    procedure GetFloatValue6(const Str:string;const iFirst:integer;var iEnd:integer);

    

  public
    { Public declarations }
    constructor Create();
    destructor  Destroy();Override;
  end;

  {$IFDEF MSWINDOWS}

  TSystemTime = record
          wYear   : Word;
          wMonth  : Word;
          wDayOfWeek  : Word;
          wDay    : Word;
          wHour   : Word;
          wMinute : Word;
          wSecond : Word;
          wMilliSeconds: Word;
          reserved    : array [0..7] of char;
  end;
  procedure GetSystemTime(var lpSystemTime: TSystemTime); stdcall;
  {$EXTERNALSYM GetSystemTime}

  {$ENDIF}


  //错误号定义
  const
        csTCompile_NoError              = 0;    //没有发现错误!
        csTCompile_NoKnownError         = 1;    //不知道的错误!
        csTCompile_NoErrorCode          = 2;    //找不到错误号所对应的错误描述!
        csTCompile_CompileHexCodeError  = 3;    //编译时指令的十六进制代码错误!
        csTCompile_HexMod2_EQ_1_Error   = 4;    //编译时传入指令长度错误!
        csTCompile_PMMarker_Error       = 5;    //编译得到参数名称时发生错误!
        csTCompile_FMMarker_Error       = 6;    //编译得到函数名称时发生错误!
        csTCompile_Wording_Error        = 7;    //语法发生错误!
        csTCompile_Bracket_Error        = 8;    //语法错误,在 ( ) 处!
        csTCompile_Optimize_Error       = 9;    //编译优化时发生错误!
        csTCompile_Define_Error         =10;    //函数编译错误(或超出定义域)!
        csTCompile_Handwriting_Error    =11;    //函数书写格式错误!
        csTCompile_FFHandwriting_Error  =12;    //积分函数书写格式错误!
        csTCompile_ReadFloat_Error      =13;    //编译读取常数数字时发生错误!
        csTCompile_ReadMarker_Error     =14;    //编译读取标识符时发生错误!
        csTCompile_Read_Error           =15;    //语法错误,有不识别的字符!
        csTCompile_Note_Match_Error     =16;    //注释符号不匹配!  { } 或 /*  */
        csTCompile_FPList_Error         =17;    //参数列表错误!
        csTCompile_IFHandwriting_Error  =18;    //If函数书写格式错误!


implementation

  const
    MaxTanhDomain = 5678.22249441322; // Ln(MaxExtended)/2
    two2neg32: Extended = 1.0/4294967295;  // 1/(2^32-1)
    MaxInt:extended=2147483647.0;
    Infinity:extended=1.0/0.0;

function  TCompile.GetError():string;
begin
  result:=GetErrorGB(ErrorCode);
end;

function  TCompile.GetErrorGB(const xErrorCode:integer):string;     //返回错误描述
begin
  case xErrorCode of
    csTCompile_NoError              :result:='';//没有发现错误!
    csTCompile_NoKnownError         :result:='不知道的错误!';
    csTCompile_NoErrorCode          :result:='找不到错误号所对应的错误描述!';
    csTCompile_CompileHexCodeError  :result:='编译时指令的十六进制代码错误!';
    csTCompile_HexMod2_EQ_1_Error   :result:='编译时传入指令长度错误!';
    csTCompile_PMMarker_Error       :result:='编译得到参数名称时发生错误!';
    csTCompile_FMMarker_Error       :result:='编译得到函数名称时发生错误!';
    csTCompile_Wording_Error        :result:='语法发生错误!';
    csTCompile_Bracket_Error        :result:='语法错误,在 ( ) 处!';
    csTCompile_Optimize_Error       :result:='编译优化时发生错误!';
    csTCompile_Define_Error         :result:='函数编译错误(或超出定义域)!';
    csTCompile_Handwriting_Error    :result:='函数书写格式错误!';
    csTCompile_FFHandwriting_Error  :result:='积分函数书写格式错误!';
    csTCompile_ReadFloat_Error      :result:='编译读取常数数字时发生错误!';
    csTCompile_ReadMarker_Error     :result:='编译读取标识符时发生错误!';
    csTCompile_Read_Error           :result:='语法错误,有不识别的字符!';
    csTCompile_Note_Match_Error     :result:='注释符号不匹配!  { } 或 /*  */';
    csTCompile_FPList_Error         :result:='参数列表错误!';
    csTCompile_IfHandwriting_Error  :result:='If函数书写格式错误!';
  else result:=GetErrorGB(csTCompile_NoErrorCode);
  end;
end;

function  TCompile.GetErrorBIG5(const xErrorCode:integer):string;     //返回错误描述
begin
  //注意:以下使用的是中文繁体BIG5码,要使用内码转换器才能察看
  case xErrorCode of
    csTCompile_NoError              :result:='';//⊿Τ祇瞷岿粇!
    csTCompile_NoKnownError         :result:='ぃ