src/main/match.c - R - Git at Google

 /*
  *  R : A Computer Language for Statistical Data Analysis
  *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
  *  Copyright (C) 1998-2017   The R Core Team.
  *
  *  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, a copy is available at
  *  https://www.R-project.org/Licenses/


  *  Matching and Partial Matching for Strings
  *
  *  In theory all string matching code should be placed in this file
  *  At present there are still a couple of rogue matchers about.
  *
  *
  *  psmatch(char *, char *, int);
  *
  *  This code will perform partial matching for list tags.  When
  *  exact is 1, and exact match is required (typically after ...)
  *  otherwise partial matching is performed.
  *
  *  Examples:
  *
  *	psmatch("aaa", "aaa", 0) -> 1
  *	psmatch("aaa", "aa", 0) -> 1
  *	psmatch("aa", "aaa", 0) -> 0
  *
  */

 #ifdef HAVE_CONFIG_H
 #include <config.h>
 #endif

 #include "Defn.h"


 /* used in subscript.c and subassign.c */
 Rboolean NonNullStringMatch(SEXP s, SEXP t)
 {
     /* "" or NA string matches nothing */
     if (s == NA_STRING || t == NA_STRING) return FALSE;
     if (CHAR(s)[0] && CHAR(t)[0] && Seql(s, t))
 	return TRUE;
     else
 	return FALSE;
 }

 /* currently unused outside this file */
 Rboolean psmatch(const char *f, const char *t, Rboolean exact)
 {
     if (exact)
 	return (Rboolean)!strcmp(f, t);
     /* else */
     while (*t) {
 	if (*t != *f)   return FALSE;
 	t++;
 	f++;
     }
     return TRUE;
 }


 /* Matching formals and arguments */

 /* Are these are always native charset? */
 Rboolean pmatch(SEXP formal, SEXP tag, Rboolean exact)
 {
     const char *f, *t;
     const void *vmax = vmaxget();
     switch (TYPEOF(formal)) {
     case SYMSXP:
 	f = CHAR(PRINTNAME(formal));
 	break;
     case CHARSXP:
 	f = CHAR(formal);
 	break;
     case STRSXP:
 	f = translateChar(STRING_ELT(formal, 0));
 	break;
     default:
 	goto fail;
     }
     switch(TYPEOF(tag)) {
     case SYMSXP:
 	t = CHAR(PRINTNAME(tag));
 	break;
     case CHARSXP:
 	t = CHAR(tag);
 	break;
     case STRSXP:
 	t = translateChar(STRING_ELT(tag, 0));
 	break;
     default:
 	goto fail;
     }
     Rboolean res = psmatch(f, t, exact);
     vmaxset(vmax);
     return res;
  fail:
     error(_("invalid partial string match"));
     return FALSE;/* for -Wall */
 }


 /* Destructively Extract A Named List Element. */
 /* Returns the first partially matching tag found. */
 /* Pattern is a C string. */

 static SEXP matchPar_int(const char *tag, SEXP *list, Rboolean exact)
 {
     if (*list == R_NilValue)
 	return R_MissingArg;
     else if (TAG(*list) != R_NilValue &&
 	     psmatch(tag, CHAR(PRINTNAME(TAG(*list))), exact)) {
 	SEXP s = *list;
 	*list = CDR(*list);
 	return CAR(s);
     }
     else {
 	SEXP last = *list;
 	SEXP next = CDR(*list);
 	while (next != R_NilValue) {
 	    if (TAG(next) != R_NilValue &&
 		psmatch(tag, CHAR(PRINTNAME(TAG(next))), exact)) {
 		SETCDR(last, CDR(next));
 		return CAR(next);
 	    }
 	    else {
 		last = next;
 		next = CDR(next);
 	    }
 	}
 	return R_MissingArg;
     }
 }

 /* unused outside this file */
 SEXP attribute_hidden matchPar(const char *tag, SEXP * list)
 {
     return matchPar_int(tag, list, FALSE);
 }


 /* Destructively Extract A Named List Element. */
 /* Returns the first partially matching tag found. */
 /* Pattern is a symbol. */

 SEXP attribute_hidden matchArg(SEXP tag, SEXP * list)
 {
     return matchPar(CHAR(PRINTNAME(tag)), list);
 }


 /* Destructively Extract A Named List Element. */
 /* Returns the first exactly matching tag found. */
 /* Pattern is a symbol. */

 SEXP attribute_hidden matchArgExact(SEXP tag, SEXP * list)
 {
       return matchPar_int(CHAR(PRINTNAME(tag)), list, TRUE);
 }


 /* Match the supplied arguments with the formals and */
 /* return the matched arguments in actuals. */

 #define ARGUSED(x) LEVELS(x)
 #define SET_ARGUSED(x,v) SETLEVELS(x,v)


 /* We need to leave 'supplied' unchanged in case we call UseMethod */
 /* MULTIPLE_MATCHES was added by RI in Jan 2005 but never activated:
    code in R-2-8-branch */

 SEXP attribute_hidden matchArgs(SEXP formals, SEXP supplied, SEXP call)
 {
     Rboolean seendots;
     int i, arg_i = 0;
     SEXP f, a, b, dots, actuals;

     actuals = R_NilValue;
     for (f = formals ; f != R_NilValue ; f = CDR(f), arg_i++) {
 	/* CONS_NR is used since argument lists created here are only
 	   used internally and so should not increment reference
 	   counts */
 	actuals = CONS_NR(R_MissingArg, actuals);
 	SET_MISSING(actuals, 1);
     }
     /* We use fargused instead of ARGUSED/SET_ARGUSED on elements of
        formals to avoid modification of the formals SEXPs.  A gc can
        cause matchArgs to be called from finalizer code, resulting in
        another matchArgs call with the same formals.  In R-2.10.x, this
        corrupted the ARGUSED data of the formals and resulted in an
        incorrect "formal argument 'foo' matched by multiple actual
        arguments" error.
      */
     int fargused[arg_i ? arg_i : 1]; // avoid undefined behaviour
     memset(fargused, 0, sizeof(fargused));

     for(b = supplied; b != R_NilValue; b = CDR(b)) SET_ARGUSED(b, 0);

     PROTECT(actuals);

     /* First pass: exact matches by tag */
     /* Grab matched arguments and check */
     /* for multiple exact matches. */

     f = formals;
     a = actuals;
     arg_i = 0;
     while (f != R_NilValue) {
       SEXP ftag = TAG(f);
       const char *ftag_name = CHAR(PRINTNAME(ftag));
       if (ftag != R_DotsSymbol && ftag != R_NilValue) {
 	    for (b = supplied, i = 1; b != R_NilValue; b = CDR(b), i++) {
 	      SEXP btag = TAG(b);
 	      if (btag != R_NilValue) {
 		  const char *btag_name = CHAR(PRINTNAME(btag));
 		  if (streql( ftag_name, btag_name )) {
 		      if (fargused[arg_i] == 2)
 			  errorcall(call,
 	                      _("formal argument \"%s\" matched by multiple actual arguments"),
 	                      CHAR(PRINTNAME(TAG(f))));
 		      if (ARGUSED(b) == 2)
 			  errorcall(call,
 	                      _("argument %d matches multiple formal arguments"),
                               i);
 		      SETCAR(a, CAR(b));
 		      if(CAR(b) != R_MissingArg) SET_MISSING(a, 0);
 		      SET_ARGUSED(b, 2);
 		      fargused[arg_i] = 2;
 		  }
 	      }
 	    }
 	}
 	f = CDR(f);
 	a = CDR(a);
         arg_i++;
     }

     /* Second pass: partial matches based on tags */
     /* An exact match is required after first ... */
     /* The location of the first ... is saved in "dots" */

     dots = R_NilValue;
     seendots = FALSE;
     f = formals;
     a = actuals;
     arg_i = 0;
     while (f != R_NilValue) {
 	if (fargused[arg_i] == 0) {
 	    if (TAG(f) == R_DotsSymbol && !seendots) {
 		/* Record where ... value goes */
 		dots = a;
 		seendots = TRUE;
 	    } else {
 		for (b = supplied, i = 1; b != R_NilValue; b = CDR(b), i++) {
 		    if (ARGUSED(b) != 2 && TAG(b) != R_NilValue &&
 			pmatch(TAG(f), TAG(b), seendots)) {
 			if (ARGUSED(b))
 			    errorcall(call,
 				_("argument %d matches multiple formal arguments"), i);
 			if (fargused[arg_i] == 1)
 			    errorcall(call,
 				_("formal argument \"%s\" matched by multiple actual arguments"),
 				CHAR(PRINTNAME(TAG(f))));
 			if (R_warn_partial_match_args) {
 			    warningcall(call,
 					_("partial argument match of '%s' to '%s'"),
 					CHAR(PRINTNAME(TAG(b))),
 					CHAR(PRINTNAME(TAG(f))) );
 			}
 			SETCAR(a, CAR(b));
 			if (CAR(b) != R_MissingArg) SET_MISSING(a, 0);
 			SET_ARGUSED(b, 1);
 			fargused[arg_i] = 1;
 		    }
 		}
 	    }
 	}
 	f = CDR(f);
 	a = CDR(a);
         arg_i++;
     }

     /* Third pass: matches based on order */
     /* All args specified in tag=value form */
     /* have now been matched.  If we find ... */
     /* we gobble up all the remaining args. */
     /* Otherwise we bind untagged values in */
     /* order to any unmatched formals. */

     f = formals;
     a = actuals;
     b = supplied;
     seendots = FALSE;

     while (f != R_NilValue && b != R_NilValue && !seendots) {
 	if (TAG(f) == R_DotsSymbol) {
 	    /* Skip ... matching until all tags done */
 	    seendots = TRUE;
 	    f = CDR(f);
 	    a = CDR(a);
 	} else if (CAR(a) != R_MissingArg) {
 	    /* Already matched by tag */
 	    /* skip to next formal */
 	    f = CDR(f);
 	    a = CDR(a);
 	} else if (ARGUSED(b) || TAG(b) != R_NilValue) {
 	    /* This value used or tagged , skip to next value */
 	    /* The second test above is needed because we */
 	    /* shouldn't consider tagged values for positional */
 	    /* matches. */
 	    /* The formal being considered remains the same */
 	    b = CDR(b);
 	} else {
 	    /* We have a positional match */
 	    SETCAR(a, CAR(b));
 	    if(CAR(b) != R_MissingArg) SET_MISSING(a, 0);
 	    SET_ARGUSED(b, 1);
 	    b = CDR(b);
 	    f = CDR(f);
 	    a = CDR(a);
 	}
     }

     if (dots != R_NilValue) {
 	/* Gobble up all unused actuals */
 	SET_MISSING(dots, 0);
 	i = 0;
 	for(a = supplied; a != R_NilValue ; a = CDR(a)) if(!ARGUSED(a)) i++;

 	if (i) {
 	    a = allocList(i);
 	    SET_TYPEOF(a, DOTSXP);
 	    f = a;
 	    for(b = supplied; b != R_NilValue; b = CDR(b))
 		if(!ARGUSED(b)) {
 		    SETCAR(f, CAR(b));
 		    SET_TAG(f, TAG(b));
 		    f = CDR(f);
 		}
 	    SETCAR(dots, a);
 	}
     } else {
 	/* Check that all arguments are used */
 	SEXP unused = R_NilValue, last = R_NilValue;
 	for (b = supplied; b != R_NilValue; b = CDR(b))
 	    if (!ARGUSED(b)) {
 		if(last == R_NilValue) {
 		    PROTECT(unused = CONS(CAR(b), R_NilValue));
 		    SET_TAG(unused, TAG(b));
 		    last = unused;
 		} else {
 		    SETCDR(last, CONS(CAR(b), R_NilValue));
 		    last = CDR(last);
 		    SET_TAG(last, TAG(b));
 		}
 	    }

 	if(last != R_NilValue) {
             /* show bad arguments in call without evaluating them */
             SEXP unusedForError = R_NilValue, last = R_NilValue;

             for(b = unused ; b != R_NilValue ; b = CDR(b)) {
                 SEXP tagB = TAG(b), carB = CAR(b) ;
                 if (TYPEOF(carB) == PROMSXP) carB = PREXPR(carB) ;
                 if (last == R_NilValue) {
                     PROTECT(last = CONS(carB, R_NilValue));
                     SET_TAG(last, tagB);
                     unusedForError = last;
                 } else {
                     SETCDR(last, CONS(carB, R_NilValue));
                     last = CDR(last);
                     SET_TAG(last, tagB);
                 }
             }
 	    errorcall(call /* R_GlobalContext->call */,
 		      ngettext("unused argument %s",
 			       "unused arguments %s",
 			       (unsigned long) length(unusedForError)),
 		      strchr(CHAR(asChar(deparse1line(unusedForError, 0))), '('));
 	}
     }
     UNPROTECT(1);
     return(actuals);
 }

 /* Use matchArgs_RC if the result might escape into R. */
 SEXP attribute_hidden matchArgs_RC(SEXP formals, SEXP supplied, SEXP call)
 {
     SEXP args = matchArgs(formals, supplied, call);
     /* it would be better not to build this arglist with CONS_NR in
        the first place */
     for (SEXP a = args; a  != R_NilValue; a = CDR(a)) {
 	if (! TRACKREFS(a)) {
 	    ENABLE_REFCNT(a);
 	    INCREMENT_REFCNT(CAR(a));
 	    INCREMENT_REFCNT(CDR(a));
 	}
     }
     return args;
 }


 /* patchArgsByActuals - patch promargs (given as 'supplied') to be promises
    for the respective actuals in the given environment 'cloenv'.  This is
    used by NextMethod to allow patching of arguments to the current closure
    before dispatching to the next method.  The implementation is based on
    matchArgs, but there is no error/warning checking, assuming that it has
    already been done by a call to matchArgs when the current closure was
    invoked.
 */

 typedef enum {
     FS_UNMATCHED       = 0, /* the formal was not matched by any supplied arg */
     FS_MATCHED_PRESENT = 1, /* the formal was matched by a non-missing arg */
     FS_MATCHED_MISSING = 2, /* the formal was matched, but by a missing arg */
     FS_MATCHED_LOCAL   = 3, /* the formal was matched by a missing arg, but
                                a local variable of the same name as the formal
                                has been used */
 } fstype_t;

 static R_INLINE
 void patchArgument(SEXP suppliedSlot, SEXP name, fstype_t *farg, SEXP cloenv) {
     SEXP value = CAR(suppliedSlot);
     if (value == R_MissingArg) {
         value = findVarInFrame3(cloenv, name, TRUE);
         if (value == R_MissingArg) {
             if (farg) *farg = FS_MATCHED_MISSING;
             return;
         }
         if (farg) *farg = FS_MATCHED_LOCAL;
     } else
         if (farg) *farg = FS_MATCHED_PRESENT;

     SETCAR(suppliedSlot, mkPROMISE(name, cloenv));
 }

 SEXP attribute_hidden
 patchArgsByActuals(SEXP formals, SEXP supplied, SEXP cloenv)
 {
     int i, seendots, farg_i;
     SEXP f, a, b, prsupplied;

     int nfarg = length(formals);
     if (!nfarg) nfarg = 1; // avoid undefined behaviour
     fstype_t farg[nfarg];
     for(i = 0; i < nfarg; i++) farg[i] = FS_UNMATCHED;

     /* Shallow-duplicate supplied arguments */

     PROTECT(prsupplied = allocList(length(supplied)));
     for(b = supplied, a = prsupplied; b != R_NilValue; b = CDR(b), a = CDR(a)) {
         SETCAR(a, CAR(b));
         SET_ARGUSED(a, 0);
         SET_TAG(a, TAG(b));
     }

     /* First pass: exact matches by tag */

     f = formals;
     farg_i = 0;
     while (f != R_NilValue) {
 	if (TAG(f) != R_DotsSymbol) {
 	    for (b = prsupplied; b != R_NilValue; b = CDR(b)) {
 		if (TAG(b) != R_NilValue && pmatch(TAG(f), TAG(b), 1)) {
 		    patchArgument(b, TAG(f), &farg[farg_i], cloenv);
 		    SET_ARGUSED(b, 2);
 		    break; /* Previous invocation of matchArgs */
 		           /* ensured unique matches */
 		}
 	    }
 	}
 	f = CDR(f);
 	farg_i++;
     }

     /* Second pass: partial matches based on tags */
     /* An exact match is required after first ... */
     /* The location of the first ... is saved in "dots" */

     seendots = 0;
     f = formals;
     farg_i = 0;
     while (f != R_NilValue) {
 	if (farg[farg_i] == FS_UNMATCHED) {
 	    if (TAG(f) == R_DotsSymbol && !seendots) {
 		seendots = 1;
 	    } else {
 		for (b = prsupplied; b != R_NilValue; b = CDR(b)) {
 		    if (!ARGUSED(b) && TAG(b) != R_NilValue &&
 			pmatch(TAG(f), TAG(b), seendots)) {

 			patchArgument(b, TAG(f), &farg[farg_i], cloenv);
 			SET_ARGUSED(b, 1);
 			break; /* Previous invocation of matchArgs */
 			       /* ensured unique matches */
 		    }
 		}
 	    }
 	}
 	f = CDR(f);
 	farg_i++;
     }

     /* Third pass: matches based on order */
     /* All args specified in tag=value form */
     /* have now been matched.  If we find ... */
     /* we gobble up all the remaining args. */
     /* Otherwise we bind untagged values in */
     /* order to any unmatched formals. */

     f = formals;
     b = prsupplied;
     farg_i = 0;
     while (f != R_NilValue && b != R_NilValue) {
 	if (TAG(f) == R_DotsSymbol) {
 	    /* Done, ... and following args cannot be patched */
 	    break;
 	} else if (farg[farg_i] == FS_MATCHED_PRESENT) {
 	    /* Note that this check corresponds to CAR(b) == R_MissingArg */
 	    /* in matchArgs */

 	    /* Already matched by tag */
 	    /* skip to next formal */
 	    f = CDR(f);
 	    farg_i++;
 	} else if (ARGUSED(b) || TAG(b) != R_NilValue) {
 	    /* This value is used or tagged, skip to next value */
 	    /* The second test above is needed because we */
 	    /* shouldn't consider tagged values for positional */
 	    /* matches. */
 	    /* The formal being considered remains the same */
 	    b = CDR(b);
 	} else {
 	    /* We have a positional match */
 	    if (farg[farg_i] == FS_MATCHED_LOCAL)
 	        /* Another supplied argument, a missing with a tag, has */
 	        /* been patched to a promise reading this formal, because */
 	        /* there was a local variable of that name. Hence, we have */
 	        /* to turn this supplied argument into a missing. */
 	        /* Otherwise, we would supply a value twice, confusing */
 	        /* argument matching in subsequently called functions. */
 	        SETCAR(b, R_MissingArg);
 	    else
 	        patchArgument(b, TAG(f), NULL, cloenv);

 	    SET_ARGUSED(b, 1);
 	    b = CDR(b);
 	    f = CDR(f);
 	    farg_i++;
 	}
     }

     /* Previous invocation of matchArgs ensured all args are used */
     UNPROTECT(1);
     return(prsupplied);
 }
	/*
	* R : A Computer Language for Statistical Data Analysis
	* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
	* Copyright (C) 1998-2017 The R Core Team.
	*
	* 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, a copy is available at
	* https://www.R-project.org/Licenses/


	* Matching and Partial Matching for Strings
	*
	* In theory all string matching code should be placed in this file
	* At present there are still a couple of rogue matchers about.
	*
	*
	* psmatch(char , char , int);
	*
	* This code will perform partial matching for list tags. When
	* exact is 1, and exact match is required (typically after ...)
	* otherwise partial matching is performed.
	*
	* Examples:
	*
	* psmatch("aaa", "aaa", 0) -> 1
	* psmatch("aaa", "aa", 0) -> 1
	* psmatch("aa", "aaa", 0) -> 0
	*
	*/

	#ifdef HAVE_CONFIG_H
	#include <config.h>
	#endif

	#include "Defn.h"


	/* used in subscript.c and subassign.c */
	Rboolean NonNullStringMatch(SEXP s, SEXP t)
	{
	/* "" or NA string matches nothing */
	if (s == NA_STRING \|\| t == NA_STRING) return FALSE;
	if (CHAR(s)[0] && CHAR(t)[0] && Seql(s, t))
	return TRUE;
	else
	return FALSE;
	}

	/* currently unused outside this file */
	Rboolean psmatch(const char f, const char t, Rboolean exact)
	{
	if (exact)
	return (Rboolean)!strcmp(f, t);
	/* else */
	while (*t) {
	if (t != f) return FALSE;
	t++;
	f++;
	}
	return TRUE;
	}


	/* Matching formals and arguments */

	/* Are these are always native charset? */
	Rboolean pmatch(SEXP formal, SEXP tag, Rboolean exact)
	{
	const char f, t;
	const void *vmax = vmaxget();
	switch (TYPEOF(formal)) {
	case SYMSXP:
	f = CHAR(PRINTNAME(formal));
	break;
	case CHARSXP:
	f = CHAR(formal);
	break;
	case STRSXP:
	f = translateChar(STRING_ELT(formal, 0));
	break;
	default:
	goto fail;
	}
	switch(TYPEOF(tag)) {
	case SYMSXP:
	t = CHAR(PRINTNAME(tag));
	break;
	case CHARSXP:
	t = CHAR(tag);
	break;
	case STRSXP:
	t = translateChar(STRING_ELT(tag, 0));
	break;
	default:
	goto fail;
	}
	Rboolean res = psmatch(f, t, exact);
	vmaxset(vmax);
	return res;
	fail:
	error(_("invalid partial string match"));
	return FALSE;/* for -Wall */
	}


	/* Destructively Extract A Named List Element. */
	/* Returns the first partially matching tag found. */
	/* Pattern is a C string. */

	static SEXP matchPar_int(const char tag, SEXP list, Rboolean exact)
	{
	if (*list == R_NilValue)
	return R_MissingArg;
	else if (TAG(*list) != R_NilValue &&
	psmatch(tag, CHAR(PRINTNAME(TAG(*list))), exact)) {
	SEXP s = *list;
	list = CDR(list);
	return CAR(s);
	}
	else {
	SEXP last = *list;
	SEXP next = CDR(*list);
	while (next != R_NilValue) {
	if (TAG(next) != R_NilValue &&
	psmatch(tag, CHAR(PRINTNAME(TAG(next))), exact)) {
	SETCDR(last, CDR(next));
	return CAR(next);
	}
	else {
	last = next;
	next = CDR(next);
	}
	}
	return R_MissingArg;
	}
	}

	/* unused outside this file */
	SEXP attribute_hidden matchPar(const char tag, SEXP list)
	{
	return matchPar_int(tag, list, FALSE);
	}



	/* Destructively Extract A Named List Element. */
	/* Returns the first partially matching tag found. */
	/* Pattern is a symbol. */

	SEXP attribute_hidden matchArg(SEXP tag, SEXP * list)
	{
	return matchPar(CHAR(PRINTNAME(tag)), list);
	}


	/* Destructively Extract A Named List Element. */
	/* Returns the first exactly matching tag found. */
	/* Pattern is a symbol. */

	SEXP attribute_hidden matchArgExact(SEXP tag, SEXP * list)
	{
	return matchPar_int(CHAR(PRINTNAME(tag)), list, TRUE);
	}


	/* Match the supplied arguments with the formals and */
	/* return the matched arguments in actuals. */

	#define ARGUSED(x) LEVELS(x)
	#define SET_ARGUSED(x,v) SETLEVELS(x,v)


	/* We need to leave 'supplied' unchanged in case we call UseMethod */
	/* MULTIPLE_MATCHES was added by RI in Jan 2005 but never activated:
	code in R-2-8-branch */

	SEXP attribute_hidden matchArgs(SEXP formals, SEXP supplied, SEXP call)
	{
	Rboolean seendots;
	int i, arg_i = 0;
	SEXP f, a, b, dots, actuals;

	actuals = R_NilValue;
	for (f = formals ; f != R_NilValue ; f = CDR(f), arg_i++) {
	/* CONS_NR is used since argument lists created here are only
	used internally and so should not increment reference
	counts */
	actuals = CONS_NR(R_MissingArg, actuals);
	SET_MISSING(actuals, 1);
	}
	/* We use fargused instead of ARGUSED/SET_ARGUSED on elements of
	formals to avoid modification of the formals SEXPs. A gc can
	cause matchArgs to be called from finalizer code, resulting in
	another matchArgs call with the same formals. In R-2.10.x, this
	corrupted the ARGUSED data of the formals and resulted in an
	incorrect "formal argument 'foo' matched by multiple actual
	arguments" error.
	*/
	int fargused[arg_i ? arg_i : 1]; // avoid undefined behaviour
	memset(fargused, 0, sizeof(fargused));

	for(b = supplied; b != R_NilValue; b = CDR(b)) SET_ARGUSED(b, 0);

	PROTECT(actuals);

	/* First pass: exact matches by tag */
	/* Grab matched arguments and check */
	/* for multiple exact matches. */

	f = formals;
	a = actuals;
	arg_i = 0;
	while (f != R_NilValue) {
	SEXP ftag = TAG(f);
	const char *ftag_name = CHAR(PRINTNAME(ftag));
	if (ftag != R_DotsSymbol && ftag != R_NilValue) {
	for (b = supplied, i = 1; b != R_NilValue; b = CDR(b), i++) {
	SEXP btag = TAG(b);
	if (btag != R_NilValue) {
	const char *btag_name = CHAR(PRINTNAME(btag));
	if (streql( ftag_name, btag_name )) {
	if (fargused[arg_i] == 2)
	errorcall(call,
	_("formal argument \"%s\" matched by multiple actual arguments"),
	CHAR(PRINTNAME(TAG(f))));
	if (ARGUSED(b) == 2)
	errorcall(call,
	_("argument %d matches multiple formal arguments"),
	i);
	SETCAR(a, CAR(b));
	if(CAR(b) != R_MissingArg) SET_MISSING(a, 0);
	SET_ARGUSED(b, 2);
	fargused[arg_i] = 2;
	}
	}
	}
	}
	f = CDR(f);
	a = CDR(a);
	arg_i++;
	}

	/* Second pass: partial matches based on tags */
	/* An exact match is required after first ... */
	/* The location of the first ... is saved in "dots" */

	dots = R_NilValue;
	seendots = FALSE;
	f = formals;
	a = actuals;
	arg_i = 0;
	while (f != R_NilValue) {
	if (fargused[arg_i] == 0) {
	if (TAG(f) == R_DotsSymbol && !seendots) {
	/* Record where ... value goes */
	dots = a;
	seendots = TRUE;
	} else {
	for (b = supplied, i = 1; b != R_NilValue; b = CDR(b), i++) {
	if (ARGUSED(b) != 2 && TAG(b) != R_NilValue &&
	pmatch(TAG(f), TAG(b), seendots)) {
	if (ARGUSED(b))
	errorcall(call,
	_("argument %d matches multiple formal arguments"), i);
	if (fargused[arg_i] == 1)
	errorcall(call,
	_("formal argument \"%s\" matched by multiple actual arguments"),
	CHAR(PRINTNAME(TAG(f))));
	if (R_warn_partial_match_args) {
	warningcall(call,
	_("partial argument match of '%s' to '%s'"),
	CHAR(PRINTNAME(TAG(b))),
	CHAR(PRINTNAME(TAG(f))) );
	}
	SETCAR(a, CAR(b));
	if (CAR(b) != R_MissingArg) SET_MISSING(a, 0);
	SET_ARGUSED(b, 1);
	fargused[arg_i] = 1;
	}
	}
	}
	}
	f = CDR(f);
	a = CDR(a);
	arg_i++;
	}

	/* Third pass: matches based on order */
	/* All args specified in tag=value form */
	/* have now been matched. If we find ... */
	/* we gobble up all the remaining args. */
	/* Otherwise we bind untagged values in */
	/* order to any unmatched formals. */

	f = formals;
	a = actuals;
	b = supplied;
	seendots = FALSE;

	while (f != R_NilValue && b != R_NilValue && !seendots) {
	if (TAG(f) == R_DotsSymbol) {
	/* Skip ... matching until all tags done */
	seendots = TRUE;
	f = CDR(f);
	a = CDR(a);
	} else if (CAR(a) != R_MissingArg) {
	/* Already matched by tag */
	/* skip to next formal */
	f = CDR(f);
	a = CDR(a);
	} else if (ARGUSED(b) \|\| TAG(b) != R_NilValue) {
	/* This value used or tagged , skip to next value */
	/* The second test above is needed because we */
	/* shouldn't consider tagged values for positional */
	/* matches. */
	/* The formal being considered remains the same */
	b = CDR(b);
	} else {
	/* We have a positional match */
	SETCAR(a, CAR(b));
	if(CAR(b) != R_MissingArg) SET_MISSING(a, 0);
	SET_ARGUSED(b, 1);
	b = CDR(b);
	f = CDR(f);
	a = CDR(a);
	}
	}

	if (dots != R_NilValue) {
	/* Gobble up all unused actuals */
	SET_MISSING(dots, 0);
	i = 0;
	for(a = supplied; a != R_NilValue ; a = CDR(a)) if(!ARGUSED(a)) i++;

	if (i) {
	a = allocList(i);
	SET_TYPEOF(a, DOTSXP);
	f = a;
	for(b = supplied; b != R_NilValue; b = CDR(b))
	if(!ARGUSED(b)) {
	SETCAR(f, CAR(b));
	SET_TAG(f, TAG(b));
	f = CDR(f);
	}
	SETCAR(dots, a);
	}
	} else {
	/* Check that all arguments are used */
	SEXP unused = R_NilValue, last = R_NilValue;
	for (b = supplied; b != R_NilValue; b = CDR(b))
	if (!ARGUSED(b)) {
	if(last == R_NilValue) {
	PROTECT(unused = CONS(CAR(b), R_NilValue));
	SET_TAG(unused, TAG(b));
	last = unused;
	} else {
	SETCDR(last, CONS(CAR(b), R_NilValue));
	last = CDR(last);
	SET_TAG(last, TAG(b));
	}
	}

	if(last != R_NilValue) {
	/* show bad arguments in call without evaluating them */
	SEXP unusedForError = R_NilValue, last = R_NilValue;

	for(b = unused ; b != R_NilValue ; b = CDR(b)) {
	SEXP tagB = TAG(b), carB = CAR(b) ;
	if (TYPEOF(carB) == PROMSXP) carB = PREXPR(carB) ;
	if (last == R_NilValue) {
	PROTECT(last = CONS(carB, R_NilValue));
	SET_TAG(last, tagB);
	unusedForError = last;
	} else {
	SETCDR(last, CONS(carB, R_NilValue));
	last = CDR(last);
	SET_TAG(last, tagB);
	}
	}
	errorcall(call /* R_GlobalContext->call */,
	ngettext("unused argument %s",
	"unused arguments %s",
	(unsigned long) length(unusedForError)),
	strchr(CHAR(asChar(deparse1line(unusedForError, 0))), '('));
	}
	}
	UNPROTECT(1);
	return(actuals);
	}

	/* Use matchArgs_RC if the result might escape into R. */
	SEXP attribute_hidden matchArgs_RC(SEXP formals, SEXP supplied, SEXP call)
	{
	SEXP args = matchArgs(formals, supplied, call);
	/* it would be better not to build this arglist with CONS_NR in
	the first place */
	for (SEXP a = args; a != R_NilValue; a = CDR(a)) {
	if (! TRACKREFS(a)) {
	ENABLE_REFCNT(a);
	INCREMENT_REFCNT(CAR(a));
	INCREMENT_REFCNT(CDR(a));
	}
	}
	return args;
	}


	/* patchArgsByActuals - patch promargs (given as 'supplied') to be promises
	for the respective actuals in the given environment 'cloenv'. This is
	used by NextMethod to allow patching of arguments to the current closure
	before dispatching to the next method. The implementation is based on
	matchArgs, but there is no error/warning checking, assuming that it has
	already been done by a call to matchArgs when the current closure was
	invoked.
	*/

	typedef enum {
	FS_UNMATCHED = 0, /* the formal was not matched by any supplied arg */
	FS_MATCHED_PRESENT = 1, /* the formal was matched by a non-missing arg */
	FS_MATCHED_MISSING = 2, /* the formal was matched, but by a missing arg */
	FS_MATCHED_LOCAL = 3, /* the formal was matched by a missing arg, but
	a local variable of the same name as the formal
	has been used */
	} fstype_t;

	static R_INLINE
	void patchArgument(SEXP suppliedSlot, SEXP name, fstype_t *farg, SEXP cloenv) {
	SEXP value = CAR(suppliedSlot);
	if (value == R_MissingArg) {
	value = findVarInFrame3(cloenv, name, TRUE);
	if (value == R_MissingArg) {
	if (farg) *farg = FS_MATCHED_MISSING;
	return;
	}
	if (farg) *farg = FS_MATCHED_LOCAL;
	} else
	if (farg) *farg = FS_MATCHED_PRESENT;

	SETCAR(suppliedSlot, mkPROMISE(name, cloenv));
	}

	SEXP attribute_hidden
	patchArgsByActuals(SEXP formals, SEXP supplied, SEXP cloenv)
	{
	int i, seendots, farg_i;
	SEXP f, a, b, prsupplied;

	int nfarg = length(formals);
	if (!nfarg) nfarg = 1; // avoid undefined behaviour
	fstype_t farg[nfarg];
	for(i = 0; i < nfarg; i++) farg[i] = FS_UNMATCHED;

	/* Shallow-duplicate supplied arguments */

	PROTECT(prsupplied = allocList(length(supplied)));
	for(b = supplied, a = prsupplied; b != R_NilValue; b = CDR(b), a = CDR(a)) {
	SETCAR(a, CAR(b));
	SET_ARGUSED(a, 0);
	SET_TAG(a, TAG(b));
	}

	/* First pass: exact matches by tag */

	f = formals;
	farg_i = 0;
	while (f != R_NilValue) {
	if (TAG(f) != R_DotsSymbol) {
	for (b = prsupplied; b != R_NilValue; b = CDR(b)) {
	if (TAG(b) != R_NilValue && pmatch(TAG(f), TAG(b), 1)) {
	patchArgument(b, TAG(f), &farg[farg_i], cloenv);
	SET_ARGUSED(b, 2);
	break; /* Previous invocation of matchArgs */
	/* ensured unique matches */
	}
	}
	}
	f = CDR(f);
	farg_i++;
	}

	/* Second pass: partial matches based on tags */
	/* An exact match is required after first ... */
	/* The location of the first ... is saved in "dots" */

	seendots = 0;
	f = formals;
	farg_i = 0;
	while (f != R_NilValue) {
	if (farg[farg_i] == FS_UNMATCHED) {
	if (TAG(f) == R_DotsSymbol && !seendots) {
	seendots = 1;
	} else {
	for (b = prsupplied; b != R_NilValue; b = CDR(b)) {
	if (!ARGUSED(b) && TAG(b) != R_NilValue &&
	pmatch(TAG(f), TAG(b), seendots)) {

	patchArgument(b, TAG(f), &farg[farg_i], cloenv);
	SET_ARGUSED(b, 1);
	break; /* Previous invocation of matchArgs */
	/* ensured unique matches */
	}
	}
	}
	}
	f = CDR(f);
	farg_i++;
	}

	/* Third pass: matches based on order */
	/* All args specified in tag=value form */
	/* have now been matched. If we find ... */
	/* we gobble up all the remaining args. */
	/* Otherwise we bind untagged values in */
	/* order to any unmatched formals. */

	f = formals;
	b = prsupplied;
	farg_i = 0;
	while (f != R_NilValue && b != R_NilValue) {
	if (TAG(f) == R_DotsSymbol) {
	/* Done, ... and following args cannot be patched */
	break;
	} else if (farg[farg_i] == FS_MATCHED_PRESENT) {
	/* Note that this check corresponds to CAR(b) == R_MissingArg */
	/* in matchArgs */

	/* Already matched by tag */
	/* skip to next formal */
	f = CDR(f);
	farg_i++;
	} else if (ARGUSED(b) \|\| TAG(b) != R_NilValue) {
	/* This value is used or tagged, skip to next value */
	/* The second test above is needed because we */
	/* shouldn't consider tagged values for positional */
	/* matches. */
	/* The formal being considered remains the same */
	b = CDR(b);
	} else {
	/* We have a positional match */
	if (farg[farg_i] == FS_MATCHED_LOCAL)
	/* Another supplied argument, a missing with a tag, has */
	/* been patched to a promise reading this formal, because */
	/* there was a local variable of that name. Hence, we have */
	/* to turn this supplied argument into a missing. */
	/* Otherwise, we would supply a value twice, confusing */
	/* argument matching in subsequently called functions. */
	SETCAR(b, R_MissingArg);
	else
	patchArgument(b, TAG(f), NULL, cloenv);

	SET_ARGUSED(b, 1);
	b = CDR(b);
	f = CDR(f);
	farg_i++;
	}
	}

	/* Previous invocation of matchArgs ensured all args are used */
	UNPROTECT(1);
	return(prsupplied);
	}