home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / p / plbin.zip / pl / src / pl-op.c < prev    next >
C/C++ Source or Header  |  1992-05-26  |  9KB  |  352 lines
  1. /*  pl-op.c,v 1.1.1.1 1992/05/26 11:52:23 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: operator functions and declarations
  8. */
  9.  
  10. #include "pl-incl.h"
  11.  
  12. forwards int    atomToOperatorType P((Atom));
  13. forwards Atom    operatorTypeToAtom P((int));
  14.  
  15. static Operator operatorTable[OPERATORHASHSIZE];
  16.  
  17. /*  Find an operator in the table. Type is one of OP_PREFIX, OP_INFIX or
  18.     op_POSTFIX.
  19.  
  20.  ** Wed Apr 20 10:34:55 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  21.  
  22. Operator
  23. isCurrentOperator(name, type)
  24. register Atom name;
  25. int type;
  26. { register int v = pointerHashValue(name, OPERATORHASHSIZE);
  27.   register Operator op;
  28.  
  29.   for(op=operatorTable[v]; op && !isRef((word)op); op=op->next)
  30.   { if (op->name != name)
  31.       continue;
  32.     switch(op->type)
  33.     { case OP_FX:
  34.       case OP_FY:    if (type == OP_PREFIX)
  35.               return op;
  36.             continue;
  37.       case OP_XF:
  38.       case OP_YF:    if (type == OP_POSTFIX)
  39.               return op;
  40.             continue;
  41.       case OP_XFX:
  42.       case OP_XFY:
  43.       case OP_YFX:
  44.       case OP_YFY:    if (type == OP_INFIX)
  45.               return op;
  46.             continue;
  47.     }
  48.   }
  49.  
  50.   return (Operator) NULL;
  51. }
  52.  
  53.  
  54. static int
  55. atomToOperatorType(atom)
  56. Atom atom;
  57. { if (atom == ATOM_fx)            return OP_FX;
  58.   else if (atom == ATOM_fy)        return OP_FY;
  59.   else if (atom == ATOM_xfx)        return OP_XFX;
  60.   else if (atom == ATOM_xfy)        return OP_XFY;
  61.   else if (atom == ATOM_yfx)        return OP_YFX;
  62.   else if (atom == ATOM_yfy)        return OP_YFY;
  63.   else if (atom == ATOM_yf)        return OP_YF;
  64.   else if (atom == ATOM_xf)        return OP_XF;
  65.  
  66.   return -1;
  67. }
  68.  
  69. static Atom
  70. operatorTypeToAtom(type)
  71. int type;
  72. { switch(type)
  73.   { case OP_FX:                return ATOM_fx;
  74.     case OP_FY:                return ATOM_fy;
  75.     case OP_XFX:            return ATOM_xfx;
  76.     case OP_XFY:            return ATOM_xfy;
  77.     case OP_YFX:            return ATOM_yfx;
  78.     case OP_YFY:            return ATOM_yfy;
  79.     case OP_YF:                return ATOM_yf;
  80.     case OP_XF:                return ATOM_xf;
  81.   }
  82.   return (Atom) NULL;
  83. }
  84.  
  85. word
  86. pl_current_op(prec, type, name, h)
  87. Word prec, type, name;
  88. word h;
  89. { int Prec = 0;                    /* not specified */
  90.   int Type = -1;                /* not specified */
  91.   Atom Name = (Atom) NULL;            /* not specified */
  92.   Operator op;
  93.  
  94.   switch( ForeignControl(h) )
  95.   { case FRG_FIRST_CALL:
  96.       op = operatorTable[0];
  97.       break;
  98.     case FRG_REDO:
  99.       op = (Operator) ForeignContextAddress(h);
  100.       break;
  101.     case FRG_CUTTED:
  102.     default:
  103.       succeed;
  104.   }
  105.  
  106.   if (isInteger(*prec))
  107.     Prec = (int) valNum(*prec);
  108.   else if (!isVar(*prec))
  109.     fail;
  110.  
  111.   if (isAtom(*type))
  112.   { if ((Type = atomToOperatorType((Atom)*type)) < 0)
  113.       fail;
  114.   } else if (!isVar(*type))
  115.     fail;
  116.  
  117.   if (isAtom(*name))
  118.     Name = (Atom)*name;
  119.   else if (!isVar(*name))
  120.     fail;
  121.  
  122.   for( ; op; op = op->next )
  123.   { while(isRef((word)op))
  124.     { op = *((Operator *)unRef(op));
  125.       if (op == (Operator) NULL)
  126.     fail;
  127.     }
  128.     if (Name != (Atom) NULL && Name != op->name)
  129.       continue;
  130.     if (Type >= 0 && Type != op->type  )
  131.       continue;
  132.     if (Prec > 0 && Prec != op->priority)
  133.       continue;
  134.  
  135.     TRY(unifyAtomic(name, op->name));
  136.     TRY(unifyAtomic(type, operatorTypeToAtom(op->type)));
  137.     TRY(unifyAtomic(prec, consNum(op->priority)));
  138.  
  139.     if (Name != (Atom) NULL && Type >=0)
  140.       succeed;
  141.  
  142.     return_next_table(Operator, op);
  143.   }
  144.  
  145.   fail;
  146. }
  147.  
  148. /*  The following three functions check whether an atom is declared as
  149.     an operator. 'type' and 'priority' are integer pointers. Their
  150.     value is filled with the corresponding definition of the operator.
  151.  
  152.  ** Sun Apr 17 13:25:17 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  153.  
  154. bool
  155. isPrefixOperator(atom, type, priority)
  156. Atom atom;
  157. int *type, *priority;
  158. { register Operator op;
  159.  
  160.   if ((op = isCurrentOperator(atom, OP_PREFIX)) != (Operator) NULL)
  161.   { if (op->priority != 0)
  162.     { *priority = op->priority;
  163.       *type = op->type;
  164.  
  165.       succeed;
  166.     }
  167.   }
  168.  
  169.   fail;
  170. }
  171.  
  172. bool
  173. isPostfixOperator(atom, type, priority)
  174. Atom atom;
  175. int *type, *priority;
  176. { Operator op;
  177.  
  178.   if ((op = isCurrentOperator(atom, OP_POSTFIX)) != (Operator) NULL)
  179.   { if (op->priority != 0)
  180.     { *priority = op->priority;
  181.       *type = op->type;
  182.  
  183.       succeed;
  184.     }
  185.   }
  186.  
  187.   fail;
  188. }
  189.  
  190. bool
  191. isInfixOperator(atom, type, priority)
  192. Atom atom;
  193. int *type, *priority;
  194. { Operator op;
  195.  
  196.   if ((op = isCurrentOperator(atom, OP_INFIX)) != (Operator) NULL)
  197.   { if (op->priority != 0)
  198.     { *priority = op->priority;
  199.       *type = op->type;
  200.  
  201.       succeed;
  202.     }
  203.   }
  204.  
  205.   fail;
  206. }
  207.  
  208. /*  Declare a new operator. 'f' is a functor definition pointer, 'type'
  209.     if one of OP_FX, ... and 'priority' is the priority (0-1200].
  210.  
  211.  ** Sun Apr 17 13:24:04 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  212.  
  213. bool
  214. operator(name, type, priority)
  215. Atom name;
  216. int type;
  217. int priority;
  218. { Operator op = (Operator) NULL;
  219.  
  220.   switch(type)
  221.   { case OP_FX:
  222.     case OP_FY:        op = isCurrentOperator(name, OP_PREFIX);
  223.             break;
  224.     case OP_XF:
  225.     case OP_YF:        op = isCurrentOperator(name, OP_POSTFIX);
  226.             break;
  227.     default:        op = isCurrentOperator(name, OP_INFIX);
  228.             break;
  229.   }
  230.  
  231.   if (op == (Operator) NULL)
  232.   { int v;
  233.  
  234.     v = pointerHashValue(name, OPERATORHASHSIZE);
  235.     op = (Operator) allocHeap(sizeof(struct operator));
  236.     op->next = operatorTable[v];
  237.     operatorTable[v] = op;
  238.     op->name = name;
  239.   }
  240.   op->priority = priority;
  241.   op->type = type;
  242.  
  243.   succeed;
  244. }
  245.  
  246. word
  247. pl_op1(priority, type, name)
  248. Word priority, type, name;
  249. { int t;
  250.   int pri;
  251.  
  252.   if (!isAtom(*name) || !isAtom(*type) || !isInteger(*priority))
  253.     fail;
  254.  
  255.   if ((pri = (int) valNum(*priority)) < 0 || pri > 1200)
  256.     fail;
  257.   if ((t = atomToOperatorType((Atom)*type)) < 0)
  258.     fail;
  259.  
  260.   return operator((Atom)*name, t, pri);
  261. }
  262.  
  263. /*  Define standard system operators.
  264.  
  265.  ** Sun Apr 17 13:25:40 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  266.  
  267. bool
  268. newOp(name, type, pri)
  269. char *name;
  270. int type;
  271. int pri;
  272. { return operator(lookupAtom(name), type, pri);
  273. }
  274.  
  275. #define OP(a, t, p) { (Operator)NULL, a, t, p }
  276.  
  277. static struct operator operators[] = {
  278.   OP(ATOM_star,        OP_YFX,        400),        /* * */
  279.   OP(ATOM_plus,        OP_FX,        500),        /* + */
  280.   OP(ATOM_plus,        OP_YFX,        500),
  281.   OP(ATOM_comma,    OP_XFY,           1000),        /* , */
  282.   OP(ATOM_minus,    OP_FX,        500),        /* - */
  283.   OP(ATOM_minus,    OP_YFX,        500),
  284.   OP(ATOM_grammar,    OP_XFX,           1200),        /* --> */
  285.   OP(ATOM_ifthen,    OP_XFY,           1050),        /* -> */
  286.   OP(ATOM_divide,    OP_YFX,        400),        /* / */
  287.   OP(ATOM_div,        OP_YFX,        400),        /* // */
  288.   OP(ATOM_and,        OP_YFX,        500),        /* /\ */
  289.   OP(ATOM_module,    OP_XFY,        600),        /* : */
  290.   OP(ATOM_prove,    OP_FX,           1200),        /* :- */
  291.   OP(ATOM_prove,    OP_XFX,           1200),
  292.   OP(ATOM_semicolon,    OP_XFY,           1100),        /* ; */
  293.   OP(ATOM_bar,        OP_XFY,           1100),        /* | */
  294.   OP(ATOM_smaller,    OP_XFX,        700),        /* < */
  295.   OP(ATOM_lshift,    OP_YFX,        400),        /* << */
  296.   OP(ATOM_equals,    OP_XFX,        700),        /* = */
  297.   OP(ATOM_univ,        OP_XFX,        700),        /* =.. */
  298.   OP(ATOM_ar_equals,    OP_XFX,        700),        /* =:= */
  299.   OP(ATOM_smaller_equal,OP_XFX,        700),        /* =< */
  300.   OP(ATOM_larger_equal,    OP_XFX,        700),        /* >= */
  301.   OP(ATOM_strick_equal,    OP_XFX,        700),        /* == */
  302.   OP(ATOM_ar_not_equal,    OP_XFX,        700),        /* =\= */
  303.   OP(ATOM_larger,    OP_XFX,        700),        /* > */
  304.   OP(ATOM_rshift,    OP_YFX,        400),        /* >> */
  305.   OP(ATOM_obtain,    OP_FX,        500),        /* ? */
  306.   OP(ATOM_query,    OP_FX,           1200),        /* ?- */
  307.   OP(ATOM_at_smaller,    OP_XFX,        700),        /* @< */
  308.   OP(ATOM_at_smaller_eq,OP_XFX,        700),        /* @=< */
  309.   OP(ATOM_at_larger,    OP_XFX,        700),        /* @> */
  310.   OP(ATOM_at_larger_eq,    OP_XFX,        700),        /* @>= */
  311.   OP(ATOM_backslash,    OP_FX,        500),        /* \ */
  312.   OP(ATOM_not_provable,    OP_FY,        900),        /* \+ */
  313.   OP(ATOM_or,        OP_YFX,        500),        /* \/ */
  314.   OP(ATOM_not_equals,    OP_XFX,        700),        /* \= */
  315.   OP(ATOM_not_strickt_equals,OP_XFX,    700),        /* \== */
  316.   OP(ATOM_at_equals,    OP_XFX,        700),        /* =@= */
  317.   OP(ATOM_at_not_equals,OP_XFX,        700),        /* \=@= */
  318.   OP(ATOM_hat,        OP_XFY,        200),        /* ^ */
  319.   OP(ATOM_discontiguous,OP_FX,           1150),        /* discontiguous */
  320.   OP(ATOM_dynamic,    OP_FX,           1150),        /* dynamic */
  321.   OP(ATOM_is,        OP_XFX,        700),        /* is */
  322.   OP(ATOM_mod,        OP_XFX,        300),        /* mod */
  323.   OP(ATOM_module_transparent,OP_FX,    1150),        /* module_transparent */
  324.   OP(ATOM_multifile,    OP_FX,           1150),        /* multifile */
  325.   OP(ATOM_not,        OP_FY,        900),        /* not */
  326.   OP(ATOM_xor,        OP_YFX,        400),        /* xor */
  327.   OP(ATOM_tilde,    OP_FX,        900),        /* ~ */
  328.  
  329.   OP((Atom)NULL,    0,        0)
  330. };
  331.  
  332.  
  333. void
  334. initOperators()
  335. { { register Operator *op;
  336.     register int n;
  337.  
  338.     for(n=0, op=operatorTable; n < (OPERATORHASHSIZE-1); n++, op++)
  339.       *op = (Operator)makeRef(op+1);
  340.   }
  341.  
  342.   { register Operator op;
  343.     register int v;
  344.  
  345.     for( op = &operators[0]; op->name; op++ )
  346.     { v = pointerHashValue(op->name, OPERATORHASHSIZE);
  347.       op->next = operatorTable[v];
  348.       operatorTable[v] = op;
  349.     }
  350.   }
  351. }
  352.