[geany/geany] 2fdd94: Merge pull request #3157 from techee/tcl_sync - Commits

13 May 2022


      Branch:      refs/heads/master
Author:      Jiří Techet techet@gmail.com
Committer:   GitHub noreply@github.com
Date:        Thu, 12 May 2022 22:45:31 UTC
Commit:      2fdd948c57dfd6677b18b8e49e0d7665dee6ae3e
             https://github.com/geany/geany/commit/2fdd948c57dfd6677b18b8e49e0d7665dee6ae...
Log Message:
-----------
Merge pull request #3157 from techee/tcl_sync
Use the upstream TCL parser
Modified Paths:
--------------
    ctags/Makefile.am
    ctags/parsers/geany_tcl.c
    ctags/parsers/tcl.c
    ctags/parsers/tcl.h
    ctags/parsers/tcloo.c
    meson.build
    src/filetypes.c
    src/tagmanager/tm_parser.c
    src/tagmanager/tm_parser.h
    src/tagmanager/tm_parsers.h
    tests/ctags/simple.tcl
    tests/ctags/simple.tcl.tags
Modified: ctags/Makefile.am
4 lines changed, 3 insertions(+), 1 deletions(-)
===================================================================
@@ -89,7 +89,9 @@ parsers = \
    parsers/rust.c \
    parsers/sh.c \
    parsers/sql.c \
-	parsers/geany_tcl.c \
+	parsers/tcl.c \
+	parsers/tcl.h \
+	parsers/tcloo.c \
    parsers/geany_tex.c \
    parsers/txt2tags.c \
    parsers/verilog.c \
Modified: ctags/parsers/geany_tcl.c
145 lines changed, 0 insertions(+), 145 deletions(-)
===================================================================
@@ -1,145 +0,0 @@
-/*
-*   Copyright (c) 2000-2003, Darren Hiebert
-*
-*   This source code is released for free distribution under the terms of the
-*   GNU General Public License version 2 or (at your option) any later version.
-*
-*   This module contains functions for generating tags for TCL scripts.
-*/
-
-/*
-*   INCLUDE FILES
-*/
-#include "general.h"  /* must always come first */
-
-#include <string.h>
-
-#include "parse.h"
-#include "read.h"
-#include "routines.h"
-#include "vstring.h"
-
-/*
-*   DATA DEFINITIONS
-*/
-typedef enum {
-	K_CLASS, K_METHOD, K_PROCEDURE, K_MODULE
-} tclKind;
-
-static kindDefinition TclKinds [] = {
-	{ true, 'c', "class",     "classes" },
-	{ true, 'm', "method",    "methods" },
-	{ true, 'p', "procedure", "procedures" },
-	{ true, 'n', "module",    "modules" }
-};
-
-/*
-*   FUNCTION DEFINITIONS
-*/
-
-static const unsigned char *makeTclTag (
-		const unsigned char *cp,
-		vString *const name,
-		const tclKind kind)
-{
-	vStringClear (name);
-	while ((int) *cp != '\0'  &&  ! isspace ((int) *cp))
-	{
-		vStringPut (name, (int) *cp);
-		++cp;
-	}
-	makeSimpleTag (name, kind);
-	return cp;
-}
-
-static bool match (const unsigned char *line, const char *word)
-{
-	size_t len = strlen (word);
-	bool matched = (strncmp ((const char*) line, word, len) == 0);
-
-	if (matched)
-	{
-		/* check that the word is followed by a space to avoid detecting something
-		 * like "proc_new ..." */
-		matched = isspace (*(line + len));
-	}
-	return matched;
-}
-
-static void findTclTags (void)
-{
-	vString *name = vStringNew ();
-	const unsigned char *line;
-
-	while ((line = readLineFromInputFile ()) != NULL)
-	{
-		const unsigned char *cp;
-
-		while (isspace (line [0])) 
-			++line;
-		
-		if (line [0] == '\0'  ||  line [0] == '#')
-			continue;
-
-		/* read first word */
-		for (cp = line ; *cp != '\0'  &&  ! isspace ((int) *cp) ; ++cp)
-			;
-		if (! isspace ((int) *cp))
-			continue;
-		while (isspace ((int) *cp))
-			++cp;
-		/* Now `line' points at first word and `cp' points at next word */
-
-		if (match (line, "proc"))
-			cp = makeTclTag (cp, name, K_PROCEDURE);
-		else if (match (line, "class") || match (line, "itcl::class"))
-			cp = makeTclTag (cp, name, K_CLASS);
-		else if (match (line, "public") ||
-				match (line, "protected") ||
-				match (line, "private"))
-		{
-			if (match (cp, "method"))
-			{
-				cp += 6;
-				while (isspace ((int) *cp))
-					++cp;
-				cp = makeTclTag (cp, name, K_METHOD);
-			}
-		}
-		else if (match (line, "method"))
-		{
-			cp = makeTclTag (cp, name, K_METHOD);
-		}
-		else if (match (line, "oo::class") ) {
-			if (match (cp, "create"))
-			{
-				cp += 6;
-				while (isspace ((int) *cp))
-					++cp;
-				cp = makeTclTag (cp, name, K_CLASS);
-			}
-		}
-		else if (match (line, "namespace") ) {
-			if (match (cp, "eval"))
-			{
-				cp += 4;
-				while (isspace ((int) *cp))
-					++cp;
-				cp = makeTclTag (cp, name, K_MODULE);
-			}
-		}
-
-	}
-	vStringDelete (name);
-}
-
-extern parserDefinition* TclParser (void)
-{
-	static const char *const extensions [] = { "tcl", "tk", "wish", "itcl", NULL };
-	parserDefinition* def = parserNew ("Tcl");
-	def->kindTable  = TclKinds;
-	def->kindCount  = ARRAY_SIZE (TclKinds);
-	def->extensions = extensions;
-	def->parser     = findTclTags;
-	return def;
-}
Modified: ctags/parsers/tcl.c
716 lines changed, 716 insertions(+), 0 deletions(-)
===================================================================
@@ -0,0 +1,716 @@
+/*
+*   Copyright (c) 2000-2003, Darren Hiebert
+*   Copyright (c) 2017, Masatake YAMATO
+*   Copyright (c) 2017, Red Hat, Inc.
+*
+*   This source code is released for free distribution under the terms of the
+*   GNU General Public License version 2 or (at your option) any later version.
+*
+*   This module contains functions for generating tags for TCL scripts.
+*/
+
+/*
+*   INCLUDE FILES
+*/
+#include "general.h"  /* must always come first */
+#include "tokeninfo.h"
+#include "parse.h"
+#include "read.h"
+#include "vstring.h"
+#include "keyword.h"
+#include "entry.h"
+#include "routines.h"
+#include "ptrarray.h"
+#include "tcl.h"
+
+#include <string.h>
+
+
+
+/*
+*   DATA DEFINITIONS
+*/
+typedef enum {
+	K_PROCEDURE, K_NAMESPACE, K_PARAMETER,
+} tclKind;
+
+static scopeSeparator TclParameterSeparators [] = {
+	{ K_PROCEDURE        , "{" },
+};
+
+static kindDefinition TclKinds [] = {
+	{ true, 'p', "procedure", "procedures", },
+	{ true, 'n', "namespace", "namespaces", },
+	{ false, 'z', "parameter", "procedure parameters",
+	  ATTACH_SEPARATORS(TclParameterSeparators)},
+};
+
+enum {
+	KEYWORD_PROC,
+	KEYWORD_NAMESPACE,
+	KEYWORD_EVAL,
+	KEYWORD_PACKAGE,
+};
+
+typedef int keywordId; /* to allow KEYWORD_NONE */
+
+
+static const keywordTable TclKeywordTable[] = {
+	/* keyword			keyword ID */
+	{ "proc",			KEYWORD_PROC		},
+	{ "namespace",		KEYWORD_NAMESPACE	},
+	{ "eval",			KEYWORD_EVAL		},
+	{ "package",        KEYWORD_PACKAGE     },
+};
+
+typedef struct sCollector collector;
+struct sCollector {
+	void (* proc) (const tokenInfo *const, collector *);
+	vString *str;
+	int depth;
+	int scopeIndex;
+	int nth;
+};
+
+/*
+*   FUNCTION DEFINITIONS
+*/
+
+static bool tokenIsEOL (const tokenInfo *const token);
+
+static void initToken (tokenInfo *token, void *data);
+static void readToken (tokenInfo *const token, void *data);
+static void clearToken (tokenInfo *token);
+static void copyToken (tokenInfo *dest, tokenInfo *src, void *data CTAGS_ATTR_UNUSED);
+
+struct sTclParserState {
+	enum TclTokenType lastTokenType;
+};
+
+typedef struct sTclToken {
+	tokenInfo base;
+	int scopeIndex;
+	struct sTclParserState *pstate;
+} tclToken;
+
+#define TCL(TOKEN) ((tclToken *)TOKEN)
+#define TCL_PSTATE(TOKEN) (TCL(TOKEN)->pstate)
+
+static struct tokenTypePair typePairs [] = {
+	{ '{', '}' },
+	{ '[', ']' },
+};
+
+
+static struct tokenInfoClass tclTokenInfoClass = {
+	.nPreAlloc = 4,
+	.typeForUndefined = TOKEN_TCL_UNDEFINED,
+	.keywordNone      = KEYWORD_NONE,
+	.typeForKeyword   = TOKEN_TCL_KEYWORD,
+	.typeForEOF       = TOKEN_TCL_EOF,
+	.extraSpace       = sizeof (tclToken) - sizeof (tokenInfo),
+	.pairs            = typePairs,
+	.pairCount        = ARRAY_SIZE (typePairs),
+	.init             = initToken,
+	.read             = readToken,
+	.clear            = clearToken,
+	.copy             = copyToken,
+};
+
+extern tokenInfo *newTclToken (void *pstate)
+{
+	return newTokenFull (&tclTokenInfoClass, pstate);
+}
+
+static void clearToken (tokenInfo *token)
+{
+	TCL (token)->scopeIndex = CORK_NIL;
+	TCL (token)->pstate = NULL;
+}
+
+static void copyToken (tokenInfo *dest, tokenInfo *src, void *data CTAGS_ATTR_UNUSED)
+{
+	TCL (dest)->scopeIndex =
+		TCL (src)->scopeIndex;
+	TCL (dest)->pstate =
+		TCL (src)->pstate;
+}
+
+static void readString (vString *string)
+{
+	int c;
+	bool escaped = false;
+
+	while (1)
+	{
+		c = getcFromInputFile ();
+		switch (c)
+		{
+		case EOF:
+			return;
+		case '\':
+			if (escaped)
+			{
+				vStringPut (string, c);
+				escaped = false;
+			}
+			else
+				escaped = true;
+			break;
+		case '"':
+			vStringPut (string, c);
+			if (escaped)
+				escaped = false;
+			else
+				return;
+			break;
+		default:
+			escaped = false;
+			vStringPut (string, c);
+			break;
+		}
+	}
+}
+
+static void readIdentifier (vString *string)
+{
+	while (1)
+	{
+		int c = getcFromInputFile ();
+		if (isgraph (c) && (!strchr ("{}[]", c)))
+			vStringPut (string, c);
+		else
+		{
+			ungetcToInputFile (c);
+			break;
+		}
+	}
+}
+
+static keywordId resolveKeyword (vString *string)
+{
+	char *s = vStringValue (string);
+	static langType lang = LANG_AUTO;
+
+	if (lang == LANG_AUTO)
+		lang = getInputLanguage ();
+
+	return lookupKeyword (s, lang);
+}
+
+static void initToken (tokenInfo *token, void *data)
+{
+	TCL (token)->pstate = data;
+}
+
+static void readToken0 (tokenInfo *const token, struct sTclParserState *pstate)
+{
+	int c = EOF;
+	bool escaped;
+	bool bol = (pstate->lastTokenType == TOKEN_TCL_EOL
+				|| pstate->lastTokenType == ';'
+				|| pstate->lastTokenType == TOKEN_TCL_UNDEFINED);
+	token->type		= TOKEN_TCL_UNDEFINED;
+	token->keyword	= KEYWORD_NONE;
+	vStringClear (token->string);
+
+ getNextChar:
+	escaped = false;
+
+	do {
+		c = getcFromInputFile ();
+	} while (c == ' ' || c== '\t' || c == '\f');
+
+	if (c == '\')
+	{
+		bol = false;
+		int c0 = getcFromInputFile ();
+		switch (c0)
+		{
+		case '\n':
+		case '\r':
+			goto getNextChar;
+		default:
+			escaped = true;
+			c = c0;
+			break;
+		}
+	}
+
+	token->lineNumber   = getInputLineNumber ();
+	token->filePosition = getInputFilePosition ();
+
+	switch (c)
+	{
+	case EOF:
+		token->type = TOKEN_TCL_EOF;
+		break;
+	case '\n':
+	case '\r':
+		token->type = TOKEN_TCL_EOL;
+		break;
+	case '#':
+		if (!escaped)
+		{
+			if (bol)
+			{
+				do
+					c = getcFromInputFile ();
+				while (c != EOF && c != '\r' && c != '\n');
+			}
+			goto getNextChar;
+		}
+	case '"':
+		if (!escaped)
+		{
+			token->type = TOKEN_TCL_STRING;
+			tokenPutc (token, c);
+			readString (token->string);
+			break;
+		}
+	case ';':
+	case '{':
+	case '}':
+	case '[':
+	case ']':
+		if (!escaped)
+		{
+			tokenPutc (token, c);
+			token->type = c;
+			break;
+		}
+	case '$':
+		if (!escaped)
+		{
+			tokenPutc (token, c);
+			token->type = TOKEN_TCL_VARIABLE;
+
+			int c0 = getcFromInputFile ();
+			if (c0 == EOF)
+				break;
+
+			if (c0 == '{')
+			{
+				tokenPutc (token, c0);
+				while ((c0 = getcFromInputFile ()) != EOF)
+				{
+					tokenPutc (token, c0);
+					if (c0 == '}')
+						break;
+				}
+			}
+			else if (isalnum (c0))
+			{
+				tokenPutc (token, c0);
+				readIdentifier (token->string);
+			}
+			else
+				ungetcToInputFile (c0);
+			break;
+		}
+	default:
+			tokenPutc (token, c);
+			readIdentifier (token->string);
+
+			token->keyword = resolveKeyword (token->string);
+			if (token->keyword == KEYWORD_NONE)
+				token->type = TOKEN_TCL_IDENTIFIER;
+			else
+				token->type = TOKEN_TCL_KEYWORD;
+			break;
+	}
+}
+
+static void readToken (tokenInfo *const token, void *data)
+{
+	struct sTclParserState *pstate = TCL_PSTATE(token);
+
+	readToken0 (token, pstate);
+
+	pstate->lastTokenType = token->type;
+
+	if (data)
+	{
+		collector *col = data;
+		col->proc (token, col);
+	}
+}
+
+static bool tokenIsEOL (const tokenInfo *const token)
+{
+	if (token->type == ';'
+		|| tokenIsType (token, TCL_EOL)
+		|| tokenIsEOF (token))
+		return true;
+	return false;
+}
+
+static void skipToEndOfCmdline (tokenInfo *const token)
+{
+	while (!tokenIsEOL (token))
+	{
+		if ((token->type == '{')
+			|| (token->type == '['))
+			tokenSkipOverPair(token);
+		tokenRead (token);
+	}
+}
+
+extern void skipToEndOfTclCmdline (tokenInfo *const token)
+{
+	skipToEndOfCmdline (token);
+}
+
+static bool isAbsoluteIdentifier(tokenInfo *const token)
+{
+	return !strncmp (tokenString (token), "::", 2);
+}
+
+static const char* getLastComponentInIdentifier(tokenInfo *const token)
+{
+	const char* s = tokenString (token);
+	char *last = strrstr(s, "::");
+
+	if (last)
+		return last + 2;
+	else
+		return NULL;
+}
+
+
+static void notifyNamespaceImport (tokenInfo *const token)
+{
+	subparser *sub;
+
+	foreachSubparser (sub, false)
+	{
+		tclSubparser *tclsub = (tclSubparser *)sub;
+
+		if (tclsub->namespaceImportNotify)
+		{
+			enterSubparser(sub);
+			tclsub->namespaceImportNotify (tclsub, tokenString (token),
+										   TCL_PSTATE(token));
+			leaveSubparser();
+		}
+	}
+}
+
+static int notifyCommand (tokenInfo *const token, int parent)
+{
+	subparser *sub;
+	int r = CORK_NIL;
+
+	foreachSubparser (sub, false)
+	{
+		tclSubparser *tclsub = (tclSubparser *)sub;
+
+		if (tclsub->commandNotify)
+		{
+			enterSubparser(sub);
+			r = tclsub->commandNotify (tclsub, tokenString (token), parent,
+									   TCL_PSTATE(token));
+			leaveSubparser();
+			if (r != CORK_NIL)
+				break;
+		}
+	}
+	return r;
+}
+
+static void collectSignature (const tokenInfo *const token, collector * col)
+{
+	if (tokenIsEOL (token))
+		return;
+
+	if (tokenIsType (token, TCL_IDENTIFIER) &&
+		(col->depth == 1
+		 || (col->depth == 2 && tokenIsType (token, TCL_IDENTIFIER)
+			 && vStringLast (col->str) == '{')))
+	{
+		tagEntryInfo e;
+		initTagEntry (&e, tokenString (token), K_PARAMETER);
+		e.extensionFields.scopeIndex = col->scopeIndex;
+		e.extensionFields.nth = col->nth++;
+		makeTagEntry (&e);
+	}
+	else if (tokenIsTypeVal (token, '{'))
+		col->depth++;
+	else if (tokenIsTypeVal (token, '}'))
+		col->depth--;
+
+	if ((vStringLength (col->str) > 0
+		 && vStringLast (col->str) != '{'
+		 && vStringLast (col->str) != '['
+		 && vStringLast (col->str) != '(')
+		&& (!tokenIsTypeVal (token, '}'))
+		&& (!tokenIsTypeVal (token, ']'))
+		&& (!tokenIsTypeVal (token, ')')))
+		vStringPut (col->str, ' ');
+	vStringCat (col->str, token->string);
+}
+
+static void parseProc (tokenInfo *const token,
+					   int parent)
+{
+	int index = CORK_NIL;
+	int index_fq = CORK_NIL;
+
+	tokenRead (token);
+
+	if (tokenIsType(token, TCL_IDENTIFIER))
+	{
+		const char *last = getLastComponentInIdentifier (token);
+		if (last)
+		{
+			tagEntryInfo e;
+
+			initTagEntry (&e, last, K_PROCEDURE);
+			e.lineNumber = token->lineNumber;
+			e.filePosition = token->filePosition;
+
+			int len  = (last - tokenString (token));
+			vString *ns = vStringNew();
+			tagEntryInfo *e_parent = getEntryInCorkQueue (parent);
+			if (isAbsoluteIdentifier (token))
+			{
+				if (len > 2)
+					vStringNCopy (ns, token->string, len - 2);
+			}
+			else if (e_parent)
+			{
+				const char * sep = scopeSeparatorFor (getInputLanguage(),
+													  K_PROCEDURE,
+													  e_parent->kindIndex);
+				vStringCatS(ns, e_parent->name);
+				vStringCatS(ns, sep);
+				vStringNCopy(ns, token->string, len - 2);
+			}
+			else
+				vStringNCopy (ns, token->string, len - 2);
+
+			if (vStringLength(ns) > 0)
+			{
+				e.extensionFields.scopeKindIndex = K_NAMESPACE;
+				e.extensionFields.scopeName = vStringValue (ns);
+			}
+
+			e.skipAutoFQEmission = 1;
+			index = makeTagEntry (&e);
+
+			if (isXtagEnabled(XTAG_QUALIFIED_TAGS))
+			{
+				const char * sep = scopeSeparatorFor (getInputLanguage(),
+													  K_PROCEDURE,
+													  vStringIsEmpty (ns)
+													  ? KIND_GHOST_INDEX
+													  : K_NAMESPACE);
+
+				vStringCatS (ns, sep);
+				vStringCatS (ns, last);
+
+				index_fq = makeSimpleTag (ns, K_PROCEDURE);
+				tagEntryInfo *e_fq = getEntryInCorkQueue (index_fq);
+				if (e_fq)
+					markTagExtraBit (e_fq, XTAG_QUALIFIED_TAGS);
+			}
+			vStringDelete (ns);
+		}
+		else
+		{
+			tagEntryInfo *ep;
+			index = makeSimpleTag (token->string, K_PROCEDURE);
+			ep = getEntryInCorkQueue (index);
+			if (ep)
+				ep->extensionFields.scopeIndex = parent;
+		}
+	}
+
+	vString *signature = NULL;
+	if (!tokenIsEOL (token))
+	{
+		tokenRead (token);
+		if (tokenIsType (token, TCL_IDENTIFIER))
+		{
+			tagEntryInfo e;
+			initTagEntry (&e, tokenString (token), K_PARAMETER);
+			e.extensionFields.scopeIndex = index;
+			makeTagEntry (&e);
+			signature = vStringNewCopy (token->string);
+		}
+		else if (token->type == '{')
+		{
+			signature = vStringNewInit ("{");
+			collector col = {
+				.proc = collectSignature,
+				.str = signature,
+				.depth = 1,
+				.scopeIndex = index,
+				.nth = 0,
+			};
+			tokenSkipOverPairFull (token, &col);
+		}
+
+		skipToEndOfCmdline(token);
+	}
+
+	tagEntryInfo *e = getEntryInCorkQueue (index);
+	if (e)
+	{
+		e->extensionFields.endLine = token->lineNumber;
+
+		if (signature)
+		{
+			e->extensionFields.signature = vStringDeleteUnwrap (signature);
+			signature = NULL;
+		}
+
+		tagEntryInfo *e_fq = getEntryInCorkQueue (index_fq);
+		if (e_fq)
+		{
+			const char *sig = e->extensionFields.signature;
+			e_fq->extensionFields.endLine = token->lineNumber;
+			if (sig)
+				e_fq->extensionFields.signature = eStrdup (sig);
+		}
+	}
+	vStringDelete (signature);	/* NULL is acceptable */
+}
+
+static void parseNamespace (tokenInfo *const token,
+							int parent)
+{
+	tokenRead (token);
+	if (tokenIsEOF(token))
+		return;
+
+	if (tokenIsType (token, TCL_IDENTIFIER) &&
+		(strcmp(tokenString(token), "import") == 0))
+	{
+		while (1)
+		{
+			tokenRead (token);
+
+			if (!tokenIsType (token, TCL_IDENTIFIER))
+				break;
+
+			if (tokenString(token)[0] == '-')
+				continue;
+
+			notifyNamespaceImport (token);
+		}
+		skipToEndOfCmdline(token);
+		return;
+	}
+	else if (!tokenIsKeyword (token, EVAL))
+		return;
+
+	tokenRead (token);
+	if (!tokenIsType (token, TCL_IDENTIFIER))
+	{
+		skipToEndOfCmdline(token);
+		return;
+	}
+
+	int index = makeSimpleTag (token->string, K_NAMESPACE);
+	tagEntryInfo *e = getEntryInCorkQueue (index);
+	if (e && parent != CORK_NIL && !isAbsoluteIdentifier(token))
+		e->extensionFields.scopeIndex = parent;
+
+	tokenRead (token);
+	if (token->type != '{')
+	{
+		skipToEndOfCmdline(token);
+		return;
+	}
+
+	do {
+		tokenRead (token);
+		if (tokenIsKeyword (token, NAMESPACE))
+			parseNamespace (token, index);
+		else if (tokenIsKeyword (token, PROC))
+			parseProc (token, index);
+		else if (tokenIsType (token, TCL_IDENTIFIER))
+		{
+			notifyCommand (token, index);
+			skipToEndOfCmdline(token); /* ??? */
+		}
+		else if (token->type == '}')
+		{
+			if (e)
+				e->extensionFields.endLine = token->lineNumber;
+			break;
+		}
+		else
+			skipToEndOfCmdline(token);
+	} while (!tokenIsEOF(token));
+}
+
+static void parsePackage (tokenInfo *const token)
+{
+	tokenRead (token);
+	if (tokenIsType (token, TCL_IDENTIFIER)
+		&& (strcmp (tokenString (token), "require") == 0))
+	{
+	next:
+		tokenRead (token);
+		if (tokenIsType (token, TCL_IDENTIFIER)
+			&& (vStringLength (token->string) > 0))
+		{
+			if (tokenString(token)[0] == '-')
+				goto next;
+		}
+	}
+	skipToEndOfCmdline(token);
+}
+
+
+static void findTclTags (void)
+{
+	struct sTclParserState pstate = {
+		.lastTokenType = TOKEN_TCL_UNDEFINED,
+	};
+	tokenInfo *const token = newTclToken (&pstate);
+
+	do {
+		tokenRead (token);
+		if (tokenIsKeyword (token, NAMESPACE))
+			parseNamespace (token, CORK_NIL);
+		else if (tokenIsKeyword (token, PROC))
+			parseProc (token, CORK_NIL);
+		else if (tokenIsKeyword (token, PACKAGE))
+			parsePackage (token);
+		else if (tokenIsType (token, TCL_IDENTIFIER))
+		{
+			notifyCommand (token, CORK_NIL);
+			skipToEndOfCmdline(token); /* ??? */
+		}
+		else
+			skipToEndOfCmdline(token);
+	} while (!tokenIsEOF(token));
+
+	tokenDelete (token);
+	flashTokenBacklog (&tclTokenInfoClass);
+}
+
+extern parserDefinition* TclParser (void)
+{
+	static const char *const extensions [] = { "tcl", "tk", "wish", "exp", NULL };
+	static const char *const aliases [] = {"expect", "tclsh", NULL };
+
+	parserDefinition* def = parserNew ("Tcl");
+	def->kindTable      = TclKinds;
+	def->kindCount  = ARRAY_SIZE (TclKinds);
+	def->extensions = extensions;
+	def->aliases = aliases;
+	def->keywordTable = TclKeywordTable;
+	def->keywordCount = ARRAY_SIZE (TclKeywordTable);
+
+	def->parser     = findTclTags;
+	def->useCork    = CORK_QUEUE;
+	def->requestAutomaticFQTag = true;
+	def->defaultScopeSeparator = "::";
+	def->defaultRootScopeSeparator = "::";
+
+	return def;
+}
Modified: ctags/parsers/tcl.h
51 lines changed, 51 insertions(+), 0 deletions(-)
===================================================================
@@ -0,0 +1,51 @@
+/*
+*   Copyright (c) 2017, Masatake YAMATO
+*
+*   This source code is released for free distribution under the terms of the
+*   GNU General Public License version 2 or (at your option) any later version.
+*/
+
+#ifndef CTAGS_PARSER_TCL_H
+#define CTAGS_PARSER_TCL_H
+
+/*
+*   INCLUDE FILES
+*/
+#include "general.h"  /* must always come first */
+
+#include "subparser.h"
+#include "tokeninfo.h"
+
+typedef struct sTclSubparser tclSubparser;
+
+enum TclTokenType {
+	/* 0..255 are the byte's value */
+	TOKEN_TCL_EOF = 256,
+	TOKEN_TCL_UNDEFINED,
+	TOKEN_TCL_KEYWORD,
+	TOKEN_TCL_IDENTIFIER,
+	TOKEN_TCL_VARIABLE,
+	TOKEN_TCL_EOL,
+	TOKEN_TCL_STRING,
+};
+
+struct sTclSubparser {
+	subparser subparser;
+
+	/* `pstate' is needed to call newTclToken(). */
+	void (* namespaceImportNotify) (tclSubparser *s, char *namespace,
+									void *pstate);
+	/* Return CORK_NIL if the command line is NOT consumed.
+	   If a positive integer is returned, end: field may
+	   be attached by tcl base parser.
+	   Return CORK_NIL - 1 if the command line is consumed
+	   but not tag is made. */
+	int (* commandNotify) (tclSubparser *s, char *command,
+						   int parentIndex,
+						   void *pstate);
+};
+
+extern tokenInfo *newTclToken (void *pstate);
+extern void skipToEndOfTclCmdline (tokenInfo *const token);
+
+#endif	/* CTAGS_PARSER_TCL_H */
Modified: ctags/parsers/tcloo.c
201 lines changed, 201 insertions(+), 0 deletions(-)
===================================================================
@@ -0,0 +1,201 @@
+/*
+*   Copyright (c) 2017, Masatake YAMATO
+*
+*   This source code is released for free distribution under the terms of the
+*   GNU General Public License version 2 or (at your option) any later version.
+*
+*/
+
+#include "general.h"  /* must always come first */
+#include "tcl.h"
+#include "param.h"
+#include "parse.h"
+#include "entry.h"
+#include "tokeninfo.h"
+
+#include <string.h>
+
+
+struct tclooSubparser {
+	tclSubparser tcl;
+	bool foundTclOONamespaceImported;
+};
+
+static scopeSeparator TclOOGenericSeparators [] = {
+	{ KIND_WILDCARD_INDEX, "::" },
+};
+
+enum TclOOKind {
+	K_CLASS,
+	K_METHOD,
+};
+
+static kindDefinition TclOOKinds[] = {
+	{ true, 'c', "class", "classes" },
+	{ true, 'm', "method", "methods",
+	  ATTACH_SEPARATORS(TclOOGenericSeparators) },
+};
+
+static bool tclooForceUse;
+
+static void parseMethod (tokenInfo *token, int owner)
+{
+	tokenRead (token);
+	if (tokenIsType (token, TCL_IDENTIFIER))
+	{
+		tagEntryInfo e;
+
+		initTagEntry(&e, tokenString (token), K_METHOD);
+		e.extensionFields.scopeIndex = owner;
+		makeTagEntry (&e);
+	}
+	skipToEndOfTclCmdline (token);
+}
+
+static void parseSuperclass (tokenInfo *token, int this_class)
+{
+	tokenRead (token);
+	if (tokenIsType (token, TCL_IDENTIFIER))
+	{
+		tagEntryInfo *e = getEntryInCorkQueue(this_class);
+
+		if (e)
+		{
+			if (e->extensionFields.inheritance)
+			{   /* superclass is used twice in a class. */
+				eFree ((void *)e->extensionFields.inheritance);
+			}
+			e->extensionFields.inheritance = eStrdup(tokenString(token));
+		}
+	}
+	skipToEndOfTclCmdline (token);
+}
+
+static int parseClass (tclSubparser *s CTAGS_ATTR_UNUSED, int parentIndex,
+					   void *pstate)
+{
+	tokenInfo *token = newTclToken (pstate);
+	int r = CORK_NIL;
+
+	tokenRead (token);
+	if (tokenIsType (token, TCL_IDENTIFIER)
+		&& (strcmp(tokenString(token), "create") == 0))
+	{
+		tokenRead (token);
+		if (tokenIsType (token, TCL_IDENTIFIER))
+		{
+			tagEntryInfo e;
+
+			initTagEntry(&e, tokenString (token), K_CLASS);
+			e.extensionFields.scopeIndex = parentIndex;
+			r = makeTagEntry (&e);
+		}
+
+		if (tokenSkipToType (token, '{'))
+		{
+			do {
+				tokenRead (token);
+				if (tokenIsType (token, TCL_IDENTIFIER)
+					|| tokenIsType (token, TCL_KEYWORD))
+				{
+					if (strcmp(tokenString(token), "method") == 0)
+						parseMethod(token, r);
+					else if (strcmp(tokenString(token), "superclass") == 0)
+						parseSuperclass(token, r);
+					else
+						skipToEndOfTclCmdline (token);
+				}
+				else if (token->type == '}')
+					break;
+			} while (!tokenIsEOF(token));
+		}
+	}
+
+	skipToEndOfTclCmdline (token);
+	tokenDelete(token);
+	return r;
+}
+
+static int commandNotify (tclSubparser *s, char *command,
+						  int parentIndex, void *pstate)
+{
+	struct tclooSubparser *tcloo = (struct tclooSubparser *)s;
+	int r = CORK_NIL;
+
+	if ((tcloo->foundTclOONamespaceImported
+		 && (strcmp (command, "class") == 0))
+		|| (strcmp (command, "oo::class") == 0))
+		r = parseClass (s, parentIndex, pstate);
+
+	return r;
+}
+
+static void namespaceImportNotify (tclSubparser *s, char *namespace,
+								   void *pstate CTAGS_ATTR_UNUSED)
+{
+	struct tclooSubparser *tcloo = (struct tclooSubparser *)s;
+
+	if (strcmp(namespace, "oo::*") == 0
+		|| strcmp(namespace, "oo::class") == 0)
+		tcloo->foundTclOONamespaceImported = true;
+}
+
+static void inputStart (subparser *s)
+{
+	struct tclooSubparser *tcloo = (struct tclooSubparser *)s;
+
+	tcloo->foundTclOONamespaceImported = tclooForceUse;
+}
+
+static struct tclooSubparser tclooSubparser = {
+	.tcl = {
+		.subparser = {
+			.direction = SUBPARSER_BI_DIRECTION,
+			.inputStart = inputStart,
+		},
+		.commandNotify = commandNotify,
+		.namespaceImportNotify = namespaceImportNotify,
+	},
+};
+
+static void findTclOOTags(void)
+{
+	scheduleRunningBaseparser (RUN_DEFAULT_SUBPARSERS);
+}
+
+static void tclooForceUseParamHandler (const langType language CTAGS_ATTR_UNUSED,
+									  const char *name, const char *arg)
+{
+	tclooForceUse = paramParserBool (arg, tclooForceUse, name, "parameter");
+}
+
+static parameterHandlerTable TclOOParameterHandlerTable [] = {
+	{ .name = "forceUse",
+	  .desc = "enable the parser even when `oo' namespace is not specified in the input (true or [false])" ,
+	  .handleParameter = tclooForceUseParamHandler,
+	},
+};
+
+extern parserDefinition* TclOOParser (void)
+{
+	parserDefinition* const def = parserNew("TclOO");
+
+	static parserDependency dependencies [] = {
+		[0] = { DEPTYPE_SUBPARSER, "Tcl", &tclooSubparser },
+	};
+
+	def->dependencies = dependencies;
+	def->dependencyCount = ARRAY_SIZE (dependencies);
+
+	def->kindTable = TclOOKinds;
+	def->kindCount = ARRAY_SIZE(TclOOKinds);
+
+	def->parser = findTclOOTags;
+	def->useCork = CORK_QUEUE;
+	def->requestAutomaticFQTag = true;
+
+	def->parameterHandlerTable = TclOOParameterHandlerTable;
+	def->parameterHandlerCount = ARRAY_SIZE(TclOOParameterHandlerTable);
+
+	return def;
+}
Modified: meson.build
4 lines changed, 3 insertions(+), 1 deletions(-)
===================================================================
@@ -638,7 +638,6 @@ ctags = static_library('ctags',
    'ctags/parsers/geany_lcpp.h',
    'ctags/parsers/geany_markdown.c',
    'ctags/parsers/geany_matlab.c',
-	'ctags/parsers/geany_tcl.c',
    'ctags/parsers/geany_tex.c',
    'ctags/parsers/geany_vhdl.c',
    'ctags/parsers/go.c',
@@ -668,6 +667,9 @@ ctags = static_library('ctags',
    'ctags/parsers/rust.c',
    'ctags/parsers/sh.c',
    'ctags/parsers/sql.c',
+	'ctags/parsers/tcl.c',
+	'ctags/parsers/tcl.h',
+	'ctags/parsers/tcloo.c',
    'ctags/parsers/txt2tags.c',
    'ctags/parsers/verilog.c',
    c_args: geany_cflags + [ '-DG_LOG_DOMAIN="CTags"',
Modified: src/filetypes.c
2 lines changed, 1 insertions(+), 1 deletions(-)
===================================================================
@@ -144,7 +144,7 @@ static void init_builtin_filetypes(void)
    FT_INIT( JS,         JAVASCRIPT,   "Javascript",       NULL,                      SOURCE_FILE, SCRIPT   );
    FT_INIT( PYTHON,     PYTHON,       "Python",           NULL,                      SOURCE_FILE, SCRIPT   );
    FT_INIT( RUBY,       RUBY,         "Ruby",             NULL,                      SOURCE_FILE, SCRIPT   );
-	FT_INIT( TCL,        TCL,          "Tcl",              NULL,                      SOURCE_FILE, SCRIPT   );
+	FT_INIT( TCL,        TCLOO,        "Tcl",              NULL,                      SOURCE_FILE, SCRIPT   );
    FT_INIT( LUA,        LUA,          "Lua",              NULL,                      SOURCE_FILE, SCRIPT   );
    FT_INIT( GDSCRIPT,   GDSCRIPT,     "GDScript",         NULL,                      SOURCE_FILE, SCRIPT   );
    FT_INIT( HASKELL,    HASKELL,      "Haskell",          NULL,                      SOURCE_FILE, COMPILED );
Modified: src/tagmanager/tm_parser.c
31 lines changed, 28 insertions(+), 3 deletions(-)
===================================================================
@@ -372,10 +372,9 @@ static TMParserMapGroup group_RUBY[] = {
 };
static TMParserMapEntry map_TCL[] = {
-	{'c', tm_tag_class_t},      // class
-	{'m', tm_tag_member_t},     // method
    {'p', tm_tag_function_t},   // procedure
-	{'n', tm_tag_namespace_t},  // module
+	{'n', tm_tag_namespace_t},  // namespace
+	{'z', tm_tag_undef_t},      // parameter
 };
 static TMParserMapGroup group_TCL[] = {
    {_("Namespaces"), TM_ICON_NAMESPACE, tm_tag_namespace_t},
@@ -384,6 +383,19 @@ static TMParserMapGroup group_TCL[] = {
    {_("Procedures"), TM_ICON_OTHER, tm_tag_function_t},
 };
+static TMParserMapEntry map_TCLOO[] = {
+	{'c', tm_tag_class_t},   // class
+	{'m', tm_tag_member_t},  // method
+};
+#define group_TCLOO group_TCL
+
+static TMSubparserMapEntry subparser_TCLOO_TCL_map[] = {
+	{tm_tag_namespace_t, tm_tag_namespace_t},
+	{tm_tag_class_t, tm_tag_class_t},
+	{tm_tag_member_t, tm_tag_member_t},
+	{tm_tag_function_t, tm_tag_function_t},
+};
+
 static TMParserMapEntry map_SH[] = {
    {'a', tm_tag_undef_t},     // alias
    {'f', tm_tag_function_t},  // function
@@ -1008,6 +1020,7 @@ static TMParserMap parser_map[] = {
    MAP_ENTRY(POWERSHELL),
    MAP_ENTRY(JULIA),
    MAP_ENTRY(CPREPROCESSOR),
+	MAP_ENTRY(TCLOO),
 };
 /* make sure the parser map is consistent and complete */
 G_STATIC_ASSERT(G_N_ELEMENTS(parser_map) == TM_PARSER_COUNT);
@@ -1110,6 +1123,7 @@ static void add_subparser(TMParserType lang, TMParserType sublang, TMSubparserMa
 static void init_subparser_map(void)
 {
    SUBPARSER_MAP_ENTRY(HTML, JAVASCRIPT, subparser_HTML_javascript_map);
+	SUBPARSER_MAP_ENTRY(TCLOO, TCL, subparser_TCLOO_TCL_map);
 }
@@ -1302,6 +1316,13 @@ gchar *tm_parser_update_scope(TMParserType lang, gchar *scope)
    		/* PHP parser uses two different scope separators but this would
    		 * complicate things in Geany so make sure there's just one type */
    		return replace_string_if_present(scope, "\", "::");
+		case TM_PARSER_TCL:
+		case TM_PARSER_TCLOO:
+			/* The TCL(OO) parser returns scope prefixed with :: which we don't
+			 * want. */
+			if (g_str_has_prefix(scope, "::"))
+				return g_strdup(scope + 2);
+			break;
    }
    return scope;
 }
@@ -1432,6 +1453,8 @@ const gchar *tm_parser_scope_separator(TMParserType lang)
    	case TM_PARSER_PHP:
    	case TM_PARSER_POWERSHELL:
    	case TM_PARSER_RUST:
+		case TM_PARSER_TCL:
+		case TM_PARSER_TCLOO:
    	case TM_PARSER_ZEPHIR:
    		return "::";
@@ -1492,6 +1515,8 @@ gboolean tm_parser_has_full_scope(TMParserType lang)
    	case TM_PARSER_RUBY:
    	case TM_PARSER_RUST:
    	case TM_PARSER_SQL:
+		case TM_PARSER_TCL:
+		case TM_PARSER_TCLOO:
    	case TM_PARSER_TXT2TAGS:
    	case TM_PARSER_VALA:
    	case TM_PARSER_VERILOG:
Modified: src/tagmanager/tm_parser.h
1 lines changed, 1 insertions(+), 0 deletions(-)
===================================================================
@@ -112,6 +112,7 @@ enum
    TM_PARSER_JULIA,
    TM_PARSER_BIBTEX,
    TM_PARSER_CPREPROCESSOR,
+	TM_PARSER_TCLOO,
    TM_PARSER_COUNT
 };
Modified: src/tagmanager/tm_parsers.h
3 lines changed, 2 insertions(+), 1 deletions(-)
===================================================================
@@ -67,6 +67,7 @@
    PowerShellParser, \
    JuliaParser, \
    BibtexParser, \
-	CPreProParser
+	CPreProParser, \
+	TclOOParser
#endif
Modified: tests/ctags/simple.tcl
59 lines changed, 52 insertions(+), 7 deletions(-)
===================================================================
@@ -1,10 +1,55 @@
-# proc comment
-proc simple1
+oo::class create X {
+    superclass Y;
-class tcl_class
+    method add v {
+    }; method doSomething {v} {
+    }
+}
-itcl::class itcl_class
+class create ShouldNotBeCaptured {
+}
-public method method1
-protected method method2
-private method method3
+proc simple1 {} {
+}
+
+namespace eval A::B {
+}
+
+namespace eval A {
+    proc pr1 {s} {
+	puts $s
+    }
+    pr1 "a"
+    proc B::pr2 {s} {
+	puts "$s"
+    }
+    namespace eval C {
+	proc pr3 {s} {
+	    puts $s
+	}
+    }
+    proc ::pr4 {s} {
+	puts "$s"
+    }
+
+}
+
+proc ::pr5 {s} {
+    puts "$s"
+}
+
+proc pr6 {s} {
+    puts "$s"
+}
+
+A::pr1 "b"
+
+A::B::pr2 "c"
+
+A::C::pr3 "d"
+
+pr4 "e"
+
+pr5 "f"
+
+pr6 "g"
Modified: tests/ctags/simple.tcl.tags
19 lines changed, 13 insertions(+), 6 deletions(-)
===================================================================
@@ -1,7 +1,14 @@
 # format=tagmanager
-itcl_class�1�0
-method1�64�0
-method2�64�0
-method3�64�0
-simple1�16�0
-tcl_class�1�0
+A�256�0
+A::B�256�0
+C�256�A�0
+X�1�0
+add�64�X�0
+doSomething�64�X�0
+pr1�16�{s}�A�0
+pr2�16�{s}�B�0
+pr3�16�{s}�A::C�0
+pr4�16�{s}�0
+pr5�16�{s}�0
+pr6�16�{s}�0
+simple1�16�{}�0
--------------
This E-Mail was brought to you by github_commit_mail.py (Source: https://github.com/geany/infrastructure).

    