c_cpp/etc/calc/obj.c

   1 /*
   2  * obj - object handling primitives
   3  *
   4  * Copyright (C) 1999-2007  David I. Bell
   5  *
   6  * Calc is open software; you can redistribute it and/or modify it under
   7  * the terms of the version 2.1 of the GNU Lesser General Public License
   8  * as published by the Free Software Foundation.
   9  *
  10  * Calc is distributed in the hope that it will be useful, but WITHOUT
  11  * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  12  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
  13  * Public License for more details.
  14  *
  15  * A copy of version 2.1 of the GNU Lesser General Public License is
  16  * distributed with calc under the filename COPYING-LGPL.  You should have
  17  * received a copy with calc; if not, write to Free Software Foundation, Inc.
  18  * 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  19  *
  20  * @(#) $Revision: 30.2 $
  21  * @(#) $Id: obj.c,v 30.2 2013/08/11 08:41:38 chongo Exp $
  22  * @(#) $Source: /usr/local/src/bin/calc/RCS/obj.c,v $
  23  *
  24  * Under source code control:   1990/02/15 01:48:19
  25  * File existed as early as:    before 1990
  26  *
  27  * Share and enjoy!  :-)        http://www.isthe.com/chongo/tech/comp/calc/
  28  */
  29 /*
  30  * "Object" handling primitives.
  31  * This simply means that user-specified routines are called to perform
  32  * the indicated operations.
  33  */
  34
  35
  36 #include <stdio.h>
  37 #include "calc.h"
  38 #include "opcodes.h"
  39 #include "func.h"
  40 #include "symbol.h"
  41 #include "str.h"
  42
  43
  44 /*
  45  * Types of values returned by calling object routines.
  46  */
  47 #define A_VALUE 0       /* returns arbitrary value */
  48 #define A_INT   1       /* returns integer value */
  49 #define A_UNDEF 2       /* returns no value */
  50
  51 /*
  52  * Error handling actions for when the function is undefined.
  53  */
  54 #define ERR_NONE        0       /* no special action */
  55 #define ERR_PRINT       1       /* print element */
  56 #define ERR_CMP 2       /* compare two values */
  57 #define ERR_TEST        3       /* test value for nonzero */
  58 #define ERR_POW 4       /* call generic power routine */
  59 #define ERR_ONE 5       /* return number 1 */
  60 #define ERR_INC 6       /* increment by one */
  61 #define ERR_DEC 7       /* decrement by one */
  62 #define ERR_SQUARE 8    /* square value */
  63 #define ERR_VALUE 9     /* return value */
  64 #define ERR_ASSIGN 10   /* assign value */
  65
  66
  67 STATIC struct objectinfo {
  68         short args;     /* number of arguments */
  69         short retval;   /* type of return value */
  70         short error;    /* special action on errors */
  71         char *name;     /* name of function to call */
  72         char *comment;  /* useful comment if any */
  73 } objectinfo[] = {
  74         {1, A_UNDEF, ERR_PRINT,
  75          "print",       "print value, default prints elements"},
  76         {1, A_VALUE, ERR_ONE,
  77          "one", "multiplicative identity, default is 1"},
  78         {1, A_INT,   ERR_TEST,
  79          "test", "logical test (false,true => 0,1), default tests elements"},
  80         {2, A_VALUE, ERR_NONE,
  81          "add", NULL},
  82         {2, A_VALUE, ERR_NONE,
  83          "sub", NULL},
  84         {1, A_VALUE, ERR_NONE,
  85          "neg", "negative"},
  86         {2, A_VALUE, ERR_NONE,
  87          "mul", NULL},
  88         {2, A_VALUE, ERR_NONE,
  89          "div", "non-integral division"},
  90         {1, A_VALUE, ERR_NONE,
  91          "inv", "multiplicative inverse"},
  92         {2, A_VALUE, ERR_NONE,
  93          "abs", "absolute value within given error"},
  94         {1, A_VALUE, ERR_NONE,
  95          "norm", "square of absolute value"},
  96         {1, A_VALUE, ERR_NONE,
  97          "conj", "conjugate"},
  98         {2, A_VALUE, ERR_POW,
  99          "pow", "integer power, default does multiply, square, inverse"},
 100         {1, A_VALUE, ERR_NONE,
 101          "sgn", "sign of value (-1, 0, 1)"},
 102         {2, A_INT,   ERR_CMP,
 103          "cmp", "equality (equal,nonequal => 0,1), default tests elements"},
 104         {2, A_VALUE, ERR_NONE,
 105          "rel", "relative order, positive for >, etc."},
 106         {3, A_VALUE, ERR_NONE,
 107          "quo", "integer quotient"},
 108         {3, A_VALUE, ERR_NONE,
 109          "mod", "remainder of division"},
 110         {1, A_VALUE, ERR_NONE,
 111          "int", "integer part"},
 112         {1, A_VALUE, ERR_NONE,
 113          "frac", "fractional part"},
 114         {1, A_VALUE, ERR_INC,
 115          "inc", "increment, default adds 1"},
 116         {1, A_VALUE, ERR_DEC,
 117          "dec", "decrement, default subtracts 1"},
 118         {1, A_VALUE, ERR_SQUARE,
 119          "square", "default multiplies by itself"},
 120         {2, A_VALUE, ERR_NONE,
 121          "scale", "multiply by power of 2"},
 122         {2, A_VALUE, ERR_NONE,
 123          "shift", "shift left by n bits (right if negative)"},
 124         {3, A_VALUE, ERR_NONE,
 125          "round", "round to given number of decimal places"},
 126         {3, A_VALUE, ERR_NONE,
 127          "bround", "round to given number of binary places"},
 128         {3, A_VALUE, ERR_NONE,
 129          "root", "root of value within given error"},
 130         {3, A_VALUE, ERR_NONE,
 131          "sqrt", "square root within given error"},
 132         {2, A_VALUE, ERR_NONE,
 133          "or",  "bitwise or"},
 134         {2, A_VALUE, ERR_NONE,
 135          "and", "bitwise and"},
 136         {1, A_VALUE, ERR_NONE,
 137          "not", "logical not"},
 138         {1, A_VALUE, ERR_NONE,
 139          "fact", "factorial or postfix !"},
 140         {1, A_VALUE, ERR_VALUE,
 141          "min", "value for min(...)"},
 142         {1, A_VALUE, ERR_VALUE,
 143          "max", "value for max(...)"},
 144         {1, A_VALUE, ERR_VALUE,
 145          "sum", "value for sum(...)"},
 146         {2, A_UNDEF, ERR_ASSIGN,
 147          "assign", "assign, defaults to a = b"},
 148         {2, A_VALUE, ERR_NONE,
 149          "xor", "value for binary ~"},
 150         {1, A_VALUE, ERR_NONE,
 151          "comp", "value for unary ~"},
 152         {1, A_VALUE, ERR_NONE,
 153          "content", "unary hash op"},
 154         {2, A_VALUE, ERR_NONE,
 155          "hashop",  "binary hash op"},
 156         {1, A_VALUE, ERR_NONE,
 157          "backslash", "unary backslash op"},
 158         {2, A_VALUE, ERR_NONE,
 159          "setminus", "binary backslash op"},
 160         {1, A_VALUE, ERR_NONE,
 161          "plus", "unary + op"},
 162         {0, 0, 0,
 163          NULL, NULL}
 164 };
 165
 166
 167 STATIC STRINGHEAD objectnames;  /* names of objects */
 168 STATIC STRINGHEAD elements;     /* element names for parts of objects */
 169 STATIC OBJECTACTIONS **objects; /* table of actions for objects */
 170
 171 #define OBJALLOC 16
 172 STATIC long maxobjcount = 0;
 173
 174 S_FUNC VALUE objpowi(VALUE *vp, NUMBER *q);
 175 S_FUNC BOOL objtest(OBJECT *op);
 176 S_FUNC BOOL objcmp(OBJECT *op1, OBJECT *op2);
 177 S_FUNC void objprint(OBJECT *op);
 178
 179
 180 /*
 181  * Show all the routine names available for objects.
 182  */
 183 void
 184 showobjfuncs(void)
 185 {
 186         register struct objectinfo *oip;
 187
 188         printf("\nThe following object routines are definable.\n");
 189         printf("Note: xx represents the actual object type name.\n\n");
 190         printf("Name    Args    Comments\n");
 191         for (oip = objectinfo; oip->name; oip++) {
 192                 printf("xx_%-8s %d      %s\n", oip->name, oip->args,
 193                         oip->comment ? oip->comment : "");
 194         }
 195         printf("\n");
 196 }
 197
 198
 199 /*
 200  * Call the appropriate user-defined routine to handle an object action.
 201  * Returns the value that the routine returned.
 202  */
 203 VALUE
 204 objcall(int action, VALUE *v1, VALUE *v2, VALUE *v3)
 205 {
 206         FUNC *fp;               /* function to call */
 207         STATIC OBJECTACTIONS *oap; /* object to call for */
 208         struct objectinfo *oip; /* information about action */
 209         long index;             /* index of function (negative if undefined) */
 210         VALUE val;              /* return value */
 211         VALUE tmp;              /* temp value */
 212         char name[SYMBOLSIZE+1+1];      /* full name of user routine to call */
 213         size_t namestr_len;     /* length of the namestr() return string */
 214         char *namestr_ret;      /* namestr() return string */
 215         size_t opi_name_len;    /* length of the oip name */
 216
 217         /* initialize VALUEs */
 218         val.v_subtype = V_NOSUBTYPE;
 219         tmp.v_subtype = V_NOSUBTYPE;
 220
 221         if ((unsigned)action > OBJ_MAXFUNC) {
 222                 math_error("Illegal action for object call");
 223                 /*NOTREACHED*/
 224         }
 225         oip = &objectinfo[action];
 226         if (v1->v_type == V_OBJ) {
 227                 oap = v1->v_obj->o_actions;
 228         } else if (v2->v_type == V_OBJ) {
 229                 oap = v2->v_obj->o_actions;
 230         } else {
 231                 math_error("Object routine called with non-object");
 232                 /*NOTREACHED*/
 233         }
 234         index = oap->oa_indices[action];
 235         if (index < 0) {
 236                 namestr_ret = namestr(&objectnames, oap->oa_index);
 237                 if (namestr_ret == NULL) {
 238                         math_error("namestr returned NULL!!!");
 239                         /*NOTREACHED*/
 240                 }
 241                 namestr_len = strlen(namestr_ret);
 242                 opi_name_len = strlen(oip->name);
 243                 if (namestr_len > (size_t)SYMBOLSIZE-1-opi_name_len) {
 244                         math_error("namestr returned a strong too long!!!");
 245                         /*NOTREACHED*/
 246                 }
 247                 name[0] = '\0';
 248                 strncpy(name, namestr_ret, namestr_len+1);
 249                 strcat(name, "_");
 250                 strncat(name, oip->name, opi_name_len+1);
 251                 index = adduserfunc(name);
 252                 oap->oa_indices[action] = index;
 253         }
 254         fp = NULL;
 255         if (index >= 0)
 256                 fp = findfunc(index);
 257         if (fp == NULL) {
 258                 switch (oip->error) {
 259                 case ERR_PRINT:
 260                         objprint(v1->v_obj);
 261                         val.v_type = V_NULL;
 262                         break;
 263                 case ERR_CMP:
 264                         val.v_type = V_INT;
 265                         if (v1->v_type != v2->v_type) {
 266                                 val.v_int = 1;
 267                                 return val;
 268                         }
 269                         val.v_int = objcmp(v1->v_obj, v2->v_obj);
 270                         break;
 271                 case ERR_TEST:
 272                         val.v_type = V_INT;
 273                         val.v_int = objtest(v1->v_obj);
 274                         break;
 275                 case ERR_POW:
 276                         if (v2->v_type != V_NUM) {
 277                                 math_error("Non-real power");
 278                                 /*NOTREACHED*/
 279                         }
 280                         val = objpowi(v1, v2->v_num);
 281                         break;
 282                 case ERR_ONE:
 283                         val.v_type = V_NUM;
 284                         val.v_num = qlink(&_qone_);
 285                         break;
 286                 case ERR_INC:
 287                         tmp.v_type = V_NUM;
 288                         tmp.v_num = &_qone_;
 289                         val = objcall(OBJ_ADD, v1, &tmp, NULL_VALUE);
 290                         break;
 291                 case ERR_DEC:
 292                         tmp.v_type = V_NUM;
 293                         tmp.v_num = &_qone_;
 294                         val = objcall(OBJ_SUB, v1, &tmp, NULL_VALUE);
 295                         break;
 296                 case ERR_SQUARE:
 297                         val = objcall(OBJ_MUL, v1, v1, NULL_VALUE);
 298                         break;
 299                 case ERR_VALUE:
 300                         copyvalue(v1, &val);
 301                         break;
 302                 case ERR_ASSIGN:
 303                         copyvalue(v2, &tmp);
 304                         tmp.v_subtype |= v1->v_subtype;
 305                         freevalue(v1);
 306                         *v1 = tmp;
 307                         val.v_type = V_NULL;
 308                         break;
 309                 default:
 310                         math_error("Function \"%s\" is undefined",
 311                                     namefunc(index));
 312                         /*NOTREACHED*/
 313                 }
 314                 return val;
 315         }
 316         switch (oip->args) {
 317         case 0:
 318                 break;
 319         case 1:
 320                 ++stack;
 321                 stack->v_addr = v1;
 322                 stack->v_type = V_ADDR;
 323                 break;
 324         case 2:
 325                 ++stack;
 326                 stack->v_addr = v1;
 327                 stack->v_type = V_ADDR;
 328                 ++stack;
 329                 stack->v_addr = v2;
 330                 stack->v_type = V_ADDR;
 331                 break;
 332         case 3:
 333                 ++stack;
 334                 stack->v_addr = v1;
 335                 stack->v_type = V_ADDR;
 336                 ++stack;
 337                 stack->v_addr = v2;
 338                 stack->v_type = V_ADDR;
 339                 ++stack;
 340                 stack->v_addr = v3;
 341                 stack->v_type = V_ADDR;
 342                 break;
 343         default:
 344                 math_error("Bad number of args to calculate");
 345                 /*NOTREACHED*/
 346         }
 347         calculate(fp, oip->args);
 348         switch (oip->retval) {
 349         case A_VALUE:
 350                 return *stack--;
 351         case A_UNDEF:
 352                 freevalue(stack--);
 353                 val.v_type = V_NULL;
 354                 break;
 355         case A_INT:
 356                 if ((stack->v_type != V_NUM) || qisfrac(stack->v_num)) {
 357                         math_error("Integer return value required");
 358                         /*NOTREACHED*/
 359                 }
 360                 index = qtoi(stack->v_num);
 361                 qfree(stack->v_num);
 362                 stack--;
 363                 val.v_type = V_INT;
 364                 val.v_int = index;
 365                 break;
 366         default:
 367                 math_error("Bad object return");
 368                 /*NOTREACHED*/
 369         }
 370         return val;
 371 }
 372
 373
 374 /*
 375  * Print the elements of an object in short and unambiguous format.
 376  * This is the default routine if the user's is not defined.
 377  *
 378  * given:
 379  *      op              object being printed
 380  */
 381 S_FUNC void
 382 objprint(OBJECT *op)
 383 {
 384         int count;              /* number of elements */
 385         int i;                  /* index */
 386
 387         count = op->o_actions->oa_count;
 388         math_fmt("obj %s {", namestr(&objectnames, op->o_actions->oa_index));
 389         for (i = 0; i < count; i++) {
 390                 if (i)
 391                         math_str(", ");
 392                 printvalue(&op->o_table[i], PRINT_SHORT | PRINT_UNAMBIG);
 393         }
 394         math_chr('}');
 395 }
 396
 397
 398 /*
 399  * Test an object for being "nonzero".
 400  * This is the default routine if the user's is not defined.
 401  * Returns TRUE if any of the elements are "nonzero".
 402  */
 403 S_FUNC BOOL
 404 objtest(OBJECT *op)
 405 {
 406         int i;                  /* loop counter */
 407
 408         i = op->o_actions->oa_count;
 409         while (--i >= 0) {
 410                 if (testvalue(&op->o_table[i]))
 411                         return TRUE;
 412         }
 413         return FALSE;
 414 }
 415
 416
 417 /*
 418  * Compare two objects for equality, returning TRUE if they differ.
 419  * This is the default routine if the user's is not defined.
 420  * For equality, all elements must be equal.
 421  */
 422 S_FUNC BOOL
 423 objcmp(OBJECT *op1, OBJECT *op2)
 424 {
 425         int i;                  /* loop counter */
 426
 427         if (op1->o_actions != op2->o_actions)
 428                 return TRUE;
 429         i = op1->o_actions->oa_count;
 430         while (--i >= 0) {
 431                 if (comparevalue(&op1->o_table[i], &op2->o_table[i]))
 432                         return TRUE;
 433         }
 434         return FALSE;
 435 }
 436
 437
 438 /*
 439  * Raise an object to an integral power.
 440  * This is the default routine if the user's is not defined.
 441  * Negative powers mean the positive power of the inverse.
 442  * Zero means the multiplicative identity.
 443  *
 444  * given:
 445  *      vp              value to be powered
 446  *      q               power to raise number to
 447  */
 448 S_FUNC VALUE
 449 objpowi(VALUE *vp, NUMBER *q)
 450 {
 451         VALUE res, tmp;
 452         long power;             /* power to raise to */
 453         FULL bit;               /* current bit value */
 454
 455         if (qisfrac(q)) {
 456                 math_error("Raising object to non-integral power");
 457                 /*NOTREACHED*/
 458         }
 459         if (zge31b(q->num)) {
 460                 math_error("Raising object to very large power");
 461                 /*NOTREACHED*/
 462         }
 463         power = ztolong(q->num);
 464         if (qisneg(q))
 465                 power = -power;
 466         /*
 467          * Handle some low powers specially
 468          */
 469         if ((power <= 2) && (power >= -2)) {
 470                 switch ((int) power) {
 471                 case 0:
 472                         return objcall(OBJ_ONE, vp, NULL_VALUE, NULL_VALUE);
 473                 case 1:
 474                         res.v_obj = objcopy(vp->v_obj);
 475                         res.v_type = V_OBJ;
 476                         res.v_subtype = V_NOSUBTYPE;
 477                         return res;
 478                 case -1:
 479                         return objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
 480                 case 2:
 481                         return objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
 482                 }
 483         }
 484         if (power < 0)
 485                 power = -power;
 486         /*
 487          * Compute the power by squaring and multiplying.
 488          * This uses the left to right method of power raising.
 489          */
 490         bit = TOPFULL;
 491         while ((bit & power) == 0)
 492                 bit >>= 1L;
 493         bit >>= 1L;
 494         res = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
 495         if (bit & power) {
 496                 tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
 497                 objfree(res.v_obj);
 498                 res = tmp;
 499         }
 500         bit >>= 1L;
 501         while (bit) {
 502                 tmp = objcall(OBJ_SQUARE, &res, NULL_VALUE, NULL_VALUE);
 503                 objfree(res.v_obj);
 504                 res = tmp;
 505                 if (bit & power) {
 506                         tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
 507                         objfree(res.v_obj);
 508                         res = tmp;
 509                 }
 510                 bit >>= 1L;
 511         }
 512         if (qisneg(q)) {
 513                 tmp = objcall(OBJ_INV, &res, NULL_VALUE, NULL_VALUE);
 514                 objfree(res.v_obj);
 515                 return tmp;
 516         }
 517         return res;
 518 }
 519
 520
 521 /*
 522  * Define a (possibly) new class of objects.
 523  * The list of indexes for the element names is also specified here,
 524  * and the number of elements defined for the object.
 525  *
 526  * given:
 527  *      name            name of object type
 528  *      indices         table of indices for elements
 529  *      count           number of elements defined for the object
 530  */
 531 int
 532 defineobject(char *name, int indices[], int count)
 533 {
 534         OBJECTACTIONS *oap;     /* object definition structure */
 535         STRINGHEAD *hp;
 536         OBJECTACTIONS **newobjects;
 537         int index;
 538
 539         hp = &objectnames;
 540         if (hp->h_list == NULL)
 541                 initstr(hp);
 542         index = findstr(hp, name);
 543         if (index >= 0) {
 544                 /*
 545                  * Object is already defined.  Give an error unless this
 546                  * new definition is exactly the same as the old one.
 547                  */
 548                 oap = objects[index];
 549                 if (oap->oa_count == count) {
 550                         for (index = 0; ; index++) {
 551                                 if (index >= count)
 552                                         return 0;
 553                                 if (oap->oa_elements[index] != indices[index])
 554                                         break;
 555                         }
 556                 }
 557                 return 1;
 558         }
 559
 560         if (hp->h_count >= maxobjcount) {
 561                 if (maxobjcount == 0) {
 562                         newobjects = (OBJECTACTIONS **) malloc(
 563                                 OBJALLOC * sizeof(OBJECTACTIONS *));
 564                         maxobjcount = OBJALLOC;
 565                 } else {
 566                         maxobjcount += OBJALLOC;
 567                         newobjects = (OBJECTACTIONS **) realloc(objects,
 568                                 maxobjcount * sizeof(OBJECTACTIONS *));
 569                 }
 570                 if (newobjects == NULL) {
 571                         math_error("Allocation failure for new object type");
 572                         /*NOTREACHED*/
 573                 }
 574                 objects = newobjects;
 575         }
 576
 577         oap = (OBJECTACTIONS *) malloc(objectactionsize(count));
 578         name = addstr(hp, name);
 579         if ((oap == NULL) || (name == NULL)) {
 580                 math_error("Cannot allocate object type");
 581                 /*NOTREACHED*/
 582         }
 583         oap->oa_count = count;
 584         for (index = OBJ_MAXFUNC; index >= 0; index--)
 585                 oap->oa_indices[index] = -1;
 586         for (index = 0; index < count; index++)
 587                 oap->oa_elements[index] = indices[index];
 588         index = findstr(hp, name);
 589         oap->oa_index = index;
 590         objects[index] = oap;
 591         return 0;
 592 }
 593
 594
 595 /*
 596  * Check an object name to see if it is currently defined.
 597  * If so, the index for the object type is returned.
 598  * If the object name is currently unknown, then -1 is returned.
 599  */
 600 int
 601 checkobject(char *name)
 602 {
 603         STRINGHEAD *hp;
 604
 605         hp = &objectnames;
 606         if (hp->h_list == NULL)
 607                 return -1;
 608         return findstr(hp, name);
 609 }
 610
 611
 612 /*
 613  * Define a (possibly) new element name for an object.
 614  * Returns an index which identifies the element name.
 615  */
 616 int
 617 addelement(char *name)
 618 {
 619         STRINGHEAD *hp;
 620         int index;
 621
 622         hp = &elements;
 623         if (hp->h_list == NULL)
 624                 initstr(hp);
 625         index = findstr(hp, name);
 626         if (index >= 0)
 627                 return index;
 628         if (addstr(hp, name) == NULL) {
 629                 math_error("Cannot allocate element name");
 630                 /*NOTREACHED*/
 631         }
 632         return findstr(hp, name);
 633 }
 634
 635
 636 /*
 637  * Return the index which identifies an element name.
 638  * Returns minus one if the element name is unknown.
 639  *
 640  * given:
 641  *      name            element name
 642  */
 643 int
 644 findelement(char *name)
 645 {
 646         if (elements.h_list == NULL)
 647                 return -1;
 648         return findstr(&elements, name);
 649 }
 650
 651
 652 /*
 653  * Returns the name of object type with specified index
 654  */
 655 char *
 656 objtypename(unsigned long index)
 657 {
 658         return namestr(&objectnames, (long)index);
 659 }
 660
 661
 662 /*
 663  * Return the value table offset to be used for an object element name.
 664  * This converts the element index from the element table into an offset
 665  * into the object value array.  Returns -1 if the element index is unknown.
 666  */
 667 int
 668 objoffset(OBJECT *op, long index)
 669 {
 670         register OBJECTACTIONS *oap;
 671         int offset;                     /* offset into value array */
 672
 673         oap = op->o_actions;
 674         for (offset = oap->oa_count - 1; offset >= 0; offset--) {
 675                 if (oap->oa_elements[offset] == index)
 676                         return offset;
 677         }
 678         return -1;
 679 }
 680
 681
 682 /*
 683  * Allocate a new object structure with the specified index.
 684  */
 685 OBJECT *
 686 objalloc(long index)
 687 {
 688         OBJECTACTIONS *oap;
 689         OBJECT *op;
 690         VALUE *vp;
 691         int i;
 692
 693         if (index < 0 || index > maxobjcount) {
 694                 math_error("Allocating bad object index");
 695                 /*NOTREACHED*/
 696         }
 697         oap = objects[index];
 698         if (oap == NULL) {
 699                 math_error("Object type not defined");
 700                 /*NOTREACHED*/
 701         }
 702         i = oap->oa_count;
 703         if (i < USUAL_ELEMENTS)
 704                 i = USUAL_ELEMENTS;
 705         if (i == USUAL_ELEMENTS)
 706                 op = (OBJECT *) malloc(sizeof(OBJECT));
 707         else
 708                 op = (OBJECT *) malloc(objectsize(i));
 709         if (op == NULL) {
 710                 math_error("Cannot allocate object");
 711                 /*NOTREACHED*/
 712         }
 713         op->o_actions = oap;
 714         vp = op->o_table;
 715         for (i = oap->oa_count; i-- > 0; vp++) {
 716                 vp->v_num = qlink(&_qzero_);
 717                 vp->v_type = V_NUM;
 718                 vp->v_subtype = V_NOSUBTYPE;
 719         }
 720         return op;
 721 }
 722
 723
 724 /*
 725  * Free an object structure.
 726  */
 727 void
 728 objfree(OBJECT *op)
 729 {
 730         VALUE *vp;
 731         int i;
 732
 733         vp = op->o_table;
 734         for (i = op->o_actions->oa_count; i-- > 0; vp++) {
 735                 if (vp->v_type == V_NUM) {
 736                         qfree(vp->v_num);
 737                 } else {
 738                         freevalue(vp);
 739                 }
 740         }
 741         if (op->o_actions->oa_count <= USUAL_ELEMENTS)
 742                 free(op);
 743         else
 744                 free((char *) op);
 745 }
 746
 747
 748 /*
 749  * Copy an object value
 750  */
 751 OBJECT *
 752 objcopy(OBJECT *op)
 753 {
 754         VALUE *v1, *v2;
 755         OBJECT *np;
 756         int i;
 757
 758         i = op->o_actions->oa_count;
 759         if (i < USUAL_ELEMENTS)
 760                 i = USUAL_ELEMENTS;
 761         if (i == USUAL_ELEMENTS)
 762                 np = (OBJECT *) malloc(sizeof(OBJECT));
 763         else
 764                 np = (OBJECT *) malloc(objectsize(i));
 765         if (np == NULL) {
 766                 math_error("Cannot allocate object");
 767                 /*NOTREACHED*/
 768         }
 769         np->o_actions = op->o_actions;
 770         v1 = op->o_table;
 771         v2 = np->o_table;
 772         for (i = op->o_actions->oa_count; i-- > 0; v1++, v2++) {
 773                 copyvalue(v1, v2);
 774         }
 775         return np;
 776 }
 777
 778
 779 /*
 780  * Show object types that have been defined.
 781  */
 782 void
 783 showobjtypes(void)
 784 {
 785         STRINGHEAD *hp;
 786         OBJECTACTIONS *oap;
 787         STRINGHEAD *ep;
 788         int index, i;
 789
 790         hp = &objectnames;
 791         ep = &elements;
 792         if (hp->h_count == 0) {
 793                 printf("No object types defined\n");
 794                 return;
 795         }
 796         for (index = 0; index < hp->h_count; index++) {
 797                 oap = objects[index];
 798                 printf("\t%s\t{", namestr(&objectnames, index));
 799                 for (i = 0; i < oap->oa_count; i++) {
 800                         if (i) printf(",");
 801                         printf("%s", namestr(ep, oap->oa_elements[i]));
 802                 }
 803                 printf("}\n");
 804         }
 805
 806 }
 807
 808
 809 /* END CODE */