home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / SOURCE / LEFUN.C < prev    next >
C/C++ Source or Header  |  1996-06-04  |  35KB  |  1,386 lines
  1. /* Copyright 1991 Digital Equipment Corporation.
  2. ** All Rights Reserved.
  3. *****************************************************************/
  4. /*     $Id: lefun.c,v 1.4 1995/01/14 00:24:55 duchier Exp $     */
  5.  
  6. #ifndef lint
  7. static char vcid[] = "$Id: lefun.c,v 1.4 1995/01/14 00:24:55 duchier Exp $";
  8. #endif /* lint */
  9.  
  10. #include "extern.h"
  11. #include "login.h"
  12. #include "copy.h"
  13. #include "trees.h"
  14. #include "parser.h"
  15. #include "print.h"
  16. #include "lefun.h"
  17. #include "token.h"
  18.  
  19.  
  20. ptr_goal resid_aim;
  21. ptr_resid_list resid_vars; /* 21.9 */
  22. /* ptr_goal resid_limit; 12.6 */
  23.  
  24. long curried;
  25. long can_curry;
  26.  
  27. /* ptr_psi_term match_date; 13.6 */
  28. /* ptr_choice_point cut_point; 13.6 */
  29.  
  30. static long attr_missing;
  31. static long check_func_flag;
  32.  
  33. void eval_global_var(); /*  RM: Feb 10 1993  */
  34.  
  35.  
  36. /* Create a new psi_term on the stack with value '@' (top) and no attributes. */
  37. ptr_psi_term stack_psi_term(stat)
  38. long stat;
  39. {
  40.   ptr_psi_term result;
  41.  
  42.   result=STACK_ALLOC(psi_term);
  43.   result->type=top;
  44.   result->status=stat;
  45.   result->flags=stat?QUOTED_TRUE:FALSE; /* 14.9 */
  46.   result->attr_list=NULL;
  47.   result->coref=NULL;
  48. #ifdef TS
  49.   result->time_stamp=global_time_stamp; /* 9.6 */
  50. #endif
  51.   result->resid=NULL;
  52.   result->value=NULL;
  53.  
  54.   return result;
  55. }
  56.  
  57.  
  58.  
  59. /* Create a new psi_term on the stack with a real number value. */
  60. ptr_psi_term real_stack_psi_term(stat,thereal)
  61. long stat;
  62. REAL thereal;
  63. {
  64.   ptr_psi_term result;
  65.  
  66.   result=STACK_ALLOC(psi_term);
  67.   result->type = (thereal==floor(thereal)) ? integer : real;
  68.   result->status=stat;
  69.   result->flags=stat?QUOTED_TRUE:FALSE; /* 14.9 */
  70.   result->attr_list=NULL;
  71.   result->coref=NULL;
  72. #ifdef TS
  73.   result->time_stamp=global_time_stamp; /* 9.6 */
  74. #endif
  75.   result->resid=NULL;
  76.   result->value=(GENERIC)heap_alloc(sizeof(REAL));
  77.   (* (REAL *)(result->value)) = thereal;
  78.  
  79.   return result;
  80. }
  81.  
  82.  
  83.  
  84. /* Create a new psi_term on the heap with value '@' (top) and no attributes. */
  85. ptr_psi_term heap_psi_term(stat)
  86. long stat;
  87. {
  88.   ptr_psi_term result;
  89.  
  90.   result=HEAP_ALLOC(psi_term);
  91.   result->type=top;
  92.   result->status=stat;
  93.   result->flags=stat?QUOTED_TRUE:FALSE; /* 14.9 */
  94.   result->attr_list=NULL;
  95.   result->coref=NULL;
  96. #ifdef TS
  97.   result->time_stamp=global_time_stamp; /* 9.6 */
  98. #endif
  99.   result->resid=NULL;
  100.   result->value=NULL;
  101.  
  102.   return result;
  103. }
  104.  
  105.  
  106.  
  107. /* Create an empty list on the stack,  wiped out by RM: Dec 14 1992  */
  108. /* ptr_psi_term stack_empty_list()  is now aliased to stack_nil()    */
  109.  
  110.  
  111.  
  112. /******** RESIDUATE_DOUBLE(t,u)
  113.   Residuate the current expression with T in the Residuation Variable set.
  114.   Also store the other variable, so that its sort can be used in the
  115.   'bestsort' calculation needed to implement disequality constraints.
  116. */
  117. void residuate_double(t,u) /* 21.9 */
  118. ptr_psi_term t,u;
  119. {
  120.   ptr_resid_list curr;
  121.  
  122.   curr=STACK_ALLOC(resid_list);
  123.   curr->var=t;
  124.   curr->othervar=u;
  125.   curr->next=resid_vars;
  126.   resid_vars=curr;
  127. }
  128.  
  129.  
  130.  
  131.  
  132. /******** RESIDUATE(t)
  133.   Residuate the current expression with T in the Residuation Variable set.
  134. */
  135. void residuate(t)
  136. ptr_psi_term t;
  137. {
  138.   ptr_resid_list curr;
  139.  
  140.   curr=STACK_ALLOC(resid_list);
  141.   curr->var=t;
  142.   curr->othervar=NULL; /* 21.9 */
  143.   curr->next=resid_vars;
  144.   resid_vars=curr;
  145. }
  146.  
  147.  
  148.  
  149. /******** RESIDUATE2(u,v)
  150.   Residuate the current function on the two variables U and V.
  151. */
  152. void residuate2(u,v)
  153. ptr_psi_term u,v;
  154. {
  155.   residuate(u);
  156.   if (v && u!=v) residuate(v);
  157. }
  158.  
  159.  
  160.  
  161. /******** RESIDUATE3(u,v,w)
  162.   Residuate the current function on the three variables U, V, and W.
  163. */
  164. void residuate3(u,v,w)
  165. ptr_psi_term u,v,w;
  166. {
  167.   residuate(u);
  168.   if (v && u!=v) residuate(v);
  169.   if (w && u!=w && v!=w) residuate(w);
  170. } 
  171.  
  172.  
  173.  
  174. /******** CURRY()
  175.   Decide that the current function will have to be curried.
  176.   This has become so simple it could be a MACRO.
  177.   The real work is done by DO_CURRY.
  178. */
  179. void curry()
  180. {
  181.   if (can_curry)
  182.     curried=TRUE;
  183. }
  184.  
  185.  
  186.  
  187.  
  188. /******** RESIDUATEGOALONVAR(g,var,othervar)
  189.   Add the goal to the variable's residuation list.
  190.   Also update the residuation's 'bestsort' field if it exists (needed to
  191.   implement complete disequality semantics).  The 'othervar' parameter
  192.   is needed for this.
  193. */
  194. long residuateGoalOnVar(g, var, othervar)
  195. ptr_goal g;
  196. ptr_psi_term var,othervar;
  197. {
  198.   long result;
  199.   long resflag,resflag2;
  200.   GENERIC rescode,rescode2,resvalue,resvalue2;
  201.   /* Set to FALSE if the goal is already residuated on the var: */
  202.   long not_found = TRUE;
  203.   /* Points to a pointer to a residuation structure.  Used so we can */
  204.   /* add the goal to the end of the residuation list, so that it can */
  205.   /* can be undone later if backtracking happens.  See the call to   */
  206.   /* push_ptr_value.  */
  207.   ptr_residuation *r;
  208.     
  209.   /* 5.8 PVR */
  210.   if ((GENERIC)var>=heap_pointer) {
  211.     Errorline("attempt to residuate on psi-term %P in the heap.\n",var);
  212.  
  213.     return FALSE;
  214.   }
  215.  
  216.   r= &(var->resid);
  217.     
  218.   while (not_found && *r) {
  219.     if ((*r)->goal == g) { /* This goal is already attached */
  220.       /* Keep track of best sort so far */
  221.       /* Glb_code(..) tries to keep 'sortflag' TRUE if possible. */
  222.       result=glb_code((*r)->sortflag,(*r)->bestsort,
  223.               TRUE,var->type,&resflag,&rescode);
  224.       result=glb_value(result,resflag,rescode,(*r)->value,var->value,
  225.                &resvalue); /* 6.10 */
  226.       if (!result)
  227.         return FALSE; /* 21.9 */
  228.       else if (othervar) {
  229.     result=glb_code(resflag,rescode,TRUE,othervar->type,
  230.             &resflag2,&rescode2);
  231.         result=glb_value(result,resflag2,rescode2,resvalue,othervar->value,
  232.              &resvalue2); /* 6.10 */
  233.         if (!result) {
  234.           return FALSE;
  235.         }
  236.         else {
  237.       /* The value field only has to be trailed once, since its value */
  238.       /* does not change, once given. */
  239.       if ((*r)->value==NULL && resvalue2!=NULL) { /* 6.10 */
  240.         push_ptr_value(int_ptr,&((*r)->value));
  241.       }
  242.       if ((*r)->bestsort!=rescode2) {
  243.             push_ptr_value(((*r)->sortflag?def_ptr:code_ptr),
  244.                &((*r)->bestsort));
  245.             (*r)->bestsort=rescode2; /* 21.9 */
  246.       }
  247.       if ((*r)->sortflag!=resflag2) {
  248.             push_ptr_value(int_ptr,&((*r)->sortflag));
  249.             (*r)->sortflag=resflag2; /* 21.9 */
  250.       }
  251.     }
  252.       }
  253.       else {
  254.     if ((*r)->value==NULL && resvalue!=NULL) { /* 6.10 */
  255.       push_ptr_value(int_ptr,&((*r)->value));
  256.     }
  257.     if ((*r)->bestsort!=rescode) {
  258.           push_ptr_value(((*r)->sortflag?def_ptr:code_ptr),
  259.                      &((*r)->bestsort));
  260.           (*r)->bestsort=rescode; /* 21.9 */
  261.     }
  262.     if ((*r)->sortflag!=resflag) {
  263.           push_ptr_value(int_ptr,&((*r)->sortflag));
  264.           (*r)->sortflag=resflag; /* 21.9 */
  265.     }
  266.       }
  267.       not_found = FALSE;
  268.     }
  269.     else
  270.       r= &((*r)->next);  /* look at the next one */
  271.   }
  272.   
  273.   if (not_found) {
  274.     /* We must attach this goal & the variable's sort onto this variable */
  275.     
  276.     push_ptr_value(resid_ptr,r);
  277.     *r=STACK_ALLOC(residuation);
  278.     if (othervar) {
  279.       result=glb_code(TRUE,var->type,TRUE,othervar->type,&resflag,&rescode);
  280.       result=glb_value(result,resflag,rescode,var->value,othervar->value,
  281.                &resvalue); /* 6.10 */
  282.       if (!result) {
  283.         return FALSE;
  284.       }
  285.       else {
  286.     (*r)->sortflag=resflag;
  287.         (*r)->bestsort=rescode; /* 21.9 */
  288.     (*r)->value=resvalue; /* 6.10 */
  289.       }
  290.     }
  291.     else {
  292.       (*r)->sortflag=TRUE;
  293.       (*r)->bestsort=(GENERIC)var->type; /* 21.9 */
  294.       (*r)->value=(GENERIC)var->value; /* 6.10 */
  295.     }
  296.     (*r)->goal=g;
  297.     (*r)->next=NULL;
  298.   }
  299.   
  300.   if (!(g->pending)) {
  301.     /* this goal is not pending, so make sure it will be put on the goal
  302.      * stack later
  303.      */
  304.     push_ptr_value(int_ptr,&(g->pending));
  305.     g->pending=TRUE;
  306.   }
  307.   
  308.   return TRUE; /* 21.9 */
  309. }
  310.  
  311.  
  312.  
  313. /******** DO_RESIDUATION()
  314.   Undo anything that matching may have done, then
  315.   create a residuated expression. Check that the same constraint does not
  316.   hang several times on the same variable.
  317.  
  318.   This routine takes time proportional to the square of the number of
  319.   residuations.  This is too slow; eventually it should be sped up, 
  320.   especially if equality constraints are often used.
  321. */
  322. long do_residuation(); /* forward declaration */
  323.  
  324. /* LIFE-defined routines reset the goal stack to what it was */
  325. /* before the function call. */
  326. long do_residuation_user()
  327. {
  328.   goal_stack=resid_aim->next; /* reset goal stack */
  329.   return do_residuation();
  330. }
  331.  
  332. /* C-defined routines do all stack manipulation themselves */
  333. long do_residuation()
  334. {
  335.   long success;
  336.   ptr_psi_term t,u;
  337.   ptr_goal *gs;
  338.   
  339.   /* This undoes perfectly valid work! */
  340.   /* The old version of Wild_Life did not trail anything
  341.      during matching, so I think this was a nop for it. */
  342.   /* PVR 11.5 undo(resid_limit); */
  343.   /* PVR 11.5 choice_stack=cut_point; */
  344.  
  345.   /* PVR 9.2.94 */
  346.   /* goal_stack=resid_aim->next; */
  347.  
  348.   if (trace) {
  349.     tracing();
  350.     print_resid_message(resid_aim->a,resid_vars);
  351.   }
  352.  
  353.   while (resid_vars) {
  354.     
  355.     t=resid_vars->var; /* 21.9 */
  356.     u=resid_vars->othervar; /* 21.9 */
  357.     /* PVR */ deref_ptr(t);
  358.     resid_vars=resid_vars->next;
  359.     Traceline("residuating on %P (other = %P)\n",t,u);
  360.     
  361.     success=residuateGoalOnVar(resid_aim, t, u); /* 21.9 */
  362.     if (!success) { /* 21.9 */
  363.       Traceline("failure because of disentailment\n");
  364.       return FALSE;
  365.     }
  366.   }
  367.   
  368.   Traceline("no failure because of disentailment\n");
  369.   return TRUE; /* 21.9 */
  370. }
  371.  
  372.  
  373.  
  374. /********* DO_CURRYING()
  375.   This performs CURRYing: all that needs to be done is to yield the calling
  376.   term as the result after having given up on evaluation. In effect the calling
  377.   psi-term is left intact.
  378. */
  379. void do_currying()
  380. {
  381.   ptr_psi_term funct,result;
  382.  
  383.   /* PVR 5.11 undo(resid_limit); */
  384.   /* PVR 5.11 choice_stack=cut_point; */
  385.   goal_stack=resid_aim->next;
  386.   funct=(ptr_psi_term )resid_aim->a;
  387.   result=(ptr_psi_term )resid_aim->b;
  388.     
  389.   Traceline("currying %P\n",funct);
  390.    
  391.   push_goal(unify_noeval,funct,result,NULL);
  392.   resid_aim=NULL;
  393. }
  394.  
  395.  
  396.  
  397. /******** RELEASE_RESID(t)
  398.   Release the residuations pending on the Residuation Variable T.
  399.   This is done by simply pushing the residuated goals onto the goal-stack.
  400.   A goal is not added if already present on the stack.
  401.   Two versions of this routine exist: one which trails t and one which never
  402.   trails t.
  403. */
  404. void release_resid_main(t,trailflag)
  405. ptr_psi_term t;
  406. long trailflag;
  407. {
  408.   ptr_goal g;
  409.   ptr_residuation r;
  410.   
  411.   if (r=t->resid) {
  412.     if (trailflag) push_ptr_value(resid_ptr,&(t->resid));
  413.     t->resid=NULL;
  414.     
  415.     while (r) {
  416.       g=r->goal;
  417.       if (g->pending) {
  418.     
  419.     push_ptr_value(int_ptr,&(g->pending));
  420.     g->pending=FALSE;
  421.     
  422.     push_ptr_value(goal_ptr,&(g->next));
  423.     
  424.     g->next=goal_stack;
  425.     goal_stack=g;
  426.     
  427.         Traceline("releasing %P\n",g->a);
  428.       }
  429.       r=r->next;
  430.     }
  431.   }
  432. }
  433.  
  434. void release_resid(t)
  435. ptr_psi_term t;
  436. {
  437.   release_resid_main(t,TRUE);
  438. }
  439.  
  440. void release_resid_notrail(t)
  441. ptr_psi_term t;
  442. {
  443.   release_resid_main(t,FALSE);
  444. }
  445.  
  446.  
  447.  
  448. /******** APPEND_RESID(u,v)
  449.   Append the residuations pending on V to U. This routine does not check that
  450.   the same constraint is not present twice in the end on U. This doesn't matter
  451.   since RELEASE_RESID ensures that the same constraint is not released more
  452.   than once.
  453. */
  454. void append_resid(u,v)
  455. ptr_psi_term u,v;
  456. {
  457.   ptr_residuation *g;
  458.   
  459.   g= &(u->resid);
  460.   while (*g)
  461.     g = &((*g)->next);
  462.   
  463.   push_ptr_value(resid_ptr,g);
  464.   *g=v->resid;
  465. }
  466.  
  467.  
  468.  
  469. /******** EVAL_AIM()
  470.   Evaluate a function.
  471.   This copies the current definition of the function and
  472.   stacking the various goals that are necessary to evaluate the function
  473.   correctly.
  474.   It creates an extra psi-term (with value top) in which to write the result.
  475. */
  476. long eval_aim()
  477. {
  478.   long success=TRUE;
  479.   ptr_psi_term funct,result,head,body;
  480.   ptr_pair_list rule;
  481.   /* RESID */ ptr_resid_block rb;
  482.   ptr_choice_point cutpt;
  483.   ptr_psi_term match_date; /* 13.6 */
  484.   
  485.   funct=(ptr_psi_term )aim->a;
  486.   deref_ptr(funct);
  487.  
  488.   /*  RM: Jun 18 1993  */
  489.   push2_ptr_value(int_ptr,&(funct->status),(funct->status & SMASK));
  490.   funct->status=4;
  491.  
  492.   
  493.   /* if (!funct->type->evaluate_args) mark_quote(funct); 25.8 */ /* 18.2 PVR */
  494.   result=(ptr_psi_term )aim->b;
  495.   rule=(ptr_pair_list )aim->c;
  496.  
  497.   match_date=(ptr_psi_term )stack_pointer;
  498.   cutpt=choice_stack; /* 13.6 */
  499.  
  500.   /* For currying and residuation */
  501.   curried=FALSE;
  502.   can_curry=TRUE;
  503.   /* resid_aim=aim; */
  504.   resid_vars=NULL;
  505.   /* resid_limit=(ptr_goal )stack_pointer; 12.6 */
  506.       
  507.   if (rule) {
  508.     Traceline("evaluate %P\n",funct);
  509.     if ((unsigned long)rule<=MAX_BUILT_INS) {
  510.       
  511.       resid_aim=aim;
  512.       success=c_rule[(unsigned long)rule]();
  513.  
  514.       if (curried)
  515.     do_currying();
  516.       else
  517.     if (resid_vars)
  518.       success=do_residuation(); /* 21.9 */
  519.     else {
  520.       /* resid_aim=NULL; */
  521.         }
  522.     }
  523.     else {
  524.       while (rule && (rule->a==NULL || rule->b==NULL)) {
  525.         rule=rule->next;
  526.         Traceline("alternative rule has been retracted\n");
  527.       }
  528.       if (rule) {
  529.         /* push_choice_point(eval,funct,result,rule->next); */ /* 17.6 */
  530.  
  531.         resid_aim=aim;
  532.         /* RESID */ rb = STACK_ALLOC(resid_block);
  533.         /* RESID */ save_resid(rb,match_date);
  534.         /* RESID */ /* resid_aim = NULL; */
  535.  
  536.         clear_copy();
  537.  
  538.     /*  RM: Jun 18 1993: no functions in head */
  539.     /*  if (TRUE)
  540.         head=eval_copy(rule->a,STACK);
  541.         else */
  542.     
  543.     head=quote_copy(rule->a,STACK);
  544.         body=eval_copy(rule->b,STACK);
  545.     head->status=4;
  546.     
  547.         if (rule->next) /* 17.6 */
  548.           push_choice_point(eval,funct,result,rule->next);
  549.  
  550.         push_goal(unify,body,result,NULL);
  551.         /* RESID */ push_goal(eval_cut,body,cutpt,rb); /* 13.6 */
  552.         /* RESID */ push_goal(match,funct,head,rb);
  553.         /* eval_args(head->attr_list); */
  554.       }
  555.       else {
  556.         success=FALSE;
  557.         /* resid_aim=NULL; */
  558.       }
  559.     }
  560.   }
  561.   else {
  562.     success=FALSE;
  563.     /* resid_aim=NULL; */
  564.   }
  565.   resid_aim=NULL;
  566.   /* match_date=NULL; */ /* 13.6 */
  567.   return success;
  568. }
  569.  
  570.  
  571.  
  572. /* Match the corresponding arguments */
  573. /* RESID */ match_attr1(u,v,rb)
  574. ptr_node *u,v;
  575. /* RESID */ ptr_resid_block rb;
  576. {
  577.   long cmp;
  578.   ptr_node temp;
  579.   
  580.   if (v) {
  581.     if (*u==NULL)
  582.       attr_missing=TRUE;
  583.     else {
  584.       cmp=featcmp((*u)->key,v->key);
  585.       if(cmp==0) {
  586.         ptr_psi_term t;
  587.       /* RESID */ match_attr1(&((*u)->right),v->right,rb);
  588.         t = (ptr_psi_term) (*u)->data;
  589.       /* RESID */ push_goal(match,(*u)->data,v->data,rb);
  590.         /* deref2_eval(t); */
  591.       /* RESID */ match_attr1(&((*u)->left),v->left,rb);
  592.       }
  593.       else if (cmp>0) {
  594.         temp=v->right;
  595.         v->right=NULL;
  596.       /* RESID */ match_attr1(u,temp,rb);
  597.       /* RESID */ match_attr1(&((*u)->left),v,rb);
  598.       v->right=temp;
  599.       }
  600.       else {
  601.       temp=v->left;
  602.       v->left=NULL;
  603.       /* RESID */ match_attr1(&((*u)->right),v,rb);
  604.       /* RESID */ match_attr1(u,temp,rb);
  605.       v->left=temp;
  606.       }
  607.     }
  608.   }
  609. }
  610.  
  611.  
  612. /* Evaluate the lone arguments (for lazy failure + eager success) */
  613. /* RESID */ match_attr2(u,v,rb)
  614. ptr_node *u,v;
  615. /* RESID */ ptr_resid_block rb;
  616. {
  617.   long cmp;
  618.   ptr_node temp;
  619.   
  620.   if (v) {
  621.     if (*u==NULL) { /* PVR 12.03 */
  622.       ptr_psi_term t;
  623.       match_attr1(u,v->right,rb);
  624.       t = (ptr_psi_term) v->data;
  625.       deref2_rec_eval(t);
  626.       match_attr1(u,v->left,rb);
  627.     }
  628.     else {
  629.       cmp=featcmp((*u)->key,v->key);
  630.       if(cmp==0) {
  631.       /* RESID */ match_attr2(&((*u)->right),v->right,rb);
  632.       /* RESID */ match_attr2(&((*u)->left),v->left,rb);
  633.       }
  634.       else if (cmp>0) {
  635.         temp=v->right;
  636.         v->right=NULL;
  637.       /* RESID */ match_attr2(u,temp,rb);
  638.       /* RESID */ match_attr2(&((*u)->left),v,rb);
  639.       v->right=temp;
  640.       }
  641.       else {
  642.       temp=v->left;
  643.       v->left=NULL;
  644.       /* RESID */ match_attr2(&((*u)->right),v,rb);
  645.       /* RESID */ match_attr2(u,temp,rb);
  646.       v->left=temp;
  647.       }
  648.     }
  649.   }
  650.   else if (*u!=NULL) {
  651.     ptr_psi_term t /* , empty */ ;
  652.     match_attr1(&((*u)->right),v,rb);
  653.     t = (ptr_psi_term) (*u)->data;
  654.     /* Create a new psi-term to put the (useless) result: */
  655.     /* This is needed so that *all* arguments of a function call */
  656.     /* are evaluated, which avoids incorrect 'Yes' answers.      */
  657.     deref2_rec_eval(t); /* Assumes goal_stack is already restored. */
  658.     match_attr1(&((*u)->left),v,rb);
  659.   }
  660. }
  661.  
  662.  
  663. /* Evaluate the corresponding arguments */
  664. /* RESID */ match_attr3(u,v,rb)
  665. ptr_node *u,v;
  666. /* RESID */ ptr_resid_block rb;
  667. {
  668.   long cmp;
  669.   ptr_node temp;
  670.   
  671.   if (v) {
  672.     if (*u==NULL)
  673.       attr_missing=TRUE;
  674.     else {
  675.       cmp=featcmp((*u)->key,v->key);
  676.       if(cmp==0) {
  677.         ptr_psi_term t1,t2;
  678.       /* RESID */ match_attr3(&((*u)->right),v->right,rb);
  679.         t1 = (ptr_psi_term) (*u)->data;
  680.         t2 = (ptr_psi_term) v->data;
  681.       /* RESID */ /* push_goal(match,(*u)->data,v->data,rb); */
  682.         deref2_eval(t1); /* Assumes goal_stack is already restored. */
  683.         deref2_eval(t2); /* PVR 12.03 */
  684.       /* RESID */ match_attr3(&((*u)->left),v->left,rb);
  685.       }
  686.       else if (cmp>0) {
  687.         temp=v->right;
  688.         v->right=NULL;
  689.       /* RESID */ match_attr3(u,temp,rb);
  690.       /* RESID */ match_attr3(&((*u)->left),v,rb);
  691.       v->right=temp;
  692.       }
  693.       else {
  694.       temp=v->left;
  695.       v->left=NULL;
  696.       /* RESID */ match_attr3(&((*u)->right),v,rb);
  697.       /* RESID */ match_attr3(u,temp,rb);
  698.       v->left=temp;
  699.       }
  700.     }
  701.   }
  702. }
  703.  
  704.  
  705.  
  706. /******** MATCH_ATTR(u,v)
  707.   Match the attribute trees of psi_terms U and V.
  708.   If V has an attribute that U doesn't then curry.
  709.   U is the calling term, V is the definition.
  710.   This routine is careful to push nested eval and match goals in
  711.   descending order of feature names.
  712. */
  713. void match_attr(u,v,rb)
  714. ptr_node *u,v;
  715. ptr_resid_block rb;
  716. {
  717.   match_attr1(u,v,rb); /* Match corresponding arguments (third) */
  718.   match_attr2(u,v,rb); /* Evaluate lone arguments (second) */
  719.   match_attr3(u,v,rb); /* Evaluate corresponding arguments (first) */
  720. }
  721.  
  722.  
  723.  
  724.  
  725.  
  726. /******** MATCH_AIM()
  727.   This is very similar to UNIFY_AIM, only matching cannot modify the calling
  728.   psi_term.   The first argument is the calling term (which may not be changed)
  729.   and the second argument is the function definition (which may be changed).
  730.   Residuate the expression if the calling term is more general than the
  731.   function definition.
  732. */
  733. long match_aim()
  734. {
  735.   long success=TRUE;
  736.   ptr_psi_term u,v,tmp;
  737.   REAL r;
  738.   long less,lesseq;
  739.   ptr_resid_block rb;
  740.   ptr_psi_term match_date;
  741.   
  742.   u=(ptr_psi_term )aim->a;
  743.   v=(ptr_psi_term )aim->b;
  744.   deref_ptr(u);
  745.   deref_ptr(v);
  746.   rb=(ptr_resid_block)aim->c;
  747.   restore_resid(rb,&match_date);
  748.   
  749.   if (u!=v) {
  750.     if (success=matches(u->type,v->type,&lesseq)) {
  751.       if (lesseq) {
  752.         if (u->type!=cut || v->type!=cut) { /* Ignore value field for cut! */
  753.           if (v->value) {
  754.             if (u->value) {
  755.               if (overlap_type(v->type,real))
  756.                 success=(*((REAL *)u->value)==(*((REAL *)v->value)));
  757.               else if (overlap_type(v->type,quoted_string))
  758.                 success=(strcmp((char *)u->value,(char *)v->value)==0);
  759.           /* DENYS: BYTEDATA */
  760.               else if (overlap_type(v->type,sys_bytedata)) {
  761.         unsigned long ulen = *((unsigned long *) u->value);
  762.         unsigned long vlen = *((unsigned long *) v->value);
  763.                 success=(ulen==vlen && bcmp((char *)u->value,(char *)v->value,ulen)==0);
  764.           }
  765.             }
  766.             else
  767.               residuate_double(u,v);
  768.           }
  769.         }
  770.       }
  771.       else if (u->value) {
  772.         /* Here we have U <| V but U and V have values which cannot match. */
  773.         success=TRUE;
  774.           
  775.         if (v->value) {
  776.           if (overlap_type(v->type,real))
  777.             success=(*((REAL *)u->value)==(*((REAL *)v->value)));
  778.         }
  779.         else if (overlap_type(u->type,integer)) {
  780.           r= *((REAL *)u->value);
  781.           success=(r==floor(r));
  782.         }
  783.           
  784.         if (success) residuate_double(u,v);
  785.       } 
  786.       else
  787.         residuate_double(u,v);
  788.                   
  789.       if (success) {
  790.         if (FUNC_ARG(u) && FUNC_ARG(v)) { /*  RM: Feb 10 1993  */
  791.           /* residuate2(u,v); 21.9 */
  792.           residuate_double(u,v); /* 21.9 */
  793.           residuate_double(v,u); /* 21.9 */
  794.     }
  795.         else if (FUNC_ARG(v)) {  /*  RM: Feb 10 1993  */
  796.           residuate_double(v,u); /* 21.9 */
  797.         }
  798.         else {
  799.           v->coref=u;
  800.         } /* 21.9 */
  801.       attr_missing=FALSE;
  802.       match_attr(&(u->attr_list),v->attr_list,rb);
  803.       if (attr_missing) {
  804.             if (can_curry)
  805.               curried=TRUE;
  806.             else
  807.               residuate_double(u,v);
  808.           }
  809.         /* } 21.9 */
  810.       }
  811.     }
  812.   }
  813.  
  814.   can_curry=FALSE;
  815.   save_resid(rb,match_date); /* updated resid_block */
  816.   /* This should be a useless statement: */
  817.   resid_aim = NULL;
  818.   
  819.   return success;
  820. }
  821.  
  822.  
  823.  
  824. /******************************************************************************
  825.   The following routines prepare terms for unification, proof or matching.
  826.   They deal with conjunctions, disjunctions, functions and arguments which
  827.   have to be examined before the general proof can continue.
  828. */
  829.  
  830.  
  831.  
  832. /* Forward declarations */
  833. long check_out();
  834. long eval_args();
  835.  
  836.  
  837.  
  838. /******** EVAL_ARGS(n)
  839.   N is an attribute tree, the attributes must be examined, if any reveal
  840.   themselves to need evaluating then return FALSE.
  841. */
  842. long i_eval_args(n)
  843. ptr_node n;
  844. {
  845.   check_func_flag=FALSE;
  846.   return eval_args(n);
  847. }
  848.  
  849.  
  850.  
  851. long eval_args(n)
  852. ptr_node n;
  853. {
  854.   long flag=TRUE;
  855.   
  856.   if (n) {
  857.     flag = eval_args(n->right);
  858.     flag = check_out(n->data) && flag;
  859.     flag = eval_args(n->left) && flag;
  860.   }
  861.   
  862.   return flag;
  863. }
  864.  
  865.  
  866.  
  867. /******** CHECK_DISJ(t)
  868.   Deal with disjunctions.
  869. */
  870. void check_disj(t)
  871. ptr_psi_term t;
  872. {
  873.   Traceline("push disjunction goal %P\n",t);
  874.   if (t->value)
  875.     push_goal(disj,t,t,(GENERIC)TRUE); /* 18.2 PVR */
  876.   else
  877.     push_goal(fail,NULL,NULL,NULL);
  878. }
  879.  
  880.  
  881.  
  882. /******** CHECK_FUNC(t)
  883.   Deal with an unevaluated function: push an 'eval' goal for it, which will
  884.   cause it to be evaluated.
  885. */
  886. void check_func(t)
  887. ptr_psi_term t;
  888. {
  889.   ptr_psi_term result,t1,copy;
  890.  
  891.   /* Check for embedded definitions
  892.      RM: Dec 16 1992  Re-instated this check then disabled it again
  893.      if (resid_aim) {
  894.      Errorline("embedded functions appeared in %P.\n",resid_aim->a);
  895.      fail_all();
  896.      }
  897.      else */ {
  898.     
  899.     Traceline("setting up function call %P\n",t);
  900.     /* Create a psi-term to put the result */
  901.     result = stack_psi_term(0);
  902.     
  903.     /* Make a partial copy of the calling term */
  904.     copy=stack_copy_psi_term(*t);
  905.     copy->status &= ~RMASK;
  906.   
  907.     /* Bind the calling term to the result */
  908.     /* push_ptr_value(psi_term_ptr,&(t->coref)); */
  909.     push_psi_ptr_value(t,&(t->coref));
  910.     t->coref=result;
  911.  
  912.     /* Evaluate the copy of the calling term */
  913.     push_goal(eval,copy,result,t->type->rule);
  914.   
  915.     /* Avoid evaluation for built-in functions with unevaluated arguments */
  916.     /* (cond and such_that) */
  917.     check_func_flag=TRUE;
  918.     if (t->type==iff) {
  919.       get_one_arg(t->attr_list,&t1);
  920.       if (t1) {
  921.     /* mark_eval(t1); 24.8 */
  922.         check_out(t1);
  923.       }
  924.     }
  925.     else if(t->type==disjunction) {
  926.     }
  927.     else if (t->type!=such_that) {
  928.       if (t->type->evaluate_args)
  929.         eval_args(t->attr_list);
  930.       /* else mark_quote_tree(t->attr_list); 24.8 25.8 */
  931.     }
  932.   }
  933. }
  934.  
  935.  
  936.  
  937.  
  938. /******** CHECK_TYPE(t)
  939.   Here we deal with a type which may need checking.
  940.   This routine will have to be modified to deal with the infinite loops
  941.   currently caused by definitions such as:
  942.  
  943.   :: H:husband(spouse => wife(spouse => H)).
  944.   :: W:wife(spouse => husband(spouse => W)).
  945.  
  946. */
  947. long check_type(t)
  948. ptr_psi_term t;
  949. {
  950.   long flag=FALSE;
  951.  
  952.   push2_ptr_value(int_ptr,&(t->status),(t->status & SMASK));
  953.   /* push_ptr_value(int_ptr,&(t->status)); */
  954.   
  955.   if (t->type->properties) {
  956.     if (t->attr_list || t->type->always_check) {
  957.       /* Check all constraints here: */
  958.       fetch_def(t, TRUE); /* PVR 18.2.94 */
  959.       /* t->status=(2 & SMASK) | (t->status & RMASK); PVR 18.2.94 */
  960.  
  961.       eval_args(t->attr_list);
  962.       flag=FALSE;
  963.     }
  964.     else {
  965.       /* definition pending on more information */
  966.       t->status= (2 & SMASK) | (t->status & RMASK);
  967.       flag=TRUE;
  968.     }
  969.   }
  970.   else {
  971.     
  972.     /*  RM: Dec 15 1992  I don't know what this is for
  973.     if (!ovverlap_type(t->type,alist))
  974.     t->status= (4 & SMASK) | (t->status & RMASK);
  975.     */
  976.     
  977.     flag=eval_args(t->attr_list);
  978.   }
  979.   
  980.   return flag;
  981. }
  982.  
  983.  
  984.   
  985. /******** CHECK_OUT(t)
  986.   This routine checks out psi_term T.
  987.   It deals with the following cases:
  988.   - T is a conjunction,
  989.   - T is a type which has properties to check.
  990.   - The same for T's arguments.
  991.   If any of the above holds then proof has to be suspended until the
  992.   case has been dealt with.  This is done by pushing goals on the goal_stack
  993.   to handle the case.  If all is dealt with then CHECK_OUT returns TRUE.
  994.   I.e., CHECK_OUT returns TRUE iff it has not pushed any goals on the stack.
  995.  
  996.   Evaluation is *not* done here, but as a part of dereferencing when a value
  997.   is needed.
  998.  
  999.   Of all the routines related to check_out, only i_check_out, check_func,
  1000.   i_eval_args, and the dereference routines are called from outside of this
  1001.   file (lefun.c).
  1002.   - i_check_out(t) checks out everything except functions.  When a function
  1003.     is encountered, check_out returns immediately without looking inside it.
  1004.   - f_check_out(t) checks out functions too.
  1005.   - i_eval_args(n) checks out all arguments, except functions.
  1006.   - check_func(t) checks out a function & all its arguments (including all
  1007.     nested functions.  This is done as part of dereferencing, which is part
  1008.     of unification, matching, built-ins, and user-defined routines.
  1009. */
  1010. long i_check_out(t)
  1011. ptr_psi_term t;
  1012. {
  1013.   check_func_flag=FALSE;
  1014.   return check_out(t);
  1015. }
  1016.  
  1017. long f_check_out(t)
  1018. ptr_psi_term t;
  1019. {
  1020.   check_func_flag=TRUE;
  1021.   return check_out(t);
  1022. }
  1023.  
  1024. long check_out(t)
  1025. ptr_psi_term t;
  1026. {
  1027.   long flag=FALSE;
  1028.   
  1029.   deref_ptr(t);
  1030.  
  1031.   /* Traceline("PVR: entering check_out with status %d and term %P\n",
  1032.             t->status,t); for brunobug.lf PVR 14.2.94 */
  1033.  
  1034.   if (t->status || (GENERIC)t>=heap_pointer) /*  RM: Feb  8 1993  */
  1035.     flag=TRUE;
  1036.   else {
  1037.     t->status |= RMASK;
  1038.  
  1039.     switch(t->type->type) { /*  RM: Feb  8 1993  */
  1040.       
  1041.     case function:
  1042.       if (check_func_flag) {
  1043.     check_func(t);
  1044.     flag=TRUE;
  1045.       }
  1046.       else {
  1047.     /* Function evaluation handled during matching and unification */
  1048.     flag=TRUE;
  1049.       }
  1050.       break;
  1051.  
  1052.     case type:
  1053.       flag=check_type(t);
  1054.       break;
  1055.  
  1056.     case global: /*  RM: Feb  8 1993  */
  1057.       eval_global_var(t);
  1058.       check_out(t);
  1059.       flag=FALSE;
  1060.       break;
  1061.       
  1062.     default:
  1063.       flag=eval_args(t->attr_list);
  1064.     }
  1065.     t->status &= ~RMASK;
  1066.   }
  1067.   return flag;    
  1068. }
  1069.  
  1070.  
  1071.  
  1072. /********************************************************************/
  1073. /*                                                                  */
  1074. /* New dereference routines for Wild_Life                           */
  1075. /* These routines handle evaluation-by-need.  Check_out is changed  */
  1076. /* to no longer call check_func, which is done in the new routines. */
  1077. /* Functions inside of psi-terms are only evaluated if needed.  It  */
  1078. /* is assumed that 'needed' is true when they are derefed.          */
  1079. /*                                                                  */
  1080. /* There are three new dereference routines:                        */
  1081. /*    deref_eval(P)                                                 */
  1082. /*       If the psi-term P is a function, call check_func to        */
  1083. /*       push eval goals so that the function will be evaluated.    */
  1084. /*       Then return TRUE so that the caller can itself return.     */
  1085. /*       This only looks at the top level.                          */
  1086. /*    deref_rec(P)                                                  */
  1087. /*       If the psi-term P recursively contains any functions, then */
  1088. /*       push eval goals to evaluate all of them.  Set a global     */
  1089. /*       variable deref_flag if this is the case.                   */
  1090. /*    deref_args(P,S)                                               */
  1091. /*       Same as above, except does not look at the top level or at */
  1092. /*       the arguments named in the set S.                          */
  1093. /*       This is needed to guarantee evaluation of all arguments of */
  1094. /*       a built-in, even those not used by the built-in.           */
  1095. /*                                                                  */
  1096. /* The original dereference macro is renamed to:                    */
  1097. /*    deref_ptr(P) = while (P->coref) P=P->coref                    */
  1098. /* There are three new macros:                                      */
  1099. /*    deref(P)        = deref_ptr(P);                               */
  1100. /*                      if (deref_eval(P)) then return TRUE         */
  1101. /*    deref_rec(P)    = deref_ptr(P);                               */
  1102. /*                      if (deref_rec_eval(P)) then return TRUE     */
  1103. /*    deref_args(P,S) = deref_ptr(P);                               */
  1104. /*                      if (deref_args_eval(P,S)) then return TRUE  */
  1105. /*                                                                  */
  1106. /********************************************************************/
  1107.  
  1108. static long deref_flag;
  1109. void deref_rec_body();
  1110. void deref_rec_args();
  1111. void deref_rec_args_exc();
  1112.  
  1113. /* Ensure evaluation of top of psi-term */
  1114. long deref_eval(t)
  1115. ptr_psi_term t;
  1116. {
  1117.   ptr_goal save=goal_stack;
  1118.  
  1119.   deref_flag=FALSE;
  1120.   goal_stack=aim;
  1121.  
  1122.   if (t->status==0) {
  1123.     if(t->type->type==function) {
  1124.       check_func(t);    /* Push eval goals to evaluate the function. */
  1125.       deref_flag=TRUE;  /* TRUE so that caller will return to main_prove. */
  1126.     }
  1127.     else
  1128.       if(t->type->type==global) { /*  RM: Feb 10 1993  */
  1129.     eval_global_var(t);
  1130.     deref_ptr(t);/*  RM: Jun 25 1993  */
  1131.     deref_flag=deref_eval(t);
  1132.       }
  1133.       else {
  1134.     if (t->status!=2) {
  1135.       if((GENERIC)t<heap_pointer)
  1136.         push_ptr_value(int_ptr,&(t->status)); /*  RM: Jul 15 1993  */
  1137.       t->status=4;
  1138.       deref_flag=FALSE;
  1139.     }
  1140.       }
  1141.   }
  1142.   else
  1143.     deref_flag=FALSE;
  1144.   
  1145.   if (!deref_flag) goal_stack=save;
  1146.   return (deref_flag);
  1147. }
  1148.  
  1149. /* Ensure evaluation of *all* of psi-term */
  1150. long deref_rec_eval(t)
  1151. ptr_psi_term t;
  1152. {
  1153.   ptr_goal save=goal_stack;
  1154.  
  1155.   deref_flag=FALSE;
  1156.   goal_stack=aim;
  1157.   deref_rec_body(t);
  1158.   if (!deref_flag) goal_stack=save;
  1159.   return (deref_flag);
  1160. }
  1161.  
  1162. void deref_rec_body(t)
  1163. ptr_psi_term t;
  1164. {
  1165.   if (t->status==0) {
  1166.     if (t->type->type==function) {
  1167.       check_func(t);
  1168.       deref_flag=TRUE;
  1169.     }
  1170.     else
  1171.       if(t->type->type==global) { /*  RM: Feb 10 1993  */
  1172.     eval_global_var(t);
  1173.     deref_ptr(t);/*  RM: Jun 25 1993  */
  1174.     deref_rec_body(t);
  1175.       }
  1176.       else {
  1177.     /* if (t->status!=2) Tried adding this -- PVR 9.2.94 */
  1178.       if((GENERIC)t<heap_pointer)
  1179.         push_ptr_value(int_ptr,&(t->status));/*  RM: Jul 15 1993  */
  1180.       t->status=4;
  1181.       deref_rec_args(t->attr_list);
  1182.       }
  1183.   }
  1184. }
  1185.  
  1186. void deref_rec_args(n)
  1187. ptr_node n;
  1188. {
  1189.   ptr_psi_term t1;
  1190.   
  1191.   if (n) {
  1192.     deref_rec_args(n->right);
  1193.     t1 = (ptr_psi_term) (n->data);
  1194.     deref_ptr(t1);
  1195.     deref_rec_body(t1);
  1196.     deref_rec_args(n->left);
  1197.   }
  1198. }
  1199.  
  1200. /* Same as deref_rec_eval, but doesn't look at either the top level or */
  1201. /* the arguments in the set. */
  1202. long deref_args_eval(t,set)
  1203. ptr_psi_term t;
  1204. long set;
  1205. {
  1206.   ptr_goal save = goal_stack;
  1207.   ptr_goal top = aim;
  1208.  
  1209.   deref_flag = FALSE;
  1210.   goal_stack = top;
  1211.   deref_rec_args_exc(t->attr_list,set);
  1212.   if (!deref_flag) goal_stack = save;
  1213.   return (deref_flag);
  1214. }
  1215.  
  1216. /* Return TRUE iff string (considered as number) is in the set */
  1217. /* This routine only recognizes the strings "1", "2", "3",     */
  1218. /* represented as numbers 1, 2, 4.                             */
  1219. long in_set(str,set)
  1220. char *str;
  1221. long set;
  1222. {
  1223.   if (set&1 && !featcmp(str,"1")) return TRUE;
  1224.   if (set&2 && !featcmp(str,"2")) return TRUE;
  1225.   if (set&4 && !featcmp(str,"3")) return TRUE;
  1226.   if (set&8 && !featcmp(str,"4")) return TRUE;
  1227.   return FALSE;
  1228. }
  1229.  
  1230. void deref_rec_args_exc(n,set)
  1231. ptr_node n;
  1232. long set;
  1233. {
  1234.   ptr_psi_term t;
  1235.   
  1236.   if (n) {
  1237.     deref_rec_args_exc(n->right,set);
  1238.     if (!in_set(n->key,set)) {
  1239.       t = (ptr_psi_term) (n->data);
  1240.       deref_ptr(t);
  1241.       deref_rec_body(t);
  1242.     }
  1243.     deref_rec_args_exc(n->left,set);
  1244.   }
  1245. }
  1246.  
  1247.  
  1248. /* These two needed only for match_aim and match_attr: */
  1249.  
  1250. /* Same as deref_eval, but assumes goal_stack already restored. */
  1251. void deref2_eval(t)
  1252. ptr_psi_term t;
  1253. {
  1254.   deref_ptr(t);
  1255.   if (t->status==0) {
  1256.     if (t->type->type==function) {
  1257.       check_func(t);
  1258.     }
  1259.     else 
  1260.       if(t->type->type==global) { /*  RM: Feb 10 1993  */
  1261.           eval_global_var(t);
  1262.     deref_ptr(t);/*  RM: Jun 25 1993  */
  1263.     deref2_eval(t);
  1264.       }
  1265.       else {
  1266.     t->status=4;
  1267.       }
  1268.   }
  1269. }
  1270.  
  1271. /* Same as deref_rec_eval, but assumes goal_stack already restored. */
  1272. void deref2_rec_eval(t)
  1273. ptr_psi_term t;
  1274. {
  1275.   deref_ptr(t);
  1276.   deref_rec_body(t);
  1277. }
  1278.  
  1279. /********************************************************************/
  1280.  
  1281. /* Saving & restoring residuation information */
  1282.  
  1283. void save_resid(rb,match_date)
  1284. ptr_resid_block rb;
  1285. ptr_psi_term match_date;
  1286. {
  1287.    if (rb) {
  1288.       rb->cc_cr = (can_curry<<1) + curried; /* 11.9 */
  1289.       rb->ra = resid_aim;
  1290.       rb->rv = resid_vars;
  1291.       /* rb->cr = curried; 11.9 */
  1292.       /* rb->cc = can_curry; 11.9 */
  1293.       rb->md = match_date;
  1294.    }
  1295. }
  1296.  
  1297. void restore_resid(rb,match_date)
  1298. ptr_resid_block rb;
  1299. ptr_psi_term *match_date;
  1300. {
  1301.    if (rb) {
  1302.       can_curry = (rb->cc_cr&2)?TRUE:FALSE; /* 11.9 */
  1303.       curried   = (rb->cc_cr&1)?TRUE:FALSE; /* 11.9 */
  1304.       resid_aim = rb->ra;
  1305.       resid_vars = rb->rv;
  1306.       /* curried = rb->cr; 11.9 */
  1307.       /* can_curry = rb->cc; 11.9 */
  1308.       *match_date = rb->md;
  1309.    }
  1310. }
  1311.  
  1312.  
  1313.  
  1314. /******** EVAL_GLOBAL_VAR(t)
  1315.   Dereference a global variable.
  1316.   */
  1317.  
  1318. void eval_global_var(t)     /*  RM: Feb 10 1993  */
  1319.  
  1320.      ptr_psi_term t;
  1321. {
  1322.   deref_ptr(t);
  1323.  
  1324.   /* Global variable (not persistent) */
  1325.  
  1326.   Traceline("dereferencing variable %P\n",t);
  1327.   
  1328.   /* Trails the heap RM: Nov 10 1993  */
  1329.   if(!t->type->global_value) {
  1330.  
  1331.     /* Trail the heap !! */
  1332.     {
  1333.       ptr_stack n;
  1334.       n=STACK_ALLOC(stack);
  1335.       n->type=psi_term_ptr;
  1336.       n->a= (GENERIC) &(t->type->global_value);
  1337.       n->b= NULL;
  1338.       n->next=undo_stack;
  1339.       undo_stack=n;
  1340.     }
  1341.  
  1342.  
  1343.     clear_copy();
  1344.     t->type->global_value=eval_copy(t->type->init_value,STACK);
  1345.  
  1346.   }
  1347.  
  1348.   /* var_occurred=TRUE; RM: Feb  4 1994  */
  1349.  
  1350.   if(t->type->type==global && t!=t->type->global_value) {
  1351.     /*Traceline("dereferencing variable %P\n",t);*/
  1352.     push_psi_ptr_value(t,&(t->coref));
  1353.     t->coref=t->type->global_value;
  1354.   }
  1355. }
  1356.  
  1357.  
  1358.  
  1359.  
  1360. /******** INIT_GLOBAL_VARS()
  1361.   Initialize all non-persistent global variables.
  1362.   */
  1363.  
  1364. void init_global_vars()  /*  RM: Feb 15 1993  */
  1365.  
  1366. {
  1367.   ptr_definition def;
  1368.  
  1369.   /* printf("initializing global vars...\n"); */
  1370.   
  1371.   /*
  1372.     for(def=first_definition;def;def=def->next) {
  1373.     if(def->type==global && ((GENERIC)def->global_value<heap_pointer)) {
  1374.     clear_copy();
  1375.     def->global_value=eval_copy(def->init_value,STACK); 
  1376.     }
  1377.     }
  1378.     */
  1379.  
  1380.   for(def=first_definition;def;def=def->next)
  1381.     if((GENERIC)(def->global_value)<(GENERIC)heap_pointer)
  1382.       def->global_value=NULL;
  1383. }
  1384.  
  1385. /********************************************************************/
  1386.