home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d456 / CAJSCRPT.ZIP / ifps3 / ifpiclass.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-08-26  |  21.6 KB  |  852 lines
  1. unit ifpiclass;
  2. {
  3.   Innerfuse Pascal Script III
  4.   Copyright (C) 2000-2002 by Carlo Kok (ck@carlo-kok.com)
  5. }
  6. {$I ifps3_def.inc}
  7. interface
  8. uses
  9.   ifpscomp, ifps3utl, ifps3common;
  10.  
  11. type
  12.   TIFPSCompileTimeClass = class;
  13.   {Class importer at compile time}
  14.   TIFPSCompileTimeClassesImporter = class
  15.   private
  16.     FClasses: TIFList;
  17.     FSE: TIFPSPascalCompiler;
  18.   public
  19.     {Script Engine}
  20.     property SE: TIFPSPascalCompiler read FSe;
  21.     {create}
  22.     constructor Create(AOwner: TIFPSPascalCompiler; AutoFree: Boolean);
  23.     {destroy}
  24.     destructor Destroy; override;
  25.     {Add a class}
  26.     function Add(InheritsFrom: TIFPSCompileTimeClass; FClass: TClass): TIFPSCompileTimeClass;
  27.     function Add2(InheritsFrom: TIFPSCompileTimeClass; FClassName: string): TIFPSCompileTimeClass;
  28.     {Find a class}
  29.     function FindClass(const aClassName: string):TIFPSCompileTimeClass;
  30.     {Clear the list of classes}
  31.     procedure Clear;
  32.   end;
  33.   {Property type: iptRW = Read/Write; iptR= readonly; iptW= writeonly}
  34.   TIFPSPropType = (iptRW, iptR, iptW);
  35.   {Compiletime class}
  36.   TIFPSCompileTimeClass = class
  37.   private
  38.     FInheritsFrom: TIFPSCompileTimeClass;
  39.     FClass: TClass;
  40.     FClassName: string;
  41.     FClassNameHash: Longint;
  42.     FClassItems: TIFList;
  43.  
  44.     FOwner: TIFPSCompileTimeClassesImporter;
  45.   public
  46.     property ClassInheritsFrom: TIFPSCompileTimeClass read FInheritsFrom write FInheritsFrom; 
  47.     {Register a method/constructor}
  48.     function RegisterMethod(const Decl: string): Boolean;
  49.     {Register a property}
  50.     procedure RegisterProperty(const PropertyName, PropertyType: string; PropAC: TIFPSPropType);
  51.     {Register all published properties}
  52.     procedure RegisterPublishedProperties;
  53.     {Register a published property}
  54.     function RegisterPublishedProperty(const Name: string): Boolean;
  55.     {create2}
  56.     constructor Create2(ClassName: string; aOwner: TIFPSCompileTimeClassesImporter);
  57.     {create}
  58.     constructor Create(FClass: TClass; aOwner: TIFPSCompileTimeClassesImporter);
  59.     {destroy}
  60.     destructor Destroy; override;
  61.   end;
  62.  
  63. function AddImportedClassVariable(Sender: TIFPSPascalCompiler; const VarName, VarType: string): Boolean;
  64.  
  65. implementation
  66. uses
  67.   TypInfo;
  68.  
  69. type
  70.    TComp = class (TIFPSPascalCompiler) end;
  71.  
  72. function AddImportedClassVariable(Sender: TIFPSPascalCompiler; const VarName, VarType: string): Boolean;
  73. var
  74.   P: PIFPSVar;
  75. begin
  76.   P := Sender.AddVariableN(VarName, VarType);
  77.   if p = nil then
  78.   begin
  79.     Result := False;
  80.     Exit;
  81.   end;
  82.   SetVarExportName(P, FastUppercase(VarName));
  83.   p^.Used := True;
  84.   Result := True;
  85. end;
  86.  
  87.  
  88. {'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params
  89.  
  90. For property write functions there is an '@' after the funcname.
  91. }
  92. type
  93.   PClassItem = ^TClassItem;
  94.   TClassItem = record
  95.     Owner: TIFPSCompileTimeClass;
  96.     Name: string;
  97.     NameHash: Longint;
  98.     FType: Byte; { 0 = method; 1 = property; 2 = constructor/class method }
  99.     ProcDecl: string;
  100.     PropAC: TIFPSPropType;
  101.     case byte of
  102.       0: (MethodProcNo: Cardinal);
  103.       1: (PropReadProcNo, PropWriteProcNo: Cardinal);
  104.   end;
  105.   TIFPSDelphiClass = class(TIFPSExternalClass)
  106.   private
  107.     Ce: TIFPSCompileTimeClass;
  108.     CompareProcNo, CastProcNo, NilProcNo: Cardinal;
  109.   public
  110.     function SelfType: Cardinal; override;
  111.  
  112.     constructor Create(CE: TIFPSCompileTimeClass);
  113.     destructor Destroy; override;
  114.  
  115.     function Property_Find(const Name: string; var Index: Cardinal): Boolean; override;
  116.     function Property_Get(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
  117.     function Property_Set(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
  118.     function Property_GetHeader(Index: Cardinal; var s: string): Boolean; override;
  119.  
  120.     function Func_Find(const Name: string; var Index: Cardinal): Boolean; override;
  121.     function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
  122.  
  123.     function ClassFunc_Find(const Name: string; var Index: Cardinal): Boolean; override;
  124.     function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
  125.  
  126.     function IsCompatibleWith(Cl: TIFPSExternalClass): Boolean; override;
  127.     function SetNil(TypeNo: Cardinal; var ProcNo: Cardinal): Boolean; override;
  128.     function CastToType(TypeNo, IntoType: Cardinal; var ProcNo: Cardinal): Boolean; override;
  129.     function CompareClass(OtherTypeNo: Cardinal; var ProcNo: Cardinal): Boolean; override;
  130.   end;
  131.  
  132. { TIFPSCompileTimeClass }
  133.  
  134. constructor TIFPSCompileTimeClass.Create(FClass: TClass; aOwner: TIFPSCompileTimeClassesImporter);
  135. begin
  136.   inherited Create;
  137.   FClassName := FastUppercase(FClass.ClassName);
  138.   FClassNameHash := MakeHash(FClassName);
  139.   FClassItems := TIfList.Create;
  140.   Self.FClass := FClass;
  141.   FOwner := aOwner;
  142. end;
  143.  
  144. constructor TIFPSCompileTimeClass.Create2(ClassName: string;
  145.   aOwner: TIFPSCompileTimeClassesImporter);
  146. begin
  147.   inherited Create;
  148.   FClassName := Classname;
  149.   FClassNameHash := MakeHash(FClassName);
  150.   FClassItems := TIfList.Create;
  151.   FOwner := aOwner;
  152. end;
  153.  
  154. destructor TIFPSCompileTimeClass.Destroy;
  155. var
  156.   I: Longint;
  157.   P: PClassItem;
  158. begin
  159.   for i := FClassItems.Count -1 downto 0 do
  160.   begin
  161.     p := FClassItems.GetItem(I);
  162.     Dispose(P);
  163.   end;
  164.   FClassItems.Free;
  165.   inherited Destroy;
  166. end;
  167.  
  168. function TIFPSCompileTimeClass.RegisterMethod(const Decl: string): Boolean;
  169. var
  170.   Parser: TIfPascalParser;
  171.   FuncType: Byte;
  172.   VNames, Name, NDecl: string;
  173.   modifier: Char;
  174.   VCType: Cardinal;
  175.   P: PClassItem;
  176.  
  177. begin
  178.   Parser := TIfPascalParser.Create;
  179.   Parser.SetText(Decl);
  180.   if Parser.CurrTokenId = CSTII_Function then
  181.     FuncType:= 0
  182.   else if Parser.CurrTokenId = CSTII_Procedure then
  183.     FuncType := 1
  184.   else if Parser.CurrTokenId = CSTII_Constructor then
  185.     FuncType := 2
  186.   else
  187.   begin
  188.     Parser.Free;
  189.     Result := False;
  190.     exit;
  191.   end;
  192.   NDecl := '';
  193.   Parser.Next;
  194.   if Parser.CurrTokenId <> CSTI_Identifier then
  195.   begin
  196.     Parser.Free;
  197.     Result := False;
  198.     exit;
  199.   end; {if}
  200.   Name := Parser.GetToken;
  201.   Parser.Next;
  202.   if Parser.CurrTokenId = CSTI_OpenRound then
  203.   begin
  204.     Parser.Next;
  205.     if Parser.CurrTokenId <> CSTI_CloseRound then
  206.     begin
  207.       while True do
  208.       begin
  209.         if Parser.CurrTokenId = CSTII_Var then
  210.         begin
  211.           modifier := '!';
  212.           Parser.Next;
  213.         end
  214.         else
  215.           modifier := '@';
  216.         if Parser.CurrTokenId <> CSTI_Identifier then
  217.         begin
  218.           Parser.Free;
  219.           Result := False;
  220.           exit;
  221.         end;
  222.         VNames := Parser.GetToken + '|';
  223.         Parser.Next;
  224.         while Parser.CurrTokenId = CSTI_Comma do
  225.         begin
  226.           Parser.Next;
  227.           if Parser.CurrTokenId <> CSTI_Identifier then
  228.           begin
  229.             Parser.Free;
  230.             Result := False;
  231.             exit;
  232.           end;
  233.           VNames := VNames + Parser.GetToken + '|';
  234.           Parser.Next;
  235.         end;
  236.         if Parser.CurrTokenId <> CSTI_Colon then
  237.         begin
  238.           Parser.Free;
  239.           Result := False;
  240.           exit;
  241.         end;
  242.         Parser.Next;
  243.         VCType := FOwner.FSE.FindType(Parser.GetToken);
  244.         if VCType = Cardinal(-1) then
  245.         begin
  246.           Parser.Free;
  247.           Result := False;
  248.           exit;
  249.         end;
  250.         while Pos('|', VNames) > 0 do
  251.         begin
  252.           NDecl := NDecl + ' ' + modifier + copy(VNames, 1, Pos('|', VNames) - 1)
  253.             +
  254.             ' ' + inttostr(VCType);
  255.           Delete(VNames, 1, Pos('|', VNames));
  256.         end;
  257.         Parser.Next;
  258.         if Parser.CurrTokenId = CSTI_CloseRound then
  259.           break;
  260.         if Parser.CurrTokenId <> CSTI_Semicolon then
  261.         begin
  262.           Parser.Free;
  263.           Result := False;
  264.           exit;
  265.         end;
  266.         Parser.Next;
  267.       end; {while}
  268.     end; {if}
  269.     Parser.Next;
  270.   end; {if}
  271.   if FuncType = 0 then
  272.   begin
  273.     if Parser.CurrTokenId <> CSTI_Colon then
  274.     begin
  275.       Parser.Free;
  276.       Result := False;
  277.       exit;
  278.     end;
  279.  
  280.     Parser.Next;
  281.     VCType := FOwner.FSE.FindType(Parser.GetToken);
  282.     if VCType = Cardinal(-1) then
  283.     begin
  284.       Parser.Free;
  285.       Result := False;
  286.       exit;
  287.     end;
  288.   end
  289.   else if FuncType = 2 then {constructor}
  290.   begin
  291.     VCType := FOwner.FSE.FindType(FClassName) 
  292.   end else
  293.     VCType := Cardinal(-1);
  294.   NDecl := inttostr(VCType) + NDecl;
  295.   Parser.Free;
  296.   new(p);
  297.   p^.Owner := Self;
  298.   p^.Name := Name;
  299.   p^.NameHash := MakeHash(Name);
  300.   p^.ProcDecl := NDecl;
  301.   if FuncType = 2 then
  302.     p^.FType := 2
  303.   else
  304.     p^.FType := 0;
  305.   p^.MethodProcNo := Cardinal(-1);
  306.   FClassItems.Add(p);
  307.   Result := True;
  308. end;
  309.  
  310. procedure TIFPSCompileTimeClass.RegisterProperty(const PropertyName,
  311.   PropertyType: string; PropAC: TIFPSPropType);
  312. var
  313.   FType: Cardinal;
  314.   p: PClassItem;
  315.   PT, s: string;
  316. begin
  317.   pt := PropertyType;
  318.   repeat
  319.     FType := FOwner.FSE.FindType(FastUpperCase(grfw(pt)));
  320.     if FType = cardinal(-1) then Exit;
  321.     if s = '' then s := inttostr(ftype) else s := s + ' '+ inttostr(ftype);
  322.   until pt = '';
  323.   New(p);
  324.   p^.Owner := Self;
  325.   p^.Name := FastUppercase(PropertyName);
  326.   p^.NameHash := MakeHash(p^.Name);
  327.   p^.FType := 1;
  328.   p^.PropAC := PropAC;
  329.   p^.ProcDecl := s;
  330.   p^.PropReadProcNo := Cardinal(-1);
  331.   p^.PropWriteProcNo := Cardinal(-1);
  332.   FClassItems.Add(p);
  333. end;
  334.  
  335.  
  336. procedure TIFPSCompileTimeClass.RegisterPublishedProperties;
  337. var
  338.   p: PPropList;
  339.   i, Count: Longint;
  340.   a: TIFPSPropType;
  341. begin
  342.   if (Fclass = nil) or (Fclass.ClassInfo = nil) then exit;
  343.   Count := GetTypeData(fclass.ClassInfo)^.PropCount;
  344.   GetMem(p, Count * SizeOf(Pointer));
  345.   GetPropInfos(fclass.ClassInfo, p);
  346.   for i := Count -1 downto 0 do
  347.   begin
  348.     if p^[i]^.PropType^.Kind in [tkLString, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod] then
  349.     begin
  350.       if (p^[i]^.GetProc <> nil) then
  351.       begin
  352.         if p^[i]^.SetProc = nil then
  353.           a := iptr
  354.         else
  355.           a := iptrw;
  356.       end else
  357.       begin
  358.         a := iptW;
  359.         if p^[i]^.SetProc = nil then continue;
  360.       end;
  361.       RegisterProperty(p^[i]^.Name, p^[i]^.PropType^.Name, a);
  362.     end;
  363.   end;
  364.   FreeMem(p);
  365. end;
  366.  
  367. function TIFPSCompileTimeClass.RegisterPublishedProperty(const Name: string): Boolean;
  368. var
  369.   p: PPropInfo;
  370.   a: TIFPSPropType;
  371. begin
  372.   if (Fclass = nil) or (Fclass.ClassInfo = nil) then begin Result := False; exit; end;
  373.   p := GetPropInfo(fclass.ClassInfo, Name);
  374.   if p = nil then begin Result := False; exit; end;
  375.   if (p^.GetProc <> nil) then
  376.   begin
  377.     if p^.SetProc = nil then
  378.       a := iptr
  379.     else
  380.       a := iptrw;
  381.   end else
  382.   begin
  383.     a := iptW;
  384.     if p^.SetProc = nil then begin result := False; exit; end;
  385.   end;
  386.   RegisterProperty(p^.Name, p^.PropType^.Name, a);
  387.   Result := True;
  388. end;
  389.  
  390. { TIFPSCompileTimeClassesImporter }
  391. function TIFPSCompileTimeClassesImporter.Add(InheritsFrom: TIFPSCompileTimeClass; FClass: TClass): TIFPSCompileTimeClass;
  392. var
  393.   f: PIFPSType;
  394. begin
  395.   Result := TIFPSCompileTimeClass.Create(fClass, Self);
  396.   Result.FInheritsFrom := InheritsFrom;
  397.   FClasses.Add(Result);
  398.   f := FSE.AddType(Result.FClassName, btClass);
  399.   f^.Ex := TIFPSDelphiClass.Create(Result);
  400.   f^.FExport := True;
  401. end;
  402.  
  403. function TIFPSCompileTimeClassesImporter.Add2(
  404.   InheritsFrom: TIFPSCompileTimeClass;
  405.   FClassName: string): TIFPSCompileTimeClass;
  406. var
  407.   f: PIFPSType;
  408. begin
  409.   Result := TIFPSCompileTimeClass.Create2(fClassname, Self);
  410.   Result.FInheritsFrom := InheritsFrom;
  411.   FClasses.Add(Result);
  412.   f := FSE.AddType(Result.FClassName, btClass);
  413.   f^.Ex := TIFPSDelphiClass.Create(Result);
  414.   f^.FExport := True;
  415. end;
  416.  
  417. procedure TIFPSCompileTimeClassesImporter.Clear;
  418. var
  419.   I: Longint;
  420. begin
  421.   for i := FClasses.Count -1 downto 0 do
  422.   begin
  423.     TIFPSCompileTimeClass(FClasses.GetItem(I)).Free;
  424.   end;
  425.   FClasses.Clear;
  426. end;
  427.  
  428. constructor TIFPSCompileTimeClassesImporter.Create(AOwner: TIFPSPascalCompiler; AutoFree: Boolean);
  429. begin
  430.   inherited Create;
  431.   FSE := AOwner;
  432.   FClasses := TIfList.Create;
  433.   if AutoFree then
  434.     FSE.AddToFreeList(Self);
  435. end;
  436.  
  437. destructor TIFPSCompileTimeClassesImporter.Destroy;
  438. begin
  439.   Clear;
  440.   FClasses.Free;
  441.   inherited Destroy;
  442. end;
  443.  
  444. function TIFPSCompileTimeClassesImporter.FindClass(const aClassName: string):TIFPSCompileTimeClass;
  445. var
  446.   i: Longint;
  447.   Cl: string;
  448.   H: Longint;
  449.   x: TIFPSCompileTimeClass;
  450. begin
  451.   cl := FastUpperCase(aClassName);
  452.   H := MakeHash(Cl);
  453.   for i :=0 to FClasses.Count -1 do
  454.   begin
  455.     x := FClasses.GetItem(I);
  456.     if (X.FClassNameHash = H) and (X.FClassName = Cl) then
  457.     begin
  458.       Result := X;
  459.       Exit;
  460.     end;
  461.   end;
  462.   Result := nil;
  463. end;
  464.  
  465.  
  466.  
  467. const
  468.   IFPSClassType = '!IFPSClass';
  469.   ProcHDR = 'procedure a;';
  470. type
  471.   TIFPSPascalCompiler2 = class (TIFPSPascalCompiler) end;
  472.  
  473. { TIFPSDelphiClass }
  474.  
  475. constructor TIFPSDelphiClass.Create(CE: TIFPSCompileTimeClass);
  476. begin
  477.   inherited Create(CE.FOwner.FSE);
  478.   NilProcNo := Cardinal(-1);
  479.   CastProcNo := Cardinal(-1);
  480.   CompareProcNo := Cardinal(-1);
  481.  
  482.   Self.Ce := CE;
  483. end;
  484.  
  485. function TIFPSDelphiClass.Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean;
  486. var
  487.   C: PClassItem;
  488.   P: PIFPSUsedRegProc;
  489.   s, w, n: string;
  490.  
  491. begin
  492.   C := Pointer(Index);
  493.   if c^.MethodProcNo = Cardinal(-1) then
  494.   begin
  495.     ProcNo := TIFPSPascalCompiler2(Se).AddUsedFunction2(P);
  496.     P^.RP := SE.AddFunction(ProcHDR);
  497.     p^.RP^.Name := '';
  498.     p^.RP^.NameHash := 0;
  499.     p^.RP^.Decl := C^.ProcDecl;
  500.     TIFPSPascalCompiler2(Se).ReplaceTypes(p^.RP^.Decl);
  501.     s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
  502.     w := C^.ProcDecl;
  503.     if GRFW(w) = '-1' then
  504.       s := s + #0
  505.     else
  506.       s := s + #1;
  507.     while W <> '' do
  508.     begin
  509.       n := grfw(w);
  510.       grfw(w);
  511.       if (n <> '') and (n[1] = '!') then
  512.         s := s + #1
  513.       else
  514.         s := s + #0;
  515.     end;
  516.     p^.RP^.ImportDecl := s;
  517.     C^.MethodProcNo := ProcNo;
  518.   end else begin
  519.      ProcNo := c^.MethodProcNo;
  520.   end;
  521.   Result := True;
  522. end;
  523.  
  524. function TIFPSDelphiClass.Func_Find(const Name: string; var Index: Cardinal): Boolean;
  525. var
  526.   H: Longint;
  527.   I: Longint;
  528.   CurrClass: TIFPSCompileTimeClass;
  529.   C: PClassItem;
  530. begin
  531.   H := MakeHash(Name);
  532.   CurrClass := Ce;
  533.   while CurrClass <> nil do
  534.   begin
  535.     for i := CurrClass.FClassItems.Count -1 downto 0 do
  536.     begin
  537.       C := CurrClass.FClassItems.GetItem(I);
  538.       if (c^.Ftype = 0) and (C^.NameHash = H) and (C^.Name = Name) then
  539.       begin
  540.         Index := Cardinal(C);
  541.         Result := True;
  542.         exit;
  543.       end;
  544.     end;
  545.     CurrClass := CurrClass.FInheritsFrom;
  546.   end;
  547.   Result := False;
  548. end;
  549.  
  550. function TIFPSDelphiClass.Property_Find(const Name: string;
  551.   var Index: Cardinal): Boolean;
  552. var
  553.   H: Longint;
  554.   I: Longint;
  555.   CurrClass: TIFPSCompileTimeClass;
  556.   C: PClassItem;
  557. begin
  558.   H := MakeHash(Name);
  559.   CurrClass := Ce;
  560.   while CurrClass <> nil do
  561.   begin
  562.     for i := CurrClass.FClassItems.Count -1 downto 0 do
  563.     begin
  564.       C := CurrClass.FClassItems.GetItem(I);
  565.       if (c^.Ftype = 1) and (C^.NameHash = H) and (C^.Name = Name) then
  566.       begin
  567.         Index := Cardinal(C);
  568.         Result := True;
  569.         exit;
  570.       end;
  571.     end;
  572.     CurrClass := CurrClass.FInheritsFrom;
  573.   end;
  574.   Result := False;
  575. end;
  576.  
  577. function TIFPSDelphiClass.Property_Get(Index: Cardinal;
  578.   var ProcNo: Cardinal): Boolean;
  579. var
  580.   C: PClassItem;
  581.   P: PIFPSUsedRegProc;
  582.   w,s: string;
  583.   i: Longint;
  584.  
  585. begin
  586.   C := Pointer(Index);
  587.   if c^.PropAC = iptW then
  588.   begin
  589.     Result := False;
  590.     exit;
  591.   end;
  592.   if c^.PropReadProcNo = Cardinal(-1) then
  593.   begin
  594.     ProcNo := TIFPSPascalCompiler2(Se).AddUsedFunction2(P);
  595.     P^.RP := SE.AddFunction(ProcHDR);
  596.     p^.RP^.Name := '';
  597.     p^.RP^.NameHash := 0;
  598.     p^.RP^.Decl := IntToStr(TIFPSPascalCompiler2(Se).AT2UT(StrToIntDef(Fw(C^.ProcDecl), -1)));
  599.     s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|';
  600.     w := C^.ProcDecl;
  601.     i := 0;
  602.     repeat
  603.       grfw(w);
  604.       inc(i);
  605.     until w = '';
  606.     s := s + #0#0#0#0;
  607.     Longint((@(s[length(s)-3]))^) := i;
  608.     p^.RP^.ImportDecl := s;
  609.     C^.PropReadProcNo := ProcNo;
  610.   end else begin
  611.      ProcNo := c^.PropReadProcNo;
  612.   end;
  613.   Result := True;
  614. end;
  615.  
  616. function TIFPSDelphiClass.Property_Set(Index: Cardinal;
  617.   var ProcNo: Cardinal): Boolean;
  618. var
  619.   C: PClassItem;
  620.   P: PIFPSUsedRegProc;
  621.   s, w: string;
  622.   i: Longint;
  623.  
  624. begin
  625.   C := Pointer(Index);
  626.   if c^.PropAC = iptR then
  627.   begin
  628.     Result := False;
  629.     exit;
  630.   end;
  631.   if c^.PropWriteProcNo = Cardinal(-1) then
  632.   begin
  633.     ProcNo := TIFPSPascalCompiler2(Se).AddUsedFunction2(P);
  634.     P^.RP := SE.AddFunction(ProcHDR);
  635.     p^.RP^.Name := '';
  636.     p^.RP^.NameHash := 0;
  637.     p^.RP^.Decl := '-1';
  638.     s := 'class:' + C.Owner.FClassName + '|' + C.Name + '@|';
  639.     w := C^.ProcDecl;
  640.     i := 0;
  641.     repeat
  642.       grfw(w);
  643.       inc(i);
  644.     until w = '';
  645.     s := s + #0#0#0#0;
  646.     Longint((@(s[length(s)-3]))^) := i;
  647.     p^.RP^.ImportDecl := s;
  648.     C^.PropWriteProcNo := ProcNo;
  649.   end else begin
  650.      ProcNo := c^.PropWriteProcNo;
  651.   end;
  652.   Result := True;
  653. end;
  654.  
  655. function TIFPSDelphiClass.Property_GetHeader(Index: Cardinal;
  656.   var s: string): Boolean;
  657. var
  658.   c: PClassItem;
  659. begin
  660.   C := Pointer(Index);
  661.   s := c^.ProcDecl;
  662.   Result := True;
  663. end;
  664.  
  665. function TIFPSDelphiClass.SelfType: Cardinal;
  666. begin
  667.   Result := SE.FindType(IFPSClassType);
  668.   if Result = Cardinal(-1) then
  669.   begin
  670.     SE.AddType(IFPSClassType, btResourcePointer);
  671.     Result := SE.FindType(IFPSClassType);
  672.   end;
  673. end;
  674.  
  675. function TIFPSDelphiClass.ClassFunc_Call(Index: Cardinal;
  676.   var ProcNo: Cardinal): Boolean;
  677. var
  678.   C: PClassItem;
  679.   P: PIFPSUsedRegProc;
  680.   s, w, n: string;
  681.  
  682. begin
  683.   C := Pointer(Index);
  684.   if c^.MethodProcNo = Cardinal(-1) then
  685.   begin
  686.     ProcNo := TIFPSPascalCompiler2(Se).AddUsedFunction2(P);
  687.     P^.RP := SE.AddFunction(ProcHDR);
  688.     p^.RP^.Name := '';
  689.     p^.RP^.NameHash := 0;
  690.     p^.RP^.Decl := C^.ProcDecl;
  691.     TIFPSPascalCompiler2(Se).ReplaceTypes(p^.RP^.Decl);
  692.     s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0);
  693.     w := C^.ProcDecl;
  694.     if GRFW(w) = '-1' then
  695.       s := s + #0
  696.     else
  697.       s := s + #1;
  698.     while W <> '' do
  699.     begin
  700.       n := grfw(w);
  701.       grfw(w);
  702.       if (n <> '') and (n[1] = '!') then
  703.         s := s + #1
  704.       else
  705.         s := s + #0;
  706.     end;
  707.     p^.RP^.ImportDecl := s;
  708.     C^.MethodProcNo := ProcNo;
  709.   end else begin
  710.      ProcNo := c^.MethodProcNo;
  711.   end;
  712.   Result := True;
  713. end;
  714.  
  715. function TIFPSDelphiClass.ClassFunc_Find(const Name: string;
  716.   var Index: Cardinal): Boolean;
  717. var
  718.   H: Longint;
  719.   I: Longint;
  720.   CurrClass: TIFPSCompileTimeClass;
  721.   C: PClassItem;
  722. begin
  723.   H := MakeHash(Name);
  724.   CurrClass := Ce;
  725.   while CurrClass <> nil do
  726.   begin
  727.     for i := CurrClass.FClassItems.Count -1 downto 0 do
  728.     begin
  729.       C := CurrClass.FClassItems.GetItem(I);
  730.       if (c^.Ftype = 2) and (C^.NameHash = H) and (C^.Name = Name) then
  731.       begin
  732.         Index := Cardinal(C);
  733.         Result := True;
  734.         exit;
  735.       end;
  736.     end;
  737.     CurrClass := CurrClass.FInheritsFrom;
  738.   end;
  739.   Result := False;
  740. end;
  741.  
  742. function TIFPSDelphiClass.IsCompatibleWith(
  743.   Cl: TIFPSExternalClass): Boolean;
  744. var
  745.   Temp: TIFPSCompileTimeClass;
  746. begin
  747.   if not (cl is TIFPSDelphiClass) then
  748.   begin
  749.     Result := False;
  750.     exit;
  751.   end;
  752.   temp := TIFPSDelphiClass(cl).Ce;
  753.   while Temp <> nil do
  754.   begin
  755.     if Temp = Ce then
  756.     begin
  757.       Result := True;
  758.       exit;
  759.     end;
  760.     Temp := Temp.FInheritsFrom;
  761.   end;
  762.   Result := False;
  763. end;
  764.  
  765. destructor TIFPSDelphiClass.Destroy;
  766. begin
  767.   inherited Destroy;
  768. end;
  769.  
  770. function TIFPSDelphiClass.SetNil(TypeNo: Cardinal; var ProcNo: Cardinal): Boolean;
  771. var
  772.   P: PIFPSUsedRegProc;
  773.  
  774. begin
  775.   if NilProcNo <> Cardinal(-1) then
  776.   begin
  777.     Procno := NilProcNo;
  778.     Result := True;
  779.     exit;
  780.   end;
  781.   ProcNo := TIFPSPascalCompiler2(Se).AddUsedFunction2(P);
  782.   P^.RP := SE.AddFunction(ProcHDR);
  783.   p^.RP^.Name := '';
  784.   p^.RP^.NameHash := 0;
  785.   p^.RP^.Decl := '-1 !VARNO '+IntToStr(TypeNo);
  786.   p^.RP^.ImportDecl := 'class:-';
  787.   NilProcNo := Procno;
  788.   Result := True;
  789. end;
  790.  
  791. function TIFPSDelphiClass.CastToType(TypeNo, IntoType: Cardinal;
  792.   var ProcNo: Cardinal): Boolean;
  793. var
  794.   P: PIFPSUsedRegProc;
  795.   Pt: PIFPSType;
  796.  
  797. begin
  798.   pt := TComp(Se).FUsedTypes.GetItem(IntoType);
  799.   if (pt^.BaseType <> btClass) or (not (pt^.Ex is TIFPSDelphiClass)) then
  800.   begin
  801.     Result := False;
  802.     exit;
  803.   end;
  804.   if CastProcNo <> Cardinal(-1) then
  805.   begin
  806.     Procno := CastProcNo;
  807.     Result := True;
  808.     exit;
  809.   end;
  810.   ProcNo := TIFPSPascalCompiler2(Se).AddUsedFunction2(P);
  811.   P^.RP := SE.AddFunction(ProcHDR);
  812.   p^.RP^.Name := '';
  813.   p^.RP^.NameHash := 0;
  814.   p^.RP^.Decl := '-1 !VARTO '+IntToStr(TypeNo)+' !TYPENO '+IntToStr(TComp(SE).GetType(btu32));
  815.   p^.RP^.ImportDecl := 'class:+';
  816.   CastProcNo := ProcNo;
  817.   Result := True;
  818. end;
  819.  
  820. function TIFPSDelphiClass.CompareClass(OtherTypeNo: Cardinal;
  821.   var ProcNo: Cardinal): Boolean;
  822. var
  823.   P: PIFPSUsedRegProc;
  824.   Pt: PIFPSType;
  825.  
  826. begin
  827.   pt := TComp(Se).FUsedTypes.GetItem(OtherTypeNo);
  828.   if (pt <> nil) and ((pt^.BaseType <> btClass) or (not (pt^.Ex is TIFPSDelphiClass))) then
  829.   begin
  830.     Result := False;
  831.     exit;
  832.   end;
  833.   if CompareProcNo <> Cardinal(-1) then
  834.   begin
  835.     Procno := CompareProcNo;
  836.     Result := True;
  837.     exit;
  838.   end;
  839.   ProcNo := TIFPSPascalCompiler2(Se).AddUsedFunction2(P);
  840.   P^.RP := SE.AddFunction(ProcHDR);
  841.   p^.RP^.Name := '';
  842.   p^.RP^.NameHash := 0;
  843.   p^.RP^.Decl := IntToStr(TComp(SE).at2ut(TComp(SE).FBooleanType))+' !K '+IntToStr(TComp(SE).at2ut(TComp(SE).FindType('TObject')))+' !J '+IntToStr(TComp(SE).at2ut(TComp(SE).FindType('TObject')));
  844.   p^.RP^.ImportDecl := 'class:*';
  845.   CompareProcNo := ProcNo;
  846.   Result := True;
  847. end;
  848.  
  849. end.
  850.  
  851.  
  852.