XS: new parrser

Signed-off-by: Masatake YAMATO <[email protected]>
universal-ctags · Dec 13, 2022 · ce2c144 · ce2c144
1 parent c62933e
commit ce2c144
Show file tree

Hide file tree

Showing 8 changed files with 355 additions and 1 deletion.
diff --git a/Units/parser-xs.r/simple-xs.d/args.ctags b/Units/parser-xs.r/simple-xs.d/args.ctags
@@ -0,0 +1,2 @@
+--sort=no
+--extras=+g
diff --git a/Units/parser-xs.r/simple-xs.d/expected.tags b/Units/parser-xs.r/simple-xs.d/expected.tags
@@ -0,0 +1,48 @@
+SDBM_File	input.xs	/^MODULE = SDBM_File	PACKAGE = SDBM_File	PREFIX = sdbm_$/;"	m
+SDBM_File	input.xs	/^MODULE = SDBM_File	PACKAGE = SDBM_File	PREFIX = sdbm_$/;"	p	module:SDBM_File
+sdbm_TIEHASH	input.xs	/^sdbm_TIEHASH(dbtype, filename, flags, mode, pagname=NULL)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:SDBM_File
+TIEHASH	input.xs	/^sdbm_TIEHASH(dbtype, filename, flags, mode, pagname=NULL)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:SDBM_File
+sdbm_DESTROY	input.xs	/^sdbm_DESTROY(db)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:void
+DESTROY	input.xs	/^sdbm_DESTROY(db)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:void
+sdbm_FETCH	input.xs	/^sdbm_FETCH(db, key)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:datum_value
+FETCH	input.xs	/^sdbm_FETCH(db, key)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:datum_value
+sdbm_STORE	input.xs	/^sdbm_STORE(db, key, value, flags = DBM_REPLACE)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:int
+STORE	input.xs	/^sdbm_STORE(db, key, value, flags = DBM_REPLACE)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:int
+sdbm_DELETE	input.xs	/^sdbm_DELETE(db, key)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:int
+DELETE	input.xs	/^sdbm_DELETE(db, key)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:int
+sdbm_EXISTS	input.xs	/^sdbm_EXISTS(db,key)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:int
+EXISTS	input.xs	/^sdbm_EXISTS(db,key)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:int
+sdbm_FIRSTKEY	input.xs	/^sdbm_FIRSTKEY(db)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:datum_key
+FIRSTKEY	input.xs	/^sdbm_FIRSTKEY(db)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:datum_key
+sdbm_NEXTKEY	input.xs	/^sdbm_NEXTKEY(db, key)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:datum_key
+NEXTKEY	input.xs	/^sdbm_NEXTKEY(db, key)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:datum_key
+sdbm_error	input.xs	/^sdbm_error(db)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:int
+error	input.xs	/^sdbm_error(db)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:int
+filter_fetch_key	input.xs	/^filter_fetch_key(db, code)$/;"	f	package:SDBM_File.SDBM_File	typeref:typename:SV *
+SDBM_File	input.xs	/^MODULE = SDBM_File	PACKAGE = SDBM_X	PREFIX = sdbm_X_$/;"	m
+SDBM_X	input.xs	/^MODULE = SDBM_File	PACKAGE = SDBM_X	PREFIX = sdbm_X_$/;"	p	module:SDBM_File
+sdbm_X_DELETE0	input.xs	/^sdbm_X_DELETE0(db, key)$/;"	f	package:SDBM_File.SDBM_X	typeref:typename:int
+DELETE0	input.xs	/^sdbm_X_DELETE0(db, key)$/;"	f	package:SDBM_File.SDBM_X	typeref:typename:int
+sdbm_X_DELETE1	input.xs	/^sdbm_X_DELETE1(db, key)$/;"	f	package:SDBM_File.SDBM_X	typeref:typename:int
+DELETE1	input.xs	/^sdbm_X_DELETE1(db, key)$/;"	f	package:SDBM_File.SDBM_X	typeref:typename:int
+PERL_NO_GET_CONTEXT	input.xs	/^#define PERL_NO_GET_CONTEXT$/;"	d	file:
+fetch_key	input.xs	/^#define fetch_key /;"	d	file:
+store_key	input.xs	/^#define store_key /;"	d	file:
+fetch_value	input.xs	/^#define fetch_value /;"	d	file:
+store_value	input.xs	/^#define store_value /;"	d	file:
+__anoned1397e40108	input.xs	/^typedef struct {$/;"	s	file:
+dbp	input.xs	/^	DBM *	dbp ;$/;"	m	struct:__anoned1397e40108	typeref:typename:DBM *	file:
+filter	input.xs	/^	SV *    filter[4];$/;"	m	struct:__anoned1397e40108	typeref:typename:SV * [4]	file:
+filtering	input.xs	/^	int     filtering ;$/;"	m	struct:__anoned1397e40108	typeref:typename:int	file:
+SDBM_File_type	input.xs	/^	} SDBM_File_type;$/;"	t	typeref:struct:__anoned1397e40108	file:
+SDBM_File	input.xs	/^typedef SDBM_File_type * SDBM_File ;$/;"	t	typeref:typename:SDBM_File_type *	file:
+datum_key	input.xs	/^typedef datum datum_key ;$/;"	t	typeref:typename:datum	file:
+datum_value	input.xs	/^typedef datum datum_value ;$/;"	t	typeref:typename:datum	file:
+sdbm_FETCH	input.xs	/^#define sdbm_FETCH(/;"	d	file:
+sdbm_STORE	input.xs	/^#define sdbm_STORE(/;"	d	file:
+sdbm_DELETE	input.xs	/^#define sdbm_DELETE(/;"	d	file:
+sdbm_EXISTS	input.xs	/^#define sdbm_EXISTS(/;"	d	file:
+sdbm_FIRSTKEY	input.xs	/^#define sdbm_FIRSTKEY(/;"	d	file:
+sdbm_NEXTKEY	input.xs	/^#define sdbm_NEXTKEY(/;"	d	file:
+X	input.xs	/^#define X "X"/;"	d	file:
+Y	input.xs	/^#define Y "Y"/;"	d	file:
diff --git a/Units/parser-xs.r/simple-xs.d/features b/Units/parser-xs.r/simple-xs.d/features
@@ -0,0 +1 @@
+pcre2
diff --git a/Units/parser-xs.r/simple-xs.d/input.xs b/Units/parser-xs.r/simple-xs.d/input.xs
@@ -0,0 +1,159 @@
+/* Derrive from perl5/ext/SDBM_File/SDBM_File.xs */
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "sdbm.h"
+
+#define fetch_key 0
+#define store_key 1
+#define fetch_value 2
+#define store_value 3
+
+typedef struct {
+	DBM *	dbp ;
+	SV *    filter[4];
+	int     filtering ;
+	} SDBM_File_type;
+
+typedef SDBM_File_type * SDBM_File ;
+typedef datum datum_key ;
+typedef datum datum_value ;
+
+#define sdbm_FETCH(db,key)			sdbm_fetch(db->dbp,key)
+#define sdbm_STORE(db,key,value,flags)		sdbm_store(db->dbp,key,value,flags)
+#define sdbm_DELETE(db,key)			sdbm_delete(db->dbp,key)
+#define sdbm_EXISTS(db,key)			sdbm_exists(db->dbp,key)
+#define sdbm_FIRSTKEY(db)			sdbm_firstkey(db->dbp)
+#define sdbm_NEXTKEY(db,key)			sdbm_nextkey(db->dbp)
+
+
+MODULE = SDBM_File	PACKAGE = SDBM_File	PREFIX = sdbm_
+
+PROTOTYPES: DISABLE
+
+SDBM_File
+sdbm_TIEHASH(dbtype, filename, flags, mode, pagname=NULL)
+	char *		dbtype
+	char *		filename
+	int		flags
+	int		mode
+	char *		pagname
+	CODE:
+	{
+	    DBM *	dbp ;
+
+	    RETVAL = NULL ;
+	    if (pagname == NULL) {
+		dbp = sdbm_open(filename, flags, mode);
+	    }
+	    else {
+		dbp = sdbm_prep(filename, pagname, flags, mode);
+	    }
+	    if (dbp) {
+		RETVAL = (SDBM_File)safecalloc(1, sizeof(SDBM_File_type));
+		RETVAL->dbp = dbp ;
+	    }
+
+	}
+	OUTPUT:
+	  RETVAL
+
+void
+sdbm_DESTROY(db)
+	SDBM_File	db
+	CODE:
+	if (db) {
+	    int i = store_value;
+	    sdbm_close(db->dbp);
+	    do {
+		if (db->filter[i])
+		    SvREFCNT_dec_NN(db->filter[i]);
+	    } while (i-- > 0);
+	    safefree(db) ;
+	}
+
+datum_value
+sdbm_FETCH(db, key)
+	SDBM_File	db
+	datum_key	key
+
+int
+sdbm_STORE(db, key, value, flags = DBM_REPLACE)
+	SDBM_File	db
+	datum_key	key
+	datum_value	value
+	int		flags
+    CLEANUP:
+	if (RETVAL) {
+	    if (RETVAL < 0 && errno == EPERM)
+		croak("No write permission to sdbm file");
+	    croak("sdbm store returned %d, errno %d, key \"%s\"",
+			RETVAL,errno,key.dptr);
+	    sdbm_clearerr(db->dbp);
+	}
+
+int
+sdbm_DELETE(db, key)
+	SDBM_File	db
+	datum_key	key
+
+int
+sdbm_EXISTS(db,key)
+	SDBM_File	db
+	datum_key	key
+
+datum_key
+sdbm_FIRSTKEY(db)
+	SDBM_File	db
+
+datum_key
+sdbm_NEXTKEY(db, key)
+	SDBM_File	db
+
+int
+sdbm_error(db)
+	SDBM_File	db
+	ALIAS:
+	sdbm_clearerr = 1
+	CODE:
+	RETVAL = ix ? sdbm_clearerr(db->dbp) : sdbm_error(db->dbp);
+	OUTPUT:
+	  RETVAL
+
+SV *
+filter_fetch_key(db, code)
+	SDBM_File	db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	ALIAS:
+	SDBM_File::filter_fetch_key = fetch_key
+	SDBM_File::filter_store_key = store_key
+	SDBM_File::filter_fetch_value = fetch_value
+	SDBM_File::filter_store_value = store_value
+	CODE:
+	    DBM_setFilter(db->filter[ix], code);
+
+BOOT:
+	{
+	    HV *stash = gv_stashpvs("SDBM_File", 1);
+	    newCONSTSUB(stash, "PAGFEXT", newSVpvs(PAGFEXT));
+	    newCONSTSUB(stash, "DIRFEXT", newSVpvs(DIRFEXT));
+	    newCONSTSUB(stash, "PAIRMAX", newSVuv(PAIRMAX));
+	}
+
+MODULE = SDBM_File	PACKAGE = SDBM_X	PREFIX = sdbm_X_
+
+int
+sdbm_X_DELETE0(db, key)
+	SDBM_File	db
+	datum_key	key
+
+#define X "X"
+
+int
+sdbm_X_DELETE1(db, key)
+	SDBM_File	db
+	datum_key	key
+
+#define Y "Y"
diff --git a/docs/news.rst b/docs/news.rst
@@ -479,6 +479,7 @@ The following parsers have been added:
 * TypeScript
 * Varlink *peg/packcc*
 * WindRes
+* XS *optlib pcre2*
 * XSLT v1.0 *libxml*
 * Yacc
 * Yaml *libyaml*

diff --git a/main/parsers_p.h b/main/parsers_p.h
@@ -48,7 +48,8 @@
 
 #ifdef HAVE_PCRE2
 #define OPTLIB2C_PCRE2_PARSER_LIST             \
-   RDocParser
+   RDocParser, \
+   XSParser
 #else
 #define OPTLIB2C_PCRE2_PARSER_LIST
 #endif

diff --git a/optlib/xs.ctags b/optlib/xs.ctags
@@ -0,0 +1,141 @@
+#
+# xs.ctags --- interface description file format used to create an extension interface between Perl and C code
+#
+# Copyright (c) 2022, Red Hat, Inc.
+# Copyright (c) 2022, Masatake YAMATO
+#
+# Author: Masatake YAMATO <[email protected]>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+# USA.
+#
+# References:
+#
+# - https://perldoc.perl.org/perlxs
+#
+
+#
+# TODO:
+#
+# - capture aliases
+# - capture signatures of functions,
+# - make reftag for INCLUDE'ed files
+# - separators
+#
+
+--langdef=XS
+--map-XS=+.xs
+
+#
+# Kind definitions
+#
+
+--kinddef-XS=m,module,modules
+--kinddef-XS=p,package,packages
+--kinddef-XS=f,function,functions
+
+#
+# Tables declaration
+#
+
+--_tabledef-XS=init
+--_tabledef-XS=main
+--_tabledef-XS=func
+--_tabledef-XS=keywords
+
+#
+# Prelude
+#
+
+--_prelude-XS={{
+    /scope false def
+    /xsstart false def
+    /prefix false def
+    /prefix-length 0 def
+}}
+
+#
+# Tables definitions
+#
+
+# keywords table
+--_mtable-regex-XS=keywords/(?:REQUIRE|BOOT|CASE|PREINIT|INPUT|INIT|CODE|PPCODE|OUTPUT|CLEANUP|ALIAS|ATTRS|PROTOTYPES|PROTOTYPE|VERSIONCHECK|INCLUDE|INCLUDE_COMMAND|SCOPE|INTERFACE|INTERFACE_MACRO|C_ARGS|POSTCALL|OVERLOAD|FALLBACK|EXPORT_XSUB_SYMBOLS)[^\n]*\n//{pcre2}
+
+# init table
+--_mtable-regex-XS=init/((?:.*?)[\n])[ \t]*(MODULE[ \t]*=)//{pcre2}{tjump=main}{_guest=C,1start,1end}{_advanceTo=2start}{{
+  /xsstart 2 /start _matchloc def
+}}
+
+# main table
+--_mtable-regex-XS=main/[ \t]*MODULE[ \t]*=[ \t]*([^ \t\n]+)([ \t]*PACKAGE[ \t]*=[ \t]*([^ \t\n]+))?([ \t]*PREFIX[ \t]*=[ \t]*([^ \t\n]+))?[^\n]*\n/\1/m/{{
+  \3 false ne {
+    % Make a tag for the package and set it to the scope.
+    \3 /package 3 /start _matchloc _tag _commit dup . scope:
+  } {
+    % Make a tag for the module and set it to the scope.
+    .
+  } ifelse
+  /scope exch def
+
+  % Record the prefix.
+  \5 false ne {
+    /prefix \5 def
+    /prefix-length \5 length def
+  } if
+}}
+
+--_mtable-regex-XS=main/[\t ]+[^\n]*\n//
+--_mtable-extend-XS=main+keywords
+--_mtable-regex-XS=main/([A-Za-z_][^\n]*?)[\t ]*\n//{tenter=func}{pcre2}{{
+  % return type
+  \1
+}}
+
+--_mtable-regex-XS=main/[^\n]*\n//
+--_mtable-regex-XS=main/()//{tquit}{{
+  xsstart false ne {
+    (CPreProcessor) xsstart 1 /start _matchloc _makepromise pop
+  } if
+}}
+
+# func table
+--_mtable-extend-XS=func+keywords
+--_mtable-regex-XS=func/([A-Za-z_][a-zA-Z0-9_]*)[ \t]*\([^\n]*\n/\1/f/{tleave}{{
+  % function name
+  count 0 gt {
+    prefix false ne {
+      \1 prefix _strstr {
+        0 eq {
+          prefix-length \1 length prefix-length sub 0 string _copyinterval
+          % type name-sans-prefix
+          /function 1 /start _matchloc _tag _commit dup scope scope:
+          % type tag
+          1 index exch
+          % type type tag
+          exch typeref:
+        } if
+      } {
+        pop
+      } ifelse
+    } if
+    % Fill the scope: field.
+    . scope scope:
+    % if a return type is on the stack, set it to typeref: field.
+    % Should we consdier "struct", "union", and "enum" here?
+    . exch typeref:
+  } if
+}}
+--_mtable-regex-XS=func/[^\n]*\n//{tleave}
+--_mtable-regex-XS=func/.//{tleave}
diff --git a/source.mak b/source.mak
@@ -219,6 +219,7 @@ OPTSCRIPT_OBJS = $(OPTSCRIPT_SRCS:.c=.$(OBJEXT))
 
 OPTLIB2C_PCRE2_INPUT =       \
    optlib/rdoc.ctags         \
+   optlib/xs.ctags           \
    \
    $(NULL)
 OPTLIB2C_PCRE2_SRCS = $(OPTLIB2C_PCRE2_INPUT:.ctags=.c)