home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / huprolog / Source / C / DATAB < prev    next >
Encoding:
Text File  |  1990-06-10  |  22.1 KB  |  861 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 "maxvars.h"
  22. #include "files.h"
  23.  
  24. /* 
  25.  
  26. The clauses which constitute the Prolog program are stored in skeletal
  27. form, with each variable replaced either by an anonymous variable or by
  28. a skeletal reference containing an offset from the base of a frame on
  29. the local stack.  The body of a clause is represented by a collection
  30. of terms chained immediately together.
  31.  
  32. */
  33.  
  34. IMPORT void ARGERROR(),ERROR(),ABORT(),SYSTEMERROR();      /* from linebufffer.c */
  35. IMPORT ATOM copyatom(),GetAtom(),LOOKATOM();
  36. IMPORT TERM A0,A1,A2;            /* from evalpreds.c */
  37. IMPORT int BCT;         /* from execute.c */
  38. IMPORT ENV CHOICEPOINT;
  39. IMPORT ENV NEWENV();            /* from unify.c */
  40. IMPORT ENV BASEENV,ENVTOP;
  41. IMPORT void KILLSTACKS();
  42. IMPORT void freeterms();
  43. IMPORT TERM A0,A1,A2;           /* from evalpreds.c     */
  44. IMPORT void FileError();        /* from files.c         */
  45. IMPORT void CloseFile();        /* from files.c         */
  46. IMPORT boolean FERRORFLAG;      /* from files.c         */
  47. IMPORT boolean ECHOFLAG,HALTFLAG,WARNFLAG;       /* fom prolog.c */
  48. IMPORT boolean VERBOSE;
  49. IMPORT boolean aSYSMODE;
  50. IMPORT ENV E;
  51. IMPORT TERM READIN();           /* from readin.c        */
  52. IMPORT void ATOMCHAR(),STARTATOM();
  53. IMPORT boolean FileExist();
  54. IMPORT string NEWATOM;
  55. IMPORT void CHECKATOM();
  56. IMPORT TERM phy_name();
  57. IMPORT ATOM atom();
  58. IMPORT boolean isatom(),EXECUTE(),INTRES();
  59. IMPORT int INTVALUE();
  60. IMPORT void TESTATOM();
  61. IMPORT void DISPLAY();
  62. IMPORT file OpenFile();
  63. IMPORT ATOM LOOKUP();
  64. IMPORT boolean UNIFY();
  65. IMPORT void reclaim_heap();
  66. IMPORT PHASE MODE;
  67.  
  68. /*
  69. EXPORT  boolean DOCONSULT(boolean);
  70. EXPORT boolean DOENSURE();
  71. EXPORT void abolish(),DOABOLISH(),retractclauses();
  72. EXPORT boolean DOCLAUSE(),DORETRACT();
  73. EXPORT void destroycl(CL);
  74. EXPORT void InitDatabase();
  75. EXPORT CLAUSE ADDCLAUSE();
  76. EXPORT TERM SKELETON();
  77. EXPORT CLAUSE ANDG,OR1G,OR2G,IMPG;
  78. */
  79.  
  80. /*
  81.    Produce a skeleton for p and add it to the database.  The new clause
  82.    is added at the front of the clause chain if asserta is true,
  83.    otherwise at the end.
  84. */
  85.  
  86. GLOBAL CLAUSE ANDG,OR1G,OR2G,IMPG;
  87.  
  88. /*
  89. Produce a skeleton for a variable v. When the first occurrence of
  90. v is encountered, it is tentatively translated as an anonymous
  91. variable, and a pointer to this variable is stored in the
  92. 'varmap' entry. If a second occurrence is encountered, the
  93. anonymous variable is changed to a skeletal reference.
  94. */
  95.  
  96. GLOBAL int  VARCT,VARTOP;
  97.  
  98. IMPORT  TERM VAR_TAB[MAXVARS]; /* from read.c */
  99. LOCAL   TERM VAR_REF[MAXVARS];
  100.  
  101. GLOBAL TERM SKELETON (REGISTER ATOM A, register TERM Y)
  102. { register TERM X, Z;
  103.   REGISTER TERM S;
  104.   register int J,N;
  105.   N=arity(A);
  106.   if(N==0) return nil_term;
  107.   Z=S=heapterms(N);
  108.   X=Y;
  109.   for(;;)
  110.   { Y=X; deref(Y);
  111.     if((A=name(Y))==UNBOUNDT) 
  112.     {
  113.         for(J=0;J<VARCT;++J) if(VAR_TAB[J]==Y) goto skel_var;
  114.         for(J=MAXVARS-VARTOP;J<MAXVARS; ++J)
  115.             if(VAR_TAB[J]==Y)
  116.             {
  117.                 name(VAR_REF[J])=SKELT;
  118.                 offset(VAR_REF[J])=term_units(VARCT);
  119.                 VAR_TAB[J]=nil_term;
  120.                 J=VARCT++;if(VARCT+VARTOP >=MAXVARS) ABORT(NVARSE);
  121.                 VAR_TAB[J] =Y;
  122.             skel_var:
  123.                 name(Z)=SKELT; offset(Z)=term_units(J);
  124.                 goto skel_exit;
  125.             }
  126.         /* enter new variable */
  127.         J=MAXVARS - ++VARTOP;if(VARCT+VARTOP>=MAXVARS) ABORT(NVARSE);
  128.         VAR_TAB[J]=Y;VAR_REF[J]=Z;
  129.         name(Z)=UNBOUNDT; val(Z)=nil_term;
  130.     skel_exit:
  131.         if (--N==0) break;
  132.         next_br(X); next_br(Z); continue;
  133.     }
  134.     else if(A==INTT) 
  135.          { name(Z)=INTT; ival(Z)=ival(Y); 
  136.            if (--N==0) break;
  137.            next_br(X); next_br(Z); continue;
  138.          }
  139.     else { if (--N==0)
  140.            { name(Z)=copyatom(A); 
  141.              if((N=arity(A))>0) 
  142.              { Z=son(Z)=heapterms(N);
  143.                X=son(Y);
  144.                continue;
  145.              }
  146.              son(Z)=nil_term; break;
  147.            }
  148.            name(Z)=copyatom(A); 
  149.            son(Z)=SKELETON(name(Z),son(Y));
  150.            next_br(X); next_br(Z); continue;
  151.          }
  152.   }
  153.   return S;
  154. }
  155.  
  156. GLOBAL CLAUSE ADDCLAUSE (register TERM Q)
  157. { ATOM A; 
  158.   register TERM Z,ZZ;
  159.   REGISTER TERM HEAD,X;
  160.   register CLAUSE CL;
  161.  
  162.     /* deref(Q); */
  163.     A=name(Q);
  164.     VARTOP=VARCT=0;
  165.     if(A!=ARROW_2) 
  166.     { 
  167.         if((system(A) && !aSYSMODE) || class(A)!=NORMP) ARGERROR();
  168.         A=copyatom(A);
  169.         HEAD=SKELETON(A,son(Q));
  170.         CL=heapterms(4); 
  171.         name(body(CL))=nil_atom; son(body(CL))=nil_term;
  172.     }
  173.     else /* name(A)==ARROW_2 */
  174.     { int I;
  175.       HEAD=arg1(Q); A=copyatom(name(HEAD));
  176.       if((system(A) && !aSYSMODE) || class(A)!=NORMP) ARGERROR();
  177.       HEAD=SKELETON(A,son(HEAD)); 
  178.       Z=arg2(Q); 
  179.       I=5;/* number of terms in a simple clause */
  180.       /* copy clause body onto heap */ 
  181.       while(name(Z)==COMMA_2) { Z=arg2(Z); I++; }
  182.       if(I>=MAXARITY) ABORT(DEPTHE);
  183.       CL=heapterms(I);
  184.       ZZ=body(CL); Z=arg2(Q);
  185.      skel_1:
  186.         if(name(Z)==COMMA_2) X=arg1(Z); else X=Z;
  187.         if(name(X)==UNBOUNDT) 
  188.     {
  189.         register int J;
  190.         for(J=0;J<VARCT;++J) if(VAR_TAB[J]==X) goto skel_var;
  191.         for(J=MAXVARS-VARTOP;J < MAXVARS; ++J)
  192.             if(VAR_TAB[J]==X)
  193.             {
  194.                 name(VAR_REF[J])=SKELT;
  195.                 offset(VAR_REF[J])=term_units(VARCT);
  196.                 VAR_TAB[J]=nil_term;
  197.                 J=VARCT++;if(VARCT+VARTOP >=MAXVARS) ABORT(NVARSE);
  198.                 VAR_TAB[J] =X;
  199.             skel_var:
  200.                 name(ZZ)=SKELT; offset(ZZ)=term_units(J);
  201.                 goto skel_exit;
  202.             }
  203.         /* enter new variable */
  204.         J=MAXVARS - ++VARTOP;if(VARCT+VARTOP >=MAXVARS) ABORT(NVARSE);
  205.         VAR_TAB[J]=X;VAR_REF[J]=ZZ;
  206.         name(ZZ)=UNBOUNDT; val(ZZ)=nil_term;
  207.     skel_exit:;
  208.     }
  209.         else
  210.         {
  211.             name(ZZ)=copyatom(name(X));
  212.             son(ZZ)=SKELETON(name(ZZ),son(X));
  213.         }
  214.         next_br(ZZ);
  215.         if(name(Z)==COMMA_2)
  216.         {
  217.             Z=arg2(Z); goto skel_1;
  218.         }
  219.         name(ZZ)=nil_atom; son(ZZ)=nil_term;
  220.     }
  221.     /* A=copyatom(A);  siehe oben */
  222.     if(aSYSMODE) setsystem(A);
  223.     name(CL)=CLAUSET;name(br(CL))=INTT;
  224.     nextcl(CL)=nil_term; setnvars(CL,VARCT); 
  225.     name(head(CL))=A; son(head(CL))=HEAD;
  226.     return CL;
  227. }
  228.  
  229. /****************** I N I T I A L I S A T I O N ***********/
  230.  
  231.  
  232. LOCAL TERM CURRTERM;
  233. LOCAL int CURRMAX;
  234.  
  235. LOCAL CLAUSE initclause(register int N, register int VARS)
  236. { register CLAUSE CL;
  237.   CL=heapterms(N+2); name(CL)=CLAUSET; nextcl(CL)=nil_term;
  238.   name(br(CL))=INTT; setnvars(CL,VARS);
  239.   CURRTERM=br(br(CL)); CURRMAX=N; 
  240.   return CL;
  241. }
  242.  
  243. LOCAL void setarg(register ATOM A, register TERM S)
  244. { if(CURRMAX-- <=0) SYSTEMERROR("InitDatabase.1");
  245.   name(CURRTERM)=A; son(CURRTERM)=S; inc_term(CURRTERM);
  246. }
  247.  
  248. LOCAL void skelarg(register int N)
  249. { if(CURRMAX-- <=0) SYSTEMERROR("InitDatabase.2");
  250.   name(CURRTERM)=SKELT; offset(CURRTERM)=term_units(N); 
  251.   inc_term(CURRTERM);
  252. }
  253.  
  254. LOCAL void closeclause(void)
  255. { if(CURRMAX-- <=0) SYSTEMERROR("InitDatabase.3");
  256.   name(CURRTERM)=nil_atom; son(CURRTERM)=nil_term;
  257. }
  258.  
  259. LOCAL TERM vars(register int M, register int N)
  260. { register TERM T;
  261.   T=heapterms(2); name(T)=SKELT; offset(T)=term_units(M);
  262.   name(br(T))=SKELT; offset(br(T))=term_units(N);
  263.   return T;
  264. }
  265.  
  266. LOCAL TERM v(register int N)
  267. { register TERM T;
  268.   T=heapterms(1); name(T)=SKELT; offset(T)=term_units(N);
  269.   return T;
  270. }
  271.  
  272. LOCAL void arithclause(register ATOM A)
  273. { register TERM P;
  274.     clause(A)=initclause(6,4);
  275.     setarg(A,vars(0,1));
  276.     setarg(EVALUATE_2,vars(2,0));
  277.     setarg(EVALUATE_2,vars(3,1));
  278.     setarg(CUT_0,nil_term);
  279.     P=heapterms(1); name(P)=A; son(P)=vars(2,3);
  280.     setarg(ACOMP_1,P);
  281.     closeclause();
  282. }
  283.  
  284. GLOBAL void InitDatabase(void)
  285. { register TERM P; 
  286.   register CLAUSE C;
  287.  
  288.   /* 
  289.      (P,Q):-P,Q. 
  290.   */
  291.   clause(COMMA_2)=ANDG=initclause(4,2);
  292.     setarg(COMMA_2,vars(0,1));
  293.     skelarg((0));
  294.     skelarg((1));
  295.     closeclause();
  296.  
  297.   /* 
  298.      (P;_):-P. 
  299.      (_;Q):-Q. 
  300.   */
  301.   clause(SEMI_2)=OR1G=initclause(3,2);
  302.     setarg(SEMI_2,vars(0,1));
  303.     skelarg((0));
  304.     closeclause();
  305.   nextcl(OR1G)=OR2G=initclause(3,2);
  306.     setarg(SEMI_2,vars(0,1));
  307.     skelarg((1));
  308.     closeclause();
  309.  
  310.   /*
  311.      (P->Q):-P,!,Q.
  312.   */
  313.   clause(IMPL_2)=IMPG=initclause(5,2);
  314.     setarg(IMPL_2,vars(0,1));
  315.     skelarg((0));
  316.     setarg(CUT_0,nil_term);
  317.     skelarg((1));
  318.     closeclause();
  319.  
  320.   /*
  321.      repeat.
  322.      repeat:-repeat.
  323.   */
  324.   C=clause(REPEAT_0)=initclause(2,0);
  325.     setarg(REPEAT_0,nil_term);
  326.     closeclause();
  327.   nextcl(C)=C;
  328.  
  329.   /*
  330.      true.
  331.   */
  332.   clause(TRUE_0)=initclause(2,0);
  333.     setarg(TRUE_0,nil_term);
  334.     closeclause();
  335.  
  336.   /*
  337.      not X:-X,!,fail.
  338.      not _.
  339.   */
  340.   clause(NOT_1)=C=initclause(5,1);
  341.     setarg(NOT_1,v(0));
  342.     skelarg((0));
  343.     setarg(CUT_0,nil_term);
  344.     setarg(FAIL_0,nil_term);
  345.     closeclause();
  346.   nextcl(C)=initclause(2,1);
  347.     setarg(NOT_1,v(0));
  348.     closeclause();
  349.  
  350.   /*
  351.      \+ X:-X,!,fail.
  352.      \+ _.
  353.   */
  354.   clause(NOT1_1)=C=initclause(5,1);
  355.     setarg(NOT1_1,v(0));
  356.     skelarg((0));
  357.     setarg(CUT_0,nil_term);
  358.     setarg(FAIL_0,nil_term);
  359.     closeclause();
  360.   nextcl(C)=initclause(2,1);
  361.     setarg(NOT1_1,v(0));
  362.     closeclause();
  363.  
  364.   /*
  365.      X=X.
  366.   */
  367.   clause(ISEQ_2)=initclause(2,1);
  368.     setarg(ISEQ_2,vars(0,0));
  369.     closeclause();
  370.  
  371.   /* 
  372.      X\=X:-!,fail.
  373.      _\=_.
  374.   */
  375.   clause(ISNEQ_2)=C=initclause(4,1);
  376.     setarg(ISNEQ_2,vars(0,0));
  377.     setarg(CUT_0,nil_term);
  378.     setarg(FAIL_0,nil_term);
  379.     closeclause();
  380.   nextcl(C)=initclause(2,2);
  381.     setarg(ISNEQ_2,vars(0,1));
  382.     closeclause();
  383.  
  384.   /*
  385.      [X,Y|T]:-consult(X),[Y|T].
  386.      [X] :- consult(X).
  387.   */
  388.   P=heapterms(2);
  389.   name(P)=SKELT; offset(P)=term_units(0);
  390.   name(br(P))=CONS_2; son(br(P))=vars(1,2);
  391.   clause(CONS_2)=C=initclause(4,3);
  392.     setarg(CONS_2,P);
  393.     setarg(CONSULT_1,v(0));
  394.     setarg(CONS_2,vars(1,2));
  395.     closeclause();
  396.   P=heapterms(2);
  397.   name(P)=SKELT; offset(P)=term_units(0);
  398.   name(br(P))=NIL_0; son(br(P))=nil_term;
  399.   nextcl(C)=initclause(3,1);
  400.     setarg(CONS_2,P);
  401.     setarg(CONSULT_1,v(0));
  402.     closeclause();
  403.  
  404.   /*
  405.      call(X):-X.
  406.   */
  407.   clause(CALL_1)=initclause(3,1);
  408.     setarg(CALL_1,v(0));
  409.     skelarg((0));
  410.     closeclause();
  411.  
  412.   /*
  413.      D := `E :- !,$dass(D,X).
  414.      D := E :- $evaluate(X,E),!,$dass(D,X).
  415.   */
  416.   P=heapterms(2);
  417.   name(P)=SKELT; offset(P)=term_units(0);
  418.   name(br(P))=QUOTE_1; son(br(P))=v(1);
  419.   clause(ASSIGN_2)=C=initclause(4,2);
  420.     setarg(ASSIGN_2,P);
  421.     setarg(CUT_0,nil_term);
  422.     setarg(DASSIGN_2,vars(0,1));
  423.     closeclause();
  424.   nextcl(C)=initclause(5,3);
  425.     setarg(ASSIGN_2,vars(0,1));
  426.     setarg(EVALUATE_2,vars(2,1));
  427.     setarg(CUT_0,nil_term);
  428.     setarg(DASSIGN_2,vars(0,2));
  429.     closeclause();
  430.  
  431.   /*
  432.      A=:=B :- $evaluate(AR,A),$evaluate(BR,B),!,$acomp(AR=:=BR).
  433.      etc.
  434.   */
  435.   arithclause(EQ_2);
  436.   arithclause(NE_2);
  437.   arithclause(LT_2);
  438.   arithclause(GT_2);
  439.   arithclause(LE_2);
  440.   arithclause(GE_2);
  441.  
  442. }
  443.  
  444.  
  445. GLOBAL void DOASSERT(boolean pos)
  446. /* A1   databasereference       */
  447. {                          /* A2   position                */
  448.     REGISTER ATOM A;
  449.     register CLAUSE CL,C,CX;
  450.  
  451.     if(pos && name(A1)!=UNBOUNDT) ARGERROR();
  452.  
  453.     if((A=name(A0))==ARROW_2) A=name(arg1(A0)); 
  454.     if( (system(A) && !aSYSMODE) || class(A)!=NORMP) ERROR(SYSPROCE);
  455.     A=copyatom(A);
  456.     if(name(A2)==INTT && ival(A2)==0)
  457.       { 
  458.             CL=ADDCLAUSE(A0);
  459.             nextcl(CL)=clause(A);
  460.             clause(A)=CL;  
  461.       }
  462.     else
  463.     if(name(A2)==END_0)
  464.       { CL=ADDCLAUSE(A0);
  465.         if(non_nil_clause(C=clause(A)))
  466.           { while(non_nil_clause(CX=nextcl(C)))C=CX;
  467.             nextcl(C)=CL;  /* md: noetig ? */
  468.           }
  469.         else clause(A)=CL;
  470.         nextcl(CL)=nil_clause;
  471.       }
  472.     else if(name(A2)==DBREF_1)   
  473.       { CX= (CLAUSE)INTVALUE(son(A2));
  474.         TESTATOM(A,head(CX));
  475.         if(denied(CX)) ARGERROR();
  476.         nextcl(CL=ADDCLAUSE(A0))=nextcl(CX); nextcl(CX)=CL;
  477.       }  
  478.     else 
  479.       { int i;
  480.         i=INTVALUE(A2);
  481.         if(i < 0) ARGERROR();
  482.         if(i==0)
  483.           { 
  484.             CL=ADDCLAUSE(A0);
  485.             nextcl(CL)=clause(A);
  486.             clause(A)=CL;  
  487.           }
  488.         else
  489.           {
  490.             if((C=clause(A))==nil_clause)ABORT(ARGE);
  491.             while(--i>0) 
  492.               { C=nextcl(C); 
  493.                 if(C==nil_clause) ARGERROR(); 
  494.               }
  495.             CL=ADDCLAUSE(A0);
  496.             nextcl(CL)=nextcl(C); nextcl(C)=CL;
  497.           }
  498.       }
  499.  
  500.     if(pos) (void) UNI(A1,mkfunc(DBREF_1,mkint((int)CL)));
  501.     return;
  502. }
  503.  
  504. GLOBAL void DOASSA(void)
  505. /* A0 term */
  506. {   
  507.     register ATOM A;
  508.     CLAUSE CL;
  509.     if((A=name(A0))==ARROW_2) A=name(arg1(A0)); 
  510.     if( (system(A) && !aSYSMODE) || class(A)!=NORMP) ERROR(SYSPROCE);
  511.     A=copyatom(A);
  512.     CL=ADDCLAUSE(A0);
  513.     nextcl(CL)=clause(A);
  514.     clause(A)=CL;  
  515.     return;
  516. }
  517.  
  518.  
  519.  
  520. LOCAL CLAUSE clausechain=nil_term;   /* used for retract */
  521.  
  522. GLOBAL void notecl(register CLAUSE CL)
  523. { nextcl(CL)=clausechain;clausechain=CL; deny(CL); }
  524.  
  525. GLOBAL void destroycl(register CLAUSE CL)
  526. { register TERM T,B;
  527.   register int I;
  528.   B=CL; name(B)=INTT; /* makes freeterms going the right way */
  529.   T=body(CL); I=3;
  530.   /* the field nvars/nextcl should be cleared to avoid
  531.      errors in recursively freeing nonexisting term structures */
  532.   for(;;)
  533.   { I++; 
  534.     if(name(T)==nil_atom) { freeterms(I,B); break; }
  535.     next_br(T);
  536.   }
  537. }
  538.  
  539. GLOBAL void retractclauses(void)
  540. { /* this function should be called from toplevel */
  541.     register CLAUSE CL ;
  542.     while(non_nil_clause(CL=clausechain)){
  543.         clausechain=nextcl(CL);
  544.         destroycl(CL);
  545.     }
  546.     reclaim_heap(false);
  547. }
  548.  
  549.  
  550. LOCAL TERM GenTerm(CLAUSE CL, ENV CE)
  551. {
  552.     TERM H,B;
  553.     register TERM T,CP,BCE;
  554.  
  555.     BCE=base(CE);
  556.     if(CL==nil_clause) ARGERROR();
  557.     if(name(body(CL))==nil_atom) 
  558.     { /* facts */
  559.       H=mkfreevar(); 
  560.       UNIFY(1,H,head(CL),BE,BCE,MAXDEPTH); 
  561.       return H;
  562.     }
  563.     CP=body(CL);
  564.     if(non_nil_atom(name(br(CP)))) 
  565.     { /* body contructed from several calls */
  566.         B=T=mkfunc(COMMA_2,mk2sons(UNBOUNDT,nil_term,UNBOUNDT,nil_term));
  567.         for(;;)
  568.         { UNIFY(1,son(T),CP,BE,BCE,MAXDEPTH);
  569.           next_br(CP);
  570.           if(name(br(CP))==nil_atom)
  571.           { T=br(son(T)); name(T)=UNBOUNDT;
  572.             UNIFY(1,T,CP,BE,BCE,MAXDEPTH);
  573.             break;
  574.           }
  575.           T=br(son(T)); 
  576.           name(T)=COMMA_2; 
  577.           son(T)=mk2sons(UNBOUNDT,nil_term,UNBOUNDT,nil_term);
  578.         }
  579.     }
  580.     else B=body(CL); /* body consisting of exactly one call */
  581.     /* compose term from head and body */
  582.     T=mkfunc(ARROW_2,mk2sons(UNBOUNDT,nil_term,UNBOUNDT,nil_term));
  583.     UNIFY(1,son(T),head(CL),BE,BCE,MAXDEPTH); 
  584.     UNIFY(1,br(son(T)),B,BE,BCE,MAXDEPTH);
  585.     return T;
  586. }
  587.  
  588. GLOBAL boolean testheap(register CLAUSE CL)
  589.     /* true, if CL is an active goal */
  590. { 
  591.     register ENV i;
  592.     register CLAUSE CP;
  593.     register TERM CALL;
  594.     ATOM A;
  595.     boolean result=false;
  596.  
  597.     for(i=BASEENV;i<ENVTOP;inc_env(i))
  598.         if( non_nil_env(CALL=call(i)) && (A=name(CALL))>=FUNCNAME)
  599.             if( class(A)==NORMP && (rule(i)==CL))
  600.             { /* active goal */
  601.                 result=true;
  602.                 if( WARNFLAG) ws("WARNING: retract active goal\n");
  603.                 CP=clause(A);
  604.                 if(CP==CL) { rule(i)=DUMMYCL ; continue; }
  605.                 while(non_nil_clause(CP)  && (nextcl(CP)!=CL))
  606.                   CP=nextcl(CP);
  607.                 rule(i)=CP; 
  608.             }
  609.             else if(A==CLAUSE_2 && rule(i)==CL)
  610.             {   /* clause/2 is a  backtrackable built in, thats why
  611.                 rule(i) is set to BCT with son(BCT)=nextclause */
  612.                 result=true;
  613.                 if(WARNFLAG) ws("WARNING: retract active clause\n");
  614.                 rule(i)=nextcl(CL);
  615.             }
  616.     return result;
  617. }
  618.  
  619. LOCAL void clearcl(register CLAUSE CL)
  620. { 
  621.     register ATOM A; 
  622.     register CLAUSE hcl;
  623.     boolean active;
  624.     active=testheap(CL);
  625.     A=name(head(CL)); hcl=clause(A);
  626.     if(hcl==CL) 
  627.         clause(A)=nextcl(CL); 
  628.     else 
  629.     { 
  630.         while(nextcl(hcl) !=CL) hcl=nextcl(hcl);
  631.         nextcl(hcl)=nextcl(CL);
  632.     }
  633.     if(active)notecl(CL);else destroycl(CL);
  634. }
  635.  
  636.  
  637.  
  638. GLOBAL boolean DORETRACT(boolean pos, boolean all)
  639. /* retract/1 a clause from database */
  640. { ENV OC,NE ;
  641.  CLAUSE CL,NCL;
  642.  ATOM A;
  643.  OC=CHOICEPOINT;
  644.  if(pos && all)
  645.      SYSTEMERROR("datab.c/DORETRACT");
  646.  if(pos && name(A1)!=UNBOUNDT)
  647.  {
  648.     TESTATOM(DBREF_1,A1);
  649.     CL=(CLAUSE)INTVALUE(son(A1));
  650.     if(denied(CL))ARGERROR();
  651.     NE=NEWENV(var_sizes(CL));CHOICEPOINT=NE;
  652.     if(UNI(A0,GenTerm(CL,NE)))
  653.     { CHOICEPOINT=OC; clearcl(CL); return true; }
  654.     return false;
  655.   }
  656.  if(!all && !BCT)BCT=1;
  657.  A=name(A0);
  658.  if(A==ARROW_2) A=name(arg1(A0));
  659.  if(system(A)) ARGERROR();
  660.  CL=clause(A);
  661.  /* now CL is the first clause to check */
  662.  OC=CHOICEPOINT;
  663.  while(non_nil_clause(CL))
  664.  { NE=NEWENV(var_sizes(CL)); CHOICEPOINT=NE;
  665.    NCL=nextcl(CL);
  666.    if( !all && UNI(A0,GenTerm(CL,NE))) 
  667.      { CHOICEPOINT=OC; 
  668.        clearcl(CL); 
  669.        if(pos)return INTRES(A1,(int)CL); 
  670.        return true;
  671.      }
  672.    else if(all && UNIFY(1,A0,head(CL),BE,base(NE),MAXDEPTH))
  673.     { 
  674.         CHOICEPOINT=OC; 
  675.         clearcl(CL); 
  676.     }
  677.    KILLSTACKS(NE);
  678.    CL=NCL;
  679.  }
  680.  return(all);
  681. }
  682.  
  683.  
  684. GLOBAL boolean DOCLAUSE(boolean third_arg)
  685. { CLAUSE CL=nil_clause;
  686.   TERM T;
  687.   ENV NE;
  688.   boolean u;
  689.   
  690.  if(third_arg && (name(A2)!=UNBOUNDT))
  691.  {
  692.     TESTATOM(DBREF_1,A2);
  693.     CL=(CLAUSE)INTVALUE(son(A2));
  694.     if(denied(CL))ARGERROR();
  695.     NE=NEWENV(var_sizes(CL));
  696.     T=GenTerm(CL,NE);
  697.     if(name(T)==ARROW_2)
  698.         return UNI(A0,son(T)) && UNI(A1,br(son(T)));
  699.     else
  700.         return UNI(A0,T) && UNI(A1,mkatom(TRUE_0));
  701.  }
  702.  
  703.  if(BCT) CL= (CLAUSE)(BCT);
  704.  else { ATOM A; A=name(A0);
  705.  if(A<FUNCNAME)ARGERROR();
  706.         if(system(A))return false;
  707.         CL=clause(A);
  708.       }
  709.  while(non_nil_clause(CL))
  710.  { NE=NEWENV(var_sizes(CL));
  711.    T=GenTerm(CL,NE);
  712.    if(name(T)==ARROW_2)
  713.       u=UNI(A0,son(T)) && UNI(A1,br(son(T)));
  714.    else
  715.       u=UNI(A0,T) && UNI(A1,mkatom(TRUE_0));
  716.    if(u){ 
  717.        BCT= (int)nextcl(CL);
  718.        if(third_arg)return UNI(A2,mkfunc(DBREF_1,mkint((int)CL)));
  719.        return true;
  720.        }   
  721.    CL=nextcl(CL);
  722.    KILLSTACKS(NE);
  723.  } 
  724.  return false;
  725. }
  726.  
  727. GLOBAL void  abolish(ATOM A)
  728. { register CLAUSE CL,CL1;
  729.   if(system(A))return;
  730.   CL=clause(A); clause(A)=nil_clause;
  731.   while(non_nil_clause(CL))
  732.     { CL1=CL;CL=nextcl(CL); 
  733.       if (testheap(CL1)) notecl(CL1); else destroycl(CL1); 
  734.     }
  735. }
  736.  
  737. GLOBAL void  DOABOLISH(int i)
  738. {
  739.     ATOM A;
  740.     if(i==2)
  741.     {   CHECKATOM(A0);
  742.         if(A=LOOKATOM(name(A0),-INTVALUE(A1))) abolish(A);
  743.         return; 
  744.     }
  745.     if(isatom(A0))
  746.     {
  747.         for(i=0;i<=MAXARITY;i++)
  748.           if(non_nil_atom(A=LOOKATOM(name(A0),-i))) abolish(A);
  749.         return ;
  750.     }
  751.     if(non_nil_atom(A=atom(A0))) abolish(A);
  752. }
  753.     
  754.  
  755. GLOBAL boolean DOCONSULT(boolean reconsult)
  756. {
  757.     TERM X;
  758.     ATOM A,FILEATOM;
  759.     ATOM LASTA=nil_atom;
  760.     CLAUSE LASTCL=nil_term;
  761.     ENV EP,OLDE;
  762.     TERM oldfilename;
  763.     CLAUSE CX,CL;
  764.     boolean res=true;
  765.  
  766.     EP=E;
  767.     if(name(A0)==MINUS_1){ A0=arg1(A0); reconsult=true;}
  768.     if(reconsult)
  769.       for(A=GetAtom(nil_atom);non_nil_atom(A);A=GetAtom(A)) setnotrc(A);
  770.     CHECKATOM(A0);
  771.     if((FILEATOM=name(A0))==USER_0) FILEATOM=STDIN_0;;
  772.     oldfilename=FNAME(inputfile);
  773.     if((inputfile=OpenFile(phy_name(FILEATOM),read_mode))<0)
  774.         { FileError(CANTOP);res=false;goto exit;}
  775.     FLOGNAME(inputfile)=copyatom(FILEATOM);
  776.  
  777.     while(! HALTFLAG)
  778.     {   
  779.         retractclauses();
  780.         CHOICEPOINT=OLDE=E=NEWENV(0); BE=base(E);
  781.         if(VERBOSE && MODE!=SYSM)
  782.             if(FILEATOM==STDIN_0) ws("user >"); 
  783.             else if(!ECHOFLAG) ws(".");
  784.         X=READIN();
  785.         A=name(X);
  786.         if(A==END_0) HALTFLAG=true;  
  787.         else if(A==QUESTION_1 || A==ARROW_1 )
  788.         { 
  789.             LASTA=nil_atom;
  790.             name(X)=CALL_1; 
  791.             if( ! EXECUTE(X,E) && WARNFLAG && A!=ARROW_1)
  792.                 ws("WARNING: goal failed during consult/reconsult");
  793.         }
  794.         else 
  795.         {  
  796.             if(A ==ARROW_2) A=name(arg1(X));
  797.             if((system(A) && !aSYSMODE) || class(A) !=NORMP)
  798.                 ABORT(SYSPROCE);
  799.             A=copyatom(A);
  800.             if(reconsult && !rc(A)) 
  801.               { setrc(A); abolish(A); }
  802.             /* inline code for assert */        
  803.             if(non_nil_clause(CX=clause(A)))
  804.             {
  805.                 if(non_nil_atom(A) && A==LASTA) CX=LASTCL;
  806.                 else
  807.                     while(non_nil_clause(CL=nextcl(CX)))CX=CL;
  808.                 nextcl(CX)=CL=ADDCLAUSE(X);
  809.                 if(WARNFLAG && LASTA !=A)
  810.                 {
  811.                     ws("WARNING: new clauses for ");
  812.                     wq(A);ws("/");wi(arity(A));
  813.                     ws("\n");
  814.                 }
  815.             }
  816.             else
  817.                 clause(A)=CL=ADDCLAUSE(X);
  818.             nextcl(CL)=nil_clause; 
  819.             LASTA=A;
  820.             LASTCL=CL;
  821.         }
  822.         KILLSTACKS(OLDE);
  823.     }
  824.   exit:
  825.     HALTFLAG=false;
  826.     CloseFile(inputfile);
  827.     inputfile=OpenFile(oldfilename,read_mode);
  828.     ISEOF(inputfile)=false;
  829.     E=EP; BE=base(E);
  830.     return res;
  831. }
  832.  
  833. GLOBAL boolean DOENSURE(void)
  834. {
  835.     ATOM A;
  836.     register int ARITY;
  837.     register string s;
  838.     if(!(isatom(A0) && isatom(A1))) ARGERROR();
  839.     if(name(A2) !=INTT) ARGERROR();
  840.     ARITY=ival(A2);
  841.     if(ARITY < 0 || ARITY > MAXARITY) ARGERROR();
  842.     A=LOOKUP(tempcopy(name(A1)),ARITY,false);
  843.     A=copyatom(A);
  844.     if(ensure(A)) return true;
  845.     STARTATOM();
  846.     s=tempcopy(name(A0));
  847.     while(*s)ATOMCHAR(*s++);
  848.     s=tempcopy(name(A1));
  849.     while(*s)ATOMCHAR(*s++);
  850.     ATOMCHAR('.');
  851.     s=itoa(ARITY);
  852.     while(*s)ATOMCHAR(*s++);
  853.     ATOMCHAR(0); /* terminate string */
  854.     if(!FileExist(NEWATOM)) return false;
  855.     setensure(A);
  856.     A0=mkatom(LOOKUP(NEWATOM,0,false));
  857.     DOCONSULT(false);
  858.     return true;
  859. }
  860.  
  861.