Changeset 233 for branches/xpascal/Source.pas

Timestamp:

Jun 26, 2023, 6:08:23 PM (17 months ago)

Author:

chronos

Message:

• Added: Support for procedures.
• Added: Project pascal file can be opened from main menu. Last file name is remembered.
• Modified: Improved XML output of source structure.

File:

• branches/xpascal/Source.pas (modified) (18 diffs)

branches/xpascal/Source.pas

@@ -148 +148 @@
   end;
 
+  { TProcedure }
+
+  TProcedure = class(TSourceNode)
+  protected
+    function GetFieldsCount: Integer; override;
+  public
+    Name: string;
+    InternalName: string;
+    Params: TFunctionParameters;
+    Block: TBlock;
+    ParentType: TType;
+    procedure GetValue(Index: Integer; out Value); override;
+    function GetField(Index: Integer): TField; override;
+    procedure SetValue(Index: Integer; var Value); override;
+    constructor Create;
+    destructor Destroy; override;
+  end;
+
+  { TProcedures }
+
+  TProcedures = class(TSourceNodeList<TProcedure>)
+    ParentType: TType;
+    function SearchByName(Name: string): TProcedure;
+    function AddNew(Name: string): TProcedure;
+  end;
+
   TCommand = class(TSourceNode)
   end;
@@ -164 +190 @@
   public
     FunctionDef: TFunction;
+    Params: TExpressions;
+    procedure GetValue(Index: Integer; out Value); override;
+    function GetField(Index: Integer): TField; override;
+    procedure SetValue(Index: Integer; var Value); override;
+    constructor Create;
+    destructor Destroy; override;
+  end;
+
+  { TProcedureCall }
+
+  TProcedureCall = class(TCommand)
+  protected
+    function GetFieldsCount: Integer; override;
+  public
+    ProcedureDef: TProcedure;
     Params: TExpressions;
     procedure GetValue(Index: Integer; out Value); override;
@@ -365 +406 @@
     Constants: TConstants;
     Functions: TFunctions;
+    Procedures: TProcedures;
     Types: TTypes;
     BeginEnd: TBeginEnd;
@@ -375 +417 @@
     function GetVariable(Name: string): TVariable;
     function GetFunction(Name: string): TFunction;
+    function GetProcedure(Name: string): TProcedure;
     constructor Create;
     destructor Destroy; override;
@@ -426 +469 @@
 end;
 
+{ TProcedureCall }
+
+function TProcedureCall.GetFieldsCount: Integer;
+begin
+  Result := 2;
+end;
+
+procedure TProcedureCall.GetValue(Index: Integer; out Value);
+begin
+  if Index = 0 then TProcedure(Value) := ProcedureDef
+  else if Index = 1 then TExpressions(Value) := Params
+  else inherited;
+end;
+
+function TProcedureCall.GetField(Index: Integer): TField;
+begin
+  if Index = 0 then Result := TField.Create(dtObject, 'Procedure')
+  else if Index = 1 then Result := TField.Create(dtObject, 'Parameters')
+  else inherited;
+end;
+
+procedure TProcedureCall.SetValue(Index: Integer; var Value);
+begin
+  if Index = 0 then ProcedureDef := TProcedure(Value)
+  else if Index = 1 then Params := TExpressions(Value)
+  else inherited;
+end;
+
+constructor TProcedureCall.Create;
+begin
+  Params := TExpressions.Create;
+end;
+
+destructor TProcedureCall.Destroy;
+begin
+  FreeAndNil(Params);
+  inherited;
+end;
+
+{ TProcedure }
+
+function TProcedures.SearchByName(Name: string): TProcedure;
+var
+  I: Integer;
+begin
+  I := 0;
+  while (I < Count) and (TProcedure(Items[I]).Name <> Name) do Inc(I);
+  if I < Count then Result := TProcedure(Items[I])
+    else Result := nil;
+end;
+
+function TProcedures.AddNew(Name: string): TProcedure;
+begin
+  Result := TProcedure.Create;
+  Result.Name := Name;
+  Result.ParentType := ParentType;
+  Add(Result);
+end;
+
+function TProcedure.GetFieldsCount: Integer;
+begin
+  Result := 3;
+end;
+
+procedure TProcedure.GetValue(Index: Integer; out Value);
+begin
+  if Index = 0 then TBlock(Value) := Block
+  else if Index = 1 then TFunctionParameters(Value) := Params
+  else if Index = 2 then string(Value) := Name
+  else inherited;
+end;
+
+function TProcedure.GetField(Index: Integer): TField;
+begin
+  if Index = 0 then Result := TField.Create(dtObject, 'Block')
+  else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
+  else if Index = 2 then Result := TField.Create(dtString, 'Name')
+  else inherited;
+end;
+
+procedure TProcedure.SetValue(Index: Integer; var Value);
+begin
+  if Index = 0 then Block := TBlock(Value)
+  else if Index = 1 then Params := TFunctionParameters(Value)
+  else if Index = 2 then Name := string(Value)
+  else inherited;
+end;
+
+constructor TProcedure.Create;
+begin
+  Params := TFunctionParameters.Create;
+  Block := TBlock.Create;
+end;
+
+destructor TProcedure.Destroy;
+begin
+  FreeAndNil(Block);
+  FreeAndNil(Params);
+  inherited;
+end;
+
 { TExpressionBrackets }
 
@@ -771 +915 @@
   if Index = 0 then TBlock(Value) := Block
   else if Index = 1 then TFunctionParameters(Value) := Params
-  else if Index = 2 then TType(Value) := ResultType
-  else if Index = 3 then string(Value) := Name
+  else if Index = 2 then string(Value) := Name
+  else if Index = 3 then TType(Value) := ResultType
   else inherited;
 end;
@@ -780 +924 @@
   if Index = 0 then Result := TField.Create(dtObject, 'Block')
   else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
-  else if Index = 2 then Result := TField.Create(dtObject, 'ResultType')
-  else if Index = 3 then Result := TField.Create(dtString, 'Name')
+  else if Index = 2 then Result := TField.Create(dtString, 'Name')
+  else if Index = 3 then Result := TField.Create(dtObject, 'ResultType')
   else inherited;
 end;
@@ -794 +938 @@
   if Index = 0 then Block := TBlock(Value)
   else if Index = 1 then Params := TFunctionParameters(Value)
-  else if Index = 2 then ResultType := TType(Value)
-  else if Index = 3 then Name := string(Value)
+  else if Index = 2 then Name := string(Value)
+  else if Index = 3 then ResultType := TType(Value)
   else inherited;
 end;
@@ -1052 +1196 @@
 begin
   if Index = 0 then Result := TField.Create(dtObject, 'Function')
-  else if Index = 1 then Result := TField.Create(dtObject, 'Parameters')
+  else if Index = 1 then Result := TField.Create(dtList, 'Parameters')
   else inherited;
 end;
@@ -1139 +1283 @@
   else if Index = 3 then TConstants(Value) := Constants
   else if Index = 4 then TFunctions(Value) := Functions
+  else if Index = 5 then TProcedures(Value) := Procedures
   else inherited;
 end;
@@ -1144 +1289 @@
 function TBlock.GetField(Index: Integer): TField;
 begin
-  if Index = 0 then Result := TField.Create(dtObject, 'Block')
+  if Index = 0 then Result := TField.Create(dtObject, 'BeginEnd')
   else if Index = 1 then Result := TField.Create(dtList, 'Types')
   else if Index = 2 then Result := TField.Create(dtList, 'Variables')
   else if Index = 3 then Result := TField.Create(dtList, 'Constants')
   else if Index = 4 then Result := TField.Create(dtList, 'Functions')
+  else if Index = 5 then Result := TField.Create(dtList, 'Procedures')
   else inherited;
 end;
@@ -1154 +1300 @@
 function TBlock.GetFieldsCount: Integer;
 begin
-  Result := 5;
+  Result := 6;
 end;
 
@@ -1164 +1310 @@
   else if Index = 3 then Constants := TConstants(Value)
   else if Index = 4 then Functions := TFunctions(Value)
+  else if Index = 5 then Procedures := TProcedures(Value)
   else inherited;
 end;
@@ -1170 +1317 @@
 begin
   Functions.Clear;
+  Procedures.Clear;
   Constants.Clear;
   Variables.Clear;
@@ -1201 +1349 @@
   if not Assigned(Result) and Assigned(ParentBlock) then
     Result := ParentBlock.GetFunction(Name);
+end;
+
+function TBlock.GetProcedure(Name: string): TProcedure;
+begin
+  Result := Procedures.SearchByName(Name);
+  if not Assigned(Result) and Assigned(ParentBlock) then
+    Result := ParentBlock.GetProcedure(Name);
 end;
 
@@ -1211 +1366 @@
   Functions := TFunctions.Create;
   Functions.Parent := Self;
+  Procedures := TProcedures.Create;
+  Procedures.Parent := Self;
   Types := TTypes.Create;
   Types.Parent := Self;
@@ -1224 +1381 @@
   FreeAndNil(Constants);
   FreeAndNil(Functions);
+  FreeAndNil(Procedures);
   inherited;
 end;
@@ -1237 +1395 @@
 function TBeginEnd.GetField(Index: Integer): TField;
 begin
-  if Index = 0 then Result := TField.Create(dtList, 'Command')
+  if Index = 0 then Result := TField.Create(dtList, 'Commands')
   else inherited;
 end;