← Back to branch summary

~ubuntu-branches/ubuntu/maverick/swig1.3/maverick

« back to all changes in this revision

Viewing changes to Source/Modules/r.cxx

  • Committer: Bazaar Package Importer
  • Author(s): Michael Vogt
  • Date: 2008-11-10 16:29:56 UTC
  • mfrom: (1.2.8 upstream) (2.1.3 lenny)
  • Revision ID: james.westby@ubuntu.com-20081110162956-xue6itkuqhbza87s
Tags: 1.3.36-1ubuntu1
* Merge from debian unstable, remaining changes:
  - Drop pike and libchicken-dev from the build-depends 
    (both are universe)
  - Use python2.5 instead of python2.4.
  - use php5
  - Clean Runtime/ as well.
  - debian/Rules (clean): Remove Lib/ocaml/swigp4.ml.
  - drop "--without-mzscheme", we don't have it in our build-depends

Show diffs side-by-side

added added

removed removed

Lines of Context:
Source/Modules/r.cxx
7
7
 * R language module for SWIG.
8
8
 * ----------------------------------------------------------------------------- */
9
9
 
10
 
char cvsroot_r_cxx[] = "$Id: r.cxx 10267 2008-02-27 13:06:46Z wsfulton $";
 
10
char cvsroot_r_cxx[] = "$Id: r.cxx 10540 2008-06-21 15:23:02Z wsfulton $";
11
11
 
12
12
#include "swigmod.h"
13
13
 
16
16
static const double DEFAULT_NUMBER = .0000123456712312312323;
17
17
static const int MAX_OVERLOAD_ARGS = 5;
18
18
 
 
19
static String* replaceInitialDash(const String *name)
 
20
{
 
21
  String *retval;
 
22
  if (!Strncmp(name, "_", 1)) {
 
23
    retval = Copy(name);
 
24
    Insert(retval, 0, "s");
 
25
  } else {
 
26
    retval = Copy(name);
 
27
  }
 
28
  return retval;
 
29
}
 
30
 
19
31
static String * getRTypeName(SwigType *t, int *outCount = NULL) {
20
32
  String *b = SwigType_base(t);
21
33
  List *els = SwigType_split(t);
45
57
  Insert(tmp, 0, retName);
46
58
  return tmp;
47
59
  
 
60
  /*
48
61
  if(count)
49
62
    return(b);
50
63
  
51
64
  Delete(b);
52
65
  return(NewString(""));
 
66
  */
53
67
}
54
68
 
55
69
#if 0
60
74
  SwigType_push(elType, elDecl);
61
75
  String *ans;
62
76
 
63
 
  String *rtype = Swig_typemap_lookup_new("rtype", n, "", 0);
 
77
  String *rtype = Swig_typemap_lookup("rtype", n, "", 0);
64
78
  String *i = getRTypeName(elType);
65
79
 
66
80
  if(Len(i) == 0) {
92
106
  Now handles arrays, i.e. struct A[2]
93
107
****************/
94
108
 
95
 
static String *getRClassName(String *retType, int addRef = 1, int upRef=0) {
 
109
static String *getRClassName(String *retType, int /*addRef*/ = 1, int upRef=0) {
96
110
  String *tmp = NewString("");
97
111
  SwigType *resolved = SwigType_typedef_resolve_all(retType);
98
112
  char *retName = Char(SwigType_manglestr(resolved));
103
117
  }
104
118
  
105
119
  return tmp;
 
120
/*
106
121
#if 1
107
122
  List *l = SwigType_split(retType);
108
123
  int n = Len(l);
148
163
#endif
149
164
  
150
165
  return tmp;
 
166
*/
151
167
}
152
168
 
153
169
/*********************
342
358
  int outputRegistrationRoutines(File *out);
343
359
  
344
360
  int outputCommandLineArguments(File *out);
345
 
  int generateCopyRoutinesObsolete(Node *n); 
346
361
  int generateCopyRoutines(Node *n); 
347
362
  int DumpCode(Node *n);
348
363
  
572
587
  //   ParmList *parms = Getattr(n, "parms");
573
588
  // memory leak
574
589
  ParmList *parms = SwigType_function_parms(SwigType_del_pointer(Copy(t)));
575
 
  if (debugMode) {
 
590
 
 
591
 
 
592
  //  if (debugMode) {
576
593
    Printf(stderr, "Type: %s\n", t);
577
594
    Printf(stderr, "Return type: %s\n", SwigType_base(t));
578
 
  }
 
595
    //}
579
596
  
580
597
  bool isVoidType = Strcmp(rettype, "void") == 0;
581
598
  if (debugMode)
605
622
 
606
623
  Printf(f->def, "%s %s(", rtype, funName);
607
624
 
608
 
  emit_args(rettype, parms, f);
 
625
  emit_parameter_variables(parms, f);
 
626
  emit_return_variable(n, rettype, f);
609
627
//  emit_attach_parmmaps(parms,f);
610
628
 
611
629
  /*  Using weird name and struct to avoid potential conflicts. */
616
634
  Wrapper_add_local(f, "r_nprotect", "int r_nprotect = 0"); // for use in converting arguments to R objects for call.
617
635
  Wrapper_add_local(f, "r_vmax", "char * r_vmax= 0"); // for use in converting arguments to R objects for call.
618
636
 
619
 
  // Add local for error code in return value.  This is not in emit_args because that assumes an out typemap
 
637
  // Add local for error code in return value.  This is not in emit_return_variable because that assumes an out typemap
620
638
  // whereas the type makes are reverse
621
639
  Wrapper_add_local(f, "ecode", "int ecode = 0");
622
640
 
696
714
    
697
715
    Setattr(bbase, "type", rettype);
698
716
    Setattr(bbase, "name", NewString("result"));
699
 
    String *returnTM = Swig_typemap_lookup_new("in", bbase, "result", f);
 
717
    String *returnTM = Swig_typemap_lookup("in", bbase, "result", f);
700
718
    if(returnTM) {
701
719
      String *tm = returnTM;
702
720
      Replaceall(tm,"$input", "r_swig_cb_data->retValue");
1590
1608
  int   nfunc = Len(dispatch);
1591
1609
  Printv(f->code, 
1592
1610
         "argtypes <- mapply(class, list(...))\n",
 
1611
         "argv <- list(...)\n",
1593
1612
         "argc <- length(argtypes)\n", NIL );
1594
1613
 
1595
1614
  Printf(f->code, "# dispatch functions %d\n", nfunc);
1619
1638
      }
1620
1639
      Printv(f->code, "if (", NIL);
1621
1640
      for (p =pi, j = 0 ; j < num_arguments ; j++) {
1622
 
        String *tm = Swig_typemap_lookup_new("rtype", p, "", 0);
 
1641
        String *tm = Swig_typemap_lookup("rtype", p, "", 0);
1623
1642
        if(tm) {
1624
1643
          replaceRClass(tm, Getattr(p, "type"));
1625
1644
        }
 
1645
        if (DohStrcmp(tm,"numeric")==0) {
 
1646
        Printf(f->code, "%sis.numeric(argv[[%d]])",
 
1647
               j == 0 ? "" : " && ",
 
1648
               j+1);
 
1649
        }
 
1650
        else {
1626
1651
        Printf(f->code, "%sextends(argtypes[%d], '%s')",
1627
1652
               j == 0 ? "" : " && ",
1628
1653
               j+1,
1629
1654
               tm);
 
1655
        }
1630
1656
        p = Getattr(p, "tmap:in:next");
1631
1657
      }
1632
1658
      Printf(f->code, ") { f <- %s%s }\n", sfname, overname);
1678
1704
  
1679
1705
  ParmList *l = Getattr(n, "parms");
1680
1706
  Parm *p;
1681
 
  String *returnTM = NULL;
1682
1707
  String *tm;
1683
1708
  
1684
1709
  p = l;
1753
1778
  Wrapper *f = NewWrapper();
1754
1779
  Wrapper *sfun = NewWrapper();
1755
1780
    
1756
 
 
1757
 
  int isVoidReturnType = 0;
1758
 
  returnTM = Swig_typemap_lookup_new("out", n, "result",0);
1759
 
  if(returnTM) 
1760
 
    isVoidReturnType = (Strcmp(type, "void") == 0);
 
1781
  int isVoidReturnType = (Strcmp(type, "void") == 0);
 
1782
  // Need to use the unresolved return type since 
 
1783
  // typedef resolution removes the const which causes a 
 
1784
  // mismatch with the function action
 
1785
  emit_return_variable(n, unresolved_return_type, f);
1761
1786
 
1762
1787
  SwigType *rtype = Getattr(n, "type");
1763
1788
  int addCopyParam = 0;
1786
1811
  Swig_typemap_attach_parms("scoerceout", l, f);
1787
1812
  Swig_typemap_attach_parms("scheck", l, f);
1788
1813
 
1789
 
  // Need to use the unresolved return type since 
1790
 
  // typedef resolution removes the const which causes a 
1791
 
  // mismatch with the function action
1792
 
  emit_args(unresolved_return_type, l, f);
 
1814
  emit_parameter_variables(l, f);
1793
1815
  emit_attach_parmmaps(l,f);
1794
1816
  Setattr(n,"wrap:parms",l);
1795
1817
 
1823
1845
    String   *name  = Getattr(p,"name");
1824
1846
    String   *lname  = Getattr(p,"lname");
1825
1847
 
 
1848
    // R keyword renaming
 
1849
    if (name && Swig_name_warning(p, 0, name, 0))
 
1850
      name = 0;
1826
1851
 
1827
1852
    /* If we have a :: in the parameter name because we are accessing a static member of a class, say, then
1828
1853
       we need to remove that prefix. */
1835
1860
    if (Len(name) == 0)
1836
1861
      name = NewStringf("s_arg%d", i+1);
1837
1862
 
1838
 
    if (!Strncmp(name, "_", 1)) {
1839
 
      name = Copy(name);
1840
 
      Insert(name, 0, "s");
1841
 
    }
 
1863
    name = replaceInitialDash(name);
1842
1864
 
1843
1865
    if (!Strncmp(name, "arg", 3)) {
1844
1866
      name = Copy(name);
1935
1957
    }
1936
1958
 
1937
1959
 
1938
 
    tm = Swig_typemap_lookup_new("rtype", curP, "", 0);
 
1960
    tm = Swig_typemap_lookup("rtype", curP, "", 0);
1939
1961
    if(tm) {
1940
1962
      replaceRClass(tm, Getattr(curP, "type"));
1941
1963
    }
1970
1992
    }
1971
1993
  }
1972
1994
 
1973
 
 
1974
 
  emit_action(n, f);
1975
 
 
1976
 
 
1977
 
 
1978
 
 
1979
1995
  String *outargs = NewString("");
1980
1996
  int numOutArgs = isVoidReturnType ? -1 : 0;
1981
1997
  for(p = l, i = 0; p; i++) {
1982
 
    String *tm;
1983
1998
    if((tm = Getattr(p, "tmap:argout"))) {
1984
1999
      //       String *lname =  Getattr(p, "lname");
1985
2000
      numOutArgs++;
1998
2013
      p = nextSibling(p);
1999
2014
  }
2000
2015
 
 
2016
  String *actioncode = emit_action(n);
 
2017
 
2001
2018
  /* Deal with the explicit return value. */
2002
 
  if (returnTM) { 
2003
 
    String *tm = returnTM;
 
2019
  if ((tm = Swig_typemap_lookup_out("out", n, "result", f, actioncode))) { 
2004
2020
    SwigType *retType = Getattr(n, "type");
2005
2021
    //Printf(stderr, "Return Value for %s, array? %s\n", retType, SwigType_isarray(retType) ? "yes" : "no");     
2006
2022
    /*      if(SwigType_isarray(retType)) {
2018
2034
      Replaceall(tm,"$owner", "R_SWIG_EXTERNAL");
2019
2035
    }
2020
2036
 
2021
 
    if(0 && addCopyParam) {
 
2037
#if 0
 
2038
    if(addCopyParam) {
2022
2039
      Printf(f->code, "if(LOGICAL(s_swig_copy)[0]) {\n");
2023
2040
      Printf(f->code, "/* Deal with returning a reference. */\nr_ans = R_NilValue;\n");
2024
2041
      Printf(f->code, "}\n else {\n");
2025
2042
    } 
 
2043
#endif
2026
2044
    Printf(f->code, "%s\n", tm);
2027
 
    if(0 && addCopyParam) 
 
2045
#if 0
 
2046
    if(addCopyParam) 
2028
2047
      Printf(f->code, "}\n"); /* end of if(s_swig_copy) ... else { ... } */
 
2048
#endif
2029
2049
 
2030
2050
  } else {
2031
2051
    Swig_warning(WARN_TYPEMAP_OUT_UNDEF, input_file, line_number,
2067
2087
  Printv(f->code, UnProtectWrapupCode, NIL);
2068
2088
 
2069
2089
  /*If the user gave us something to convert the result in  */
2070
 
  if ((tm = Swig_typemap_lookup_new("scoerceout", n, 
 
2090
  if ((tm = Swig_typemap_lookup("scoerceout", n, 
2071
2091
                                    "result", sfun))) {
2072
2092
    Replaceall(tm,"$source","ans");
2073
2093
    Replaceall(tm,"$result","ans");
2093
2113
  Wrapper_print(sfun, sfile);
2094
2114
 
2095
2115
  Printf(sfun->code, "\n# End of %s\n", iname);
2096
 
  tm = Swig_typemap_lookup_new("rtype", n, "", 0);
 
2116
  tm = Swig_typemap_lookup("rtype", n, "", 0);
2097
2117
  if(tm) {
2098
2118
    SwigType *retType = Getattr(n, "type");
2099
2119
    replaceRClass(tm, retType);
2149
2169
  return SWIG_OK;
2150
2170
}
2151
2171
 
2152
 
 
2153
 
int R::defineArrayAccessors(SwigType *type) {
2154
 
 
2155
 
  SwigType *base = SwigType_base(type);
2156
 
  String *rclass = NewStringf("%sArray", base);
2157
 
  char *prclassName = Char(rclass);
2158
 
  if(strncmp(prclassName, "struct ", 7) == 0)
2159
 
    prclassName += 7;
2160
 
 
2161
 
  Node *n = NewHash();
2162
 
  Setattr(n, "type", base);
2163
 
  String *tm;
2164
 
  String *rclassName = getRClassName(base);
2165
 
  String *rclassBase = getRClassName(base, 0);
2166
 
 
2167
 
  String *cGetName = NewStringf("R_SWIG_%s_get_item_", prclassName);
2168
 
  String *cSetName = NewStringf("R_SWIG_%s_set_item_", prclassName);
2169
 
 
2170
 
  Wrapper *cGetItem = NewWrapper();
2171
 
 
2172
 
  String *getItem = NewString(""), 
2173
 
    *setItem = NewString("");
2174
 
 
2175
 
  Printf(getItem, "function(x, i, j, ..., drop = TRUE) {\n");
2176
 
 
2177
 
  Printf(getItem, "%sif(i < 1 || i > x@dims[1])\n%sstop('index must be between 1 and ', x@dims[1])\n", tab4, tab8);
2178
 
  Printf(getItem, "%s.Call('%s', x@ref, as.integer(i-1), PACKAGE = '%s')\n", tab4, cGetName, Rpackage);
2179
 
  Printf(getItem, "}\n");
2180
 
 
2181
 
 
2182
 
 
2183
 
  Printf(setItem, "function(x, i, j, ..., value) {\n");
2184
 
 
2185
 
  Printf(setItem, "%sif(i < 1 || i > x@dims[1])\n%sstop('index must be between 1 and ', x@dims[1])\n", tab4, tab8);
2186
 
 
2187
 
  /* Do the SCOERCEIN and the SCHECK here */
2188
 
  tm = Swig_typemap_lookup_new("scoercein", n, "value", 0);
2189
 
  if(tm) {
2190
 
    Replaceall(tm, "$input", "s_value");
2191
 
    Replaceall(tm, "$R_class", rclassName);
2192
 
    Replaceall(tm, "$*R_class", rclassBase);
2193
 
 
2194
 
    Printf(setItem, "%s%s\n", tab4, tm);
2195
 
  }
2196
 
 
2197
 
  tm = Swig_typemap_lookup_new("scheck", n, "value", 0);
2198
 
  if(tm) {
2199
 
    Replaceall(tm, "$input", "s_value");
2200
 
    Replaceall(tm, "$R_class", rclassName);
2201
 
    Replaceall(tm, "$*R_class", rclassBase);
2202
 
 
2203
 
    Printf(setItem, "%s%s\n", tab4, tm);
2204
 
  }
2205
 
 
2206
 
 
2207
 
 
2208
 
  Printf(setItem, "%s.Call('%s', x@ref, as.integer(i-1), value, PACKAGE = '%s')\n", tab4, cSetName, Rpackage);
2209
 
  Printf(setItem, "%sx\n}\n", tab4);
2210
 
 
2211
 
 
2212
 
 
2213
 
  Printf(cGetItem->def, "SEXP\n%s(SEXP s_x, SEXP s_i)\n{\n", cGetName);
2214
 
 
2215
 
  String *tmp = NewStringf("%s *ptr", SwigType_lstr(base, 0));
2216
 
  String *tmp1 = NewStringf("%s result", SwigType_lstr(base, 0));
2217
 
 
2218
 
  Wrapper_add_localv(cGetItem, "r_vmax", "VMAXTYPE", "r_vmax = vmaxget()", NIL);
2219
 
  Wrapper_add_local(cGetItem, "ptr", tmp);
2220
 
  Wrapper_add_local(cGetItem, "r_ans", "SEXP r_ans");
2221
 
  Wrapper_add_local(cGetItem, "result", tmp1);
2222
 
  Wrapper_add_local(cGetItem, "r_nprotect", "int r_nprotect = 0");
2223
 
 
2224
 
  Printf(cGetItem->code, "ptr = (%s *) R_SWIG_resolveExternalRef(s_x, \"\", \"s_x\", 0);\n", SwigType_lstr(base, 0));
2225
 
  Printf(cGetItem->code, "result = ptr[INTEGER(s_i)[0]];\n");
2226
 
 
2227
 
 
2228
 
  tm = Swig_typemap_lookup_new("out", n, "result", 0);
2229
 
  if(tm) {
2230
 
    Replaceall(tm, "$result", "r_ans");
2231
 
    Replaceall(tm,"$owner", "R_SWIG_EXTERNAL");
2232
 
    Printf(cGetItem->code, "%s\n", tm);
2233
 
  }
2234
 
 
2235
 
  Delete(tmp); Delete(tmp1);
2236
 
 
2237
 
  Printf(cGetItem->code, "%s\nreturn r_ans;\n}\n\n", UnProtectWrapupCode);
2238
 
 
2239
 
 
2240
 
  /******************************/
2241
 
  /*
2242
 
    R_SWIG_..._set_item(SEXP x, SEXP s_i, SEXP s_value) {
2243
 
    char *r_vmax = vmaxget();
2244
 
    int r_nprotect = 0;
2245
 
    type *ptr, *el, value;
2246
 
  
2247
 
    ptr = (type *) R_SWIG_resolveExternalRef(s_x, "", "s_x", 0);
2248
 
  
2249
 
    ptr[INTEGER(s_i)[0]] = *el;
2250
 
  
2251
 
    cleanup
2252
 
    return
2253
 
    }
2254
 
  */
2255
 
  Wrapper *cSetItem = NewWrapper();
2256
 
  {
2257
 
 
2258
 
    Printf(cSetItem->def, "SEXP\n%s(SEXP s_x, SEXP s_i, SEXP s_value)\n{\n", cSetName);
2259
 
 
2260
 
    tmp = NewStringf("%s *ptr", SwigType_lstr(base, 0));
2261
 
    tmp1 = NewStringf("%s value", SwigType_lstr(base, 0));
2262
 
 
2263
 
    Wrapper_add_localv(cSetItem, "r_vmax", "VMAXTYPE", "r_vmax = vmaxget()", NIL);
2264
 
    Wrapper_add_local(cSetItem, "r_nprotect", "int r_nprotect = 0");
2265
 
 
2266
 
    Wrapper_add_local(cSetItem, "ptr", tmp);
2267
 
    Wrapper_add_local(cSetItem, "value", tmp1);
2268
 
    Replaceall(tmp, "*ptr", "*el = &value");
2269
 
    Wrapper_add_local(cSetItem, "el", tmp);
2270
 
 
2271
 
    Printf(cSetItem->code, 
2272
 
           "ptr = (%s *) R_SWIG_resolveExternalRef(s_x, \"\", \"s_x\", 0);\n", 
2273
 
           SwigType_lstr(base, 0));
2274
 
 
2275
 
 
2276
 
    String *tm = Swig_typemap_lookup_new("in", n, "value", 0);
2277
 
    if(tm) {
2278
 
      String *rclassName = getRClassName(base);
2279
 
      String *rclassBase = getRClassName(base, 0);
2280
 
      Replaceall(tm, "$input", "s_value");
2281
 
      Replaceall(tm, "$*1", "value");
2282
 
      //XXX think about what we really mean here.
2283
 
      Replaceall(tm, "$1", "el");
2284
 
 
2285
 
      Replaceall(tm, "$R_class", rclassName);
2286
 
      Replaceall(tm, "$*R_class", rclassBase);
2287
 
 
2288
 
      Printf(cSetItem->code, "%s\n", tm);
2289
 
 
2290
 
      Delete(rclassName); Delete(rclassBase);
2291
 
    }
2292
 
    Printf(cSetItem->code, "ptr[INTEGER(s_i)[0]] = *el;\n");
2293
 
  }
2294
 
  Printf(cSetItem->code, "%s\nreturn R_NilValue;\n}\n\n", UnProtectWrapupCode);
2295
 
 
2296
 
  /*************************/
2297
 
 
2298
 
 
2299
 
  Wrapper_print(cGetItem, f_wrapper);
2300
 
  Wrapper_print(cSetItem, f_wrapper);
2301
 
 
2302
 
  String *elClass = NewStringf("_p%s", SwigType_manglestr(base));
2303
 
  if(!Getattr(SClassDefs, elClass)) {
2304
 
    if (debugMode)
2305
 
      Printf(stderr, "<defineArrayAccessors> Defining class %s\n", elClass);
2306
 
    Printf(s_classes, "setClass('%s', contains = 'ExternalReference')\n", elClass);       
2307
 
    //Add to namespace
2308
 
    Setattr(SClassDefs, elClass, elClass);
2309
 
  }
2310
 
  Delete(elClass);
2311
 
 
2312
 
  if(!Getattr(SClassDefs, rclassName)) {
2313
 
    Setattr(SClassDefs, rclassName, rclassName);
2314
 
    Printf(s_classes, "setClass('%s', contains = 'SWIGArray')\n", rclassName);
2315
 
  }
2316
 
 
2317
 
  Printf(s_classes, "setMethod('[', '%s',\n%s)\n", rclassName, getItem);
2318
 
  Printf(s_classes, "setMethod('[<-', '%s',\n%s)\n", rclassName, setItem);
2319
 
 
2320
 
 
2321
 
  Delete(n); 
2322
 
  DelWrapper(cGetItem);
2323
 
  DelWrapper(cSetItem);
2324
 
  Delete(rclass);
2325
 
  Delete(cGetName);
2326
 
 
2327
 
  return SWIG_OK;
2328
 
}
2329
 
 
2330
 
 
2331
2172
/*****************************************************
2332
2173
 Add the specified routine name to the collection of 
2333
2174
 generated routines that are called from R functions.
2493
2334
      String *tp;
2494
2335
 
2495
2336
      elName = Getattr(c, "name");
 
2337
 
2496
2338
      String *elKind = Getattr(c, "kind");
2497
2339
      if (Strcmp(elKind, "variable") != 0) {
2498
2340
        c = nextSibling(c);
2505
2347
#if 0
2506
2348
      tp = getRType(c);
2507
2349
#else
2508
 
      tp = Swig_typemap_lookup_new("rtype", c, "", 0);
 
2350
      tp = Swig_typemap_lookup("rtype", c, "", 0);
2509
2351
      if(!tp) {
2510
2352
        c = nextSibling(c);
2511
2353
        continue;
2532
2374
      //            Printf(stderr, "<classDeclaration> elType %p\n", elType);
2533
2375
      //            tp = getRClassNameCopyStruct(Getattr(c, "type"), 1);
2534
2376
#endif
2535
 
 
2536
 
      Printf(def, "%s%s = \"%s\"", tab8, elName, tp);
 
2377
      String *elNameT = replaceInitialDash(elName);
 
2378
      Printf(def, "%s%s = \"%s\"", tab8, elNameT, tp);
2537
2379
      firstItem = false;
2538
2380
      Delete(tp);
 
2381
      Delete(elNameT);
2539
2382
      c = nextSibling(c);
2540
2383
    }
2541
2384
    Printf(def, "),\n%scontains = \"RSWIGStruct\")\n", tab8);
2562
2405
  in all cases.
2563
2406
*/
2564
2407
 
2565
 
// This procedure is for reference
2566
 
int R::generateCopyRoutinesObsolete(Node *n) {
2567
 
  Wrapper *toC = NewWrapper();
2568
 
  Wrapper *toCRef = NewWrapper();
2569
 
  Wrapper *toR = NewWrapper();
2570
 
 
2571
 
  Wrapper *copyToR = NewWrapper();
2572
 
  Wrapper *copyToC = NewWrapper();
2573
 
 
2574
 
  
2575
 
  String *name = Getattr(n, "name");
2576
 
  String *tdname = Getattr(n, "tdname");
2577
 
  String *kind = Getattr(n, "kind");
2578
 
  String *type;
2579
 
 
2580
 
  if(Len(tdname)) {
2581
 
    type = Copy(tdname);
2582
 
  } else {
2583
 
    type = NewStringf("%s %s", kind, name);
2584
 
  }
2585
 
  
2586
 
 
2587
 
#ifdef R_SWIG_VERBOSE
2588
 
  if (debugMode)
2589
 
    Printf(stderr, "generateCopyRoutines:  name = %s, %s\n", name, type);
2590
 
#endif
2591
 
 
2592
 
  String *rclassNameRef = getRClassName(type, 1); 
2593
 
  String *copyRefRefName = NewStringf("R_swig_copy_%sRef_%sRef", rclassNameRef, rclassNameRef);
2594
 
  String *toCName = NewStringf("R_swig_copy_%sRef_to_C", name);
2595
 
  String *toRName = NewStringf("R_swig_copy_%sRef_to_R", name);
2596
 
 
2597
 
  addRegistrationRoutine(copyRefRefName, 2);
2598
 
  addRegistrationRoutine(toCName, 2);
2599
 
  addRegistrationRoutine(toRName, 1);
2600
 
 
2601
 
  Printf(toC->def, "int\n%s(SEXP sobj, %s *value)", toCName, type);
2602
 
  Printf(toR->def, "SEXP\n%s(%s *value)", toRName, type);
2603
 
  Printf(toCRef->def, "SEXP\n%s(SEXP s_src, SEXP s_dest) {", copyRefRefName);
2604
 
 
2605
 
  Delete(toCName);
2606
 
  Delete(toRName);
2607
 
 
2608
 
  String *tmp = NewStringf("%s *src", type);
2609
 
  Wrapper_add_local(toCRef, "src", tmp);
2610
 
  Delete(tmp);
2611
 
  tmp = NewStringf("%s *dest", type);
2612
 
  Wrapper_add_local(toCRef, "dest", tmp);
2613
 
  Delete(tmp);
2614
 
 
2615
 
  Printf(toCRef->code, "src = (%s *) R_SWIG_resolveExternalRef(s_src, \"%sRef\", \"s_src\", (Rboolean) FALSE);\n",
2616
 
         type, rclassNameRef);
2617
 
  Printf(toCRef->code, "dest = (%s *) R_SWIG_resolveExternalRef(s_dest, \"%sRef\", \"s_dest\", (Rboolean) FALSE);\n",
2618
 
         type, rclassNameRef);
2619
 
  Printf(toCRef->code, "memcpy(dest, src, sizeof(*src));\nreturn R_NilValue;\n}\n\n");
2620
 
 
2621
 
 
2622
 
 
2623
 
  Wrapper_add_localv(toR, "r_obj", "SEXP", "r_obj", NIL);
2624
 
  Wrapper_add_localv(toR, "r_vmax", "VMAXTYPE", "r_vmax = vmaxget()", NIL);
2625
 
  Wrapper_add_localv(toR, "_tmp_sexp", "SEXP", "_tmp_sexp", NIL);
2626
 
  Wrapper_add_local(toR, "r_nprotect", "int r_nprotect = 0");
2627
 
  Wrapper_add_local(toC, "ecode", "int ecode = 0");
2628
 
 
2629
 
  Printf(copyToR->def, "%sCopyToR = function(value, obj = new(\"%s\"))\n{\n", name, name);
2630
 
  Printf(copyToC->def, "%sCopyToC = function(value, obj)\n{\n", name);
2631
 
 
2632
 
 
2633
 
  Printf(toR->code, "Rf_protect(r_obj = NEW_OBJECT(MAKE_CLASS(\"%s\")));\nr_nprotect++;\n\n", name);
2634
 
 
2635
 
  Wrapper_add_localv(toC, "_tmp_sexp", "SEXP", "_tmp_sexp", NIL);
2636
 
 
2637
 
  Node *c = firstChild(n);
2638
 
  //  Swig_typemap_attach_parms("in", c, toR);
2639
 
  // Swig_typemap_attach_parms("out", c, toR);
2640
 
 
2641
 
  for(; c; c = nextSibling(c)) {
2642
 
    String *elName = Getattr(c, "name");
2643
 
    if (!Len(elName)) {
2644
 
      continue;
2645
 
    }
2646
 
    String *tp = Swig_typemap_lookup_new("rtype", c, "", 0);
2647
 
    if(!tp) {
2648
 
      continue;
2649
 
    }
2650
 
    /* The S functions to get and set the member value. */
2651
 
    String *symname = Getattr(c, "sym:name");
2652
 
    String *ClassPrefix = Getattr(n, "sym:name");
2653
 
    String *get = Swig_name_get(Swig_name_member(Char(ClassPrefix), symname));
2654
 
    String *set = Swig_name_set(Swig_name_member(Char(ClassPrefix), symname));
2655
 
 
2656
 
 
2657
 
#if 0
2658
 
    This is already done now in getRType().
2659
 
      If that for some reason no longer gets called, this had better go back.
2660
 
                         SwigType *elTT = Getattr(c, "type");
2661
 
    SwigType *decl = Getattr(c, "decl");
2662
 
    SwigType_push(elTT, decl);
2663
 
#endif
2664
 
 
2665
 
 
2666
 
    Printf(copyToR->code, "obj@%s = %s(value)\n", elName, get);
2667
 
    Printf(copyToC->code, "%s(obj, value@%s)\n", set, elName);
2668
 
 
2669
 
 
2670
 
    String *field = NewStringf("value->%s", elName);
2671
 
    SwigType *elType = Getattr(c, "type");
2672
 
 
2673
 
 
2674
 
    String *tm = Swig_typemap_lookup_new("out", c, field, 0);
2675
 
    if(tm) {
2676
 
#ifdef R_SWIG_VERBOSE
2677
 
      if (debugMode)
2678
 
        Printf(stderr, "Got conversion to R for '%s': '%s' '%s' -> '%s'\n", elName, elType, elTT, tm);
2679
 
#endif
2680
 
 
2681
 
      //XXX Get the field in as the rhs.
2682
 
      // What about looking in the "memberin"/"memberout" typemaps.
2683
 
      Replaceall(tm, "$1", Char(field));
2684
 
      Replaceall(tm, "$result", "_tmp_sexp");
2685
 
      Replaceall(tm,"$owner", "R_SWIG_EXTERNAL");
2686
 
      replaceRClass(tm,elType);
2687
 
 
2688
 
 
2689
 
      Printf(toR->code, "%s\nRf_protect(_tmp_sexp);\nr_nprotect++;\n", tm);
2690
 
      Printf(toR->code, "Rf_protect(r_obj = R_do_slot_assign(r_obj, Rf_mkString(\"%s\"), _tmp_sexp));\nr_nprotect++;\n\n", elName);
2691
 
    } else {
2692
 
      Printf(stderr, "*** Can't convert field %s in \n", elName);
2693
 
    }
2694
 
 
2695
 
 
2696
 
 
2697
 
    char *field_p = Char(field);
2698
 
    tm = Swig_typemap_lookup_new("in", c, field_p, 0);
2699
 
    if(tm && !GetFlag(c, "feature:immutable")) {
2700
 
      replaceRClass(tm,elType);
2701
 
      if (debugMode)
2702
 
        Printf(stderr, "typemap (in) for %s => %s\n", 
2703
 
               SwigType_str(elType, 0), tm);
2704
 
      String *tmp1 = 
2705
 
        NewStringf("%s val", SwigType_lstr(elType, 0));
2706
 
      Wrapper_add_local(toC, "val", tmp1);
2707
 
      Replaceall(tm, "$input", "_tmp_sexp");
2708
 
      if (debugMode)
2709
 
        Printf(stderr, "Got conversion to C for %s: %s.   %s\n", 
2710
 
               elName, tm, field);
2711
 
#ifdef R_SWIG_VERBOSE
2712
 
#endif
2713
 
      Printf(toC->code, "_tmp_sexp = GET_SLOT(sobj, Rf_mkString(\"%s\"));\n%s\n\n", elName, tm);
2714
 
      Delete(field);
2715
 
    }
2716
 
    /*
2717
 
 
2718
 
    Replaceall(conversion, "$1", field);
2719
 
    Printf(toC->code, "value->%s = ;\n", name);
2720
 
    */
2721
 
  }
2722
 
 
2723
 
  Printv(toR->code, UnProtectWrapupCode,
2724
 
         "\nreturn(r_obj);\n}\n", NIL);
2725
 
 
2726
 
  Printf(toC->code, "\nreturn(1);\n}\n");
2727
 
 
2728
 
 
2729
 
  Printf(f_wrapper, "%s;\n", toR->def);
2730
 
  Printf(f_wrapper, "%s;\n", toC->def);
2731
 
 
2732
 
  Printf(toR->def, "\n{\n");
2733
 
  Printf(toC->def, "\n{\n");
2734
 
 
2735
 
  String *rclassName = getRClassName(type, 0); // without the Ref.
2736
 
 
2737
 
  Printf(copyToR->code, "obj\n}\n\n");
2738
 
 
2739
 
  Printf(sfile, "# Start definition of copy functions & methods for %s\n", rclassName);  
2740
 
 
2741
 
  Wrapper_print(copyToR, sfile);
2742
 
  Printf(copyToC->code, "obj\n}\n\n");
2743
 
  Wrapper_print(copyToC, sfile);
2744
 
 
2745
 
 
2746
 
  Printf(sfile, "# Start definition of copy methods for %s\n", rclassName);  
2747
 
  Printf(sfile, "setMethod('copyToR', '%sRef', %sCopyToR)\n", rclassName, name);
2748
 
  Printf(sfile, "setMethod('copyToC', '%s', %sCopyToC)\n\n", rclassName, name);
2749
 
  Printv(sfile, "setMethod('copyToC', c('", rclassName, "Ref', '", rclassName, "Ref'),",
2750
 
         " function(value, obj) {\n",
2751
 
         tab4, ".Call(\"", copyRefRefName, "\", value, obj, PACKAGE = \"",
2752
 
         Rpackage, "\")\n})\n\n", NIL);
2753
 
  Printf(sfile, "# End definition of copy methods for %s\n", rclassName);  
2754
 
  Printf(sfile, "# End definition of copy functions & methods for %s\n", rclassName);  
2755
 
 
2756
 
  String *m = NewStringf("%sCopyToR", name);
2757
 
  addNamespaceMethod(m);
2758
 
  char *tt = Char(m);  tt[Len(m)-1] = 'C';
2759
 
  addNamespaceMethod(m);
2760
 
  Delete(m);
2761
 
 
2762
 
 
2763
 
  Delete(rclassName);
2764
 
 
2765
 
  DelWrapper(copyToR);
2766
 
  DelWrapper(copyToC);
2767
 
 
2768
 
  Wrapper_print(toR, f_wrapper);
2769
 
  Wrapper_print(toC, f_wrapper);
2770
 
  Wrapper_print(toCRef, f_wrapper);
2771
 
 
2772
 
  DelWrapper(toR);
2773
 
  DelWrapper(toC);
2774
 
  DelWrapper(toCRef);
2775
 
 
2776
 
  return SWIG_OK;
2777
 
}
2778
 
 
2779
2408
int R::generateCopyRoutines(Node *n) {
2780
2409
  Wrapper *copyToR = NewWrapper();
2781
2410
  Wrapper *copyToC = NewWrapper();
2814
2443
      continue;
2815
2444
    }
2816
2445
 
2817
 
    String *tp = Swig_typemap_lookup_new("rtype", c, "", 0);
 
2446
    String *tp = Swig_typemap_lookup("rtype", c, "", 0);
2818
2447
    if(!tp) {
2819
2448
      continue;
2820
2449
    }
2828
2457
 
2829
2458
 
2830
2459
    /* The S functions to get and set the member value. */
2831
 
    Printf(copyToR->code, "obj@%s = value$%s\n", elName, elName);
2832
 
    Printf(copyToC->code, "obj$%s = value@%s\n", elName, elName);
 
2460
    String *elNameT = replaceInitialDash(elName);
 
2461
    Printf(copyToR->code, "obj@%s = value$%s\n", elNameT, elNameT);
 
2462
    Printf(copyToC->code, "obj$%s = value@%s\n", elNameT, elNameT);
 
2463
    Delete(elNameT);
2833
2464
  }
2834
2465
  Printf(copyToR->code, "obj\n}\n\n");
2835
2466
  String *rclassName = getRClassNameCopyStruct(type, 0); // without the Ref.