h_sys.pas

一个Delphi解释器的例子

unit h_sys;

interface

implementation
Uses Delphin,forms;


{--------------------}
function myTOBJECTCREATE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result:=ObjToVar(TOBJECT(slf).CREATE);
End;
{--------------------}
function myTOBJECTFREE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 TOBJECT(slf).FREE;
End;
{--------------------}
function myTOBJECTCLEANUPINSTANCE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 TOBJECT(slf).CLEANUPINSTANCE;
End;
{--------------------}
{function myTOBJECTCLASSTYPE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := TOBJECT(slf).CLASSTYPE;
End;}
{--------------------}
function myTOBJECTCLASSNAME(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := TOBJECT(slf).CLASSNAME;
End;
{--------------------}
function myTOBJECTCLASSNAMEIS(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := TOBJECT(slf).CLASSNAMEIS(S[0]);
End;
{--------------------}
{function myTOBJECTCLASSPARENT(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := TOBJECT(slf).CLASSPARENT;
End;}
{--------------------}
{function myTOBJECTCLASSINFO(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := TOBJECT(slf).CLASSINFO;
End;}
{--------------------}
function myTOBJECTINSTANCESIZE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := TOBJECT(slf).INSTANCESIZE;
End;
{--------------------}
{function myTOBJECTINHERITSFROM(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := TOBJECT(slf).INHERITSFROM(S[0]);
End;}
{--------------------}
function myTOBJECTDISPATCH(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 TOBJECT(slf).DISPATCH(S[0]);
End;
{--------------------}
{function myTOBJECTMETHODADDRESS(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := TOBJECT(slf).METHODADDRESS(S[0]);
End;}
{--------------------}
{function myTOBJECTMETHODNAME(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := TOBJECT(slf).METHODNAME(S[0]);
End;}
{--------------------}
{function myTOBJECTFIELDADDRESS(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := TOBJECT(slf).FIELDADDRESS(S[0]);
End;}
{--------------------}
function myTOBJECTDEFAULTHANDLER(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 TOBJECT(slf).DEFAULTHANDLER(S[0]);
End;
{--------------------}
function myTOBJECTNEWINSTANCE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result :=ObjToVar(TOBJECT(slf).NEWINSTANCE);
End;
{--------------------}
function myTOBJECTFREEINSTANCE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 TOBJECT(slf).FREEINSTANCE;
End;
{--------------------}
function myTOBJECTDESTROY(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 TOBJECT(slf).DESTROY;
End;
{--------------------}
function myIORESULT(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := IORESULT;
End;
{--------------------}
function myMOVE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 MOVE(S[0],S[1],S[2]);
End;
{--------------------}
function myPARAMCOUNT(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := PARAMCOUNT;
End;
{--------------------}
function myPARAMSTR(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := PARAMSTR(S[0]);
End;
{--------------------}
function myRANDOMIZE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 RANDOMIZE;
End;
{--------------------}
function myUPCASE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := UPCASE(String(S[0])[1]);
End;

function myVARCLEAR(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 VARCLEAR(S[0]);
End;
{--------------------}
function myVARCOPY(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 VARCOPY(S[0],S[1]);
End;
{--------------------}
{function myVARCAST(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 VARCAST(S[0],S[1],S[2]);
End;}
{--------------------}
function myVARTYPE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARTYPE(S[0]);
End;
{--------------------}
function myVARASTYPE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARASTYPE(S[0],S[1]);
End;
{--------------------}
function myVARISEMPTY(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARISEMPTY(S[0]);
End;
{--------------------}
function myVARISNULL(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARISNULL(S[0]);
End;
{--------------------}
function myVARTOSTR(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARTOSTR(S[0]);
End;
{--------------------}
function myVARFROMDATETIME(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARFROMDATETIME(S[0]);
End;
{--------------------}
function myVARTODATETIME(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARTODATETIME(S[0]);
End;
{--------------------}
{function myVARARRAYCREATE(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARARRAYCREATE(S[0],S[1]);
End;}
{--------------------}
function myVARARRAYOF(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARARRAYOF(S[0]);
End;
{--------------------}
{function myVARARRAYREDIM(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 VARARRAYREDIM(S[0],S[1]);
End;}
{--------------------}
function myVARARRAYDIMCOUNT(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARARRAYDIMCOUNT(S[0]);
End;
{--------------------}
function myVARARRAYLOWBOUND(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARARRAYLOWBOUND(S[0],S[1]);
End;
{--------------------}
function myVARARRAYHIGHBOUND(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARARRAYHIGHBOUND(S[0],S[1]);
End;
{--------------------}
{function myVARARRAYLOCK(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARARRAYLOCK(S[0]);
End;
{--------------------}
{function myVARARRAYUNLOCK(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 VARARRAYUNLOCK(S[0]);
End;
{--------------------}
function myVARARRAYREF(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
// Result := VARARRAYREF(S[0]);
End;
{--------------------}
function myVARISARRAY(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result := VARISARRAY(S[0]);
End;
{--------------------}
function myUNIQUESTRING(slf:TObject;var APropName:String;var s:array of variant):variant;
var a:string;
begin
 a:=s[0];
 UNIQUESTRING(a);
 S[0]:=a;
End;
{--------------------}
function myFPOWER10(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 FPOWER10;
End;
{--------------------}
function myTEXTSTART(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 TEXTSTART;
End;
{------------------------------}
function mypos(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
Result:=pos(s[0],s[1]);
end;
{------------------------------}
function myinsert(slf:TObject;var APropName:String;var s:array of variant):variant;
var source,target:string;
    index:integer;
begin
Source:=s[0];
target:=s[1];
Index :=s[2];
insert(source,target,index);
Result:=target;
s[0]:=source;
s[1]:=target;
s[2]:=index;
end;
{------------------------------}
function MyCopy(slf:TObject;var APropName:String;var s:array of variant):variant;
var st:string;
    i1,i2:integer;
begin
st:=s[0];
i1:=s[1];
i2:=s[2];
Result:=Copy(st,i1,i2);
end;
{------------------------------}
function mydelete(slf:TObject;var APropName:String;var s:array of variant):variant;
var v:string;
    i,c:integer;
begin
v:=s[0];
i:=s[1];
c:=s[2];
delete(v,i,c);
s[0]:=v;
end;
{------------------------------}
function mystr(slf:TObject;var APropName:String;var s:array of variant):variant;
var v:string;
begin
v:=s[1];
str(s[0],v);
s[1]:=v;
end;
{------------------------------}
function MyLength(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
Result:=length(s[0]);
end;
{------------------------------}
function MySetLength(slf:TObject;var APropName:String;var s:array of variant):variant;
var r:string;
    i:integer;
begin
r:=s[0];
i:=s[1];
SetLength(r,i);
s[0]:=r;
end;
{------------------------------}
function myWriteln(slf:TObject;var APropName:String;var s:array of variant):variant;
var sst:string;
    i:integer;
    F:TForm;
begin
 sst:='';
 for i:=1 to S[0][0] do sst:=sst+s[0][i];
 If assigned(OutLabel) then begin
                        OutLabel.Caption:=sst;
                        F:=TForm(Outlabel.Owner);
                        If F.Visible=false then F.Visible:=True;
                        {F.Repaint;}
                       end;
 if assigned(OutMemo) then OutMemo.Lines.Add(sst);
end;
{------------------------------}
function myEWriteln(slf:TObject;var APropName:String;var s:array of variant):variant;
var sst:string;
    i:integer;
begin
 ErrorPrinted:=True;
 if not assigned(ErrorMemo) then exit;
 for i:=1 to S[0][0] do sst:=sst+s[0][i];
 ErrorMemo.Lines.Add(sst);
end;
{--------------------------}
{function myRunFormModal(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result:=RunFormModal(S[0]);
end;}
{--------------------------}
function myRunForm(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 RunForm(s[0]);
end;
{--------------------------}
function myRunMacro(slf:TObject;var APropName:String;var s:array of variant):variant;
begin
 Result:=RunMacro(s[0]);
end;
{--------------------------}
procedure InitSystem;
begin
  AddFun ('RunMacro',MyRunMacro,[0]);
  AddProc('RunForm',MyRunForm,[0]);
//  AddFun ('RunFormModal',MyRunFormModal,[0]);

  AddProc('Print',MyWriteln,[3]);
  AddProc('PrintError',MyEWriteln,[3]);

//  AddFun ('Assigned',MyAssigned,[0]);}

// System Standard
  AddConst('pi',pi);

  AddProc('SetLength',MySetLength,[1,0]);
  AddFun ('Length',MyLength,[0]);
  AddProc('Insert',MyInsert,[0,1,0]);
  AddFun ('Pos',MyPos,[0,0]);
  AddFun ('Copy',MyCopy,[0,0,0]);
  AddProc('Delete',MyDelete,[1,0,0]);
  AddProc('Str',MyStr,[0,1]);

//  AddObjectType('TOBJECT','');

  AddProc('TOBJECT.FREE',myTOBJECTFREE,[2]);
  AddProc('TOBJECT.CLEANUPINSTANCE',myTOBJECTCLEANUPINSTANCE,[2]);
  AddFun ('TOBJECT.CLASSNAME',myTOBJECTCLASSNAME,[2]);
  AddFun ('TOBJECT.CLASSNAMEIS',myTOBJECTCLASSNAMEIS,[0]);
  AddFun ('TOBJECT.INSTANCESIZE',myTOBJECTINSTANCESIZE,[2]);
  AddProc('TOBJECT.DISPATCH',myTOBJECTDISPATCH,[1]);
  AddProc('TOBJECT.DEFAULTHANDLER',myTOBJECTDEFAULTHANDLER,[1]);

//   AddFun('TOBJECT.METHODADDRESS',myTOBJECTMETHODADDRESS,[0]);
//   AddFun('TOBJECT.METHODNAME',myTOBJECTMETHODNAME,[0]);
//   AddFun('TOBJECT.FIELDADDRESS',myTOBJECTFIELDADDRESS,[0]);
//  AddFun ('TOBJECT.NEWINSTANCE',myTOBJECTNEWINSTANCE,[2]);
//  AddProc('TOBJECT.FREEINSTANCE',myTOBJECTFREEINSTANCE,[2]);

  AddFun('IORESULT',myIORESULT,[2]);
  AddProc('MOVE',myMOVE,[0,1,0]);
  AddFun('PARAMCOUNT',myPARAMCOUNT,[2]);
  AddFun('PARAMSTR',myPARAMSTR,[0]);
  AddProc('RANDOMIZE',myRANDOMIZE,[2]);
  AddFun('UPCASE',myUPCASE,[0]);

  AddProc('VARCLEAR',myVARCLEAR,[1]);
  AddProc('VARCOPY',myVARCOPY,[1,0]);
{  AddProc('VARCAST',myVARCAST,[1,0,0]);}
  AddFun ('VARTYPE',myVARTYPE,[0]);
  AddFun ('VARASTYPE',myVARASTYPE,[0,0]);
  AddFun ('VARISEMPTY',myVARISEMPTY,[0]);
  AddFun ('VARISNULL',myVARISNULL,[0]);
  AddFun ('VARTOSTR',myVARTOSTR,[0]);
  AddFun ('VARFROMDATETIME',myVARFROMDATETIME,[0]);
  AddFun ('VARTODATETIME',myVARTODATETIME,[0]);
  AddFun ('VARARRAYOF',myVARARRAYOF,[0]);
{  AddProc('VARARRAYREDIM',myVARARRAYREDIM,[1,0]);}
  AddFun ('VARARRAYDIMCOUNT',myVARARRAYDIMCOUNT,[0]);
  AddFun ('VARARRAYLOWBOUND',myVARARRAYLOWBOUND,[0,0]);
  AddFun ('VARARRAYHIGHBOUND',myVARARRAYHIGHBOUND,[0,0]);
//   AddFun('VARARRAYLOCK',myVARARRAYLOCK,[0]);
//  AddProc('VARARRAYUNLOCK',myVARARRAYUNLOCK,[0]);
  AddFun ('VARARRAYREF',myVARARRAYREF,[0]);
  AddFun ('VARISARRAY',myVARISARRAY,[0]);
  AddProc('UNIQUESTRING',myUNIQUESTRING,[1]);
  AddProc('FPOWER10',myFPOWER10,[2]);
  AddProc('TEXTSTART',myTEXTSTART,[2]);
end;

initialization
  InitSystem;
end.