The R Project SVN R

Rev

Rev 38671 | Rev 38840 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 38671 Rev 38673
Line 1... Line -...
1 
#include <R.h>
 - 
 
2 
#include <Rinternals.h>
 - 
 
3 
#include <Rdefines.h>
 - 
 
4 
 
 - 
 
5 
#include "embeddedRCall.h"
 1 
#include "embeddedRCall.h"
6 
 
 2 
 
7 
void bar1() ;
 3 
void bar1() ;
8 
void source(const char *name);
 4 
void source(const char *name);
9 
/*
 5 
/*
Line 12... Line 8...
12 
   plot(1:10, pch="+")
 8 
   plot(1:10, pch="+")
13 
 */
 9 
 */
14 
int
 10 
int
15 
main(int argc, char *argv[])
 11 
main(int argc, char *argv[])
16 
{
 12 
{
17 
  char *localArgs[] = {"R", "--silent"};
 13 
    char *localArgs[] = {"R", "--silent"};
18 
  init_R(sizeof(localArgs)/sizeof(localArgs[0]), localArgs);
 14 
    init_R(sizeof(localArgs)/sizeof(localArgs[0]), localArgs);
19 
  source("foo.R");
 15 
    source("foo.R");
20 
  bar1();
 16 
    bar1();
21 
 
 17 
 
22 
  return(0);
 18 
    return(0);
23 
}
 19 
}
24 
 
 20 
 
25 
 
 21 
 
26 
/*
 22 
/*
27 
 This arranges for the command source("foo.R")
 23 
 This arranges for the command source("foo.R")
Line 29... Line 25...
29 
 call in bar1.
 25 
 call in bar1.
30 
 */
 26 
 */
31 
void
 27 
void
32 
source(const char *name)
 28 
source(const char *name)
33 
{
 29 
{
34 
  SEXP e, tmp, fun;
 30 
    SEXP e;
35 
 
 - 
 
36 
   PROTECT(e = allocVector(LANGSXP, 2));
 - 
 
37 
   PROTECT(fun = Rf_findFun(Rf_install("source"), R_GlobalEnv));
 - 
 
38 
   SETCAR(e, fun);
 - 
 
39 
   SETCAR(CDR(e), tmp = NEW_CHARACTER(1));
 - 
 
40 
   SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING("foo.R"));
 - 
 
41 
 
 31 
 
- 
 
 32 
    PROTECT(e = lang2(install("source"), mkString(name)));
42 
   R_tryEval(e, R_GlobalEnv, NULL);
 33 
    R_tryEval(e, R_GlobalEnv, NULL);
- 
 
 34 
    UNPROTECT(1);
43 
}
 35 
}
44 
 
 36 
 
45 
/*
37 
/*
46 
  Call the function foo() with 3 arguments, 2 of which
 38 
  Call the function foo() with 3 arguments, 2 of which
47 
  are named.
 39 
  are named.
48 
   foo(pch="+", id = 123, c(T,F))
 40 
   foo(pch="+", id = 123, c(T,F))
49 
 
 41 
 
50 
  Note that Rf_PrintValue() of the expression seg-faults.
 42 
  Note that PrintValue() of the expression seg-faults.
51 
  We have to set the print name correctly.
 43 
  We have to set the print name correctly.
52 
*/
 44 
*/
53 
 
 45 
 
54 
void
 46 
void
55 
bar1()
47 
bar1()
56 
{
 48 
{
57 
  SEXP fun, pch;
 49 
    SEXP fun, pch;
58 
  SEXP e;
 50 
    SEXP e;
59 
  int n = 7;
 - 
 
60 
 
 51 
 
61 
    PROTECT(e = allocVector(LANGSXP, 4));
 52 
    PROTECT(e = allocVector(LANGSXP, 4));
62 
    fun = Rf_findFun(Rf_install("foo"), R_GlobalEnv);
 53 
    fun = findFun(install("foo"), R_GlobalEnv);
63 
    if(GET_LENGTH(fun) == 0) {
 54 
    if(fun == R_NilValue) {
64 
      fprintf(stderr, "No definition for function foo. Source foo.R and save the session.\n");
 55 
	fprintf(stderr, "No definition for function foo. Source foo.R and save the session.\n");
65 
      UNPROTECT(1);
 56 
	UNPROTECT(1);
66 
      exit(1);
 57 
	exit(1);
67 
    }
 58 
    }
68 
    PROTECT(fun);
 - 
 
69 
    SETCAR(e, fun);
 59 
    SETCAR(e, fun);
70 
 
 60 
 
71 
    PROTECT(pch = NEW_CHARACTER(1));
 - 
 
72 
    SET_STRING_ELT(pch, 0, COPY_TO_USER_STRING("+"));
 - 
 
73 
    SETCAR(CDR(e), pch);
61 
    SETCADR(e, mkString("+"));
74 
 
 - 
 
75 
    SET_TAG(CDR(e), Rf_install("pch"));
 62 
    SET_TAG(CDR(e), install("pch"));
76 
 
 - 
 
77 
 
 - 
 
78 
    PROTECT(pch = NEW_INTEGER(1));
 - 
 
79 
    INTEGER_DATA(pch)[0] = 123;
 - 
 
80 
    SETCAR(CDR(CDR(e)), pch);
- 
 
81 
 
 63 
 
- 
 
 64 
    SETCADDR(e, ScalarInteger(123));
82 
    SET_TAG(CDR(CDR(e)), Rf_install("id"));
 65 
    SET_TAG(CDR(CDR(e)), install("id"));
83 
 
 66 
 
84 
    PROTECT(pch = NEW_LOGICAL(2));
 67 
    pch = allocVector(LGLSXP, 2);
85 
     LOGICAL_DATA(pch)[0] = TRUE;
 68 
    LOGICAL(pch)[0] = TRUE;
86 
     LOGICAL_DATA(pch)[1] = FALSE;
 69 
    LOGICAL(pch)[1] = FALSE;
87 
    SETCAR(CDR(CDR(CDR(e))), pch);
70 
    SETCADDDR(e, pch);
88 
 
 71 
 
89 
    Rf_PrintValue(e);
 72 
    PrintValue(e);
90 
    eval(e, R_GlobalEnv);
 73 
    eval(e, R_GlobalEnv);
91 
 
 74 
 
92 
    SETCAR(e, Rf_install("foo"));
 75 
    SETCAR(e, install("foo"));
93 
    Rf_PrintValue(e);
 76 
    PrintValue(e);
94 
    R_tryEval(e, R_GlobalEnv, NULL);
 77 
    R_tryEval(e, R_GlobalEnv, NULL);
95 
 
 78 
 
96 
    UNPROTECT(n);
 79 
    UNPROTECT(1);
97 
}
 80 
}
98 
 
 81