Tcl: extract null tags for procedures

The test case is taken from #4157 submitted by Javier Mora. Co-authored-by: Javier Mora <[email protected]> Signed-off-by: Masatake YAMATO <[email protected]>
universal-ctags · Jan 1, 2025 · eefb204 · eefb204
1 parent a92b1a7
commit eefb204
Show file tree

Hide file tree

Showing 4 changed files with 84 additions and 10 deletions.
diff --git a/Units/parser-tcl.r/nulltags.d/args.ctags b/Units/parser-tcl.r/nulltags.d/args.ctags
@@ -0,0 +1,3 @@
+--sort=no
+--extras=+{nulltag}
+--_xformat=%-16N %-10K %4n %-16F %C %{scopeKind}:%{scope}
diff --git a/Units/parser-tcl.r/nulltags.d/expected.tags-x b/Units/parser-tcl.r/nulltags.d/expected.tags-x
@@ -0,0 +1,12 @@
+                 procedure     1 input.tcl proc {} {} {return Empty } :
+aaa              procedure     2 input.tcl proc aaa {} {return Normal} :
+a                procedure     4 input.tcl proc {a} {} {return Braced} :
+ns1              namespace     6 input.tcl namespace eval ns1 { :
+                 procedure     7 input.tcl proc {} {} {return Empty } namespace:::ns1
+bbb              procedure     8 input.tcl proc bbb {} {return Normal} namespace:::ns1
+b                procedure     9 input.tcl proc {b} {} {return Braced} namespace:::ns1
+ns2              namespace    12 input.tcl namespace eval ns2 :
+                 procedure    13 input.tcl proc ns2:: {} {return Empty } namespace:ns2
+ccc              procedure    14 input.tcl proc ns2::ccc {} {return Normal} namespace:ns2
+c                procedure    15 input.tcl proc {ns2::c} {} {return Braced} namespace:ns2
+                 procedure    17 input.tcl proc :: {} {return "Empty at Root NS"} :
diff --git a/Units/parser-tcl.r/nulltags.d/input.tcl b/Units/parser-tcl.r/nulltags.d/input.tcl
@@ -0,0 +1,17 @@
+proc {}  {} {return Empty }
+proc aaa {} {return Normal}
+
+proc {a} {} {return Braced}
+
+namespace eval ns1 {
+	proc {}  {} {return Empty }
+	proc bbb {} {return Normal}
+	proc {b} {} {return Braced}
+}
+
+namespace eval ns2
+proc ns2::    {} {return Empty }
+proc ns2::ccc {} {return Normal}
+proc {ns2::c} {} {return Braced}
+
+proc :: {} {return "Empty at Root NS"}
diff --git a/parsers/tcl.c b/parsers/tcl.c
@@ -450,13 +450,42 @@ static void collectSignature (const tokenInfo *const token, collector * col)
 	vStringCat (col->str, token->string);
 }
 
+static void tokenReadQuotedIdentifier (tokenInfo *const token)
+{
+	token->type  = TOKEN_TCL_IDENTIFIER;
+	vStringClear (token->string);
+	unsigned int depth = 1;
+	while (depth > 0)
+	{
+		int c = getcFromInputFile ();
+		switch (c)
+		{
+		case EOF:
+			return;
+		case '{':
+			depth++;
+			tokenPutc (token, c);
+			break;
+		case '}':
+			if (depth != 1)
+				tokenPutc (token, c);
+			depth--;
+			break;
+		default:
+			vStringPut (token->string, c);
+		}
+	}
+}
+
 static void parseProc (tokenInfo *const token,
-					   int parent)
+					   int parent, bool quoted)
 {
 	int index = CORK_NIL;
 	int index_fq = CORK_NIL;
-
-	tokenRead (token);
+	if (quoted)
+		tokenReadQuotedIdentifier (token);
+	else
+		tokenRead (token);
 
 	if (tokenIsType(token, TCL_IDENTIFIER))
 	{
@@ -494,6 +523,8 @@ static void parseProc (tokenInfo *const token,
 				e.extensionFields.scopeName = vStringValue (ns);
 			}
 
+			if (*e.name == '\0')
+				e.allowNullTag = 1;
 			e.skipAutoFQEmission = 1;
 			index = makeTagEntry (&e);
 
@@ -517,13 +548,24 @@ static void parseProc (tokenInfo *const token,
 		}
 		else
 		{
-			tagEntryInfo *ep;
-			index = makeSimpleTag (token->string, K_PROCEDURE);
-			ep = getEntryInCorkQueue (index);
-			if (ep)
-				ep->extensionFields.scopeIndex = parent;
+			tagEntryInfo e;
+			initTagEntry (&e, tokenString (token), K_PROCEDURE);
+			if (quoted)
+			{
+				e.lineNumber = token->lineNumber;
+				e.filePosition = token->filePosition;
+				if (vStringIsEmpty (token->string))
+					e.allowNullTag = 1;
+			}
+			e.extensionFields.scopeIndex = parent;
+			index = makeTagEntry (&e);
 		}
 	}
+	else if (!quoted && token->type == '{')
+	{
+		parseProc(token, parent, true);
+		return;
+	}
 
 	vString *signature = NULL;
 	if (!tokenIsEOL (token))
@@ -628,7 +670,7 @@ static void parseNamespace (tokenInfo *const token,
 		if (tokenIsKeyword (token, NAMESPACE))
 			parseNamespace (token, index);
 		else if (tokenIsKeyword (token, PROC))
-			parseProc (token, index);
+			parseProc (token, index, false);
 		else if (tokenIsType (token, TCL_IDENTIFIER))
 		{
 			int r = notifyCommand (token, index);
@@ -677,7 +719,7 @@ static void findTclTags (void)
 		if (tokenIsKeyword (token, NAMESPACE))
 			parseNamespace (token, CORK_NIL);
 		else if (tokenIsKeyword (token, PROC))
-			parseProc (token, CORK_NIL);
+			parseProc (token, CORK_NIL, false);
 		else if (tokenIsKeyword (token, PACKAGE))
 			parsePackage (token);
 		else if (tokenIsType (token, TCL_IDENTIFIER))