Index: src/include/Rinternals.h =================================================================== --- src/include/Rinternals.h (revision 43463) +++ src/include/Rinternals.h (working copy) @@ -103,6 +103,7 @@ #define WEAKREFSXP 23 /* weak reference */ #define RAWSXP 24 /* raw bytes */ #define S4SXP 25 /* S4, non-vector */ +#define NATFSXP 26 /* native function */ #define FUNSXP 99 /* Closure or Builtin or Special */ @@ -470,6 +471,8 @@ #define EXTPTR_PROT(x) CDR(x) #define EXTPTR_TAG(x) TAG(x) +#define NATF_PTR(x) CAR(x) + #ifdef BYTECODE /* Bytecode access macros */ #define BCODE_CODE(x) CAR(x) @@ -651,6 +654,10 @@ void R_SetExternalPtrTag(SEXP s, SEXP tag); void R_SetExternalPtrProtected(SEXP s, SEXP p); +/* Native functions interface */ +typedef SEXP(*native_fun_t)(SEXP,SEXP); +SEXP R_MakeNativeFunction(native_fun_t p); + /* Finalization interface */ typedef void (*R_CFinalizer_t)(SEXP); void R_RegisterFinalizer(SEXP s, SEXP fun); Index: src/main/Makefile.in =================================================================== --- src/main/Makefile.in (revision 43463) +++ src/main/Makefile.in (working copy) @@ -24,7 +24,7 @@ engine.c envir.c errors.c eval.c \ format.c fourier.c \ gevents.c gram.c gram-ex.c graphics.c \ - identical.c inlined.c internet.c iosupport.c \ + identical.c inlined.c inspect.c internet.c iosupport.c \ lapack.c list.c localecharset.c logic.c \ main.c mapply.c match.c memory.c model.c \ names.c \ Index: src/main/duplicate.c =================================================================== --- src/main/duplicate.c (revision 43463) +++ src/main/duplicate.c (working copy) @@ -138,6 +138,7 @@ case SPECIALSXP: case BUILTINSXP: case EXTPTRSXP: + case NATFSXP: #ifdef BYTECODE case BCODESXP: #endif Index: src/main/util.c =================================================================== --- src/main/util.c (revision 43463) +++ src/main/util.c (working copy) @@ -218,6 +218,7 @@ { "weakref", WEAKREFSXP }, { "raw", RAWSXP }, { "S4", S4SXP }, + { "nativefn", NATFSXP }, /* aliases : */ { "numeric", REALSXP }, { "name", SYMSXP }, Index: src/main/names.c =================================================================== --- src/main/names.c (revision 43463) +++ src/main/names.c (working copy) @@ -940,6 +940,8 @@ {"setEncoding", do_setencoding, 0, 11, 2, {PP_FUNCALL, PREC_FN, 0}}, {"lazyLoadDBfetch",do_lazyLoadDBfetch,0,1, 4, {PP_FUNCALL, PREC_FN, 0}}, +{"inspect", do_inspect, 0, 0, 1, {PP_FUNCALL, PREC_FN, 0}}, + {NULL, NULL, 0, 0, 0, {PP_INVALID, PREC_FN, 0}}, }; Index: src/main/memory.c =================================================================== --- src/main/memory.c (revision 43463) +++ src/main/memory.c (working copy) @@ -441,6 +441,7 @@ case WEAKREFSXP: \ case RAWSXP: \ case S4SXP: \ + case NATFSXP: \ break; \ case STRSXP: \ case EXPRSXP: \ @@ -2421,6 +2422,16 @@ R_PreciousList = RecursiveRelease(object, R_PreciousList); } +/* Native Function Objects */ +SEXP R_MakeNativeFunction(native_fun_t p) +{ + SEXP s = allocSExp(NATFSXP); + SETCAR(s, R_NilValue); + SETCDR(s, R_NilValue); + SET_TAG(s, R_NilValue); + NATF_PTR(s) = p; + return s; +} /* External Pointer Objects */ SEXP R_MakeExternalPtr(void *p, SEXP tag, SEXP prot) Index: src/main/envir.c =================================================================== --- src/main/envir.c (revision 43463) +++ src/main/envir.c (working copy) @@ -1239,7 +1239,7 @@ UNPROTECT(1); } if (TYPEOF(vl) == CLOSXP || TYPEOF(vl) == BUILTINSXP || - TYPEOF(vl) == SPECIALSXP) + TYPEOF(vl) == SPECIALSXP || TYPEOF(vl) == NATFSXP) return (vl); if (vl == R_MissingArg) error(_("argument \"%s\" is missing, with no default"), Index: src/main/objects.c =================================================================== --- src/main/objects.c (revision 43463) +++ src/main/objects.c (working copy) @@ -125,6 +125,10 @@ else if (TYPEOF(op) == CLOSXP) { ans = applyClosure(call, op, args, rho, newrho); } + else if (TYPEOF(op) == NATFSXP) { + native_fun_t fn = NATF_PTR(op); + ans = fn(args, rho); + } else ans = R_NilValue; /* for -Wall */ return ans; @@ -195,6 +199,9 @@ val = findVar1(method, callrho, FUNSXP, TRUE); if (isFunction(val)) return val; + val = findVar1(method, callrho, NATFSXP, TRUE); + if (TYPEOF(val) == NATFSXP) + return val; else { /* We assume here that no one registered a non-function */ SEXP table = findVarInFrame3(defrho, @@ -269,7 +276,7 @@ sprintf(buf, "%s.%s", generic, ss); method = install(buf); sxp = R_LookupMethod(method, rho, callrho, defrho); - if (isFunction(sxp)) { + if (isFunction(sxp) || TYPEOF(sxp) == NATFSXP) { defineVar(install(".Generic"), mkString(generic), newrho); if (i > 0) { PROTECT(t = allocVector(STRSXP, nclass - i)); @@ -299,7 +306,7 @@ sprintf(buf, "%s.default", generic); method = install(buf); sxp = R_LookupMethod(method, rho, callrho, defrho); - if (isFunction(sxp)) { + if (isFunction(sxp) || TYPEOF(sxp) == NATFSXP) { defineVar(install(".Generic"), mkString(generic), newrho); defineVar(install(".Class"), R_NilValue, newrho); PROTECT(t = mkString(buf)); Index: src/main/eval.c =================================================================== --- src/main/eval.c (revision 43463) +++ src/main/eval.c (working copy) @@ -502,6 +502,16 @@ check_stack_balance(op, save); vmaxset(vmax); } + else if (TYPEOF(op) == NATFSXP) { + native_fun_t fn = NATF_PTR(op); +#ifdef EVAL_NATF + PROTECT(tmp = evalList(CDR(e), rho, op)); + tmp = fn(tmp, rho); + UNPROTECT(1); +#else + tmp = fn(CDR(e), rho); +#endif + } else if (TYPEOF(op) == CLOSXP) { PROTECT(tmp = promiseArgs(CDR(e), rho)); tmp = applyClosure(e, op, tmp, rho, R_BaseEnv); Index: src/main/print.c =================================================================== --- src/main/print.c (revision 43463) +++ src/main/print.c (working copy) @@ -745,6 +745,9 @@ case EXTPTRSXP: Rprintf("\n", R_ExternalPtrAddr(s)); break; + case NATFSXP: + Rprintf("\n", NATF_PTR(s)); + break; #ifdef BYTECODE case BCODESXP: Rprintf("\n", s);