GPL + CeCILL Header change
[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 "internal.hxx"
31 #include "callable.hxx"
32 #include "list.hxx"
33 #include "double.hxx"
34 #include "function.hxx"
35
36 extern "C"
37 {
38 #include "sciblk2.h"
39 #include "scicos.h" /* set_block_error() */
40 }
41
42 static double toDouble(const int i)
43 {
44     return static_cast<double>(i);
45 }
46
47 static void setErrAndFree(const int flag, types::typed_list out)
48 {
49     set_block_error(flag);
50     for (size_t i = 0; i < out.size(); ++i)
51     {
52         out[i]->killMe();
53     }
54 }
55
56 /*--------------------------------------------------------------------------*/
57 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,
58              int ipar[], int* nipar, double* inptr[], int insz[], int* nin, double* outptr[], int outsz[], int* nout, void* scsptr)
59 {
60     types::typed_list in(8), out;
61
62     types::Double* Flag = new types::Double(*flag);
63     in[0] = Flag;
64
65     types::Double* Nevprt = new types::Double(*nevprt);
66     in[1] = Nevprt;
67
68     types::Double* T = new types::Double(*t);
69     in[2] = T;
70
71     types::Double* X = new types::Double(*nx, 1);
72     memcpy(X->get(), x, *nx * sizeof(double));
73     in[3] = X;
74
75     types::InternalType* Z;
76     if (*nz == 0)
77     {
78         Z = types::Double::Empty();
79     }
80     else
81     {
82         if (!vec2var(std::vector<double>(z, z + *nz), Z))
83         {
84             setErrAndFree(-1, out);
85             delete in[0];
86             delete in[1];
87             delete in[2];
88             delete in[3];
89             return;
90         }
91         if (!Z->isDouble())
92         {
93             setErrAndFree(-1, out);
94             delete in[0];
95             delete in[1];
96             delete in[2];
97             delete in[3];
98             return;
99         }
100         //types::Double* Z = new types::Double(*nz, 1);
101         //memcpy(Z->get(), z, *nz * sizeof(double));
102     }
103     in[4] = Z->getAs<types::Double>();
104
105     types::Double* Rpar = new types::Double(*nrpar, 1);
106     memcpy(Rpar->get(), rpar, *nrpar * sizeof(double));
107     in[5] = Rpar;
108
109     // Treating 'ipar' differently because it is an int tab, unlike the other double ones
110     types::Double* Ipar = new types::Double(*nipar, 1);
111     std::transform(ipar, ipar + *nipar, Ipar->get(), toDouble);
112     in[6] = Ipar;
113
114     types::List* Nin = new types::List();
115     for (int i = 0; i < *nin; ++i)
116     {
117         int nu = insz[i];
118         int nu2 = insz[*nin + i];
119         types::Double* U = new types::Double(nu, nu2);
120         memcpy(U->get(), inptr[i], nu * nu2 * sizeof(double));
121         Nin->append(U);
122     }
123     in[7] = Nin;
124
125     /***********************
126     * Call Scilab function *
127     ***********************/
128     types::Callable* pCall = static_cast<types::Callable*>(scsptr);
129
130     try
131     {
132         types::optional_list opt;
133         if (pCall->call(in, opt, 5, out) != types::Function::OK)
134         {
135             setErrAndFree(-1, out);
136             return;
137         }
138
139         if (out.size() != 5)
140         {
141             setErrAndFree(-1, out);
142             return;
143         }
144     }
145     catch (const ast::InternalError& /*ie*/)
146     {
147         setErrAndFree(-1, out);
148         return;
149     }
150
151     switch (*flag)
152     {
153         case 1 :
154         case 2 :
155         case 4 :
156         case 5 :
157         case 6 :
158         {
159             if (!out[2]->isDouble())
160             {
161                 setErrAndFree(-1, out);
162                 return;
163             }
164             std::vector<double> Zout;
165             if (!var2vec(out[2], Zout))
166             {
167                 setErrAndFree(-1, out);
168                 return;
169             }
170             memcpy(z, &Zout[0], *nz * sizeof(double));
171
172             if (!out[3]->isDouble())
173             {
174                 setErrAndFree(-1, out);
175                 return;
176             }
177             types::Double* Xout = out[3]->getAs<types::Double>();
178             memcpy(x, Xout->get(), *nx * sizeof(double));
179
180             if (*flag == 1 || *flag == 6)
181             {
182                 if (*nout != 0)
183                 {
184                     if (!out[4]->isList())
185                     {
186                         setErrAndFree(-1, out);
187                         return;
188                     }
189                     types::List* Yout = out[4]->getAs<types::List>();
190                     if (Yout->getSize() < *nout)
191                     {
192                         // Consider that 'outptr' has not been defined in the macro: do not update the current 'outptr'
193                         break;
194                     }
195                     for (int k = *nout - 1; k >= 0; --k)
196                     {
197                         if (!Yout->get(k)->isDouble())
198                         {
199                             setErrAndFree(-1, out);
200                             return;
201                         }
202                         types::Double* KthElement = Yout->get(k)->getAs<types::Double>();
203                         double* y = (double*)outptr[k];
204                         int ny = outsz[k];
205                         int ny2 = 1;
206                         if (*flag == 1)
207                         {
208                             ny2 = outsz[*nout + k];
209                         }
210                         if (KthElement->getSize() != ny * ny2)
211                         {
212                             // At initialization (flag 6), the 'y' returned by the macro is not necessarily properly initialized.
213                             // In this case, do nothing to avoid copying corrupt data
214                             break;
215                         }
216                         memcpy(y, KthElement->get(), ny * ny2 * sizeof(double));
217                     }
218                 }
219             }
220             break;
221         }
222
223         case 0 :
224             /*  x'  computation */
225         {
226             if (!out[0]->isDouble())
227             {
228                 setErrAndFree(-1, out);
229                 return;
230             }
231             types::Double* XDout = out[0]->getAs<types::Double>();
232             memcpy(xd, XDout->get(), *nx * sizeof(double));
233             break;
234         }
235
236         case 3 :
237         {
238             if (!out[1]->isDouble())
239             {
240                 setErrAndFree(-1, out);
241                 return;
242             }
243             types::Double* Tout = out[1]->getAs<types::Double>();
244             memcpy(tvec, Tout->get(), *ntvec * sizeof(double));
245             break;
246         }
247
248         default :
249         {
250             setErrAndFree(-1, out);
251             return;
252         }
253     }
254
255     for (size_t i = 0; i < out.size(); ++i)
256     {
257         out[i]->killMe();
258     }
259 }