Modules/cgensupport.c

   1 /***********************************************************
   2 Copyright 1991-1995 by Stichting Mathematisch Centrum, Amsterdam,
   3 The Netherlands.
   4
   5                         All Rights Reserved
   6
   7 Permission to use, copy, modify, and distribute this software and its
   8 documentation for any purpose and without fee is hereby granted,
   9 provided that the above copyright notice appear in all copies and that
  10 both that copyright notice and this permission notice appear in
  11 supporting documentation, and that the names of Stichting Mathematisch
  12 Centrum or CWI not be used in advertising or publicity pertaining to
  13 distribution of the software without specific, written prior permission.
  14
  15 STICHTING MATHEMATISCH CENTRUM DISCLAIMS ALL WARRANTIES WITH REGARD TO
  16 THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
  17 FITNESS, IN NO EVENT SHALL STICHTING MATHEMATISCH CENTRUM BE LIABLE
  18 FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  19 WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  20 ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
  21 OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  22
  23 ******************************************************************/
  24
  25 /* Functions used by cgen output */
  26
  27 #include "allobjects.h"
  28 #include "cgensupport.h"
  29
  30
  31 /* Functions to extract arguments.
  32    These needs to know the total number of arguments supplied,
  33    since the argument list is a tuple only of there is more than
  34    one argument. */
  35
  36 int
  37 getiobjectarg(args, nargs, i, p_arg)
  38         register object *args;
  39         int nargs, i;
  40         object **p_arg;
  41 {
  42         if (nargs != 1) {
  43                 if (args == NULL || !is_tupleobject(args) ||
  44                                 nargs != gettuplesize(args) ||
  45                                 i < 0 || i >= nargs) {
  46                         return err_badarg();
  47                 }
  48                 else {
  49                         args = gettupleitem(args, i);
  50                 }
  51         }
  52         if (args == NULL) {
  53                 return err_badarg();
  54         }
  55         *p_arg = args;
  56         return 1;
  57 }
  58
  59 int
  60 getilongarg(args, nargs, i, p_arg)
  61         register object *args;
  62         int nargs, i;
  63         long *p_arg;
  64 {
  65         if (nargs != 1) {
  66                 if (args == NULL || !is_tupleobject(args) ||
  67                                 nargs != gettuplesize(args) ||
  68                                 i < 0 || i >= nargs) {
  69                         return err_badarg();
  70                 }
  71                 args = gettupleitem(args, i);
  72         }
  73         if (args == NULL || !is_intobject(args)) {
  74                 return err_badarg();
  75         }
  76         *p_arg = getintvalue(args);
  77         return 1;
  78 }
  79
  80 int
  81 getishortarg(args, nargs, i, p_arg)
  82         register object *args;
  83         int nargs, i;
  84         short *p_arg;
  85 {
  86         long x;
  87         if (!getilongarg(args, nargs, i, &x))
  88                 return 0;
  89         *p_arg = x;
  90         return 1;
  91 }
  92
  93 static int
  94 extractdouble(v, p_arg)
  95         register object *v;
  96         double *p_arg;
  97 {
  98         if (v == NULL) {
  99                 /* Fall through to error return at end of function */
 100         }
 101         else if (is_floatobject(v)) {
 102                 *p_arg = GETFLOATVALUE((floatobject *)v);
 103                 return 1;
 104         }
 105         else if (is_intobject(v)) {
 106                 *p_arg = GETINTVALUE((intobject *)v);
 107                 return 1;
 108         }
 109         else if (is_longobject(v)) {
 110                 *p_arg = dgetlongvalue(v);
 111                 return 1;
 112         }
 113         return err_badarg();
 114 }
 115
 116 static int
 117 extractfloat(v, p_arg)
 118         register object *v;
 119         float *p_arg;
 120 {
 121         if (v == NULL) {
 122                 /* Fall through to error return at end of function */
 123         }
 124         else if (is_floatobject(v)) {
 125                 *p_arg = GETFLOATVALUE((floatobject *)v);
 126                 return 1;
 127         }
 128         else if (is_intobject(v)) {
 129                 *p_arg = GETINTVALUE((intobject *)v);
 130                 return 1;
 131         }
 132         else if (is_longobject(v)) {
 133                 *p_arg = dgetlongvalue(v);
 134                 return 1;
 135         }
 136         return err_badarg();
 137 }
 138
 139 int
 140 getifloatarg(args, nargs, i, p_arg)
 141         register object *args;
 142         int nargs, i;
 143         float *p_arg;
 144 {
 145         object *v;
 146         float x;
 147         if (!getiobjectarg(args, nargs, i, &v))
 148                 return 0;
 149         if (!extractfloat(v, &x))
 150                 return 0;
 151         *p_arg = x;
 152         return 1;
 153 }
 154
 155 int
 156 getistringarg(args, nargs, i, p_arg)
 157         object *args;
 158         int nargs, i;
 159         string *p_arg;
 160 {
 161         object *v;
 162         if (!getiobjectarg(args, nargs, i, &v))
 163                 return 0;
 164         if (!is_stringobject(v)) {
 165                 return err_badarg();
 166         }
 167         *p_arg = getstringvalue(v);
 168         return 1;
 169 }
 170
 171 int
 172 getichararg(args, nargs, i, p_arg)
 173         object *args;
 174         int nargs, i;
 175         char *p_arg;
 176 {
 177         string x;
 178         if (!getistringarg(args, nargs, i, &x))
 179                 return 0;
 180         if (x[0] == '\0' || x[1] != '\0') {
 181                 /* Not exactly one char */
 182                 return err_badarg();
 183         }
 184         *p_arg = x[0];
 185         return 1;
 186 }
 187
 188 int
 189 getilongarraysize(args, nargs, i, p_arg)
 190         object *args;
 191         int nargs, i;
 192         long *p_arg;
 193 {
 194         object *v;
 195         if (!getiobjectarg(args, nargs, i, &v))
 196                 return 0;
 197         if (is_tupleobject(v)) {
 198                 *p_arg = gettuplesize(v);
 199                 return 1;
 200         }
 201         if (is_listobject(v)) {
 202                 *p_arg = getlistsize(v);
 203                 return 1;
 204         }
 205         return err_badarg();
 206 }
 207
 208 int
 209 getishortarraysize(args, nargs, i, p_arg)
 210         object *args;
 211         int nargs, i;
 212         short *p_arg;
 213 {
 214         long x;
 215         if (!getilongarraysize(args, nargs, i, &x))
 216                 return 0;
 217         *p_arg = x;
 218         return 1;
 219 }
 220
 221 /* XXX The following four are too similar.  Should share more code. */
 222
 223 int
 224 getilongarray(args, nargs, i, n, p_arg)
 225         object *args;
 226         int nargs, i;
 227         int n;
 228         long *p_arg; /* [n] */
 229 {
 230         object *v, *w;
 231         if (!getiobjectarg(args, nargs, i, &v))
 232                 return 0;
 233         if (is_tupleobject(v)) {
 234                 if (gettuplesize(v) != n) {
 235                         return err_badarg();
 236                 }
 237                 for (i = 0; i < n; i++) {
 238                         w = gettupleitem(v, i);
 239                         if (!is_intobject(w)) {
 240                                 return err_badarg();
 241                         }
 242                         p_arg[i] = getintvalue(w);
 243                 }
 244                 return 1;
 245         }
 246         else if (is_listobject(v)) {
 247                 if (getlistsize(v) != n) {
 248                         return err_badarg();
 249                 }
 250                 for (i = 0; i < n; i++) {
 251                         w = getlistitem(v, i);
 252                         if (!is_intobject(w)) {
 253                                 return err_badarg();
 254                         }
 255                         p_arg[i] = getintvalue(w);
 256                 }
 257                 return 1;
 258         }
 259         else {
 260                 return err_badarg();
 261         }
 262 }
 263
 264 int
 265 getishortarray(args, nargs, i, n, p_arg)
 266         object *args;
 267         int nargs, i;
 268         int n;
 269         short *p_arg; /* [n] */
 270 {
 271         object *v, *w;
 272         if (!getiobjectarg(args, nargs, i, &v))
 273                 return 0;
 274         if (is_tupleobject(v)) {
 275                 if (gettuplesize(v) != n) {
 276                         return err_badarg();
 277                 }
 278                 for (i = 0; i < n; i++) {
 279                         w = gettupleitem(v, i);
 280                         if (!is_intobject(w)) {
 281                                 return err_badarg();
 282                         }
 283                         p_arg[i] = getintvalue(w);
 284                 }
 285                 return 1;
 286         }
 287         else if (is_listobject(v)) {
 288                 if (getlistsize(v) != n) {
 289                         return err_badarg();
 290                 }
 291                 for (i = 0; i < n; i++) {
 292                         w = getlistitem(v, i);
 293                         if (!is_intobject(w)) {
 294                                 return err_badarg();
 295                         }
 296                         p_arg[i] = getintvalue(w);
 297                 }
 298                 return 1;
 299         }
 300         else {
 301                 return err_badarg();
 302         }
 303 }
 304
 305 int
 306 getidoublearray(args, nargs, i, n, p_arg)
 307         object *args;
 308         int nargs, i;
 309         int n;
 310         double *p_arg; /* [n] */
 311 {
 312         object *v, *w;
 313         if (!getiobjectarg(args, nargs, i, &v))
 314                 return 0;
 315         if (is_tupleobject(v)) {
 316                 if (gettuplesize(v) != n) {
 317                         return err_badarg();
 318                 }
 319                 for (i = 0; i < n; i++) {
 320                         w = gettupleitem(v, i);
 321                         if (!extractdouble(w, &p_arg[i]))
 322                                 return 0;
 323                 }
 324                 return 1;
 325         }
 326         else if (is_listobject(v)) {
 327                 if (getlistsize(v) != n) {
 328                         return err_badarg();
 329                 }
 330                 for (i = 0; i < n; i++) {
 331                         w = getlistitem(v, i);
 332                         if (!extractdouble(w, &p_arg[i]))
 333                                 return 0;
 334                 }
 335                 return 1;
 336         }
 337         else {
 338                 return err_badarg();
 339         }
 340 }
 341
 342 int
 343 getifloatarray(args, nargs, i, n, p_arg)
 344         object *args;
 345         int nargs, i;
 346         int n;
 347         float *p_arg; /* [n] */
 348 {
 349         object *v, *w;
 350         if (!getiobjectarg(args, nargs, i, &v))
 351                 return 0;
 352         if (is_tupleobject(v)) {
 353                 if (gettuplesize(v) != n) {
 354                         return err_badarg();
 355                 }
 356                 for (i = 0; i < n; i++) {
 357                         w = gettupleitem(v, i);
 358                         if (!extractfloat(w, &p_arg[i]))
 359                                 return 0;
 360                 }
 361                 return 1;
 362         }
 363         else if (is_listobject(v)) {
 364                 if (getlistsize(v) != n) {
 365                         return err_badarg();
 366                 }
 367                 for (i = 0; i < n; i++) {
 368                         w = getlistitem(v, i);
 369                         if (!extractfloat(w, &p_arg[i]))
 370                                 return 0;
 371                 }
 372                 return 1;
 373         }
 374         else {
 375                 return err_badarg();
 376         }
 377 }