source: tol/rtol/source/tolRlink.cpp @ a53fb9c

1941-docker-image-to-testdevel
Last change on this file since a53fb9c was a53fb9c, checked in by Pedro Gea <pgea@…>, 10 years ago

Refs #1941
Se revisan las funciones RTolSetXxx. Se añade el uso de R_concat para poder decompilarlas.
Se añade la función para crear matrices.

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@7389 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 9.2 KB
Line 
1
2/* Microsoft stdext::hash_map */
3  #define __HASH_MAP_MSVC__    1
4/* google::dense_hash_map and google::sparse_hash_map */
5  #define __HASH_MAP_GOOGLE__  2
6/* The used hashing handler */
7  #define __USE_HASH_MAP__   __HASH_MAP_GOOGLE__
8
9#undef BIGGEST_FIELD_ALIGNMENT
10#define BIGGEST_FIELD_ALIGNMENT 4
11
12#include <string.h>
13#include <tol/tol_init.h>
14#include <tol/tol_bfsmem.h>
15#include <tol/tol_bmatgra.h>
16#include <tol/tol_blanguag.h>
17#include <tol/tol_bdatgra.h>
18#include <tol/tol_btxtgra.h>
19#include <tol/tol_bdate.h>
20#include <tol/tol_bdtegra.h>
21
22#ifdef UNIX
23  #define DLLEXPORT(f) f
24#else
25  #define DLLEXPORT(f) __declspec(dllexport) f
26#endif
27
28#include <R.h>
29
30extern "C" DLLEXPORT(void) RInitTolKernel(void);
31 
32//////////////////////////////////////////////////////////////////////////////
33
34extern BList R_stack;
35void R_concat(BList* head, BList* tail);
36
37BList R_stack;
38
39//----------------------------------------------------------------------------
40void R_concat(BList* head, BList* tail)
41//----------------------------------------------------------------------------
42{
43  if (head->Cdr()) {
44    R_concat(head->Cdr(), tail);
45  }
46  else {
47    head->PutCdr(tail);
48  }
49}
50
51//----------------------------------------------------------------------------
52extern "C" DLLEXPORT(void) RTolCompile(char **name, int *ok)
53//----------------------------------------------------------------------------
54{
55  if(TOLHasBeenInitialized()==0) RInitTolKernel();
56  char* str_lvalue = (char*)*name;
57  BSyntaxObject * so = GraAnything()->EvaluateExpr(str_lvalue);
58  if (so) {
59    BList* result = NIL;
60    BList* aux = NIL;
61    LstFastAppend(result, aux, so);
62    R_concat(&R_stack, result);
63    *ok = 1;
64  }
65  else {
66    *ok = 0;
67  }
68}
69
70//----------------------------------------------------------------------------
71extern "C" DLLEXPORT(void) RTolDecompile(char **name)
72//----------------------------------------------------------------------------
73{
74  char* str_name = (char*)*name;
75  BList *P = R_stack.Cdr(), *prev = &R_stack;
76  short found = 0;
77 
78  while (!found && P) {
79    BSyntaxObject * so = (BSyntaxObject*)(P->Car());
80    const char* object_name = so->Name().String();
81    if (!strcmp(object_name, str_name)) {
82          prev->PutCdr(P->Cdr());
83      delete P;
84      DESTROY(so);
85      found = 1;
86          break;
87    }
88        prev = P;
89    P = P->Cdr();
90  }
91}
92
93//////////////////////////////////////////////////////////////////////////////
94
95//----------------------------------------------------------------------------
96extern "C" DLLEXPORT(void) RTOLVersion(char **version)
97//----------------------------------------------------------------------------
98{
99  *version = (char*)TOLVersion();
100}
101
102//----------------------------------------------------------------------------
103extern "C" DLLEXPORT(void) RTOLHasBeenInitialized(int *initialized)
104//----------------------------------------------------------------------------
105{
106  *initialized = TOLHasBeenInitialized();
107}
108
109//----------------------------------------------------------------------------
110extern "C" DLLEXPORT(void) RInitTolKernel(void)
111//----------------------------------------------------------------------------
112{
113  InitTolKernel(NULL, 0, "vA");
114  LoadInitLibrary(true, true);
115}
116
117//////////////////////////////////////////////////////////////////////////////
118
119//----------------------------------------------------------------------------
120extern "C" DLLEXPORT(void) RTolGetReal(char **name, double *value)
121//----------------------------------------------------------------------------
122{
123  if(TOLHasBeenInitialized()==0) RInitTolKernel();
124  char* str_lvalue = (char*)*name;
125  BSyntaxObject * so = GraReal()->EvaluateExpr(str_lvalue);
126  if (so) {
127    BDat & d = Dat(so);
128    *value = d.Value();
129    DESTROY(so);
130  }
131  else {
132    error("Real expression '%s' is not valid", str_lvalue);
133  }
134}
135
136//----------------------------------------------------------------------------
137extern "C" DLLEXPORT(void) RTolGetText(char **name, char **value)
138//----------------------------------------------------------------------------
139{
140  if(TOLHasBeenInitialized()==0) RInitTolKernel();
141  char* str_lvalue = (char*)*name;
142  BSyntaxObject * so = GraText()->EvaluateExpr(str_lvalue);
143  if (so) {
144    BText & d = Text(so);
145    *value = (char *)(d.String());
146    DESTROY(so);
147  }
148  else {
149    error("Text expression '%s' is not valid", str_lvalue);
150  }
151}
152
153//----------------------------------------------------------------------------
154extern "C" DLLEXPORT(void) RTolGetDate(char **name, double *value)
155//----------------------------------------------------------------------------
156{
157  if(TOLHasBeenInitialized()==0) RInitTolKernel();
158  char* str_lvalue = (char*)*name;
159  BSyntaxObject * so = GraDate()->EvaluateExpr(str_lvalue);
160  if (so) {
161    BDate & d = Date(so);
162    *value = (double)(d.Index());
163    DESTROY(so);
164  }
165  else {
166    error("Date expression '%s' is not valid", str_lvalue);
167  }
168}
169
170//----------------------------------------------------------------------------
171extern "C" DLLEXPORT(void) RTolGetMatrix(char **name, double *value)
172//----------------------------------------------------------------------------
173{
174  if(TOLHasBeenInitialized()==0) RInitTolKernel();
175  char* str_lvalue = (char*)*name;
176  BSyntaxObject * so = GraMatrix()->EvaluateExpr(str_lvalue);
177  if (so) {
178    BMat & m = Mat(so);
179    int cols = m.Columns();
180    int rows = m.Rows();       
181    for (int c=0; c<cols; ++c) {
182      for (int r=0; r<rows; ++r) {
183        BDat & d = m(r, c);
184        value[c*rows+r] = d.Value();
185      }
186    }
187    DESTROY(so);
188  }
189  else {
190    error("Matrix expression '%s' is not valid", str_lvalue);
191  }
192}
193
194//////////////////////////////////////////////////////////////////////////////
195
196//----------------------------------------------------------------------------
197extern "C" DLLEXPORT(void) RTolSetReal(char **name, int *type, double *value, int *ok)
198//----------------------------------------------------------------------------
199{
200  if(TOLHasBeenInitialized()==0) RInitTolKernel();
201  char* str_name = (char*)*name;
202  BDat d;
203  if(*type == 0) {
204    d.PutValue(*value);
205  } else if(*type == 2) {
206    d.PutValue(BDat::PosInf());
207  } else if(*type == 3) {
208    d.PutValue(BDat::NegInf());
209  } else { // type 1
210    d.PutKnown(BUNKNOWN);
211  }
212  BSyntaxObject * so = new BContensDat(str_name, d, "");
213  if (so) {
214    BList* result = NIL;
215    BList* aux = NIL;
216    LstFastAppend(result, aux, so);
217    R_concat(&R_stack, result);   
218    *ok = 1;
219  }
220  else {
221    *ok = 0;
222  }
223}
224
225//----------------------------------------------------------------------------
226extern "C" DLLEXPORT(void) RTolSetText(char **name, char **value, int *ok)
227//----------------------------------------------------------------------------
228{
229  if(TOLHasBeenInitialized()==0) RInitTolKernel();
230  char* str_name = (char*)*name;
231  char* str_value = (char*)*value;
232  BSyntaxObject * so = new BContensText(str_name, str_value, "");
233  if (so) {
234    BList* result = NIL;
235    BList* aux = NIL;
236    LstFastAppend(result, aux, so);
237    R_concat(&R_stack, result);   
238    *ok = 1;
239  }
240  else {
241    *ok = 0;
242  }
243}
244
245//----------------------------------------------------------------------------
246extern "C" DLLEXPORT(void) RTolSetDate(char **name, int *type, double *value, int *ok)
247//----------------------------------------------------------------------------
248{
249  if(TOLHasBeenInitialized()==0) RInitTolKernel();
250  char* str_name = (char*)*name;
251  BDate d;
252  if(*type == 0) {
253    d.PutIndex(*value);
254  } else if(*type == 2) {
255    d.PutIndex(219147); // End
256  } else if(*type == 3) {
257    d.PutIndex(-115782); // Begin
258  } else { // type 1
259    d.PutIndex(-300000); // Unknown
260  }
261  BSyntaxObject * so = new BContensDate(str_name, d, "");
262  if (so) {
263    BList* result = NIL;
264    BList* aux = NIL;
265    LstFastAppend(result, aux, so);
266    R_concat(&R_stack, result);   
267    *ok = 1;
268  }
269  else {
270    *ok = 0;
271  }
272}
273
274//----------------------------------------------------------------------------
275extern "C" DLLEXPORT(void) RTolSetMatrix(char **name, int *rows, int *cols,
276  bool *mask, int *type, double *value, int *ok)
277//----------------------------------------------------------------------------
278{
279  if(TOLHasBeenInitialized()==0) RInitTolKernel();
280  char* str_name = (char*)*name;
281  BMat d(*rows, *cols);
282  for (int c=0; c< (*cols); ++c) {   
283    for (int r=0; r< (*rows); ++r) {
284      int p = c * (*rows) + r;
285      if(*mask) {
286        if(type[p] == 0) {
287          d(r, c).PutValue(value[p]);
288        } else if(type[p] == 2) {
289          d(r, c).PutValue(BDat::PosInf());
290        } else if(type[p] == 3) {
291          d(r, c).PutValue(BDat::NegInf());
292        } else { // type 1
293          d(r, c).PutKnown(BUNKNOWN);
294        }
295      } else {
296        d(r, c).PutValue(value[p]);
297      }
298    }
299  }
300  BSyntaxObject * so = new BContensMat(str_name, d, "");
301  if (so) {
302    BList* result = NIL;
303    BList* aux = NIL;
304    LstFastAppend(result, aux, so);
305    R_concat(&R_stack, result);   
306    *ok = 1;
307  }
308  else {
309    *ok = 0;
310  }
311}
312
313//////////////////////////////////////////////////////////////////////////////
314
Note: See TracBrowser for help on using the repository browser.