home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Utilities / Calc / obj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-10  |  14.3 KB  |  619 lines  |  [TEXT/????]
  1. /*
  2.  * Copyright (c) 1992 David I. Bell
  3.  * Permission is granted to use, distribute, or modify this source,
  4.  * provided that this copyright notice remains intact.
  5.  *
  6.  * "Object" handling primatives.
  7.  * This simply means that user-specified routines are called to perform
  8.  * the indicated operations.
  9.  */
  10.  
  11. #include "calc.h"
  12. #include "opcodes.h"
  13. #include "func.h"
  14. #include "symbol.h"
  15. #include "xstring.h"
  16.  
  17.  
  18. /*
  19.  * Types of values returned by calling object routines.
  20.  */
  21. #define A_VALUE    0    /* returns arbitrary value */
  22. #define A_INT    1    /* returns integer value */
  23. #define A_UNDEF    2    /* returns no value */
  24.  
  25. /*
  26.  * Error handling actions for when the function is undefined.
  27.  */
  28. #define E_NONE    0    /* no special action */
  29. #define E_PRINT    1    /* print element */
  30. #define E_CMP    2    /* compare two values */
  31. #define E_TEST    3    /* test value for nonzero */
  32. #define E_POW    4    /* call generic power routine */
  33. #define E_ONE    5    /* return number 1 */
  34. #define E_INC    6    /* increment by one */
  35. #define E_DEC    7    /* decrement by one */
  36. #define E_SQUARE 8    /* square value */
  37.  
  38.  
  39. static struct objectinfo {
  40.     short args;    /* number of arguments */
  41.     short retval;    /* type of return value */
  42.     short error;    /* special action on errors */
  43.     char *name;    /* name of function to call */
  44.     char *comment;    /* useful comment if any */
  45. } objectinfo[] = {
  46.     1, A_UNDEF, E_PRINT, "print",    "print value, default prints elements",
  47.     1, A_VALUE, E_ONE,   "one",    "multiplicative identity, default is 1",
  48.     1, A_INT,   E_TEST,  "test",    "logical test (false,true => 0,1), default tests elements",
  49.     2, A_VALUE, E_NONE,  "add",    NULL,
  50.     2, A_VALUE, E_NONE,  "sub",    NULL,
  51.     1, A_VALUE, E_NONE,  "neg",    "negative",
  52.     2, A_VALUE, E_NONE,  "mul",    NULL,
  53.     2, A_VALUE, E_NONE,  "div",    "non-integral division",
  54.     1, A_VALUE, E_NONE,  "inv",    "multiplicative inverse",
  55.     2, A_VALUE, E_NONE,  "abs",    "absolute value within given error",
  56.     1, A_VALUE, E_NONE,  "norm",    "square of absolute value",
  57.     1, A_VALUE, E_NONE,  "conj",    "conjugate",
  58.     2, A_VALUE, E_POW,   "pow",    "integer power, default does multiply, square, inverse",
  59.     1, A_INT,   E_NONE,  "sgn",    "sign of value (-1, 0, 1)",
  60.     2, A_INT,   E_CMP,   "cmp",    "equality (equal,nonequal => 0,1), default tests elements",
  61.     2, A_INT,   E_NONE,  "rel",    "inequality (less,equal,greater => -1,0,1)",
  62.     2, A_VALUE, E_NONE,  "quo",    "integer quotient",
  63.     2, A_VALUE, E_NONE,  "mod",    "remainder of division",
  64.     1, A_VALUE, E_NONE,  "int",    "integer part",
  65.     1, A_VALUE, E_NONE,  "frac",    "fractional part",
  66.     1, A_VALUE, E_INC,   "inc",    "increment, default adds 1",
  67.     1, A_VALUE, E_DEC,   "dec",    "decrement, default subtracts 1",
  68.     1, A_VALUE, E_SQUARE,"square",    "default multiplies by itself",
  69.     2, A_VALUE, E_NONE,  "scale",    "multiply by power of 2",
  70.     2, A_VALUE, E_NONE,  "shift",    "shift left by n bits (right if negative)",
  71.     2, A_VALUE, E_NONE,  "round",    "round to given number of decimal places",
  72.     2, A_VALUE, E_NONE,  "bround",    "round to given number of binary places",
  73.     3, A_VALUE, E_NONE,  "root",    "root of value within given error",
  74.     2, A_VALUE, E_NONE,  "sqrt",    "square root within given error",
  75.     0, 0, 0, NULL
  76. };
  77.  
  78.  
  79. static STRINGHEAD objectnames;    /* names of objects */
  80. static STRINGHEAD elements;    /* element names for parts of objects */
  81. static OBJECTACTIONS *objects[MAXOBJECTS]; /* table of actions for objects */
  82.  
  83.  
  84. /*
  85.  * Free list of usual small objects.
  86.  */
  87. static FREELIST    freelist = {
  88.     sizeof(OBJECT),        /* size of typical objects */
  89.     100            /* number of free objects to keep */
  90. };
  91.  
  92.  
  93. static VALUE objpowi();
  94. static BOOL objtest(), objcmp();
  95. static void objprint();
  96.  
  97.  
  98. /*
  99.  * Show all the routine names available for objects.
  100.  */
  101. void
  102. showobjfuncs()
  103. {
  104.     register struct objectinfo *oip;
  105.  
  106.     printf("\nThe following object routines are definable.\n");
  107.     printf("Note: xx represents the actual object type name.\n\n");
  108.     printf("Name    Args    Comments\n");
  109.     for (oip = objectinfo; oip->name; oip++) {
  110.         printf("xx_%-8s %d    %s\n", oip->name, oip->args,
  111.             oip->comment ? oip->comment : "");
  112.     }
  113.     printf("\n");
  114. }
  115.  
  116.  
  117. /*
  118.  * Call the appropriate user-defined routine to handle an object action.
  119.  * Returns the value that the routine returned.
  120.  */
  121. /*VARARGS*/
  122. VALUE
  123. objcall(action, v1, v2, v3)
  124.     VALUE *v1, *v2, *v3;
  125. {
  126.     FUNC *fp;        /* function to call */
  127.     OBJECTACTIONS *oap;    /* object to call for */
  128.     struct objectinfo *oip;    /* information about action */
  129.     long index;        /* index of function (negative if undefined) */
  130.     VALUE val;        /* return value */
  131.     VALUE tmp;        /* temp value */
  132.     char name[SYMBOLSIZE+1];    /* full name of user routine to call */
  133.  
  134.     if ((unsigned)action > OBJ_MAXFUNC)
  135.         error("Illegal action for object call");
  136.     oip = &objectinfo[action];
  137.     if (v1->v_type == V_OBJ)
  138.         oap = v1->v_obj->o_actions;
  139.     else if (v2->v_type == V_OBJ)
  140.         oap = v2->v_obj->o_actions;
  141.     else
  142.         error("Object routine called with non-object");
  143.     index = oap->actions[action];
  144.     if (index == 0) {
  145.         strcpy(name, oap->name);
  146.         strcat(name, "_");
  147.         strcat(name, oip->name);
  148.         index = adduserfunc(name);
  149.         oap->actions[action] = index;
  150.     }
  151.     fp = NULL;
  152.     if (index > 0)
  153.         fp = findfunc(index);
  154.     if (fp == NULL) {
  155.         switch (oip->error) {
  156.             case E_PRINT:
  157.                 objprint(v1->v_obj);
  158.                 val.v_type = V_NULL;
  159.                 break;
  160.             case E_CMP:
  161.                 val.v_type = V_INT;
  162.                 if (v1->v_type != v2->v_type) {
  163.                     val.v_int = 1;
  164.                     return val;
  165.                 }
  166.                 val.v_int = objcmp(v1->v_obj, v2->v_obj);
  167.                 break;
  168.             case E_TEST:
  169.                 val.v_type = V_INT;
  170.                 val.v_int = objtest(v1->v_obj);
  171.                 break;
  172.             case E_POW:
  173.                 if (v2->v_type != V_NUM)
  174.                     error("Non-real power");
  175.                 val = objpowi(v1, v2->v_num);
  176.                 break;
  177.             case E_ONE:
  178.                 val.v_type = V_NUM;
  179.                 val.v_num = qlink(&_qone_);
  180.                 break;
  181.             case E_INC:
  182.                 tmp.v_type = V_NUM;
  183.                 tmp.v_num = &_qone_;
  184.                 val = objcall(OBJ_ADD, v1, &tmp);
  185.                 break;
  186.             case E_DEC:
  187.                 tmp.v_type = V_NUM;
  188.                 tmp.v_num = &_qone_;
  189.                 val = objcall(OBJ_SUB, v1, &tmp);
  190.                 break;
  191.             case E_SQUARE:
  192.                 val = objcall(OBJ_MUL, v1, v1);
  193.                 break;
  194.             default:
  195.                 error("Function \"%s\" is undefined", namefunc(index));
  196.         }
  197.         return val;
  198.     }
  199.     switch (oip->args) {
  200.         case 0:
  201.             break;
  202.         case 1:
  203.             ++stack;
  204.             stack->v_addr = v1;
  205.             stack->v_type = V_ADDR;
  206.             break;
  207.         case 2:
  208.             ++stack;
  209.             stack->v_addr = v1;
  210.             stack->v_type = V_ADDR;
  211.             ++stack;
  212.             stack->v_addr = v2;
  213.             stack->v_type = V_ADDR;
  214.             break;
  215.         case 3:
  216.             ++stack;
  217.             stack->v_addr = v1;
  218.             stack->v_type = V_ADDR;
  219.             ++stack;
  220.             stack->v_addr = v2;
  221.             stack->v_type = V_ADDR;
  222.             ++stack;
  223.             stack->v_addr = v3;
  224.             stack->v_type = V_ADDR;
  225.             break;
  226.         default:
  227.             error("Bad number of args to calculate");
  228.     }
  229.     calculate(fp, oip->args);
  230.     switch (oip->retval) {
  231.         case A_VALUE:
  232.             return *stack--;
  233.         case A_UNDEF:
  234.             freevalue(stack--);
  235.             val.v_type = V_NULL;
  236.             break;
  237.         case A_INT:
  238.             if ((stack->v_type != V_NUM) || qisfrac(stack->v_num))
  239.                 error("Integer return value required");
  240.             index = qtoi(stack->v_num);
  241.             qfree(stack->v_num);
  242.             stack--;
  243.             val.v_type = V_INT;
  244.             val.v_int = index;
  245.             break;
  246.         default:
  247.             error("Bad object return");
  248.     }
  249.     return val;
  250. }
  251.  
  252.  
  253. /*
  254.  * Routine called to clear the cache of known undefined functions for
  255.  * the objects.  This changes negative indices back into positive ones
  256.  * so that they will all be checked for existence again.
  257.  */
  258. void
  259. objuncache()
  260. {
  261.     register int *ip;
  262.     int i, j;
  263.  
  264.     i = objectnames.h_count;
  265.     while (--i >= 0) {
  266.         ip = objects[i]->actions;
  267.         for (j = OBJ_MAXFUNC; j-- >= 0; ip++)
  268.             if (*ip < 0)
  269.                 *ip = -*ip;
  270.     }
  271. }
  272.  
  273.  
  274. /*
  275.  * Print the elements of an object in short and unambiguous format.
  276.  * This is the default routine if the user's is not defined.
  277.  */
  278. static void
  279. objprint(op)
  280.     OBJECT *op;        /* object being printed */
  281. {
  282.     int count;        /* number of elements */
  283.     int i;            /* index */
  284.  
  285.     count = op->o_actions->count;
  286.     math_fmt("obj %s {", op->o_actions->name);
  287.     for (i = 0; i < count; i++) {
  288.         if (i)
  289.             math_str(", ");
  290.         printvalue(&op->o_table[i], PRINT_SHORT | PRINT_UNAMBIG);
  291.     }
  292.     math_chr('}');
  293. }
  294.  
  295.  
  296. /*
  297.  * Test an object for being "nonzero".
  298.  * This is the default routine if the user's is not defined.
  299.  * Returns TRUE if any of the elements are "nonzero".
  300.  */
  301. static BOOL
  302. objtest(op)
  303.     OBJECT *op;
  304. {
  305.     int i;            /* loop counter */
  306.  
  307.     i = op->o_actions->count;
  308.     while (--i >= 0) {
  309.         if (testvalue(&op->o_table[i]))
  310.             return TRUE;
  311.     }
  312.     return FALSE;
  313. }
  314.  
  315.  
  316. /*
  317.  * Compare two objects for equality, returning TRUE if they differ.
  318.  * This is the default routine if the user's is not defined.
  319.  * For equality, all elements must be equal.
  320.  */
  321. static BOOL
  322. objcmp(op1, op2)
  323.     OBJECT *op1, *op2;
  324. {
  325.     int i;            /* loop counter */
  326.  
  327.     if (op1->o_actions != op2->o_actions)
  328.         return TRUE;
  329.     i = op1->o_actions->count;
  330.     while (--i >= 0) {
  331.         if (comparevalue(&op1->o_table[i], &op2->o_table[i]))
  332.             return TRUE;
  333.     }
  334.     return FALSE;
  335. }
  336.  
  337.  
  338. /*
  339.  * Raise an object to an integral power.
  340.  * This is the default routine if the user's is not defined.
  341.  * Negative powers mean the positive power of the inverse.
  342.  * Zero means the multiplicative identity.
  343.  */
  344. static VALUE
  345. objpowi(vp, q)
  346.     VALUE *vp;        /* value to be powered */
  347.     NUMBER *q;        /* power to raise number to */
  348. {
  349.     VALUE res, tmp;
  350.     long power;        /* power to raise to */
  351.     unsigned long bit;    /* current bit value */
  352.  
  353.     if (qisfrac(q))
  354.         error("Raising object to non-integral power");
  355.     if (isbig(q->num))
  356.         error("Raising object to very large power");
  357.     power = (istiny(q->num) ? z1tol(q->num) : z2tol(q->num));
  358.     if (qisneg(q))
  359.         power = -power;
  360.     /*
  361.      * Handle some low powers specially
  362.      */
  363.     if ((power <= 2) && (power >= -2)) {
  364.         switch ((int) power) {
  365.             case 0:
  366.                 return objcall(OBJ_ONE, vp);
  367.             case 1:
  368.                 res.v_obj = objcopy(vp->v_obj);
  369.                 res.v_type = V_OBJ;
  370.                 return res;
  371.             case -1:
  372.                 return objcall(OBJ_INV, vp);
  373.             case 2:
  374.                 return objcall(OBJ_SQUARE, vp);
  375.         }
  376.     }
  377.     if (power < 0)
  378.         power = -power;
  379.     /*
  380.      * Compute the power by squaring and multiplying.
  381.      * This uses the left to right method of power raising.
  382.      */
  383.     bit = TOPFULL;
  384.     while ((bit & power) == 0)
  385.         bit >>= 1L;
  386.     bit >>= 1L;
  387.     res = objcall(OBJ_SQUARE, vp);
  388.     if (bit & power) {
  389.         tmp = objcall(OBJ_MUL, &res, vp);
  390.         objfree(res.v_obj);
  391.         res = tmp;
  392.     }
  393.     bit >>= 1L;
  394.     while (bit) {
  395.         tmp = objcall(OBJ_SQUARE, &res);
  396.         objfree(res.v_obj);
  397.         res = tmp;
  398.         if (bit & power) {
  399.             tmp = objcall(OBJ_MUL, &res, vp);
  400.             objfree(res.v_obj);
  401.             res = tmp;
  402.         }
  403.         bit >>= 1L;
  404.     }
  405.     if (qisneg(q)) {
  406.         tmp = objcall(OBJ_INV, &res);
  407.         objfree(res.v_obj);
  408.         return tmp;
  409.     }
  410.     return res;
  411. }
  412.  
  413.  
  414. /*
  415.  * Define a (possibly) new class of objects.
  416.  * Returns the index of the object name which identifies it.
  417.  * This index can then be used to reference the object actions.
  418.  * The list of indexes for the element names is also specified here,
  419.  * and the number of elements defined for the object.
  420.  */
  421. defineobject(name, indices, count)
  422.     char *name;        /* name of object type */
  423.     int indices[];        /* table of indices for elements */
  424. {
  425.     OBJECTACTIONS *oap;    /* object definition structure */
  426.     STRINGHEAD *hp;
  427.     int index;
  428.  
  429.     hp = &objectnames;
  430.     if (hp->h_list == NULL)
  431.         initstr(hp);
  432.     index = findstr(hp, name);
  433.     if (index >= 0)
  434.         error("Object type \"%s\" is already defined", name);
  435.     if (hp->h_count >= MAXOBJECTS)
  436.         error("Too many object types in use");
  437.     oap = (OBJECTACTIONS *) malloc(objectactionsize(count));
  438.     if (oap)
  439.         name = addstr(hp, name);
  440.     if ((oap == NULL) || (name == NULL))
  441.         error("Cannot allocate object type");
  442.     oap->name = name;
  443.     oap->count = count;
  444.     for (index = OBJ_MAXFUNC; index >= 0; index--)
  445.         oap->actions[index] = 0;
  446.     for (index = 0; index < count; index++)
  447.         oap->elements[index] = indices[index];
  448.     index = findstr(hp, name);
  449.     objects[index] = oap;
  450.     return index;
  451. }
  452.  
  453.  
  454. /*
  455.  * Check an object name to see if it is currently defined.
  456.  * If so, the index for the object type is returned.
  457.  * If the object name is currently unknown, then -1 is returned.
  458.  */
  459. checkobject(name)
  460.     char *name;
  461. {
  462.     STRINGHEAD *hp;
  463.  
  464.     hp = &objectnames;
  465.     if (hp->h_list == NULL)
  466.         return -1;
  467.     return findstr(hp, name);
  468. }
  469.  
  470.  
  471. /*
  472.  * Define a (possibly) new element name for an object.
  473.  * Returns an index which identifies the element name.
  474.  */
  475. addelement(name)
  476.     char *name;
  477. {
  478.     STRINGHEAD *hp;
  479.     int index;
  480.  
  481.     hp = &elements;
  482.     if (hp->h_list == NULL)
  483.         initstr(hp);
  484.     index = findstr(hp, name);
  485.     if (index >= 0)
  486.         return index;
  487.     if (addstr(hp, name) == NULL)
  488.         error("Cannot allocate element name");
  489.     return findstr(hp, name);
  490. }
  491.  
  492.  
  493. /*
  494.  * Return the index which identifies an element name.
  495.  * Returns minus one if the element name is unknown.
  496.  */
  497. findelement(name)
  498.     char *name;        /* element name */
  499. {
  500.     if (elements.h_list == NULL)
  501.         return -1;
  502.     return findstr(&elements, name);
  503. }
  504.  
  505.  
  506. /*
  507.  * Return the value table offset to be used for an object element name.
  508.  * This converts the element index from the element table into an offset
  509.  * into the object value array.  Returns -1 if the element index is unknown.
  510.  */
  511. objoffset(op, index)
  512.     OBJECT *op;
  513.     long index;
  514. {
  515.     register OBJECTACTIONS *oap;
  516.     int offset;            /* offset into value array */
  517.  
  518.     oap = op->o_actions;
  519.     for (offset = oap->count - 1; offset >= 0; offset--) {
  520.         if (oap->elements[offset] == index)
  521.             return offset;
  522.     }
  523.     return -1;
  524. }
  525.  
  526.  
  527. /*
  528.  * Allocate a new object structure with the specified index.
  529.  */
  530. OBJECT *
  531. objalloc(index)
  532.     long index;
  533. {
  534.     OBJECTACTIONS *oap;
  535.     OBJECT *op;
  536.     VALUE *vp;
  537.     int i;
  538.  
  539.     if ((unsigned) index >= MAXOBJECTS)
  540.         error("Allocating bad object index");
  541.     oap = objects[index];
  542.     if (oap == NULL)
  543.         error("Object type not defined");
  544.     i = oap->count;
  545.     if (i < USUAL_ELEMENTS)
  546.         i = USUAL_ELEMENTS;
  547.     if (i == USUAL_ELEMENTS)
  548.         op = (OBJECT *) allocitem(&freelist);
  549.     else
  550.         op = (OBJECT *) malloc(objectsize(i));
  551.     if (op == NULL)
  552.         error("Cannot allocate object");
  553.     op->o_actions = oap;
  554.     vp = op->o_table;
  555.     for (i = oap->count; i-- > 0; vp++)
  556.         vp->v_type = V_NULL;
  557.     return op;
  558. }
  559.  
  560.  
  561. /*
  562.  * Free an object structure.
  563.  */
  564. void
  565. objfree(op)
  566.     register OBJECT *op;
  567. {
  568.     VALUE *vp;
  569.     int i;
  570.  
  571.     vp = op->o_table;
  572.     for (i = op->o_actions->count; i-- > 0; vp++) {
  573.         if (vp->v_type == V_NUM) {
  574.             qfree(vp->v_num);
  575.         } else
  576.             freevalue(vp);
  577.     }
  578.     if (op->o_actions->count <= USUAL_ELEMENTS)
  579.         freeitem(&freelist, (FREEITEM *) op);
  580.     else
  581.         free((char *) op);
  582. }
  583.  
  584.  
  585. /*
  586.  * Copy an object value
  587.  */
  588. OBJECT *
  589. objcopy(op)
  590.     OBJECT *op;
  591. {
  592.     VALUE *v1, *v2;
  593.     OBJECT *np;
  594.     int i;
  595.  
  596.     i = op->o_actions->count;
  597.     if (i < USUAL_ELEMENTS)
  598.         i = USUAL_ELEMENTS;
  599.     if (i == USUAL_ELEMENTS)
  600.         np = (OBJECT *) allocitem(&freelist);
  601.     else
  602.         np = (OBJECT *) malloc(objectsize(i));
  603.     if (np == NULL)
  604.         error("Cannot allocate object");
  605.     np->o_actions = op->o_actions;
  606.     v1 = op->o_table;
  607.     v2 = np->o_table;
  608.     for (i = op->o_actions->count; i-- > 0; v1++, v2++) {
  609.         if (v1->v_type == V_NUM) {
  610.             v2->v_num = qlink(v1->v_num);
  611.             v2->v_type = V_NUM;
  612.         } else
  613.             copyvalue(v1, v2);
  614.     }
  615.     return np;
  616. }
  617.  
  618. /* END CODE */
  619.