From 00e3424c1aac0de14f9b2c969711df6873ab3eee Mon Sep 17 00:00:00 2001 From: John Peel Date: Thu, 26 Sep 2013 22:17:18 -0400 Subject: [PATCH] Simba: CodeInsight and Function List update. CodeInsight now parses assigns in variable blocks. CodeInsight now parses Lape unions correctly. CodeInsight now returns method names with () even if they have no params. FunctionList now puts type methods under their respective type. GetMethodName doesn't include NextChar for non-methods. CodeInsight now shows record inheritence. FunctionList now sets proper MethodStr for non-methods. --- Projects/Simba/framefunctionlist.pas | 98 ++++++++++++++++++++++++---- Projects/Simba/simbaunit.pas | 4 +- Units/Misc/CastaliaPasLex.pas | 1 + Units/Misc/CastaliaPasLexTypes.pas | 1 + Units/Misc/CastaliaSimplePasPar.pas | 72 ++++++++++---------- Units/Misc/v_ideCodeParser.pas | 55 +++++++++++++--- 6 files changed, 170 insertions(+), 61 deletions(-) diff --git a/Projects/Simba/framefunctionlist.pas b/Projects/Simba/framefunctionlist.pas index 2f8b8bf95..57bbfd8c0 100644 --- a/Projects/Simba/framefunctionlist.pas +++ b/Projects/Simba/framefunctionlist.pas @@ -549,18 +549,48 @@ procedure TFunctionListFrame.Terminate; procedure TFillThread.Update; procedure AddProcsTree(Node: TTreeNode; Procs: TDeclarationList; Path: string); procedure ProcessProcedure(Node: TTreeNode; Proc: TciProcedureDeclaration); + function findNodeStartingWith(Node: TTreeNode; x: string): TTreeNode; + var + x_len: LongInt; + begin + x_len := Length(x); + + Result := Node.GetFirstChild(); + while (Result <> nil) and (Copy(Result.Text, 1, x_len) <> x) do + Result := Result.GetNextSibling(); + end; var tmpNode: TTreeNode; Name, FirstLine: string; Index: LongInt; + ClassName: TDeclaration; begin if (Assigned(Proc.Name)) then begin Name := Proc.Name.ShortText + '; '; + ClassName := Proc.Items.GetFirstItemOfClass(TciProcedureClassName); + if (Assigned(ClassName)) then + begin + tmpNode := findNodeStartingWith(Node, ClassName.ShortText + ' ='); + if (tmpNode = nil) then + tmpNode := findNodeStartingWith(Node, ClassName.ShortText); + + if (tmpNode = nil) then + begin + tmpNode := Node.TreeNodes.AddChild(Node, ClassName.CleanText); + tmpNode.ImageIndex := 36; + tmpNode.SelectedIndex := 36; + end; + + Node := tmpNode; + end; + FirstLine := Lowercase(Proc.CleanText); - if (Pos(#10, FirstLine) > 0) then - FirstLine := Copy(FirstLine, 1, Pos(#10, FirstLine) - 1); + + Index := Pos(#13, FirstLine); + if (Index > 0) then + FirstLine := Copy(FirstLine, 1, Index - 1); Index := Node.IndexOfText(Trim(Name)); if (Index = -1) then @@ -594,27 +624,68 @@ procedure TFillThread.Update; end; end; procedure ProcessDecl(Node: TTreeNode; Decl: TDeclaration); + function getVarName(Decl: TDeclaration): string; + begin + case Decl.ClassName of + 'TciVarDeclaration': Result := Decl.Items.GetFirstItemOfClass(TciVarName).ShortText; + 'TciConstantDeclaration': Result := Decl.Items.GetFirstItemOfClass(TciConstantName).ShortText; + 'TciClassField': Result := Decl.Items.GetFirstItemOfClass(TciFieldName).ShortText; + end; + end; var tmpNode: TTreeNode; begin - tmpNode := Node.TreeNodes.AddChild(Node, Decl.CleanText); + tmpNode := Node.TreeNodes.AddChild(Node, Trim(Decl.CleanText)); tmpNode.Data := GetMem(SizeOf(TMethodInfo)); if (Decl is TciConstantDeclaration) then tmpNode.ImageIndex := 33; - if (Decl is TciTypeDeclaration) then tmpNode.ImageIndex := 36; - if (Decl is TciVarDeclaration) then tmpNode.ImageIndex := 37; + if (Decl is TciVarDeclaration) or (Decl is TciClassField) then tmpNode.ImageIndex := 37; tmpNode.SelectedIndex := tmpNode.ImageIndex; FillChar(PMethodInfo(tmpNode.Data)^, SizeOf(TMethodInfo), 0); - with PMethodInfo(tmpNode.Data)^ do - begin - MethodStr := strnew(Pchar(Decl.CleanText)); - Filename := strnew(pchar(Path)); - BeginPos := Decl.StartPos; - EndPos := Decl.StartPos + Length(TrimRight(Decl.RawText)); - end; + with PMethodInfo(tmpNode.Data)^ do + begin + MethodStr := strnew(Pchar(getVarName(Decl))); + Filename := strnew(pchar(Path)); + BeginPos := Decl.StartPos; + EndPos := Decl.StartPos + Length(TrimRight(Decl.RawText)); + end; + end; + procedure ProcessType(Node: TTreeNode; Decl: TciTypeDeclaration); + var + tmpNode: TTreeNode; + TypeKind: TciTypeKind; + TypeName: TciTypeName; + Index: LongInt; + begin + TypeKind := TciTypeKind(Decl.Items.GetFirstItemOfClass(TciTypeKind)); + TypeName := TciTypeName(Decl.Items.GetFirstItemOfClass(TciTypeName)); + + case TypeKind.ShortText of + 'record', 'union': tmpNode := Node.TreeNodes.AddChild(Node, Trim(TypeName.CleanText) + ' = ' + TypeKind.GetRealType.ShortText); + else + tmpNode := Node.TreeNodes.AddChild(Node, Trim(Decl.CleanText)); + end; + + tmpNode.ImageIndex := 36; + tmpNode.SelectedIndex := 36; + tmpNode.Data := GetMem(SizeOf(TMethodInfo)); + FillChar(PMethodInfo(tmpNode.Data)^, SizeOf(TMethodInfo), 0); + + with PMethodInfo(tmpNode.Data)^ do + begin + MethodStr := strnew(Pchar(Decl.CleanText)); + Filename := strnew(pchar(Path)); + BeginPos := Decl.StartPos; + EndPos := Decl.StartPos + Length(TrimRight(Decl.RawText)); + end; + + if (TypeKind.ShortText = 'record') or (TypeKind.ShortText = 'union') then + for Index := 0 to TypeKind.GetRealType.Items.Count - 1 do + ProcessDecl(tmpNode, TypeKind.GetRealType.Items[Index]); end; + var I: integer; begin; @@ -625,7 +696,8 @@ procedure TFillThread.Update; if (Assigned(Procs[I])) then case Procs[I].ClassName of 'TciProcedureDeclaration': ProcessProcedure(Node, Procs[I] as TciProcedureDeclaration); - 'TciVarDeclaration', 'TciTypeDeclaration', 'TciConstantDeclaration': ProcessDecl(Node, Procs[I] as TDeclaration); + 'TciVarDeclaration', 'TciConstantDeclaration': ProcessDecl(Node, Procs[I] as TDeclaration); + 'TciTypeDeclaration': ProcessType(Node, Procs[I] as TciTypeDeclaration); 'TciJunk', 'TciInclude', 'TciCompoundStatement': ; else WriteLn('Unknown Class: ', Procs[I].ClassName); diff --git a/Projects/Simba/simbaunit.pas b/Projects/Simba/simbaunit.pas index b1e150622..cba04496c 100644 --- a/Projects/Simba/simbaunit.pas +++ b/Projects/Simba/simbaunit.pas @@ -3131,7 +3131,7 @@ function GetMethodName(Decl: string; PlusNextChar: boolean) : string; for Index := I to Length(decl) do case Decl[Index] of '(', ';', ':': begin - if (PlusNextChar) then + if (PlusNextChar) and (I > 1) then begin Result += '('; if (Decl[Index] = ';') or (Decl[Index] = ':') then //There are no parameters.. @@ -3145,7 +3145,7 @@ function GetMethodName(Decl: string; PlusNextChar: boolean) : string; Result += Decl[Index]; end; - if (PlusNextChar) then + if (PlusNextChar) and (I > 1) then Result += '('; end; diff --git a/Units/Misc/CastaliaPasLex.pas b/Units/Misc/CastaliaPasLex.pas index 7a1de1b23..f84050d88 100644 --- a/Units/Misc/CastaliaPasLex.pas +++ b/Units/Misc/CastaliaPasLex.pas @@ -1015,6 +1015,7 @@ function TmwBasePasLex.Func73: TptTokenKind; begin Result := tokIdentifier; if KeyComp('Except') then Result := tokExcept; + if KeyComp('Union') then Result := tokUnion; end; function TmwBasePasLex.Func75: TptTokenKind; diff --git a/Units/Misc/CastaliaPasLexTypes.pas b/Units/Misc/CastaliaPasLexTypes.pas index ce65d81f8..5e76f8330 100644 --- a/Units/Misc/CastaliaPasLexTypes.pas +++ b/Units/Misc/CastaliaPasLexTypes.pas @@ -200,6 +200,7 @@ interface tokReal, tokReal48, tokRecord, + tokUnion, {$IFDEF D12_NEWER} tokReference, //JThurman 2008-25-07 (anonymous methods) {$ENDIF} diff --git a/Units/Misc/CastaliaSimplePasPar.pas b/Units/Misc/CastaliaSimplePasPar.pas index ee23d0799..c2d793fdf 100644 --- a/Units/Misc/CastaliaSimplePasPar.pas +++ b/Units/Misc/CastaliaSimplePasPar.pas @@ -391,6 +391,7 @@ TmwSimplePasPar = class(TObject) procedure RecordConstant; virtual; procedure RecordFieldConstant; virtual; procedure RecordType; virtual; + procedure UnionType; virtual; procedure RecordVariant; virtual; procedure RelativeOperator; virtual; procedure RepeatStatement; virtual; @@ -452,6 +453,7 @@ TmwSimplePasPar = class(TObject) procedure UsesClause; virtual; procedure VarAbsolute; virtual; procedure VarEqual; virtual; + procedure VarAssign; virtual; procedure VarDeclaration; virtual; procedure Variable; virtual; procedure VariableList; virtual; @@ -1606,10 +1608,10 @@ procedure TmwSimplePasPar.ResolutionInterfaceName; procedure TmwSimplePasPar.Constraint; begin - while TokenId in [tokConstructor, tokRecord, tokClass, tokIdentifier] do + while TokenId in [tokConstructor, tokRecord, tokUnion, tokClass, tokIdentifier] do begin case TokenId of - tokConstructor, tokRecord, tokClass: NextToken; + tokConstructor, tokRecord, tokUnion, tokClass: NextToken; tokIdentifier: TypeId; end; if TokenId = tokComma then @@ -2777,7 +2779,7 @@ procedure TmwSimplePasPar.QualifiedIdentifier; tokImplementation, tokIn, tokInherited, tokInitialization, tokInline, tokInterface, tokIs, tokLabel, tokLibrary, tokMod, tokNil, tokNot, tokObject, tokOf, tokOr, tokOut, tokPacked, tokProcedure, tokProgram, tokProperty, - tokRaise, tokRecord, tokRepeat, tokResourceString, tokSealed, tokSet, + tokRaise, tokRecord, tokUnion, tokRepeat, tokResourceString, tokSealed, tokSet, tokShl, tokShr, tokStatic, tokString, tokThen, tokThreadVar, tokTo, tokTry, tokType, tokUnit, tokUnsafe, tokUntil, tokUses, tokVar, tokWhile, tokWith, tokXor] then @@ -3114,14 +3116,9 @@ procedure TmwSimplePasPar.VarDeclaration; tokPlatform: DirectivePlatform; end; case GenID of - tokAbsolute: - begin - VarAbsolute; - end; - tokEqual: - begin - VarEqual; - end; + tokAbsolute: VarAbsolute; + tokEqual: VarEqual; + tokAssign: VarAssign; end; while ExID in [tokDeprecated, tokLibrary, tokPlatform] do // DR 2001-10-20 case ExID of @@ -3143,6 +3140,12 @@ procedure TmwSimplePasPar.VarEqual; ConstantValueTyped; end; +procedure TmwSimplePasPar.VarAssign; +begin + Expected(tokAssign); + ConstantValueTyped; +end; + procedure TmwSimplePasPar.VarNameList; begin VarName; @@ -3289,9 +3292,10 @@ procedure TmwSimplePasPar.FieldNameList; procedure TmwSimplePasPar.RecordType; begin Expected(tokRecord); + if TokenID = tokSemicolon then Exit; - {$IFDEF D8_NEWER1} + if TokenID = tokRoundOpen then begin ClassHeritage; @@ -3299,9 +3303,19 @@ procedure TmwSimplePasPar.RecordType; Exit; end; ClassMemberList; - {$ELSE} + + Expected(tokEnd); +end; + +procedure TmwSimplePasPar.UnionType; +begin + Expected(tokUnion); + + if TokenID = tokSemicolon then + Exit; + FieldList; - {$ENDIF} + Expected(tokEnd); end; @@ -4313,30 +4327,16 @@ procedure TmwSimplePasPar.PointerType; procedure TmwSimplePasPar.StructuredType; begin if TokenID = tokPacked then - begin NextToken; - end; + case TokenID of - tokArray: - begin - ArrayType; - end; - tokFile: - begin - FileType; - end; - tokRecord: - begin - RecordType; - end; - tokSet: - begin - SetType; - end; + tokArray: ArrayType; + tokFile: FileType; + tokRecord: RecordType; + tokUnion: UnionType; + tokSet: SetType; else - begin - SynError(InvalidStructuredType); - end; + SynError(InvalidStructuredType); end; end; @@ -4560,7 +4560,7 @@ procedure TmwSimplePasPar.TypeKind; begin SimpleType; end; - tokArray, tokFile, tokPacked, tokRecord, tokSet: + tokArray, tokFile, tokPacked, tokRecord, tokUnion, tokSet: begin StructuredType; end; diff --git a/Units/Misc/v_ideCodeParser.pas b/Units/Misc/v_ideCodeParser.pas index 3cdfb4de9..956061bcd 100644 --- a/Units/Misc/v_ideCodeParser.pas +++ b/Units/Misc/v_ideCodeParser.pas @@ -97,6 +97,11 @@ TciStruct = class(TDeclaration) function GetDefault(Return: TVarBase = vbName): TDeclaration; end; + TciParentedStruct = class(TciStruct) + private + function GetShortText: string; override; + end; + TciTypeKind = class(TDeclaration) private function GetShortText: string; override; @@ -172,7 +177,8 @@ TciParameterType = class(TciTypeKind); //Pr TciArrayType = class(TDeclaration); //Array TciArrayConstant = class(TDeclaration); //Array - TciRecordType = class(TciStruct); //Record + TciRecordType = class(TciParentedStruct); //Record + TciUnionType = class(TciStruct); TciClassField = class(TDeclaration); //Record TciFieldName = class(TDeclaration); //Record TciRecordConstant = class(TDeclaration); //Record @@ -247,6 +253,7 @@ TCodeParser = class(TmwSimplePasPar) procedure ArrayConstant; override; //Array Const procedure RecordType; override; //Record + procedure UnionType; override; //Union procedure ClassField; override; //Record + Class procedure FieldName; override; //Record + Class procedure RecordConstant; override; //Record Const @@ -726,6 +733,22 @@ function TciStruct.GetDefault(Return: TVarBase = vbName): TDeclaration; Result := d.Owner.Items.GetFirstItemOfClass(TciFieldName) end; +function TciParentedStruct.GetShortText: string; +var + P: LongInt; +begin + if (fShortText = '') then + begin + fShortText := CleanText; + P := Pos(')', fShortText); + if (P > 0) then + fShortText := Copy(fShortText, 1, P) + else + fShortText := GetFirstWord(fShortText); + end; + Result := fShortText; +end; + function TciTypeKind.GetShortText: string; var d: TDeclaration; @@ -835,19 +858,24 @@ function TciProcedureDeclaration.GetCleanDeclaration: string; Return : TciReturnType; begin if (fCleanDecl <> '') then - result := fCleanDecl + Result := fCleanDecl else begin - result := proctype; + Result := ProcType; + if (Name <> nil) then - result := result + ' ' + Name.ShortText; + Result := Result + ' ' + Name.ShortText + '('; + if (Params <> '') then - result := result + '(' + params + ')'; + Result := Result + Params; + + Result := Result + ')'; + Return := fItems.GetFirstItemOfClass(TciReturnType) as TciReturnType; if (Return <> nil) then - result := result + ': ' + Return.ShortText + Result := Result + ': ' + Return.ShortText else - result := result + ';'; + Result := Result + ';'; end; end; @@ -1478,9 +1506,16 @@ procedure TCodeParser.RecordType; PopStack; end; +procedure TCodeParser.UnionType; +begin + PushStack(TciUnionType); + inherited; + PopStack; +end; + procedure TCodeParser.ClassField; begin - if (not InDeclarations([TciRecordType, TciClassType])) then + if (not InDeclarations([TciRecordType, TciUnionType, TciClassType])) then begin inherited; Exit; @@ -1552,7 +1587,7 @@ procedure TCodeParser.AncestorId; procedure TCodeParser.ClassMethodHeading; begin - if (not InDeclarations([TciRecordType, TciClassType])) then + if (not InDeclarations([TciRecordType, TciUnionType, TciClassType])) then begin inherited; Exit; @@ -1617,7 +1652,7 @@ procedure TCodeParser.ProcedureMethodName; procedure TCodeParser.ClassProperty; begin - if (not InDeclarations([TciRecordType, TciClassType])) then + if (not InDeclarations([TciRecordType, TciUnionType, TciClassType])) then begin inherited; Exit;