home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / X_PROLOG.LZH / X_PROLOG / SOURCES / MACHINE.C < prev    next >
C/C++ Source or Header  |  1990-08-13  |  8KB  |  281 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 <setjmp.h> 
  19. #include "prolog.h"
  20. #include "error.h"
  21. #include "extern.h"
  22.  
  23. extern functor *get_functor();    /* functor */
  24.  
  25. extern term *nil_proto();    /* terms */
  26. extern term *argument();    /* terms */
  27. extern term *deref();        /* terms */
  28. extern short term_unify();    /* terms */
  29. extern term *term_instance();    /* terms */
  30.  
  31. extern void pop_copies();    /* memory */
  32.  
  33. extern void push_back();    /* memory */
  34.  
  35. extern void push_env();        /* memory */
  36. extern void push_frame();    /* memory */
  37.  
  38. extern void pop_trails();    /* memory */
  39.  
  40. extern void panic();        /* error */
  41. extern term *error();        /* error */
  42.  
  43. extern short call_builtin();    /* builtin */
  44.  
  45. extern void init_stacks();    /* init */
  46.  
  47. term *ocopytop, *ocopynext;    /* copystack */
  48.  
  49. /*    This is the prolog machine    */
  50.  
  51. void machine(goal)
  52. term *goal;                /* the goal to start with */
  53. {
  54.     register term *c_term;        /* the current term */
  55.     register clause *c_clause;    /* the current clause */
  56.     register short success;
  57.     
  58.     if (FUNC(goal) == NILFUNCTOR)    /* no main goal ?? */
  59.         panic(NOGOAL);
  60.  
  61.     ocopytop = copytop;        /* save the size of the copystack */
  62.     ocopynext = copynext;
  63.         
  64.     if (setjmp(&abortpoint))    /* returned from longjmp */
  65.     {
  66.         copytop = ocopytop;
  67.         copynext = ocopynext;
  68.         trailtop= 0L;
  69.         Preenv = Topenv = (env *)0L;
  70.         Backpoint = (backlog *)0L;
  71.         stacktop = stack;
  72.     }
  73.         
  74.     c_errno = 0;        /* clear error number */
  75.     
  76.     /* we first set the logs for the main goal */
  77.     
  78.     push_env(0L, goal);        /* no ancestor, no vars */
  79.     push_frame(Topenv, 0);
  80.     if (FUNC(goal) == COMMAFUNCTOR)
  81.         c_term = argument(goal, Topenv, 1);
  82.     else
  83.         c_term = deref(goal, Topenv);
  84.  
  85.     success = TRUE;
  86.     do                /* forever */
  87.     {
  88.         /* upon start of the loop c_term points to the current */
  89.         /* 'program' term in the current enviroment. */
  90.         /* if !success then backtracking has set c_clause, */
  91.         /* otherwise we must set c_clause */
  92.  
  93.         if (success)            /* set c_clause */
  94.         {
  95.             if (!ISSTRUCT(c_term)    /* must be compound term */
  96.                || ! (c_clause = (clause *)FUNC(c_term)->cp))
  97.             {
  98.                 /* replace the faulty call by error */
  99.                 push_env(Topenv, NULL);
  100.                 push_frame(Topenv, MAXVARS);
  101.                 Topenv->current = error(ENOCLAUSE, c_term);
  102.                 c_term=ARG(Topenv->current,1);
  103.                 continue;    /* try again with error */
  104.             }
  105.             /* if our current clause offers some more alternatives*/
  106.             /* we must set a backtrack log for the current call */
  107.         
  108.             if (c_clause->next)
  109.                 push_back(c_clause);
  110.         }
  111.             
  112.         /* build preliminary enviroment for goal */
  113.         if (! ISBUILTIN(c_clause))
  114.         {
  115.             push_env(Topenv, c_clause->body);
  116.             push_frame(Topenv, c_clause->nvars);
  117.         }
  118.         
  119.         /* now do the true work */
  120.  
  121.         if (dodebug) debug();
  122.         if (ISBUILTIN(c_clause))    /* call a builtin */
  123.         {
  124.             switch((short)c_clause->head)
  125.             {
  126.                 case 0:            /* abort */
  127.                     longjmp(&abortpoint, TRUE);
  128.                 case 1:         /* call */
  129.                     push_env(Topenv,
  130.                         argument(c_term,Topenv,1));
  131.                     push_frame(Topenv, 0);
  132.                       if (FUNC(Topenv->current) == COMMAFUNCTOR)
  133.                       c_term = ARG(Topenv->current, 1);
  134.                       else
  135.                       c_term = Topenv->current;
  136.  
  137.                     success = TRUE;
  138.                     continue;
  139.             }
  140.             success = call_builtin((short)c_clause->head,
  141.                          c_term,Topenv);
  142.         }
  143.         else                /* unify c_term and head */
  144.             success = term_unify(c_term, Preenv,
  145.                          c_clause->head, Topenv);
  146.         
  147.         if (c_errno)        /* an bi error has occured */
  148.         {
  149.             if (c_errno == ESYNTAX)
  150.             { 
  151.                 c_errno = 0;
  152.                 goto fail;
  153.             }
  154.             if (c_errno == EIO && !io_errors)
  155.             {
  156.                 c_errno = 0;
  157.                 goto fail;
  158.             }
  159.             push_env(Topenv, NULL);
  160.             push_frame(Topenv, MAXVARS);
  161.             Topenv->current = error(c_errno, c_term);
  162.             c_term=ARG(Topenv->current,1);
  163.             if (c_errno != ESYNTAX)
  164.             {
  165.                 biseen();
  166.                 bitold();
  167.             }
  168.             c_errno = 0;
  169.             success = TRUE;
  170.             continue;    /* again with new error goal */
  171.         }
  172.             
  173.         if (success)        /* the head matches the current term */
  174.         {
  175.             /* try to enter the body of the clause */
  176.  
  177.             if (! ISBUILTIN(c_clause) &&
  178.                 FUNC(c_clause->body) != TRUEFUNCTOR)
  179.             {
  180.                 if (FUNC(Topenv->current) == COMMAFUNCTOR)
  181.                   c_term = ARG(Topenv->current, 1);
  182.                 else
  183.                   c_term = Topenv->current;
  184.             }
  185.             else
  186.             /* assume c_clause is done. */
  187.             /* we now descend in the enviroments until a not */
  188.             /* done enviroment is found. */
  189.             /* the skipped enviroments are finished and must be */
  190.             /* removed. */
  191.             /* if we move past a 'locked' enviroment, we */
  192.             /* must duplicate it for sake of backtracking */
  193.             /* this is done by creating a new enviroment */
  194.             /* an its frame beeing the old frame */
  195.             {
  196.                 register env *e = Topenv;
  197.                 
  198.                 /* search for an proper enviroment */
  199.                 do
  200.                 {
  201.                     if (FUNC(e->current)
  202.                                  == COMMAFUNCTOR)
  203.                         break;
  204.                     else
  205.                         if (!(e=e->pre))  /* oops */
  206.                             panic(EXITUS);
  207.                 } while (TRUE);
  208.  
  209.                 /* clean up the stack */
  210.                 /* easy if e is not frozen */
  211.                 if ((long)e > (long)Backpoint)
  212.                 {
  213.                     Topenv = e;    /* reduce env stack */
  214.                     Preenv = Topenv->pre;
  215.                     stacktop = (char *)((long)Topenv +
  216.                         sizeof(env) + Topenv->nvars *
  217.                         sizeof(term));
  218.                 }
  219.                 else
  220.                 {
  221.                     /* cut stack upto choice point */
  222.                     stacktop = (char *)((long)Backpoint +
  223.                         sizeof(backlog));
  224.                         
  225.                     /* duplicate e, but not it's vars */
  226.                     push_env(e->pre, 0L);
  227.                     Topenv->frame = e->frame;
  228.                     Topenv->nvars = e->nvars;
  229.                 }
  230.                 
  231.                 /* setup c_term and c_clause */
  232.                 Topenv->current = ARG(e->current,2);
  233.                 if (FUNC(Topenv->current) == COMMAFUNCTOR)
  234.                   c_term = ARG(Topenv->current, 1);
  235.                 else
  236.                   c_term = Topenv->current;
  237.             } /* else */
  238.         } /* success */
  239.         else /* !success */
  240.         {
  241. fail:
  242.             /* the builtin has failed or the current clauses */
  243.             /* head didn't match. */
  244.             
  245.             /* remove new term copies */
  246.             pop_copies(Backpoint->copylev);
  247.             
  248.             /* unbind frozen vars */
  249.             pop_trails(Backpoint->traillev);
  250.             
  251.             /* remove enviroments without alternatives */
  252.             /* and restore the old c_term */
  253.             stacktop = (char *)((long)Backpoint+sizeof(backlog));
  254.             Topenv = Backpoint->frozen_env;
  255.             Preenv = Topenv->pre;
  256.  
  257.             if (FUNC(Topenv->current) == COMMAFUNCTOR)
  258.                 c_term = ARG(Topenv->current, 1);
  259.             else
  260.                 c_term = Topenv->current;
  261.                 
  262.             while (FUNC(c_term) == CALLFUNCTOR)
  263.                 c_term = argument(c_term, Topenv, 1);
  264.                 
  265.             /* setup the new current clause */
  266.             c_clause = ((clause *)(Backpoint->resume))->next;
  267.             
  268.             /* if we got no further alternative, we must */
  269.             /* remove this backtrack log */
  270.             /* otherwise we must update the log */
  271.             if (!c_clause || !c_clause->next)
  272.             {
  273.                 stacktop = (char *)Backpoint;
  274.                 Backpoint = Backpoint->pre;
  275.             }
  276.             else
  277.                 Backpoint->resume = (char *)c_clause;
  278.         } /* !success */
  279.     } while (TRUE);
  280. }
  281.