Tcl: support switch command (2984dad8) · Commits · Elphel / doxverilog

src/tclscanner.l

+182 −1

Original line number	Original line	Diff line number	Diff line
	@@ -1836,6 +1836,181 @@ D
	myScan->ns, myScan->entry_cl, myScan->entry_fn);		myScan->ns, myScan->entry_cl, myScan->entry_fn);
	}		}

			//! Handle internal tcl commands.
			// switch ?options? string pattern body ?pattern body ...?
			// switch ?options? string {pattern body ?pattern body ...?}
			static void tcl_command_SWITCH()
			{
			D
			tcl_codify_cmd("keyword",0);
			tcl_codify_cmd(NULL,1);
			tcl_scan *myScan=NULL;
			unsigned int i;
			QCString token;
			// first: find the last option token
			unsigned int lastOptionIndex = 0;
			for (i = 2; i<tcl.list_commandwords.count(); i += 2)
			{
			token = (*tcl.list_commandwords.at(i)).utf8();
			if (token == "--")
			{
			lastOptionIndex = i;
			break;
			}
			if (token[0] == '-' && i - lastOptionIndex == 2)
			{
			// options start with dash and should form a continuous chain
			lastOptionIndex = i;
			}
			}
			// second: eat up options
			for (i = 2; i <= lastOptionIndex; i++)
			{
			myScan = tcl_command_ARG(myScan, i, false);
			}
			// third: how many tokens are left?
			if (tcl.list_commandwords.count() - lastOptionIndex == 5)
			{
			//printf("syntax: switch ?options? string {pattern body ?pattern body ...?}\n");
			myScan = tcl_command_ARG(myScan, lastOptionIndex + 1, false);
			myScan = tcl_command_ARG(myScan, lastOptionIndex + 2, false);
			myScan = tcl_command_ARG(myScan, lastOptionIndex + 3, false);
			// walk trough the list step by step
			// this way we can preserve whitespace
			bool inBraces = false;
			bool nextIsPattern = true;
			int size;
			const char *elem;
			const char *next;
			token = (*tcl.list_commandwords.at(lastOptionIndex + 4)).utf8();
			if (token[0] == '{')
			{
			inBraces = true;
			token = token.mid(1, token.length() - 2);
			if (myScan!=NULL)
			{
			myScan->after << "NULL" << QCString("{");
			}
			else
			{
			tcl_codify(NULL,QCString("{"));
			}
			}
			// ToDo: check if multibyte chars are handled correctly
			while (token.length() > 0)
			{
			TclFindElement((const char*)token, token.length(), &elem, &next, &size, NULL);
			//printf("%s\nstart=%d, elem=%d, next=%d, size=%d, brace=%d\n",
			// (const char) token, (const char) token, elem, next, size, brace);
			//
			// handle leading whitespace/opening brace/double quotes
			if (elem - token > 0)
			{
			if (myScan != NULL)
			{
			myScan->after << "NULL" << token.left(elem - token);
			}
			else
			{
			tcl_codify(NULL, token.left(elem - token));
			}
			}
			// handle actual element without braces/double quotes
			if (nextIsPattern)
			{
			if (myScan != NULL)
			{
			myScan->after << "NULL" << token.mid(elem - token,size);
			}
			else
			{
			tcl_codify(NULL,token.mid(elem - token, size));
			}
			//printf("pattern=%s\n",(const char*) token.mid(elem - token, size));
			}
			else {
			if (myScan != NULL)
			{
			myScan->after << "script" << token.mid(elem - token, size);
			}
			else
			{
			myScan = tcl.scan.at(0);
			myScan = tcl_scan_start('?', token.mid(elem - token, size),
			myScan->ns, myScan->entry_cl, myScan->entry_fn);
			}
			//printf("script =%s\n", (const char*) token.mid(elem - token, size));
			}
			// handle trailing whitespace/closing brace/double quotes
			if (next - elem - size > 0)
			{
			if (myScan != NULL)
			{
			myScan->after << "NULL" << token.mid(elem - token + size, next - elem - size);
			}
			else
			{
			tcl_codify(NULL, token.mid(elem - token + size, next - elem - size));
			}
			}
			nextIsPattern = !nextIsPattern;
			token = token.mid(next - token);
			}
			if (inBraces)
			{
			if (myScan != NULL)
			{
			myScan->after << "NULL" << QCString("}");
			}
			else
			{
			tcl_codify(NULL, QCString("}"));
			}
			}
			if (!nextIsPattern)
			{
			tcl_war("Invalid switch syntax: last token is not a list of even elements.\n");
			//tcl_war("%s\n", tcl.list_commandwords.join(" ").ascii());
			}
			}
			else if ((tcl.list_commandwords.count() - lastOptionIndex > 6) &&
			((tcl.list_commandwords.count() - lastOptionIndex-3) % 4 == 0))
			{
			//printf("detected: switch ?options? string pattern body ?pattern body ...?\n");
			myScan = tcl_command_ARG(myScan, lastOptionIndex + 1, false);
			myScan = tcl_command_ARG(myScan, lastOptionIndex + 2, false);
			//printf("value=%s\n",(const char) (tcl.list_commandwords.at(lastOptionIndex + 2)).utf8());
			for (i = lastOptionIndex + 3; i < tcl.list_commandwords.count(); i += 4)
			{
			myScan = tcl_command_ARG(myScan, i + 0, false); // whitespace
			myScan = tcl_command_ARG(myScan, i + 1, false); // pattern
			myScan = tcl_command_ARG(myScan, i + 2, false); // whitespace
			if (myScan != NULL) // script
			{
			myScan->after << "script" << tcl.list_commandwords[i+3];
			}
			else
			{
			myScan = tcl.scan.at(0);
			myScan = tcl_scan_start('?', *tcl.list_commandwords.at(i+3),
			myScan->ns, myScan->entry_cl, myScan->entry_fn);
			}
			//printf("pattern=%s\n",(const char) (tcl.list_commandwords.at(i+1)).utf8());
			//printf("script=%s\n",(const char) (tcl.list_commandwords.at(i+3)).utf8());
			}
			}
			else
			{
			// not properly detected syntax
			tcl_war("Invalid switch syntax: %d options followed by %d tokens.\n",
			lastOptionIndex / 2, (tcl.list_commandwords.count() - 1) / 2 - lastOptionIndex / 2);
			for (i = lastOptionIndex + 1; i <= tcl.list_commandwords.count(); i++)
			{
			myScan = tcl_command_ARG(myScan, i, false);
			}
			}
			}

	//! Handle internal tcl commands.		//! Handle internal tcl commands.
	// "catch script ?resultVarName? ?optionsVarName?"		// "catch script ?resultVarName? ?optionsVarName?"
	static void tcl_command_CATCH()		static void tcl_command_CATCH()
	@@ -2494,8 +2669,14 @@ tcl_inf("->\n");
	}		}
	/*		/*
	* Start of internal tcl keywords		* Start of internal tcl keywords
	* Ready: eval, catch, if, for, foreach, while		* Ready: switch, eval, catch, if, for, foreach, while
	*/		*/
			if (myStr=="switch")
			{
			if (tcl.list_commandwords.count() < 5) {myLine=__LINE__;goto command_warn;}
			tcl_command_SWITCH();
			goto command_end;
			}
	if (myStr=="eval")		if (myStr=="eval")
	{		{
	if (tcl.list_commandwords.count() < 3) {myLine=__LINE__;goto command_warn;}		if (tcl.list_commandwords.count() < 3) {myLine=__LINE__;goto command_warn;}

testing/060/060commandswitch_8tcl.xml

0 → 100644

+358 −0

File added.

Preview size limit exceeded, changes collapsed.

testing/060_command_switch.tcl

0 → 100644

+238 −0

Original line number	Original line	Diff line number	Diff line
			#// objective: tests processing of switch, only references/referencedby relations are relevant
			#// check: 060__command__switch_8tcl.xml
			#// config: REFERENCED_BY_RELATION = yes
			#// config: REFERENCES_RELATION = yes
			#// config: EXTRACT_ALL = yes
			#// config: INLINE_SOURCES = no

			##
			# \brief should be reference by every proc below
			proc Invoked args {
			puts "Procedure \"Invoked\" is invoked indeed. Ok."
			return $args
			}
			##
			# \brief must not be reference by every proc below
			proc NotInvoked args {
			puts "Procedure \"NotInvoked\" is invoked. Not Ok!"
			return $args
			}
			#
			# check if call references work at all
			proc a args {
			Invoked NotInvoked
			return
			}
			#
			# switch command
			# switch ?options? string pattern body ?pattern body ...?
			proc b args {
			switch value NotInvoked {
			} NotInvoked {
			} default {
			Invoked
			}
			return
			}
			proc c args {
			switch value NotInvoked {
			} [Invoked] {
			} default {
			}
			return
			}
			proc d args {
			switch NotInvoked pattern {
			} [Invoked] {
			} default {
			}
			return
			}
			proc e args {
			switch [Invoked] pattern {
			} NotInvoked {
			} default {
			}
			return
			}
			proc f args {
			switch -exact value pattern {
			} NotInvoked {
			} default {
			Invoked
			}
			return
			}
			proc g args {
			switch -exact -- value pattern {
			} NotInvoked {
			} default {
			Invoked
			}
			return
			}
			proc h args {
			switch -exact -- -value pattern {
			} NotInvoked {
			} default {
			Invoked
			}
			return
			}
			# switch ?options? string {pattern body ?pattern body ...?}
			proc i args {
			switch value {
			NotInvoked {
			}
			NotInvoked {
			}
			default {
			Invoked
			}
			}
			return
			}
			proc j args {
			switch vale {
			NotInvoked {
			}
			[NotInvoked] {
			}
			default {
			Invoked
			}
			}
			return
			}
			proc k args {
			switch NotInvoked {
			[NotInvoked] {
			}
			NotInvoked {
			Invoked
			}
			default {
			}
			}
			return
			}
			proc l args {
			switch [Invoked] {
			pattern {
			}
			NotInvoked {
			}
			default {
			}
			}
			return
			}
			proc m args {
			switch -exact value {
			pattern {
			}
			NotInvoked {
			}
			default {
			Invoked
			}
			}
			return
			}
			proc n args {
			switch -exact -- value {
			pattern {
			}
			NotInvoked {
			}
			default {
			Invoked
			}
			}
			return
			}
			proc o args {
			switch -exact -- -value {
			pattern {
			}
			NotInvoked {
			}
			default {
			Invoked
			}
			}
			return
			}
			proc p args {
			switch -exact -- inquotes {
			"inquotes" {
			Invoked
			}
			default {
			}
			}
			return
			}
			proc q args {
			switch -exact -- "in quotes" {
			"in quotes" {
			Invoked
			}
			default {
			}
			}
			return
			}
			proc r args {
			switch -exact -- inbraces {
			{inbraces} {
			Invoked
			}
			default {
			}
			}
			return
			}
			proc s args {
			switch -exact -- {in braces} {
			{in braces} {
			Invoked
			}
			default {
			}
			}
			return
			}
			# wrong syntax
			proc x args {
			catch {switch -exact -- [Invoked] pattern1 NotInvoked pattern2}
			return
			}
			# The current version does not check the last argument beforehand.
			# Therefore, all script elements are evaluated as scripts before
			# the parser detects the dangling pattern. It throws a warning, at the very least.
			# Anyway, for working code the documentation will be correct.
			proc y args {
			catch {switch -exact -- [Invoked] {
			pattern {
			NotInvoked
			}
			NotInvoked {
			NotInvoked
			}
			default {
			NotInvoked
			}
			pattern
			}}
			return
			}
			#
			# call all single letter procs
			# let tcl check what is called and what is not called
			foreach p [info procs ?] {
			puts "Check procedure \"$p\""
			$p
			}
			exit

Admin message