diff --git a/Units/parser-xs.r/simple-xs.d/args.ctags b/Units/parser-xs.r/simple-xs.d/args.ctags new file mode 100644 index 0000000000..f371192148 --- /dev/null +++ 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 new file mode 100644 index 0000000000..f64d0e6f40 --- /dev/null +++ b/Units/parser-xs.r/simple-xs.d/expected.tags @@ -0,0 +1,37 @@ +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 +sdbm_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 +sdbm_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 +sdbm_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 +sdbm_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 +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 +sdbm_X_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 new file mode 100644 index 0000000000..92d5e6de8e --- /dev/null +++ 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 new file mode 100644 index 0000000000..0207a77b6b --- /dev/null +++ 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 index f5920d18fb..93c24f02bf 100644 --- 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 index faba51fb11..9fbf01f380 100644 --- 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 new file mode 100644 index 0000000000..78178ca7a2 --- /dev/null +++ b/optlib/xs.ctags @@ -0,0 +1,126 @@ +# +# 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 +# +# 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: +# +# - tagging the prefix trimmed function names +# - 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 +}} + +# +# 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 + } if +}} + +--_mtable-regex-XS=main/[\t ]+[^\n]*\n// +--_mtable-extend-XS=main+keywords +--_mtable-regex-XS=main/([A-Za-z_].*?)[\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]*\(/\1/f/{tleave}{{ + % function name + count 0 gt { + % TODO prefix handling + % 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 index 6347483728..a45d726a72 100644 --- 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)