home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / huprolog / Source / C / EXEC < prev    next >
Encoding:
Text File  |  1990-06-10  |  15.1 KB  |  466 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     **
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include "systems.h"
  18. #include "types.h"
  19. #include "errors.h"
  20. #include "atoms.h"
  21. #include "manager.h"
  22.  
  23. /* 
  24.  
  25. EXECUTE
  26.  
  27. Execute is the finite state control of the abstract Prolog machine. It
  28. executes the goal by manipulating the local and global stacks,
  29. and uses UNIFY to match goals against clauses from the
  30. database. CALLEVALPRED handles evaluable predicates.
  31.  
  32. */
  33.  
  34.  
  35. IMPORT boolean EVENT,UserAbort;  /* from signal handler in prolog.c */
  36. IMPORT boolean ENAB_INTR;
  37. IMPORT ENV CHOICEPOINT,ENVTOP;
  38. IMPORT boolean SPYTRACE,WARNFLAG;
  39. IMPORT ENV NEWENV();                  
  40. IMPORT void ABORT(),SYSTEMERROR();      /* from linebufffer.c */
  41. IMPORT CLAUSE ANDG,OR1G,OR2G,IMPG;
  42. IMPORT TERM GLOTOP,HEAPTOP;
  43. IMPORT ATOM ATOMSTOP;
  44. IMPORT STRING STRINGSTOP;
  45. IMPORT TRAIL TRAILEND;
  46. IMPORT ATOM LASTATOM;
  47. IMPORT void wq();
  48. IMPORT TERM mk2sons();
  49. IMPORT boolean UNIFY();
  50. IMPORT TERM DOEVAL();
  51. IMPORT void CALLEVALPRED();   /* from evalpreds.c */
  52. IMPORT boolean TRACE();
  53. IMPORT void reclaim_heap();
  54. IMPORT ATOM LOOKUP();
  55. IMPORT string ERRORMSG();
  56.  
  57. /* 
  58. EXPORT int BCT;
  59. EXPORT boolean EXECUTE();
  60. */
  61.  
  62. int BCT=0;
  63.  
  64. int ERRORFLAG=0;
  65.  
  66. boolean RES ; /* result from callevalpred */
  67.  
  68. #if P8000 && SMALLVERSION
  69.   LOCAL TERM BASE;
  70.   LOCAL int ARITY;
  71.   LOCAL ENV CHP;
  72. #endif
  73.  
  74. GLOBAL boolean EXECUTE (REGISTER TERM CALLP, REGISTER ENV CALLENV)
  75. { auto ENV CALLTOP;
  76.   REGISTER ENV ENVP;
  77.   REGISTER CLAUSE CP;
  78.   register ATOM A;
  79. #if RISCOS 
  80.   static int pollctr = 0;
  81. #endif
  82. #if ! (P8000 && SMALLVERSION)
  83.   TERM BASE;
  84.   int ARITY;
  85.   ENV CHP;
  86. #endif
  87.  
  88.   /* GOALENV=CALLENV;*/
  89.   CALLTOP=ENVTOP;
  90.  
  91.   CALLP=mk2sons(name(CALLP),son(CALLP),nil_atom,nil_term);
  92.  
  93.   /* Finite State Automata controlling Prolog execution */
  94.  
  95.   CALLQ:
  96. #if BIC
  97.          /* Check if a key was pressed */
  98.          if(*((int *)(0xf297))!= *((int *)(0xf299)))
  99.            { EVENT=true; UserAbort=true; 
  100.            }
  101. #endif
  102. #if RISCOS 
  103.          if( ++pollctr > 30 ) {
  104.             pollctr = 0;
  105.             if( _kernel_escape_seen() )
  106.             { EVENT=true; UserAbort=true;
  107.             }
  108.          }
  109. #endif
  110.          if(EVENT)
  111.          {  if(UserAbort && ENAB_INTR)
  112.             { UserAbort=false; EVENT=SPYTRACE;
  113.               if(clause(INTERRUPT_0)==nil_clause) ABORT(ABORTE);
  114.               if(non_nil_atom(name(CALLP)))
  115.                   CALLP=mk2sons(INTERRUPT_0,nil_term,GOTO_1,CALLP);
  116.               else
  117.                   CALLP=mk2sons(INTERRUPT_0,nil_term,nil_atom,nil_term);
  118.                 
  119.             }
  120.             if(ERRORFLAG)
  121.             { TERM T;
  122.               if(clause(ERROR_2)==nil_clause) ABORT(ERRORFLAG);
  123.               T=mk2sons(UNBOUNDT,nil_term,
  124.                         LOOKUP(ERRORMSG(ERRORFLAG),0,false),nil_term);
  125.               UNI(T,CALLP);
  126.               if(non_nil_atom(name(br(CALLP))))
  127.                   CALLP=mk2sons(ERROR_2,T, GOTO_1,br(CALLP));
  128.               else
  129.                   CALLP=mk2sons(ERROR_2,T,nil_atom,nil_term);
  130.               ERRORFLAG=0;
  131.             }
  132.             if(SPYTRACE) 
  133.                { if(name(CALLP)!=GOTO_1 && class(name(CALLP))!=VARP)
  134.                  if(TRACE(CALL_0,CALLP,CALLENV)==false) goto FAILQ; }
  135.  
  136.          EVENT=SPYTRACE;
  137.          }
  138.         /* CALLP holds a goal and CALLENV its environment. */
  139.         A=name(CALLP);
  140. #if  HACKY
  141.         ++nrofcalls(A);
  142. #endif 
  143.         if(A>=LASTATOM && non_nil_clause(CP=clause(A)))
  144.                       goto PROCQ;  /* ----------------------->> PROCQ */
  145.         switch(class(A))
  146.         { case NORMP:
  147.               if(non_nil_clause(CP=clause(A))) 
  148.                       goto PROCQ;  /* ----------------------->> PROCQ */
  149.               if(non_nil_clause(clause(UNKNOWN_1)))
  150.               { TERM T;
  151.                 T=mkfreevar();UNI(T,CALLP);
  152.                 if(non_nil_atom(name(br(CALLP))))
  153.                     CALLP=mk2sons(UNKNOWN_1,T,GOTO_1,br(CALLP));
  154.                 else
  155.                     CALLP=mk2sons(UNKNOWN_1,T,nil_atom,nil_term);
  156.                 goto CALLQ;
  157.               }
  158.               if(WARNFLAG)
  159.                 { ws("WARNING: no clause for relation ");
  160.                   wq(A);ws("/");wi(arity(A));ws("\n");
  161.                 }
  162.               goto FAILQ; /* -------------------------------->> FAILQ */
  163.  
  164.         case FAILP: 
  165.               goto FAILQ; /* -------------------------------->> FAILQ */
  166.  
  167.         case ISVARP: 
  168.               { register TERM T;
  169.                 T=son(CALLP);
  170.                 deref_(T,base(CALLENV));
  171.                 if (name(T)==UNBOUNDT) goto RETURNQ;
  172.                 goto FAILQ;
  173.               }
  174.  
  175.         case ISATOMP: 
  176.               { register TERM T;
  177.                 T=son(CALLP);
  178.                 deref_(T,base(CALLENV));
  179.                 if (isatom(T)) goto RETURNQ;
  180.                 goto FAILQ;
  181.               }
  182.  
  183.         case ISINTEGERP:
  184.               { register TERM T;
  185.                 T=son(CALLP);
  186.                 deref_(T,base(CALLENV));
  187.                 if (is_integer(name(T))) goto RETURNQ;
  188.                 goto FAILQ;
  189.               }
  190.  
  191.         case ISMEMBP:
  192.              { register TERM T;
  193.                int I=0;
  194.                TERM TT,A0;
  195.                ATOM A,AA;
  196.                E=CALLENV; BE=base(CALLENV);
  197.                T=son(CALLP); deref(T); A=name(A0=T);
  198.                T=br(son(CALLP)); deref(T); 
  199.                if (A==COLON_2) AA=name(arg1(A0)); else AA=0;
  200.                while (name(T)==CONS_2)
  201.                { I++;
  202.                  TT=son(T); deref(TT);
  203.                  if (name(TT)==UNBOUNDT) 
  204.                     if (UNI(son(T),A0)) goto RETURNQ;
  205.                     else goto FAILQ;
  206.                  if ((name(TT)==A || A==UNBOUNDT) && UNI(son(T),A0)) 
  207.                       goto RETURNQ;
  208.                  if (I>100000) return false; /* probably cyclic term */
  209.                  T=br(son(T));
  210.                  deref(T);
  211.                }
  212.                goto FAILQ;
  213.              }
  214.  
  215.         case NOMEMBP:
  216.              { register TERM T;
  217.                int I=0;
  218.                TERM TT,A0;
  219.                ATOM A,AA;
  220.                E=CALLENV; BE=base(CALLENV);
  221.                T=son(CALLP); deref(T); A=name(A0=T);
  222.                T=br(son(CALLP)); deref(T); 
  223.                if (A==COLON_2) AA=name(arg1(A0)); else AA=0;
  224.                while (name(T)==CONS_2)
  225.                { I++;
  226.                  TT=son(T); deref(TT);
  227.                  if (name(TT)==UNBOUNDT) 
  228.                     if (UNI(son(T),A0)) goto FAILQ;
  229.                     else goto RETURNQ;
  230.                  if ((name(TT)==A || A==UNBOUNDT) && UNI(son(T),A0)) 
  231.                       goto FAILQ;
  232.                  if (I>100000) return false; /* probably cyclic term */
  233.                  T=br(son(T));
  234.                  deref(T);
  235.                }
  236.                goto RETURNQ;
  237.              }
  238.  
  239.         case CUTP:
  240.               ENVP=CALLENV;
  241.               { register CLAUSE RC;
  242.                 RC=rule(ENVP);
  243.                 while(ENVP>CALLTOP  && 
  244.  
  245.                 ( RC >=IMPG || RC==nil_clause)
  246. /*
  247.                  (RC==IMPG || RC==ANDG || RC==OR1G || RC==OR2G 
  248.                             || RC==nil_clause ) 
  249. */
  250.                   )
  251.                   { ENVP=env(ENVP); RC=rule(ENVP); }
  252.               }
  253.               CHOICEPOINT=choice(ENVP);
  254.               goto RETURNQ; /* ---------------------------->> RETURNQ */
  255.  
  256.          case ARITHP:
  257.                /* predicate $evaluate */
  258.                CALLP=DOEVAL(CALLP,CALLENV);
  259.                if(ERRORFLAG)goto CALLQ;
  260.                goto RETURNQ; /*--------------------------->> RETURNQ */
  261.  
  262.         case EVALP:
  263.               { CALLEVALPRED(CALLP,CALLENV);
  264.                 if(ERRORFLAG) goto CALLQ;
  265.                 if(RES) 
  266.                   goto RETURNQ; /* ----------------------->> RETURNQ */
  267.                 goto FAILQ; /*------------------------------>> FAILQ */
  268.               }  
  269.  
  270.         case VARP:
  271.               { register TERM T;
  272.                 T=br(CALLP); 
  273.                 deref_(CALLP,base(CALLENV));
  274.                 if(name(CALLP)<FUNCNAME) ABORT(CALLE);
  275.                 if(non_nil_atom(name(T)))
  276.                    CALLP=mk2sons(name(CALLP),son(CALLP),GOTO_1,T);
  277.                 else
  278.                    CALLP=mk2sons(name(CALLP),son(CALLP),nil_atom,nil_term);
  279.  
  280.               }
  281.               goto CALLQ; /* ------------------------------>> CALLQ */
  282.               
  283.         case GOTOP:
  284.               CALLP=son(CALLP);
  285.               if(non_nil_term(CALLP) && name(CALLP)) 
  286.                   goto CALLQ; /* ------------->> CALLQ */
  287.               goto RETURNQ; /* ---------------------------->> RETURNQ */
  288.  
  289.         case BTEVALP:
  290.               BCT=0;
  291.   REDOEVALQ:
  292.             { register ENV RE;
  293.               /*RE=NEWENV((int)arity(A));*/ /* ??????? md ??????? */
  294.               RE=NEWENV(term_units(1)); 
  295.               call(RE)=CALLP; env(RE)=CALLENV; 
  296.               rule(RE)=(CLAUSE)BCT;
  297.               CHP=CHOICEPOINT;
  298.               CHOICEPOINT=RE;
  299.               CALLEVALPRED(CALLP,CALLENV);
  300.               if(RES)
  301.                 { 
  302.                   if(BCT) rule(RE)= (CLAUSE)BCT;
  303.                   /* saves backtracking information */
  304.                   else CHOICEPOINT=CHP ;
  305.                   goto RETURNQ; /* ------------------->> RETURNQ */
  306.                 }
  307.               CHOICEPOINT=CHP;
  308.               if(ERRORFLAG) goto CALLQ; /* ------------->> CALLQ  */
  309.               goto FAILQ; /* ---------------------------->> FAILQ */
  310.             }
  311.          }
  312.   PROCQ:
  313.       /* CP points to a chain of untried clauses */
  314.       /* A==name(CALLP) */
  315.        
  316.         { register ENV CH=CHOICEPOINT;
  317.           if(CH<CALLENV) ENVP=CALLENV; 
  318.           else ENVP=CH; 
  319.           if(inc_env(ENVP)>=MAXENVS) ABORT(FRAMESPACEE); 
  320.           ENVTOP=ENVP;  
  321.  
  322.           choice(ENVP)=CHP=CH;
  323.           base(ENVP)=BASE=GLOTOP;
  324.           trail(ENVP)=TRAILEND;
  325.         }
  326.  
  327.         if((ARITY=arity(A))==0) 
  328.         /* parameterless call --> no indexing, direct clause access */
  329.           { register TERM T;
  330.             T=GLOTOP; 
  331.             if((GLOTOP+=var_sizes(CP))>=HEAPTOP) reclaim_heap(true);
  332.             while(T<GLOTOP) { name(T)=UNBOUNDT; inc_term(T); } 
  333.             if(non_nil_clause(nextcl(CP))) 
  334.               { CHOICEPOINT=ENVP; atomtop(ENVP)=ATOMSTOP; }
  335.             goto UNIFIED;
  336.           }
  337.  
  338.         /* A:=name of actual first parameter (for indexing) */
  339.         { register TERM T;
  340.           T=son(CALLP);
  341.           deref_(T,base(CALLENV));
  342.           A=name(T);
  343.         }
  344.         for(;;)
  345.           { CLAUSE CPP;
  346.             /* advance CP to the first applicable clause */
  347.             if(A>FUNCNAME)
  348.              { register ATOM AA;
  349.                /* simplified indexing: check name(son(head)) */
  350. func:
  351.                 AA=name(son(head(CP))); 
  352.                 if(AA > FUNCNAME && AA !=A)
  353.                   { if(non_nil_clause(CP=nextcl(CP))) 
  354.                          /* continue; */ goto func;
  355.                     CHOICEPOINT=CHP; goto FAILQ; /* --------->> FAILQ */
  356.                   }
  357.                 for(CPP=nextcl(CP);non_nil_clause(CPP);CPP=nextcl(CPP))
  358.                 {
  359.                   AA=name(son(head(CPP))); 
  360.                   if(AA < FUNCNAME || AA==A)
  361.                     { CHOICEPOINT=ENVP; atomtop(ENVP)=ATOMSTOP;
  362.                       break; 
  363.                     } 
  364.                 }
  365.              }
  366.             else if(non_nil_clause(CPP=nextcl(CP))) 
  367.                   { CHOICEPOINT=ENVP; atomtop(ENVP)=ATOMSTOP; }
  368.  
  369.             { register TERM T;
  370.               T=BASE; 
  371.               if((GLOTOP=T+=var_sizes(CP))>=HEAPTOP) reclaim_heap(true);
  372.               while(BASE < T) { dec_term(T);name(T)=UNBOUNDT;} 
  373.  
  374.               if(UNIFY(ARITY,son(CALLP),son(head(CP)),
  375.                  base(CALLENV),T,MAXDEPTH)) goto UNIFIED; 
  376.  
  377.             }
  378.             CP=CPP;
  379.  
  380.         /* nextclause: */
  381.             if(CP==nil_term) 
  382.               { CHOICEPOINT=CHP; goto FAILQ; } /* ---------->> FAILQ */
  383.           }
  384.  
  385.   UNIFIED:
  386.         call(ENVP)=CALLP; env(ENVP)=CALLENV; 
  387.  
  388.         inc_env(ENVTOP); rule(ENVP)=CP;
  389.         { register TERM T;
  390.           if(non_nil_atom(name(T=body(CP))))
  391.            { CALLENV=ENVP; CALLP=T; goto CALLQ; } /* ------>> CALLQ */
  392.           /* ---------------------------------------------->> RETURNQ */
  393.         }
  394.         
  395.   RETURNQ:
  396.       /* The subgoal in CALLP has just succeeded. */
  397.      if(SPYTRACE)
  398.       { TRACE(PROVED_0,CALLP,CALLENV);
  399.         /* if(CALLENV>GOALENV) */
  400.         if(CALLENV>=CALLTOP)
  401.           { if(non_nil_term(CALLP) && name(next_br(CALLP))) 
  402.                goto  CALLQ; /* ------------------------------>> CALLQ */
  403.             CALLP=call(CALLENV); 
  404.             CALLENV=env(CALLENV);
  405.             goto RETURNQ; } /* ---------------------------->> RETURNQ */
  406.       }
  407.      else
  408.       { register ENV RE; 
  409.         /* RE=GOALENV; */
  410.         RE=CALLTOP;
  411.         /* while(CALLENV>RE) */
  412.         while(CALLENV>=RE) 
  413.           { if(non_nil_term(CALLP) && name(next_br(CALLP))) 
  414.                goto  CALLQ; /* ------------------------------>> CALLQ */
  415.             CALLP=call(CALLENV); 
  416.             CALLENV=env(CALLENV);
  417.           } 
  418.       }
  419.     return true;  /* >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> return */
  420.  
  421.   FAILQ:
  422.       /* Failure has occurred.  'choicepoint' is the newest
  423.                      environment with a nondeterminate choice. */
  424.         if(SPYTRACE) TRACE(FAILED_0,CALLP,CALLENV);
  425.         if(CHOICEPOINT>CALLTOP)
  426.           { 
  427.             /* temporary using A as variable of type  TRAIL */
  428.             { register TRAIL T,TT;
  429.               TT=TRAILEND; T=TRAILEND=trail(CHOICEPOINT);
  430.               while(T<TT) 
  431.                { name(boundvar(T))=UNBOUNDT; inc_trail(T); }
  432.             }
  433.             { register ENV CH;
  434.               CH=CHOICEPOINT;
  435.               CALLP=call(CH); 
  436.               CALLENV=env(CH); 
  437.               CP=rule(CH);
  438.               ATOMSTOP=atomtop(CH);
  439.               STRINGSTOP= (STRING)nextatom(ATOMSTOP);
  440.               GLOTOP=base(CH);
  441.               ENVTOP=CH;
  442.               CHOICEPOINT=choice(CH);
  443.             }
  444.             /* end of KILLSTACKS */
  445.             if(class(A=name(CALLP))==BTEVALP)
  446.             { if(!(BCT= (int)CP)) goto FAILQ; /* ----->> FAILQ */
  447.               if(SPYTRACE) 
  448.                 if(TRACE(REDO_0,CALLP,CALLENV)==false) goto  FAILQ; 
  449.               goto REDOEVALQ; /* ----------------------->> REDOEVALQ */
  450.             }
  451.             if( CP==DUMMYCL) CP=clause(A);
  452.             else if(CP==nil_clause) goto FAILQ; /* ----->> FAILQ */
  453.                  else CP=nextcl(CP);
  454.             if(CP==nil_clause) goto FAILQ; /* ----------->>  FAILQ */
  455.             if(SPYTRACE) 
  456.               if(TRACE(REDO_0,CALLP,CALLENV)==false) goto  FAILQ;
  457.             goto PROCQ; /* --------------------------------->> PROCQ */
  458.           }
  459.         BCT=0;
  460.         return false;  /* >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> return */ 
  461.   }
  462.   /* Execute */
  463.  
  464.  
  465.  
  466.