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