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

src/tclscanner.l

+182 −1

Original line number	Diff line number	Diff line
		@@ -1836,6 +1836,181 @@ D
		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.
		// "catch script ?resultVarName? ?optionsVarName?"
		static void tcl_command_CATCH()
		@@ -2494,8 +2669,14 @@ tcl_inf("->\n");
		}
		/*
		* 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 (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	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