home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / X_PROLOG.LZH / X_PROLOG / SOURCES / BIMETA.C < prev    next >
C/C++ Source or Header  |  1990-08-13  |  7KB  |  325 lines
  1. /*
  2.  *        X PROLOG  Vers. 2.0
  3.  *
  4.  *
  5.  *    Written by :     Andreas Toenne
  6.  *            CS Dept. , IRB
  7.  *            University of Dortmund, W-Germany
  8.  *            <at@unido.uucp>
  9.  *            <....!seismo!unido!at>
  10.  *            <at@unido.bitnet>
  11.  *
  12.  *    Copyright :    This software is copyrighted by Andreas Toenne.
  13.  *            Permission is granted hereby to copy the entire
  14.  *            package including this copyright notice without fee.
  15.  *
  16.  */
  17.  
  18. #include <stdio.h>
  19. #include <ctype.h> 
  20. #include "prolog.h"
  21. #include "extern.h"
  22. #include "error.h"
  23.  
  24. extern functor *get_functor();        /* functor */
  25. extern term *term_copy();        /* terms */
  26. extern term *int_copy();        /* terms */
  27. extern term *var_copy();        /* terms */
  28. extern short term_unify();        /* terms */
  29. extern term *term_instance();        /* terms */
  30. extern term *argument();        /* terms */
  31. extern void demolish_trails();        /* memory */
  32.  
  33. /*    VAR ( term )    */
  34.  
  35. short bivar(args)
  36. term *args[];
  37. {
  38.     return(ISVAR(args[0]));
  39. }
  40.  
  41. /*    NONVAR ( term ) */
  42.  
  43. short binonvar(args)
  44. term *args[];
  45. {
  46.     return(! ISVAR(args[0]));
  47. }
  48.  
  49. /*    ATOM ( term )    */
  50.  
  51. short biatom(args)
  52. term *args[];
  53. {
  54.     return(ISATOM(args[0]));
  55. }
  56.  
  57. /*    INTEGER ( term ) */
  58.  
  59. short biinteger(args)
  60. term *args[];
  61. {
  62.     return(ISINT(args[0]));
  63. }
  64.  
  65. /*    ATOMIC ( term )    */
  66.  
  67. short biatomic(args)
  68. term *args[];
  69. {
  70.     return(ISATOM(args[0]) || ISINT(args[0]));
  71. }
  72.  
  73. /*    TRUE      */
  74.  
  75. short bitrue( /* args */ )
  76. /* term *args[]; */
  77. {
  78.     return(TRUE);
  79. }
  80.  
  81. /*    FAIL    */
  82.  
  83. short bifail( /* args */ )
  84. /* term *args[]; */
  85. {
  86.     return(FALSE);
  87. }
  88.  
  89. /*    FUNCTOR (term, functor, arity)    */
  90.  
  91. short bifunctor(args)
  92. term *args[];
  93. {
  94.     term *t;
  95.     short i;
  96.     
  97.     if (ISSTRUCT(args[0]))            /* term */
  98.     {
  99.         if (ISVAR(args[1]))        /* functor */
  100.         {
  101.               BIND_VAR(args[1],term_copy(get_functor(NAME(args[0]),0)));
  102.         }
  103.         else
  104.         {
  105.             if (!ISATOM(args[1]))
  106.                 BIERROR(EBAD);
  107.             if (strcmp(NAME(args[0]), NAME(args[1])))
  108.                 return(FALSE);
  109.         }
  110.         if (ISVAR(args[2]))        /* arity */
  111.         {
  112.             BIND_VAR(args[2],int_copy((long)ARITY(args[0])));
  113.             return(TRUE);
  114.         }
  115.         else
  116.         {
  117.             if (!ISINT(args[2]))
  118.                 BIERROR(EBAD);
  119.                return(ARITY(args[0]) == VALUE(args[2]));
  120.         }
  121.     }
  122.     if (!ISVAR(args[0]))
  123.         BIERROR(EBAD);
  124.  
  125.     if (!ISATOM(args[1]) || !ISINT(args[2]))
  126.         BIERROR(EBAD);
  127.     
  128.     i = (short)VALUE(args[2]);
  129.     if (i<0 || i>MAXARGS)
  130.         return(FALSE);
  131.     t = term_copy(get_functor(NAME(args[1]), i));
  132.     while (i>0)
  133.         ARG(t,i--) = var_copy();
  134.     BIND_VAR(args[0], t);
  135.     return(TRUE);
  136. }
  137.  
  138. /*    ARG ( pos, structure, term )  */
  139.  
  140. short biarg(args)
  141. term *args[];
  142. {
  143.     short i;
  144.     register term *pos = args[0];
  145.     register term *str = args[1];
  146.     register term *ter = args[2];
  147.     
  148.     if (!ISSTRUCT(str))
  149.         BIERROR(EBAD);
  150.     if (!ISINT(pos))
  151.         BIERROR(EBAD);
  152.  
  153.     i = (short)VALUE(pos);
  154.     if (i<0 || i>ARITY(str))
  155.         return(FALSE);
  156.     return(term_unify(argument(str,Topenv,i), Topenv, ter, Topenv));
  157. }
  158.  
  159. /*    =.. (structure, list)     */
  160.  
  161. short biuniv(args)
  162. term *args[];
  163. {
  164.     register term *l, *t;
  165.     short i, j;
  166.     
  167.     if (ISVAR(args[0]) && ISVAR(args[1]))
  168.         BIERROR(EBAD);
  169.  
  170.     if (ISVAR(args[0]))
  171.     {
  172.         l = t = args[1];
  173.         /*    Count the arguments */
  174.         for (i=0;;i++)
  175.         {
  176.             t = argument(t, Topenv, 2);
  177.             if (!ISSTRUCT(t))        /* only , and [] */
  178.                 return(FALSE);
  179.             if (FUNC(t) != DOTFUNCTOR)    /* [] found */
  180.                 break;
  181.         }
  182.         if (!ISSTRUCT(argument(l,Topenv,1)))    /* check head */
  183.             return(FALSE);
  184.         t = term_copy(get_functor(NAME(argument(l,Topenv,1)), i));
  185.         for (j=1; j<=i; j++)
  186.         {
  187.             l = argument(l,Topenv, 2);
  188.             ARG(t,j) = term_instance(argument(l, Topenv, 1), Topenv);
  189.         }
  190.         BIND_VAR(args[0], t);
  191.         return(TRUE);
  192.     }
  193.     
  194.     /* first arg is a structure, lets construct a list and match */
  195.     /* it with the second argument */
  196.     
  197.     t = l = term_copy(DOTFUNCTOR);
  198.     ARG(t,1) = term_copy(get_functor(NAME(args[0]),0));
  199.     for (i=1,j=ARITY(args[0]); i<=j; i++)
  200.     {
  201.         ARG(l,2) = term_copy(DOTFUNCTOR);
  202.         l = ARG(l,2);
  203.         ARG(l,1) = term_instance(argument(args[0], Topenv,i),Topenv);
  204.     }
  205.     ARG(l,2) = NILATOM;
  206.     return(term_unify(t, Topenv, args[1], Topenv));
  207. }
  208.  
  209. /*    NAME ( atom, list )    */
  210.  
  211. short biname(args)
  212. term *args[];
  213. {
  214.     register term *t, *l;
  215.     char *c;
  216.     short i;
  217.     char name[MAXNAME];
  218.     
  219.     if (ISVAR(args[0]) && ISVAR(args[1]))
  220.         BIERROR(EBAD);
  221.         
  222.     if (ISVAR(args[1]))        /* let's build the name's list */
  223.     {
  224.         c = NAME(args[0]);
  225.         t = l = term_copy(DOTFUNCTOR);
  226.         while (*c)        /* while chars left */
  227.         {
  228.             ARG(l,1) = int_copy((long)(*c++));
  229.             if (*c)
  230.             {
  231.                 ARG(l,2) = term_copy(DOTFUNCTOR);
  232.                 l = ARG(l,2);
  233.             }
  234.         }
  235.         ARG(l,2) = NILATOM;
  236.         BIND_VAR(args[1], t);
  237.         return(TRUE);
  238.     }
  239.     /* Otherwise we must construct the atom from the list */
  240.     l = t = args[1];
  241.     for (i=0; FUNC(t) == DOTFUNCTOR; i++)
  242.     {
  243.         name[i] = (char)VALUE(argument(t,Topenv,1));
  244.         t = argument(t, Topenv, 2);
  245.     }
  246.     name[i] = '\0';
  247.     t = term_copy(get_functor(name, 0));
  248.     return(term_unify(args[0], Topenv, t, Topenv));
  249. }
  250.  
  251. /*    ! (the cut)    */
  252.  
  253. short bicut( /* args */ )
  254. /* term *args[]; */
  255. {
  256.     env *e;
  257.     env *e1;
  258.     term *t;
  259.     short i,j;
  260.     
  261.     e = Topenv;
  262.     while (e)
  263.     {
  264.         e = e->pre;
  265.         if (FUNC(e->current) == COMMAFUNCTOR)
  266.             t = ARG(e->current, 1);
  267.         else
  268.             t = e->current;
  269.         if (FUNC(t) != CALLFUNCTOR)
  270.             break;
  271.         e = e->pre;        /* skip the $call */
  272.         if (FUNC(e->current) == COMMAFUNCTOR)
  273.             t = ARG(e->current, 1);
  274.         else
  275.             t = e->current;
  276.         if (FUNC(t) == COMMAFUNCTOR || FUNC(t) == SEMICOLONFUNCTOR)
  277.             continue;
  278.         break;
  279.     }
  280.  
  281. /**/    if (e != Preenv) debug();
  282.     
  283.     if (e)            /* we found a proper enviroment */
  284.     {
  285.         /* if enviroment is frozen, remove backlogs above env */
  286.         /* the cruch the stack : move Topenv ontop of Preenv */
  287.         /* this saves some stack, but if we ! in a ; or , Goal */
  288.         /* this extra space is not freed */
  289.         
  290.         if ((long)e < (long)Backpoint)
  291.         {
  292.             while ((long)e < (long)Backpoint->pre)
  293.                 Backpoint = Backpoint->pre;
  294.             Backpoint = Backpoint->pre;
  295.  
  296.             /* e1 points to space above Preenv */
  297.             e1 = (env *)((long)Preenv + sizeof(env) +
  298.                     Preenv->nvars*sizeof(term));
  299.  
  300.             /* move Topenv ontop of Preenv (at the place of e1) */
  301.             if (Topenv != e1) /* Topenv already here ? */
  302.             {
  303.                 e1->pre = Preenv;
  304.                 e1->current = Topenv->current;
  305.                 j = e1->nvars = Topenv->nvars;
  306.  
  307.                 /* move frame of Topenv ontop of e1 */
  308.                 /* j and t are utmost necessary because */
  309.                 /* e1 and Topenv might overlap */
  310.                 e1->frame = (term *)(e1+1); /* frame behind e */
  311.                 t = Topenv->frame;    /* frame behind Topenv */
  312.                 for (i=0; i<j; i++)
  313.                     e1->frame[i] = t[i];
  314.             }
  315.  
  316.             Topenv = e1;
  317.             stacktop = (char *)((long)e1 + sizeof(env) +
  318.                         e1->nvars * sizeof(term));
  319.             demolish_trails(Backpoint->traillev);
  320.         }
  321.     }
  322. /**/    if (e != Preenv) debug();
  323.     return(TRUE);
  324. }
  325.