Update CHANGES.md before the release
[scilab.git] / scilab / modules / scicos / src / cpp / sciblk2.cpp
1 /*  Scicos
2 *
3 *  Copyright (C) 2015 - Scilab Enterprises - Paul Bignier
4 *  Copyright (C) INRIA - METALAU Project <scicos@inria.fr>
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, write to the Free Software
18 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
19 *
20 * See the file ./license.txt
21 */
22 /*--------------------------------------------------------------------------*/
23 #include <vector>
24 #include <algorithm>
25 #include <cstring>
26
27 #include "var2vec.hxx"
28 #include "vec2var.hxx"
29
30 #include "callable.hxx"
31 #include "configvariable.hxx"
32 #include "double.hxx"
33 #include "function.hxx"
34 #include "internal.hxx"
35 #include "list.hxx"
36 #include "scilabWrite.hxx"
37
38 extern "C"
39 {
40 #include "sciblk2.h"
41 #include "scicos.h" /* set_block_error() */
42 }
43
44 static double toDouble(const int i)
45 {
46     return static_cast<double>(i);
47 }
48
49 static void setErrAndFree(const int flag, types::typed_list out)
50 {
51     set_block_error(flag);
52     for (size_t i = 0; i < out.size(); ++i)
53     {
54         out[i]->killMe();
55     }
56 }
57
58 /*--------------------------------------------------------------------------*/
59 void sciblk2(int* flag, int* nevprt, double* t, double xd[], double x[], int* nx, double z[], int* nz, double tvec[], int* ntvec, double rpar[], int* nrpar,
60              int ipar[], int* nipar, double* inptr[], int insz[], int* nin, double* outptr[], int outsz[], int* nout, void* scsptr)
61 {
62     types::typed_list in(8), out;
63
64     types::Double* Flag = new types::Double(*flag);
65     in[0] = Flag;
66
67     types::Double* Nevprt = new types::Double(*nevprt);
68     in[1] = Nevprt;
69
70     types::Double* T = new types::Double(*t);
71     in[2] = T;
72
73     types::Double* X = new types::Double(*nx, 1);
74     memcpy(X->get(), x, *nx * sizeof(double));
75     in[3] = X;
76
77     types::InternalType* Z;
78     if (*nz == 0)
79     {
80         Z = types::Double::Empty();
81     }
82     else
83     {
84         if (!vec2var(std::vector<double>(z, z + *nz), Z))
85         {
86             setErrAndFree(-1, out);
87             delete in[0];
88             delete in[1];
89             delete in[2];
90             delete in[3];
91             return;
92         }
93         if (!Z->isDouble())
94         {
95             setErrAndFree(-1, out);
96             delete in[0];
97             delete in[1];
98             delete in[2];
99             delete in[3];
100             return;
101         }
102         //types::Double* Z = new types::Double(*nz, 1);
103         //memcpy(Z->get(), z, *nz * sizeof(double));
104     }
105     in[4] = Z->getAs<types::Double>();
106
107     types::Double* Rpar = new types::Double(*nrpar, 1);
108     memcpy(Rpar->get(), rpar, *nrpar * sizeof(double));
109     in[5] = Rpar;
110
111     // Treating 'ipar' differently because it is an int tab, unlike the other double ones
112     types::Double* Ipar = new types::Double(*nipar, 1);
113     std::transform(ipar, ipar + *nipar, Ipar->get(), toDouble);
114     in[6] = Ipar;
115
116     types::List* Nin = new types::List();
117     for (int i = 0; i < *nin; ++i)
118     {
119         int nu = insz[i];
120         int nu2 = insz[*nin + i];
121         types::Double* U = new types::Double(nu, nu2);
122         memcpy(U->get(), inptr[i], nu * nu2 * sizeof(double));
123         Nin->append(U);
124     }
125     in[7] = Nin;
126
127     /***********************
128     * Call Scilab function *
129     ***********************/
130     types::Callable* pCall = static_cast<types::Callable*>(scsptr);
131
132     ConfigVariable::increaseRecursion();
133     ConfigVariable::where_begin(1, 1, pCall);
134
135     types::optional_list opt;
136     types::Callable::ReturnValue Ret;
137
138     try
139     {
140         Ret = pCall->call(in, opt, 5, out);
141         ConfigVariable::where_end();
142         ConfigVariable::decreaseRecursion();
143
144         if (Ret != types::Function::OK)
145         {
146             setErrAndFree(-1, out);
147             return;
148         }
149
150         if (out.size() != 5)
151         {
152             setErrAndFree(-1, out);
153             return;
154         }
155     }
156     catch (const ast::InternalError &)
157     {
158         std::wostringstream ostr;
159         ConfigVariable::whereErrorToString(ostr);
160
161         bool oldSilentError = ConfigVariable::isSilentError();
162         ConfigVariable::setSilentError(false);
163         scilabErrorW(ostr.str().c_str());
164         ConfigVariable::setSilentError(oldSilentError);
165         ConfigVariable::resetWhereError();
166
167         ConfigVariable::where_end();
168         ConfigVariable::setLastErrorFunction(pCall->getName());
169         ConfigVariable::decreaseRecursion();
170
171         setErrAndFree(-1, out);
172         throw;
173     }
174
175     switch (*flag)
176     {
177         case 1 :
178         case 2 :
179         case 4 :
180         case 5 :
181         case 6 :
182         {
183             if (!out[2]->isDouble())
184             {
185                 setErrAndFree(-1, out);
186                 return;
187             }
188             std::vector<double> Zout;
189             if (!var2vec(out[2], Zout))
190             {
191                 setErrAndFree(-1, out);
192                 return;
193             }
194             memcpy(z, &Zout[0], *nz * sizeof(double));
195
196             if (!out[3]->isDouble())
197             {
198                 setErrAndFree(-1, out);
199                 return;
200             }
201             types::Double* Xout = out[3]->getAs<types::Double>();
202             memcpy(x, Xout->get(), *nx * sizeof(double));
203
204             if (*flag == 1 || *flag == 6)
205             {
206                 if (*nout != 0)
207                 {
208                     if (!out[4]->isList())
209                     {
210                         setErrAndFree(-1, out);
211                         return;
212                     }
213                     types::List* Yout = out[4]->getAs<types::List>();
214                     if (Yout->getSize() < *nout)
215                     {
216                         // Consider that 'outptr' has not been defined in the macro: do not update the current 'outptr'
217                         break;
218                     }
219                     for (int k = *nout - 1; k >= 0; --k)
220                     {
221                         if (!Yout->get(k)->isDouble())
222                         {
223                             setErrAndFree(-1, out);
224                             return;
225                         }
226                         types::Double* KthElement = Yout->get(k)->getAs<types::Double>();
227                         double* y = (double*)outptr[k];
228                         int ny = outsz[k];
229                         int ny2 = 1;
230                         if (*flag == 1)
231                         {
232                             ny2 = outsz[*nout + k];
233                         }
234                         if (KthElement->getSize() != ny * ny2)
235                         {
236                             // At initialization (flag 6), the 'y' returned by the macro is not necessarily properly initialized.
237                             // In this case, do nothing to avoid copying corrupt data
238                             break;
239                         }
240                         memcpy(y, KthElement->get(), ny * ny2 * sizeof(double));
241                     }
242                 }
243             }
244             break;
245         }
246
247         case 0 :
248             /*  x'  computation */
249         {
250             if (!out[0]->isDouble())
251             {
252                 setErrAndFree(-1, out);
253                 return;
254             }
255             types::Double* XDout = out[0]->getAs<types::Double>();
256             memcpy(xd, XDout->get(), *nx * sizeof(double));
257             break;
258         }
259
260         case 3 :
261         {
262             if (!out[1]->isDouble())
263             {
264                 setErrAndFree(-1, out);
265                 return;
266             }
267             types::Double* Tout = out[1]->getAs<types::Double>();
268             memcpy(tvec, Tout->get(), *ntvec * sizeof(double));
269             break;
270         }
271
272         default :
273         {
274             setErrAndFree(-1, out);
275             return;
276         }
277     }
278
279     for (size_t i = 0; i < out.size(); ++i)
280     {
281         out[i]->killMe();
282     }
283 }