delphin.pas

一个Delphi解释器的例子

{*******************************************************}
{                                                       }
{  Delphi Interpreter                                   }
{  Copyright (c) 1996-1998 S.Kurinny & S.Kostinsky      }
{                                                       }
{*******************************************************}

Unit delphin;

Interface
Uses
  classes, sysutils, forms, windows, dialogs,typinfo,controls,dsgnintf,
  stdctrls;

{-------------------------------------------------------------------------}

Const
  { maximal number of procedure parameters allowed in the interpreter}
  maxparams = 100;

  SErrFunDefined='Function %s is already defined';
  eofincom_ERR = 'Unexpected EOF in comment block';
  delimeter_expected = 'Operator delimeter expected';
  eofinstring_ERR ='Unexpected EOF in string constant declaration';
  need_opbr ='( expected';
  comma_expected= 'Comma expected';
  need_clbr= ') expected';
  begin_expected= 'BEGIN expected';
  unk_macrotype= 'Unknown macro type %S';
  par_notfound= 'Parameter %S not found';
  unkn_id= 'Unknown identifier: %s';
  unexp_writer= 'Unknown variable type during writing program';
  do_exp= 'DO expected';
  down_to_exp= 'TO or DOWNTO expected';
  unit_declared= 'Unit %s already defined';
  bad_unit= 'Unit declaration error';
  fun_notfound= 'Function %s not found';
  until_exp= 'UNTIL Expected';
  linker_error= 'Link Error';
  labname_exp= 'Label name expected';
  label_already= 'Label <%s> already defined';
  delim_or_coma= 'Comma or delimeter expected';
  err_declpart= 'Error in declaration block';
  lab_notdef= 'Label <%s> not defined';
  progname_exp= 'Program name expected';
  varname_exp= 'Variable name expected';
  var_already= 'Variable <%s> already defined';
  bad_varblock= 'Error in variable declaration block';
  var_NotDef= 'Variable <%s> not defined';
  else_exp= 'ELSE expected';
  then_exp= 'THEN expected';
  id_expected= 'Identifier expected';
  meth_decerr= 'Method declaration error';
  bad_methparam= 'Method parameters declaration error';
  no_props= 'Properties not implemented';
  need_par= 'Parent name expected';
  clbr_exp= ') Expected';
  only_class= 'Only class declarations allowed';
  err_decl= '%s declaration  error';
  p2_exp= 'Colon expected';
  synt_err='Syntax error in  (%s): %s.';
  bad_idName= 'Bad identifier name <%s>';
  bad_id= 'Bad identifier <%s>';
  opsq_exp= '[ expected but %s found';
  clsq_exp= '] expected but %s found';
  in_funuse= 'Invalid function usage';
  in_procuse= 'Invalid procedure usage';
  bad_hex= 'Hex constant declaration error';
  file_not_found= 'File %S not found';
  compile_before= 'Compile before run';
  bad_realconst= 'Real constant declaration error';
  bad_charconst= 'String constant declaration error';
  unsup_partype= 'Unsupported parameter type';
  no_resvar= 'Variable Result not found for %s';
  proc_notfound= 'Procedure %s not found';
  eq_exp= '= expected';
  end_expected= 'END expected';
  SErrCircularVarRef='Circular variable %S reference';
  SErrUnknReaderType='Unknown reader type';

type
//  tproctype = Function(slf: tobject; Var s: Array of variant): variant; register;
  TProcType = Function(slf: tobject; var APropName: String; Var s: Array of variant): variant; register;

  tbytearray = Array[0..maxparams] of byte;

  TFunListItem = Class
    PropName: String;
    ProcAddr: tproctype;
    ParCount: integer;
    Fun: boolean;
    Params: tbytearray; {0-stack param  1-var param 2-no param
                           3-open array param}
    IsProp: Boolean;
    IsPropSet: Boolean;
  End;

  TFunList = Class(TStringList)
  Public
    Constructor Create;

    Procedure AddItem(Const Aname,APropName: String; ProcAddr: TProcType;
      Fun, IsProp, IsPropSet: Boolean; Const Params: Array of byte);
    Destructor Destroy; override;
  End;

Var
  Funs: TFunList;

{-------------------------------------------------------------------------}

{Converts object to variant. Used when writing interface functions
 for importing Delphi objects and functions to interpreter.}
Function ObjToVar(S: TObject): Variant;

{Converts variant to object. Used when writing interface functions
 for importing Delphi objects and functions to interpreter.}
Function VarToObj(S: Variant): TObject;

{@see ObjToVar}
Function OV(S: TObject): Variant;

{@see VarToObj}
Function VO(S: Variant): TObject;

{ Use this function to call previously registered in interpreter procedure or function.

 @param ProcName function name
 @param SLF pointer to object instance if called function is object method
 @param S parameters
 @return return value (for functions)}
{Function CallHalProc(Const procName: String; slf: tobject;
  Var s: Array of variant): variant;}

{ Returns address of registered in interpreter function or procedure
  Returns nil if item not found
}
//Function GetHalProcAddr(Const FunName: String): tproctype;

{ Calls interpreter procedure or function without parameters
  If procedure or function with ProcName not found does nothing
}
//function SimpleCallHalProc(Const ProcName:String):Variant;

{Registers Delphi's procedure in interpreter
 @param AName Procedure name. For registration object method use qualified name
    ('TOBJECT.FREE')
 @param ProcAddr Import function address. @see TProcType
 @param Params Array of parameters definitions.
	       If =[2] - no parameters, otherwise type of each parameter  should be specified.
       Parameter types: 0 - stack parameter, 1 - var parameter, 3 - open array.
 Open array is passed to import function in variant with array type.
 V[0] - array size. V[1]..V[V[0]] - array items. Use convert functions
 for converting to array of const of to other array types
}
Procedure AddProc(Const Aname: String; ProcAddr: TProcType; Const Params: Array of byte);

{ Same as AddProc, but for registering functions
  @see AddProc
}
Procedure AddFun(Const Aname: String; ProcAddr: TProcType; Const Params: Array of byte);

{ Registers object properties. Interface functions for reading and
 writing property value should be specified.
 If Property is read-only then pass SETPROCADDR=nil}
Procedure AddProp(Const Aname: String; ProcAddr, SetProcAddr: TProcType);

{ Registers array properties.
 ADIM- array dimension. ( 3 ---> A[1,2,2] 1 --> A[6])}
Procedure AddArrayProp(Const Aname: String; ADim: Integer; ProcAddr, SetProcAddr: TProcType);

{ Deletes previously registered in the interpreter procedure or function
  If item with ProcName not found does nothing
}
procedure DelProc(Const ProcName:String);

{----------------------------------------------}

Const
  conotifyevent = 'TNotifyEvent'; // don't resource
  cocloseevent = 'TCloseEvent'; // don't resource
  coprocResult = '.Result'; // don't resource
  StackSize=1000;
Type

// Functions of this type are used for converting external variable
// names to ids
  TDynaVarNameTOId = Function(Const S: String): Integer of Object;

// Procedures of this type are called to set value to external variable by id.
  TDynaSetVar = Procedure(ID: Integer; Value: Variant) of Object;

// Functions of this type are used to get values of external variables 
  TDynaGetVar = Function(ID: Integer): Variant of Object;

Type
  ECompilerError = Class(Exception);

{-------------------}

Type
  TToken = Record
    ID: Integer;
    Data: Variant;
  End;

Type TCharSet = Set of char;

Const
  WhiteSpaces: TCharSet = ['+', '-', '/', '*', '(', ')', ':', '=', ',', ';', '>', '<',
    '$', '.', '#', '[', ']', '^', '@', '&', '~', '|', '%'];
  BlackSpaces: TCharSet = [#1..#32];
  StopChars: TCharSet = [#0..#32, '+', '-', '/', '*', '(', ')', ':', '=', ',', '''',
    '{', '}', ';', '>', '<', '$', '.', '#', '[', ']', '"', '^', '@', '&', '~', '|', '%'];
  FirstIdentChar: TCharSet = ['A'..'Z', '