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-proc.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  25KB  |  1,020 lines
  1. /*  pl-proc.c,v 1.3 1993/02/23 13:16:42 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: Procedure (re) allocation
  8. */
  9.  
  10. #include "pl-incl.h"
  11.  
  12. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  13. General  handling  of  procedures:  creation;  adding/removing  clauses;
  14. finding source files, etc.
  15. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  16.  
  17. forwards void    resetReferencesModule P((Module));
  18. forwards bool    attribute P((Definition, Word, short));
  19. forwards bool    autoImport P((FunctorDef, Module));
  20.  
  21. SourceFile sourceFileTable = (SourceFile) NULL;
  22. SourceFile tailSourceFileTable = (SourceFile) NULL;
  23. SourceFile isCurrentSourceFile();
  24.  
  25. Procedure
  26. lookupProcedure(f, m)
  27. FunctorDef f;
  28. Module m;
  29. { Procedure proc;
  30.   register Definition def;
  31.   Symbol s;
  32.   
  33.   if ((s = lookupHTable(m->procedures, f)) != (Symbol) NULL)
  34.     return (Procedure) s->value;
  35.  
  36.   proc = (Procedure)  allocHeap(sizeof(struct procedure));
  37.   def  = (Definition) allocHeap(sizeof(struct definition));
  38.   proc->type = PROCEDURE_TYPE;
  39.   proc->functor = f;
  40.   proc->definition = def;
  41.   def->module = m;
  42.   addHTable(m->procedures, f, proc);
  43.   statistics.predicates++;
  44.  
  45.   def->definition.clauses = (Clause) NULL;
  46.   def->lastClause = (Clause) NULL;
  47. #if O_PROFILE
  48.   def->profile_ticks = 0;
  49.   def->profile_calls = 0;
  50.   def->profile_redos = 0;
  51.   def->profile_fails = 0;
  52. #endif /* O_PROFILE */
  53.   clearFlags(def);
  54.   resetProcedure(proc);
  55.  
  56.   return proc;
  57. }
  58.  
  59. void
  60. resetProcedure(proc)
  61. Procedure proc;
  62. { register Definition def = proc->definition;
  63.  
  64.   def->flags ^= def->flags & ~SPY_ME;    /* Preserve the spy flag */
  65.   def->source = (SourceFile) NULL;
  66.   def->source_count = 0;
  67. #if O_AUTOINDEX
  68.   set(def, TRACE_ME|AUTOINDEX);
  69.   def->indexPattern = 0x0;
  70.   def->indexCardinality = 0;
  71.   def->indexMerit = 0;
  72. #else
  73.   set(def, TRACE_ME);
  74.   if ( proc->functor->arity == 0 )
  75.   { def->indexPattern = 0x0;
  76.     def->indexCardinality = 0;
  77.   } else
  78.   { def->indexPattern = 0x1;
  79.     def->indexCardinality = 1;
  80.   }
  81. #endif
  82. }
  83.  
  84. Procedure
  85. isCurrentProcedure(f, m)
  86. FunctorDef f;
  87. Module m;
  88. { Symbol s;
  89.  
  90.   if ((s = lookupHTable(m->procedures, f)) != (Symbol) NULL)
  91.     return (Procedure) s->value;
  92.  
  93.   return (Procedure) NULL;
  94. }
  95.  
  96. bool
  97. isDefinedProcedure(proc)
  98. register Procedure proc;
  99. { if ( /* true(proc->definition, FOREIGN) || not needed; union */
  100.        proc->definition->definition.clauses != (Clause) NULL ||
  101.        true(proc->definition, DYNAMIC) )
  102.     succeed;
  103.   fail;
  104. }
  105.  
  106. /*  Find a procedure from description `descr'. `descr' is one of:
  107.     <term> or <module>:<term>. If the procedure does not exists NULL
  108.     is returned.
  109.  
  110.  ** Tue Apr 19 16:11:25 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  111.  
  112. Procedure
  113. findProcedure(descr)
  114. Word descr;
  115. { Module m = (Module) NULL;
  116.   FunctorDef fd;
  117.   Procedure proc;
  118.  
  119.   if ((descr = stripModule(descr, &m)) == (Word) NULL)
  120.     return (Procedure) NULL;
  121.  
  122.   if (isAtom(*descr) )
  123.     fd = lookupFunctorDef((Atom)*descr, 0);
  124.   else if (isTerm(*descr) )
  125.     fd = functorTerm(*descr);
  126.   else
  127.   { warning("Illegal predicate specification");
  128.     return (Procedure) NULL;
  129.   }
  130.   
  131.   for( ; m; m = m->super )
  132.   { if ( (proc = isCurrentProcedure(fd, m)) != NULL )
  133.       return proc;
  134.   }
  135.  
  136.   return (Procedure) NULL;
  137. }
  138.  
  139. Procedure
  140. findCreateProcedure(descr)
  141. Word descr;
  142. { Module m = (Module) NULL;
  143.  
  144.   if ((descr = stripModule(descr, &m)) == (Word) NULL)
  145.   { warning("Illegal module specification");
  146.     return (Procedure) NULL;
  147.   }
  148.  
  149.   if (isAtom(*descr) )
  150.     return lookupProcedure(lookupFunctorDef((Atom)*descr, 0), m);
  151.   if (isTerm(*descr) )
  152.     return lookupProcedure(functorTerm(*descr), m);
  153.  
  154.   warning("Illegal predicate specification");
  155.   return (Procedure) NULL;
  156. }
  157.  
  158. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  159. This function  implements  $c_current_predicate/2.   current_predicate/2
  160. itself  is  written  in  Prolog, based on this function.  Having dynamic
  161. linking from super modules and dynamoc loading from the  libraries,  the
  162. definition  of current predicate has become a difficult issue.  Normally
  163. it is used for meta-programming and program analysis.  I think it should
  164. succeed  for  each  predicate  that  can   be   called.    The   current
  165. implementation  is VERY slow due to all Prolog overhead.  This should be
  166. reconsidered and probably a large part of this function should be  moved
  167. to C.
  168. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  169.  
  170. word
  171. pl_current_predicate(name, functor, h)
  172. Word name, functor;
  173. word h;
  174. { Atom n;
  175.   FunctorDef f;
  176.   Module m = (Module) NULL;
  177.   Procedure proc;
  178.   Symbol symb;
  179.  
  180.   if ( ForeignControl(h) == FRG_CUTTED )
  181.     succeed;
  182.  
  183.   if ((functor = stripModule(functor, &m)) == (Word) NULL)
  184.     fail;
  185.  
  186.   if (isAtom(*name) )
  187.     n = (Atom) *name;
  188.   else if (isVar(*name) )
  189.     n = (Atom) NULL;
  190.   else
  191.     fail;
  192.  
  193.   if (isTerm(*functor) )
  194.     f = functorTerm(*functor);
  195.   else if (isAtom(*functor) )
  196.     f = lookupFunctorDef((Atom)*functor, 0);
  197.   else if (isVar(*functor) )
  198.     f = (FunctorDef) NULL;
  199.   else
  200.     fail;
  201.  
  202.   if ( ForeignControl(h) == FRG_FIRST_CALL)
  203.   { if (f != (FunctorDef) NULL) 
  204.     { if ((proc = isCurrentProcedure(f, m)) != (Procedure) NULL)
  205.       { TRY(unifyAtomic(name, f->name) );
  206.     succeed;
  207.       } else
  208.     fail;
  209.     }
  210.     symb = firstHTable(m->procedures);
  211.   } else
  212.     symb = (Symbol) ForeignContextAddress(h);
  213.  
  214.   for(; symb; symb = nextHTable(m->procedures, symb) )
  215.   { proc = (Procedure) symb->value;
  216.  
  217.     if (n != (Atom) NULL && n != proc->functor->name)
  218.       continue;
  219.  
  220.     if (unifyAtomic(name, proc->functor->name) == FALSE)
  221.       continue;
  222.     if (unifyFunctor(functor, proc->functor) == FALSE)
  223.       continue;
  224.  
  225.     if ((symb = nextHTable(m->procedures, symb)) != (Symbol) NULL)
  226.       ForeignRedo(symb);
  227.  
  228.     succeed;
  229.   }
  230.  
  231.   fail;
  232. }
  233.  
  234.  
  235. /*  Assert a clause to a procedure. Where askes to assert either at the
  236.     head or at the tail of the clause list. It should be instantiated
  237.     to ether 'a' or 'z'.
  238.  
  239.  ** Fri Apr 29 12:44:08 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  240.  
  241. #if PROTO
  242. bool
  243. assertProcedure(Procedure proc, Clause clause, char where)
  244. #else
  245. bool
  246. assertProcedure(proc, clause, where)
  247. Procedure proc;
  248. Clause clause;
  249. char where;
  250. #endif
  251. { register Definition def = proc->definition;
  252.  
  253.   startCritical;
  254.   if (def->lastClause == (Clause) NULL)
  255.   { def->definition.clauses = def->lastClause = clause;
  256.   } else if (where == 'a')
  257.   { clause->next = def->definition.clauses;
  258.     def->definition.clauses = clause;
  259.   } else
  260.   { Clause last = def->lastClause;
  261.  
  262.     last->next = clause;
  263.     def->lastClause = clause;
  264.     
  265. #if O_AUTOINDEX
  266.     if ( true(def, AUTOINDEX) && def->indexPattern == 0x0 )
  267.     { if ( true(clause, INDEXABLE) )
  268.       { if ( true(last, INDEXABLE) )
  269.     { def->indexMerit += 1;        /* indexing gains on this clause */
  270.  
  271.       if ( def->indexMerit > 1 )    /* good enough? */
  272.       { def->indexPattern = 0x1;
  273.         def->indexCardinality = 1;
  274.         reindexProcedure(proc);
  275.       }
  276.     }
  277.       } else
  278.       { def->indexMerit -= 2;        /* indexing looses on this one */
  279.       }
  280.     }
  281. #endif /* O_AUTOINDEX */
  282.   }
  283.   endCritical;  
  284.  
  285.   succeed;
  286. }
  287.  
  288. /*  Abolish a procedure.  Referenced  clauses  are   unlinked  and left
  289.     dangling in the dark until the procedure referencing it deletes it.
  290.  
  291.     Since we have a foreign language interface we will allow to  abolish
  292.     foreign  predicates  as  well.  Permission testing should be done by
  293.     the caller.
  294.  
  295.  ** Sun Apr 17 16:18:50 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  296.  
  297. bool
  298. abolishProcedure(proc, module)
  299. Procedure proc;
  300. Module module;
  301. { register Definition def = proc->definition;
  302.  
  303.   if ( def->module != module )        /* imported predicate; remove link */
  304.   { def  = (Definition) allocHeap(sizeof(struct definition));
  305.     proc->definition = def;
  306.     def->module = module;
  307.     def->definition.clauses = (Clause) NULL;
  308.     def->lastClause = (Clause) NULL;
  309. #if O_PROFILE
  310.     def->profile_ticks = 0;
  311.     def->profile_calls = 0;
  312.     def->profile_redos = 0;
  313.     def->profile_fails = 0;
  314. #endif /* O_PROFILE */
  315.     resetProcedure(proc);
  316.  
  317.     succeed;
  318.   }
  319.  
  320.   if ( true(def, FOREIGN) )
  321.   { startCritical;
  322.     def->definition.clauses = def->lastClause = (Clause) NULL;
  323.     resetProcedure(proc);
  324.     endCritical;
  325.  
  326.     succeed;
  327.   }
  328.  
  329.   removeClausesProcedure(proc);
  330.   resetProcedure(proc);
  331.  
  332.   succeed;
  333. }
  334.  
  335. void
  336. removeClausesProcedure(proc)
  337. Procedure proc;
  338. { Definition def = proc->definition;
  339.   Clause c, next;
  340.  
  341.   startCritical;
  342.   for(c = def->definition.clauses; c; c = next)
  343.   { next = c->next;
  344.     if (c->references == 0)
  345.     { freeClause(c);
  346.     } else
  347.     { set(c, ERASED);
  348.       c->next = (Clause) NULL;
  349.     }
  350.   }
  351.   def->definition.clauses = def->lastClause = (Clause) NULL;
  352.  
  353.   endCritical;
  354. }
  355.  
  356. /*  Retract a clause from a procedure.  When a clause without references
  357.     is  retracted  it  is  actually removed from the heap, otherwise the
  358.     clause is unlinked and marked as `erased'.  Its  next  pointer  will
  359.     not be changed.  to avoid the follow up clause to be destroyed it is
  360.     given an extra reference.
  361.  
  362.  ** Sun Apr 17 16:28:32 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  363.  
  364. bool
  365. retractClauseProcedure(proc, clause)
  366. Procedure proc;
  367. Clause clause;
  368. { Clause prev = (Clause) NULL;
  369.   Clause c;
  370.   register Definition def = proc->definition;
  371.  
  372.   for(c = def->definition.clauses; c; prev = c, c = c->next)
  373.   { if (c == clause)
  374.     { startCritical;
  375.       if (prev == (Clause) NULL)
  376.       { def->definition.clauses = c->next;
  377.     if (c->next == (Clause) NULL)
  378.       def->lastClause = (Clause) NULL;
  379.       } else
  380.       { prev->next = c->next;
  381.     if (c->next == (Clause) NULL)
  382.       def->lastClause = prev;
  383.       }
  384.       if (c->references == 0)
  385.       { freeClause(c);
  386.       } else
  387.       { set(clause, ERASED);
  388.     if (clause->next)
  389.       clause->next->references++;
  390.       }
  391.       endCritical;
  392.  
  393.       succeed;
  394.     }
  395.   }
  396.  
  397.   fail;
  398. }
  399.  
  400. void
  401. unallocClause(clause)
  402. Clause clause;
  403. { DEBUG(1, word w;
  404.        setVar(w);
  405.        decompile(clause, &w);
  406.        Putf("removing clause ");
  407.        pl_write(&w);
  408.        Putf(" of %s\n", procedureName(clause->procedure));
  409.        );
  410.  
  411.   if ( clause->next &&
  412.        --clause->next->references == 0 &&
  413.        true(clause->next, ERASED) )
  414.     unallocClause(clause->next);
  415.  
  416.   freeClause(clause);
  417. }
  418.  
  419. void
  420. freeClause(c)
  421. Clause c;
  422. { if (c->XR_size)
  423.   { freeHeap(c->externals, sizeof(word) * c->XR_size);
  424.     statistics.externals -= c->XR_size;
  425.   }
  426.   statistics.codes -= c->code_size;
  427.   freeHeap(c->codes, sizeof(code) * c->code_size);
  428.   freeHeap(c, sizeof(struct clause));
  429. }
  430.  
  431. /*  resetReferences() sets all clause reference counts to zero. It is
  432.     called by abort().
  433.  
  434.  ** Fri May 27 10:36:14 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  435.  
  436. static void
  437. resetReferencesModule(m)
  438. Module m;
  439. { Definition def;
  440.   Symbol s;
  441.   Clause clause;
  442.  
  443.   for_table(s, m->procedures)
  444.   { def = ((Procedure) s->value)->definition;
  445. #if O_PROFILE
  446.     clear(def, PROFILE_TICKED);
  447. #endif /* O_PROFILE */
  448.     if ( true(def, FOREIGN) )
  449.       continue;
  450.  
  451.     for(clause=def->definition.clauses; clause; clause = clause->next)
  452.       clause->references = 0;
  453.   }
  454. }
  455.  
  456. void
  457. resetReferences()
  458. { Symbol s;
  459.  
  460.   for_table(s, moduleTable)
  461.     resetReferencesModule((Module) s->value);
  462. }
  463.  
  464.         /********************************
  465.         *     UNDEFINED PROCEDURES      *
  466.         *********************************/
  467.  
  468. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  469. A dynamic call to `f' in `m' has to be made (via call/1, apply/2 or from
  470. C). This procedure  returns  the  procedure  to  be  run.   If  no  such
  471. procedure  exists  an  undefined  procedure is created and returned.  In
  472. this case interpret() will later call  trapUndefined()  to  generate  an
  473. error message (or link the procedure from the library via autoload).
  474. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  475.  
  476. Procedure
  477. resolveProcedure(f, module)
  478. FunctorDef f;
  479. Module module;
  480. { Procedure proc;
  481.   Module m;
  482.  
  483.   for( m = module; m != (Module) NULL; m = m->super )
  484.   { if ( (proc = isCurrentProcedure(f, m)) != (Procedure) NULL &&
  485.        isDefinedProcedure(proc) )
  486.       return proc;
  487.   }
  488.  
  489.   return lookupProcedure(f, module);
  490. }
  491.  
  492. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  493. autoImport() tries to autoimport f into module `m' and  returns  success
  494. if this is possible.
  495.  
  496. PROBLEM: I'm not entirely  sure  it  is  save  to  deallocated  the  old
  497. definition  structure  in  all  cases.   It  is  not  member of any heap
  498. structure, thus sofar everything  is  alright.   After  a  dynamic  link
  499. interpret()  picks up the new definition pointer, thus this should be ok
  500. as well.  Any other C-code that  does  nasty  things  (non-deterministic
  501. code  perhaps,  calls  indirect via C? (I do recall once conciously have
  502. decided its not save, but can't recall why ...)
  503. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  504.  
  505. static bool
  506. autoImport(f, m)
  507. FunctorDef f;
  508. Module m;
  509. { Procedure proc, p;
  510.                     /* Defined: no problem */
  511.   if ( (proc = isCurrentProcedure(f, m)) != NULL &&
  512.        isDefinedProcedure(proc) )
  513.     succeed;
  514.   
  515.   if ( m->super == (Module) NULL )    /* No super: can't import */
  516.     fail;
  517.  
  518.   TRY( autoImport(f, m->super) );    /* Import in super */
  519.  
  520.   p = isCurrentProcedure(f, m->super);    /* Link the two */
  521.   if ( proc == NULL )            /* Create header if not there */
  522.     proc = lookupProcedure(f, m);
  523.                     /* save? */
  524.   freeHeap(proc->definition, sizeof(struct definition));
  525.   proc->definition = p->definition;
  526.  
  527.   succeed;
  528. }
  529.  
  530. void
  531. trapUndefined(proc)
  532. Procedure proc;
  533. { int retry_times = 0;
  534.  
  535.   retry:
  536.                     /* Auto import */
  537.   if ( autoImport(proc->functor, proc->definition->module) == TRUE )
  538.     return;
  539.                     /* Pred/Module does not want to trap */
  540.   if ( true(proc->definition, DYNAMIC) ||
  541.        false(proc->definition->module, UNKNOWN) )
  542.     return;
  543.                     /* Trap via exception/3 */
  544.   if ( status.boot == FALSE )
  545.   { word goal;
  546.     mark m;
  547.     bool rval;
  548.   
  549.     Mark(m);
  550.     goal = globalFunctor(FUNCTOR_undefinterc3);
  551.     unifyAtomic(argTermP(goal, 0), proc->definition->module->name);
  552.     unifyAtomic(argTermP(goal, 1), proc->functor->name);
  553.     unifyAtomic(argTermP(goal, 2), consNum(proc->functor->arity));
  554.  
  555.     debugstatus.suspendTrace++;
  556.     rval = callGoal(MODULE_system, goal, FALSE);
  557.     debugstatus.suspendTrace--;
  558.  
  559.     Undo(m);
  560.  
  561.     if ( rval == TRUE )
  562.     { extern int trace_continuation;    /* from pl-trace.c */
  563.  
  564.       switch( trace_continuation )
  565.       { case ACTION_FAIL:
  566.       return;
  567.     case ACTION_RETRY:
  568.       if ( retry_times++ )
  569.       { warning("exception handler failed to define predicate %s\n",
  570.             procedureName(proc));
  571.         break;
  572.       }
  573.       goto retry;
  574.     default:
  575.       warning("Illegal return value from exception handler");
  576.       }
  577.     }
  578.   }
  579.  
  580.                     /* No one want to intercept */
  581.   warning("Undefined predicate: %s", procedureName(proc) );
  582. }
  583.  
  584.         /********************************
  585.         *            RETRACT            *
  586.         *********************************/
  587.  
  588. word
  589. pl_retract(term, h)
  590. Word term;
  591. word h;
  592. { Procedure proc;
  593.   Word head, body;
  594.   Module m = (Module) NULL;
  595.   Clause clause;
  596.  
  597.   if ( ForeignControl(h) == FRG_CUTTED )
  598.   { clause = (Clause) ForeignContextAddress(h);
  599.     leaveClause(clause);            /* dereference it */
  600.  
  601.     succeed;
  602.   }
  603.  
  604.   if ((term = stripModule(term, &m)) == (Word) NULL)
  605.     fail;
  606.  
  607.   if (splitClause(term, &head, &body) == FALSE)
  608.     return warning("retract/1: illegal specification");
  609.  
  610.   if ( ForeignControl(h) == FRG_FIRST_CALL )
  611.   { if ( isAtom(*head) )
  612.       proc = isCurrentProcedure(lookupFunctorDef((Atom)*head, 0), m);
  613.     else if ( isTerm(*head) )
  614.       proc = isCurrentProcedure(functorTerm(*head), m);
  615.     else
  616.       return warning("retract/1: Illegal predicate specification");
  617.  
  618.     if ( proc == (Procedure) NULL )
  619.       fail;
  620.  
  621.     if ( true(proc->definition, FOREIGN) )
  622.       return warning("retract/1: cannot retract from a foreign predicate");
  623.     if ( true(proc->definition, SYSTEM) && false(proc->definition, DYNAMIC) )
  624.       return warning("retract/1: Attempt to retract from a system predicate");
  625.  
  626.     clause = proc->definition->definition.clauses;
  627.   } else
  628.   { Clause next;            /* dereference the old one */
  629.  
  630.     clause = (Clause) ForeignContextAddress(h);
  631.     for( next = clause; next && true(next, ERASED); next = next->next )
  632.       ;
  633.     leaveClause(clause);
  634.     clause = next;
  635.   }
  636.  
  637.   for(; clause; clause = clause->next)
  638.   { Clause next;
  639.     bool det;
  640.  
  641.     if (isTerm(*head) )
  642.     { if ((clause = findClause(clause, 
  643.                    argTermP(*head, 0), 
  644.                    clause->procedure->definition,
  645.                    &det)) == (Clause) NULL)
  646.     fail;
  647.     } else if ( isAtom(*head) )
  648.     { if ( true(clause, ERASED) )
  649.     continue;
  650.       det = (clause->next == NULL);
  651.     } else
  652.       return warning("retract/1: illegal clause head");
  653.  
  654.     { mark m;
  655.  
  656.       Mark(m);
  657.       if (decompile(clause, term) == TRUE)
  658.       { next = clause->next;
  659.     retractClauseProcedure(clause->procedure, clause);
  660. /*    set(clause->procedure->definition, DYNAMIC); */
  661.     if ( det == TRUE )
  662.       succeed;
  663.     next->references++;    /* avoid the next beeing deleted */
  664.  
  665.     ForeignRedo(next);
  666.       }
  667.       Undo(m);
  668.     }
  669.  
  670.     continue;
  671.   }
  672.  
  673.   fail;
  674. }
  675.  
  676.         /********************************
  677.         *       PROLOG PREDICATES       *
  678.         *********************************/
  679.  
  680. word
  681. pl_abolish(atom, arity)
  682. Word atom, arity;
  683. { FunctorDef f;
  684.   Procedure proc;
  685.   Module m = (Module) NULL;
  686.  
  687.   if ((atom = stripModule(atom, &m)) == (Word) NULL)
  688.     fail;
  689.  
  690.   if (!isAtom(*atom) || !isInteger(*arity))
  691.     return warning("abolish/2: instantiation fault");
  692.  
  693.   if ((f = isCurrentFunctor((Atom)*atom, (int)valNum(*arity))) == (FunctorDef) NULL)
  694.     succeed;
  695.   if ((proc = isCurrentProcedure(f, m)) == (Procedure) NULL)
  696.     succeed;
  697.  
  698.   if ( true(proc->definition, SYSTEM) && !SYSTEM_MODE && m == MODULE_system )
  699.     return warning("abolish/2: attempt to abolish a system predicate");
  700.  
  701.   return abolishProcedure(proc, m);
  702. }
  703.  
  704. word
  705. pl_list_references(descr)
  706. Word descr;
  707. { Procedure proc;
  708.   Clause clause;
  709.  
  710.   if ((proc = findProcedure(descr)) == (Procedure) NULL)
  711.     return warning("$list_references/1: no such predicate");
  712.  
  713.   if ( true(proc->definition, FOREIGN) )
  714.     fail;
  715.   for(clause=proc->definition->definition.clauses;
  716.        clause;
  717.        clause = clause->next)
  718.     Putf("%d ", clause->references);
  719.  
  720.   Putf("\n");
  721.  
  722.   succeed;
  723. }
  724.  
  725. word
  726. pl_list_active_procedures()
  727. { Procedure proc;
  728.   Module m;
  729.   Clause clause;
  730.   int nth;
  731.   bool first;
  732.   Symbol sm, sp;
  733.  
  734.   for_table(sm, moduleTable)
  735.   { m = (Module) sm->value;
  736.     for_table(sp, m->procedures)
  737.     { proc = (Procedure) sp->value;
  738.  
  739.       if ( true(proc->definition, FOREIGN) ||    /* no clauses */
  740.        proc->definition->module != m)    /* imported */
  741.     continue;
  742.  
  743.       first = TRUE;
  744.       for(clause = proc->definition->definition.clauses, nth=1;
  745.        clause;
  746.        nth++, clause = clause->next)
  747.       { if ( true(clause, ERASED) )
  748.       continue;
  749.     if (clause->references != 0)
  750.     { if (first)
  751.       { Putf("%s: ", procedureName(proc) );
  752.         first = FALSE;
  753.       } else
  754.         Putf(", ");
  755.       Putf("%d: %d", nth, clause->references);
  756.     }
  757.       }
  758.       if (first == FALSE)
  759.     Putf("\n");
  760.     }
  761.   }
  762.  
  763.   succeed;
  764. }
  765.  
  766. #if PROTO
  767. static bool
  768. attribute(Definition def, Word value, short att)
  769. #else
  770. static bool
  771. attribute(def, value, att)
  772. Definition def;
  773. Word value;
  774. short att;
  775. #endif
  776. { if ( isVar(*value) )
  777.     return unifyAtomic(value, consNum((def->flags & att) ? 1 : 0));
  778.  
  779.   switch((int) valNum(*value))
  780.   { case 0:    clear(def, att);
  781.         succeed;
  782.     case 1:    set(def, att);
  783.         if ( (att == DYNAMIC || att == MULTIFILE) && SYSTEM_MODE )
  784.         { set(def, SYSTEM);
  785.           set(def, HIDE_CHILDS);
  786.         }
  787.         succeed;
  788.     default:    return sysError("$predicate_attribute/3: Illegal value");
  789.   }
  790. }
  791.  
  792. word
  793. pl_predicate_attribute(pred, what, value)
  794. Word pred, what, value;
  795. { Procedure proc;
  796.   FunctorDef fd;
  797.   Definition def;
  798.   Atom key;
  799.   Module module = (Module) NULL;
  800.  
  801.   pred = stripModule(pred, &module);
  802.   if ( isAtom(*pred) )
  803.     fd = lookupFunctorDef((Atom) *pred, 0);
  804.   else if ( isTerm(*pred) )
  805.     fd = functorTerm(*pred);
  806.   else
  807.     fail;
  808.  
  809.   proc = resolveProcedure(fd, module);
  810.   def = proc->definition;
  811.  
  812.   if (!isAtom(*what) )
  813.     return warning("$predicate_attribute/3: key should be an atom");
  814.   key = (Atom) *what;
  815.  
  816.   if (key == ATOM_imported)
  817.   { if (module == def->module)
  818.       fail;
  819.     return unifyAtomic(value, def->module->name);
  820.   }
  821.   if (key == ATOM_indexed)
  822.   { if (def->indexPattern == 0x0)
  823.       fail;
  824.     return indexPatternToTerm(proc, value);
  825.   }
  826.  
  827.   if (!isVar(*value) && (!isInteger(*value) || (valNum(*value) & ~1)))
  828.     return warning("$predicate_attribute/3: illegal 3rd argument");
  829.  
  830.   if (key == ATOM_dynamic)    return attribute(def, value, DYNAMIC);
  831.   if (key == ATOM_multifile)    return attribute(def, value, MULTIFILE);
  832.   if (key == ATOM_system)    return attribute(def, value, SYSTEM);
  833.   if (key == ATOM_spy)        return attribute(def, value, SPY_ME);
  834.   if (key == ATOM_trace)    return attribute(def, value, TRACE_ME);
  835.   if (key == ATOM_hide_childs)    return attribute(def, value, HIDE_CHILDS);
  836.   if (key == ATOM_transparent)    return attribute(def, value, TRANSPARENT);
  837.   if (key == ATOM_discontiguous) return attribute(def,value, DISCONTIGUOUS);
  838.   if (key == ATOM_foreign)
  839.     return unifyAtomic(value, consNum(true(def, FOREIGN) ? 1 : 0));
  840.   if (key == ATOM_exported)
  841.     return unifyAtomic(value, consNum(isPublicModule(module, proc)));
  842.   if (key == ATOM_defined)
  843.     return unifyAtomic(value, consNum(true(def, FOREIGN) ||
  844.                       def->definition.clauses ? 1 : 0) );
  845.   else
  846.     return warning("$predicate_attribute/4: unknown key");
  847. }
  848.  
  849.  
  850. void
  851. reindexProcedure(proc)
  852. Procedure proc;
  853. { register Clause cl;
  854.  
  855.   for(cl = proc->definition->definition.clauses; cl; cl = cl->next)
  856.     reindexClause(cl);
  857. }
  858.  
  859.  
  860. word
  861. pl_index(pred)
  862. Word pred;
  863. { Procedure proc = findCreateProcedure(pred);
  864.   Module module = (Module) NULL;
  865.   Word head = stripModule(pred, &module);
  866.   Word arg;
  867.   int arity, a;
  868.   ulong pattern = 0x0;
  869.   int card = 0;
  870.  
  871.   if (head == (Word) NULL)
  872.     fail;
  873.  
  874.   if (!isTerm(*head) )            /* :- index(foo) */
  875.     succeed;
  876.   arity = proc->functor->arity;
  877.   for(a = 0; a < arity; a++)
  878.   { arg = argTermP(*head, a);
  879.     deRef(arg);
  880.     if (!isInteger(*arg) || valNum(*arg) > 1 || valNum(*arg) < 0)
  881.       return warning("index/1: %s: illegal index specification", 
  882.                     procedureName(proc));
  883.     if (valNum(*arg) == 1)
  884.     { pattern |= 1 << a;
  885.       if (++card == 4)        /* maximal 4 indexed arguments */
  886.     break;
  887.     }
  888.   }
  889.  
  890. #if O_AUTOINDEX
  891.   clear(proc->definition, AUTOINDEX);
  892. #endif
  893.   if (proc->definition->indexPattern == pattern)
  894.     succeed;
  895.  
  896.   if (true(proc->definition, FOREIGN))
  897.     return warning("index/1: cannot index foreign predicate %s", 
  898.                     procedureName(proc));
  899.  
  900.   proc->definition->indexPattern = pattern;
  901.   proc->definition->indexCardinality = card;
  902.  
  903.   reindexProcedure(proc);
  904.  
  905.   succeed;
  906. }
  907.  
  908.         /********************************
  909.         *         SOURCE FILE           *
  910.         *********************************/
  911.  
  912. SourceFile
  913. lookupSourceFile(name)
  914. Atom name;
  915. { SourceFile file;
  916.  
  917.   for(file=sourceFileTable; file; file=file->next)
  918.   { if (file->name == name)
  919.       return file;
  920.   }
  921.   file = (SourceFile) allocHeap(sizeof(struct sourceFile) );
  922.   file->name = name;
  923.   file->count = 0;
  924.   file->time = 0L;
  925.   file->system = status.boot;
  926.   file->next = (SourceFile) NULL;
  927.  
  928.   if ( sourceFileTable == (SourceFile) NULL )
  929.   { sourceFileTable = tailSourceFileTable = file;
  930.   } else
  931.   { tailSourceFileTable->next = file;
  932.     tailSourceFileTable = file;
  933.   }
  934.  
  935.   return file;
  936. }
  937.  
  938. SourceFile
  939. isCurrentSourceFile(name)
  940. Atom name;
  941. { SourceFile file;
  942.  
  943.   for(file=sourceFileTable; file; file=file->next)
  944.   { if (file->name == name)
  945.       return file;
  946.   }
  947.  
  948.   return (SourceFile) NULL;
  949. }
  950.  
  951. word
  952. pl_make_system_source_files()
  953. { SourceFile file;
  954.  
  955.   for(file=sourceFileTable; file; file=file->next)
  956.     file->system = TRUE;
  957.  
  958.   succeed;
  959. }
  960.  
  961. word
  962. pl_source_file(descr, file)
  963. Word descr, file;
  964. { Procedure proc;
  965.  
  966.   if ((proc = findProcedure(descr)) == (Procedure) NULL)
  967.     fail;
  968.   if (proc->definition->source == (SourceFile) NULL)
  969.     fail;
  970.  
  971.   return unifyAtomic(file, proc->definition->source->name);
  972. }
  973.  
  974. word
  975. pl_time_source_file(file, time, h)
  976. Word file, time;
  977. word h;
  978. { SourceFile fr;
  979.  
  980.   switch( ForeignControl(h) )
  981.   { case FRG_FIRST_CALL:
  982.       fr = sourceFileTable;
  983.       break;
  984.     case FRG_REDO:
  985.       fr = (SourceFile) ForeignContextAddress(h);
  986.       break;
  987.     case FRG_CUTTED:
  988.     default:
  989.       succeed;
  990.   }
  991.  
  992.   for(;fr != (SourceFile) NULL; fr = fr->next)
  993.   { if ( fr->system == TRUE )
  994.       continue;
  995.     if ( unifyAtomic(file, fr->name) &&
  996.          unifyTime(time, fr->time) )
  997.     { if (fr->next != (SourceFile) NULL)
  998.     ForeignRedo(fr->next);
  999.       else
  1000.     succeed;
  1001.     }
  1002.   }
  1003.  
  1004.   fail;
  1005. }
  1006.  
  1007. word
  1008. pl_start_consult(file)
  1009. Word file;
  1010. { SourceFile f;
  1011.  
  1012.   if (!isAtom(*file) )
  1013.     fail;
  1014.   f = lookupSourceFile((Atom)*file);
  1015.   f->count++;
  1016.   f->time = LastModifiedFile(stringAtom(*file));
  1017.  
  1018.   succeed;
  1019. }
  1020.