Scheme: rewrite as a x-lisp based parser

Signed-off-by: Masatake YAMATO <[email protected]>

Tmain/list-fields-with-prefix.d/stdout-expected.txt

@@ -48,6 +48,7 @@ x       UCTAGSxpath          no      NONE             s--    no    -- xpath for
 -       UCTAGSoverline       no      ReStructuredText --b    no    -- whether using overline & underline for declaring section
 -       UCTAGSsectionMarker  no      ReStructuredText s--    no    -- character used for declaring section
 -       UCTAGSmixin          yes     Ruby             s--    no    -- how the class or module is mixed in (mixin:HOW:MODULE)
+-       UCTAGSdefiner        yes     Scheme           s--    no    -- the name of the function or macro that defines the unknown/Y-kind object
 -       UCTAGSparameter      no      SystemVerilog    --b    no    -- parameter whose value can be overridden.
 -       UCTAGStarget         yes     Thrift           s--    no    -- the target language specified at "namespace"
 -       UCTAGSthrows         yes     Thrift           s--    no    -- throws list of function

Tmain/list-fields.d/stdout-expected.txt

@@ -66,6 +66,7 @@ z	kind	no	NONE	s--	no	r-	[tags output] prepend "kind:" to k/ (or K/) field outpu
 -	overline	no	ReStructuredText	--b	no	--	whether using overline & underline for declaring section
 -	sectionMarker	no	ReStructuredText	s--	no	--	character used for declaring section
 -	mixin	yes	Ruby	s--	no	--	how the class or module is mixed in (mixin:HOW:MODULE)
+-	definer	yes	Scheme	s--	no	--	the name of the function or macro that defines the unknown/Y-kind object
 -	parameter	no	SystemVerilog	--b	no	--	parameter whose value can be overridden.
 -	target	yes	Thrift	s--	no	--	the target language specified at "namespace"
 -	throws	yes	Thrift	s--	no	--	throws list of function

Units/option-regex-attaching-role.r/extending-existing-parser.d/expected.tags

@@ -1,4 +1,4 @@
-foo	input.scm	/^(define-module foo$/;"	function	language:Scheme	roles:def
+foo	input.scm	/^(define-module foo$/;"	unknown	language:Scheme	roles:def	definer:DEFINE-MODULE
 foobar	input.scm	/^(define (foobar)$/;"	function	language:Scheme	roles:def
 foo	input.scm	/^(define-module foo$/;"	module	language:myGauche	roles:def
 bar	input.scm	/^  (use bar)$/;"	module	language:myGauche	scope:module:foo	roles:used

parsers/lisp.c

@@ -134,7 +134,7 @@ static kindDefinition EmacsLispKinds [] = {
  * lisp tag functions
  *  look for (def or (DEF, quote or QUOTE
  */
-static bool lisp_is_def (struct lispDialect *dialect, const unsigned char *strp)
+bool lispIsDef (struct lispDialect *dialect, const unsigned char *strp)
 {
 	bool cis = dialect->case_insensitive; /* Renaming for making code short */
 	bool is_def = ( (strp [1] == 'd' || (cis && strp [1] == 'D'))
@@ -478,7 +478,7 @@ static void findLispTags (void)
 		.definer_field = LispFields + F_DEFINER,
 		.skip_initial_spaces = false,
 		.lambda_syntax_sugar = false,
-		.is_def = lisp_is_def,
+		.is_def = lispIsDef,
 		.get_it = lispGetIt,
 		.scope = CORK_NIL,
 	};
@@ -496,7 +496,7 @@ static void findEmacsLispTags (void)
 		.definer_field = EmacsLispFields + eF_DEFINER,
 		.skip_initial_spaces = false,
 		.lambda_syntax_sugar = false,
-		.is_def = lisp_is_def,
+		.is_def = lispIsDef,
 		.get_it = lispGetIt,
 		.scope = CORK_NIL,
 	};

parsers/scheme.c

@@ -13,21 +13,34 @@
 */
 #include "general.h"  /* must always come first */
 
-#include <string.h>
-
+#include "entry.h"
 #include "parse.h"
-#include "read.h"
-#include "routines.h"
-#include "vstring.h"
+
+#include "x-lisp.h"
+
+#include <ctype.h>
+#include <string.h>
 
 /*
 *   DATA DEFINITIONS
 */
 typedef enum {
+	K_UNKNOWN,
 	K_FUNCTION, K_SET
 } schemeKind;
 
+typedef enum {
+	F_DEFINER,
+} schemeField;
+
+static fieldDefinition SchemeFields[] = {
+	{ .name = "definer",
+	  .description = "the name of the function or macro that defines the unknown/Y-kind object",
+	  .enabled = true },
+};
+
 static kindDefinition SchemeKinds [] = {
+	{ true, 'Y', "unknown", "unknown type of definitions" },
 	{ true, 'f', "function", "functions" },
 	{ true, 's', "set",      "sets" }
 };
@@ -36,76 +49,60 @@ static kindDefinition SchemeKinds [] = {
 *   FUNCTION DEFINITIONS
 */
 
-/* Algorithm adapted from from GNU etags.
- * Scheme tag functions
- * look for (def... xyzzy
- * look for (def... (xyzzy
- * look for (def ... ((... (xyzzy ....
- * look for (set! xyzzy
- */
-static void readIdentifier (vString *const name, const unsigned char *cp)
+/*
+*   FUNCTION DEFINITIONS
+*/
+static bool scheme_is_def (struct lispDialect *dialect, const unsigned char *strp)
 {
-	const unsigned char *p;
-	vStringClear (name);
-	/* Go till you get to white space or a syntactic break */
-	for (p = cp; *p != '\0' && *p != '(' && *p != ')' && !isspace (*p); p++)
-		vStringPut (name, *p);
+	bool cis = dialect->case_insensitive; /* Renaming for making code short */
+
+	bool is_set = ( (strp [1] == 's' || (cis && strp [1] == 'S'))
+					&& (strp [2] == 'e' || (cis && strp [2] == 'E'))
+					&& (strp [3] == 't' || (cis && strp [3] == 'T'))
+					&& (strp [4] == '!'));
+	if (is_set)
+		return true;
+
+	return lispIsDef (dialect, strp);
 }
 
-static void findSchemeTags (void)
+static int  scheme_hint2kind (const vString *const hint, const char *namespace CTAGS_ATTR_UNUSED)
 {
-	vString *name = vStringNew ();
-	const unsigned char *line;
+	int k = K_UNKNOWN;
+	int n = vStringLength (hint) - 4;
 
-	while ((line = readLineFromInputFile ()) != NULL)
+	if (strncmp (vStringValue (hint) + 1, "SET!", 4) == 0)
+		return K_SET;
+
+	/* 4 means strlen("(def"). */
+#define EQN(X) strncmp(vStringValue (hint) + 4, &X[3], n) == 0
+	switch (n)
 	{
-		const unsigned char *cp = line;
-
-		if (cp [0] == '(' &&
-			(cp [1] == 'D' || cp [1] == 'd') &&
-			(cp [2] == 'E' || cp [2] == 'e') &&
-			(cp [3] == 'F' || cp [3] == 'f'))
-		{
-			while (*cp != '\0'  &&  !isspace (*cp))
-				cp++;
-			/* Skip over open parens and white space */
-			do {
-				while (*cp != '\0' && (isspace (*cp) || *cp == '('))
-					cp++;
-				if (*cp == '\0')
-					cp = line = readLineFromInputFile ();
-				else
-					break;
-			} while (line);
-			if (line == NULL)
-				break;
-			readIdentifier (name, cp);
-			makeSimpleTag (name, K_FUNCTION);
-		}
-		if (cp [0] == '(' &&
-			(cp [1] == 'S' || cp [1] == 's') &&
-			(cp [2] == 'E' || cp [2] == 'e') &&
-			(cp [3] == 'T' || cp [3] == 't') &&
-			(cp [4] == '!') &&
-			(isspace (cp [5]) || cp[5] == '\0'))
-		{
-			cp += 5;
-			/* Skip over white space */
-			do {
-				while (*cp != '\0' && isspace (*cp))
-					cp++;
-				if (*cp == '\0')
-					cp = line = readLineFromInputFile ();
-				else
-					break;
-			} while (line);
-			if (line == NULL)
-				break;
-			readIdentifier (name, cp);
-			makeSimpleTag (name, K_SET);
-		}
+	case 3:
+		if (EQN("DEFINE"))
+			k = K_FUNCTION;
+		break;
+
 	}
-	vStringDelete (name);
+	return k;
+}
+
+static void findSchemeTags (void)
+{
+	struct lispDialect scheme_dialect = {
+		.definer2kind = scheme_hint2kind,
+		.case_insensitive = true,
+		.namespace_sep = 0,
+		.unknown_kind = K_UNKNOWN,
+		.definer_field = SchemeFields + F_DEFINER,
+		.skip_initial_spaces = false,
+		.lambda_syntax_sugar = true,
+		.is_def = scheme_is_def,
+		.get_it = lispGetIt,
+		.scope = CORK_NIL,
+	};
+
+	findLispTagsCommon (&scheme_dialect);
 }
 
 extern parserDefinition* SchemeParser (void)
@@ -119,8 +116,11 @@ extern parserDefinition* SchemeParser (void)
 	parserDefinition* def = parserNew ("Scheme");
 	def->kindTable      = SchemeKinds;
 	def->kindCount  = ARRAY_SIZE (SchemeKinds);
+	def->fieldTable = SchemeFields;
+	def->fieldCount = ARRAY_SIZE (SchemeFields);
 	def->extensions = extensions;
 	def->aliases    = aliases;
 	def->parser     = findSchemeTags;
+	def->useCork = CORK_QUEUE;
 	return def;
 }

parsers/x-lisp.h

@@ -34,5 +34,6 @@ void findLispTagsCommon (struct lispDialect *dialect);
 int lispGetIt (struct lispDialect *dialect,
 			   vString *const name, const unsigned char *dbp, vString *kind_hint,
 			   const char *namespace);
+bool lispIsDef (struct lispDialect *dialect, const unsigned char *strp);
 
 #endif	/* CTAGS_LISP_H */