* Bug 16365 fixed: median(m,'r'|'c') was wrong after 5dc990
[scilab.git] / scilab / modules / scicos / src / cpp / sciblk4.cpp
1 /*  Scicos
2 *
3 *  Copyright (C) 2015 - Scilab Enterprises - Antoine ELIAS
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 <cstring>
24 #include <cstdio>
25
26 #include "internal.hxx"
27 #include "callable.hxx"
28 #include "list.hxx"
29 #include "tlist.hxx"
30 #include "double.hxx"
31 #include "int.hxx"
32 #include "function.hxx"
33 #include "scilabWrite.hxx"
34
35 extern "C"
36 {
37 #include "sciblk4.h"
38 #include "scicos.h"
39 #include "import.h"
40 }
41
42 #include "createblklist.hxx"
43
44 /*--------------------------------------------------------------------------*/
45 template <typename T>
46 bool sci2var(T* p, void* dest, const int row, const int col)
47 {
48     const int size = p->getSize();
49     typename T::type* srcR = p->get();
50
51     if (row != p->getRows())
52     {
53         return false;
54     }
55
56     if (col != p->getCols())
57     {
58         return false;
59     }
60
61     if (p->isComplex())
62     {
63         typename T::type* srcI = p->getImg();
64         if (dest == nullptr)
65         {
66             return false;
67         }
68
69         typename T::type* destR = (typename T::type*)dest;
70         typename T::type* destI = destR + size;
71         for (int i = 0; i < size; ++i)
72         {
73             destR[i] = srcR[i];
74             destI[i] = srcI[i];
75         }
76     }
77     else
78     {
79         if (dest == nullptr)
80         {
81             return false;
82         }
83
84         typename T::type* destR = (typename T::type*)dest;
85         for (int i = 0; i < size; ++i)
86         {
87             destR[i] = srcR[i];
88         }
89     }
90
91     return true;
92 }
93
94 /*--------------------------------------------------------------------------*/
95 static bool sci2var(types::InternalType* p, void* dest, const int desttype, const int row, const int col)
96 {
97     switch (p->getType())
98     {
99         case types::InternalType::ScilabDouble:
100         {
101             if (p->getAs<types::Double>()->isComplex() && desttype == SCSCOMPLEX_N)
102             {
103                 return sci2var(p->getAs<types::Double>(), dest, row, col);
104             }
105
106             if (p->getAs<types::Double>()->isComplex() == false && desttype == SCSREAL_N)
107             {
108                 return sci2var(p->getAs<types::Double>(), dest, row, col);
109             }
110         }
111         case types::InternalType::ScilabInt8:
112         {
113             if (desttype == SCSINT8_N)
114             {
115                 return sci2var(p->getAs<types::Int8>(), dest, row, col);
116             }
117         }
118         case types::InternalType::ScilabInt16:
119         {
120             if (desttype == SCSINT16_N)
121             {
122                 return sci2var(p->getAs<types::Int16>(), dest, row, col);
123             }
124         }
125         case types::InternalType::ScilabInt32:
126         {
127             if (desttype == SCSINT32_N)
128             {
129                 return sci2var(p->getAs<types::Int32>(), dest, row, col);
130             }
131         }
132         case types::InternalType::ScilabUInt8:
133         {
134             if (desttype == SCSUINT8_N)
135             {
136                 return sci2var(p->getAs<types::UInt8>(), dest, row, col);
137             }
138         }
139         case types::InternalType::ScilabUInt16:
140         {
141             if (desttype == SCSUINT16_N)
142             {
143                 return sci2var(p->getAs<types::UInt16>(), dest, row, col);
144             }
145         }
146         case types::InternalType::ScilabUInt32:
147         {
148             if (desttype == SCSUINT32_N)
149             {
150                 return sci2var(p->getAs<types::UInt32>(), dest, row, col);
151             }
152         }
153         default:
154             return false;
155     }
156
157     return false;
158 }
159
160 /*--------------------------------------------------------------------------*/
161 static bool getDoubleArray(types::InternalType* p, double* dest)
162 {
163     if (p == nullptr)
164     {
165         return false;
166     }
167
168     if (p->isDouble())
169     {
170         types::Double* d = p->getAs<types::Double>();
171         const int size = d->getSize();
172         if (size == 0)
173         {
174             return true;
175         }
176
177         if (dest == nullptr)
178         {
179             return false;
180         }
181
182         memcpy(dest, d->get(), sizeof(double) * size);
183         return true;
184     }
185
186     return false;
187 }
188
189 /*--------------------------------------------------------------------------*/
190 static bool getDoubleArrayAsInt(types::InternalType* p, int* dest)
191 {
192     if (p == nullptr)
193     {
194         return false;
195     }
196
197     if (p->isDouble())
198     {
199         types::Double* d = p->getAs<types::Double>();
200         const int size = d->getSize();
201         if (size == 0)
202         {
203             return true;
204         }
205
206         double* dbl = d->get();
207         for (int i = 0; i < size; ++i)
208         {
209             dest[i] = static_cast<int>(dbl[i]);
210         }
211         return true;
212     }
213
214     return false;
215 }
216
217 /*--------------------------------------------------------------------------*/
218 static bool getOpaquePointer(types::InternalType* p, void** dest)
219 {
220     if (p == nullptr)
221     {
222         return false;
223     }
224
225     *dest = p;
226     return true;
227 }
228
229 /*--------------------------------------------------------------------------*/
230 void sciblk4(scicos_block* blk, const int flag)
231 {
232     int ierr = 0;
233     /* Retrieve block number */
234     const int kfun = get_block_number();
235
236     /* Retrieve 'funtyp' by import structure */
237     int* ptr = nullptr;
238     int nv = 0, mv = 0;
239     char buf[] = "funtyp";
240     ierr = getscicosvarsfromimport(buf, (void**)&ptr, &nv, &mv);
241     if (ierr == 0)
242     {
243         set_block_error(-1);
244         return;
245     }
246     const int* const funtyp = (int *)ptr;
247
248     types::typed_list in, out;
249     types::optional_list opt;
250
251     /*****************************
252     * Create Scilab tlist Blocks *
253     *****************************/
254     types::InternalType* pIT = nullptr;
255     if (flag == 4) // Initialization
256     {
257         pIT = createblklist(blk, -1, funtyp[kfun - 1]);
258         if (pIT == nullptr)
259         {
260             set_block_error(-1);
261             return;
262         }
263         *blk->work = pIT;
264         pIT->IncreaseRef();
265     }
266     else if (flag == 5) // Ending
267     {
268         pIT = *(types::InternalType**)blk->work;
269         pIT->DecreaseRef();
270     }
271     else // any other flag might use refreshed values
272     {
273         pIT = *(types::InternalType**)blk->work;
274         pIT = refreshblklist(pIT, blk, -1, funtyp[kfun - 1]);
275         }
276
277     in.push_back(pIT);
278     /* * flag * */
279     in.push_back(new types::Double(flag));
280
281     /***********************
282     * Call Scilab function *
283     ***********************/
284     types::Callable* pCall = static_cast<types::Callable*>(blk->scsptr);
285
286     ConfigVariable::where_begin(1, 1, pCall);
287     types::Callable::ReturnValue Ret;
288
289     try
290     {
291         Ret = pCall->call(in, opt, 1, out);
292         ConfigVariable::where_end();
293         ConfigVariable::decreaseRecursion();
294
295         if (Ret != types::Callable::OK)
296         {
297             set_block_error(-1);
298             return;
299         }
300
301         if (out.size() != 1)
302         {
303             set_block_error(-1);
304             return;
305         }
306     }
307     catch (const ast::InternalError &)
308     {
309         std::wostringstream ostr;
310         ConfigVariable::whereErrorToString(ostr);
311
312         bool oldSilentError = ConfigVariable::isSilentError();
313         ConfigVariable::setSilentError(false);
314         scilabErrorW(ostr.str().c_str());
315         ConfigVariable::setSilentError(oldSilentError);
316         ConfigVariable::resetWhereError();
317
318         ConfigVariable::where_end();
319         ConfigVariable::setLastErrorFunction(pCall->getName());
320         ConfigVariable::decreaseRecursion();
321
322         set_block_error(-1);
323         throw;
324     }
325
326     pIT = out[0];
327     if (pIT->isTList() == false)
328     {
329         set_block_error(-1);
330         delete pIT;
331         return;
332     }
333
334     types::TList* t = pIT->getAs<types::TList>();
335
336     switch (flag)
337     {
338         /**************************
339         * update continuous state
340         **************************/
341         case 0:
342         {
343             if (blk->nx != 0)
344             {
345                 /* 14 - xd */
346                 if (getDoubleArray(t->getField(L"xd"), blk->xd) == false)
347                 {
348                     t->killMe();
349                     set_block_error(-1);
350                     return;
351                 }
352
353                 if ((funtyp[kfun - 1] == 10004) || (funtyp[kfun - 1] == 10005))
354                 {
355                     /* 15 - res */
356                     if (getDoubleArray(t->getField(L"res"), blk->res) == false)
357                     {
358                         t->killMe();
359                         set_block_error(-1);
360                         return;
361                     }
362                 }
363             }
364             break;
365         }
366         /**********************
367         * update output state
368         **********************/
369         case 1:
370         {
371             /* 21 - outptr */
372             if (blk->nout > 0)
373             {
374                 types::InternalType* pIT = t->getField(L"outptr");
375                 if (pIT && pIT->isList())
376                 {
377                     types::List* lout = pIT->getAs<types::List>();
378                     if (blk->nout == lout->getSize())
379                     {
380                         for (int i = 0; i < blk->nout; ++i)
381                         {
382                             //update data
383                             int row = blk->outsz[i];
384                             int col = blk->outsz[i + blk->nout];
385                             int type = blk->outsz[i + blk->nout * 2];
386                             if (sci2var(lout->get(i), blk->outptr[i], type, row, col) == false)
387                             {
388                                 t->killMe();
389                                 set_block_error(-1);
390                                 return;
391                             }
392                         }
393                     }
394                 }
395             }
396             break;
397         }
398         case 2:
399         {
400             /* 7 - z */
401             if (blk->nz != 0)
402             {
403                 if (getDoubleArray(t->getField(L"z"), blk->z) == false)
404                 {
405                     t->killMe();
406                     set_block_error(-1);
407                     return;
408                 }
409             }
410
411             /* 11 - oz */
412             if (blk->noz != 0)
413             {
414                 if (getOpaquePointer(t->getField(L"oz"), blk->ozptr) == false)
415                 {
416                     t->killMe();
417                     set_block_error(-1);
418                     return;
419                 }
420             }
421
422             if (blk->nx != 0)
423             {
424                 /* 13 - x */
425                 if (getDoubleArray(t->getField(L"x"), blk->x) == false)
426                 {
427                     t->killMe();
428                     set_block_error(-1);
429                     return;
430                 }
431
432                 /* 14 - xd */
433                 if (getDoubleArray(t->getField(L"xd"), blk->xd) == false)
434                 {
435                     t->killMe();
436                     set_block_error(-1);
437                     return;
438                 }
439             }
440
441             break;
442         }
443
444         /***************************
445         * update event output state
446         ***************************/
447         case 3:
448         {
449             /* 23 - evout */
450             if (getDoubleArray(t->getField(L"evout"), blk->evout) == false)
451             {
452                 t->killMe();
453                 set_block_error(-1);
454                 return;
455             }
456             break;
457         }
458         /**********************
459         * state initialisation
460         **********************/
461         case 4:
462         {
463             /* 7 - z */
464             if (blk->nz != 0)
465             {
466                 if (getDoubleArray(t->getField(L"z"), blk->z) == false)
467                 {
468                     t->killMe();
469                     set_block_error(-1);
470                     return;
471                 }
472             }
473
474             /* 11 - oz */
475             if (blk->noz != 0)
476             {
477                 if (getOpaquePointer(t->getField(L"oz"), blk->ozptr) == false)
478                 {
479                     t->killMe();
480                     set_block_error(-1);
481                     return;
482                 }
483             }
484
485             if (blk->nx != 0)
486             {
487                 /* 13 - x */
488                 if (getDoubleArray(t->getField(L"x"), blk->x) == false)
489                 {
490                     t->killMe();
491                     set_block_error(-1);
492                     return;
493                 }
494
495                 /* 14 - xd */
496                 if (getDoubleArray(t->getField(L"xd"), blk->xd) == false)
497                 {
498                     t->killMe();
499                     set_block_error(-1);
500                     return;
501                 }
502             }
503
504             break;
505         }
506
507         case 5:
508         {
509             /* 7 - z */
510             if (blk->nz != 0)
511             {
512                 if (getDoubleArray(t->getField(L"z"), blk->z) == false)
513                 {
514                     t->killMe();
515                     set_block_error(-1);
516                     return;
517                 }
518             }
519
520             /* 11 - oz */
521             if (blk->noz != 0)
522             {
523                 if (getOpaquePointer(t->getField(L"oz"), blk->ozptr) == false)
524                 {
525                     t->killMe();
526                     set_block_error(-1);
527                     return;
528                 }
529             }
530
531             break;
532         }
533
534         /*****************************
535         * output state initialisation
536         *****************************/
537         case 6:
538         {
539             /* 7 - z */
540             if (blk->nz != 0)
541             {
542                 if (getDoubleArray(t->getField(L"z"), blk->z) == false)
543                 {
544                     t->killMe();
545                     set_block_error(-1);
546                     return;
547                 }
548             }
549
550             /* 11 - oz */
551             if (blk->noz != 0)
552             {
553                 if (getOpaquePointer(t->getField(L"oz"), blk->ozptr) == false)
554                 {
555                     t->killMe();
556                     set_block_error(-1);
557                     return;
558                 }
559             }
560
561             if (blk->nx != 0)
562             {
563                 /* 13 - x */
564                 if (getDoubleArray(t->getField(L"x"), blk->x) == false)
565                 {
566                     t->killMe();
567                     set_block_error(-1);
568                     return;
569                 }
570
571                 /* 14 - xd */
572                 if (getDoubleArray(t->getField(L"xd"), blk->xd) == false)
573                 {
574                     t->killMe();
575                     set_block_error(-1);
576                     return;
577                 }
578             }
579
580             /* 21 - outptr */
581             if (blk->nout > 0)
582             {
583                 types::InternalType* pIT = t->getField(L"outptr");
584                 if (pIT && pIT->isList())
585                 {
586                     types::List* lout = pIT->getAs<types::List>();
587                     if (blk->nout == lout->getSize())
588                     {
589                         for (int i = 0; i < blk->nout; ++i)
590                         {
591                             //update data
592                             const int row = blk->outsz[i];
593                             const int col = blk->outsz[i + blk->nout];
594                             const int type = blk->outsz[i + blk->nout * 2];
595                             if (sci2var(lout->get(i), blk->outptr[i], type, row, col) == false)
596                             {
597                                 t->killMe();
598                                 set_block_error(-1);
599                                 return;
600                             }
601                         }
602                     }
603                 }
604             }
605             break;
606         }
607
608         /*******************************************
609         * define property of continuous time states
610         * (algebraic or differential states)
611         *******************************************/
612         case 7:
613         {
614             if (blk->nx != 0)
615             {
616                 /* 40 - xprop */
617                 if (getDoubleArrayAsInt(t->getField(L"xprop"), blk->xprop) == false)
618                 {
619                     t->killMe();
620                     set_block_error(-1);
621                     return;
622                 }
623             }
624             break;
625         }
626
627         /****************************
628         * zero crossing computation
629         ****************************/
630         case 9:
631         {
632             /* 33 - g */
633             if (getDoubleArray(t->getField(L"g"), blk->g) == false)
634             {
635                 t->killMe();
636                 set_block_error(-1);
637                 return;
638             }
639
640             if (get_phase_simulation() == 1)
641             {
642                 /* 39 - mode */
643                 if (getDoubleArrayAsInt(t->getField(L"mode"), blk->mode) == false)
644                 {
645                     t->killMe();
646                     set_block_error(-1);
647                     return;
648                 }
649             }
650             break;
651         }
652         /**********************
653         * Jacobian computation
654         **********************/
655         case 10:
656         {
657             if ((funtyp[kfun - 1] == 10004) || (funtyp[kfun - 1] == 10005))
658             {
659                 /* 15 - res */
660                 if (getDoubleArray(t->getField(L"res"), blk->res) == false)
661                 {
662                     t->killMe();
663                     set_block_error(-1);
664                     return;
665                 }
666             }
667             break;
668         }
669     }
670
671     t->killMe();
672     return;
673 }
674 /*--------------------------------------------------------------------------*/